Branch data Line data Source code
1 : : /* Backend function setup
2 : : Copyright (C) 2002-2024 Free Software Foundation, Inc.
3 : : Contributed by Paul Brook
4 : :
5 : : This file is part of GCC.
6 : :
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
10 : : version.
11 : :
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
15 : : for more details.
16 : :
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/>. */
20 : :
21 : : /* trans-decl.cc -- Handling of backend function and variable decls, etc */
22 : :
23 : : #include "config.h"
24 : : #include "system.h"
25 : : #include "coretypes.h"
26 : : #include "target.h"
27 : : #include "function.h"
28 : : #include "tree.h"
29 : : #include "gfortran.h"
30 : : #include "gimple-expr.h" /* For create_tmp_var_raw. */
31 : : #include "trans.h"
32 : : #include "stringpool.h"
33 : : #include "cgraph.h"
34 : : #include "fold-const.h"
35 : : #include "stor-layout.h"
36 : : #include "varasm.h"
37 : : #include "attribs.h"
38 : : #include "dumpfile.h"
39 : : #include "toplev.h" /* For announce_function. */
40 : : #include "debug.h"
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"
48 : : #include "gimplify.h"
49 : : #include "omp-general.h"
50 : : #include "attr-fnspec.h"
51 : : #include "tree-iterator.h"
52 : : #include "dependency.h"
53 : :
54 : : #define MAX_LABEL_VALUE 99999
55 : :
56 : :
57 : : /* Holds the result of the function if no result variable specified. */
58 : :
59 : : static GTY(()) tree current_fake_result_decl;
60 : : static GTY(()) tree parent_fake_result_decl;
61 : :
62 : :
63 : : /* Holds the variable DECLs for the current function. */
64 : :
65 : : static GTY(()) tree saved_function_decls;
66 : : static GTY(()) tree saved_parent_function_decls;
67 : :
68 : : /* Holds the variable DECLs that are locals. */
69 : :
70 : : static GTY(()) tree saved_local_decls;
71 : :
72 : : /* The namespace of the module we're currently generating. Only used while
73 : : outputting decls for module variables. Do not rely on this being set. */
74 : :
75 : : static gfc_namespace *module_namespace;
76 : :
77 : : /* The currently processed procedure symbol. */
78 : : static gfc_symbol* current_procedure_symbol = NULL;
79 : :
80 : : /* The currently processed module. */
81 : : static struct module_htab_entry *cur_module;
82 : :
83 : : /* With -fcoarray=lib: For generating the registering call
84 : : of static coarrays. */
85 : : static bool has_coarray_vars;
86 : : static stmtblock_t caf_init_block;
87 : :
88 : :
89 : : /* List of static constructor functions. */
90 : :
91 : : tree gfc_static_ctors;
92 : :
93 : :
94 : : /* Whether we've seen a symbol from an IEEE module in the namespace. */
95 : : static int seen_ieee_symbol;
96 : :
97 : : /* Function declarations for builtin library functions. */
98 : :
99 : : tree gfor_fndecl_pause_numeric;
100 : : tree gfor_fndecl_pause_string;
101 : : tree gfor_fndecl_stop_numeric;
102 : : tree gfor_fndecl_stop_string;
103 : : tree gfor_fndecl_error_stop_numeric;
104 : : tree gfor_fndecl_error_stop_string;
105 : : tree gfor_fndecl_runtime_error;
106 : : tree gfor_fndecl_runtime_error_at;
107 : : tree gfor_fndecl_runtime_warning_at;
108 : : tree gfor_fndecl_os_error_at;
109 : : tree gfor_fndecl_generate_error;
110 : : tree gfor_fndecl_set_args;
111 : : tree gfor_fndecl_set_fpe;
112 : : tree gfor_fndecl_set_options;
113 : : tree gfor_fndecl_set_convert;
114 : : tree gfor_fndecl_set_record_marker;
115 : : tree gfor_fndecl_set_max_subrecord_length;
116 : : tree gfor_fndecl_ctime;
117 : : tree gfor_fndecl_fdate;
118 : : tree gfor_fndecl_ttynam;
119 : : tree gfor_fndecl_in_pack;
120 : : tree gfor_fndecl_in_unpack;
121 : : tree gfor_fndecl_in_pack_class;
122 : : tree gfor_fndecl_in_unpack_class;
123 : : tree gfor_fndecl_associated;
124 : : tree gfor_fndecl_system_clock4;
125 : : tree gfor_fndecl_system_clock8;
126 : : tree gfor_fndecl_ieee_procedure_entry;
127 : : tree gfor_fndecl_ieee_procedure_exit;
128 : :
129 : : /* Coarray run-time library function decls. */
130 : : tree gfor_fndecl_caf_init;
131 : : tree gfor_fndecl_caf_finalize;
132 : : tree gfor_fndecl_caf_this_image;
133 : : tree gfor_fndecl_caf_num_images;
134 : : tree gfor_fndecl_caf_register;
135 : : tree gfor_fndecl_caf_deregister;
136 : : tree gfor_fndecl_caf_get;
137 : : tree gfor_fndecl_caf_send;
138 : : tree gfor_fndecl_caf_sendget;
139 : : tree gfor_fndecl_caf_get_by_ref;
140 : : tree gfor_fndecl_caf_send_by_ref;
141 : : tree gfor_fndecl_caf_sendget_by_ref;
142 : : tree gfor_fndecl_caf_sync_all;
143 : : tree gfor_fndecl_caf_sync_memory;
144 : : tree gfor_fndecl_caf_sync_images;
145 : : tree gfor_fndecl_caf_stop_str;
146 : : tree gfor_fndecl_caf_stop_numeric;
147 : : tree gfor_fndecl_caf_error_stop;
148 : : tree gfor_fndecl_caf_error_stop_str;
149 : : tree gfor_fndecl_caf_atomic_def;
150 : : tree gfor_fndecl_caf_atomic_ref;
151 : : tree gfor_fndecl_caf_atomic_cas;
152 : : tree gfor_fndecl_caf_atomic_op;
153 : : tree gfor_fndecl_caf_lock;
154 : : tree gfor_fndecl_caf_unlock;
155 : : tree gfor_fndecl_caf_event_post;
156 : : tree gfor_fndecl_caf_event_wait;
157 : : tree gfor_fndecl_caf_event_query;
158 : : tree gfor_fndecl_caf_fail_image;
159 : : tree gfor_fndecl_caf_failed_images;
160 : : tree gfor_fndecl_caf_image_status;
161 : : tree gfor_fndecl_caf_stopped_images;
162 : : tree gfor_fndecl_caf_form_team;
163 : : tree gfor_fndecl_caf_change_team;
164 : : tree gfor_fndecl_caf_end_team;
165 : : tree gfor_fndecl_caf_sync_team;
166 : : tree gfor_fndecl_caf_get_team;
167 : : tree gfor_fndecl_caf_team_number;
168 : : tree gfor_fndecl_co_broadcast;
169 : : tree gfor_fndecl_co_max;
170 : : tree gfor_fndecl_co_min;
171 : : tree gfor_fndecl_co_reduce;
172 : : tree gfor_fndecl_co_sum;
173 : : tree gfor_fndecl_caf_is_present;
174 : : tree gfor_fndecl_caf_random_init;
175 : :
176 : :
177 : : /* Math functions. Many other math functions are handled in
178 : : trans-intrinsic.cc. */
179 : :
180 : : gfc_powdecl_list gfor_fndecl_math_powi[4][3];
181 : : tree gfor_fndecl_math_ishftc4;
182 : : tree gfor_fndecl_math_ishftc8;
183 : : tree gfor_fndecl_math_ishftc16;
184 : :
185 : :
186 : : /* String functions. */
187 : :
188 : : tree gfor_fndecl_compare_string;
189 : : tree gfor_fndecl_concat_string;
190 : : tree gfor_fndecl_string_len_trim;
191 : : tree gfor_fndecl_string_index;
192 : : tree gfor_fndecl_string_scan;
193 : : tree gfor_fndecl_string_verify;
194 : : tree gfor_fndecl_string_trim;
195 : : tree gfor_fndecl_string_minmax;
196 : : tree gfor_fndecl_adjustl;
197 : : tree gfor_fndecl_adjustr;
198 : : tree gfor_fndecl_select_string;
199 : : tree gfor_fndecl_compare_string_char4;
200 : : tree gfor_fndecl_concat_string_char4;
201 : : tree gfor_fndecl_string_len_trim_char4;
202 : : tree gfor_fndecl_string_index_char4;
203 : : tree gfor_fndecl_string_scan_char4;
204 : : tree gfor_fndecl_string_verify_char4;
205 : : tree gfor_fndecl_string_trim_char4;
206 : : tree gfor_fndecl_string_minmax_char4;
207 : : tree gfor_fndecl_adjustl_char4;
208 : : tree gfor_fndecl_adjustr_char4;
209 : : tree gfor_fndecl_select_string_char4;
210 : :
211 : :
212 : : /* Conversion between character kinds. */
213 : : tree gfor_fndecl_convert_char1_to_char4;
214 : : tree gfor_fndecl_convert_char4_to_char1;
215 : :
216 : :
217 : : /* Other misc. runtime library functions. */
218 : : tree gfor_fndecl_iargc;
219 : : tree gfor_fndecl_kill;
220 : : tree gfor_fndecl_kill_sub;
221 : : tree gfor_fndecl_is_contiguous0;
222 : :
223 : :
224 : : /* Intrinsic functions implemented in Fortran. */
225 : : tree gfor_fndecl_sc_kind;
226 : : tree gfor_fndecl_si_kind;
227 : : tree gfor_fndecl_sl_kind;
228 : : tree gfor_fndecl_sr_kind;
229 : :
230 : : /* BLAS gemm functions. */
231 : : tree gfor_fndecl_sgemm;
232 : : tree gfor_fndecl_dgemm;
233 : : tree gfor_fndecl_cgemm;
234 : : tree gfor_fndecl_zgemm;
235 : :
236 : : /* RANDOM_INIT function. */
237 : : tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */
238 : :
239 : : static void
240 : 4467 : gfc_add_decl_to_parent_function (tree decl)
241 : : {
242 : 4467 : gcc_assert (decl);
243 : 4467 : DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
244 : 4467 : DECL_NONLOCAL (decl) = 1;
245 : 4467 : DECL_CHAIN (decl) = saved_parent_function_decls;
246 : 4467 : saved_parent_function_decls = decl;
247 : 4467 : }
248 : :
249 : : void
250 : 255866 : gfc_add_decl_to_function (tree decl)
251 : : {
252 : 255866 : gcc_assert (decl);
253 : 255866 : TREE_USED (decl) = 1;
254 : 255866 : DECL_CONTEXT (decl) = current_function_decl;
255 : 255866 : DECL_CHAIN (decl) = saved_function_decls;
256 : 255866 : saved_function_decls = decl;
257 : 255866 : }
258 : :
259 : : static void
260 : 12065 : add_decl_as_local (tree decl)
261 : : {
262 : 12065 : gcc_assert (decl);
263 : 12065 : TREE_USED (decl) = 1;
264 : 12065 : DECL_CONTEXT (decl) = current_function_decl;
265 : 12065 : DECL_CHAIN (decl) = saved_local_decls;
266 : 12065 : saved_local_decls = decl;
267 : 12065 : }
268 : :
269 : :
270 : : /* Build a backend label declaration. Set TREE_USED for named labels.
271 : : The context of the label is always the current_function_decl. All
272 : : labels are marked artificial. */
273 : :
274 : : tree
275 : 509812 : gfc_build_label_decl (tree label_id)
276 : : {
277 : : /* 2^32 temporaries should be enough. */
278 : 509812 : static unsigned int tmp_num = 1;
279 : 509812 : tree label_decl;
280 : 509812 : char *label_name;
281 : :
282 : 509812 : if (label_id == NULL_TREE)
283 : : {
284 : : /* Build an internal label name. */
285 : 506315 : ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
286 : 506315 : label_id = get_identifier (label_name);
287 : : }
288 : : else
289 : 509812 : label_name = NULL;
290 : :
291 : : /* Build the LABEL_DECL node. Labels have no type. */
292 : 509812 : label_decl = build_decl (input_location,
293 : : LABEL_DECL, label_id, void_type_node);
294 : 509812 : DECL_CONTEXT (label_decl) = current_function_decl;
295 : 509812 : SET_DECL_MODE (label_decl, VOIDmode);
296 : :
297 : : /* We always define the label as used, even if the original source
298 : : file never references the label. We don't want all kinds of
299 : : spurious warnings for old-style Fortran code with too many
300 : : labels. */
301 : 509812 : TREE_USED (label_decl) = 1;
302 : :
303 : 509812 : DECL_ARTIFICIAL (label_decl) = 1;
304 : 509812 : return label_decl;
305 : : }
306 : :
307 : :
308 : : /* Set the backend source location of a decl. */
309 : :
310 : : void
311 : 156196 : gfc_set_decl_location (tree decl, locus * loc)
312 : : {
313 : 156196 : DECL_SOURCE_LOCATION (decl) = gfc_get_location (loc);
314 : 156196 : }
315 : :
316 : :
317 : : /* Return the backend label declaration for a given label structure,
318 : : or create it if it doesn't exist yet. */
319 : :
320 : : tree
321 : 5818 : gfc_get_label_decl (gfc_st_label * lp)
322 : : {
323 : 5818 : if (lp->backend_decl)
324 : : return lp->backend_decl;
325 : : else
326 : : {
327 : 3497 : char label_name[GFC_MAX_SYMBOL_LEN + 1];
328 : 3497 : tree label_decl;
329 : :
330 : : /* Validate the label declaration from the front end. */
331 : 3497 : gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
332 : :
333 : : /* Build a mangled name for the label. */
334 : 3497 : sprintf (label_name, "__label_%.6d", lp->value);
335 : :
336 : : /* Build the LABEL_DECL node. */
337 : 3497 : label_decl = gfc_build_label_decl (get_identifier (label_name));
338 : :
339 : : /* Tell the debugger where the label came from. */
340 : 3497 : if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
341 : 3497 : gfc_set_decl_location (label_decl, &lp->where);
342 : : else
343 : 0 : DECL_ARTIFICIAL (label_decl) = 1;
344 : :
345 : : /* Store the label in the label list and return the LABEL_DECL. */
346 : 3497 : lp->backend_decl = label_decl;
347 : 3497 : return label_decl;
348 : : }
349 : : }
350 : :
351 : : /* Return the name of an identifier. */
352 : :
353 : : static const char *
354 : 356502 : sym_identifier (gfc_symbol *sym)
355 : : {
356 : 356502 : if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
357 : : return "MAIN__";
358 : : else
359 : 352242 : return sym->name;
360 : : }
361 : :
362 : : /* Convert a gfc_symbol to an identifier of the same name. */
363 : :
364 : : static tree
365 : 356502 : gfc_sym_identifier (gfc_symbol * sym)
366 : : {
367 : 356502 : return get_identifier (sym_identifier (sym));
368 : : }
369 : :
370 : : /* Construct mangled name from symbol name. */
371 : :
372 : : static const char *
373 : 17552 : mangled_identifier (gfc_symbol *sym)
374 : : {
375 : 17552 : gfc_symbol *proc = sym->ns->proc_name;
376 : 17552 : static char name[3*GFC_MAX_MANGLED_SYMBOL_LEN + 14];
377 : : /* Prevent the mangling of identifiers that have an assigned
378 : : binding label (mainly those that are bind(c)). */
379 : :
380 : 17552 : if (sym->attr.is_bind_c == 1 && sym->binding_label)
381 : : return sym->binding_label;
382 : :
383 : 17445 : if (!sym->fn_result_spec
384 : 56 : || (sym->module && !(proc && proc->attr.flavor == FL_PROCEDURE)))
385 : : {
386 : 17397 : if (sym->module == NULL)
387 : 0 : return sym_identifier (sym);
388 : : else
389 : 17397 : snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
390 : : }
391 : : else
392 : : {
393 : : /* This is an entity that is actually local to a module procedure
394 : : that appears in the result specification expression. Since
395 : : sym->module will be a zero length string, we use ns->proc_name
396 : : to provide the module name instead. */
397 : 48 : if (proc && proc->module)
398 : 48 : snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s",
399 : : proc->module, proc->name, sym->name);
400 : : else
401 : 0 : snprintf (name, sizeof name, "__%s_PROC_%s",
402 : : proc->name, sym->name);
403 : : }
404 : :
405 : : return name;
406 : : }
407 : :
408 : : /* Get mangled identifier, adding the symbol to the global table if
409 : : it is not yet already there. */
410 : :
411 : : static tree
412 : 17403 : gfc_sym_mangled_identifier (gfc_symbol * sym)
413 : : {
414 : 17403 : tree result;
415 : 17403 : gfc_gsymbol *gsym;
416 : 17403 : const char *name;
417 : :
418 : 17403 : name = mangled_identifier (sym);
419 : 17403 : result = get_identifier (name);
420 : :
421 : 17403 : gsym = gfc_find_gsymbol (gfc_gsym_root, name);
422 : 17403 : if (gsym == NULL)
423 : : {
424 : 17253 : gsym = gfc_get_gsymbol (name, false);
425 : 17253 : gsym->ns = sym->ns;
426 : 17253 : gsym->sym_name = sym->name;
427 : : }
428 : :
429 : 17403 : return result;
430 : : }
431 : :
432 : : /* Construct mangled function name from symbol name. */
433 : :
434 : : static tree
435 : 73958 : gfc_sym_mangled_function_id (gfc_symbol * sym)
436 : : {
437 : 73958 : int has_underscore;
438 : 73958 : char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
439 : :
440 : : /* It may be possible to simply use the binding label if it's
441 : : provided, and remove the other checks. Then we could use it
442 : : for other things if we wished. */
443 : 73958 : if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
444 : 3300 : sym->binding_label)
445 : : /* use the binding label rather than the mangled name */
446 : 3290 : return get_identifier (sym->binding_label);
447 : :
448 : 70668 : if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
449 : 23514 : || (sym->module != NULL && (sym->attr.external
450 : 22592 : || sym->attr.if_source == IFSRC_IFBODY)))
451 : 48076 : && !sym->attr.module_procedure)
452 : : {
453 : : /* Main program is mangled into MAIN__. */
454 : 47785 : if (sym->attr.is_main_program)
455 : 24870 : return get_identifier ("MAIN__");
456 : :
457 : : /* Intrinsic procedures are never mangled. */
458 : 22915 : if (sym->attr.proc == PROC_INTRINSIC)
459 : 8794 : return get_identifier (sym->name);
460 : :
461 : 14121 : if (flag_underscoring)
462 : : {
463 : 13306 : has_underscore = strchr (sym->name, '_') != 0;
464 : 13306 : if (flag_second_underscore && has_underscore)
465 : 246 : snprintf (name, sizeof name, "%s__", sym->name);
466 : : else
467 : 13060 : snprintf (name, sizeof name, "%s_", sym->name);
468 : 13306 : return get_identifier (name);
469 : : }
470 : : else
471 : 815 : return get_identifier (sym->name);
472 : : }
473 : : else
474 : : {
475 : 22883 : snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
476 : 22883 : return get_identifier (name);
477 : : }
478 : : }
479 : :
480 : :
481 : : void
482 : 93673 : gfc_set_decl_assembler_name (tree decl, tree name)
483 : : {
484 : 93673 : tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
485 : 93673 : SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
486 : 93673 : }
487 : :
488 : :
489 : : /* Returns true if a variable of specified size should go on the stack. */
490 : :
491 : : bool
492 : 155253 : gfc_can_put_var_on_stack (tree size)
493 : : {
494 : 155253 : unsigned HOST_WIDE_INT low;
495 : :
496 : 155253 : if (!INTEGER_CST_P (size))
497 : : return 0;
498 : :
499 : 148429 : if (flag_max_stack_var_size < 0)
500 : : return 1;
501 : :
502 : 121712 : if (!tree_fits_uhwi_p (size))
503 : : return 0;
504 : :
505 : 121712 : low = TREE_INT_CST_LOW (size);
506 : 121712 : if (low > (unsigned HOST_WIDE_INT) flag_max_stack_var_size)
507 : 211 : return 0;
508 : :
509 : : /* TODO: Set a per-function stack size limit. */
510 : :
511 : : return 1;
512 : : }
513 : :
514 : :
515 : : /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
516 : : an expression involving its corresponding pointer. There are
517 : : 2 cases; one for variable size arrays, and one for everything else,
518 : : because variable-sized arrays require one fewer level of
519 : : indirection. */
520 : :
521 : : static void
522 : 264 : gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
523 : : {
524 : 264 : tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
525 : 264 : tree value;
526 : :
527 : : /* Parameters need to be dereferenced. */
528 : 264 : if (sym->cp_pointer->attr.dummy)
529 : 1 : ptr_decl = build_fold_indirect_ref_loc (input_location,
530 : : ptr_decl);
531 : :
532 : : /* Check to see if we're dealing with a variable-sized array. */
533 : 264 : if (sym->attr.dimension
534 : 264 : && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
535 : : {
536 : : /* These decls will be dereferenced later, so we don't dereference
537 : : them here. */
538 : 140 : value = convert (TREE_TYPE (decl), ptr_decl);
539 : : }
540 : : else
541 : : {
542 : 124 : ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
543 : : ptr_decl);
544 : 124 : value = build_fold_indirect_ref_loc (input_location,
545 : : ptr_decl);
546 : : }
547 : :
548 : 264 : SET_DECL_VALUE_EXPR (decl, value);
549 : 264 : DECL_HAS_VALUE_EXPR_P (decl) = 1;
550 : 264 : GFC_DECL_CRAY_POINTEE (decl) = 1;
551 : 264 : }
552 : :
553 : :
554 : : /* Finish processing of a declaration without an initial value. */
555 : :
556 : : static void
557 : 150866 : gfc_finish_decl (tree decl)
558 : : {
559 : 150866 : gcc_assert (TREE_CODE (decl) == PARM_DECL
560 : : || DECL_INITIAL (decl) == NULL_TREE);
561 : :
562 : 150866 : if (!VAR_P (decl))
563 : : return;
564 : :
565 : 744 : if (DECL_SIZE (decl) == NULL_TREE
566 : 744 : && COMPLETE_TYPE_P (TREE_TYPE (decl)))
567 : 0 : layout_decl (decl, 0);
568 : :
569 : : /* A few consistency checks. */
570 : : /* A static variable with an incomplete type is an error if it is
571 : : initialized. Also if it is not file scope. Otherwise, let it
572 : : through, but if it is not `extern' then it may cause an error
573 : : message later. */
574 : : /* An automatic variable with an incomplete type is an error. */
575 : :
576 : : /* We should know the storage size. */
577 : 744 : gcc_assert (DECL_SIZE (decl) != NULL_TREE
578 : : || (TREE_STATIC (decl)
579 : : ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
580 : : : DECL_EXTERNAL (decl)));
581 : :
582 : : /* The storage size should be constant. */
583 : 744 : gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
584 : : || !DECL_SIZE (decl)
585 : : || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
586 : : }
587 : :
588 : :
589 : : /* Handle setting of GFC_DECL_SCALAR* on DECL. */
590 : :
591 : : void
592 : 362634 : gfc_finish_decl_attrs (tree decl, symbol_attribute *attr)
593 : : {
594 : 362634 : if (!attr->dimension && !attr->codimension)
595 : : {
596 : : /* Handle scalar allocatable variables. */
597 : 290681 : if (attr->allocatable)
598 : : {
599 : 5667 : gfc_allocate_lang_decl (decl);
600 : 5667 : GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1;
601 : : }
602 : : /* Handle scalar pointer variables. */
603 : 290681 : if (attr->pointer)
604 : : {
605 : 36090 : gfc_allocate_lang_decl (decl);
606 : 36090 : GFC_DECL_SCALAR_POINTER (decl) = 1;
607 : : }
608 : 290681 : if (attr->target)
609 : : {
610 : 22603 : gfc_allocate_lang_decl (decl);
611 : 22603 : GFC_DECL_SCALAR_TARGET (decl) = 1;
612 : : }
613 : : }
614 : 362634 : }
615 : :
616 : :
617 : : /* Apply symbol attributes to a variable, and add it to the function scope. */
618 : :
619 : : static void
620 : 159989 : gfc_finish_var_decl (tree decl, gfc_symbol * sym)
621 : : {
622 : 159989 : tree new_type;
623 : :
624 : : /* Set DECL_VALUE_EXPR for Cray Pointees. */
625 : 159989 : if (sym->attr.cray_pointee)
626 : 264 : gfc_finish_cray_pointee (decl, sym);
627 : :
628 : : /* TREE_ADDRESSABLE means the address of this variable is actually needed.
629 : : This is the equivalent of the TARGET variables.
630 : : We also need to set this if the variable is passed by reference in a
631 : : CALL statement. */
632 : 159989 : if (sym->attr.target)
633 : 24670 : TREE_ADDRESSABLE (decl) = 1;
634 : :
635 : : /* If it wasn't used we wouldn't be getting it. */
636 : 159989 : TREE_USED (decl) = 1;
637 : :
638 : 159989 : if (sym->attr.flavor == FL_PARAMETER
639 : 1208 : && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
640 : 1200 : TREE_READONLY (decl) = 1;
641 : :
642 : : /* Chain this decl to the pending declarations. Don't do pushdecl()
643 : : because this would add them to the current scope rather than the
644 : : function scope. */
645 : 159989 : if (current_function_decl != NULL_TREE)
646 : : {
647 : 142764 : if (sym->ns->proc_name
648 : 142758 : && (sym->ns->proc_name->backend_decl == current_function_decl
649 : 16432 : || sym->result == sym))
650 : 126326 : gfc_add_decl_to_function (decl);
651 : 16438 : else if (sym->ns->proc_name
652 : 16432 : && sym->ns->proc_name->attr.flavor == FL_LABEL)
653 : : /* This is a BLOCK construct. */
654 : 12065 : add_decl_as_local (decl);
655 : 4373 : else if (sym->ns->omp_affinity_iterators)
656 : : /* This is a block-local iterator. */
657 : 0 : add_decl_as_local (decl);
658 : : else
659 : 4373 : gfc_add_decl_to_parent_function (decl);
660 : : }
661 : :
662 : 159989 : if (sym->attr.cray_pointee)
663 : : return;
664 : :
665 : 159725 : if(sym->attr.is_bind_c == 1 && sym->binding_label)
666 : : {
667 : : /* We need to put variables that are bind(c) into the common
668 : : segment of the object file, because this is what C would do.
669 : : gfortran would typically put them in either the BSS or
670 : : initialized data segments, and only mark them as common if
671 : : they were part of common blocks. However, if they are not put
672 : : into common space, then C cannot initialize global Fortran
673 : : variables that it interoperates with and the draft says that
674 : : either Fortran or C should be able to initialize it (but not
675 : : both, of course.) (J3/04-007, section 15.3). */
676 : 107 : TREE_PUBLIC(decl) = 1;
677 : 107 : DECL_COMMON(decl) = 1;
678 : 107 : if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
679 : : {
680 : 2 : DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
681 : 2 : DECL_VISIBILITY_SPECIFIED (decl) = true;
682 : : }
683 : : }
684 : :
685 : : /* If a variable is USE associated, it's always external. */
686 : 159725 : if (sym->attr.use_assoc || sym->attr.used_in_submodule)
687 : : {
688 : 126 : DECL_EXTERNAL (decl) = 1;
689 : 126 : TREE_PUBLIC (decl) = 1;
690 : : }
691 : 159599 : else if (sym->fn_result_spec && !sym->ns->proc_name->module)
692 : : {
693 : :
694 : 0 : if (sym->ns->proc_name->attr.if_source != IFSRC_DECL)
695 : 0 : DECL_EXTERNAL (decl) = 1;
696 : : else
697 : 0 : TREE_STATIC (decl) = 1;
698 : :
699 : 0 : TREE_PUBLIC (decl) = 1;
700 : : }
701 : 159599 : else if (sym->module && !sym->attr.result && !sym->attr.dummy)
702 : : {
703 : : /* TODO: Don't set sym->module for result or dummy variables. */
704 : 17223 : gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
705 : :
706 : 17223 : TREE_PUBLIC (decl) = 1;
707 : 17223 : TREE_STATIC (decl) = 1;
708 : 17223 : if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
709 : : {
710 : 241 : DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
711 : 241 : DECL_VISIBILITY_SPECIFIED (decl) = true;
712 : : }
713 : : }
714 : :
715 : : /* Derived types are a bit peculiar because of the possibility of
716 : : a default initializer; this must be applied each time the variable
717 : : comes into scope it therefore need not be static. These variables
718 : : are SAVE_NONE but have an initializer. Otherwise explicitly
719 : : initialized variables are SAVE_IMPLICIT and explicitly saved are
720 : : SAVE_EXPLICIT. */
721 : 159725 : if (!sym->attr.use_assoc
722 : 159599 : && (sym->attr.save != SAVE_NONE || sym->attr.data
723 : 129029 : || (sym->value && sym->ns->proc_name->attr.is_main_program)
724 : 125202 : || (flag_coarray == GFC_FCOARRAY_LIB
725 : 943 : && sym->attr.codimension && !sym->attr.allocatable)))
726 : 34493 : TREE_STATIC (decl) = 1;
727 : :
728 : : /* If derived-type variables with DTIO procedures are not made static
729 : : some bits of code referencing them get optimized away.
730 : : TODO Understand why this is so and fix it. */
731 : 159725 : if (!sym->attr.use_assoc
732 : 159599 : && ((sym->ts.type == BT_DERIVED
733 : 30967 : && sym->ts.u.derived->attr.has_dtio_procs)
734 : 159098 : || (sym->ts.type == BT_CLASS
735 : 4336 : && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
736 : 520 : TREE_STATIC (decl) = 1;
737 : :
738 : : /* Treat asynchronous variables the same as volatile, for now. */
739 : 159725 : if (sym->attr.volatile_ || sym->attr.asynchronous)
740 : : {
741 : 788 : TREE_THIS_VOLATILE (decl) = 1;
742 : 788 : TREE_SIDE_EFFECTS (decl) = 1;
743 : 788 : new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
744 : 788 : TREE_TYPE (decl) = new_type;
745 : : }
746 : :
747 : : /* Keep variables larger than max-stack-var-size off stack. */
748 : 159719 : if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive)
749 : 143672 : && !sym->attr.automatic
750 : 143654 : && !sym->attr.associate_var
751 : 136216 : && sym->attr.save != SAVE_EXPLICIT
752 : 134016 : && sym->attr.save != SAVE_IMPLICIT
753 : 107787 : && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
754 : 107397 : && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
755 : : /* Put variable length auto array pointers always into stack. */
756 : 146 : && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
757 : 7 : || sym->attr.dimension == 0
758 : 7 : || sym->as->type != AS_EXPLICIT
759 : : || sym->attr.pointer
760 : 7 : || sym->attr.allocatable)
761 : 159864 : && !DECL_ARTIFICIAL (decl))
762 : : {
763 : 138 : if (flag_max_stack_var_size > 0
764 : 131 : && !(sym->ns->proc_name
765 : 131 : && sym->ns->proc_name->attr.is_main_program))
766 : 32 : gfc_warning (OPT_Wsurprising,
767 : : "Array %qs at %L is larger than limit set by "
768 : : "%<-fmax-stack-var-size=%>, moved from stack to static "
769 : : "storage. This makes the procedure unsafe when called "
770 : : "recursively, or concurrently from multiple threads. "
771 : : "Consider increasing the %<-fmax-stack-var-size=%> "
772 : : "limit (or use %<-frecursive%>, which implies "
773 : : "unlimited %<-fmax-stack-var-size%>) - or change the "
774 : : "code to use an ALLOCATABLE array. If the variable is "
775 : : "never accessed concurrently, this warning can be "
776 : : "ignored, and the variable could also be declared with "
777 : : "the SAVE attribute.",
778 : : sym->name, &sym->declared_at);
779 : :
780 : 138 : TREE_STATIC (decl) = 1;
781 : :
782 : : /* Because the size of this variable isn't known until now, we may have
783 : : greedily added an initializer to this variable (in build_init_assign)
784 : : even though the max-stack-var-size indicates the variable should be
785 : : static. Therefore we rip out the automatic initializer here and
786 : : replace it with a static one. */
787 : 138 : gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
788 : 138 : gfc_code *prev = NULL;
789 : 138 : gfc_code *code = sym->ns->code;
790 : 138 : while (code && code->op == EXEC_INIT_ASSIGN)
791 : : {
792 : : /* Look for an initializer meant for this symbol. */
793 : 8 : if (code->expr1->symtree == st)
794 : : {
795 : 8 : if (prev)
796 : 0 : prev->next = code->next;
797 : : else
798 : 8 : sym->ns->code = code->next;
799 : :
800 : : break;
801 : : }
802 : :
803 : 0 : prev = code;
804 : 0 : code = code->next;
805 : : }
806 : 146 : if (code && code->op == EXEC_INIT_ASSIGN)
807 : : {
808 : : /* Keep the init expression for a static initializer. */
809 : 8 : sym->value = code->expr2;
810 : : /* Cleanup the defunct code object, without freeing the init expr. */
811 : 8 : code->expr2 = NULL;
812 : 8 : gfc_free_statement (code);
813 : 8 : free (code);
814 : : }
815 : : }
816 : :
817 : : /* Handle threadprivate variables. */
818 : 159725 : if (sym->attr.threadprivate
819 : 159725 : && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
820 : 151 : set_decl_tls_model (decl, decl_default_tls_model (decl));
821 : :
822 : : /* Mark weak variables. */
823 : 159725 : if (sym->attr.ext_attr & (1 << EXT_ATTR_WEAK))
824 : 1 : declare_weak (decl);
825 : :
826 : 159725 : gfc_finish_decl_attrs (decl, &sym->attr);
827 : : }
828 : :
829 : :
830 : : /* Allocate the lang-specific part of a decl. */
831 : :
832 : : void
833 : 94753 : gfc_allocate_lang_decl (tree decl)
834 : : {
835 : 94753 : if (DECL_LANG_SPECIFIC (decl) == NULL)
836 : 89864 : DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
837 : 94753 : }
838 : :
839 : :
840 : : /* Determine order of two symbol declarations. */
841 : :
842 : : static bool
843 : 4443 : decl_order (gfc_symbol *sym1, gfc_symbol *sym2)
844 : : {
845 : 4443 : if (sym1->declared_at.lb->location > sym2->declared_at.lb->location)
846 : : return true;
847 : : else
848 : 0 : return false;
849 : : }
850 : :
851 : :
852 : : /* Remember a symbol to generate initialization/cleanup code at function
853 : : entry/exit. */
854 : :
855 : : static void
856 : 69551 : gfc_defer_symbol_init (gfc_symbol * sym)
857 : : {
858 : 69551 : gfc_symbol *p;
859 : 69551 : gfc_symbol *last;
860 : 69551 : gfc_symbol *head;
861 : :
862 : : /* Don't add a symbol twice. */
863 : 69551 : if (sym->tlink)
864 : : return;
865 : :
866 : 65927 : last = head = sym->ns->proc_name;
867 : 65927 : p = last->tlink;
868 : :
869 : 65927 : gfc_function_dependency (sym, head);
870 : :
871 : : /* Make sure that setup code for dummy variables which are used in the
872 : : setup of other variables is generated first. */
873 : 65927 : if (sym->attr.dummy)
874 : : {
875 : : /* Find the first dummy arg seen after us, or the first non-dummy arg.
876 : : This is a circular list, so don't go past the head. */
877 : : while (p != head
878 : 13587 : && (!p->attr.dummy || decl_order (p, sym)))
879 : : {
880 : 1303 : last = p;
881 : 1303 : p = p->tlink;
882 : : }
883 : : }
884 : 53643 : else if (sym->fn_result_dep)
885 : : {
886 : : /* In the case of non-dummy symbols with dependencies on an old-fashioned
887 : : function result (ie. proc_name = proc_name->result), make sure that the
888 : : order in the tlink chain is such that the code appears in declaration
889 : : order. This ensures that mutual dependencies between these symbols are
890 : : respected. */
891 : : while (p != head
892 : 228 : && (!p->attr.result || decl_order (sym, p)))
893 : : {
894 : 162 : last = p;
895 : 162 : p = p->tlink;
896 : : }
897 : : }
898 : : /* Insert in between last and p. */
899 : 65927 : last->tlink = sym;
900 : 65927 : sym->tlink = p;
901 : : }
902 : :
903 : :
904 : : /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
905 : : backend_decl for a module symbol, if it all ready exists. If the
906 : : module gsymbol does not exist, it is created. If the symbol does
907 : : not exist, it is added to the gsymbol namespace. Returns true if
908 : : an existing backend_decl is found. */
909 : :
910 : : bool
911 : 12366 : gfc_get_module_backend_decl (gfc_symbol *sym)
912 : : {
913 : 12366 : gfc_gsymbol *gsym;
914 : 12366 : gfc_symbol *s;
915 : 12366 : gfc_symtree *st;
916 : :
917 : 12366 : gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
918 : :
919 : 12366 : if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
920 : : {
921 : 12366 : st = NULL;
922 : 12366 : s = NULL;
923 : :
924 : : /* Check for a symbol with the same name. */
925 : 326 : if (gsym)
926 : 12040 : gfc_find_symbol (sym->name, gsym->ns, 0, &s);
927 : :
928 : 12366 : if (!s)
929 : : {
930 : 464 : if (!gsym)
931 : : {
932 : 326 : gsym = gfc_get_gsymbol (sym->module, false);
933 : 326 : gsym->type = GSYM_MODULE;
934 : 326 : gsym->ns = gfc_get_namespace (NULL, 0);
935 : : }
936 : :
937 : 464 : st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
938 : 464 : st->n.sym = sym;
939 : 464 : sym->refs++;
940 : : }
941 : 11902 : else if (gfc_fl_struct (sym->attr.flavor))
942 : : {
943 : 9472 : if (s && s->attr.flavor == FL_PROCEDURE)
944 : : {
945 : 5263 : gfc_interface *intr;
946 : 5263 : gcc_assert (s->attr.generic);
947 : 5364 : for (intr = s->generic; intr; intr = intr->next)
948 : 5364 : if (gfc_fl_struct (intr->sym->attr.flavor))
949 : : {
950 : 5263 : s = intr->sym;
951 : 5263 : break;
952 : : }
953 : : }
954 : :
955 : : /* Normally we can assume that s is a derived-type symbol since it
956 : : shares a name with the derived-type sym. However if sym is a
957 : : STRUCTURE, it may in fact share a name with any other basic type
958 : : variable. If s is in fact of derived type then we can continue
959 : : looking for a duplicate type declaration. */
960 : 9472 : if (sym->attr.flavor == FL_STRUCT && s->ts.type == BT_DERIVED)
961 : : {
962 : 0 : s = s->ts.u.derived;
963 : : }
964 : :
965 : 9472 : if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl)
966 : : {
967 : 25 : if (s->attr.flavor == FL_UNION)
968 : 0 : s->backend_decl = gfc_get_union_type (s);
969 : : else
970 : 25 : s->backend_decl = gfc_get_derived_type (s);
971 : : }
972 : 9472 : gfc_copy_dt_decls_ifequal (s, sym, true);
973 : 9472 : return true;
974 : : }
975 : 2430 : else if (s->backend_decl)
976 : : {
977 : 2418 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
978 : 393 : gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
979 : : true);
980 : 2025 : else if (sym->ts.type == BT_CHARACTER)
981 : 300 : sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
982 : 2418 : sym->backend_decl = s->backend_decl;
983 : 2418 : return true;
984 : : }
985 : : }
986 : : return false;
987 : : }
988 : :
989 : :
990 : : /* Create an array index type variable with function scope. */
991 : :
992 : : static tree
993 : 40686 : create_index_var (const char * pfx, int nest)
994 : : {
995 : 40686 : tree decl;
996 : :
997 : 40686 : decl = gfc_create_var_np (gfc_array_index_type, pfx);
998 : 40686 : if (nest)
999 : 28 : gfc_add_decl_to_parent_function (decl);
1000 : : else
1001 : 40658 : gfc_add_decl_to_function (decl);
1002 : 40686 : return decl;
1003 : : }
1004 : :
1005 : :
1006 : : /* Create variables to hold all the non-constant bits of info for a
1007 : : descriptorless array. Remember these in the lang-specific part of the
1008 : : type. */
1009 : :
1010 : : static void
1011 : 53835 : gfc_build_qualified_array (tree decl, gfc_symbol * sym)
1012 : : {
1013 : 53835 : tree type;
1014 : 53835 : int dim;
1015 : 53835 : int nest;
1016 : 53835 : gfc_namespace* procns;
1017 : 53835 : symbol_attribute *array_attr;
1018 : 53835 : gfc_array_spec *as;
1019 : 53835 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
1020 : :
1021 : 53835 : type = TREE_TYPE (decl);
1022 : 53835 : array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
1023 : 53835 : as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
1024 : :
1025 : : /* We just use the descriptor, if there is one. */
1026 : 53835 : if (GFC_DESCRIPTOR_TYPE_P (type))
1027 : : return;
1028 : :
1029 : 41722 : gcc_assert (GFC_ARRAY_TYPE_P (type));
1030 : 41722 : procns = gfc_find_proc_namespace (sym->ns);
1031 : 83444 : nest = (procns->proc_name->backend_decl != current_function_decl)
1032 : 41722 : && !sym->attr.contained;
1033 : :
1034 : 555 : if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB
1035 : 269 : && as->type != AS_ASSUMED_SHAPE
1036 : 41980 : && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
1037 : : {
1038 : 258 : tree token;
1039 : 258 : tree token_type = build_qualified_type (pvoid_type_node,
1040 : : TYPE_QUAL_RESTRICT);
1041 : :
1042 : 258 : if (sym->module && (sym->attr.use_assoc
1043 : 16 : || sym->ns->proc_name->attr.flavor == FL_MODULE))
1044 : : {
1045 : 19 : tree token_name
1046 : 19 : = get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"),
1047 : : IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym))));
1048 : 19 : token = build_decl (DECL_SOURCE_LOCATION (decl), VAR_DECL, token_name,
1049 : : token_type);
1050 : 19 : if (sym->attr.use_assoc)
1051 : 3 : DECL_EXTERNAL (token) = 1;
1052 : : else
1053 : 16 : TREE_STATIC (token) = 1;
1054 : :
1055 : 19 : TREE_PUBLIC (token) = 1;
1056 : :
1057 : 19 : if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
1058 : : {
1059 : 0 : DECL_VISIBILITY (token) = VISIBILITY_HIDDEN;
1060 : 0 : DECL_VISIBILITY_SPECIFIED (token) = true;
1061 : : }
1062 : : }
1063 : : else
1064 : : {
1065 : 239 : token = gfc_create_var_np (token_type, "caf_token");
1066 : 239 : TREE_STATIC (token) = 1;
1067 : : }
1068 : :
1069 : 258 : GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
1070 : 258 : DECL_ARTIFICIAL (token) = 1;
1071 : 258 : DECL_NONALIASED (token) = 1;
1072 : :
1073 : 258 : if (sym->module && !sym->attr.use_assoc)
1074 : : {
1075 : 16 : pushdecl (token);
1076 : 16 : DECL_CONTEXT (token) = sym->ns->proc_name->backend_decl;
1077 : 16 : gfc_module_add_decl (cur_module, token);
1078 : : }
1079 : 242 : else if (sym->attr.host_assoc
1080 : 242 : && TREE_CODE (DECL_CONTEXT (current_function_decl))
1081 : : != TRANSLATION_UNIT_DECL)
1082 : 2 : gfc_add_decl_to_parent_function (token);
1083 : : else
1084 : 240 : gfc_add_decl_to_function (token);
1085 : : }
1086 : :
1087 : 98120 : for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
1088 : : {
1089 : 56398 : if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
1090 : : {
1091 : 529 : GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
1092 : 529 : suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim));
1093 : : }
1094 : : /* Don't try to use the unknown bound for assumed shape arrays. */
1095 : 56398 : if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
1096 : 56398 : && (as->type != AS_ASSUMED_SIZE
1097 : 2089 : || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
1098 : : {
1099 : 16465 : GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
1100 : 16465 : suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim));
1101 : : }
1102 : :
1103 : 56398 : if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
1104 : : {
1105 : 9965 : GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
1106 : 9965 : suppress_warning (GFC_TYPE_ARRAY_STRIDE (type, dim));
1107 : : }
1108 : : }
1109 : 42475 : for (dim = GFC_TYPE_ARRAY_RANK (type);
1110 : 42475 : dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
1111 : : {
1112 : 753 : if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
1113 : : {
1114 : 96 : GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
1115 : 96 : suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim));
1116 : : }
1117 : : /* Don't try to use the unknown ubound for the last coarray dimension. */
1118 : 753 : if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
1119 : 753 : && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
1120 : : {
1121 : 50 : GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
1122 : 50 : suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim));
1123 : : }
1124 : : }
1125 : 41722 : if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
1126 : : {
1127 : 7900 : GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
1128 : : "offset");
1129 : 7900 : suppress_warning (GFC_TYPE_ARRAY_OFFSET (type));
1130 : :
1131 : 7900 : if (nest)
1132 : 8 : gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
1133 : : else
1134 : 7892 : gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
1135 : : }
1136 : :
1137 : 57026 : if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE && as->rank != 0
1138 : 56995 : && as->type != AS_ASSUMED_SIZE)
1139 : : {
1140 : 13581 : GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
1141 : 13581 : suppress_warning (GFC_TYPE_ARRAY_SIZE (type));
1142 : : }
1143 : :
1144 : 41722 : if (POINTER_TYPE_P (type))
1145 : : {
1146 : 18283 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
1147 : 18283 : gcc_assert (TYPE_LANG_SPECIFIC (type)
1148 : : == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
1149 : 18283 : type = TREE_TYPE (type);
1150 : : }
1151 : :
1152 : 41722 : if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
1153 : : {
1154 : 13581 : tree size, range;
1155 : :
1156 : 40743 : size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1157 : 13581 : GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
1158 : 13581 : range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1159 : : size);
1160 : 13581 : TYPE_DOMAIN (type) = range;
1161 : 13581 : layout_type (type);
1162 : : }
1163 : :
1164 : 75518 : if (TYPE_NAME (type) != NULL_TREE && as->rank > 0
1165 : 33541 : && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
1166 : 73959 : && VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)))
1167 : : {
1168 : 6069 : tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
1169 : :
1170 : 6457 : for (dim = 0; dim < as->rank - 1; dim++)
1171 : : {
1172 : 388 : gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
1173 : 388 : gtype = TREE_TYPE (gtype);
1174 : : }
1175 : 6069 : gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
1176 : 6069 : if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
1177 : 6069 : TYPE_NAME (type) = NULL_TREE;
1178 : : }
1179 : :
1180 : 41722 : if (TYPE_NAME (type) == NULL_TREE)
1181 : : {
1182 : 13995 : tree gtype = TREE_TYPE (type), rtype, type_decl;
1183 : :
1184 : 32321 : for (dim = as->rank - 1; dim >= 0; dim--)
1185 : : {
1186 : 18326 : tree lbound, ubound;
1187 : 18326 : lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
1188 : 18326 : ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
1189 : 18326 : rtype = build_range_type (gfc_array_index_type, lbound, ubound);
1190 : 18326 : gtype = build_array_type (gtype, rtype);
1191 : : /* Ensure the bound variables aren't optimized out at -O0.
1192 : : For -O1 and above they often will be optimized out, but
1193 : : can be tracked by VTA. Also set DECL_NAMELESS, so that
1194 : : the artificial lbound.N or ubound.N DECL_NAME doesn't
1195 : : end up in debug info. */
1196 : 18326 : if (lbound
1197 : 18326 : && VAR_P (lbound)
1198 : 529 : && DECL_ARTIFICIAL (lbound)
1199 : 18855 : && DECL_IGNORED_P (lbound))
1200 : : {
1201 : 529 : if (DECL_NAME (lbound)
1202 : 529 : && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
1203 : : "lbound") != 0)
1204 : 529 : DECL_NAMELESS (lbound) = 1;
1205 : 529 : DECL_IGNORED_P (lbound) = 0;
1206 : : }
1207 : 18326 : if (ubound
1208 : 17938 : && VAR_P (ubound)
1209 : 16465 : && DECL_ARTIFICIAL (ubound)
1210 : 34791 : && DECL_IGNORED_P (ubound))
1211 : : {
1212 : 16465 : if (DECL_NAME (ubound)
1213 : 16465 : && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
1214 : : "ubound") != 0)
1215 : 16465 : DECL_NAMELESS (ubound) = 1;
1216 : 16465 : DECL_IGNORED_P (ubound) = 0;
1217 : : }
1218 : : }
1219 : 13995 : TYPE_NAME (type) = type_decl = build_decl (input_location,
1220 : : TYPE_DECL, NULL, gtype);
1221 : 13995 : DECL_ORIGINAL_TYPE (type_decl) = gtype;
1222 : : }
1223 : : }
1224 : :
1225 : :
1226 : : /* For some dummy arguments we don't use the actual argument directly.
1227 : : Instead we create a local decl and use that. This allows us to perform
1228 : : initialization, and construct full type information. */
1229 : :
1230 : : static tree
1231 : 21683 : gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
1232 : : {
1233 : 21683 : tree decl;
1234 : 21683 : tree type;
1235 : 21683 : gfc_array_spec *as;
1236 : 21683 : symbol_attribute *array_attr;
1237 : 21683 : char *name;
1238 : 21683 : gfc_packed packed;
1239 : 21683 : int n;
1240 : 21683 : bool known_size;
1241 : 21683 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
1242 : :
1243 : : /* Use the array as and attr. */
1244 : 21683 : as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
1245 : 21683 : array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
1246 : :
1247 : : /* The dummy is returned for pointer, allocatable or assumed rank arrays.
1248 : : For class arrays the information if sym is an allocatable or pointer
1249 : : object needs to be checked explicitly (IS_CLASS_ARRAY can be false for
1250 : : too many reasons to be of use here). */
1251 : 21683 : if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
1252 : 20029 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
1253 : 20029 : || array_attr->allocatable
1254 : 16106 : || (as && as->type == AS_ASSUMED_RANK))
1255 : : return dummy;
1256 : :
1257 : : /* Add to list of variables if not a fake result variable.
1258 : : These symbols are set on the symbol only, not on the class component. */
1259 : 12963 : if (sym->attr.result || sym->attr.dummy)
1260 : 12396 : gfc_defer_symbol_init (sym);
1261 : :
1262 : : /* For a class array the array descriptor is in the _data component, while
1263 : : for a regular array the TREE_TYPE of the dummy is a pointer to the
1264 : : descriptor. */
1265 : 12963 : type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy)
1266 : : : TREE_TYPE (dummy));
1267 : : /* type now is the array descriptor w/o any indirection. */
1268 : 12963 : gcc_assert (TREE_CODE (dummy) == PARM_DECL
1269 : : && POINTER_TYPE_P (TREE_TYPE (dummy)));
1270 : :
1271 : : /* Do we know the element size? */
1272 : 12963 : known_size = sym->ts.type != BT_CHARACTER
1273 : 12963 : || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
1274 : :
1275 : 12203 : if (known_size && !GFC_DESCRIPTOR_TYPE_P (type))
1276 : : {
1277 : : /* For descriptorless arrays with known element size the actual
1278 : : argument is sufficient. */
1279 : 6338 : gfc_build_qualified_array (dummy, sym);
1280 : 6338 : return dummy;
1281 : : }
1282 : :
1283 : 6625 : if (GFC_DESCRIPTOR_TYPE_P (type))
1284 : : {
1285 : : /* Create a descriptorless array pointer. */
1286 : 6353 : packed = PACKED_NO;
1287 : :
1288 : : /* Even when -frepack-arrays is used, symbols with TARGET attribute
1289 : : are not repacked. */
1290 : 6353 : if (!flag_repack_arrays || sym->attr.target)
1291 : : {
1292 : 6351 : if (as->type == AS_ASSUMED_SIZE)
1293 : 79 : packed = PACKED_FULL;
1294 : : }
1295 : : else
1296 : : {
1297 : 2 : if (as->type == AS_EXPLICIT)
1298 : : {
1299 : 3 : packed = PACKED_FULL;
1300 : 3 : for (n = 0; n < as->rank; n++)
1301 : : {
1302 : 2 : if (!(as->upper[n]
1303 : 2 : && as->lower[n]
1304 : 2 : && as->upper[n]->expr_type == EXPR_CONSTANT
1305 : 2 : && as->lower[n]->expr_type == EXPR_CONSTANT))
1306 : : {
1307 : : packed = PACKED_PARTIAL;
1308 : : break;
1309 : : }
1310 : : }
1311 : : }
1312 : : else
1313 : : packed = PACKED_PARTIAL;
1314 : : }
1315 : :
1316 : : /* For classarrays the element type is required, but
1317 : : gfc_typenode_for_spec () returns the array descriptor. */
1318 : 6353 : type = is_classarray ? gfc_get_element_type (type)
1319 : 5614 : : gfc_typenode_for_spec (&sym->ts);
1320 : 6353 : type = gfc_get_nodesc_array_type (type, as, packed,
1321 : 6353 : !sym->attr.target);
1322 : : }
1323 : : else
1324 : : {
1325 : : /* We now have an expression for the element size, so create a fully
1326 : : qualified type. Reset sym->backend decl or this will just return the
1327 : : old type. */
1328 : 272 : DECL_ARTIFICIAL (sym->backend_decl) = 1;
1329 : 272 : sym->backend_decl = NULL_TREE;
1330 : 272 : type = gfc_sym_type (sym);
1331 : 272 : packed = PACKED_FULL;
1332 : : }
1333 : :
1334 : 6625 : ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
1335 : 6625 : decl = build_decl (input_location,
1336 : : VAR_DECL, get_identifier (name), type);
1337 : :
1338 : 6625 : DECL_ARTIFICIAL (decl) = 1;
1339 : 6625 : DECL_NAMELESS (decl) = 1;
1340 : 6625 : TREE_PUBLIC (decl) = 0;
1341 : 6625 : TREE_STATIC (decl) = 0;
1342 : 6625 : DECL_EXTERNAL (decl) = 0;
1343 : :
1344 : : /* Avoid uninitialized warnings for optional dummy arguments. */
1345 : 6625 : if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
1346 : 6625 : || sym->attr.optional)
1347 : 706 : suppress_warning (decl);
1348 : :
1349 : : /* We should never get deferred shape arrays here. We used to because of
1350 : : frontend bugs. */
1351 : 6625 : gcc_assert (as->type != AS_DEFERRED);
1352 : :
1353 : 6625 : if (packed == PACKED_PARTIAL)
1354 : 1 : GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
1355 : 6624 : else if (packed == PACKED_FULL)
1356 : 351 : GFC_DECL_PACKED_ARRAY (decl) = 1;
1357 : :
1358 : 6625 : gfc_build_qualified_array (decl, sym);
1359 : :
1360 : 6625 : if (DECL_LANG_SPECIFIC (dummy))
1361 : 858 : DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
1362 : : else
1363 : 5767 : gfc_allocate_lang_decl (decl);
1364 : :
1365 : 6625 : GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
1366 : :
1367 : 6625 : if (sym->ns->proc_name->backend_decl == current_function_decl
1368 : 481 : || sym->attr.contained)
1369 : 6617 : gfc_add_decl_to_function (decl);
1370 : : else
1371 : 8 : gfc_add_decl_to_parent_function (decl);
1372 : :
1373 : : return decl;
1374 : : }
1375 : :
1376 : : /* Return a constant or a variable to use as a string length. Does not
1377 : : add the decl to the current scope. */
1378 : :
1379 : : static tree
1380 : 14981 : gfc_create_string_length (gfc_symbol * sym)
1381 : : {
1382 : 14981 : gcc_assert (sym->ts.u.cl);
1383 : 14981 : gfc_conv_const_charlen (sym->ts.u.cl);
1384 : :
1385 : 14981 : if (sym->ts.u.cl->backend_decl == NULL_TREE)
1386 : : {
1387 : 3106 : tree length;
1388 : 3106 : const char *name;
1389 : :
1390 : : /* The string length variable shall be in static memory if it is either
1391 : : explicitly SAVED, a module variable or with -fno-automatic. Only
1392 : : relevant is "len=:" - otherwise, it is either a constant length or
1393 : : it is an automatic variable. */
1394 : 6212 : bool static_length = sym->attr.save
1395 : 3002 : || sym->ns->proc_name->attr.flavor == FL_MODULE
1396 : 6108 : || (flag_max_stack_var_size == 0
1397 : 2 : && sym->ts.deferred && !sym->attr.dummy
1398 : 0 : && !sym->attr.result && !sym->attr.function);
1399 : :
1400 : : /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1401 : : variables as some systems do not support the "." in the assembler name.
1402 : : For nonstatic variables, the "." does not appear in assembler. */
1403 : 3002 : if (static_length)
1404 : : {
1405 : 104 : if (sym->module)
1406 : 47 : name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module,
1407 : : sym->name);
1408 : : else
1409 : 57 : name = gfc_get_string (GFC_PREFIX ("%s"), sym->name);
1410 : : }
1411 : 3002 : else if (sym->module)
1412 : 0 : name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
1413 : : else
1414 : 3002 : name = gfc_get_string (".%s", sym->name);
1415 : :
1416 : 3106 : length = build_decl (input_location,
1417 : : VAR_DECL, get_identifier (name),
1418 : : gfc_charlen_type_node);
1419 : 3106 : DECL_ARTIFICIAL (length) = 1;
1420 : 3106 : TREE_USED (length) = 1;
1421 : 3106 : if (sym->ns->proc_name->tlink != NULL)
1422 : 2856 : gfc_defer_symbol_init (sym);
1423 : :
1424 : 3106 : sym->ts.u.cl->backend_decl = length;
1425 : :
1426 : 3106 : if (static_length)
1427 : 104 : TREE_STATIC (length) = 1;
1428 : :
1429 : 3106 : if (sym->ns->proc_name->attr.flavor == FL_MODULE
1430 : 47 : && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
1431 : 47 : TREE_PUBLIC (length) = 1;
1432 : : }
1433 : :
1434 : 14981 : gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1435 : 14981 : return sym->ts.u.cl->backend_decl;
1436 : : }
1437 : :
1438 : : /* If a variable is assigned a label, we add another two auxiliary
1439 : : variables. */
1440 : :
1441 : : static void
1442 : 66 : gfc_add_assign_aux_vars (gfc_symbol * sym)
1443 : : {
1444 : 66 : tree addr;
1445 : 66 : tree length;
1446 : 66 : tree decl;
1447 : :
1448 : 66 : gcc_assert (sym->backend_decl);
1449 : :
1450 : 66 : decl = sym->backend_decl;
1451 : 66 : gfc_allocate_lang_decl (decl);
1452 : 66 : GFC_DECL_ASSIGN (decl) = 1;
1453 : 66 : length = build_decl (input_location,
1454 : : VAR_DECL, create_tmp_var_name (sym->name),
1455 : : gfc_charlen_type_node);
1456 : 66 : addr = build_decl (input_location,
1457 : : VAR_DECL, create_tmp_var_name (sym->name),
1458 : : pvoid_type_node);
1459 : 66 : gfc_finish_var_decl (length, sym);
1460 : 66 : gfc_finish_var_decl (addr, sym);
1461 : : /* STRING_LENGTH is also used as flag. Less than -1 means that
1462 : : ASSIGN_ADDR cannot be used. Equal -1 means that ASSIGN_ADDR is the
1463 : : target label's address. Otherwise, value is the length of a format string
1464 : : and ASSIGN_ADDR is its address. */
1465 : 66 : if (TREE_STATIC (length))
1466 : 1 : DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1467 : : else
1468 : 65 : gfc_defer_symbol_init (sym);
1469 : :
1470 : 66 : GFC_DECL_STRING_LEN (decl) = length;
1471 : 66 : GFC_DECL_ASSIGN_ADDR (decl) = addr;
1472 : 66 : }
1473 : :
1474 : :
1475 : : static tree
1476 : 250272 : add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1477 : : {
1478 : 250272 : unsigned id;
1479 : 250272 : tree attr;
1480 : :
1481 : 2752992 : for (id = 0; id < EXT_ATTR_NUM; id++)
1482 : 2502720 : if (sym_attr.ext_attr & (1 << id) && ext_attr_list[id].middle_end_name)
1483 : : {
1484 : 0 : attr = build_tree_list (
1485 : : get_identifier (ext_attr_list[id].middle_end_name),
1486 : : NULL_TREE);
1487 : 0 : list = chainon (list, attr);
1488 : : }
1489 : :
1490 : 250272 : tree clauses = NULL_TREE;
1491 : :
1492 : 250272 : if (sym_attr.oacc_routine_lop != OACC_ROUTINE_LOP_NONE)
1493 : : {
1494 : 337 : omp_clause_code code;
1495 : 337 : switch (sym_attr.oacc_routine_lop)
1496 : : {
1497 : : case OACC_ROUTINE_LOP_GANG:
1498 : : code = OMP_CLAUSE_GANG;
1499 : : break;
1500 : : case OACC_ROUTINE_LOP_WORKER:
1501 : : code = OMP_CLAUSE_WORKER;
1502 : : break;
1503 : : case OACC_ROUTINE_LOP_VECTOR:
1504 : : code = OMP_CLAUSE_VECTOR;
1505 : : break;
1506 : : case OACC_ROUTINE_LOP_SEQ:
1507 : : code = OMP_CLAUSE_SEQ;
1508 : : break;
1509 : 0 : case OACC_ROUTINE_LOP_NONE:
1510 : 0 : case OACC_ROUTINE_LOP_ERROR:
1511 : 0 : default:
1512 : 0 : gcc_unreachable ();
1513 : : }
1514 : 337 : tree c = build_omp_clause (UNKNOWN_LOCATION, code);
1515 : 337 : OMP_CLAUSE_CHAIN (c) = clauses;
1516 : 337 : clauses = c;
1517 : :
1518 : 337 : tree dims = oacc_build_routine_dims (clauses);
1519 : 337 : list = oacc_replace_fn_attrib_attr (list, dims);
1520 : : }
1521 : :
1522 : 250272 : if (sym_attr.oacc_routine_nohost)
1523 : : {
1524 : 40 : tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_NOHOST);
1525 : 40 : OMP_CLAUSE_CHAIN (c) = clauses;
1526 : 40 : clauses = c;
1527 : : }
1528 : :
1529 : 250272 : if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET)
1530 : : {
1531 : 11 : tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE);
1532 : 11 : switch (sym_attr.omp_device_type)
1533 : : {
1534 : 3 : case OMP_DEVICE_TYPE_HOST:
1535 : 3 : OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST;
1536 : 3 : break;
1537 : 3 : case OMP_DEVICE_TYPE_NOHOST:
1538 : 3 : OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
1539 : 3 : break;
1540 : 5 : case OMP_DEVICE_TYPE_ANY:
1541 : 5 : OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY;
1542 : 5 : break;
1543 : 0 : default:
1544 : 0 : gcc_unreachable ();
1545 : : }
1546 : 11 : OMP_CLAUSE_CHAIN (c) = clauses;
1547 : 11 : clauses = c;
1548 : : }
1549 : :
1550 : 250272 : if (sym_attr.omp_declare_target_link
1551 : 250272 : || sym_attr.oacc_declare_link)
1552 : 4 : list = tree_cons (get_identifier ("omp declare target link"),
1553 : : clauses, list);
1554 : 250268 : else if (sym_attr.omp_declare_target
1555 : : || sym_attr.oacc_declare_create
1556 : : || sym_attr.oacc_declare_copyin
1557 : : || sym_attr.oacc_declare_deviceptr
1558 : 250268 : || sym_attr.oacc_declare_device_resident)
1559 : 917 : list = tree_cons (get_identifier ("omp declare target"),
1560 : : clauses, list);
1561 : :
1562 : 250272 : if (sym_attr.omp_declare_target_indirect)
1563 : 46 : list = tree_cons (get_identifier ("omp declare target indirect"),
1564 : : clauses, list);
1565 : :
1566 : 250272 : return list;
1567 : : }
1568 : :
1569 : :
1570 : : static void build_function_decl (gfc_symbol * sym, bool global);
1571 : :
1572 : :
1573 : : /* Return the decl for a gfc_symbol, create it if it doesn't already
1574 : : exist. */
1575 : :
1576 : : tree
1577 : 1424271 : gfc_get_symbol_decl (gfc_symbol * sym)
1578 : : {
1579 : 1424271 : tree decl;
1580 : 1424271 : tree length = NULL_TREE;
1581 : 1424271 : tree attributes;
1582 : 1424271 : int byref;
1583 : 1424271 : bool intrinsic_array_parameter = false;
1584 : 1424271 : bool fun_or_res;
1585 : :
1586 : 1424271 : gcc_assert (sym->attr.referenced
1587 : : || sym->attr.flavor == FL_PROCEDURE
1588 : : || sym->attr.use_assoc
1589 : : || sym->attr.used_in_submodule
1590 : : || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1591 : : || (sym->module && sym->attr.if_source != IFSRC_DECL
1592 : : && sym->backend_decl));
1593 : :
1594 : 294776 : if (sym->attr.dummy && sym->ns->proc_name->attr.is_bind_c
1595 : 1448210 : && is_CFI_desc (sym, NULL))
1596 : : {
1597 : 15484 : gcc_assert (sym->backend_decl && (sym->ts.type != BT_CHARACTER
1598 : : || sym->ts.u.cl->backend_decl));
1599 : : return sym->backend_decl;
1600 : : }
1601 : :
1602 : 1408787 : if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1603 : 187171 : byref = gfc_return_by_reference (sym->ns->proc_name);
1604 : : else
1605 : : byref = 0;
1606 : :
1607 : : /* Make sure that the vtab for the declared type is completed. */
1608 : 1408787 : if (sym->ts.type == BT_CLASS)
1609 : : {
1610 : 75822 : gfc_component *c = CLASS_DATA (sym);
1611 : 75822 : if (!c->ts.u.derived->backend_decl)
1612 : : {
1613 : 2290 : gfc_find_derived_vtab (c->ts.u.derived);
1614 : 2290 : gfc_get_derived_type (sym->ts.u.derived);
1615 : : }
1616 : : }
1617 : :
1618 : : /* PDT parameterized array components and string_lengths must have the
1619 : : 'len' parameters substituted for the expressions appearing in the
1620 : : declaration of the entity and memory allocated/deallocated. */
1621 : 1408787 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1622 : 275062 : && sym->param_list != NULL
1623 : 1884 : && gfc_current_ns == sym->ns
1624 : 1199 : && !(sym->attr.use_assoc || sym->attr.dummy))
1625 : 1199 : gfc_defer_symbol_init (sym);
1626 : :
1627 : : /* Dummy PDT 'len' parameters should be checked when they are explicit. */
1628 : 1408787 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1629 : 275062 : && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1630 : 9865 : && sym->param_list != NULL
1631 : 408 : && sym->attr.dummy)
1632 : 180 : gfc_defer_symbol_init (sym);
1633 : :
1634 : : /* All deferred character length procedures need to retain the backend
1635 : : decl, which is a pointer to the character length in the caller's
1636 : : namespace and to declare a local character length. */
1637 : 1408787 : if (!byref && sym->attr.function
1638 : 18821 : && sym->ts.type == BT_CHARACTER
1639 : 1184 : && sym->ts.deferred
1640 : 221 : && sym->ts.u.cl->passed_length == NULL
1641 : 9 : && sym->ts.u.cl->backend_decl
1642 : 0 : && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1643 : : {
1644 : 0 : sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1645 : 0 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)));
1646 : 0 : sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
1647 : : }
1648 : :
1649 : 16520 : fun_or_res = byref && (sym->attr.result
1650 : 13126 : || (sym->attr.function && sym->ts.deferred));
1651 : 1408787 : if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
1652 : : {
1653 : : /* Return via extra parameter. */
1654 : 282159 : if (sym->attr.result && byref
1655 : 3394 : && !sym->backend_decl)
1656 : : {
1657 : 2196 : sym->backend_decl =
1658 : 1098 : DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1659 : : /* For entry master function skip over the __entry
1660 : : argument. */
1661 : 1098 : if (sym->ns->proc_name->attr.entry_master)
1662 : 83 : sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1663 : : }
1664 : :
1665 : : /* Dummy variables should already have been created. */
1666 : 282159 : gcc_assert (sym->backend_decl);
1667 : :
1668 : : /* However, the string length of deferred arrays must be set. */
1669 : 282159 : if (sym->ts.type == BT_CHARACTER
1670 : 27062 : && sym->ts.deferred
1671 : : && sym->attr.dimension
1672 : 3040 : && sym->attr.allocatable)
1673 : 460 : gfc_defer_symbol_init (sym);
1674 : :
1675 : 282159 : if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS)
1676 : 9223 : GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
1677 : :
1678 : : /* Create a character length variable. */
1679 : 282159 : if (sym->ts.type == BT_CHARACTER)
1680 : : {
1681 : : /* For a deferred dummy, make a new string length variable. */
1682 : 27062 : if (sym->ts.deferred
1683 : 3040 : &&
1684 : 3040 : (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1685 : 0 : sym->ts.u.cl->backend_decl = NULL_TREE;
1686 : :
1687 : 27062 : if (sym->ts.deferred && byref)
1688 : : {
1689 : : /* The string length of a deferred char array is stored in the
1690 : : parameter at sym->ts.u.cl->backend_decl as a reference and
1691 : : marked as a result. Exempt this variable from generating a
1692 : : temporary for it. */
1693 : 707 : if (sym->attr.result)
1694 : : {
1695 : : /* We need to insert a indirect ref for param decls. */
1696 : 620 : if (sym->ts.u.cl->backend_decl
1697 : 620 : && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1698 : : {
1699 : 0 : sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1700 : 0 : sym->ts.u.cl->backend_decl =
1701 : 0 : build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
1702 : : }
1703 : : }
1704 : : /* For all other parameters make sure, that they are copied so
1705 : : that the value and any modifications are local to the routine
1706 : : by generating a temporary variable. */
1707 : 87 : else if (sym->attr.function
1708 : 75 : && sym->ts.u.cl->passed_length == NULL
1709 : 0 : && sym->ts.u.cl->backend_decl)
1710 : : {
1711 : 0 : sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1712 : 0 : if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)))
1713 : 0 : sym->ts.u.cl->backend_decl
1714 : 0 : = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
1715 : : else
1716 : 0 : sym->ts.u.cl->backend_decl = NULL_TREE;
1717 : : }
1718 : : }
1719 : :
1720 : 27062 : if (sym->ts.u.cl->backend_decl == NULL_TREE)
1721 : 1 : length = gfc_create_string_length (sym);
1722 : : else
1723 : 27061 : length = sym->ts.u.cl->backend_decl;
1724 : 27062 : if (VAR_P (length) && DECL_FILE_SCOPE_P (length))
1725 : : {
1726 : : /* Add the string length to the same context as the symbol. */
1727 : 674 : if (DECL_CONTEXT (length) == NULL_TREE)
1728 : : {
1729 : 674 : if (sym->backend_decl == current_function_decl
1730 : 674 : || (DECL_CONTEXT (sym->backend_decl)
1731 : : == current_function_decl))
1732 : 673 : gfc_add_decl_to_function (length);
1733 : : else
1734 : 1 : gfc_add_decl_to_parent_function (length);
1735 : : }
1736 : :
1737 : 674 : gcc_assert (sym->backend_decl == current_function_decl
1738 : : ? DECL_CONTEXT (length) == current_function_decl
1739 : : : (DECL_CONTEXT (sym->backend_decl)
1740 : : == DECL_CONTEXT (length)));
1741 : :
1742 : 674 : gfc_defer_symbol_init (sym);
1743 : : }
1744 : : }
1745 : :
1746 : : /* Use a copy of the descriptor for dummy arrays. */
1747 : 282159 : if ((sym->attr.dimension || sym->attr.codimension)
1748 : 95045 : && !TREE_USED (sym->backend_decl))
1749 : : {
1750 : 16971 : decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1751 : : /* Prevent the dummy from being detected as unused if it is copied. */
1752 : 16971 : if (sym->backend_decl != NULL && decl != sym->backend_decl)
1753 : 5047 : DECL_ARTIFICIAL (sym->backend_decl) = 1;
1754 : 16971 : sym->backend_decl = decl;
1755 : : }
1756 : :
1757 : : /* Returning the descriptor for dummy class arrays is hazardous, because
1758 : : some caller is expecting an expression to apply the component refs to.
1759 : : Therefore the descriptor is only created and stored in
1760 : : sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then
1761 : : responsible to extract it from there, when the descriptor is
1762 : : desired. */
1763 : 23813 : if (IS_CLASS_COARRAY_OR_ARRAY (sym)
1764 : 291547 : && (!DECL_LANG_SPECIFIC (sym->backend_decl)
1765 : 7232 : || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)))
1766 : : {
1767 : 3927 : decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1768 : : /* Prevent the dummy from being detected as unused if it is copied. */
1769 : 3927 : if (sym->backend_decl != NULL && decl != sym->backend_decl)
1770 : 739 : DECL_ARTIFICIAL (sym->backend_decl) = 1;
1771 : 3927 : sym->backend_decl = decl;
1772 : : }
1773 : :
1774 : 282159 : TREE_USED (sym->backend_decl) = 1;
1775 : 282159 : if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1776 : 6 : gfc_add_assign_aux_vars (sym);
1777 : :
1778 : 282159 : if (sym->ts.type == BT_CLASS && sym->backend_decl
1779 : 23813 : && !IS_CLASS_COARRAY_OR_ARRAY (sym))
1780 : 14425 : GFC_DECL_CLASS (sym->backend_decl) = 1;
1781 : :
1782 : 282159 : return sym->backend_decl;
1783 : : }
1784 : :
1785 : 18777 : if (sym->result == sym && sym->attr.assign
1786 : 1126633 : && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1787 : 1 : gfc_add_assign_aux_vars (sym);
1788 : :
1789 : 1126628 : if (sym->backend_decl)
1790 : : return sym->backend_decl;
1791 : :
1792 : : /* Special case for array-valued named constants from intrinsic
1793 : : procedures; those are inlined. */
1794 : 172940 : if (sym->attr.use_assoc && sym->attr.flavor == FL_PARAMETER
1795 : 126 : && (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
1796 : 126 : || sym->from_intmod == INTMOD_ISO_C_BINDING))
1797 : 172940 : intrinsic_array_parameter = true;
1798 : :
1799 : : /* If use associated compilation, use the module
1800 : : declaration. */
1801 : 172940 : if ((sym->attr.flavor == FL_VARIABLE
1802 : 14787 : || sym->attr.flavor == FL_PARAMETER)
1803 : 159434 : && (sym->attr.use_assoc || sym->attr.used_in_submodule)
1804 : 2556 : && !intrinsic_array_parameter
1805 : 2547 : && sym->module
1806 : 175487 : && gfc_get_module_backend_decl (sym))
1807 : : {
1808 : 2418 : if (sym->ts.type == BT_CLASS && sym->backend_decl)
1809 : 25 : GFC_DECL_CLASS(sym->backend_decl) = 1;
1810 : 2418 : return sym->backend_decl;
1811 : : }
1812 : :
1813 : 170522 : if (sym->attr.flavor == FL_PROCEDURE)
1814 : : {
1815 : : /* Catch functions. Only used for actual parameters,
1816 : : procedure pointers and procptr initialization targets. */
1817 : 13506 : if (sym->attr.use_assoc
1818 : : || sym->attr.used_in_submodule
1819 : 13506 : || sym->attr.intrinsic
1820 : 11481 : || sym->attr.if_source != IFSRC_DECL)
1821 : : {
1822 : 2842 : decl = gfc_get_extern_function_decl (sym);
1823 : : }
1824 : : else
1825 : : {
1826 : 10664 : if (!sym->backend_decl)
1827 : 10664 : build_function_decl (sym, false);
1828 : 10664 : decl = sym->backend_decl;
1829 : : }
1830 : 13506 : return decl;
1831 : : }
1832 : :
1833 : 157016 : if (sym->ts.type == BT_UNKNOWN)
1834 : 0 : gfc_fatal_error ("%s at %L has no default type", sym->name,
1835 : : &sym->declared_at);
1836 : :
1837 : 157016 : if (sym->attr.intrinsic)
1838 : 0 : gfc_internal_error ("intrinsic variable which isn't a procedure");
1839 : :
1840 : : /* Create string length decl first so that they can be used in the
1841 : : type declaration. For associate names, the target character
1842 : : length is used. Set 'length' to a constant so that if the
1843 : : string length is a variable, it is not finished a second time. */
1844 : 157016 : if (sym->ts.type == BT_CHARACTER)
1845 : : {
1846 : 14995 : if (sym->attr.associate_var
1847 : 1625 : && sym->ts.deferred
1848 : 320 : && sym->assoc && sym->assoc->target
1849 : 320 : && ((sym->assoc->target->expr_type == EXPR_VARIABLE
1850 : 210 : && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER)
1851 : 277 : || sym->assoc->target->expr_type != EXPR_VARIABLE))
1852 : 153 : sym->ts.u.cl->backend_decl = NULL_TREE;
1853 : :
1854 : 14995 : if (sym->attr.associate_var
1855 : 1625 : && sym->ts.u.cl->backend_decl
1856 : 627 : && (VAR_P (sym->ts.u.cl->backend_decl)
1857 : 362 : || TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL))
1858 : 313 : length = gfc_index_zero_node;
1859 : : else
1860 : 14682 : length = gfc_create_string_length (sym);
1861 : : }
1862 : :
1863 : : /* Create the decl for the variable. */
1864 : 157016 : decl = build_decl (gfc_get_location (&sym->declared_at),
1865 : : VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1866 : :
1867 : : /* Add attributes to variables. Functions are handled elsewhere. */
1868 : 157016 : attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1869 : 157016 : decl_attributes (&decl, attributes, 0);
1870 : 157016 : if (sym->ts.deferred && VAR_P (length))
1871 : 1531 : decl_attributes (&length, attributes, 0);
1872 : :
1873 : : /* Symbols from modules should have their assembler names mangled.
1874 : : This is done here rather than in gfc_finish_var_decl because it
1875 : : is different for string length variables. */
1876 : 157016 : if (sym->module || sym->fn_result_spec)
1877 : : {
1878 : 17314 : gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1879 : 17314 : if (sym->attr.use_assoc && !intrinsic_array_parameter)
1880 : 129 : DECL_IGNORED_P (decl) = 1;
1881 : : }
1882 : :
1883 : 157016 : if (sym->attr.select_type_temporary)
1884 : : {
1885 : 4714 : DECL_ARTIFICIAL (decl) = 1;
1886 : 4714 : DECL_IGNORED_P (decl) = 1;
1887 : : }
1888 : :
1889 : 157016 : if (sym->attr.dimension || sym->attr.codimension)
1890 : : {
1891 : : /* Create variables to hold the non-constant bits of array info. */
1892 : 40618 : gfc_build_qualified_array (decl, sym);
1893 : :
1894 : 40618 : if (sym->attr.contiguous
1895 : 40556 : || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1896 : 36289 : GFC_DECL_PACKED_ARRAY (decl) = 1;
1897 : : }
1898 : :
1899 : : /* Remember this variable for allocation/cleanup. */
1900 : 157016 : if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
1901 : 114330 : || (sym->ts.type == BT_CLASS &&
1902 : 4336 : (CLASS_DATA (sym)->attr.dimension
1903 : 4336 : || CLASS_DATA (sym)->attr.allocatable))
1904 : 111137 : || (sym->ts.type == BT_DERIVED
1905 : 26217 : && (sym->ts.u.derived->attr.alloc_comp
1906 : 21163 : || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
1907 : 4596 : && !sym->ns->proc_name->attr.is_main_program
1908 : 1779 : && gfc_is_finalizable (sym->ts.u.derived, NULL))))
1909 : : /* This applies a derived type default initializer. */
1910 : 262912 : || (sym->ts.type == BT_DERIVED
1911 : : && sym->attr.save == SAVE_NONE
1912 : : && !sym->attr.data
1913 : 20976 : && !sym->attr.allocatable
1914 : 5771 : && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1915 : 421 : && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1916 : 51541 : gfc_defer_symbol_init (sym);
1917 : :
1918 : : /* Set the vptr of unlimited polymorphic pointer variables so that
1919 : : they do not cause segfaults in select type, when the selector
1920 : : is an intrinsic type. Arrays are captured above. */
1921 : 157016 : if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
1922 : : && CLASS_DATA (sym)->attr.class_pointer
1923 : 961 : && !CLASS_DATA (sym)->attr.dimension && !sym->attr.dummy
1924 : 277 : && sym->attr.flavor == FL_VARIABLE && !sym->assoc)
1925 : 155 : gfc_defer_symbol_init (sym);
1926 : :
1927 : 157016 : if (sym->ts.type == BT_CHARACTER
1928 : : && sym->attr.allocatable
1929 : 14995 : && !sym->attr.dimension
1930 : 851 : && sym->ts.u.cl && sym->ts.u.cl->length
1931 : 178 : && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE)
1932 : 25 : gfc_defer_symbol_init (sym);
1933 : :
1934 : : /* Associate names can use the hidden string length variable
1935 : : of their associated target. */
1936 : 157016 : if (sym->ts.type == BT_CHARACTER
1937 : 14995 : && TREE_CODE (length) != INTEGER_CST
1938 : 2901 : && TREE_CODE (sym->ts.u.cl->backend_decl) != INDIRECT_REF)
1939 : : {
1940 : 2841 : length = fold_convert (gfc_charlen_type_node, length);
1941 : 2841 : gfc_finish_var_decl (length, sym);
1942 : 2841 : if (!sym->attr.associate_var
1943 : 1903 : && VAR_P (length)
1944 : 1903 : && sym->value && sym->value->expr_type != EXPR_NULL
1945 : 6 : && sym->value->ts.u.cl->length)
1946 : : {
1947 : 6 : gfc_expr *len = sym->value->ts.u.cl->length;
1948 : 6 : DECL_INITIAL (length) = gfc_conv_initializer (len, &len->ts,
1949 : 6 : TREE_TYPE (length),
1950 : : false, false, false);
1951 : 6 : DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node,
1952 : : DECL_INITIAL (length));
1953 : 6 : }
1954 : : else
1955 : 2835 : gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
1956 : : }
1957 : :
1958 : 157016 : gfc_finish_var_decl (decl, sym);
1959 : :
1960 : 157016 : if (sym->ts.type == BT_CHARACTER)
1961 : : /* Character variables need special handling. */
1962 : 14995 : gfc_allocate_lang_decl (decl);
1963 : :
1964 : 157016 : if (sym->assoc && sym->attr.subref_array_pointer)
1965 : 348 : sym->attr.pointer = 1;
1966 : :
1967 : 157016 : if (sym->attr.pointer && sym->attr.dimension
1968 : 4493 : && !sym->ts.deferred
1969 : 4268 : && !(sym->attr.select_type_temporary
1970 : 972 : && !sym->attr.subref_array_pointer))
1971 : 3440 : GFC_DECL_PTR_ARRAY_P (decl) = 1;
1972 : :
1973 : 157016 : if (sym->ts.type == BT_CLASS)
1974 : 4336 : GFC_DECL_CLASS(decl) = 1;
1975 : :
1976 : 157016 : sym->backend_decl = decl;
1977 : :
1978 : 157016 : if (sym->attr.assign)
1979 : 59 : gfc_add_assign_aux_vars (sym);
1980 : :
1981 : 157016 : if (intrinsic_array_parameter)
1982 : : {
1983 : 9 : TREE_STATIC (decl) = 1;
1984 : 9 : DECL_EXTERNAL (decl) = 0;
1985 : : }
1986 : :
1987 : 157016 : if (TREE_STATIC (decl)
1988 : 35162 : && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1989 : 35162 : && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1990 : 1670 : || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
1991 : 1631 : || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1992 : 35025 : && (flag_coarray != GFC_FCOARRAY_LIB
1993 : 380 : || !sym->attr.codimension || sym->attr.allocatable)
1994 : 34802 : && !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
1995 : 191569 : && !(sym->ts.type == BT_CLASS
1996 : 1569 : && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type))
1997 : : {
1998 : : /* Add static initializer. For procedures, it is only needed if
1999 : : SAVE is specified otherwise they need to be reinitialized
2000 : : every time the procedure is entered. The TREE_STATIC is
2001 : : in this case due to -fmax-stack-var-size=. */
2002 : :
2003 : 34546 : DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
2004 : 34546 : TREE_TYPE (decl), sym->attr.dimension
2005 : 34546 : || (sym->attr.codimension
2006 : 29012 : && sym->attr.allocatable),
2007 : 34546 : sym->attr.pointer || sym->attr.allocatable
2008 : 33761 : || sym->ts.type == BT_CLASS,
2009 : 34546 : sym->attr.proc_pointer);
2010 : : }
2011 : :
2012 : 157016 : if (!TREE_STATIC (decl)
2013 : 121854 : && POINTER_TYPE_P (TREE_TYPE (decl))
2014 : : && !sym->attr.pointer
2015 : : && !sym->attr.allocatable
2016 : 15646 : && !sym->attr.proc_pointer
2017 : 165648 : && !sym->attr.select_type_temporary)
2018 : 6950 : DECL_BY_REFERENCE (decl) = 1;
2019 : :
2020 : 157016 : if (sym->attr.associate_var)
2021 : 6549 : GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
2022 : :
2023 : : /* We only longer mark __def_init as read-only if it actually has an
2024 : : initializer, it does not needlessly take up space in the
2025 : : read-only section and can go into the BSS instead, see PR 84487.
2026 : : Marking this as artificial means that OpenMP will treat this as
2027 : : predetermined shared. */
2028 : :
2029 : 157016 : bool def_init = startswith (sym->name, "__def_init");
2030 : :
2031 : 157016 : if (sym->attr.vtab || def_init)
2032 : : {
2033 : 17191 : DECL_ARTIFICIAL (decl) = 1;
2034 : 17191 : if (def_init && sym->value)
2035 : 2935 : TREE_READONLY (decl) = 1;
2036 : : }
2037 : :
2038 : 157016 : return decl;
2039 : : }
2040 : :
2041 : :
2042 : : /* Substitute a temporary variable in place of the real one. */
2043 : :
2044 : : void
2045 : 5629 : gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
2046 : : {
2047 : 5629 : save->attr = sym->attr;
2048 : 5629 : save->decl = sym->backend_decl;
2049 : :
2050 : 5629 : gfc_clear_attr (&sym->attr);
2051 : 5629 : sym->attr.referenced = 1;
2052 : 5629 : sym->attr.flavor = FL_VARIABLE;
2053 : :
2054 : 5629 : sym->backend_decl = decl;
2055 : 5629 : }
2056 : :
2057 : :
2058 : : /* Restore the original variable. */
2059 : :
2060 : : void
2061 : 5629 : gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
2062 : : {
2063 : 5629 : sym->attr = save->attr;
2064 : 5629 : sym->backend_decl = save->decl;
2065 : 5629 : }
2066 : :
2067 : :
2068 : : /* Declare a procedure pointer. */
2069 : :
2070 : : static tree
2071 : 674 : get_proc_pointer_decl (gfc_symbol *sym)
2072 : : {
2073 : 674 : tree decl;
2074 : 674 : tree attributes;
2075 : :
2076 : 674 : if (sym->module || sym->fn_result_spec)
2077 : : {
2078 : 149 : const char *name;
2079 : 149 : gfc_gsymbol *gsym;
2080 : :
2081 : 149 : name = mangled_identifier (sym);
2082 : 149 : gsym = gfc_find_gsymbol (gfc_gsym_root, name);
2083 : 149 : if (gsym != NULL)
2084 : : {
2085 : 79 : gfc_symbol *s;
2086 : 79 : gfc_find_symbol (sym->name, gsym->ns, 0, &s);
2087 : 79 : if (s && s->backend_decl)
2088 : 79 : return s->backend_decl;
2089 : : }
2090 : : }
2091 : :
2092 : 595 : decl = sym->backend_decl;
2093 : 595 : if (decl)
2094 : : return decl;
2095 : :
2096 : 595 : decl = build_decl (input_location,
2097 : : VAR_DECL, get_identifier (sym->name),
2098 : : build_pointer_type (gfc_get_function_type (sym)));
2099 : :
2100 : 595 : if (sym->module)
2101 : : {
2102 : : /* Apply name mangling. */
2103 : 70 : gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
2104 : 70 : if (sym->attr.use_assoc)
2105 : 0 : DECL_IGNORED_P (decl) = 1;
2106 : : }
2107 : :
2108 : 595 : if ((sym->ns->proc_name
2109 : 595 : && sym->ns->proc_name->backend_decl == current_function_decl)
2110 : 76 : || sym->attr.contained)
2111 : 519 : gfc_add_decl_to_function (decl);
2112 : 76 : else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
2113 : 6 : gfc_add_decl_to_parent_function (decl);
2114 : :
2115 : 595 : sym->backend_decl = decl;
2116 : :
2117 : : /* If a variable is USE associated, it's always external. */
2118 : 595 : if (sym->attr.use_assoc)
2119 : : {
2120 : 0 : DECL_EXTERNAL (decl) = 1;
2121 : 0 : TREE_PUBLIC (decl) = 1;
2122 : : }
2123 : 595 : else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
2124 : : {
2125 : : /* This is the declaration of a module variable. */
2126 : 70 : TREE_PUBLIC (decl) = 1;
2127 : 70 : if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
2128 : : {
2129 : 8 : DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
2130 : 8 : DECL_VISIBILITY_SPECIFIED (decl) = true;
2131 : : }
2132 : 70 : TREE_STATIC (decl) = 1;
2133 : : }
2134 : :
2135 : 595 : if (!sym->attr.use_assoc
2136 : 595 : && (sym->attr.save != SAVE_NONE || sym->attr.data
2137 : 476 : || (sym->value && sym->ns->proc_name->attr.is_main_program)))
2138 : 119 : TREE_STATIC (decl) = 1;
2139 : :
2140 : 595 : if (TREE_STATIC (decl) && sym->value)
2141 : : {
2142 : : /* Add static initializer. */
2143 : 79 : DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
2144 : 79 : TREE_TYPE (decl),
2145 : 79 : sym->attr.dimension,
2146 : : false, true);
2147 : : }
2148 : :
2149 : : /* Handle threadprivate procedure pointers. */
2150 : 595 : if (sym->attr.threadprivate
2151 : 595 : && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
2152 : 12 : set_decl_tls_model (decl, decl_default_tls_model (decl));
2153 : :
2154 : 595 : attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
2155 : 595 : decl_attributes (&decl, attributes, 0);
2156 : :
2157 : 595 : return decl;
2158 : : }
2159 : :
2160 : :
2161 : : /* Get a basic decl for an external function. */
2162 : :
2163 : : tree
2164 : 33230 : gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args,
2165 : : const char *fnspec)
2166 : : {
2167 : 33230 : tree type;
2168 : 33230 : tree fndecl;
2169 : 33230 : tree attributes;
2170 : 33230 : gfc_expr e;
2171 : 33230 : gfc_intrinsic_sym *isym;
2172 : 33230 : gfc_expr argexpr;
2173 : 33230 : char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
2174 : 33230 : tree name;
2175 : 33230 : tree mangled_name;
2176 : 33230 : gfc_gsymbol *gsym;
2177 : :
2178 : 33230 : if (sym->backend_decl)
2179 : : return sym->backend_decl;
2180 : :
2181 : : /* We should never be creating external decls for alternate entry points.
2182 : : The procedure may be an alternate entry point, but we don't want/need
2183 : : to know that. */
2184 : 33230 : gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
2185 : :
2186 : 33230 : if (sym->attr.proc_pointer)
2187 : 674 : return get_proc_pointer_decl (sym);
2188 : :
2189 : : /* See if this is an external procedure from the same file. If so,
2190 : : return the backend_decl. If we are looking at a BIND(C)
2191 : : procedure and the symbol is not BIND(C), or vice versa, we
2192 : : haven't found the right procedure. */
2193 : :
2194 : 32556 : if (sym->binding_label)
2195 : : {
2196 : 2472 : gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
2197 : 2472 : if (gsym && !gsym->bind_c)
2198 : : gsym = NULL;
2199 : : }
2200 : 30084 : else if (sym->module == NULL)
2201 : : {
2202 : 17584 : gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
2203 : 17584 : if (gsym && gsym->bind_c)
2204 : : gsym = NULL;
2205 : : }
2206 : : else
2207 : : {
2208 : : /* Procedure from a different module. */
2209 : : gsym = NULL;
2210 : : }
2211 : :
2212 : 10731 : if (gsym && !gsym->defined)
2213 : : gsym = NULL;
2214 : :
2215 : : /* This can happen because of C binding. */
2216 : 7703 : if (gsym && gsym->ns && gsym->ns->proc_name
2217 : 7703 : && gsym->ns->proc_name->attr.flavor == FL_MODULE)
2218 : 555 : goto module_sym;
2219 : :
2220 : 32001 : if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
2221 : 22958 : && !sym->backend_decl
2222 : 22958 : && gsym && gsym->ns
2223 : 7148 : && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
2224 : 7148 : && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
2225 : : {
2226 : 7148 : if (!gsym->ns->proc_name->backend_decl)
2227 : : {
2228 : : /* By construction, the external function cannot be
2229 : : a contained procedure. */
2230 : 745 : locus old_loc;
2231 : :
2232 : 745 : gfc_save_backend_locus (&old_loc);
2233 : 745 : push_cfun (NULL);
2234 : :
2235 : 745 : gfc_create_function_decl (gsym->ns, true);
2236 : :
2237 : 745 : pop_cfun ();
2238 : 745 : gfc_restore_backend_locus (&old_loc);
2239 : : }
2240 : :
2241 : : /* If the namespace has entries, the proc_name is the
2242 : : entry master. Find the entry and use its backend_decl.
2243 : : otherwise, use the proc_name backend_decl. */
2244 : 7148 : if (gsym->ns->entries)
2245 : : {
2246 : : gfc_entry_list *entry = gsym->ns->entries;
2247 : :
2248 : 1315 : for (; entry; entry = entry->next)
2249 : : {
2250 : 1315 : if (strcmp (gsym->name, entry->sym->name) == 0)
2251 : : {
2252 : 797 : sym->backend_decl = entry->sym->backend_decl;
2253 : 797 : break;
2254 : : }
2255 : : }
2256 : : }
2257 : : else
2258 : 6351 : sym->backend_decl = gsym->ns->proc_name->backend_decl;
2259 : :
2260 : 7148 : if (sym->backend_decl)
2261 : : {
2262 : : /* Avoid problems of double deallocation of the backend declaration
2263 : : later in gfc_trans_use_stmts; cf. PR 45087. */
2264 : 7148 : if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
2265 : 0 : sym->attr.use_assoc = 0;
2266 : :
2267 : 7148 : return sym->backend_decl;
2268 : : }
2269 : : }
2270 : :
2271 : : /* See if this is a module procedure from the same file. If so,
2272 : : return the backend_decl. */
2273 : 24853 : if (sym->module)
2274 : 13300 : gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
2275 : :
2276 : 25408 : module_sym:
2277 : 25408 : if (gsym && gsym->ns
2278 : 10671 : && (gsym->type == GSYM_MODULE
2279 : 555 : || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
2280 : : {
2281 : 10671 : gfc_symbol *s;
2282 : :
2283 : 10671 : s = NULL;
2284 : 10671 : if (gsym->type == GSYM_MODULE)
2285 : 10116 : gfc_find_symbol (sym->name, gsym->ns, 0, &s);
2286 : : else
2287 : 555 : gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
2288 : :
2289 : 10671 : if (s && s->backend_decl)
2290 : : {
2291 : 8843 : if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
2292 : 965 : gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
2293 : : true);
2294 : 7878 : else if (sym->ts.type == BT_CHARACTER)
2295 : 348 : sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
2296 : 8843 : sym->backend_decl = s->backend_decl;
2297 : 8843 : return sym->backend_decl;
2298 : : }
2299 : : }
2300 : :
2301 : 16565 : if (sym->attr.intrinsic)
2302 : : {
2303 : : /* Call the resolution function to get the actual name. This is
2304 : : a nasty hack which relies on the resolution functions only looking
2305 : : at the first argument. We pass NULL for the second argument
2306 : : otherwise things like AINT get confused. */
2307 : 1293 : isym = gfc_find_function (sym->name);
2308 : 1293 : gcc_assert (isym->resolve.f0 != NULL);
2309 : :
2310 : 1293 : memset (&e, 0, sizeof (e));
2311 : 1293 : e.expr_type = EXPR_FUNCTION;
2312 : :
2313 : 1293 : memset (&argexpr, 0, sizeof (argexpr));
2314 : 1293 : gcc_assert (isym->formal);
2315 : 1293 : argexpr.ts = isym->formal->ts;
2316 : :
2317 : 1293 : if (isym->formal->next == NULL)
2318 : 1045 : isym->resolve.f1 (&e, &argexpr);
2319 : : else
2320 : : {
2321 : 248 : if (isym->formal->next->next == NULL)
2322 : 232 : isym->resolve.f2 (&e, &argexpr, NULL);
2323 : : else
2324 : : {
2325 : 16 : if (isym->formal->next->next->next == NULL)
2326 : 0 : isym->resolve.f3 (&e, &argexpr, NULL, NULL);
2327 : : else
2328 : : {
2329 : : /* All specific intrinsics take less than 5 arguments. */
2330 : 16 : gcc_assert (isym->formal->next->next->next->next == NULL);
2331 : 16 : isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
2332 : : }
2333 : : }
2334 : : }
2335 : :
2336 : 1293 : if (flag_f2c
2337 : 438 : && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
2338 : 300 : || e.ts.type == BT_COMPLEX))
2339 : : {
2340 : : /* Specific which needs a different implementation if f2c
2341 : : calling conventions are used. */
2342 : 240 : sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
2343 : : }
2344 : : else
2345 : 1053 : sprintf (s, "_gfortran_specific%s", e.value.function.name);
2346 : :
2347 : 1293 : name = get_identifier (s);
2348 : 1293 : mangled_name = name;
2349 : : }
2350 : : else
2351 : : {
2352 : 15272 : name = gfc_sym_identifier (sym);
2353 : 15272 : mangled_name = gfc_sym_mangled_function_id (sym);
2354 : : }
2355 : :
2356 : 16565 : type = gfc_get_function_type (sym, actual_args, fnspec);
2357 : :
2358 : 16565 : fndecl = build_decl (input_location,
2359 : : FUNCTION_DECL, name, type);
2360 : :
2361 : : /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2362 : : TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2363 : : the opposite of declaring a function as static in C). */
2364 : 16565 : DECL_EXTERNAL (fndecl) = 1;
2365 : 16565 : TREE_PUBLIC (fndecl) = 1;
2366 : :
2367 : 16565 : attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
2368 : 16565 : decl_attributes (&fndecl, attributes, 0);
2369 : :
2370 : 16565 : gfc_set_decl_assembler_name (fndecl, mangled_name);
2371 : :
2372 : : /* Set the context of this decl. */
2373 : 16565 : if (0 && sym->ns && sym->ns->proc_name)
2374 : : {
2375 : : /* TODO: Add external decls to the appropriate scope. */
2376 : : DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
2377 : : }
2378 : : else
2379 : : {
2380 : : /* Global declaration, e.g. intrinsic subroutine. */
2381 : 16565 : DECL_CONTEXT (fndecl) = NULL_TREE;
2382 : : }
2383 : :
2384 : : /* Set attributes for PURE functions. A call to PURE function in the
2385 : : Fortran 95 sense is both pure and without side effects in the C
2386 : : sense. */
2387 : 16565 : if (sym->attr.pure || sym->attr.implicit_pure)
2388 : : {
2389 : 1990 : if (sym->attr.function && !gfc_return_by_reference (sym))
2390 : 1872 : DECL_PURE_P (fndecl) = 1;
2391 : : /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
2392 : : parameters and don't use alternate returns (is this
2393 : : allowed?). In that case, calls to them are meaningless, and
2394 : : can be optimized away. See also in build_function_decl(). */
2395 : 1990 : TREE_SIDE_EFFECTS (fndecl) = 0;
2396 : : }
2397 : :
2398 : : /* Mark non-returning functions. */
2399 : 16565 : if (sym->attr.noreturn || sym->attr.ext_attr & (1 << EXT_ATTR_NORETURN))
2400 : 126 : TREE_THIS_VOLATILE(fndecl) = 1;
2401 : :
2402 : 16565 : sym->backend_decl = fndecl;
2403 : :
2404 : 16565 : if (DECL_CONTEXT (fndecl) == NULL_TREE)
2405 : 16565 : pushdecl_top_level (fndecl);
2406 : :
2407 : 16565 : if (sym->formal_ns
2408 : 14517 : && sym->formal_ns->proc_name == sym)
2409 : : {
2410 : 14517 : if (sym->formal_ns->omp_declare_simd)
2411 : 15 : gfc_trans_omp_declare_simd (sym->formal_ns);
2412 : 14517 : if (flag_openmp)
2413 : 1615 : gfc_trans_omp_declare_variant (sym->formal_ns);
2414 : : }
2415 : :
2416 : 16565 : return fndecl;
2417 : : }
2418 : :
2419 : :
2420 : : /* Create a declaration for a procedure. For external functions (in the C
2421 : : sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
2422 : : a master function with alternate entry points. */
2423 : :
2424 : : static void
2425 : 86740 : build_function_decl (gfc_symbol * sym, bool global)
2426 : : {
2427 : 86740 : tree fndecl, type, attributes;
2428 : 86740 : symbol_attribute attr;
2429 : 86740 : tree result_decl;
2430 : 86740 : gfc_formal_arglist *f;
2431 : :
2432 : 173480 : bool module_procedure = sym->attr.module_procedure
2433 : 350 : && sym->ns
2434 : 350 : && sym->ns->proc_name
2435 : 87090 : && sym->ns->proc_name->attr.flavor == FL_MODULE;
2436 : :
2437 : 86740 : gcc_assert (!sym->attr.external || module_procedure);
2438 : :
2439 : 86740 : if (sym->backend_decl)
2440 : 10644 : return;
2441 : :
2442 : : /* Set the line and filename. sym->declared_at seems to point to the
2443 : : last statement for subroutines, but it'll do for now. */
2444 : 76096 : gfc_set_backend_locus (&sym->declared_at);
2445 : :
2446 : : /* Allow only one nesting level. Allow public declarations. */
2447 : 76096 : gcc_assert (current_function_decl == NULL_TREE
2448 : : || DECL_FILE_SCOPE_P (current_function_decl)
2449 : : || (TREE_CODE (DECL_CONTEXT (current_function_decl))
2450 : : == NAMESPACE_DECL));
2451 : :
2452 : 76096 : type = gfc_get_function_type (sym);
2453 : 76096 : fndecl = build_decl (input_location,
2454 : : FUNCTION_DECL, gfc_sym_identifier (sym), type);
2455 : :
2456 : 76096 : attr = sym->attr;
2457 : :
2458 : : /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2459 : : TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2460 : : the opposite of declaring a function as static in C). */
2461 : 76096 : DECL_EXTERNAL (fndecl) = 0;
2462 : :
2463 : 76096 : if (sym->attr.access == ACCESS_UNKNOWN && sym->module
2464 : 21872 : && (sym->ns->default_access == ACCESS_PRIVATE
2465 : 20194 : || (sym->ns->default_access == ACCESS_UNKNOWN
2466 : 20182 : && flag_module_private)))
2467 : 1678 : sym->attr.access = ACCESS_PRIVATE;
2468 : :
2469 : 76096 : if (!current_function_decl
2470 : 58658 : && !sym->attr.entry_master && !sym->attr.is_main_program
2471 : 33156 : && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label
2472 : 1882 : || sym->attr.public_used))
2473 : 32461 : TREE_PUBLIC (fndecl) = 1;
2474 : :
2475 : 76096 : if (sym->attr.referenced || sym->attr.entry_master)
2476 : 32491 : TREE_USED (fndecl) = 1;
2477 : :
2478 : 76096 : attributes = add_attributes_to_decl (attr, NULL_TREE);
2479 : 76096 : decl_attributes (&fndecl, attributes, 0);
2480 : :
2481 : : /* Figure out the return type of the declared function, and build a
2482 : : RESULT_DECL for it. If this is a subroutine with alternate
2483 : : returns, build a RESULT_DECL for it. */
2484 : 76096 : result_decl = NULL_TREE;
2485 : : /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
2486 : 76096 : if (attr.function)
2487 : : {
2488 : 14613 : if (gfc_return_by_reference (sym))
2489 : 2916 : type = void_type_node;
2490 : : else
2491 : : {
2492 : 11697 : if (sym->result != sym)
2493 : 3749 : result_decl = gfc_sym_identifier (sym->result);
2494 : :
2495 : 11697 : type = TREE_TYPE (TREE_TYPE (fndecl));
2496 : : }
2497 : : }
2498 : : else
2499 : : {
2500 : : /* Look for alternate return placeholders. */
2501 : 61483 : int has_alternate_returns = 0;
2502 : 128106 : for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2503 : : {
2504 : 66692 : if (f->sym == NULL)
2505 : : {
2506 : : has_alternate_returns = 1;
2507 : : break;
2508 : : }
2509 : : }
2510 : :
2511 : 61483 : if (has_alternate_returns)
2512 : 69 : type = integer_type_node;
2513 : : else
2514 : 61414 : type = void_type_node;
2515 : : }
2516 : :
2517 : 76096 : result_decl = build_decl (input_location,
2518 : : RESULT_DECL, result_decl, type);
2519 : 76096 : DECL_ARTIFICIAL (result_decl) = 1;
2520 : 76096 : DECL_IGNORED_P (result_decl) = 1;
2521 : 76096 : DECL_CONTEXT (result_decl) = fndecl;
2522 : 76096 : DECL_RESULT (fndecl) = result_decl;
2523 : :
2524 : : /* Don't call layout_decl for a RESULT_DECL.
2525 : : layout_decl (result_decl, 0); */
2526 : :
2527 : : /* TREE_STATIC means the function body is defined here. */
2528 : 76096 : TREE_STATIC (fndecl) = 1;
2529 : :
2530 : : /* Set attributes for PURE functions. A call to a PURE function in the
2531 : : Fortran 95 sense is both pure and without side effects in the C
2532 : : sense. */
2533 : 76096 : if (attr.pure || attr.implicit_pure)
2534 : : {
2535 : : /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
2536 : : including an alternate return. In that case it can also be
2537 : : marked as PURE. See also in gfc_get_extern_function_decl(). */
2538 : 16718 : if (attr.function && !gfc_return_by_reference (sym))
2539 : 4125 : DECL_PURE_P (fndecl) = 1;
2540 : 16718 : TREE_SIDE_EFFECTS (fndecl) = 0;
2541 : : }
2542 : :
2543 : : /* Mark noinline functions. */
2544 : 76096 : if (attr.ext_attr & (1 << EXT_ATTR_NOINLINE))
2545 : 1 : DECL_UNINLINABLE (fndecl) = 1;
2546 : :
2547 : : /* Mark noreturn functions. */
2548 : 76096 : if (attr.ext_attr & (1 << EXT_ATTR_NORETURN))
2549 : 8 : TREE_THIS_VOLATILE (fndecl) = 1;
2550 : :
2551 : : /* Mark weak functions. */
2552 : 76096 : if (attr.ext_attr & (1 << EXT_ATTR_WEAK))
2553 : 6 : declare_weak (fndecl);
2554 : :
2555 : : /* Layout the function declaration and put it in the binding level
2556 : : of the current function. */
2557 : :
2558 : 76096 : if (global)
2559 : 745 : pushdecl_top_level (fndecl);
2560 : : else
2561 : 75351 : pushdecl (fndecl);
2562 : :
2563 : : /* Perform name mangling if this is a top level or module procedure. */
2564 : 76096 : if (current_function_decl == NULL_TREE)
2565 : 58658 : gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
2566 : :
2567 : 76096 : sym->backend_decl = fndecl;
2568 : : }
2569 : :
2570 : :
2571 : : /* Create the DECL_ARGUMENTS for a procedure.
2572 : : NOTE: The arguments added here must match the argument type created by
2573 : : gfc_get_function_type (). */
2574 : :
2575 : : static void
2576 : 76076 : create_function_arglist (gfc_symbol * sym)
2577 : : {
2578 : 76076 : tree fndecl;
2579 : 76076 : gfc_formal_arglist *f;
2580 : 76076 : tree typelist, hidden_typelist, optval_typelist;
2581 : 76076 : tree arglist, hidden_arglist, optval_arglist;
2582 : 76076 : tree type;
2583 : 76076 : tree parm;
2584 : :
2585 : 76076 : fndecl = sym->backend_decl;
2586 : :
2587 : : /* Build formal argument list. Make sure that their TREE_CONTEXT is
2588 : : the new FUNCTION_DECL node. */
2589 : 76076 : arglist = NULL_TREE;
2590 : 76076 : hidden_arglist = NULL_TREE;
2591 : 76076 : optval_arglist = NULL_TREE;
2592 : 76076 : typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
2593 : :
2594 : 76076 : if (sym->attr.entry_master)
2595 : : {
2596 : 632 : type = TREE_VALUE (typelist);
2597 : 632 : parm = build_decl (input_location,
2598 : : PARM_DECL, get_identifier ("__entry"), type);
2599 : :
2600 : 632 : DECL_CONTEXT (parm) = fndecl;
2601 : 632 : DECL_ARG_TYPE (parm) = type;
2602 : 632 : TREE_READONLY (parm) = 1;
2603 : 632 : gfc_finish_decl (parm);
2604 : 632 : DECL_ARTIFICIAL (parm) = 1;
2605 : :
2606 : 632 : arglist = chainon (arglist, parm);
2607 : 632 : typelist = TREE_CHAIN (typelist);
2608 : : }
2609 : :
2610 : 76076 : if (gfc_return_by_reference (sym))
2611 : : {
2612 : 2916 : tree type = TREE_VALUE (typelist), length = NULL;
2613 : :
2614 : 2916 : if (sym->ts.type == BT_CHARACTER)
2615 : : {
2616 : : /* Length of character result. */
2617 : 1492 : tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
2618 : :
2619 : 1492 : length = build_decl (input_location,
2620 : : PARM_DECL,
2621 : : get_identifier (".__result"),
2622 : : len_type);
2623 : 1492 : if (POINTER_TYPE_P (len_type))
2624 : : {
2625 : 228 : sym->ts.u.cl->passed_length = length;
2626 : 228 : TREE_USED (length) = 1;
2627 : : }
2628 : 1264 : else if (!sym->ts.u.cl->length)
2629 : : {
2630 : 156 : sym->ts.u.cl->backend_decl = length;
2631 : 156 : TREE_USED (length) = 1;
2632 : : }
2633 : 1492 : gcc_assert (TREE_CODE (length) == PARM_DECL);
2634 : 1492 : DECL_CONTEXT (length) = fndecl;
2635 : 1492 : DECL_ARG_TYPE (length) = len_type;
2636 : 1492 : TREE_READONLY (length) = 1;
2637 : 1492 : DECL_ARTIFICIAL (length) = 1;
2638 : 1492 : gfc_finish_decl (length);
2639 : 1492 : if (sym->ts.u.cl->backend_decl == NULL
2640 : 571 : || sym->ts.u.cl->backend_decl == length)
2641 : : {
2642 : 1077 : gfc_symbol *arg;
2643 : 1077 : tree backend_decl;
2644 : :
2645 : 1077 : if (sym->ts.u.cl->backend_decl == NULL)
2646 : : {
2647 : 921 : tree len = build_decl (input_location,
2648 : : VAR_DECL,
2649 : : get_identifier ("..__result"),
2650 : : gfc_charlen_type_node);
2651 : 921 : DECL_ARTIFICIAL (len) = 1;
2652 : 921 : TREE_USED (len) = 1;
2653 : 921 : sym->ts.u.cl->backend_decl = len;
2654 : : }
2655 : :
2656 : : /* Make sure PARM_DECL type doesn't point to incomplete type. */
2657 : 1077 : arg = sym->result ? sym->result : sym;
2658 : 1077 : backend_decl = arg->backend_decl;
2659 : : /* Temporary clear it, so that gfc_sym_type creates complete
2660 : : type. */
2661 : 1077 : arg->backend_decl = NULL;
2662 : 1077 : type = gfc_sym_type (arg);
2663 : 1077 : arg->backend_decl = backend_decl;
2664 : 1077 : type = build_reference_type (type);
2665 : : }
2666 : : }
2667 : :
2668 : 2916 : parm = build_decl (input_location,
2669 : : PARM_DECL, get_identifier ("__result"), type);
2670 : :
2671 : 2916 : DECL_CONTEXT (parm) = fndecl;
2672 : 2916 : DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2673 : 2916 : TREE_READONLY (parm) = 1;
2674 : 2916 : DECL_ARTIFICIAL (parm) = 1;
2675 : 2916 : gfc_finish_decl (parm);
2676 : :
2677 : 2916 : arglist = chainon (arglist, parm);
2678 : 2916 : typelist = TREE_CHAIN (typelist);
2679 : :
2680 : 2916 : if (sym->ts.type == BT_CHARACTER)
2681 : : {
2682 : 1492 : gfc_allocate_lang_decl (parm);
2683 : 1492 : arglist = chainon (arglist, length);
2684 : 1492 : typelist = TREE_CHAIN (typelist);
2685 : : }
2686 : : }
2687 : :
2688 : 76076 : hidden_typelist = typelist;
2689 : 163568 : for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2690 : 87492 : if (f->sym != NULL) /* Ignore alternate returns. */
2691 : 87393 : hidden_typelist = TREE_CHAIN (hidden_typelist);
2692 : :
2693 : : /* Advance hidden_typelist over optional+value argument presence flags. */
2694 : 76076 : optval_typelist = hidden_typelist;
2695 : 163568 : for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2696 : 87492 : if (f->sym != NULL
2697 : : && f->sym->attr.optional && f->sym->attr.value
2698 : 87393 : && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
2699 : : && !gfc_bt_struct (f->sym->ts.type))
2700 : 444 : hidden_typelist = TREE_CHAIN (hidden_typelist);
2701 : :
2702 : 163568 : for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2703 : : {
2704 : 87492 : char name[GFC_MAX_SYMBOL_LEN + 2];
2705 : :
2706 : : /* Ignore alternate returns. */
2707 : 87492 : if (f->sym == NULL)
2708 : 99 : continue;
2709 : :
2710 : 87393 : type = TREE_VALUE (typelist);
2711 : :
2712 : 87393 : if (f->sym->ts.type == BT_CHARACTER
2713 : 8706 : && (!sym->attr.is_bind_c || sym->attr.entry_master))
2714 : : {
2715 : 7389 : tree len_type = TREE_VALUE (hidden_typelist);
2716 : 7389 : tree length = NULL_TREE;
2717 : 7389 : if (!f->sym->ts.deferred)
2718 : 6916 : gcc_assert (len_type == gfc_charlen_type_node);
2719 : : else
2720 : 473 : gcc_assert (POINTER_TYPE_P (len_type));
2721 : :
2722 : 7389 : strcpy (&name[1], f->sym->name);
2723 : 7389 : name[0] = '_';
2724 : 7389 : length = build_decl (input_location,
2725 : : PARM_DECL, get_identifier (name), len_type);
2726 : :
2727 : 7389 : hidden_arglist = chainon (hidden_arglist, length);
2728 : 7389 : DECL_CONTEXT (length) = fndecl;
2729 : 7389 : DECL_ARTIFICIAL (length) = 1;
2730 : 7389 : DECL_ARG_TYPE (length) = len_type;
2731 : 7389 : TREE_READONLY (length) = 1;
2732 : 7389 : gfc_finish_decl (length);
2733 : :
2734 : : /* Marking the length DECL_HIDDEN_STRING_LENGTH will lead
2735 : : to tail calls being disabled. Only do that if we
2736 : : potentially have broken callers. */
2737 : 7389 : if (flag_tail_call_workaround
2738 : 7389 : && f->sym->ts.u.cl
2739 : 6943 : && f->sym->ts.u.cl->length
2740 : 2334 : && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2741 : 2069 : && (flag_tail_call_workaround == 2
2742 : 2069 : || f->sym->ns->implicit_interface_calls))
2743 : 94 : DECL_HIDDEN_STRING_LENGTH (length) = 1;
2744 : :
2745 : : /* Remember the passed value. */
2746 : 7389 : if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
2747 : : {
2748 : : /* This can happen if the same type is used for multiple
2749 : : arguments. We need to copy cl as otherwise
2750 : : cl->passed_length gets overwritten. */
2751 : 536 : f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2752 : : }
2753 : 7389 : f->sym->ts.u.cl->passed_length = length;
2754 : :
2755 : : /* Use the passed value for assumed length variables. */
2756 : 7389 : if (!f->sym->ts.u.cl->length)
2757 : : {
2758 : 5055 : TREE_USED (length) = 1;
2759 : 5055 : gcc_assert (!f->sym->ts.u.cl->backend_decl);
2760 : 5055 : f->sym->ts.u.cl->backend_decl = length;
2761 : : }
2762 : :
2763 : 7389 : hidden_typelist = TREE_CHAIN (hidden_typelist);
2764 : :
2765 : 7389 : if (f->sym->ts.u.cl->backend_decl == NULL
2766 : 7091 : || f->sym->ts.u.cl->backend_decl == length)
2767 : : {
2768 : 5353 : if (POINTER_TYPE_P (len_type))
2769 : 473 : f->sym->ts.u.cl->backend_decl
2770 : 473 : = build_fold_indirect_ref_loc (input_location, length);
2771 : 4880 : else if (f->sym->ts.u.cl->backend_decl == NULL)
2772 : 298 : gfc_create_string_length (f->sym);
2773 : :
2774 : : /* Make sure PARM_DECL type doesn't point to incomplete type. */
2775 : 5353 : if (f->sym->attr.flavor == FL_PROCEDURE)
2776 : 12 : type = build_pointer_type (gfc_get_function_type (f->sym));
2777 : : else
2778 : 5341 : type = gfc_sym_type (f->sym);
2779 : : }
2780 : : }
2781 : : /* For scalar intrinsic types, VALUE passes the value,
2782 : : hence, the optional status cannot be transferred via a NULL pointer.
2783 : : Thus, we will use a hidden argument in that case. */
2784 : 87393 : if (f->sym->attr.optional && f->sym->attr.value
2785 : 87393 : && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
2786 : : && !gfc_bt_struct (f->sym->ts.type))
2787 : : {
2788 : 444 : tree tmp;
2789 : 444 : strcpy (&name[1], f->sym->name);
2790 : 444 : name[0] = '.';
2791 : 444 : tmp = build_decl (input_location,
2792 : : PARM_DECL, get_identifier (name),
2793 : : boolean_type_node);
2794 : :
2795 : 444 : optval_arglist = chainon (optval_arglist, tmp);
2796 : 444 : DECL_CONTEXT (tmp) = fndecl;
2797 : 444 : DECL_ARTIFICIAL (tmp) = 1;
2798 : 444 : DECL_ARG_TYPE (tmp) = boolean_type_node;
2799 : 444 : TREE_READONLY (tmp) = 1;
2800 : 444 : gfc_finish_decl (tmp);
2801 : :
2802 : : /* The presence flag must be boolean. */
2803 : 444 : gcc_assert (TREE_VALUE (optval_typelist) == boolean_type_node);
2804 : 444 : optval_typelist = TREE_CHAIN (optval_typelist);
2805 : : }
2806 : :
2807 : : /* For non-constant length array arguments, make sure they use
2808 : : a different type node from TYPE_ARG_TYPES type. */
2809 : 87393 : if (f->sym->attr.dimension
2810 : 20055 : && type == TREE_VALUE (typelist)
2811 : 18980 : && TREE_CODE (type) == POINTER_TYPE
2812 : 9332 : && GFC_ARRAY_TYPE_P (type)
2813 : 7619 : && f->sym->as->type != AS_ASSUMED_SIZE
2814 : 93274 : && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2815 : : {
2816 : 2561 : if (f->sym->attr.flavor == FL_PROCEDURE)
2817 : 0 : type = build_pointer_type (gfc_get_function_type (f->sym));
2818 : : else
2819 : 2561 : type = gfc_sym_type (f->sym);
2820 : : }
2821 : :
2822 : 87393 : if (f->sym->attr.proc_pointer)
2823 : 126 : type = build_pointer_type (type);
2824 : :
2825 : 87393 : if (f->sym->attr.volatile_)
2826 : 3 : type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2827 : :
2828 : : /* Build the argument declaration. For C descriptors, we use a
2829 : : '_'-prefixed name for the parm_decl and inside the proc the
2830 : : sym->name. */
2831 : 87393 : tree parm_name;
2832 : 87393 : if (sym->attr.is_bind_c && is_CFI_desc (f->sym, NULL))
2833 : : {
2834 : 1808 : strcpy (&name[1], f->sym->name);
2835 : 1808 : name[0] = '_';
2836 : 1808 : parm_name = get_identifier (name);
2837 : : }
2838 : : else
2839 : 85585 : parm_name = gfc_sym_identifier (f->sym);
2840 : 87393 : parm = build_decl (input_location, PARM_DECL, parm_name, type);
2841 : :
2842 : 87393 : if (f->sym->attr.volatile_)
2843 : : {
2844 : 3 : TREE_THIS_VOLATILE (parm) = 1;
2845 : 3 : TREE_SIDE_EFFECTS (parm) = 1;
2846 : : }
2847 : :
2848 : : /* Fill in arg stuff. */
2849 : 87393 : DECL_CONTEXT (parm) = fndecl;
2850 : 87393 : DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2851 : : /* All implementation args except for VALUE are read-only. */
2852 : 87393 : if (!f->sym->attr.value)
2853 : 80152 : TREE_READONLY (parm) = 1;
2854 : 87393 : if (POINTER_TYPE_P (type)
2855 : 80625 : && (!f->sym->attr.proc_pointer
2856 : 80499 : && f->sym->attr.flavor != FL_PROCEDURE))
2857 : 79749 : DECL_BY_REFERENCE (parm) = 1;
2858 : 87393 : if (f->sym->attr.optional)
2859 : : {
2860 : 5427 : gfc_allocate_lang_decl (parm);
2861 : 5427 : GFC_DECL_OPTIONAL_ARGUMENT (parm) = 1;
2862 : : }
2863 : :
2864 : 87393 : gfc_finish_decl (parm);
2865 : 87393 : gfc_finish_decl_attrs (parm, &f->sym->attr);
2866 : :
2867 : 87393 : f->sym->backend_decl = parm;
2868 : :
2869 : : /* Coarrays which are descriptorless or assumed-shape pass with
2870 : : -fcoarray=lib the token and the offset as hidden arguments. */
2871 : 87393 : if (flag_coarray == GFC_FCOARRAY_LIB
2872 : 244 : && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
2873 : 231 : && !f->sym->attr.allocatable)
2874 : 195 : || (f->sym->ts.type == BT_CLASS
2875 : 13 : && CLASS_DATA (f->sym)->attr.codimension
2876 : 13 : && !CLASS_DATA (f->sym)->attr.allocatable)))
2877 : : {
2878 : 58 : tree caf_type;
2879 : 58 : tree token;
2880 : 58 : tree offset;
2881 : :
2882 : 58 : gcc_assert (f->sym->backend_decl != NULL_TREE
2883 : : && !sym->attr.is_bind_c);
2884 : 116 : caf_type = f->sym->ts.type == BT_CLASS
2885 : 107 : ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
2886 : 49 : : TREE_TYPE (f->sym->backend_decl);
2887 : :
2888 : 58 : token = build_decl (input_location, PARM_DECL,
2889 : : create_tmp_var_name ("caf_token"),
2890 : : build_qualified_type (pvoid_type_node,
2891 : : TYPE_QUAL_RESTRICT));
2892 : 58 : if ((f->sym->ts.type != BT_CLASS
2893 : 49 : && f->sym->as->type != AS_DEFERRED)
2894 : 9 : || (f->sym->ts.type == BT_CLASS
2895 : 9 : && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2896 : : {
2897 : 58 : gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
2898 : : || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
2899 : 58 : if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
2900 : 53 : gfc_allocate_lang_decl (f->sym->backend_decl);
2901 : 58 : GFC_DECL_TOKEN (f->sym->backend_decl) = token;
2902 : : }
2903 : : else
2904 : : {
2905 : 0 : gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
2906 : 0 : GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
2907 : : }
2908 : :
2909 : 58 : DECL_CONTEXT (token) = fndecl;
2910 : 58 : DECL_ARTIFICIAL (token) = 1;
2911 : 58 : DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
2912 : 58 : TREE_READONLY (token) = 1;
2913 : 58 : hidden_arglist = chainon (hidden_arglist, token);
2914 : 58 : hidden_typelist = TREE_CHAIN (hidden_typelist);
2915 : 58 : gfc_finish_decl (token);
2916 : :
2917 : 58 : offset = build_decl (input_location, PARM_DECL,
2918 : : create_tmp_var_name ("caf_offset"),
2919 : : gfc_array_index_type);
2920 : :
2921 : 58 : if ((f->sym->ts.type != BT_CLASS
2922 : 49 : && f->sym->as->type != AS_DEFERRED)
2923 : 9 : || (f->sym->ts.type == BT_CLASS
2924 : 9 : && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2925 : : {
2926 : 58 : gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
2927 : : == NULL_TREE);
2928 : 58 : GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
2929 : : }
2930 : : else
2931 : : {
2932 : 0 : gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
2933 : 0 : GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
2934 : : }
2935 : 58 : DECL_CONTEXT (offset) = fndecl;
2936 : 58 : DECL_ARTIFICIAL (offset) = 1;
2937 : 58 : DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
2938 : 58 : TREE_READONLY (offset) = 1;
2939 : 58 : hidden_arglist = chainon (hidden_arglist, offset);
2940 : 58 : hidden_typelist = TREE_CHAIN (hidden_typelist);
2941 : 58 : gfc_finish_decl (offset);
2942 : : }
2943 : :
2944 : 87393 : arglist = chainon (arglist, parm);
2945 : 87393 : typelist = TREE_CHAIN (typelist);
2946 : : }
2947 : :
2948 : : /* Add hidden present status for optional+value arguments. */
2949 : 76076 : arglist = chainon (arglist, optval_arglist);
2950 : :
2951 : : /* Add the hidden string length parameters, unless the procedure
2952 : : is bind(C). */
2953 : 76076 : if (!sym->attr.is_bind_c)
2954 : 74132 : arglist = chainon (arglist, hidden_arglist);
2955 : :
2956 : 152152 : gcc_assert (hidden_typelist == NULL_TREE
2957 : : || TREE_VALUE (hidden_typelist) == void_type_node);
2958 : 76076 : DECL_ARGUMENTS (fndecl) = arglist;
2959 : 76076 : }
2960 : :
2961 : : /* Do the setup necessary before generating the body of a function. */
2962 : :
2963 : : static void
2964 : 76076 : trans_function_start (gfc_symbol * sym)
2965 : : {
2966 : 76076 : tree fndecl;
2967 : :
2968 : 76076 : fndecl = sym->backend_decl;
2969 : :
2970 : : /* Let GCC know the current scope is this function. */
2971 : 76076 : current_function_decl = fndecl;
2972 : :
2973 : : /* Let the world know what we're about to do. */
2974 : 76076 : announce_function (fndecl);
2975 : :
2976 : 76076 : if (DECL_FILE_SCOPE_P (fndecl))
2977 : : {
2978 : : /* Create RTL for function declaration. */
2979 : 35788 : rest_of_decl_compilation (fndecl, 1, 0);
2980 : : }
2981 : :
2982 : : /* Create RTL for function definition. */
2983 : 76076 : make_decl_rtl (fndecl);
2984 : :
2985 : 76076 : allocate_struct_function (fndecl, false);
2986 : :
2987 : : /* function.cc requires a push at the start of the function. */
2988 : 76076 : pushlevel ();
2989 : 76076 : }
2990 : :
2991 : : /* Create thunks for alternate entry points. */
2992 : :
2993 : : static void
2994 : 632 : build_entry_thunks (gfc_namespace * ns, bool global)
2995 : : {
2996 : 632 : gfc_formal_arglist *formal;
2997 : 632 : gfc_formal_arglist *thunk_formal;
2998 : 632 : gfc_entry_list *el;
2999 : 632 : gfc_symbol *thunk_sym;
3000 : 632 : stmtblock_t body;
3001 : 632 : tree thunk_fndecl;
3002 : 632 : tree tmp;
3003 : 632 : locus old_loc;
3004 : :
3005 : : /* This should always be a toplevel function. */
3006 : 632 : gcc_assert (current_function_decl == NULL_TREE);
3007 : :
3008 : 632 : gfc_save_backend_locus (&old_loc);
3009 : 1973 : for (el = ns->entries; el; el = el->next)
3010 : : {
3011 : 1341 : vec<tree, va_gc> *args = NULL;
3012 : 1341 : vec<tree, va_gc> *string_args = NULL;
3013 : :
3014 : 1341 : thunk_sym = el->sym;
3015 : :
3016 : 1341 : build_function_decl (thunk_sym, global);
3017 : 1341 : create_function_arglist (thunk_sym);
3018 : :
3019 : 1341 : trans_function_start (thunk_sym);
3020 : :
3021 : 1341 : thunk_fndecl = thunk_sym->backend_decl;
3022 : :
3023 : 1341 : gfc_init_block (&body);
3024 : :
3025 : : /* Pass extra parameter identifying this entry point. */
3026 : 1341 : tmp = build_int_cst (gfc_array_index_type, el->id);
3027 : 1341 : vec_safe_push (args, tmp);
3028 : :
3029 : 1341 : if (thunk_sym->attr.function)
3030 : : {
3031 : 1130 : if (gfc_return_by_reference (ns->proc_name))
3032 : : {
3033 : 252 : tree ref = DECL_ARGUMENTS (current_function_decl);
3034 : 252 : vec_safe_push (args, ref);
3035 : 252 : if (ns->proc_name->ts.type == BT_CHARACTER)
3036 : 136 : vec_safe_push (args, DECL_CHAIN (ref));
3037 : : }
3038 : : }
3039 : :
3040 : 2885 : for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
3041 : 1544 : formal = formal->next)
3042 : : {
3043 : : /* Ignore alternate returns. */
3044 : 1544 : if (formal->sym == NULL)
3045 : 36 : continue;
3046 : :
3047 : : /* We don't have a clever way of identifying arguments, so resort to
3048 : : a brute-force search. */
3049 : 1508 : for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
3050 : 2663 : thunk_formal;
3051 : 1155 : thunk_formal = thunk_formal->next)
3052 : : {
3053 : 2232 : if (thunk_formal->sym == formal->sym)
3054 : : break;
3055 : : }
3056 : :
3057 : 1508 : if (thunk_formal)
3058 : : {
3059 : : /* Pass the argument. */
3060 : 1077 : DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
3061 : 1077 : vec_safe_push (args, thunk_formal->sym->backend_decl);
3062 : 1077 : if (formal->sym->ts.type == BT_CHARACTER)
3063 : : {
3064 : 94 : tmp = thunk_formal->sym->ts.u.cl->backend_decl;
3065 : 94 : vec_safe_push (string_args, tmp);
3066 : : }
3067 : : }
3068 : : else
3069 : : {
3070 : : /* Pass NULL for a missing argument. */
3071 : 431 : vec_safe_push (args, null_pointer_node);
3072 : 431 : if (formal->sym->ts.type == BT_CHARACTER)
3073 : : {
3074 : 38 : tmp = build_int_cst (gfc_charlen_type_node, 0);
3075 : 38 : vec_safe_push (string_args, tmp);
3076 : : }
3077 : : }
3078 : : }
3079 : :
3080 : : /* Call the master function. */
3081 : 1341 : vec_safe_splice (args, string_args);
3082 : 1341 : tmp = ns->proc_name->backend_decl;
3083 : 1341 : tmp = build_call_expr_loc_vec (input_location, tmp, args);
3084 : 1341 : if (ns->proc_name->attr.mixed_entry_master)
3085 : : {
3086 : 210 : tree union_decl, field;
3087 : 210 : tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
3088 : :
3089 : 210 : union_decl = build_decl (input_location,
3090 : : VAR_DECL, get_identifier ("__result"),
3091 : 210 : TREE_TYPE (master_type));
3092 : 210 : DECL_ARTIFICIAL (union_decl) = 1;
3093 : 210 : DECL_EXTERNAL (union_decl) = 0;
3094 : 210 : TREE_PUBLIC (union_decl) = 0;
3095 : 210 : TREE_USED (union_decl) = 1;
3096 : 210 : layout_decl (union_decl, 0);
3097 : 210 : pushdecl (union_decl);
3098 : :
3099 : 210 : DECL_CONTEXT (union_decl) = current_function_decl;
3100 : 210 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3101 : 210 : TREE_TYPE (union_decl), union_decl, tmp);
3102 : 210 : gfc_add_expr_to_block (&body, tmp);
3103 : :
3104 : 210 : for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
3105 : 342 : field; field = DECL_CHAIN (field))
3106 : 342 : if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
3107 : 342 : thunk_sym->result->name) == 0)
3108 : : break;
3109 : 0 : gcc_assert (field != NULL_TREE);
3110 : 210 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
3111 : 210 : TREE_TYPE (field), union_decl, field,
3112 : : NULL_TREE);
3113 : 210 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3114 : 210 : TREE_TYPE (DECL_RESULT (current_function_decl)),
3115 : 210 : DECL_RESULT (current_function_decl), tmp);
3116 : 210 : tmp = build1_v (RETURN_EXPR, tmp);
3117 : : }
3118 : 1131 : else if (TREE_TYPE (DECL_RESULT (current_function_decl))
3119 : 1131 : != void_type_node)
3120 : : {
3121 : 693 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3122 : 693 : TREE_TYPE (DECL_RESULT (current_function_decl)),
3123 : 693 : DECL_RESULT (current_function_decl), tmp);
3124 : 693 : tmp = build1_v (RETURN_EXPR, tmp);
3125 : : }
3126 : 1341 : gfc_add_expr_to_block (&body, tmp);
3127 : :
3128 : : /* Finish off this function and send it for code generation. */
3129 : 1341 : DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
3130 : 1341 : tmp = getdecls ();
3131 : 1341 : poplevel (1, 1);
3132 : 1341 : BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
3133 : 2682 : DECL_SAVED_TREE (thunk_fndecl)
3134 : 2682 : = fold_build3_loc (DECL_SOURCE_LOCATION (thunk_fndecl), BIND_EXPR,
3135 : 1341 : void_type_node, tmp, DECL_SAVED_TREE (thunk_fndecl),
3136 : 1341 : DECL_INITIAL (thunk_fndecl));
3137 : :
3138 : : /* Output the GENERIC tree. */
3139 : 1341 : dump_function (TDI_original, thunk_fndecl);
3140 : :
3141 : : /* Store the end of the function, so that we get good line number
3142 : : info for the epilogue. */
3143 : 1341 : cfun->function_end_locus = input_location;
3144 : :
3145 : : /* We're leaving the context of this function, so zap cfun.
3146 : : It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3147 : : tree_rest_of_compilation. */
3148 : 1341 : set_cfun (NULL);
3149 : :
3150 : 1341 : current_function_decl = NULL_TREE;
3151 : :
3152 : 1341 : cgraph_node::finalize_function (thunk_fndecl, true);
3153 : :
3154 : : /* We share the symbols in the formal argument list with other entry
3155 : : points and the master function. Clear them so that they are
3156 : : recreated for each function. */
3157 : 2463 : for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
3158 : 1122 : formal = formal->next)
3159 : 1122 : if (formal->sym != NULL) /* Ignore alternate returns. */
3160 : : {
3161 : 1077 : formal->sym->backend_decl = NULL_TREE;
3162 : 1077 : if (formal->sym->ts.type == BT_CHARACTER)
3163 : 94 : formal->sym->ts.u.cl->backend_decl = NULL_TREE;
3164 : : }
3165 : :
3166 : 1341 : if (thunk_sym->attr.function)
3167 : : {
3168 : 1130 : if (thunk_sym->ts.type == BT_CHARACTER)
3169 : 138 : thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
3170 : 1130 : if (thunk_sym->result->ts.type == BT_CHARACTER)
3171 : 138 : thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
3172 : : }
3173 : : }
3174 : :
3175 : 632 : gfc_restore_backend_locus (&old_loc);
3176 : 632 : }
3177 : :
3178 : :
3179 : : /* Create a decl for a function, and create any thunks for alternate entry
3180 : : points. If global is true, generate the function in the global binding
3181 : : level, otherwise in the current binding level (which can be global). */
3182 : :
3183 : : void
3184 : 74735 : gfc_create_function_decl (gfc_namespace * ns, bool global)
3185 : : {
3186 : : /* Create a declaration for the master function. */
3187 : 74735 : build_function_decl (ns->proc_name, global);
3188 : :
3189 : : /* Compile the entry thunks. */
3190 : 74735 : if (ns->entries)
3191 : 632 : build_entry_thunks (ns, global);
3192 : :
3193 : : /* Now create the read argument list. */
3194 : 74735 : create_function_arglist (ns->proc_name);
3195 : :
3196 : 74735 : if (ns->omp_declare_simd)
3197 : 99 : gfc_trans_omp_declare_simd (ns);
3198 : :
3199 : : /* Handle 'declare variant' directives. The applicable directives might
3200 : : be declared in a parent namespace, so this needs to be called even if
3201 : : there are no local directives. */
3202 : 74735 : if (flag_openmp)
3203 : 7936 : gfc_trans_omp_declare_variant (ns);
3204 : 74735 : }
3205 : :
3206 : : /* Return the decl used to hold the function return value. If
3207 : : parent_flag is set, the context is the parent_scope. */
3208 : :
3209 : : tree
3210 : 13785 : gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
3211 : : {
3212 : 13785 : tree decl;
3213 : 13785 : tree length;
3214 : 13785 : tree this_fake_result_decl;
3215 : 13785 : tree this_function_decl;
3216 : :
3217 : 13785 : char name[GFC_MAX_SYMBOL_LEN + 10];
3218 : :
3219 : 13785 : if (parent_flag)
3220 : : {
3221 : 167 : this_fake_result_decl = parent_fake_result_decl;
3222 : 167 : this_function_decl = DECL_CONTEXT (current_function_decl);
3223 : : }
3224 : : else
3225 : : {
3226 : 13618 : this_fake_result_decl = current_fake_result_decl;
3227 : 13618 : this_function_decl = current_function_decl;
3228 : : }
3229 : :
3230 : 13785 : if (sym
3231 : 13735 : && sym->ns->proc_name->backend_decl == this_function_decl
3232 : 6481 : && sym->ns->proc_name->attr.entry_master
3233 : 2264 : && sym != sym->ns->proc_name)
3234 : : {
3235 : 1416 : tree t = NULL, var;
3236 : 1416 : if (this_fake_result_decl != NULL)
3237 : 1388 : for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
3238 : 1039 : if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
3239 : : break;
3240 : 926 : if (t)
3241 : 577 : return TREE_VALUE (t);
3242 : 839 : decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
3243 : :
3244 : 839 : if (parent_flag)
3245 : 14 : this_fake_result_decl = parent_fake_result_decl;
3246 : : else
3247 : 825 : this_fake_result_decl = current_fake_result_decl;
3248 : :
3249 : 839 : if (decl && sym->ns->proc_name->attr.mixed_entry_master)
3250 : : {
3251 : 210 : tree field;
3252 : :
3253 : 210 : for (field = TYPE_FIELDS (TREE_TYPE (decl));
3254 : 342 : field; field = DECL_CHAIN (field))
3255 : 342 : if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
3256 : : sym->name) == 0)
3257 : : break;
3258 : :
3259 : 210 : gcc_assert (field != NULL_TREE);
3260 : 210 : decl = fold_build3_loc (input_location, COMPONENT_REF,
3261 : 210 : TREE_TYPE (field), decl, field, NULL_TREE);
3262 : : }
3263 : :
3264 : 839 : var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
3265 : 839 : if (parent_flag)
3266 : 14 : gfc_add_decl_to_parent_function (var);
3267 : : else
3268 : 825 : gfc_add_decl_to_function (var);
3269 : :
3270 : 839 : SET_DECL_VALUE_EXPR (var, decl);
3271 : 839 : DECL_HAS_VALUE_EXPR_P (var) = 1;
3272 : 839 : GFC_DECL_RESULT (var) = 1;
3273 : :
3274 : 839 : TREE_CHAIN (this_fake_result_decl)
3275 : 839 : = tree_cons (get_identifier (sym->name), var,
3276 : 839 : TREE_CHAIN (this_fake_result_decl));
3277 : 839 : return var;
3278 : : }
3279 : :
3280 : 12369 : if (this_fake_result_decl != NULL_TREE)
3281 : 3620 : return TREE_VALUE (this_fake_result_decl);
3282 : :
3283 : : /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
3284 : : sym is NULL. */
3285 : 8749 : if (!sym)
3286 : : return NULL_TREE;
3287 : :
3288 : 8749 : if (sym->ts.type == BT_CHARACTER)
3289 : : {
3290 : 784 : if (sym->ts.u.cl->backend_decl == NULL_TREE)
3291 : 0 : length = gfc_create_string_length (sym);
3292 : : else
3293 : : length = sym->ts.u.cl->backend_decl;
3294 : 784 : if (VAR_P (length) && DECL_CONTEXT (length) == NULL_TREE)
3295 : 473 : gfc_add_decl_to_function (length);
3296 : : }
3297 : :
3298 : 8749 : if (gfc_return_by_reference (sym))
3299 : : {
3300 : 1523 : decl = DECL_ARGUMENTS (this_function_decl);
3301 : :
3302 : 1523 : if (sym->ns->proc_name->backend_decl == this_function_decl
3303 : 385 : && sym->ns->proc_name->attr.entry_master)
3304 : 61 : decl = DECL_CHAIN (decl);
3305 : :
3306 : 1523 : TREE_USED (decl) = 1;
3307 : 1523 : if (sym->as)
3308 : 785 : decl = gfc_build_dummy_array_decl (sym, decl);
3309 : : }
3310 : : else
3311 : : {
3312 : 14452 : sprintf (name, "__result_%.20s",
3313 : 7226 : IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
3314 : :
3315 : 7226 : if (!sym->attr.mixed_entry_master && sym->attr.function)
3316 : 7088 : decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
3317 : : VAR_DECL, get_identifier (name),
3318 : : gfc_sym_type (sym));
3319 : : else
3320 : 138 : decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
3321 : : VAR_DECL, get_identifier (name),
3322 : 138 : TREE_TYPE (TREE_TYPE (this_function_decl)));
3323 : 7226 : DECL_ARTIFICIAL (decl) = 1;
3324 : 7226 : DECL_EXTERNAL (decl) = 0;
3325 : 7226 : TREE_PUBLIC (decl) = 0;
3326 : 7226 : TREE_USED (decl) = 1;
3327 : 7226 : GFC_DECL_RESULT (decl) = 1;
3328 : 7226 : TREE_ADDRESSABLE (decl) = 1;
3329 : :
3330 : 7226 : layout_decl (decl, 0);
3331 : 7226 : gfc_finish_decl_attrs (decl, &sym->attr);
3332 : :
3333 : 7226 : if (parent_flag)
3334 : 27 : gfc_add_decl_to_parent_function (decl);
3335 : : else
3336 : 7199 : gfc_add_decl_to_function (decl);
3337 : : }
3338 : :
3339 : 8749 : if (parent_flag)
3340 : 39 : parent_fake_result_decl = build_tree_list (NULL, decl);
3341 : : else
3342 : 8710 : current_fake_result_decl = build_tree_list (NULL, decl);
3343 : :
3344 : 8749 : if (sym->attr.assign)
3345 : 1 : DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
3346 : :
3347 : : return decl;
3348 : : }
3349 : :
3350 : :
3351 : : /* Builds a function decl. The remaining parameters are the types of the
3352 : : function arguments. Negative nargs indicates a varargs function. */
3353 : :
3354 : : static tree
3355 : 4129514 : build_library_function_decl_1 (tree name, const char *spec,
3356 : : tree rettype, int nargs, va_list p)
3357 : : {
3358 : 4129514 : vec<tree, va_gc> *arglist;
3359 : 4129514 : tree fntype;
3360 : 4129514 : tree fndecl;
3361 : 4129514 : int n;
3362 : :
3363 : : /* Library functions must be declared with global scope. */
3364 : 4129514 : gcc_assert (current_function_decl == NULL_TREE);
3365 : :
3366 : : /* Create a list of the argument types. */
3367 : 4129514 : vec_alloc (arglist, abs (nargs));
3368 : 16127791 : for (n = abs (nargs); n > 0; n--)
3369 : : {
3370 : 11998277 : tree argtype = va_arg (p, tree);
3371 : 11998277 : arglist->quick_push (argtype);
3372 : : }
3373 : :
3374 : : /* Build the function type and decl. */
3375 : 4129514 : if (nargs >= 0)
3376 : 11789382 : fntype = build_function_type_vec (rettype, arglist);
3377 : : else
3378 : 537732 : fntype = build_varargs_function_type_vec (rettype, arglist);
3379 : 4129514 : if (spec)
3380 : : {
3381 : 2459748 : tree attr_args = build_tree_list (NULL_TREE,
3382 : 2459748 : build_string (strlen (spec), spec));
3383 : 2459748 : tree attrs = tree_cons (get_identifier ("fn spec"),
3384 : 2459748 : attr_args, TYPE_ATTRIBUTES (fntype));
3385 : 2459748 : fntype = build_type_attribute_variant (fntype, attrs);
3386 : : }
3387 : 4129514 : fndecl = build_decl (input_location,
3388 : : FUNCTION_DECL, name, fntype);
3389 : :
3390 : : /* Mark this decl as external. */
3391 : 4129514 : DECL_EXTERNAL (fndecl) = 1;
3392 : 4129514 : TREE_PUBLIC (fndecl) = 1;
3393 : :
3394 : 4129514 : pushdecl (fndecl);
3395 : :
3396 : 4129514 : rest_of_decl_compilation (fndecl, 1, 0);
3397 : :
3398 : 4129514 : return fndecl;
3399 : : }
3400 : :
3401 : : /* Builds a function decl. The remaining parameters are the types of the
3402 : : function arguments. Negative nargs indicates a varargs function. */
3403 : :
3404 : : tree
3405 : 1669766 : gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
3406 : : {
3407 : 1669766 : tree ret;
3408 : 1669766 : va_list args;
3409 : 1669766 : va_start (args, nargs);
3410 : 1669766 : ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
3411 : 1669766 : va_end (args);
3412 : 1669766 : return ret;
3413 : : }
3414 : :
3415 : : /* Builds a function decl. The remaining parameters are the types of the
3416 : : function arguments. Negative nargs indicates a varargs function.
3417 : : The SPEC parameter specifies the function argument and return type
3418 : : specification according to the fnspec function type attribute. */
3419 : :
3420 : : tree
3421 : 2459748 : gfc_build_library_function_decl_with_spec (tree name, const char *spec,
3422 : : tree rettype, int nargs, ...)
3423 : : {
3424 : 2459748 : tree ret;
3425 : 2459748 : va_list args;
3426 : 2459748 : va_start (args, nargs);
3427 : 2459748 : if (flag_checking)
3428 : : {
3429 : 2459748 : attr_fnspec fnspec (spec, strlen (spec));
3430 : 2459748 : fnspec.verify ();
3431 : : }
3432 : 2459748 : ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
3433 : 2459748 : va_end (args);
3434 : 2459748 : return ret;
3435 : : }
3436 : :
3437 : : static void
3438 : 29874 : gfc_build_intrinsic_function_decls (void)
3439 : : {
3440 : 29874 : tree gfc_int4_type_node = gfc_get_int_type (4);
3441 : 29874 : tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
3442 : 29874 : tree gfc_int8_type_node = gfc_get_int_type (8);
3443 : 29874 : tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node);
3444 : 29874 : tree gfc_int16_type_node = gfc_get_int_type (16);
3445 : 29874 : tree gfc_logical4_type_node = gfc_get_logical_type (4);
3446 : 29874 : tree pchar1_type_node = gfc_get_pchar_type (1);
3447 : 29874 : tree pchar4_type_node = gfc_get_pchar_type (4);
3448 : :
3449 : : /* String functions. */
3450 : 29874 : gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
3451 : : get_identifier (PREFIX("compare_string")), ". . R . R ",
3452 : : integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
3453 : : gfc_charlen_type_node, pchar1_type_node);
3454 : 29874 : DECL_PURE_P (gfor_fndecl_compare_string) = 1;
3455 : 29874 : TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
3456 : :
3457 : 29874 : gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
3458 : : get_identifier (PREFIX("concat_string")), ". . W . R . R ",
3459 : : void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
3460 : : gfc_charlen_type_node, pchar1_type_node,
3461 : : gfc_charlen_type_node, pchar1_type_node);
3462 : 29874 : TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
3463 : :
3464 : 29874 : gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
3465 : : get_identifier (PREFIX("string_len_trim")), ". . R ",
3466 : : gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
3467 : 29874 : DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
3468 : 29874 : TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
3469 : :
3470 : 29874 : gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
3471 : : get_identifier (PREFIX("string_index")), ". . R . R . ",
3472 : : gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
3473 : : gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3474 : 29874 : DECL_PURE_P (gfor_fndecl_string_index) = 1;
3475 : 29874 : TREE_NOTHROW (gfor_fndecl_string_index) = 1;
3476 : :
3477 : 29874 : gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
3478 : : get_identifier (PREFIX("string_scan")), ". . R . R . ",
3479 : : gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
3480 : : gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3481 : 29874 : DECL_PURE_P (gfor_fndecl_string_scan) = 1;
3482 : 29874 : TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
3483 : :
3484 : 29874 : gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
3485 : : get_identifier (PREFIX("string_verify")), ". . R . R . ",
3486 : : gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
3487 : : gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3488 : 29874 : DECL_PURE_P (gfor_fndecl_string_verify) = 1;
3489 : 29874 : TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
3490 : :
3491 : 29874 : gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
3492 : : get_identifier (PREFIX("string_trim")), ". W w . R ",
3493 : : void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
3494 : : build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
3495 : : pchar1_type_node);
3496 : :
3497 : 29874 : gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
3498 : : get_identifier (PREFIX("string_minmax")), ". W w . R ",
3499 : : void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
3500 : : build_pointer_type (pchar1_type_node), integer_type_node,
3501 : : integer_type_node);
3502 : :
3503 : 29874 : gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
3504 : : get_identifier (PREFIX("adjustl")), ". W . R ",
3505 : : void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
3506 : : pchar1_type_node);
3507 : 29874 : TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
3508 : :
3509 : 29874 : gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
3510 : : get_identifier (PREFIX("adjustr")), ". W . R ",
3511 : : void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
3512 : : pchar1_type_node);
3513 : 29874 : TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
3514 : :
3515 : 29874 : gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
3516 : : get_identifier (PREFIX("select_string")), ". R . R . ",
3517 : : integer_type_node, 4, pvoid_type_node, integer_type_node,
3518 : : pchar1_type_node, gfc_charlen_type_node);
3519 : 29874 : DECL_PURE_P (gfor_fndecl_select_string) = 1;
3520 : 29874 : TREE_NOTHROW (gfor_fndecl_select_string) = 1;
3521 : :
3522 : 29874 : gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
3523 : : get_identifier (PREFIX("compare_string_char4")), ". . R . R ",
3524 : : integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
3525 : : gfc_charlen_type_node, pchar4_type_node);
3526 : 29874 : DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
3527 : 29874 : TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
3528 : :
3529 : 29874 : gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
3530 : : get_identifier (PREFIX("concat_string_char4")), ". . W . R . R ",
3531 : : void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
3532 : : gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
3533 : : pchar4_type_node);
3534 : 29874 : TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
3535 : :
3536 : 29874 : gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
3537 : : get_identifier (PREFIX("string_len_trim_char4")), ". . R ",
3538 : : gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
3539 : 29874 : DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
3540 : 29874 : TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
3541 : :
3542 : 29874 : gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
3543 : : get_identifier (PREFIX("string_index_char4")), ". . R . R . ",
3544 : : gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
3545 : : gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3546 : 29874 : DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
3547 : 29874 : TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
3548 : :
3549 : 29874 : gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
3550 : : get_identifier (PREFIX("string_scan_char4")), ". . R . R . ",
3551 : : gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
3552 : : gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3553 : 29874 : DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
3554 : 29874 : TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
3555 : :
3556 : 29874 : gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
3557 : : get_identifier (PREFIX("string_verify_char4")), ". . R . R . ",
3558 : : gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
3559 : : gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3560 : 29874 : DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
3561 : 29874 : TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
3562 : :
3563 : 29874 : gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
3564 : : get_identifier (PREFIX("string_trim_char4")), ". W w . R ",
3565 : : void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
3566 : : build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
3567 : : pchar4_type_node);
3568 : :
3569 : 29874 : gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
3570 : : get_identifier (PREFIX("string_minmax_char4")), ". W w . R ",
3571 : : void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
3572 : : build_pointer_type (pchar4_type_node), integer_type_node,
3573 : : integer_type_node);
3574 : :
3575 : 29874 : gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
3576 : : get_identifier (PREFIX("adjustl_char4")), ". W . R ",
3577 : : void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
3578 : : pchar4_type_node);
3579 : 29874 : TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
3580 : :
3581 : 29874 : gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
3582 : : get_identifier (PREFIX("adjustr_char4")), ". W . R ",
3583 : : void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
3584 : : pchar4_type_node);
3585 : 29874 : TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
3586 : :
3587 : 29874 : gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
3588 : : get_identifier (PREFIX("select_string_char4")), ". R . R . ",
3589 : : integer_type_node, 4, pvoid_type_node, integer_type_node,
3590 : : pvoid_type_node, gfc_charlen_type_node);
3591 : 29874 : DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
3592 : 29874 : TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
3593 : :
3594 : :
3595 : : /* Conversion between character kinds. */
3596 : :
3597 : 29874 : gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
3598 : : get_identifier (PREFIX("convert_char1_to_char4")), ". w . R ",
3599 : : void_type_node, 3, build_pointer_type (pchar4_type_node),
3600 : : gfc_charlen_type_node, pchar1_type_node);
3601 : :
3602 : 29874 : gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
3603 : : get_identifier (PREFIX("convert_char4_to_char1")), ". w . R ",
3604 : : void_type_node, 3, build_pointer_type (pchar1_type_node),
3605 : : gfc_charlen_type_node, pchar4_type_node);
3606 : :
3607 : : /* Misc. functions. */
3608 : :
3609 : 29874 : gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
3610 : : get_identifier (PREFIX("ttynam")), ". W . . ",
3611 : : void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
3612 : : integer_type_node);
3613 : :
3614 : 29874 : gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
3615 : : get_identifier (PREFIX("fdate")), ". W . ",
3616 : : void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
3617 : :
3618 : 29874 : gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
3619 : : get_identifier (PREFIX("ctime")), ". W . . ",
3620 : : void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
3621 : : gfc_int8_type_node);
3622 : :
3623 : 29874 : gfor_fndecl_random_init = gfc_build_library_function_decl (
3624 : : get_identifier (PREFIX("random_init")),
3625 : : void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node,
3626 : : gfc_int4_type_node);
3627 : :
3628 : : // gfor_fndecl_caf_rand_init is defined in the lib-coarray section below.
3629 : :
3630 : 29874 : gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
3631 : : get_identifier (PREFIX("selected_char_kind")), ". . R ",
3632 : : gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
3633 : 29874 : DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
3634 : 29874 : TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
3635 : :
3636 : 29874 : gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
3637 : : get_identifier (PREFIX("selected_int_kind")), ". R ",
3638 : : gfc_int4_type_node, 1, pvoid_type_node);
3639 : 29874 : DECL_PURE_P (gfor_fndecl_si_kind) = 1;
3640 : 29874 : TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
3641 : :
3642 : 29874 : gfor_fndecl_sl_kind = gfc_build_library_function_decl_with_spec (
3643 : : get_identifier (PREFIX("selected_logical_kind")), ". R ",
3644 : : gfc_int4_type_node, 1, pvoid_type_node);
3645 : 29874 : DECL_PURE_P (gfor_fndecl_sl_kind) = 1;
3646 : 29874 : TREE_NOTHROW (gfor_fndecl_sl_kind) = 1;
3647 : :
3648 : 29874 : gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
3649 : : get_identifier (PREFIX("selected_real_kind2008")), ". R R ",
3650 : : gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
3651 : : pvoid_type_node);
3652 : 29874 : DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
3653 : 29874 : TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
3654 : :
3655 : 29874 : gfor_fndecl_system_clock4 = gfc_build_library_function_decl (
3656 : : get_identifier (PREFIX("system_clock_4")),
3657 : : void_type_node, 3, gfc_pint4_type_node, gfc_pint4_type_node,
3658 : : gfc_pint4_type_node);
3659 : :
3660 : 29874 : gfor_fndecl_system_clock8 = gfc_build_library_function_decl (
3661 : : get_identifier (PREFIX("system_clock_8")),
3662 : : void_type_node, 3, gfc_pint8_type_node, gfc_pint8_type_node,
3663 : : gfc_pint8_type_node);
3664 : :
3665 : : /* Power functions. */
3666 : 29874 : {
3667 : 29874 : tree ctype, rtype, itype, jtype;
3668 : 29874 : int rkind, ikind, jkind;
3669 : : #define NIKINDS 3
3670 : : #define NRKINDS 4
3671 : 29874 : static int ikinds[NIKINDS] = {4, 8, 16};
3672 : 29874 : static int rkinds[NRKINDS] = {4, 8, 10, 16};
3673 : 29874 : char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
3674 : :
3675 : 119496 : for (ikind=0; ikind < NIKINDS; ikind++)
3676 : : {
3677 : 89622 : itype = gfc_get_int_type (ikinds[ikind]);
3678 : :
3679 : 448110 : for (jkind=0; jkind < NIKINDS; jkind++)
3680 : : {
3681 : 268866 : jtype = gfc_get_int_type (ikinds[jkind]);
3682 : 268866 : if (itype && jtype)
3683 : : {
3684 : 266831 : sprintf (name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
3685 : : ikinds[jkind]);
3686 : 533662 : gfor_fndecl_math_powi[jkind][ikind].integer =
3687 : 266831 : gfc_build_library_function_decl (get_identifier (name),
3688 : : jtype, 2, jtype, itype);
3689 : 266831 : TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3690 : 266831 : TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3691 : : }
3692 : : }
3693 : :
3694 : 448110 : for (rkind = 0; rkind < NRKINDS; rkind ++)
3695 : : {
3696 : 358488 : rtype = gfc_get_real_type (rkinds[rkind]);
3697 : 358488 : if (rtype && itype)
3698 : : {
3699 : 356860 : sprintf (name, PREFIX("pow_r%d_i%d"),
3700 : : gfc_type_abi_kind (BT_REAL, rkinds[rkind]),
3701 : : ikinds[ikind]);
3702 : 713720 : gfor_fndecl_math_powi[rkind][ikind].real =
3703 : 356860 : gfc_build_library_function_decl (get_identifier (name),
3704 : : rtype, 2, rtype, itype);
3705 : 356860 : TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3706 : 356860 : TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3707 : : }
3708 : :
3709 : 358488 : ctype = gfc_get_complex_type (rkinds[rkind]);
3710 : 358488 : if (ctype && itype)
3711 : : {
3712 : 356860 : sprintf (name, PREFIX("pow_c%d_i%d"),
3713 : : gfc_type_abi_kind (BT_REAL, rkinds[rkind]),
3714 : : ikinds[ikind]);
3715 : 713720 : gfor_fndecl_math_powi[rkind][ikind].cmplx =
3716 : 356860 : gfc_build_library_function_decl (get_identifier (name),
3717 : : ctype, 2,ctype, itype);
3718 : 356860 : TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3719 : 356860 : TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3720 : : }
3721 : : }
3722 : : }
3723 : : #undef NIKINDS
3724 : : #undef NRKINDS
3725 : : }
3726 : :
3727 : 29874 : gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
3728 : : get_identifier (PREFIX("ishftc4")),
3729 : : gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
3730 : : gfc_int4_type_node);
3731 : 29874 : TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
3732 : 29874 : TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
3733 : :
3734 : 29874 : gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
3735 : : get_identifier (PREFIX("ishftc8")),
3736 : : gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
3737 : : gfc_int4_type_node);
3738 : 29874 : TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
3739 : 29874 : TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
3740 : :
3741 : 29874 : if (gfc_int16_type_node)
3742 : : {
3743 : 29467 : gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
3744 : : get_identifier (PREFIX("ishftc16")),
3745 : : gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
3746 : : gfc_int4_type_node);
3747 : 29467 : TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
3748 : 29467 : TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
3749 : : }
3750 : :
3751 : : /* BLAS functions. */
3752 : 29874 : {
3753 : 29874 : tree pint = build_pointer_type (integer_type_node);
3754 : 29874 : tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
3755 : 29874 : tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
3756 : 29874 : tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
3757 : 29874 : tree pz = build_pointer_type
3758 : 29874 : (gfc_get_complex_type (gfc_default_double_kind));
3759 : :
3760 : 59748 : gfor_fndecl_sgemm = gfc_build_library_function_decl
3761 : 30649 : (get_identifier
3762 : : (flag_underscoring ? "sgemm_" : "sgemm"),
3763 : : void_type_node, 15, pchar_type_node,
3764 : : pchar_type_node, pint, pint, pint, ps, ps, pint,
3765 : : ps, pint, ps, ps, pint, integer_type_node,
3766 : : integer_type_node);
3767 : 59748 : gfor_fndecl_dgemm = gfc_build_library_function_decl
3768 : 30649 : (get_identifier
3769 : : (flag_underscoring ? "dgemm_" : "dgemm"),
3770 : : void_type_node, 15, pchar_type_node,
3771 : : pchar_type_node, pint, pint, pint, pd, pd, pint,
3772 : : pd, pint, pd, pd, pint, integer_type_node,
3773 : : integer_type_node);
3774 : 59748 : gfor_fndecl_cgemm = gfc_build_library_function_decl
3775 : 30649 : (get_identifier
3776 : : (flag_underscoring ? "cgemm_" : "cgemm"),
3777 : : void_type_node, 15, pchar_type_node,
3778 : : pchar_type_node, pint, pint, pint, pc, pc, pint,
3779 : : pc, pint, pc, pc, pint, integer_type_node,
3780 : : integer_type_node);
3781 : 59748 : gfor_fndecl_zgemm = gfc_build_library_function_decl
3782 : 30649 : (get_identifier
3783 : : (flag_underscoring ? "zgemm_" : "zgemm"),
3784 : : void_type_node, 15, pchar_type_node,
3785 : : pchar_type_node, pint, pint, pint, pz, pz, pint,
3786 : : pz, pint, pz, pz, pint, integer_type_node,
3787 : : integer_type_node);
3788 : : }
3789 : :
3790 : : /* Other functions. */
3791 : 29874 : gfor_fndecl_iargc = gfc_build_library_function_decl (
3792 : : get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
3793 : 29874 : TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3794 : :
3795 : 29874 : gfor_fndecl_kill_sub = gfc_build_library_function_decl (
3796 : : get_identifier (PREFIX ("kill_sub")), void_type_node,
3797 : : 3, gfc_int4_type_node, gfc_int4_type_node, gfc_pint4_type_node);
3798 : :
3799 : 29874 : gfor_fndecl_kill = gfc_build_library_function_decl (
3800 : : get_identifier (PREFIX ("kill")), gfc_int4_type_node,
3801 : : 2, gfc_int4_type_node, gfc_int4_type_node);
3802 : :
3803 : 29874 : gfor_fndecl_is_contiguous0 = gfc_build_library_function_decl_with_spec (
3804 : : get_identifier (PREFIX("is_contiguous0")), ". R ",
3805 : : gfc_int4_type_node, 1, pvoid_type_node);
3806 : 29874 : DECL_PURE_P (gfor_fndecl_is_contiguous0) = 1;
3807 : 29874 : TREE_NOTHROW (gfor_fndecl_is_contiguous0) = 1;
3808 : 29874 : }
3809 : :
3810 : :
3811 : : /* Make prototypes for runtime library functions. */
3812 : :
3813 : : void
3814 : 29874 : gfc_build_builtin_function_decls (void)
3815 : : {
3816 : 29874 : tree gfc_int8_type_node = gfc_get_int_type (8);
3817 : :
3818 : 29874 : gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3819 : : get_identifier (PREFIX("stop_numeric")),
3820 : : void_type_node, 2, integer_type_node, boolean_type_node);
3821 : : /* STOP doesn't return. */
3822 : 29874 : TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3823 : :
3824 : 29874 : gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3825 : : get_identifier (PREFIX("stop_string")), ". R . . ",
3826 : : void_type_node, 3, pchar_type_node, size_type_node,
3827 : : boolean_type_node);
3828 : : /* STOP doesn't return. */
3829 : 29874 : TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3830 : :
3831 : 29874 : gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3832 : : get_identifier (PREFIX("error_stop_numeric")),
3833 : : void_type_node, 2, integer_type_node, boolean_type_node);
3834 : : /* ERROR STOP doesn't return. */
3835 : 29874 : TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3836 : :
3837 : 29874 : gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3838 : : get_identifier (PREFIX("error_stop_string")), ". R . . ",
3839 : : void_type_node, 3, pchar_type_node, size_type_node,
3840 : : boolean_type_node);
3841 : : /* ERROR STOP doesn't return. */
3842 : 29874 : TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3843 : :
3844 : 29874 : gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3845 : : get_identifier (PREFIX("pause_numeric")),
3846 : : void_type_node, 1, gfc_int8_type_node);
3847 : :
3848 : 29874 : gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3849 : : get_identifier (PREFIX("pause_string")), ". R . ",
3850 : : void_type_node, 2, pchar_type_node, size_type_node);
3851 : :
3852 : 29874 : gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3853 : : get_identifier (PREFIX("runtime_error")), ". R ",
3854 : : void_type_node, -1, pchar_type_node);
3855 : : /* The runtime_error function does not return. */
3856 : 29874 : TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
3857 : :
3858 : 29874 : gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
3859 : : get_identifier (PREFIX("runtime_error_at")), ". R R ",
3860 : : void_type_node, -2, pchar_type_node, pchar_type_node);
3861 : : /* The runtime_error_at function does not return. */
3862 : 29874 : TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
3863 : :
3864 : 29874 : gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
3865 : : get_identifier (PREFIX("runtime_warning_at")), ". R R ",
3866 : : void_type_node, -2, pchar_type_node, pchar_type_node);
3867 : :
3868 : 29874 : gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
3869 : : get_identifier (PREFIX("generate_error")), ". W . R ",
3870 : : void_type_node, 3, pvoid_type_node, integer_type_node,
3871 : : pchar_type_node);
3872 : :
3873 : 29874 : gfor_fndecl_os_error_at = gfc_build_library_function_decl_with_spec (
3874 : : get_identifier (PREFIX("os_error_at")), ". R R ",
3875 : : void_type_node, -2, pchar_type_node, pchar_type_node);
3876 : : /* The os_error_at function does not return. */
3877 : 29874 : TREE_THIS_VOLATILE (gfor_fndecl_os_error_at) = 1;
3878 : :
3879 : 29874 : gfor_fndecl_set_args = gfc_build_library_function_decl (
3880 : : get_identifier (PREFIX("set_args")),
3881 : : void_type_node, 2, integer_type_node,
3882 : : build_pointer_type (pchar_type_node));
3883 : :
3884 : 29874 : gfor_fndecl_set_fpe = gfc_build_library_function_decl (
3885 : : get_identifier (PREFIX("set_fpe")),
3886 : : void_type_node, 1, integer_type_node);
3887 : :
3888 : 29874 : gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl (
3889 : : get_identifier (PREFIX("ieee_procedure_entry")),
3890 : : void_type_node, 1, pvoid_type_node);
3891 : :
3892 : 29874 : gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl (
3893 : : get_identifier (PREFIX("ieee_procedure_exit")),
3894 : : void_type_node, 1, pvoid_type_node);
3895 : :
3896 : : /* Keep the array dimension in sync with the call, later in this file. */
3897 : 29874 : gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3898 : : get_identifier (PREFIX("set_options")), ". . R ",
3899 : : void_type_node, 2, integer_type_node,
3900 : : build_pointer_type (integer_type_node));
3901 : :
3902 : 29874 : gfor_fndecl_set_convert = gfc_build_library_function_decl (
3903 : : get_identifier (PREFIX("set_convert")),
3904 : : void_type_node, 1, integer_type_node);
3905 : :
3906 : 29874 : gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3907 : : get_identifier (PREFIX("set_record_marker")),
3908 : : void_type_node, 1, integer_type_node);
3909 : :
3910 : 29874 : gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3911 : : get_identifier (PREFIX("set_max_subrecord_length")),
3912 : : void_type_node, 1, integer_type_node);
3913 : :
3914 : 29874 : gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3915 : : get_identifier (PREFIX("internal_pack")), ". r ",
3916 : : pvoid_type_node, 1, pvoid_type_node);
3917 : :
3918 : 29874 : gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3919 : : get_identifier (PREFIX("internal_unpack")), ". w R ",
3920 : : void_type_node, 2, pvoid_type_node, pvoid_type_node);
3921 : :
3922 : 29874 : gfor_fndecl_in_pack_class = gfc_build_library_function_decl_with_spec (
3923 : : get_identifier (PREFIX ("internal_pack_class")), ". w R r r ",
3924 : : void_type_node, 4, pvoid_type_node, pvoid_type_node, size_type_node,
3925 : : integer_type_node);
3926 : :
3927 : 29874 : gfor_fndecl_in_unpack_class = gfc_build_library_function_decl_with_spec (
3928 : : get_identifier (PREFIX ("internal_unpack_class")), ". w R r r ",
3929 : : void_type_node, 4, pvoid_type_node, pvoid_type_node, size_type_node,
3930 : : integer_type_node);
3931 : :
3932 : 29874 : gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3933 : : get_identifier (PREFIX ("associated")), ". R R ", integer_type_node, 2,
3934 : : ppvoid_type_node, ppvoid_type_node);
3935 : 29874 : DECL_PURE_P (gfor_fndecl_associated) = 1;
3936 : 29874 : TREE_NOTHROW (gfor_fndecl_associated) = 1;
3937 : :
3938 : : /* Coarray library calls. */
3939 : 29874 : if (flag_coarray == GFC_FCOARRAY_LIB)
3940 : : {
3941 : 280 : tree pint_type, pppchar_type;
3942 : :
3943 : 280 : pint_type = build_pointer_type (integer_type_node);
3944 : 280 : pppchar_type
3945 : 280 : = build_pointer_type (build_pointer_type (pchar_type_node));
3946 : :
3947 : 280 : gfor_fndecl_caf_init = gfc_build_library_function_decl_with_spec (
3948 : : get_identifier (PREFIX("caf_init")), ". W W ",
3949 : : void_type_node, 2, pint_type, pppchar_type);
3950 : :
3951 : 280 : gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3952 : : get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3953 : :
3954 : 280 : gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
3955 : : get_identifier (PREFIX("caf_this_image")), integer_type_node,
3956 : : 1, integer_type_node);
3957 : :
3958 : 280 : gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
3959 : : get_identifier (PREFIX("caf_num_images")), integer_type_node,
3960 : : 2, integer_type_node, integer_type_node);
3961 : :
3962 : 280 : gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3963 : : get_identifier (PREFIX("caf_register")), ". . . W w w w . ",
3964 : : void_type_node, 7,
3965 : : size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node,
3966 : : pint_type, pchar_type_node, size_type_node);
3967 : :
3968 : 280 : gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3969 : : get_identifier (PREFIX("caf_deregister")), ". W . w w . ",
3970 : : void_type_node, 5,
3971 : : ppvoid_type_node, integer_type_node, pint_type, pchar_type_node,
3972 : : size_type_node);
3973 : :
3974 : 280 : gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
3975 : : get_identifier (PREFIX("caf_get")), ". r . . r r w . . . w ",
3976 : : void_type_node, 10,
3977 : : pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3978 : : pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3979 : : boolean_type_node, pint_type);
3980 : :
3981 : 280 : gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
3982 : : get_identifier (PREFIX("caf_send")), ". r . . w r r . . . w ",
3983 : : void_type_node, 11,
3984 : : pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3985 : : pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3986 : : boolean_type_node, pint_type, pvoid_type_node);
3987 : :
3988 : 280 : gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
3989 : : get_identifier (PREFIX("caf_sendget")), ". r . . w r r . . r r . . . w ",
3990 : : void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node,
3991 : : pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node,
3992 : : integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node,
3993 : : integer_type_node, boolean_type_node, integer_type_node);
3994 : :
3995 : 280 : gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec (
3996 : : get_identifier (PREFIX("caf_get_by_ref")), ". r . w r . . . . w . ",
3997 : : void_type_node,
3998 : : 10, pvoid_type_node, integer_type_node, pvoid_type_node,
3999 : : pvoid_type_node, integer_type_node, integer_type_node,
4000 : : boolean_type_node, boolean_type_node, pint_type, integer_type_node);
4001 : :
4002 : 280 : gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec (
4003 : : get_identifier (PREFIX("caf_send_by_ref")), ". r . r r . . . . w . ",
4004 : : void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node,
4005 : : pvoid_type_node, integer_type_node, integer_type_node,
4006 : : boolean_type_node, boolean_type_node, pint_type, integer_type_node);
4007 : :
4008 : 280 : gfor_fndecl_caf_sendget_by_ref
4009 : 280 : = gfc_build_library_function_decl_with_spec (
4010 : : get_identifier (PREFIX("caf_sendget_by_ref")),
4011 : : ". r . r r . r . . . w w . . ",
4012 : : void_type_node, 13, pvoid_type_node, integer_type_node,
4013 : : pvoid_type_node, pvoid_type_node, integer_type_node,
4014 : : pvoid_type_node, integer_type_node, integer_type_node,
4015 : : boolean_type_node, pint_type, pint_type, integer_type_node,
4016 : : integer_type_node);
4017 : :
4018 : 280 : gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
4019 : : get_identifier (PREFIX("caf_sync_all")), ". w w . ", void_type_node,
4020 : : 3, pint_type, pchar_type_node, size_type_node);
4021 : :
4022 : 280 : gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec (
4023 : : get_identifier (PREFIX("caf_sync_memory")), ". w w . ", void_type_node,
4024 : : 3, pint_type, pchar_type_node, size_type_node);
4025 : :
4026 : 280 : gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
4027 : : get_identifier (PREFIX("caf_sync_images")), ". . r w w . ", void_type_node,
4028 : : 5, integer_type_node, pint_type, pint_type,
4029 : : pchar_type_node, size_type_node);
4030 : :
4031 : 280 : gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
4032 : : get_identifier (PREFIX("caf_error_stop")),
4033 : : void_type_node, 1, integer_type_node);
4034 : : /* CAF's ERROR STOP doesn't return. */
4035 : 280 : TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
4036 : :
4037 : 280 : gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
4038 : : get_identifier (PREFIX("caf_error_stop_str")), ". r . ",
4039 : : void_type_node, 2, pchar_type_node, size_type_node);
4040 : : /* CAF's ERROR STOP doesn't return. */
4041 : 280 : TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
4042 : :
4043 : 280 : gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl (
4044 : : get_identifier (PREFIX("caf_stop_numeric")),
4045 : : void_type_node, 1, integer_type_node);
4046 : : /* CAF's STOP doesn't return. */
4047 : 280 : TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1;
4048 : :
4049 : 280 : gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec (
4050 : : get_identifier (PREFIX("caf_stop_str")), ". r . ",
4051 : : void_type_node, 2, pchar_type_node, size_type_node);
4052 : : /* CAF's STOP doesn't return. */
4053 : 280 : TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1;
4054 : :
4055 : 280 : gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec (
4056 : : get_identifier (PREFIX("caf_atomic_define")), ". r . . w w . . ",
4057 : : void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
4058 : : pvoid_type_node, pint_type, integer_type_node, integer_type_node);
4059 : :
4060 : 280 : gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec (
4061 : : get_identifier (PREFIX("caf_atomic_ref")), ". r . . w w . . ",
4062 : : void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
4063 : : pvoid_type_node, pint_type, integer_type_node, integer_type_node);
4064 : :
4065 : 280 : gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec (
4066 : : get_identifier (PREFIX("caf_atomic_cas")), ". r . . w r r w . . ",
4067 : : void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node,
4068 : : pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type,
4069 : : integer_type_node, integer_type_node);
4070 : :
4071 : 280 : gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec (
4072 : : get_identifier (PREFIX("caf_atomic_op")), ". . r . . r w w . . ",
4073 : : void_type_node, 9, integer_type_node, pvoid_type_node, size_type_node,
4074 : : integer_type_node, pvoid_type_node, pvoid_type_node, pint_type,
4075 : : integer_type_node, integer_type_node);
4076 : :
4077 : 280 : gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec (
4078 : : get_identifier (PREFIX("caf_lock")), ". r . . w w w . ",
4079 : : void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
4080 : : pint_type, pint_type, pchar_type_node, size_type_node);
4081 : :
4082 : 280 : gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec (
4083 : : get_identifier (PREFIX("caf_unlock")), ". r . . w w . ",
4084 : : void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
4085 : : pint_type, pchar_type_node, size_type_node);
4086 : :
4087 : 280 : gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
4088 : : get_identifier (PREFIX("caf_event_post")), ". r . . w w . ",
4089 : : void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
4090 : : pint_type, pchar_type_node, size_type_node);
4091 : :
4092 : 280 : gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
4093 : : get_identifier (PREFIX("caf_event_wait")), ". r . . w w . ",
4094 : : void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
4095 : : pint_type, pchar_type_node, size_type_node);
4096 : :
4097 : 280 : gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
4098 : : get_identifier (PREFIX("caf_event_query")), ". r . . w w ",
4099 : : void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
4100 : : pint_type, pint_type);
4101 : :
4102 : 280 : gfor_fndecl_caf_fail_image = gfc_build_library_function_decl (
4103 : : get_identifier (PREFIX("caf_fail_image")), void_type_node, 0);
4104 : : /* CAF's FAIL doesn't return. */
4105 : 280 : TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image) = 1;
4106 : :
4107 : 280 : gfor_fndecl_caf_failed_images
4108 : 280 : = gfc_build_library_function_decl_with_spec (
4109 : : get_identifier (PREFIX("caf_failed_images")), ". w . r ",
4110 : : void_type_node, 3, pvoid_type_node, ppvoid_type_node,
4111 : : integer_type_node);
4112 : :
4113 : 280 : gfor_fndecl_caf_form_team
4114 : 280 : = gfc_build_library_function_decl_with_spec (
4115 : : get_identifier (PREFIX("caf_form_team")), ". . W . ",
4116 : : void_type_node, 3, integer_type_node, ppvoid_type_node,
4117 : : integer_type_node);
4118 : :
4119 : 280 : gfor_fndecl_caf_change_team
4120 : 280 : = gfc_build_library_function_decl_with_spec (
4121 : : get_identifier (PREFIX("caf_change_team")), ". w . ",
4122 : : void_type_node, 2, ppvoid_type_node,
4123 : : integer_type_node);
4124 : :
4125 : 280 : gfor_fndecl_caf_end_team
4126 : 280 : = gfc_build_library_function_decl (
4127 : : get_identifier (PREFIX("caf_end_team")), void_type_node, 0);
4128 : :
4129 : 280 : gfor_fndecl_caf_get_team
4130 : 280 : = gfc_build_library_function_decl (
4131 : : get_identifier (PREFIX("caf_get_team")),
4132 : : void_type_node, 1, integer_type_node);
4133 : :
4134 : 280 : gfor_fndecl_caf_sync_team
4135 : 280 : = gfc_build_library_function_decl_with_spec (
4136 : : get_identifier (PREFIX("caf_sync_team")), ". r . ",
4137 : : void_type_node, 2, ppvoid_type_node,
4138 : : integer_type_node);
4139 : :
4140 : 280 : gfor_fndecl_caf_team_number
4141 : 280 : = gfc_build_library_function_decl_with_spec (
4142 : : get_identifier (PREFIX("caf_team_number")), ". r ",
4143 : : integer_type_node, 1, integer_type_node);
4144 : :
4145 : 280 : gfor_fndecl_caf_image_status
4146 : 280 : = gfc_build_library_function_decl_with_spec (
4147 : : get_identifier (PREFIX("caf_image_status")), ". . r ",
4148 : : integer_type_node, 2, integer_type_node, ppvoid_type_node);
4149 : :
4150 : 280 : gfor_fndecl_caf_stopped_images
4151 : 280 : = gfc_build_library_function_decl_with_spec (
4152 : : get_identifier (PREFIX("caf_stopped_images")), ". w r r ",
4153 : : void_type_node, 3, pvoid_type_node, ppvoid_type_node,
4154 : : integer_type_node);
4155 : :
4156 : 280 : gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
4157 : : get_identifier (PREFIX("caf_co_broadcast")), ". w . w w . ",
4158 : : void_type_node, 5, pvoid_type_node, integer_type_node,
4159 : : pint_type, pchar_type_node, size_type_node);
4160 : :
4161 : 280 : gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
4162 : : get_identifier (PREFIX("caf_co_max")), ". w . w w . . ",
4163 : : void_type_node, 6, pvoid_type_node, integer_type_node,
4164 : : pint_type, pchar_type_node, integer_type_node, size_type_node);
4165 : :
4166 : 280 : gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
4167 : : get_identifier (PREFIX("caf_co_min")), ". w . w w . . ",
4168 : : void_type_node, 6, pvoid_type_node, integer_type_node,
4169 : : pint_type, pchar_type_node, integer_type_node, size_type_node);
4170 : :
4171 : 280 : gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec (
4172 : : get_identifier (PREFIX("caf_co_reduce")), ". w r . . w w . . ",
4173 : : void_type_node, 8, pvoid_type_node,
4174 : : build_pointer_type (build_varargs_function_type_list (void_type_node,
4175 : : NULL_TREE)),
4176 : : integer_type_node, integer_type_node, pint_type, pchar_type_node,
4177 : : integer_type_node, size_type_node);
4178 : :
4179 : 280 : gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
4180 : : get_identifier (PREFIX("caf_co_sum")), ". w . w w . ",
4181 : : void_type_node, 5, pvoid_type_node, integer_type_node,
4182 : : pint_type, pchar_type_node, size_type_node);
4183 : :
4184 : 280 : gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec (
4185 : : get_identifier (PREFIX("caf_is_present")), ". r . r ",
4186 : : integer_type_node, 3, pvoid_type_node, integer_type_node,
4187 : : pvoid_type_node);
4188 : :
4189 : 280 : gfor_fndecl_caf_random_init = gfc_build_library_function_decl (
4190 : : get_identifier (PREFIX("caf_random_init")),
4191 : : void_type_node, 2, logical_type_node, logical_type_node);
4192 : : }
4193 : :
4194 : 29874 : gfc_build_intrinsic_function_decls ();
4195 : 29874 : gfc_build_intrinsic_lib_fndecls ();
4196 : 29874 : gfc_build_io_library_fndecls ();
4197 : 29874 : }
4198 : :
4199 : :
4200 : : /* Evaluate the length of dummy character variables. */
4201 : :
4202 : : static void
4203 : 744 : gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
4204 : : gfc_wrapped_block *block)
4205 : : {
4206 : 744 : stmtblock_t init;
4207 : :
4208 : 744 : gfc_finish_decl (cl->backend_decl);
4209 : :
4210 : 744 : gfc_start_block (&init);
4211 : :
4212 : : /* Evaluate the string length expression. */
4213 : 744 : gfc_conv_string_length (cl, NULL, &init);
4214 : :
4215 : 744 : gfc_trans_vla_type_sizes (sym, &init);
4216 : :
4217 : 744 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4218 : 744 : }
4219 : :
4220 : :
4221 : : /* Allocate and cleanup an automatic character variable. */
4222 : :
4223 : : static void
4224 : 353 : gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
4225 : : {
4226 : 353 : stmtblock_t init;
4227 : 353 : tree decl;
4228 : 353 : tree tmp;
4229 : 353 : bool back;
4230 : :
4231 : 353 : gcc_assert (sym->backend_decl);
4232 : 353 : gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
4233 : :
4234 : 353 : gfc_init_block (&init);
4235 : :
4236 : : /* In the case of non-dummy symbols with dependencies on an old-fashioned
4237 : : function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
4238 : : must be called with the last, optional argument false so that the process
4239 : : ing of the character length occurs after the processing of the result. */
4240 : 353 : back = sym->fn_result_dep;
4241 : :
4242 : : /* Evaluate the string length expression. */
4243 : 353 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4244 : :
4245 : 353 : gfc_trans_vla_type_sizes (sym, &init);
4246 : :
4247 : 353 : decl = sym->backend_decl;
4248 : :
4249 : : /* Emit a DECL_EXPR for this variable, which will cause the
4250 : : gimplifier to allocate storage, and all that good stuff. */
4251 : 353 : tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
4252 : 353 : gfc_add_expr_to_block (&init, tmp);
4253 : :
4254 : 353 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE, back);
4255 : 353 : }
4256 : :
4257 : : /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
4258 : :
4259 : : static void
4260 : 64 : gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
4261 : : {
4262 : 64 : stmtblock_t init;
4263 : :
4264 : 64 : gcc_assert (sym->backend_decl);
4265 : 64 : gfc_start_block (&init);
4266 : :
4267 : : /* Set the initial value to length. See the comments in
4268 : : function gfc_add_assign_aux_vars in this file. */
4269 : 64 : gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
4270 : 64 : build_int_cst (gfc_charlen_type_node, -2));
4271 : :
4272 : 64 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4273 : 64 : }
4274 : :
4275 : : static void
4276 : 147062 : gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
4277 : : {
4278 : 147062 : tree t = *tp, var, val;
4279 : :
4280 : 147062 : if (t == NULL || t == error_mark_node)
4281 : : return;
4282 : 137597 : if (TREE_CONSTANT (t) || DECL_P (t))
4283 : : return;
4284 : :
4285 : 56036 : if (TREE_CODE (t) == SAVE_EXPR)
4286 : : {
4287 : 32052 : if (SAVE_EXPR_RESOLVED_P (t))
4288 : : {
4289 : 0 : *tp = TREE_OPERAND (t, 0);
4290 : 0 : return;
4291 : : }
4292 : 32052 : val = TREE_OPERAND (t, 0);
4293 : : }
4294 : : else
4295 : : val = t;
4296 : :
4297 : 56036 : var = gfc_create_var_np (TREE_TYPE (t), NULL);
4298 : 56036 : gfc_add_decl_to_function (var);
4299 : 56036 : gfc_add_modify (body, var, unshare_expr (val));
4300 : 56036 : if (TREE_CODE (t) == SAVE_EXPR)
4301 : 32052 : TREE_OPERAND (t, 0) = var;
4302 : 56036 : *tp = var;
4303 : : }
4304 : :
4305 : : static void
4306 : 82260 : gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
4307 : : {
4308 : 82260 : tree t;
4309 : :
4310 : 82260 : if (type == NULL || type == error_mark_node)
4311 : : return;
4312 : :
4313 : 82260 : type = TYPE_MAIN_VARIANT (type);
4314 : :
4315 : 82260 : if (TREE_CODE (type) == INTEGER_TYPE)
4316 : : {
4317 : 45418 : gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
4318 : 45418 : gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
4319 : :
4320 : 59250 : for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
4321 : : {
4322 : 13832 : TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
4323 : 13832 : TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
4324 : : }
4325 : : }
4326 : 36842 : else if (TREE_CODE (type) == ARRAY_TYPE)
4327 : : {
4328 : 28113 : gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
4329 : 28113 : gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
4330 : 28113 : gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
4331 : 28113 : gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
4332 : :
4333 : 28113 : for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
4334 : : {
4335 : 0 : TYPE_SIZE (t) = TYPE_SIZE (type);
4336 : 0 : TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
4337 : : }
4338 : : }
4339 : : }
4340 : :
4341 : : /* Make sure all type sizes and array domains are either constant,
4342 : : or variable or parameter decls. This is a simplified variant
4343 : : of gimplify_type_sizes, but we can't use it here, as none of the
4344 : : variables in the expressions have been gimplified yet.
4345 : : As type sizes and domains for various variable length arrays
4346 : : contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
4347 : : time, without this routine gimplify_type_sizes in the middle-end
4348 : : could result in the type sizes being gimplified earlier than where
4349 : : those variables are initialized. */
4350 : :
4351 : : void
4352 : 24700 : gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
4353 : : {
4354 : 24700 : tree type = TREE_TYPE (sym->backend_decl);
4355 : :
4356 : 24700 : if (TREE_CODE (type) == FUNCTION_TYPE
4357 : 1041 : && (sym->attr.function || sym->attr.result || sym->attr.entry))
4358 : : {
4359 : 1041 : if (! current_fake_result_decl)
4360 : : return;
4361 : :
4362 : 1041 : type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
4363 : : }
4364 : :
4365 : 48617 : while (POINTER_TYPE_P (type))
4366 : 23917 : type = TREE_TYPE (type);
4367 : :
4368 : 24700 : if (GFC_DESCRIPTOR_TYPE_P (type))
4369 : : {
4370 : 1334 : tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
4371 : :
4372 : 2668 : while (POINTER_TYPE_P (etype))
4373 : 1334 : etype = TREE_TYPE (etype);
4374 : :
4375 : 1334 : gfc_trans_vla_type_sizes_1 (etype, body);
4376 : : }
4377 : :
4378 : 24700 : gfc_trans_vla_type_sizes_1 (type, body);
4379 : : }
4380 : :
4381 : :
4382 : : /* Initialize a derived type by building an lvalue from the symbol
4383 : : and using trans_assignment to do the work. Set dealloc to false
4384 : : if no deallocation prior the assignment is needed. */
4385 : : void
4386 : 1114 : gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
4387 : : {
4388 : 1114 : gfc_expr *e;
4389 : 1114 : tree tmp;
4390 : 1114 : tree present;
4391 : :
4392 : 1114 : gcc_assert (block);
4393 : :
4394 : : /* Initialization of PDTs is done elsewhere. */
4395 : 1114 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
4396 : : return;
4397 : :
4398 : 958 : gcc_assert (!sym->attr.allocatable);
4399 : 958 : gfc_set_sym_referenced (sym);
4400 : 958 : e = gfc_lval_expr_from_sym (sym);
4401 : 958 : tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
4402 : 958 : if (sym->attr.dummy && (sym->attr.optional
4403 : 210 : || sym->ns->proc_name->attr.entry_master))
4404 : : {
4405 : 39 : present = gfc_conv_expr_present (sym);
4406 : 39 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
4407 : : tmp, build_empty_stmt (input_location));
4408 : : }
4409 : 958 : gfc_add_expr_to_block (block, tmp);
4410 : 958 : gfc_free_expr (e);
4411 : : }
4412 : :
4413 : :
4414 : : /* Initialize INTENT(OUT) derived type dummies. As well as giving
4415 : : them their default initializer, if they have allocatable
4416 : : components, they have their allocatable components deallocated. */
4417 : :
4418 : : static void
4419 : 87625 : init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
4420 : : {
4421 : 87625 : stmtblock_t init;
4422 : 87625 : gfc_formal_arglist *f;
4423 : 87625 : tree tmp;
4424 : 87625 : tree present;
4425 : 87625 : gfc_symbol *s;
4426 : 87625 : bool dealloc_with_value = false;
4427 : :
4428 : 87625 : gfc_init_block (&init);
4429 : 173995 : for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
4430 : 86370 : if (f->sym && f->sym->attr.intent == INTENT_OUT
4431 : 2901 : && !f->sym->attr.pointer
4432 : 2847 : && f->sym->ts.type == BT_DERIVED)
4433 : : {
4434 : 502 : s = f->sym;
4435 : 502 : tmp = NULL_TREE;
4436 : :
4437 : : /* Note: Allocatables are excluded as they are already handled
4438 : : by the caller. */
4439 : 502 : if (!f->sym->attr.allocatable
4440 : 502 : && gfc_is_finalizable (s->ts.u.derived, NULL))
4441 : : {
4442 : 32 : stmtblock_t block;
4443 : 32 : gfc_expr *e;
4444 : :
4445 : 32 : gfc_init_block (&block);
4446 : 32 : s->attr.referenced = 1;
4447 : 32 : e = gfc_lval_expr_from_sym (s);
4448 : 32 : gfc_add_finalizer_call (&block, e);
4449 : 32 : gfc_free_expr (e);
4450 : 32 : tmp = gfc_finish_block (&block);
4451 : : }
4452 : :
4453 : : /* Note: Allocatables are excluded as they are already handled
4454 : : by the caller. */
4455 : 502 : if (tmp == NULL_TREE && !s->attr.allocatable
4456 : 351 : && s->ts.u.derived->attr.alloc_comp)
4457 : : {
4458 : 125 : tmp = gfc_deallocate_alloc_comp (s->ts.u.derived,
4459 : : s->backend_decl,
4460 : 125 : s->as ? s->as->rank : 0);
4461 : 125 : dealloc_with_value = s->value;
4462 : : }
4463 : :
4464 : 502 : if (tmp != NULL_TREE && (s->attr.optional
4465 : 138 : || s->ns->proc_name->attr.entry_master))
4466 : : {
4467 : 19 : present = gfc_conv_expr_present (s);
4468 : 19 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
4469 : : present, tmp, build_empty_stmt (input_location));
4470 : : }
4471 : :
4472 : 502 : if (tmp != NULL_TREE && !dealloc_with_value)
4473 : 32 : gfc_add_expr_to_block (&init, tmp);
4474 : 470 : else if (s->value && !s->attr.allocatable)
4475 : : {
4476 : 242 : gfc_add_expr_to_block (&init, tmp);
4477 : 242 : gfc_init_default_dt (s, &init, false);
4478 : 242 : dealloc_with_value = false;
4479 : : }
4480 : : }
4481 : 85868 : else if (f->sym && f->sym->attr.intent == INTENT_OUT
4482 : 2399 : && f->sym->ts.type == BT_CLASS
4483 : 580 : && !CLASS_DATA (f->sym)->attr.class_pointer
4484 : 580 : && !CLASS_DATA (f->sym)->attr.allocatable)
4485 : : {
4486 : 356 : stmtblock_t block;
4487 : 356 : gfc_expr *e;
4488 : :
4489 : 356 : gfc_init_block (&block);
4490 : 356 : f->sym->attr.referenced = 1;
4491 : 356 : e = gfc_lval_expr_from_sym (f->sym);
4492 : 356 : gfc_add_finalizer_call (&block, e);
4493 : 356 : gfc_free_expr (e);
4494 : 356 : tmp = gfc_finish_block (&block);
4495 : :
4496 : 356 : if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
4497 : : {
4498 : 6 : present = gfc_conv_expr_present (f->sym);
4499 : 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
4500 : : present, tmp,
4501 : : build_empty_stmt (input_location));
4502 : : }
4503 : 356 : gfc_add_expr_to_block (&init, tmp);
4504 : : }
4505 : 87625 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4506 : 87625 : }
4507 : :
4508 : :
4509 : : /* Helper function to manage deferred string lengths. */
4510 : :
4511 : : static tree
4512 : 150 : gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
4513 : : locus *loc)
4514 : : {
4515 : 150 : tree tmp;
4516 : :
4517 : : /* Character length passed by reference. */
4518 : 150 : tmp = sym->ts.u.cl->passed_length;
4519 : 150 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4520 : 150 : tmp = fold_convert (gfc_charlen_type_node, tmp);
4521 : :
4522 : 150 : if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
4523 : : /* Zero the string length when entering the scope. */
4524 : 150 : gfc_add_modify (init, sym->ts.u.cl->backend_decl,
4525 : 150 : build_int_cst (gfc_charlen_type_node, 0));
4526 : : else
4527 : : {
4528 : 0 : tree tmp2;
4529 : :
4530 : 0 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
4531 : : gfc_charlen_type_node,
4532 : 0 : sym->ts.u.cl->backend_decl, tmp);
4533 : 0 : if (sym->attr.optional)
4534 : : {
4535 : 0 : tree present = gfc_conv_expr_present (sym);
4536 : 0 : tmp2 = build3_loc (input_location, COND_EXPR,
4537 : : void_type_node, present, tmp2,
4538 : : build_empty_stmt (input_location));
4539 : : }
4540 : 0 : gfc_add_expr_to_block (init, tmp2);
4541 : : }
4542 : :
4543 : 150 : gfc_restore_backend_locus (loc);
4544 : :
4545 : : /* Pass the final character length back. */
4546 : 150 : if (sym->attr.intent != INTENT_IN)
4547 : : {
4548 : 300 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4549 : : gfc_charlen_type_node, tmp,
4550 : 150 : sym->ts.u.cl->backend_decl);
4551 : 150 : if (sym->attr.optional)
4552 : : {
4553 : 0 : tree present = gfc_conv_expr_present (sym);
4554 : 0 : tmp = build3_loc (input_location, COND_EXPR,
4555 : : void_type_node, present, tmp,
4556 : : build_empty_stmt (input_location));
4557 : : }
4558 : : }
4559 : : else
4560 : : tmp = NULL_TREE;
4561 : :
4562 : 150 : return tmp;
4563 : : }
4564 : :
4565 : :
4566 : : /* Get the result expression for a procedure. */
4567 : :
4568 : : static tree
4569 : 22423 : get_proc_result (gfc_symbol* sym)
4570 : : {
4571 : 22423 : if (sym->attr.subroutine || sym == sym->result)
4572 : : {
4573 : 15215 : if (current_fake_result_decl != NULL)
4574 : 15008 : return TREE_VALUE (current_fake_result_decl);
4575 : :
4576 : : return NULL_TREE;
4577 : : }
4578 : :
4579 : 7208 : return sym->result->backend_decl;
4580 : : }
4581 : :
4582 : :
4583 : : /* Generate function entry and exit code, and add it to the function body.
4584 : : This includes:
4585 : : Allocation and initialization of array variables.
4586 : : Allocation of character string variables.
4587 : : Initialization and possibly repacking of dummy arrays.
4588 : : Initialization of ASSIGN statement auxiliary variable.
4589 : : Initialization of ASSOCIATE names.
4590 : : Automatic deallocation. */
4591 : :
4592 : : void
4593 : 87625 : gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
4594 : : {
4595 : 87625 : locus loc;
4596 : 87625 : gfc_symbol *sym;
4597 : 87625 : gfc_formal_arglist *f;
4598 : 87625 : stmtblock_t tmpblock;
4599 : 87625 : bool seen_trans_deferred_array = false;
4600 : 87625 : bool is_pdt_type = false;
4601 : 87625 : tree tmp = NULL;
4602 : 87625 : gfc_expr *e;
4603 : 87625 : gfc_se se;
4604 : 87625 : stmtblock_t init;
4605 : :
4606 : : /* Deal with implicit return variables. Explicit return variables will
4607 : : already have been added. */
4608 : 87625 : if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
4609 : : {
4610 : 1602 : if (!current_fake_result_decl)
4611 : : {
4612 : 79 : gfc_entry_list *el = NULL;
4613 : 79 : if (proc_sym->attr.entry_master)
4614 : : {
4615 : 46 : for (el = proc_sym->ns->entries; el; el = el->next)
4616 : 46 : if (el->sym != el->sym->result)
4617 : : break;
4618 : : }
4619 : : /* TODO: move to the appropriate place in resolve.cc. */
4620 : 79 : if (warn_return_type > 0 && el == NULL)
4621 : 4 : gfc_warning (OPT_Wreturn_type,
4622 : : "Return value of function %qs at %L not set",
4623 : : proc_sym->name, &proc_sym->declared_at);
4624 : : }
4625 : 1523 : else if (proc_sym->as)
4626 : : {
4627 : 785 : tree result = TREE_VALUE (current_fake_result_decl);
4628 : 785 : gfc_save_backend_locus (&loc);
4629 : 785 : gfc_set_backend_locus (&proc_sym->declared_at);
4630 : 785 : gfc_trans_dummy_array_bias (proc_sym, result, block);
4631 : :
4632 : : /* An automatic character length, pointer array result. */
4633 : 785 : if (proc_sym->ts.type == BT_CHARACTER
4634 : 69 : && VAR_P (proc_sym->ts.u.cl->backend_decl))
4635 : : {
4636 : 51 : tmp = NULL;
4637 : 51 : if (proc_sym->ts.deferred)
4638 : : {
4639 : 12 : gfc_start_block (&init);
4640 : 12 : tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc);
4641 : 12 : gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4642 : : }
4643 : : else
4644 : 39 : gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
4645 : : }
4646 : : }
4647 : 738 : else if (proc_sym->ts.type == BT_CHARACTER)
4648 : : {
4649 : 702 : if (proc_sym->ts.deferred)
4650 : : {
4651 : 77 : tmp = NULL;
4652 : 77 : gfc_save_backend_locus (&loc);
4653 : 77 : gfc_set_backend_locus (&proc_sym->declared_at);
4654 : 77 : gfc_start_block (&init);
4655 : : /* Zero the string length on entry. */
4656 : 77 : gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
4657 : 77 : build_int_cst (gfc_charlen_type_node, 0));
4658 : : /* Null the pointer. */
4659 : 77 : e = gfc_lval_expr_from_sym (proc_sym);
4660 : 77 : gfc_init_se (&se, NULL);
4661 : 77 : se.want_pointer = 1;
4662 : 77 : gfc_conv_expr (&se, e);
4663 : 77 : gfc_free_expr (e);
4664 : 77 : tmp = se.expr;
4665 : 77 : gfc_add_modify (&init, tmp,
4666 : 77 : fold_convert (TREE_TYPE (se.expr),
4667 : : null_pointer_node));
4668 : 77 : gfc_restore_backend_locus (&loc);
4669 : :
4670 : : /* Pass back the string length on exit. */
4671 : 77 : tmp = proc_sym->ts.u.cl->backend_decl;
4672 : 77 : if (TREE_CODE (tmp) != INDIRECT_REF
4673 : 77 : && proc_sym->ts.u.cl->passed_length)
4674 : : {
4675 : 77 : tmp = proc_sym->ts.u.cl->passed_length;
4676 : 77 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4677 : 154 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4678 : 77 : TREE_TYPE (tmp), tmp,
4679 : 77 : fold_convert
4680 : : (TREE_TYPE (tmp),
4681 : : proc_sym->ts.u.cl->backend_decl));
4682 : : }
4683 : : else
4684 : : tmp = NULL_TREE;
4685 : :
4686 : 77 : gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4687 : : }
4688 : 625 : else if (VAR_P (proc_sym->ts.u.cl->backend_decl))
4689 : 366 : gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
4690 : : }
4691 : : else
4692 : 36 : gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX);
4693 : : }
4694 : 86023 : else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
4695 : : {
4696 : : /* Nullify explicit return class arrays on entry. */
4697 : 27 : tree type;
4698 : 27 : tmp = get_proc_result (proc_sym);
4699 : 27 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
4700 : : {
4701 : 27 : gfc_start_block (&init);
4702 : 27 : tmp = gfc_class_data_get (tmp);
4703 : 27 : type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
4704 : 27 : gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
4705 : 27 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4706 : : }
4707 : : }
4708 : :
4709 : :
4710 : : /* Initialize the INTENT(OUT) derived type dummy arguments. This
4711 : : should be done here so that the offsets and lbounds of arrays
4712 : : are available. */
4713 : 87625 : gfc_save_backend_locus (&loc);
4714 : 87625 : gfc_set_backend_locus (&proc_sym->declared_at);
4715 : 87625 : init_intent_out_dt (proc_sym, block);
4716 : 87625 : gfc_restore_backend_locus (&loc);
4717 : :
4718 : : /* For some reasons, internal procedures point to the parent's
4719 : : namespace. Top-level procedure and variables inside BLOCK are fine. */
4720 : 87625 : gfc_namespace *omp_ns = proc_sym->ns;
4721 : 87625 : if (proc_sym->ns->proc_name != proc_sym)
4722 : 134104 : for (omp_ns = proc_sym->ns->contained; omp_ns;
4723 : 104319 : omp_ns = omp_ns->sibling)
4724 : 133990 : if (omp_ns->proc_name == proc_sym)
4725 : : break;
4726 : :
4727 : : /* Add 'omp allocate' attribute for gfc_trans_auto_array_allocation and
4728 : : unset attr.omp_allocate for 'omp allocate allocator(omp_default_mem_alloc),
4729 : : which has the normal codepath except for an invalid-use check in the ME.
4730 : : The main processing happens later in this function. */
4731 : 87625 : for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
4732 : 87674 : n; n = n->next)
4733 : 49 : if (!TREE_STATIC (n->sym->backend_decl))
4734 : : {
4735 : : /* Add empty entries - described and to be filled below. */
4736 : 36 : tree tmp = build_tree_list (NULL_TREE, NULL_TREE);
4737 : 36 : TREE_CHAIN (tmp) = build_tree_list (NULL_TREE, NULL_TREE);
4738 : 36 : DECL_ATTRIBUTES (n->sym->backend_decl)
4739 : 36 : = tree_cons (get_identifier ("omp allocate"), tmp,
4740 : 36 : DECL_ATTRIBUTES (n->sym->backend_decl));
4741 : 36 : if (n->u.align == NULL
4742 : 29 : && n->u2.allocator != NULL
4743 : 7 : && n->u2.allocator->expr_type == EXPR_CONSTANT
4744 : 2 : && mpz_cmp_si (n->u2.allocator->value.integer, 1) == 0)
4745 : 1 : n->sym->attr.omp_allocate = 0;
4746 : : }
4747 : :
4748 : 151069 : for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
4749 : : {
4750 : 63444 : bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
4751 : 63444 : && (sym->ts.u.derived->attr.alloc_comp
4752 : 5059 : || gfc_is_finalizable (sym->ts.u.derived,
4753 : 63444 : NULL));
4754 : 63444 : if (sym->assoc)
4755 : 4546 : continue;
4756 : :
4757 : : /* Set the vptr of unlimited polymorphic pointer variables so that
4758 : : they do not cause segfaults in select type, when the selector
4759 : : is an intrinsic type. */
4760 : 58898 : if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
4761 : 877 : && sym->attr.flavor == FL_VARIABLE && !sym->assoc
4762 : 877 : && !sym->attr.dummy && CLASS_DATA (sym)->attr.class_pointer)
4763 : : {
4764 : 253 : gfc_symbol *vtab;
4765 : 253 : gfc_init_block (&tmpblock);
4766 : 253 : vtab = gfc_find_vtab (&sym->ts);
4767 : 253 : if (!vtab->backend_decl)
4768 : : {
4769 : 42 : if (!vtab->attr.referenced)
4770 : 6 : gfc_set_sym_referenced (vtab);
4771 : 42 : gfc_get_symbol_decl (vtab);
4772 : : }
4773 : 253 : tmp = gfc_class_vptr_get (sym->backend_decl);
4774 : 253 : gfc_add_modify (&tmpblock, tmp,
4775 : 253 : gfc_build_addr_expr (TREE_TYPE (tmp),
4776 : : vtab->backend_decl));
4777 : 253 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
4778 : : }
4779 : :
4780 : 58898 : if (sym->ts.type == BT_DERIVED
4781 : 8804 : && sym->ts.u.derived
4782 : 8804 : && sym->ts.u.derived->attr.pdt_type)
4783 : : {
4784 : 297 : is_pdt_type = true;
4785 : 297 : gfc_init_block (&tmpblock);
4786 : 297 : if (!(sym->attr.dummy
4787 : : || sym->attr.pointer
4788 : : || sym->attr.allocatable))
4789 : : {
4790 : 168 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
4791 : : sym->backend_decl,
4792 : 168 : sym->as ? sym->as->rank : 0,
4793 : : sym->param_list);
4794 : 168 : gfc_add_expr_to_block (&tmpblock, tmp);
4795 : 168 : if (!sym->attr.result)
4796 : 168 : tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
4797 : : sym->backend_decl,
4798 : 168 : sym->as ? sym->as->rank : 0);
4799 : : else
4800 : : tmp = NULL_TREE;
4801 : 168 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
4802 : : }
4803 : 129 : else if (sym->attr.dummy)
4804 : : {
4805 : 48 : tmp = gfc_check_pdt_dummy (sym->ts.u.derived,
4806 : : sym->backend_decl,
4807 : 48 : sym->as ? sym->as->rank : 0,
4808 : : sym->param_list);
4809 : 48 : gfc_add_expr_to_block (&tmpblock, tmp);
4810 : 48 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
4811 : : }
4812 : : }
4813 : 58601 : else if (sym->ts.type == BT_CLASS
4814 : 3421 : && CLASS_DATA (sym)->ts.u.derived
4815 : 3421 : && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
4816 : : {
4817 : 6 : gfc_component *data = CLASS_DATA (sym);
4818 : 6 : is_pdt_type = true;
4819 : 6 : gfc_init_block (&tmpblock);
4820 : 6 : if (!(sym->attr.dummy
4821 : 6 : || CLASS_DATA (sym)->attr.pointer
4822 : : || CLASS_DATA (sym)->attr.allocatable))
4823 : : {
4824 : 0 : tmp = gfc_class_data_get (sym->backend_decl);
4825 : 0 : tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp,
4826 : 0 : data->as ? data->as->rank : 0,
4827 : : sym->param_list);
4828 : 0 : gfc_add_expr_to_block (&tmpblock, tmp);
4829 : 0 : tmp = gfc_class_data_get (sym->backend_decl);
4830 : 0 : if (!sym->attr.result)
4831 : 0 : tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
4832 : 0 : data->as ? data->as->rank : 0);
4833 : : else
4834 : : tmp = NULL_TREE;
4835 : 0 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
4836 : : }
4837 : 6 : else if (sym->attr.dummy)
4838 : : {
4839 : 0 : tmp = gfc_class_data_get (sym->backend_decl);
4840 : 0 : tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp,
4841 : 0 : data->as ? data->as->rank : 0,
4842 : : sym->param_list);
4843 : 0 : gfc_add_expr_to_block (&tmpblock, tmp);
4844 : 0 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
4845 : : }
4846 : : }
4847 : :
4848 : 58898 : if (sym->attr.pointer && sym->attr.dimension
4849 : : && sym->attr.save == SAVE_NONE
4850 : : && !sym->attr.use_assoc
4851 : : && !sym->attr.host_assoc
4852 : 58898 : && !sym->attr.dummy
4853 : 58898 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
4854 : : {
4855 : 3065 : gfc_init_block (&tmpblock);
4856 : 3065 : gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
4857 : 3065 : build_int_cst (gfc_array_index_type, 0));
4858 : 3065 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4859 : : NULL_TREE);
4860 : : }
4861 : :
4862 : 58898 : if (sym->ts.type == BT_CLASS
4863 : 3421 : && (sym->attr.save || flag_max_stack_var_size == 0)
4864 : 57 : && CLASS_DATA (sym)->attr.allocatable)
4865 : : {
4866 : 39 : tree vptr;
4867 : :
4868 : 39 : if (UNLIMITED_POLY (sym))
4869 : 0 : vptr = null_pointer_node;
4870 : : else
4871 : : {
4872 : 39 : gfc_symbol *vsym;
4873 : 39 : vsym = gfc_find_derived_vtab (sym->ts.u.derived);
4874 : 39 : vptr = gfc_get_symbol_decl (vsym);
4875 : 39 : vptr = gfc_build_addr_expr (NULL, vptr);
4876 : : }
4877 : :
4878 : 39 : if (CLASS_DATA (sym)->attr.dimension
4879 : 7 : || (CLASS_DATA (sym)->attr.codimension
4880 : 1 : && flag_coarray != GFC_FCOARRAY_LIB))
4881 : : {
4882 : 33 : tmp = gfc_class_data_get (sym->backend_decl);
4883 : 33 : tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
4884 : : }
4885 : : else
4886 : 6 : tmp = null_pointer_node;
4887 : :
4888 : 39 : DECL_INITIAL (sym->backend_decl)
4889 : 39 : = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
4890 : 39 : TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
4891 : 39 : }
4892 : 58859 : else if ((sym->attr.dimension || sym->attr.codimension
4893 : 10573 : || (IS_CLASS_COARRAY_OR_ARRAY (sym)
4894 : 2045 : && !CLASS_DATA (sym)->attr.allocatable)))
4895 : : {
4896 : 49025 : bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
4897 : 49025 : symbol_attribute *array_attr;
4898 : 49025 : gfc_array_spec *as;
4899 : 49025 : array_type type_of_array;
4900 : :
4901 : 49025 : array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
4902 : 49025 : as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
4903 : : /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
4904 : 49025 : type_of_array = as->type;
4905 : 49025 : if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed)
4906 : : type_of_array = AS_EXPLICIT;
4907 : 48954 : switch (type_of_array)
4908 : : {
4909 : 33269 : case AS_EXPLICIT:
4910 : 33269 : if (sym->attr.dummy || sym->attr.result)
4911 : 5744 : gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4912 : : /* Allocatable and pointer arrays need to processed
4913 : : explicitly. */
4914 : 27525 : else if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
4915 : 27525 : || (sym->ts.type == BT_CLASS
4916 : 0 : && CLASS_DATA (sym)->attr.class_pointer)
4917 : 27525 : || array_attr->allocatable)
4918 : : {
4919 : 0 : if (TREE_STATIC (sym->backend_decl))
4920 : : {
4921 : 0 : gfc_save_backend_locus (&loc);
4922 : 0 : gfc_set_backend_locus (&sym->declared_at);
4923 : 0 : gfc_trans_static_array_pointer (sym);
4924 : 0 : gfc_restore_backend_locus (&loc);
4925 : : }
4926 : : else
4927 : : {
4928 : 0 : seen_trans_deferred_array = true;
4929 : 0 : gfc_trans_deferred_array (sym, block);
4930 : : }
4931 : : }
4932 : 27525 : else if (sym->attr.codimension
4933 : 329 : && TREE_STATIC (sym->backend_decl))
4934 : : {
4935 : 286 : gfc_init_block (&tmpblock);
4936 : 286 : gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
4937 : : &tmpblock, sym);
4938 : 286 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4939 : : NULL_TREE);
4940 : 286 : continue;
4941 : : }
4942 : : else
4943 : : {
4944 : 27239 : gfc_save_backend_locus (&loc);
4945 : 27239 : gfc_set_backend_locus (&sym->declared_at);
4946 : :
4947 : 27239 : if (alloc_comp_or_fini)
4948 : : {
4949 : 436 : seen_trans_deferred_array = true;
4950 : 436 : gfc_trans_deferred_array (sym, block);
4951 : : }
4952 : 26803 : else if (sym->ts.type == BT_DERIVED
4953 : 1616 : && sym->value
4954 : : && !sym->attr.data
4955 : 452 : && sym->attr.save == SAVE_NONE)
4956 : : {
4957 : 245 : gfc_start_block (&tmpblock);
4958 : 245 : gfc_init_default_dt (sym, &tmpblock, false);
4959 : 245 : gfc_add_init_cleanup (block,
4960 : : gfc_finish_block (&tmpblock),
4961 : : NULL_TREE);
4962 : : }
4963 : :
4964 : 27239 : gfc_trans_auto_array_allocation (sym->backend_decl,
4965 : : sym, block);
4966 : 27239 : gfc_restore_backend_locus (&loc);
4967 : : }
4968 : : break;
4969 : :
4970 : 1499 : case AS_ASSUMED_SIZE:
4971 : : /* Must be a dummy parameter. */
4972 : 1499 : gcc_assert (sym->attr.dummy || as->cp_was_assumed);
4973 : :
4974 : : /* We should always pass assumed size arrays the g77 way. */
4975 : 1499 : if (sym->attr.dummy)
4976 : 1499 : gfc_trans_g77_array (sym, block);
4977 : : break;
4978 : :
4979 : 5153 : case AS_ASSUMED_SHAPE:
4980 : : /* Must be a dummy parameter. */
4981 : 5153 : gcc_assert (sym->attr.dummy);
4982 : :
4983 : 5153 : gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4984 : 5153 : break;
4985 : :
4986 : 9104 : case AS_ASSUMED_RANK:
4987 : 9104 : case AS_DEFERRED:
4988 : 9104 : seen_trans_deferred_array = true;
4989 : 9104 : gfc_trans_deferred_array (sym, block);
4990 : 9104 : if (sym->ts.type == BT_CHARACTER && sym->ts.deferred
4991 : 598 : && sym->attr.result)
4992 : : {
4993 : 32 : gfc_start_block (&init);
4994 : 32 : gfc_save_backend_locus (&loc);
4995 : 32 : gfc_set_backend_locus (&sym->declared_at);
4996 : 32 : tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4997 : 32 : gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4998 : : }
4999 : : break;
5000 : :
5001 : 0 : default:
5002 : 0 : gcc_unreachable ();
5003 : : }
5004 : 48739 : if (alloc_comp_or_fini && !seen_trans_deferred_array)
5005 : 207 : gfc_trans_deferred_array (sym, block);
5006 : : }
5007 : 9834 : else if ((!sym->attr.dummy || sym->ts.deferred)
5008 : 9640 : && (sym->ts.type == BT_CLASS
5009 : 2643 : && CLASS_DATA (sym)->attr.class_pointer))
5010 : 458 : gfc_trans_class_array (sym, block);
5011 : 9376 : else if ((!sym->attr.dummy || sym->ts.deferred)
5012 : 9182 : && (sym->attr.allocatable
5013 : 7089 : || (sym->attr.pointer && sym->attr.result)
5014 : 7045 : || (sym->ts.type == BT_CLASS
5015 : 2185 : && CLASS_DATA (sym)->attr.allocatable)))
5016 : : {
5017 : 4322 : if (!sym->attr.save && flag_max_stack_var_size != 0)
5018 : : {
5019 : 4255 : tree descriptor = NULL_TREE;
5020 : :
5021 : 4255 : gfc_save_backend_locus (&loc);
5022 : 4255 : gfc_set_backend_locus (&sym->declared_at);
5023 : 4255 : gfc_start_block (&init);
5024 : :
5025 : 4255 : if (sym->ts.type == BT_CHARACTER
5026 : : && sym->attr.allocatable
5027 : 861 : && !sym->attr.dimension
5028 : 843 : && sym->ts.u.cl && sym->ts.u.cl->length
5029 : 171 : && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE)
5030 : 25 : gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
5031 : :
5032 : 4255 : if (!sym->attr.pointer)
5033 : : {
5034 : : /* Nullify and automatic deallocation of allocatable
5035 : : scalars. */
5036 : 4211 : e = gfc_lval_expr_from_sym (sym);
5037 : 4211 : if (sym->ts.type == BT_CLASS)
5038 : 2185 : gfc_add_data_component (e);
5039 : :
5040 : 4211 : gfc_init_se (&se, NULL);
5041 : 4211 : if (sym->ts.type != BT_CLASS
5042 : 2185 : || sym->ts.u.derived->attr.dimension
5043 : 2185 : || sym->ts.u.derived->attr.codimension)
5044 : : {
5045 : 2026 : se.want_pointer = 1;
5046 : 2026 : gfc_conv_expr (&se, e);
5047 : : }
5048 : 2185 : else if (sym->ts.type == BT_CLASS
5049 : 2185 : && !CLASS_DATA (sym)->attr.dimension
5050 : 2185 : && !CLASS_DATA (sym)->attr.codimension)
5051 : : {
5052 : 1182 : se.want_pointer = 1;
5053 : 1182 : gfc_conv_expr (&se, e);
5054 : : }
5055 : : else
5056 : : {
5057 : 1003 : se.descriptor_only = 1;
5058 : 1003 : gfc_conv_expr (&se, e);
5059 : 1003 : descriptor = se.expr;
5060 : 1003 : se.expr = gfc_conv_descriptor_data_addr (se.expr);
5061 : 1003 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
5062 : : }
5063 : 4211 : gfc_free_expr (e);
5064 : :
5065 : 4211 : if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
5066 : : {
5067 : : /* Nullify when entering the scope. */
5068 : 8422 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5069 : 4211 : TREE_TYPE (se.expr), se.expr,
5070 : 4211 : fold_convert (TREE_TYPE (se.expr),
5071 : : null_pointer_node));
5072 : 4211 : if (sym->attr.optional)
5073 : : {
5074 : 0 : tree present = gfc_conv_expr_present (sym);
5075 : 0 : tmp = build3_loc (input_location, COND_EXPR,
5076 : : void_type_node, present, tmp,
5077 : : build_empty_stmt (input_location));
5078 : : }
5079 : 4211 : gfc_add_expr_to_block (&init, tmp);
5080 : : }
5081 : : }
5082 : :
5083 : 4255 : if ((sym->attr.dummy || sym->attr.result)
5084 : 487 : && sym->ts.type == BT_CHARACTER
5085 : 106 : && sym->ts.deferred
5086 : 106 : && sym->ts.u.cl->passed_length)
5087 : 106 : tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
5088 : : else
5089 : : {
5090 : 4149 : gfc_restore_backend_locus (&loc);
5091 : 4149 : tmp = NULL_TREE;
5092 : : }
5093 : :
5094 : : /* Initialize descriptor's TKR information. */
5095 : 4255 : if (sym->ts.type == BT_CLASS)
5096 : 2185 : gfc_trans_class_array (sym, block);
5097 : :
5098 : : /* Deallocate when leaving the scope. Nullifying is not
5099 : : needed. */
5100 : 4255 : if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
5101 : 3768 : && !sym->ns->proc_name->attr.is_main_program)
5102 : : {
5103 : 1289 : if (sym->ts.type == BT_CLASS
5104 : 449 : && CLASS_DATA (sym)->attr.codimension)
5105 : 6 : tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
5106 : : NULL_TREE, NULL_TREE,
5107 : : NULL_TREE, true, NULL,
5108 : : GFC_CAF_COARRAY_ANALYZE);
5109 : : else
5110 : : {
5111 : 1283 : gfc_expr *expr = gfc_lval_expr_from_sym (sym);
5112 : 1283 : tmp = gfc_deallocate_scalar_with_status (se.expr,
5113 : : NULL_TREE,
5114 : : NULL_TREE,
5115 : : true, expr,
5116 : : sym->ts);
5117 : 1283 : gfc_free_expr (expr);
5118 : : }
5119 : : }
5120 : :
5121 : 4255 : if (sym->ts.type == BT_CLASS)
5122 : : {
5123 : : /* Initialize _vptr to declared type. */
5124 : 2185 : gfc_save_backend_locus (&loc);
5125 : 2185 : gfc_set_backend_locus (&sym->declared_at);
5126 : 2185 : e = gfc_lval_expr_from_sym (sym);
5127 : 2185 : gfc_reset_vptr (&init, e);
5128 : 2185 : gfc_free_expr (e);
5129 : 2185 : gfc_restore_backend_locus (&loc);
5130 : : }
5131 : :
5132 : 4255 : gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
5133 : : }
5134 : : }
5135 : 5054 : else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
5136 : : {
5137 : 168 : tree tmp = NULL;
5138 : 168 : stmtblock_t init;
5139 : :
5140 : : /* If we get to here, all that should be left are pointers. */
5141 : 168 : gcc_assert (sym->attr.pointer);
5142 : :
5143 : 168 : if (sym->attr.dummy)
5144 : : {
5145 : 0 : gfc_start_block (&init);
5146 : 0 : gfc_save_backend_locus (&loc);
5147 : 0 : gfc_set_backend_locus (&sym->declared_at);
5148 : 0 : tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
5149 : 0 : gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
5150 : : }
5151 : 168 : }
5152 : 4886 : else if (sym->ts.deferred)
5153 : 0 : gfc_fatal_error ("Deferred type parameter not yet supported");
5154 : 4886 : else if (alloc_comp_or_fini)
5155 : 3726 : gfc_trans_deferred_array (sym, block);
5156 : 1160 : else if (sym->ts.type == BT_CHARACTER)
5157 : : {
5158 : 692 : gfc_save_backend_locus (&loc);
5159 : 692 : gfc_set_backend_locus (&sym->declared_at);
5160 : 692 : if (sym->attr.dummy || sym->attr.result)
5161 : 339 : gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
5162 : : else
5163 : 353 : gfc_trans_auto_character_variable (sym, block);
5164 : 692 : gfc_restore_backend_locus (&loc);
5165 : : }
5166 : 468 : else if (sym->attr.assign)
5167 : : {
5168 : 64 : gfc_save_backend_locus (&loc);
5169 : 64 : gfc_set_backend_locus (&sym->declared_at);
5170 : 64 : gfc_trans_assign_aux_var (sym, block);
5171 : 64 : gfc_restore_backend_locus (&loc);
5172 : : }
5173 : 404 : else if (sym->ts.type == BT_DERIVED
5174 : 404 : && sym->value
5175 : : && !sym->attr.data
5176 : 349 : && sym->attr.save == SAVE_NONE)
5177 : : {
5178 : 343 : gfc_start_block (&tmpblock);
5179 : 343 : gfc_init_default_dt (sym, &tmpblock, false);
5180 : 343 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
5181 : : NULL_TREE);
5182 : : }
5183 : 61 : else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
5184 : 0 : gcc_unreachable ();
5185 : : }
5186 : :
5187 : : /* Handle 'omp allocate'. This has to be after the block above as
5188 : : gfc_add_init_cleanup (..., init, ...) puts 'init' of later calls
5189 : : before earlier calls. The code is a bit more complex as gfortran does
5190 : : not really work with bind expressions / BIND_EXPR_VARS properly, i.e.
5191 : : gimplify_bind_expr needs some help for placing the GOMP_alloc. Thus,
5192 : : we pass on the location of the allocate-assignment expression and,
5193 : : if the size is not constant, the size variable if Fortran computes this
5194 : : differently. We also might add an expression location after which the
5195 : : code has to be added, e.g. for character len expressions, which affect
5196 : : the UNIT_SIZE. */
5197 : 87625 : gfc_expr *last_allocator = NULL;
5198 : 87625 : if (omp_ns && omp_ns->omp_allocate)
5199 : : {
5200 : 25 : if (!block->init || TREE_CODE (block->init) != STATEMENT_LIST)
5201 : : {
5202 : 18 : tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
5203 : 18 : append_to_statement_list (tmp, &block->init);
5204 : : }
5205 : 25 : if (!block->cleanup || TREE_CODE (block->cleanup) != STATEMENT_LIST)
5206 : : {
5207 : 25 : tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
5208 : 25 : append_to_statement_list (tmp, &block->cleanup);
5209 : : }
5210 : : }
5211 : 87625 : tree init_stmtlist = block->init;
5212 : 87625 : tree cleanup_stmtlist = block->cleanup;
5213 : 87625 : se.expr = NULL_TREE;
5214 : 87625 : for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
5215 : 87661 : n; n = n->next)
5216 : 40 : if (!TREE_STATIC (n->sym->backend_decl))
5217 : : {
5218 : 36 : tree align = (n->u.align ? gfc_conv_constant_to_tree (n->u.align)
5219 : 36 : : NULL_TREE);
5220 : 36 : if (last_allocator != n->u2.allocator)
5221 : : {
5222 : 11 : location_t loc = input_location;
5223 : 11 : gfc_init_se (&se, NULL);
5224 : 11 : if (n->u2.allocator)
5225 : : {
5226 : 9 : input_location = gfc_get_location (&n->u2.allocator->where);
5227 : 9 : gfc_conv_expr (&se, n->u2.allocator);
5228 : : }
5229 : : /* We need to evalulate non-constants - also to find the location
5230 : : after which the GOMP_alloc has to be added to - also as BLOCK
5231 : : does not yield a new BIND_EXPR_BODY. */
5232 : 11 : if (n->u2.allocator
5233 : : && (!(CONSTANT_CLASS_P (se.expr) && DECL_P (se.expr))
5234 : : || se.pre.head || se.post.head))
5235 : : {
5236 : 9 : stmtblock_t tmpblock;
5237 : 9 : gfc_init_block (&tmpblock);
5238 : 9 : se.expr = gfc_evaluate_now (se.expr, &tmpblock);
5239 : : /* First post then pre because the new code is inserted
5240 : : at the top. */
5241 : 9 : gfc_add_init_cleanup (block, gfc_finish_block (&se.post), NULL);
5242 : 9 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
5243 : : NULL);
5244 : 9 : gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), NULL);
5245 : : }
5246 : 11 : last_allocator = n->u2.allocator;
5247 : 11 : input_location = loc;
5248 : : }
5249 : :
5250 : : /* 'omp allocate( {purpose: allocator, value: align},
5251 : : {purpose: init-stmtlist, value: cleanup-stmtlist},
5252 : : {purpose: size-var, value: last-size-expr}}
5253 : : where init-stmt/cleanup-stmt is the STATEMENT list to find the
5254 : : try-final block; last-size-expr is to find the location after
5255 : : which to add the code and 'size-var' is for the proper size, cf.
5256 : : gfc_trans_auto_array_allocation - either or both of the latter
5257 : : can be NULL. */
5258 : 36 : tree tmp = lookup_attribute ("omp allocate",
5259 : 36 : DECL_ATTRIBUTES (n->sym->backend_decl));
5260 : 36 : tmp = TREE_VALUE (tmp);
5261 : 36 : TREE_PURPOSE (tmp) = se.expr;
5262 : 36 : TREE_VALUE (tmp) = align;
5263 : 36 : TREE_PURPOSE (TREE_CHAIN (tmp)) = init_stmtlist;
5264 : 36 : TREE_VALUE (TREE_CHAIN (tmp)) = cleanup_stmtlist;
5265 : : }
5266 : 4 : else if (n->sym->attr.in_common)
5267 : : {
5268 : 1 : gfc_error ("Sorry, !$OMP allocate for COMMON block variable %qs at %L "
5269 : 1 : "not supported", n->sym->common_block->name,
5270 : 1 : &n->sym->common_block->where);
5271 : 1 : break;
5272 : : }
5273 : : else
5274 : : {
5275 : 3 : gfc_error ("Sorry, !$OMP allocate for variable %qs at %L with SAVE "
5276 : : "attribute not yet implemented", n->sym->name,
5277 : : &n->sym->declared_at);
5278 : : /* FIXME: Remember to handle last_allocator. */
5279 : 3 : break;
5280 : : }
5281 : :
5282 : 87625 : gfc_init_block (&tmpblock);
5283 : :
5284 : 173995 : for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
5285 : : {
5286 : 86370 : if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER
5287 : 7105 : && f->sym->ts.u.cl->backend_decl)
5288 : : {
5289 : 7104 : if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
5290 : 3922 : gfc_trans_vla_type_sizes (f->sym, &tmpblock);
5291 : : }
5292 : : }
5293 : :
5294 : 90287 : if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
5295 : 88979 : && current_fake_result_decl != NULL)
5296 : : {
5297 : 771 : gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
5298 : 771 : if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
5299 : 69 : gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
5300 : : }
5301 : :
5302 : 87625 : gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
5303 : 87625 : }
5304 : :
5305 : :
5306 : : struct module_hasher : ggc_ptr_hash<module_htab_entry>
5307 : : {
5308 : : typedef const char *compare_type;
5309 : :
5310 : 24557 : static hashval_t hash (module_htab_entry *s)
5311 : : {
5312 : 24557 : return htab_hash_string (s->name);
5313 : : }
5314 : :
5315 : : static bool
5316 : 29264 : equal (module_htab_entry *a, const char *b)
5317 : : {
5318 : 29264 : return !strcmp (a->name, b);
5319 : : }
5320 : : };
5321 : :
5322 : : static GTY (()) hash_table<module_hasher> *module_htab;
5323 : :
5324 : : /* Hash and equality functions for module_htab's decls. */
5325 : :
5326 : : hashval_t
5327 : 154281 : module_decl_hasher::hash (tree t)
5328 : : {
5329 : 154281 : const_tree n = DECL_NAME (t);
5330 : 154281 : if (n == NULL_TREE)
5331 : 22152 : n = TYPE_NAME (TREE_TYPE (t));
5332 : 154281 : return htab_hash_string (IDENTIFIER_POINTER (n));
5333 : : }
5334 : :
5335 : : bool
5336 : 160771 : module_decl_hasher::equal (tree t1, const char *x2)
5337 : : {
5338 : 160771 : const_tree n1 = DECL_NAME (t1);
5339 : 160771 : if (n1 == NULL_TREE)
5340 : 22364 : n1 = TYPE_NAME (TREE_TYPE (t1));
5341 : 160771 : return strcmp (IDENTIFIER_POINTER (n1), x2) == 0;
5342 : : }
5343 : :
5344 : : struct module_htab_entry *
5345 : 27629 : gfc_find_module (const char *name)
5346 : : {
5347 : 27629 : if (! module_htab)
5348 : 7510 : module_htab = hash_table<module_hasher>::create_ggc (10);
5349 : :
5350 : 27629 : module_htab_entry **slot
5351 : 27629 : = module_htab->find_slot_with_hash (name, htab_hash_string (name), INSERT);
5352 : 27629 : if (*slot == NULL)
5353 : : {
5354 : 9551 : module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> ();
5355 : :
5356 : 9551 : entry->name = gfc_get_string ("%s", name);
5357 : 9551 : entry->decls = hash_table<module_decl_hasher>::create_ggc (10);
5358 : 9551 : *slot = entry;
5359 : : }
5360 : 27629 : return *slot;
5361 : : }
5362 : :
5363 : : void
5364 : 47660 : gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
5365 : : {
5366 : 47660 : const char *name;
5367 : :
5368 : 47660 : if (DECL_NAME (decl))
5369 : 40627 : name = IDENTIFIER_POINTER (DECL_NAME (decl));
5370 : : else
5371 : : {
5372 : 7033 : gcc_assert (TREE_CODE (decl) == TYPE_DECL);
5373 : 7033 : name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
5374 : : }
5375 : 47660 : tree *slot
5376 : 47660 : = entry->decls->find_slot_with_hash (name, htab_hash_string (name),
5377 : : INSERT);
5378 : 47660 : if (*slot == NULL)
5379 : 47648 : *slot = decl;
5380 : 47660 : }
5381 : :
5382 : :
5383 : : /* Generate debugging symbols for namelists. This function must come after
5384 : : generate_local_decl to ensure that the variables in the namelist are
5385 : : already declared. */
5386 : :
5387 : : static tree
5388 : 716 : generate_namelist_decl (gfc_symbol * sym)
5389 : : {
5390 : 716 : gfc_namelist *nml;
5391 : 716 : tree decl;
5392 : 716 : vec<constructor_elt, va_gc> *nml_decls = NULL;
5393 : :
5394 : 716 : gcc_assert (sym->attr.flavor == FL_NAMELIST);
5395 : 2661 : for (nml = sym->namelist; nml; nml = nml->next)
5396 : : {
5397 : 1945 : if (nml->sym->backend_decl == NULL_TREE)
5398 : : {
5399 : 201 : nml->sym->attr.referenced = 1;
5400 : 201 : nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym);
5401 : : }
5402 : 1945 : DECL_IGNORED_P (nml->sym->backend_decl) = 0;
5403 : 1945 : CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl);
5404 : : }
5405 : :
5406 : 716 : decl = make_node (NAMELIST_DECL);
5407 : 716 : TREE_TYPE (decl) = void_type_node;
5408 : 716 : NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls);
5409 : 716 : DECL_NAME (decl) = get_identifier (sym->name);
5410 : 716 : return decl;
5411 : : }
5412 : :
5413 : :
5414 : : /* Output an initialized decl for a module variable. */
5415 : :
5416 : : static void
5417 : 126597 : gfc_create_module_variable (gfc_symbol * sym)
5418 : : {
5419 : 126597 : tree decl;
5420 : :
5421 : : /* Module functions with alternate entries are dealt with later and
5422 : : would get caught by the next condition. */
5423 : 126597 : if (sym->attr.entry)
5424 : : return;
5425 : :
5426 : : /* Make sure we convert the types of the derived types from iso_c_binding
5427 : : into (void *). */
5428 : 126118 : if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
5429 : 28796 : && sym->ts.type == BT_DERIVED)
5430 : 1328 : sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
5431 : :
5432 : 126118 : if (gfc_fl_struct (sym->attr.flavor)
5433 : 20021 : && sym->backend_decl
5434 : 7067 : && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
5435 : : {
5436 : 7033 : decl = sym->backend_decl;
5437 : 7033 : gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5438 : :
5439 : 7033 : if (!sym->attr.use_assoc && !sym->attr.used_in_submodule)
5440 : : {
5441 : 6949 : gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
5442 : : || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
5443 : 6949 : gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
5444 : : || DECL_CONTEXT (TYPE_STUB_DECL (decl))
5445 : : == sym->ns->proc_name->backend_decl);
5446 : : }
5447 : 7033 : TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5448 : 7033 : DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
5449 : 7033 : gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
5450 : : }
5451 : :
5452 : : /* Only output variables, procedure pointers and array valued,
5453 : : or derived type, parameters. */
5454 : 126118 : if (sym->attr.flavor != FL_VARIABLE
5455 : 106192 : && !(sym->attr.flavor == FL_PARAMETER
5456 : 35098 : && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
5457 : 105177 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
5458 : : return;
5459 : :
5460 : 21014 : if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
5461 : : {
5462 : 452 : decl = sym->backend_decl;
5463 : 452 : gcc_assert (DECL_FILE_SCOPE_P (decl));
5464 : 452 : gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5465 : 452 : DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5466 : 452 : gfc_module_add_decl (cur_module, decl);
5467 : : }
5468 : :
5469 : : /* Don't generate variables from other modules. Variables from
5470 : : COMMONs and Cray pointees will already have been generated. */
5471 : 21014 : if (sym->attr.use_assoc || sym->attr.used_in_submodule
5472 : 21014 : || sym->attr.in_common || sym->attr.cray_pointee)
5473 : : return;
5474 : :
5475 : : /* Equivalenced variables arrive here after creation. */
5476 : 17333 : if (sym->backend_decl
5477 : 498 : && (sym->equiv_built || sym->attr.in_equivalence))
5478 : : return;
5479 : :
5480 : 17246 : if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
5481 : 0 : gfc_internal_error ("backend decl for module variable %qs already exists",
5482 : : sym->name);
5483 : :
5484 : 17246 : if (sym->module && !sym->attr.result && !sym->attr.dummy
5485 : 17246 : && (sym->attr.access == ACCESS_UNKNOWN
5486 : 3382 : && (sym->ns->default_access == ACCESS_PRIVATE
5487 : 3195 : || (sym->ns->default_access == ACCESS_UNKNOWN
5488 : 3181 : && flag_module_private))))
5489 : 188 : sym->attr.access = ACCESS_PRIVATE;
5490 : :
5491 : 17246 : if (warn_unused_variable && !sym->attr.referenced
5492 : 234 : && sym->attr.access == ACCESS_PRIVATE)
5493 : 3 : gfc_warning (OPT_Wunused_value,
5494 : : "Unused PRIVATE module variable %qs declared at %L",
5495 : : sym->name, &sym->declared_at);
5496 : :
5497 : : /* We always want module variables to be created. */
5498 : 17246 : sym->attr.referenced = 1;
5499 : : /* Create the decl. */
5500 : 17246 : decl = gfc_get_symbol_decl (sym);
5501 : :
5502 : : /* Create the variable. */
5503 : 17246 : pushdecl (decl);
5504 : 17246 : gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE
5505 : : || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE
5506 : : && sym->fn_result_spec));
5507 : 17246 : DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5508 : 17246 : rest_of_decl_compilation (decl, 1, 0);
5509 : 17246 : gfc_module_add_decl (cur_module, decl);
5510 : :
5511 : : /* Also add length of strings. */
5512 : 17246 : if (sym->ts.type == BT_CHARACTER)
5513 : : {
5514 : 375 : tree length;
5515 : :
5516 : 375 : length = sym->ts.u.cl->backend_decl;
5517 : 375 : gcc_assert (length || sym->attr.proc_pointer);
5518 : 374 : if (length && !INTEGER_CST_P (length))
5519 : : {
5520 : 47 : pushdecl (length);
5521 : 47 : rest_of_decl_compilation (length, 1, 0);
5522 : : }
5523 : : }
5524 : :
5525 : 17246 : if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
5526 : 21 : && sym->attr.referenced && !sym->attr.use_assoc)
5527 : 21 : has_coarray_vars = true;
5528 : : }
5529 : :
5530 : : /* Emit debug information for USE statements. */
5531 : :
5532 : : static void
5533 : 83143 : gfc_trans_use_stmts (gfc_namespace * ns)
5534 : : {
5535 : 83143 : gfc_use_list *use_stmt;
5536 : 93956 : for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
5537 : : {
5538 : 10813 : struct module_htab_entry *entry
5539 : 10813 : = gfc_find_module (use_stmt->module_name);
5540 : 10813 : gfc_use_rename *rent;
5541 : :
5542 : 10813 : if (entry->namespace_decl == NULL)
5543 : : {
5544 : 1143 : entry->namespace_decl
5545 : 1143 : = build_decl (input_location,
5546 : : NAMESPACE_DECL,
5547 : : get_identifier (use_stmt->module_name),
5548 : : void_type_node);
5549 : 1143 : DECL_EXTERNAL (entry->namespace_decl) = 1;
5550 : : }
5551 : 10813 : gfc_set_backend_locus (&use_stmt->where);
5552 : 10813 : if (!use_stmt->only_flag)
5553 : 9388 : (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
5554 : : NULL_TREE,
5555 : 9388 : ns->proc_name->backend_decl,
5556 : : false, false);
5557 : 13288 : for (rent = use_stmt->rename; rent; rent = rent->next)
5558 : : {
5559 : 2475 : tree decl, local_name;
5560 : :
5561 : 2475 : if (rent->op != INTRINSIC_NONE)
5562 : 98 : continue;
5563 : :
5564 : 2377 : hashval_t hash = htab_hash_string (rent->use_name);
5565 : 2377 : tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash,
5566 : : INSERT);
5567 : 2377 : if (*slot == NULL)
5568 : : {
5569 : 1296 : gfc_symtree *st;
5570 : :
5571 : 1296 : st = gfc_find_symtree (ns->sym_root,
5572 : 1296 : rent->local_name[0]
5573 : : ? rent->local_name : rent->use_name);
5574 : :
5575 : : /* The following can happen if a derived type is renamed. */
5576 : 1296 : if (!st)
5577 : : {
5578 : 0 : char *name;
5579 : 0 : name = xstrdup (rent->local_name[0]
5580 : : ? rent->local_name : rent->use_name);
5581 : 0 : name[0] = (char) TOUPPER ((unsigned char) name[0]);
5582 : 0 : st = gfc_find_symtree (ns->sym_root, name);
5583 : 0 : free (name);
5584 : 0 : gcc_assert (st);
5585 : : }
5586 : :
5587 : : /* Sometimes, generic interfaces wind up being over-ruled by a
5588 : : local symbol (see PR41062). */
5589 : 1296 : if (!st->n.sym->attr.use_assoc)
5590 : : {
5591 : 2 : *slot = error_mark_node;
5592 : 2 : entry->decls->clear_slot (slot);
5593 : 2 : continue;
5594 : : }
5595 : :
5596 : 1294 : if (st->n.sym->backend_decl
5597 : 151 : && DECL_P (st->n.sym->backend_decl)
5598 : 151 : && st->n.sym->module
5599 : 151 : && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
5600 : : {
5601 : 143 : gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
5602 : : || !VAR_P (st->n.sym->backend_decl));
5603 : 143 : decl = copy_node (st->n.sym->backend_decl);
5604 : 143 : DECL_CONTEXT (decl) = entry->namespace_decl;
5605 : 143 : DECL_EXTERNAL (decl) = 1;
5606 : 143 : DECL_IGNORED_P (decl) = 0;
5607 : 143 : DECL_INITIAL (decl) = NULL_TREE;
5608 : : }
5609 : 1151 : else if (st->n.sym->attr.flavor == FL_NAMELIST
5610 : 0 : && st->n.sym->attr.use_only
5611 : 0 : && st->n.sym->module
5612 : 0 : && strcmp (st->n.sym->module, use_stmt->module_name)
5613 : : == 0)
5614 : : {
5615 : 0 : decl = generate_namelist_decl (st->n.sym);
5616 : 0 : DECL_CONTEXT (decl) = entry->namespace_decl;
5617 : 0 : DECL_EXTERNAL (decl) = 1;
5618 : 0 : DECL_IGNORED_P (decl) = 0;
5619 : 0 : DECL_INITIAL (decl) = NULL_TREE;
5620 : : }
5621 : : else
5622 : : {
5623 : 1151 : *slot = error_mark_node;
5624 : 1151 : entry->decls->clear_slot (slot);
5625 : 1151 : continue;
5626 : : }
5627 : 143 : *slot = decl;
5628 : : }
5629 : 1224 : decl = (tree) *slot;
5630 : 1224 : if (rent->local_name[0])
5631 : 206 : local_name = get_identifier (rent->local_name);
5632 : : else
5633 : : local_name = NULL_TREE;
5634 : 1224 : gfc_set_backend_locus (&rent->where);
5635 : 1224 : (*debug_hooks->imported_module_or_decl) (decl, local_name,
5636 : 1224 : ns->proc_name->backend_decl,
5637 : 1224 : !use_stmt->only_flag,
5638 : : false);
5639 : : }
5640 : : }
5641 : 83143 : }
5642 : :
5643 : :
5644 : : /* Return true if expr is a constant initializer that gfc_conv_initializer
5645 : : will handle. */
5646 : :
5647 : : static bool
5648 : 19890 : check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
5649 : : bool pointer)
5650 : : {
5651 : 19890 : gfc_constructor *c;
5652 : 19890 : gfc_component *cm;
5653 : :
5654 : 19890 : if (pointer)
5655 : : return true;
5656 : 19881 : else if (array)
5657 : : {
5658 : 1946 : if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
5659 : : return true;
5660 : 1918 : else if (expr->expr_type == EXPR_STRUCTURE)
5661 : 12 : return check_constant_initializer (expr, ts, false, false);
5662 : 1906 : else if (expr->expr_type != EXPR_ARRAY)
5663 : : return false;
5664 : 1906 : for (c = gfc_constructor_first (expr->value.constructor);
5665 : 121275 : c; c = gfc_constructor_next (c))
5666 : : {
5667 : 119369 : if (c->iterator)
5668 : : return false;
5669 : 119369 : if (c->expr->expr_type == EXPR_STRUCTURE)
5670 : : {
5671 : 264 : if (!check_constant_initializer (c->expr, ts, false, false))
5672 : : return false;
5673 : : }
5674 : 119105 : else if (c->expr->expr_type != EXPR_CONSTANT)
5675 : : return false;
5676 : : }
5677 : : return true;
5678 : : }
5679 : 17935 : else switch (ts->type)
5680 : : {
5681 : 507 : case_bt_struct:
5682 : 507 : if (expr->expr_type != EXPR_STRUCTURE)
5683 : : return false;
5684 : 507 : cm = expr->ts.u.derived->components;
5685 : 507 : for (c = gfc_constructor_first (expr->value.constructor);
5686 : 1500 : c; c = gfc_constructor_next (c), cm = cm->next)
5687 : : {
5688 : 1097 : if (!c->expr || cm->attr.allocatable)
5689 : 397 : continue;
5690 : 700 : if (!check_constant_initializer (c->expr, &cm->ts,
5691 : : cm->attr.dimension,
5692 : : cm->attr.pointer))
5693 : : return false;
5694 : : }
5695 : : return true;
5696 : 17428 : default:
5697 : 17428 : return expr->expr_type == EXPR_CONSTANT;
5698 : : }
5699 : : }
5700 : :
5701 : : /* Emit debug info for parameters and unreferenced variables with
5702 : : initializers. */
5703 : :
5704 : : static void
5705 : 1023671 : gfc_emit_parameter_debug_info (gfc_symbol *sym)
5706 : : {
5707 : 1023671 : tree decl;
5708 : :
5709 : 1023671 : if (sym->attr.flavor != FL_PARAMETER
5710 : 827143 : && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
5711 : : return;
5712 : :
5713 : 232994 : if (sym->backend_decl != NULL
5714 : 217727 : || sym->value == NULL
5715 : : || sym->attr.use_assoc
5716 : : || sym->attr.dummy
5717 : : || sym->attr.result
5718 : : || sym->attr.function
5719 : : || sym->attr.intrinsic
5720 : : || sym->attr.pointer
5721 : 201822 : || sym->attr.allocatable
5722 : 18965 : || sym->attr.cray_pointee
5723 : : || sym->attr.threadprivate
5724 : : || sym->attr.is_bind_c
5725 : : || sym->attr.subref_array_pointer
5726 : 18965 : || sym->attr.assign)
5727 : : return;
5728 : :
5729 : 18964 : if (sym->ts.type == BT_CHARACTER)
5730 : : {
5731 : 1353 : gfc_conv_const_charlen (sym->ts.u.cl);
5732 : 1353 : if (sym->ts.u.cl->backend_decl == NULL
5733 : 1353 : || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
5734 : : return;
5735 : : }
5736 : 17611 : else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
5737 : : return;
5738 : :
5739 : 18914 : if (sym->as)
5740 : : {
5741 : 1861 : int n;
5742 : :
5743 : 1861 : if (sym->as->type != AS_EXPLICIT)
5744 : : return;
5745 : 4248 : for (n = 0; n < sym->as->rank; n++)
5746 : 2387 : if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
5747 : 2387 : || sym->as->upper[n] == NULL
5748 : 2387 : || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
5749 : : return;
5750 : : }
5751 : :
5752 : 18914 : if (!check_constant_initializer (sym->value, &sym->ts,
5753 : 18914 : sym->attr.dimension, false))
5754 : : return;
5755 : :
5756 : 18784 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
5757 : : return;
5758 : :
5759 : : /* Create the decl for the variable or constant. */
5760 : 37568 : decl = build_decl (input_location,
5761 : 18784 : sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
5762 : : gfc_sym_identifier (sym), gfc_sym_type (sym));
5763 : 18784 : if (sym->attr.flavor == FL_PARAMETER)
5764 : 18558 : TREE_READONLY (decl) = 1;
5765 : 18784 : gfc_set_decl_location (decl, &sym->declared_at);
5766 : 18784 : if (sym->attr.dimension)
5767 : 1861 : GFC_DECL_PACKED_ARRAY (decl) = 1;
5768 : 18784 : DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5769 : 18784 : TREE_STATIC (decl) = 1;
5770 : 18784 : TREE_USED (decl) = 1;
5771 : 18784 : if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
5772 : 2281 : TREE_PUBLIC (decl) = 1;
5773 : 18784 : DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
5774 : 18784 : TREE_TYPE (decl),
5775 : 18784 : sym->attr.dimension,
5776 : : false, false);
5777 : 18784 : debug_hooks->early_global_decl (decl);
5778 : : }
5779 : :
5780 : :
5781 : : static void
5782 : 2505 : generate_coarray_sym_init (gfc_symbol *sym)
5783 : : {
5784 : 2505 : tree tmp, size, decl, token, desc;
5785 : 2505 : bool is_lock_type, is_event_type;
5786 : 2505 : int reg_type;
5787 : 2505 : gfc_se se;
5788 : 2505 : symbol_attribute attr;
5789 : :
5790 : 2505 : if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
5791 : 2505 : || sym->attr.use_assoc || !sym->attr.referenced
5792 : : || sym->attr.associate_var
5793 : 265 : || sym->attr.select_type_temporary)
5794 : 2281 : return;
5795 : :
5796 : 224 : decl = sym->backend_decl;
5797 : 224 : TREE_USED(decl) = 1;
5798 : 224 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
5799 : :
5800 : 448 : is_lock_type = sym->ts.type == BT_DERIVED
5801 : 113 : && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5802 : 224 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
5803 : :
5804 : 448 : is_event_type = sym->ts.type == BT_DERIVED
5805 : 113 : && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5806 : 224 : && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
5807 : :
5808 : : /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
5809 : : to make sure the variable is not optimized away. */
5810 : 224 : DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
5811 : :
5812 : : /* For lock types, we pass the array size as only the library knows the
5813 : : size of the variable. */
5814 : 224 : if (is_lock_type || is_event_type)
5815 : 13 : size = gfc_index_one_node;
5816 : : else
5817 : 211 : size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
5818 : :
5819 : : /* Ensure that we do not have size=0 for zero-sized arrays. */
5820 : 224 : size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
5821 : : fold_convert (size_type_node, size),
5822 : 224 : build_int_cst (size_type_node, 1));
5823 : :
5824 : 224 : if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
5825 : : {
5826 : 66 : tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
5827 : 66 : size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5828 : : fold_convert (size_type_node, tmp), size);
5829 : : }
5830 : :
5831 : 224 : gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
5832 : 672 : token = gfc_build_addr_expr (ppvoid_type_node,
5833 : 224 : GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
5834 : 224 : if (is_lock_type)
5835 : 9 : reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
5836 : 215 : else if (is_event_type)
5837 : : reg_type = GFC_CAF_EVENT_STATIC;
5838 : : else
5839 : 211 : reg_type = GFC_CAF_COARRAY_STATIC;
5840 : :
5841 : : /* Compile the symbol attribute. */
5842 : 224 : if (sym->ts.type == BT_CLASS)
5843 : : {
5844 : 0 : attr = CLASS_DATA (sym)->attr;
5845 : : /* The pointer attribute is always set on classes, overwrite it with the
5846 : : class_pointer attribute, which denotes the pointer for classes. */
5847 : 0 : attr.pointer = attr.class_pointer;
5848 : : }
5849 : : else
5850 : 224 : attr = sym->attr;
5851 : 224 : gfc_init_se (&se, NULL);
5852 : 224 : desc = gfc_conv_scalar_to_descriptor (&se, decl, attr);
5853 : 224 : gfc_add_block_to_block (&caf_init_block, &se.pre);
5854 : :
5855 : 224 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size,
5856 : : build_int_cst (integer_type_node, reg_type),
5857 : : token, gfc_build_addr_expr (pvoid_type_node, desc),
5858 : : null_pointer_node, /* stat. */
5859 : : null_pointer_node, /* errgmsg. */
5860 : : build_zero_cst (size_type_node)); /* errmsg_len. */
5861 : 224 : gfc_add_expr_to_block (&caf_init_block, tmp);
5862 : 224 : gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl),
5863 : : gfc_conv_descriptor_data_get (desc)));
5864 : :
5865 : : /* Handle "static" initializer. */
5866 : 224 : if (sym->value)
5867 : : {
5868 : 84 : if (sym->value->expr_type == EXPR_ARRAY)
5869 : : {
5870 : 7 : gfc_constructor *c, *cnext;
5871 : :
5872 : : /* Test if the array has more than one element. */
5873 : 7 : c = gfc_constructor_first (sym->value->value.constructor);
5874 : 7 : gcc_assert (c); /* Empty constructor should not happen here. */
5875 : 7 : cnext = gfc_constructor_next (c);
5876 : :
5877 : 7 : if (cnext)
5878 : : {
5879 : : /* An EXPR_ARRAY with a rank > 1 here has to come from a
5880 : : DATA statement. Set its rank here as not to confuse
5881 : : the following steps. */
5882 : 6 : sym->value->rank = 1;
5883 : : }
5884 : : else
5885 : : {
5886 : : /* There is only a single value in the constructor, use
5887 : : it directly for the assignment. */
5888 : 1 : gfc_expr *new_expr;
5889 : 1 : new_expr = gfc_copy_expr (c->expr);
5890 : 1 : gfc_free_expr (sym->value);
5891 : 1 : sym->value = new_expr;
5892 : : }
5893 : : }
5894 : :
5895 : 84 : sym->attr.pointer = 1;
5896 : 84 : tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
5897 : : true, false);
5898 : 84 : sym->attr.pointer = 0;
5899 : 84 : gfc_add_expr_to_block (&caf_init_block, tmp);
5900 : : }
5901 : 140 : else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp)
5902 : : {
5903 : 27 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as
5904 : : ? sym->as->rank : 0,
5905 : : GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
5906 : 27 : gfc_add_expr_to_block (&caf_init_block, tmp);
5907 : : }
5908 : : }
5909 : :
5910 : :
5911 : : /* Generate constructor function to initialize static, nonallocatable
5912 : : coarrays. */
5913 : :
5914 : : static void
5915 : 174 : generate_coarray_init (gfc_namespace * ns __attribute((unused)))
5916 : : {
5917 : 174 : tree fndecl, tmp, decl, save_fn_decl;
5918 : :
5919 : 174 : save_fn_decl = current_function_decl;
5920 : 174 : push_function_context ();
5921 : :
5922 : 174 : tmp = build_function_type_list (void_type_node, NULL_TREE);
5923 : 174 : fndecl = build_decl (input_location, FUNCTION_DECL,
5924 : : create_tmp_var_name ("_caf_init"), tmp);
5925 : :
5926 : 174 : DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
5927 : 174 : SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
5928 : :
5929 : 174 : decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
5930 : 174 : DECL_ARTIFICIAL (decl) = 1;
5931 : 174 : DECL_IGNORED_P (decl) = 1;
5932 : 174 : DECL_CONTEXT (decl) = fndecl;
5933 : 174 : DECL_RESULT (fndecl) = decl;
5934 : :
5935 : 174 : pushdecl (fndecl);
5936 : 174 : current_function_decl = fndecl;
5937 : 174 : announce_function (fndecl);
5938 : :
5939 : 174 : rest_of_decl_compilation (fndecl, 0, 0);
5940 : 174 : make_decl_rtl (fndecl);
5941 : 174 : allocate_struct_function (fndecl, false);
5942 : :
5943 : 174 : pushlevel ();
5944 : 174 : gfc_init_block (&caf_init_block);
5945 : :
5946 : 174 : gfc_traverse_ns (ns, generate_coarray_sym_init);
5947 : :
5948 : 174 : DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
5949 : 174 : decl = getdecls ();
5950 : :
5951 : 174 : poplevel (1, 1);
5952 : 174 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5953 : :
5954 : 348 : DECL_SAVED_TREE (fndecl)
5955 : 348 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node,
5956 : 348 : decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl));
5957 : 174 : dump_function (TDI_original, fndecl);
5958 : :
5959 : 174 : cfun->function_end_locus = input_location;
5960 : 174 : set_cfun (NULL);
5961 : :
5962 : 174 : if (decl_function_context (fndecl))
5963 : 167 : (void) cgraph_node::create (fndecl);
5964 : : else
5965 : 7 : cgraph_node::finalize_function (fndecl, true);
5966 : :
5967 : 174 : pop_function_context ();
5968 : 174 : current_function_decl = save_fn_decl;
5969 : 174 : }
5970 : :
5971 : :
5972 : : static void
5973 : 126597 : create_module_nml_decl (gfc_symbol *sym)
5974 : : {
5975 : 126597 : if (sym->attr.flavor == FL_NAMELIST)
5976 : : {
5977 : 43 : tree decl = generate_namelist_decl (sym);
5978 : 43 : pushdecl (decl);
5979 : 43 : gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5980 : 43 : DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5981 : 43 : rest_of_decl_compilation (decl, 1, 0);
5982 : 43 : gfc_module_add_decl (cur_module, decl);
5983 : : }
5984 : 126597 : }
5985 : :
5986 : :
5987 : : /* Generate all the required code for module variables. */
5988 : :
5989 : : void
5990 : 8408 : gfc_generate_module_vars (gfc_namespace * ns)
5991 : : {
5992 : 8408 : module_namespace = ns;
5993 : 8408 : cur_module = gfc_find_module (ns->proc_name->name);
5994 : :
5995 : : /* Check if the frontend left the namespace in a reasonable state. */
5996 : 8408 : gcc_assert (ns->proc_name && !ns->proc_name->tlink);
5997 : :
5998 : : /* Generate COMMON blocks. */
5999 : 8408 : gfc_trans_common (ns);
6000 : :
6001 : 8408 : has_coarray_vars = false;
6002 : :
6003 : : /* Create decls for all the module variables. */
6004 : 8408 : gfc_traverse_ns (ns, gfc_create_module_variable);
6005 : 8408 : gfc_traverse_ns (ns, create_module_nml_decl);
6006 : :
6007 : 8408 : if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6008 : 7 : generate_coarray_init (ns);
6009 : :
6010 : 8408 : cur_module = NULL;
6011 : :
6012 : 8408 : gfc_trans_use_stmts (ns);
6013 : 8408 : gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
6014 : 8408 : }
6015 : :
6016 : :
6017 : : static void
6018 : 74735 : gfc_generate_contained_functions (gfc_namespace * parent)
6019 : : {
6020 : 74735 : gfc_namespace *ns;
6021 : :
6022 : : /* We create all the prototypes before generating any code. */
6023 : 92153 : for (ns = parent->contained; ns; ns = ns->sibling)
6024 : : {
6025 : : /* Skip namespaces from used modules. */
6026 : 17418 : if (ns->parent != parent)
6027 : 0 : continue;
6028 : :
6029 : 17418 : gfc_create_function_decl (ns, false);
6030 : : }
6031 : :
6032 : 92153 : for (ns = parent->contained; ns; ns = ns->sibling)
6033 : : {
6034 : : /* Skip namespaces from used modules. */
6035 : 17418 : if (ns->parent != parent)
6036 : 0 : continue;
6037 : :
6038 : 17418 : gfc_generate_function_code (ns);
6039 : : }
6040 : 74735 : }
6041 : :
6042 : :
6043 : : /* Drill down through expressions for the array specification bounds and
6044 : : character length calling generate_local_decl for all those variables
6045 : : that have not already been declared. */
6046 : :
6047 : : static void
6048 : : generate_local_decl (gfc_symbol *);
6049 : :
6050 : : /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
6051 : :
6052 : : static bool
6053 : 97740 : expr_decls (gfc_expr *e, gfc_symbol *sym,
6054 : : int *f ATTRIBUTE_UNUSED)
6055 : : {
6056 : 97740 : if (e->expr_type != EXPR_VARIABLE
6057 : 6946 : || sym == e->symtree->n.sym
6058 : 6933 : || e->symtree->n.sym->mark
6059 : 724 : || e->symtree->n.sym->ns != sym->ns)
6060 : : return false;
6061 : :
6062 : 724 : generate_local_decl (e->symtree->n.sym);
6063 : 724 : return false;
6064 : : }
6065 : :
6066 : : static void
6067 : 124642 : generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
6068 : : {
6069 : 0 : gfc_traverse_expr (e, sym, expr_decls, 0);
6070 : 1052 : }
6071 : :
6072 : :
6073 : : /* Check for dependencies in the character length and array spec. */
6074 : :
6075 : : static void
6076 : 172055 : generate_dependency_declarations (gfc_symbol *sym)
6077 : : {
6078 : 172055 : int i;
6079 : :
6080 : 172055 : if (sym->ts.type == BT_CHARACTER
6081 : 16558 : && sym->ts.u.cl
6082 : 16558 : && sym->ts.u.cl->length
6083 : 13838 : && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6084 : 1052 : generate_expr_decls (sym, sym->ts.u.cl->length);
6085 : :
6086 : 172055 : if (sym->as && sym->as->rank)
6087 : : {
6088 : 106471 : for (i = 0; i < sym->as->rank; i++)
6089 : : {
6090 : 61795 : generate_expr_decls (sym, sym->as->lower[i]);
6091 : 61795 : generate_expr_decls (sym, sym->as->upper[i]);
6092 : : }
6093 : : }
6094 : 172055 : }
6095 : :
6096 : :
6097 : : /* Generate decls for all local variables. We do this to ensure correct
6098 : : handling of expressions which only appear in the specification of
6099 : : other functions. */
6100 : :
6101 : : static void
6102 : 923571 : generate_local_decl (gfc_symbol * sym)
6103 : : {
6104 : 923571 : if (sym->attr.flavor == FL_VARIABLE)
6105 : : {
6106 : 258149 : if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
6107 : 406 : && sym->attr.referenced && !sym->attr.use_assoc)
6108 : 362 : has_coarray_vars = true;
6109 : :
6110 : 258149 : if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
6111 : 172055 : generate_dependency_declarations (sym);
6112 : :
6113 : 258149 : if (sym->attr.ext_attr & (1 << EXT_ATTR_WEAK))
6114 : : {
6115 : 2 : if (sym->attr.dummy)
6116 : 1 : gfc_error ("Symbol %qs at %L has the WEAK attribute but is a "
6117 : : "dummy argument", sym->name, &sym->declared_at);
6118 : : else
6119 : 1 : gfc_error ("Symbol %qs at %L has the WEAK attribute but is a "
6120 : : "local variable", sym->name, &sym->declared_at);
6121 : : }
6122 : :
6123 : 258149 : if (sym->attr.referenced)
6124 : 225620 : gfc_get_symbol_decl (sym);
6125 : :
6126 : : /* Warnings for unused dummy arguments. */
6127 : 32529 : else if (sym->attr.dummy && !sym->attr.in_namelist)
6128 : : {
6129 : : /* INTENT(out) dummy arguments are likely meant to be set. */
6130 : 7052 : if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT)
6131 : : {
6132 : 9 : if (sym->ts.type != BT_DERIVED)
6133 : 6 : gfc_warning (OPT_Wunused_dummy_argument,
6134 : : "Dummy argument %qs at %L was declared "
6135 : : "INTENT(OUT) but was not set", sym->name,
6136 : : &sym->declared_at);
6137 : 3 : else if (!gfc_has_default_initializer (sym->ts.u.derived)
6138 : 3 : && !sym->ts.u.derived->attr.zero_comp)
6139 : 1 : gfc_warning (OPT_Wunused_dummy_argument,
6140 : : "Derived-type dummy argument %qs at %L was "
6141 : : "declared INTENT(OUT) but was not set and "
6142 : : "does not have a default initializer",
6143 : : sym->name, &sym->declared_at);
6144 : 9 : if (sym->backend_decl != NULL_TREE)
6145 : 9 : suppress_warning (sym->backend_decl);
6146 : : }
6147 : 7043 : else if (warn_unused_dummy_argument)
6148 : : {
6149 : 6 : if (!sym->attr.artificial)
6150 : 4 : gfc_warning (OPT_Wunused_dummy_argument,
6151 : : "Unused dummy argument %qs at %L", sym->name,
6152 : : &sym->declared_at);
6153 : :
6154 : 6 : if (sym->backend_decl != NULL_TREE)
6155 : 4 : suppress_warning (sym->backend_decl);
6156 : : }
6157 : : }
6158 : :
6159 : : /* Warn for unused variables, but not if they're inside a common
6160 : : block or a namelist. */
6161 : 25477 : else if (warn_unused_variable
6162 : 40 : && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
6163 : : {
6164 : 38 : if (sym->attr.use_only)
6165 : : {
6166 : 1 : gfc_warning (OPT_Wunused_variable,
6167 : : "Unused module variable %qs which has been "
6168 : : "explicitly imported at %L", sym->name,
6169 : : &sym->declared_at);
6170 : 1 : if (sym->backend_decl != NULL_TREE)
6171 : 0 : suppress_warning (sym->backend_decl);
6172 : : }
6173 : 37 : else if (!sym->attr.use_assoc)
6174 : : {
6175 : : /* Corner case: the symbol may be an entry point. At this point,
6176 : : it may appear to be an unused variable. Suppress warning. */
6177 : 7 : bool enter = false;
6178 : 7 : gfc_entry_list *el;
6179 : :
6180 : 13 : for (el = sym->ns->entries; el; el=el->next)
6181 : 6 : if (strcmp(sym->name, el->sym->name) == 0)
6182 : 2 : enter = true;
6183 : :
6184 : 7 : if (!enter)
6185 : 5 : gfc_warning (OPT_Wunused_variable,
6186 : : "Unused variable %qs declared at %L",
6187 : : sym->name, &sym->declared_at);
6188 : 7 : if (sym->backend_decl != NULL_TREE)
6189 : 0 : suppress_warning (sym->backend_decl);
6190 : : }
6191 : : }
6192 : :
6193 : : /* For variable length CHARACTER parameters, the PARM_DECL already
6194 : : references the length variable, so force gfc_get_symbol_decl
6195 : : even when not referenced. If optimize > 0, it will be optimized
6196 : : away anyway. But do this only after emitting -Wunused-parameter
6197 : : warning if requested. */
6198 : 258149 : if (sym->attr.dummy && !sym->attr.referenced
6199 : 7055 : && sym->ts.type == BT_CHARACTER
6200 : 756 : && sym->ts.u.cl->backend_decl != NULL
6201 : 752 : && VAR_P (sym->ts.u.cl->backend_decl))
6202 : : {
6203 : 6 : sym->attr.referenced = 1;
6204 : 6 : gfc_get_symbol_decl (sym);
6205 : : }
6206 : :
6207 : : /* INTENT(out) dummy arguments and result variables with allocatable
6208 : : components are reset by default and need to be set referenced to
6209 : : generate the code for nullification and automatic lengths. */
6210 : 258149 : if (!sym->attr.referenced
6211 : 32523 : && sym->ts.type == BT_DERIVED
6212 : 18336 : && sym->ts.u.derived->attr.alloc_comp
6213 : 1277 : && !sym->attr.pointer
6214 : 1277 : && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
6215 : 1241 : ||
6216 : 1241 : (sym->attr.result && sym != sym->result)))
6217 : : {
6218 : 36 : sym->attr.referenced = 1;
6219 : 36 : gfc_get_symbol_decl (sym);
6220 : : }
6221 : :
6222 : : /* Check for dependencies in the array specification and string
6223 : : length, adding the necessary declarations to the function. We
6224 : : mark the symbol now, as well as in traverse_ns, to prevent
6225 : : getting stuck in a circular dependency. */
6226 : 258149 : sym->mark = 1;
6227 : : }
6228 : 665422 : else if (sym->attr.flavor == FL_PARAMETER)
6229 : : {
6230 : 161508 : if (warn_unused_parameter
6231 : 386 : && !sym->attr.referenced)
6232 : : {
6233 : 329 : if (!sym->attr.use_assoc)
6234 : 4 : gfc_warning (OPT_Wunused_parameter,
6235 : : "Unused parameter %qs declared at %L", sym->name,
6236 : : &sym->declared_at);
6237 : 325 : else if (sym->attr.use_only)
6238 : 1 : gfc_warning (OPT_Wunused_parameter,
6239 : : "Unused parameter %qs which has been explicitly "
6240 : : "imported at %L", sym->name, &sym->declared_at);
6241 : : }
6242 : :
6243 : 161508 : if (sym->ns && sym->ns->construct_entities)
6244 : : {
6245 : : /* Construction of the intrinsic modules within a BLOCK
6246 : : construct, where ONLY and RENAMED entities are included,
6247 : : seems to be bogus. This is a workaround that can be removed
6248 : : if someone ever takes on the task to creating full-fledge
6249 : : modules. See PR 69455. */
6250 : 76 : if (sym->attr.referenced
6251 : 76 : && sym->from_intmod != INTMOD_ISO_C_BINDING
6252 : 52 : && sym->from_intmod != INTMOD_ISO_FORTRAN_ENV)
6253 : 24 : gfc_get_symbol_decl (sym);
6254 : 76 : sym->mark = 1;
6255 : : }
6256 : : }
6257 : 503914 : else if (sym->attr.flavor == FL_PROCEDURE)
6258 : : {
6259 : : /* TODO: move to the appropriate place in resolve.cc. */
6260 : 414485 : if (warn_return_type > 0
6261 : 4385 : && sym->attr.function
6262 : 3253 : && sym->result
6263 : 3072 : && sym != sym->result
6264 : 423 : && !sym->result->attr.referenced
6265 : 36 : && !sym->attr.use_assoc
6266 : 23 : && sym->attr.if_source != IFSRC_IFBODY)
6267 : : {
6268 : 23 : gfc_warning (OPT_Wreturn_type,
6269 : : "Return value %qs of function %qs declared at "
6270 : : "%L not set", sym->result->name, sym->name,
6271 : : &sym->result->declared_at);
6272 : :
6273 : : /* Prevents "Unused variable" warning for RESULT variables. */
6274 : 23 : sym->result->mark = 1;
6275 : : }
6276 : : }
6277 : :
6278 : 923571 : if (sym->attr.dummy == 1)
6279 : : {
6280 : : /* The tree type for scalar character dummy arguments of BIND(C)
6281 : : procedures, if they are passed by value, should be unsigned char.
6282 : : The value attribute implies the dummy is a scalar. */
6283 : 86350 : if (sym->attr.value == 1 && sym->backend_decl != NULL
6284 : 7236 : && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
6285 : 253 : && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
6286 : : {
6287 : : /* We used to modify the tree here. Now it is done earlier in
6288 : : the front-end, so we only check it here to avoid regressions. */
6289 : 241 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
6290 : 241 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
6291 : 241 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
6292 : 241 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
6293 : : }
6294 : :
6295 : : /* Unused procedure passed as dummy argument. */
6296 : 86350 : if (sym->attr.flavor == FL_PROCEDURE)
6297 : : {
6298 : 875 : if (!sym->attr.referenced && !sym->attr.artificial)
6299 : : {
6300 : 55 : if (warn_unused_dummy_argument)
6301 : 2 : gfc_warning (OPT_Wunused_dummy_argument,
6302 : : "Unused dummy argument %qs at %L", sym->name,
6303 : : &sym->declared_at);
6304 : : }
6305 : :
6306 : : /* Silence bogus "unused parameter" warnings from the
6307 : : middle end. */
6308 : 875 : if (sym->backend_decl != NULL_TREE)
6309 : 874 : suppress_warning (sym->backend_decl);
6310 : : }
6311 : : }
6312 : :
6313 : : /* Make sure we convert the types of the derived types from iso_c_binding
6314 : : into (void *). */
6315 : 923571 : if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
6316 : 73337 : && sym->ts.type == BT_DERIVED)
6317 : 3225 : sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
6318 : 923571 : }
6319 : :
6320 : :
6321 : : static void
6322 : 923578 : generate_local_nml_decl (gfc_symbol * sym)
6323 : : {
6324 : 923578 : if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
6325 : : {
6326 : 673 : tree decl = generate_namelist_decl (sym);
6327 : 673 : pushdecl (decl);
6328 : : }
6329 : 923578 : }
6330 : :
6331 : :
6332 : : static void
6333 : 87625 : generate_local_vars (gfc_namespace * ns)
6334 : : {
6335 : 87625 : gfc_traverse_ns (ns, generate_local_decl);
6336 : 87625 : gfc_traverse_ns (ns, generate_local_nml_decl);
6337 : 87625 : }
6338 : :
6339 : :
6340 : : /* Generate a switch statement to jump to the correct entry point. Also
6341 : : creates the label decls for the entry points. */
6342 : :
6343 : : static tree
6344 : 632 : gfc_trans_entry_master_switch (gfc_entry_list * el)
6345 : : {
6346 : 632 : stmtblock_t block;
6347 : 632 : tree label;
6348 : 632 : tree tmp;
6349 : 632 : tree val;
6350 : :
6351 : 632 : gfc_init_block (&block);
6352 : 2605 : for (; el; el = el->next)
6353 : : {
6354 : : /* Add the case label. */
6355 : 1341 : label = gfc_build_label_decl (NULL_TREE);
6356 : 1341 : val = build_int_cst (gfc_array_index_type, el->id);
6357 : 1341 : tmp = build_case_label (val, NULL_TREE, label);
6358 : 1341 : gfc_add_expr_to_block (&block, tmp);
6359 : :
6360 : : /* And jump to the actual entry point. */
6361 : 1341 : label = gfc_build_label_decl (NULL_TREE);
6362 : 1341 : tmp = build1_v (GOTO_EXPR, label);
6363 : 1341 : gfc_add_expr_to_block (&block, tmp);
6364 : :
6365 : : /* Save the label decl. */
6366 : 1341 : el->label = label;
6367 : : }
6368 : 632 : tmp = gfc_finish_block (&block);
6369 : : /* The first argument selects the entry point. */
6370 : 632 : val = DECL_ARGUMENTS (current_function_decl);
6371 : 632 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, val, tmp);
6372 : 632 : return tmp;
6373 : : }
6374 : :
6375 : :
6376 : : /* Add code to string lengths of actual arguments passed to a function against
6377 : : the expected lengths of the dummy arguments. */
6378 : :
6379 : : static void
6380 : 2453 : add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
6381 : : {
6382 : 2453 : gfc_formal_arglist *formal;
6383 : :
6384 : 4793 : for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
6385 : 2340 : if (formal->sym && formal->sym->ts.type == BT_CHARACTER
6386 : 447 : && !formal->sym->ts.deferred)
6387 : : {
6388 : 445 : enum tree_code comparison;
6389 : 445 : tree cond;
6390 : 445 : tree argname;
6391 : 445 : gfc_symbol *fsym;
6392 : 445 : gfc_charlen *cl;
6393 : 445 : const char *message;
6394 : :
6395 : 445 : fsym = formal->sym;
6396 : 445 : cl = fsym->ts.u.cl;
6397 : :
6398 : 445 : gcc_assert (cl);
6399 : 445 : gcc_assert (cl->passed_length != NULL_TREE);
6400 : 445 : gcc_assert (cl->backend_decl != NULL_TREE);
6401 : :
6402 : : /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
6403 : : string lengths must match exactly. Otherwise, it is only required
6404 : : that the actual string length is *at least* the expected one.
6405 : : Sequence association allows for a mismatch of the string length
6406 : : if the actual argument is (part of) an array, but only if the
6407 : : dummy argument is an array. (See "Sequence association" in
6408 : : Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
6409 : 445 : if (fsym->attr.pointer || fsym->attr.allocatable
6410 : 433 : || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
6411 : 33 : || fsym->as->type == AS_ASSUMED_RANK)))
6412 : : {
6413 : 99 : comparison = NE_EXPR;
6414 : 99 : message = _("Actual string length does not match the declared one"
6415 : : " for dummy argument '%s' (%ld/%ld)");
6416 : : }
6417 : 346 : else if (fsym->as && fsym->as->rank != 0)
6418 : 33 : continue;
6419 : : else
6420 : : {
6421 : 313 : comparison = LT_EXPR;
6422 : 313 : message = _("Actual string length is shorter than the declared one"
6423 : : " for dummy argument '%s' (%ld/%ld)");
6424 : : }
6425 : :
6426 : : /* Build the condition. For optional arguments, an actual length
6427 : : of 0 is also acceptable if the associated string is NULL, which
6428 : : means the argument was not passed. */
6429 : 412 : cond = fold_build2_loc (input_location, comparison, logical_type_node,
6430 : : cl->passed_length, cl->backend_decl);
6431 : 412 : if (fsym->attr.optional)
6432 : : {
6433 : 45 : tree not_absent;
6434 : 45 : tree not_0length;
6435 : 45 : tree absent_failed;
6436 : :
6437 : 45 : not_0length = fold_build2_loc (input_location, NE_EXPR,
6438 : : logical_type_node,
6439 : : cl->passed_length,
6440 : : build_zero_cst
6441 : 45 : (TREE_TYPE (cl->passed_length)));
6442 : : /* The symbol needs to be referenced for gfc_get_symbol_decl. */
6443 : 45 : fsym->attr.referenced = 1;
6444 : 45 : not_absent = gfc_conv_expr_present (fsym);
6445 : :
6446 : 45 : absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6447 : : logical_type_node, not_0length,
6448 : : not_absent);
6449 : :
6450 : 45 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6451 : : logical_type_node, cond, absent_failed);
6452 : : }
6453 : :
6454 : : /* Build the runtime check. */
6455 : 412 : argname = gfc_build_cstring_const (fsym->name);
6456 : 412 : argname = gfc_build_addr_expr (pchar_type_node, argname);
6457 : 412 : gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
6458 : : message, argname,
6459 : : fold_convert (long_integer_type_node,
6460 : : cl->passed_length),
6461 : : fold_convert (long_integer_type_node,
6462 : : cl->backend_decl));
6463 : : }
6464 : 2453 : }
6465 : :
6466 : :
6467 : : static void
6468 : 24870 : create_main_function (tree fndecl)
6469 : : {
6470 : 24870 : tree old_context;
6471 : 24870 : tree ftn_main;
6472 : 24870 : tree tmp, decl, result_decl, argc, argv, typelist, arglist;
6473 : 24870 : stmtblock_t body;
6474 : :
6475 : 24870 : old_context = current_function_decl;
6476 : :
6477 : 24870 : if (old_context)
6478 : : {
6479 : 0 : push_function_context ();
6480 : 0 : saved_parent_function_decls = saved_function_decls;
6481 : 0 : saved_function_decls = NULL_TREE;
6482 : : }
6483 : :
6484 : : /* main() function must be declared with global scope. */
6485 : 24870 : gcc_assert (current_function_decl == NULL_TREE);
6486 : :
6487 : : /* Declare the function. */
6488 : 24870 : tmp = build_function_type_list (integer_type_node, integer_type_node,
6489 : : build_pointer_type (pchar_type_node),
6490 : : NULL_TREE);
6491 : 24870 : main_identifier_node = get_identifier ("main");
6492 : 24870 : ftn_main = build_decl (input_location, FUNCTION_DECL,
6493 : : main_identifier_node, tmp);
6494 : 24870 : DECL_EXTERNAL (ftn_main) = 0;
6495 : 24870 : TREE_PUBLIC (ftn_main) = 1;
6496 : 24870 : TREE_STATIC (ftn_main) = 1;
6497 : 24870 : DECL_ATTRIBUTES (ftn_main)
6498 : 24870 : = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
6499 : :
6500 : : /* Setup the result declaration (for "return 0"). */
6501 : 24870 : result_decl = build_decl (input_location,
6502 : : RESULT_DECL, NULL_TREE, integer_type_node);
6503 : 24870 : DECL_ARTIFICIAL (result_decl) = 1;
6504 : 24870 : DECL_IGNORED_P (result_decl) = 1;
6505 : 24870 : DECL_CONTEXT (result_decl) = ftn_main;
6506 : 24870 : DECL_RESULT (ftn_main) = result_decl;
6507 : :
6508 : 24870 : pushdecl (ftn_main);
6509 : :
6510 : : /* Get the arguments. */
6511 : :
6512 : 24870 : arglist = NULL_TREE;
6513 : 24870 : typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
6514 : :
6515 : 24870 : tmp = TREE_VALUE (typelist);
6516 : 24870 : argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
6517 : 24870 : DECL_CONTEXT (argc) = ftn_main;
6518 : 24870 : DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
6519 : 24870 : TREE_READONLY (argc) = 1;
6520 : 24870 : gfc_finish_decl (argc);
6521 : 24870 : arglist = chainon (arglist, argc);
6522 : :
6523 : 24870 : typelist = TREE_CHAIN (typelist);
6524 : 24870 : tmp = TREE_VALUE (typelist);
6525 : 24870 : argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
6526 : 24870 : DECL_CONTEXT (argv) = ftn_main;
6527 : 24870 : DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
6528 : 24870 : TREE_READONLY (argv) = 1;
6529 : 24870 : DECL_BY_REFERENCE (argv) = 1;
6530 : 24870 : gfc_finish_decl (argv);
6531 : 24870 : arglist = chainon (arglist, argv);
6532 : :
6533 : 24870 : DECL_ARGUMENTS (ftn_main) = arglist;
6534 : 24870 : current_function_decl = ftn_main;
6535 : 24870 : announce_function (ftn_main);
6536 : :
6537 : 24870 : rest_of_decl_compilation (ftn_main, 1, 0);
6538 : 24870 : make_decl_rtl (ftn_main);
6539 : 24870 : allocate_struct_function (ftn_main, false);
6540 : 24870 : pushlevel ();
6541 : :
6542 : 24870 : gfc_init_block (&body);
6543 : :
6544 : : /* Call some libgfortran initialization routines, call then MAIN__(). */
6545 : :
6546 : : /* Call _gfortran_caf_init (*argc, ***argv). */
6547 : 24870 : if (flag_coarray == GFC_FCOARRAY_LIB)
6548 : : {
6549 : 241 : tree pint_type, pppchar_type;
6550 : 241 : pint_type = build_pointer_type (integer_type_node);
6551 : 241 : pppchar_type
6552 : 241 : = build_pointer_type (build_pointer_type (pchar_type_node));
6553 : :
6554 : 241 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
6555 : : gfc_build_addr_expr (pint_type, argc),
6556 : : gfc_build_addr_expr (pppchar_type, argv));
6557 : 241 : gfc_add_expr_to_block (&body, tmp);
6558 : : }
6559 : :
6560 : : /* Call _gfortran_set_args (argc, argv). */
6561 : 24870 : TREE_USED (argc) = 1;
6562 : 24870 : TREE_USED (argv) = 1;
6563 : 24870 : tmp = build_call_expr_loc (input_location,
6564 : : gfor_fndecl_set_args, 2, argc, argv);
6565 : 24870 : gfc_add_expr_to_block (&body, tmp);
6566 : :
6567 : : /* Add a call to set_options to set up the runtime library Fortran
6568 : : language standard parameters. */
6569 : 24870 : {
6570 : 24870 : tree array_type, array, var;
6571 : 24870 : vec<constructor_elt, va_gc> *v = NULL;
6572 : 24870 : static const int noptions = 7;
6573 : :
6574 : : /* Passing a new option to the library requires three modifications:
6575 : : + add it to the tree_cons list below
6576 : : + change the noptions variable above
6577 : : + modify the library (runtime/compile_options.c)! */
6578 : :
6579 : 24870 : CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6580 : : build_int_cst (integer_type_node,
6581 : : gfc_option.warn_std));
6582 : 24870 : CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6583 : : build_int_cst (integer_type_node,
6584 : : gfc_option.allow_std));
6585 : 24870 : CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6586 : : build_int_cst (integer_type_node, pedantic));
6587 : 24870 : CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6588 : : build_int_cst (integer_type_node, flag_backtrace));
6589 : 24870 : CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6590 : : build_int_cst (integer_type_node, flag_sign_zero));
6591 : 24870 : CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6592 : : build_int_cst (integer_type_node,
6593 : : (gfc_option.rtcheck
6594 : : & GFC_RTCHECK_BOUNDS)));
6595 : 24870 : CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6596 : : build_int_cst (integer_type_node,
6597 : : gfc_option.fpe_summary));
6598 : :
6599 : 24870 : array_type = build_array_type_nelts (integer_type_node, noptions);
6600 : 24870 : array = build_constructor (array_type, v);
6601 : 24870 : TREE_CONSTANT (array) = 1;
6602 : 24870 : TREE_STATIC (array) = 1;
6603 : :
6604 : : /* Create a static variable to hold the jump table. */
6605 : 24870 : var = build_decl (input_location, VAR_DECL,
6606 : : create_tmp_var_name ("options"), array_type);
6607 : 24870 : DECL_ARTIFICIAL (var) = 1;
6608 : 24870 : DECL_IGNORED_P (var) = 1;
6609 : 24870 : TREE_CONSTANT (var) = 1;
6610 : 24870 : TREE_STATIC (var) = 1;
6611 : 24870 : TREE_READONLY (var) = 1;
6612 : 24870 : DECL_INITIAL (var) = array;
6613 : 24870 : pushdecl (var);
6614 : 24870 : var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
6615 : :
6616 : 24870 : tmp = build_call_expr_loc (input_location,
6617 : : gfor_fndecl_set_options, 2,
6618 : : build_int_cst (integer_type_node, noptions), var);
6619 : 24870 : gfc_add_expr_to_block (&body, tmp);
6620 : : }
6621 : :
6622 : : /* If -ffpe-trap option was provided, add a call to set_fpe so that
6623 : : the library will raise a FPE when needed. */
6624 : 24870 : if (gfc_option.fpe != 0)
6625 : : {
6626 : 6 : tmp = build_call_expr_loc (input_location,
6627 : : gfor_fndecl_set_fpe, 1,
6628 : : build_int_cst (integer_type_node,
6629 : : gfc_option.fpe));
6630 : 6 : gfc_add_expr_to_block (&body, tmp);
6631 : : }
6632 : :
6633 : : /* If this is the main program and an -fconvert option was provided,
6634 : : add a call to set_convert. */
6635 : :
6636 : 24870 : if (flag_convert != GFC_FLAG_CONVERT_NATIVE)
6637 : : {
6638 : 12 : tmp = build_call_expr_loc (input_location,
6639 : : gfor_fndecl_set_convert, 1,
6640 : : build_int_cst (integer_type_node, flag_convert));
6641 : 12 : gfc_add_expr_to_block (&body, tmp);
6642 : : }
6643 : :
6644 : : /* If this is the main program and an -frecord-marker option was provided,
6645 : : add a call to set_record_marker. */
6646 : :
6647 : 24870 : if (flag_record_marker != 0)
6648 : : {
6649 : 18 : tmp = build_call_expr_loc (input_location,
6650 : : gfor_fndecl_set_record_marker, 1,
6651 : : build_int_cst (integer_type_node,
6652 : : flag_record_marker));
6653 : 18 : gfc_add_expr_to_block (&body, tmp);
6654 : : }
6655 : :
6656 : 24870 : if (flag_max_subrecord_length != 0)
6657 : : {
6658 : 6 : tmp = build_call_expr_loc (input_location,
6659 : : gfor_fndecl_set_max_subrecord_length, 1,
6660 : : build_int_cst (integer_type_node,
6661 : : flag_max_subrecord_length));
6662 : 6 : gfc_add_expr_to_block (&body, tmp);
6663 : : }
6664 : :
6665 : : /* Call MAIN__(). */
6666 : 24870 : tmp = build_call_expr_loc (input_location,
6667 : : fndecl, 0);
6668 : 24870 : gfc_add_expr_to_block (&body, tmp);
6669 : :
6670 : : /* Mark MAIN__ as used. */
6671 : 24870 : TREE_USED (fndecl) = 1;
6672 : :
6673 : : /* Coarray: Call _gfortran_caf_finalize(void). */
6674 : 24870 : if (flag_coarray == GFC_FCOARRAY_LIB)
6675 : : {
6676 : 241 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
6677 : 241 : gfc_add_expr_to_block (&body, tmp);
6678 : : }
6679 : :
6680 : : /* "return 0". */
6681 : 24870 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
6682 : 24870 : DECL_RESULT (ftn_main),
6683 : : integer_zero_node);
6684 : 24870 : tmp = build1_v (RETURN_EXPR, tmp);
6685 : 24870 : gfc_add_expr_to_block (&body, tmp);
6686 : :
6687 : :
6688 : 24870 : DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
6689 : 24870 : decl = getdecls ();
6690 : :
6691 : : /* Finish off this function and send it for code generation. */
6692 : 24870 : poplevel (1, 1);
6693 : 24870 : BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
6694 : :
6695 : 49740 : DECL_SAVED_TREE (ftn_main)
6696 : 49740 : = fold_build3_loc (DECL_SOURCE_LOCATION (ftn_main), BIND_EXPR,
6697 : 24870 : void_type_node, decl, DECL_SAVED_TREE (ftn_main),
6698 : 24870 : DECL_INITIAL (ftn_main));
6699 : :
6700 : : /* Output the GENERIC tree. */
6701 : 24870 : dump_function (TDI_original, ftn_main);
6702 : :
6703 : 24870 : cgraph_node::finalize_function (ftn_main, true);
6704 : :
6705 : 24870 : if (old_context)
6706 : : {
6707 : 0 : pop_function_context ();
6708 : 0 : saved_function_decls = saved_parent_function_decls;
6709 : : }
6710 : 24870 : current_function_decl = old_context;
6711 : 24870 : }
6712 : :
6713 : :
6714 : : /* Generate an appropriate return-statement for a procedure. */
6715 : :
6716 : : tree
6717 : 13615 : gfc_generate_return (void)
6718 : : {
6719 : 13615 : gfc_symbol* sym;
6720 : 13615 : tree result;
6721 : 13615 : tree fndecl;
6722 : :
6723 : 13615 : sym = current_procedure_symbol;
6724 : 13615 : fndecl = sym->backend_decl;
6725 : :
6726 : 13615 : if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
6727 : : result = NULL_TREE;
6728 : : else
6729 : : {
6730 : 11532 : result = get_proc_result (sym);
6731 : :
6732 : : /* Set the return value to the dummy result variable. The
6733 : : types may be different for scalar default REAL functions
6734 : : with -ff2c, therefore we have to convert. */
6735 : 11532 : if (result != NULL_TREE)
6736 : : {
6737 : 11513 : result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
6738 : 23026 : result = fold_build2_loc (input_location, MODIFY_EXPR,
6739 : 11513 : TREE_TYPE (result), DECL_RESULT (fndecl),
6740 : : result);
6741 : : }
6742 : : else
6743 : : {
6744 : : /* If the function does not have a result variable, result is
6745 : : NULL_TREE, and a 'return' is generated without a variable.
6746 : : The following generates a 'return __result_XXX' where XXX is
6747 : : the function name. */
6748 : 19 : if (sym == sym->result && sym->attr.function && !flag_f2c)
6749 : : {
6750 : 8 : result = gfc_get_fake_result_decl (sym, 0);
6751 : 16 : result = fold_build2_loc (input_location, MODIFY_EXPR,
6752 : 8 : TREE_TYPE (result),
6753 : 8 : DECL_RESULT (fndecl), result);
6754 : : }
6755 : : }
6756 : : }
6757 : :
6758 : 13615 : return build1_v (RETURN_EXPR, result);
6759 : : }
6760 : :
6761 : :
6762 : : static void
6763 : 895144 : is_from_ieee_module (gfc_symbol *sym)
6764 : : {
6765 : 895144 : if (sym->from_intmod == INTMOD_IEEE_FEATURES
6766 : : || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS
6767 : 895144 : || sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6768 : 104456 : seen_ieee_symbol = 1;
6769 : 895144 : }
6770 : :
6771 : :
6772 : : static int
6773 : 74735 : is_ieee_module_used (gfc_namespace *ns)
6774 : : {
6775 : 74735 : seen_ieee_symbol = 0;
6776 : 0 : gfc_traverse_ns (ns, is_from_ieee_module);
6777 : 74735 : return seen_ieee_symbol;
6778 : : }
6779 : :
6780 : :
6781 : : static gfc_omp_clauses *module_oacc_clauses;
6782 : :
6783 : :
6784 : : static void
6785 : 144 : add_clause (gfc_symbol *sym, gfc_omp_map_op map_op)
6786 : : {
6787 : 144 : gfc_omp_namelist *n;
6788 : :
6789 : 144 : n = gfc_get_omp_namelist ();
6790 : 144 : n->sym = sym;
6791 : 144 : n->u.map.op = map_op;
6792 : :
6793 : 144 : if (!module_oacc_clauses)
6794 : 122 : module_oacc_clauses = gfc_get_omp_clauses ();
6795 : :
6796 : 144 : if (module_oacc_clauses->lists[OMP_LIST_MAP])
6797 : 22 : n->next = module_oacc_clauses->lists[OMP_LIST_MAP];
6798 : :
6799 : 144 : module_oacc_clauses->lists[OMP_LIST_MAP] = n;
6800 : 144 : }
6801 : :
6802 : :
6803 : : static void
6804 : 923578 : find_module_oacc_declare_clauses (gfc_symbol *sym)
6805 : : {
6806 : 923578 : if (sym->attr.use_assoc)
6807 : : {
6808 : 426098 : gfc_omp_map_op map_op;
6809 : :
6810 : 426098 : if (sym->attr.oacc_declare_create)
6811 : 426098 : map_op = OMP_MAP_FORCE_ALLOC;
6812 : :
6813 : 426098 : if (sym->attr.oacc_declare_copyin)
6814 : 2 : map_op = OMP_MAP_FORCE_TO;
6815 : :
6816 : 426098 : if (sym->attr.oacc_declare_deviceptr)
6817 : 0 : map_op = OMP_MAP_FORCE_DEVICEPTR;
6818 : :
6819 : 426098 : if (sym->attr.oacc_declare_device_resident)
6820 : 32 : map_op = OMP_MAP_DEVICE_RESIDENT;
6821 : :
6822 : 426098 : if (sym->attr.oacc_declare_create
6823 : : || sym->attr.oacc_declare_copyin
6824 : : || sym->attr.oacc_declare_deviceptr
6825 : 426098 : || sym->attr.oacc_declare_device_resident)
6826 : : {
6827 : 144 : sym->attr.referenced = 1;
6828 : 144 : add_clause (sym, map_op);
6829 : : }
6830 : : }
6831 : 923578 : }
6832 : :
6833 : :
6834 : : void
6835 : 87625 : finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
6836 : : {
6837 : 87625 : gfc_code *code;
6838 : 87625 : gfc_oacc_declare *oc;
6839 : 87625 : locus where = gfc_current_locus;
6840 : 87625 : gfc_omp_clauses *omp_clauses = NULL;
6841 : 87625 : gfc_omp_namelist *n, *p;
6842 : :
6843 : 87625 : module_oacc_clauses = NULL;
6844 : 87625 : gfc_traverse_ns (ns, find_module_oacc_declare_clauses);
6845 : :
6846 : 87625 : if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM)
6847 : : {
6848 : 43 : gfc_oacc_declare *new_oc;
6849 : :
6850 : 43 : new_oc = gfc_get_oacc_declare ();
6851 : 43 : new_oc->next = ns->oacc_declare;
6852 : 43 : new_oc->clauses = module_oacc_clauses;
6853 : :
6854 : 43 : ns->oacc_declare = new_oc;
6855 : : }
6856 : :
6857 : 87625 : if (!ns->oacc_declare)
6858 : : return;
6859 : :
6860 : 182 : for (oc = ns->oacc_declare; oc; oc = oc->next)
6861 : : {
6862 : 97 : if (oc->module_var)
6863 : 0 : continue;
6864 : :
6865 : 97 : if (block)
6866 : 2 : gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed "
6867 : : "in BLOCK construct", &oc->loc);
6868 : :
6869 : :
6870 : 97 : if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP])
6871 : : {
6872 : 85 : if (omp_clauses == NULL)
6873 : : {
6874 : 73 : omp_clauses = oc->clauses;
6875 : 73 : continue;
6876 : : }
6877 : :
6878 : 48 : for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next)
6879 : : ;
6880 : :
6881 : 12 : gcc_assert (p->next == NULL);
6882 : :
6883 : 12 : p->next = omp_clauses->lists[OMP_LIST_MAP];
6884 : 12 : omp_clauses = oc->clauses;
6885 : : }
6886 : : }
6887 : :
6888 : 85 : if (!omp_clauses)
6889 : : return;
6890 : :
6891 : 204 : for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next)
6892 : : {
6893 : 131 : switch (n->u.map.op)
6894 : : {
6895 : 25 : case OMP_MAP_DEVICE_RESIDENT:
6896 : 25 : n->u.map.op = OMP_MAP_FORCE_ALLOC;
6897 : 25 : break;
6898 : :
6899 : : default:
6900 : : break;
6901 : : }
6902 : : }
6903 : :
6904 : 73 : code = XCNEW (gfc_code);
6905 : 73 : code->op = EXEC_OACC_DECLARE;
6906 : 73 : code->loc = where;
6907 : :
6908 : 73 : code->ext.oacc_declare = gfc_get_oacc_declare ();
6909 : 73 : code->ext.oacc_declare->clauses = omp_clauses;
6910 : :
6911 : 73 : code->block = XCNEW (gfc_code);
6912 : 73 : code->block->op = EXEC_OACC_DECLARE;
6913 : 73 : code->block->loc = where;
6914 : :
6915 : 73 : if (ns->code)
6916 : 70 : code->block->next = ns->code;
6917 : :
6918 : 73 : ns->code = code;
6919 : :
6920 : 73 : return;
6921 : : }
6922 : :
6923 : : static void
6924 : 1808 : gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
6925 : : tree cfi_desc, tree gfc_desc, gfc_symbol *sym)
6926 : : {
6927 : 1808 : stmtblock_t block;
6928 : 1808 : gfc_init_block (&block);
6929 : 1808 : tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
6930 : 1808 : tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
6931 : 1808 : bool do_copy_inout = false;
6932 : :
6933 : : /* When allocatable + intent out, free the cfi descriptor. */
6934 : 1808 : if (sym->attr.allocatable && sym->attr.intent == INTENT_OUT)
6935 : : {
6936 : 54 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6937 : 54 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6938 : 54 : call = build_call_expr_loc (input_location, call, 1, tmp);
6939 : 54 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6940 : 54 : gfc_add_modify (&block, tmp,
6941 : 54 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6942 : : }
6943 : :
6944 : : /* -fcheck=bound: Do version, rank, attribute, type and is-NULL checks. */
6945 : 1808 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6946 : : {
6947 : 654 : char *msg;
6948 : 654 : tree tmp3;
6949 : 654 : msg = xasprintf ("Unexpected version %%d (expected %d) in CFI descriptor "
6950 : : "passed to dummy argument %s", CFI_VERSION, sym->name);
6951 : 654 : tmp2 = gfc_get_cfi_desc_version (cfi);
6952 : 654 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
6953 : 654 : build_int_cst (TREE_TYPE (tmp2), CFI_VERSION));
6954 : 654 : gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
6955 : : msg, tmp2);
6956 : 654 : free (msg);
6957 : :
6958 : : /* Rank check; however, for character(len=*), assumed/explicit-size arrays
6959 : : are permitted to differ in rank according to the Fortran rules. */
6960 : 654 : if (sym->as && sym->as->type != AS_ASSUMED_SIZE
6961 : 546 : && sym->as->type != AS_EXPLICIT)
6962 : : {
6963 : 438 : if (sym->as->rank != -1)
6964 : 222 : msg = xasprintf ("Invalid rank %%d (expected %d) in CFI descriptor "
6965 : : "passed to dummy argument %s", sym->as->rank,
6966 : : sym->name);
6967 : : else
6968 : 216 : msg = xasprintf ("Invalid rank %%d (expected 0..%d) in CFI "
6969 : : "descriptor passed to dummy argument %s",
6970 : : CFI_MAX_RANK, sym->name);
6971 : :
6972 : 438 : tmp3 = tmp2 = tmp = gfc_get_cfi_desc_rank (cfi);
6973 : 438 : if (sym->as->rank != -1)
6974 : 222 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6975 : : tmp, build_int_cst (signed_char_type_node,
6976 : 222 : sym->as->rank));
6977 : : else
6978 : : {
6979 : 216 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
6980 : 216 : tmp, build_zero_cst (TREE_TYPE (tmp)));
6981 : 216 : tmp2 = fold_build2_loc (input_location, GT_EXPR,
6982 : : boolean_type_node, tmp2,
6983 : 216 : build_int_cst (TREE_TYPE (tmp2),
6984 : 216 : CFI_MAX_RANK));
6985 : 216 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
6986 : : boolean_type_node, tmp, tmp2);
6987 : : }
6988 : 438 : gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
6989 : : msg, tmp3);
6990 : 438 : free (msg);
6991 : : }
6992 : :
6993 : 654 : tmp3 = tmp = gfc_get_cfi_desc_attribute (cfi);
6994 : 654 : if (sym->attr.allocatable || sym->attr.pointer)
6995 : : {
6996 : 6 : int attr = (sym->attr.pointer ? CFI_attribute_pointer
6997 : : : CFI_attribute_allocatable);
6998 : 12 : msg = xasprintf ("Invalid attribute %%d (expected %d) in CFI "
6999 : : "descriptor passed to dummy argument %s with %s "
7000 : : "attribute", attr, sym->name,
7001 : : sym->attr.pointer ? "pointer" : "allocatable");
7002 : 6 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7003 : 6 : tmp, build_int_cst (TREE_TYPE (tmp), attr));
7004 : : }
7005 : : else
7006 : : {
7007 : 648 : int amin = MIN (CFI_attribute_pointer,
7008 : : MIN (CFI_attribute_allocatable, CFI_attribute_other));
7009 : 648 : int amax = MAX (CFI_attribute_pointer,
7010 : : MAX (CFI_attribute_allocatable, CFI_attribute_other));
7011 : 648 : msg = xasprintf ("Invalid attribute %%d (expected %d..%d) in CFI "
7012 : : "descriptor passed to nonallocatable, nonpointer "
7013 : : "dummy argument %s", amin, amax, sym->name);
7014 : 648 : tmp2 = tmp;
7015 : 648 : tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp,
7016 : 648 : build_int_cst (TREE_TYPE (tmp), amin));
7017 : 648 : tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2,
7018 : 648 : build_int_cst (TREE_TYPE (tmp2), amax));
7019 : 648 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7020 : : boolean_type_node, tmp, tmp2);
7021 : 648 : gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
7022 : : msg, tmp3);
7023 : 648 : free (msg);
7024 : 648 : msg = xasprintf ("Invalid unallocatated/unassociated CFI "
7025 : : "descriptor passed to nonallocatable, nonpointer "
7026 : : "dummy argument %s", sym->name);
7027 : 648 : tmp3 = tmp = gfc_get_cfi_desc_base_addr (cfi),
7028 : 648 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7029 : : tmp, null_pointer_node);
7030 : : }
7031 : 654 : gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
7032 : : msg, tmp3);
7033 : 654 : free (msg);
7034 : :
7035 : 654 : if (sym->ts.type != BT_ASSUMED)
7036 : : {
7037 : 654 : int type = CFI_type_other;
7038 : 654 : if (sym->ts.f90_type == BT_VOID)
7039 : : {
7040 : 0 : type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
7041 : 0 : ? CFI_type_cfunptr : CFI_type_cptr);
7042 : : }
7043 : : else
7044 : 654 : switch (sym->ts.type)
7045 : : {
7046 : 6 : case BT_INTEGER:
7047 : 6 : case BT_LOGICAL:
7048 : 6 : case BT_REAL:
7049 : 6 : case BT_COMPLEX:
7050 : 6 : type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind);
7051 : 6 : break;
7052 : 648 : case BT_CHARACTER:
7053 : 648 : type = CFI_type_from_type_kind (CFI_type_Character,
7054 : : sym->ts.kind);
7055 : 648 : break;
7056 : 0 : case BT_DERIVED:
7057 : 0 : type = CFI_type_struct;
7058 : 0 : break;
7059 : 0 : case BT_VOID:
7060 : 0 : type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
7061 : 0 : ? CFI_type_cfunptr : CFI_type_cptr);
7062 : : break;
7063 : 0 : case BT_ASSUMED:
7064 : 0 : case BT_CLASS:
7065 : 0 : case BT_PROCEDURE:
7066 : 0 : case BT_HOLLERITH:
7067 : 0 : case BT_UNION:
7068 : 0 : case BT_BOZ:
7069 : 0 : case BT_UNKNOWN:
7070 : 0 : gcc_unreachable ();
7071 : : }
7072 : 654 : msg = xasprintf ("Unexpected type %%d (expected %d) in CFI descriptor"
7073 : : " passed to dummy argument %s", type, sym->name);
7074 : 654 : tmp2 = tmp = gfc_get_cfi_desc_type (cfi);
7075 : 654 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7076 : 654 : tmp, build_int_cst (TREE_TYPE (tmp), type));
7077 : 654 : gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
7078 : : msg, tmp2);
7079 : 654 : free (msg);
7080 : : }
7081 : : }
7082 : :
7083 : 1808 : if (!sym->attr.referenced)
7084 : 62 : goto done;
7085 : :
7086 : : /* Set string length for len=* and len=:, otherwise, it is already set. */
7087 : 1746 : if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
7088 : : {
7089 : 647 : tmp = fold_convert (gfc_array_index_type,
7090 : : gfc_get_cfi_desc_elem_len (cfi));
7091 : 647 : if (sym->ts.kind != 1)
7092 : 197 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
7093 : : gfc_array_index_type, tmp,
7094 : : build_int_cst (gfc_charlen_type_node,
7095 : 197 : sym->ts.kind));
7096 : 647 : gfc_add_modify (&block, sym->ts.u.cl->backend_decl, tmp);
7097 : : }
7098 : :
7099 : 1746 : if (sym->ts.type == BT_CHARACTER
7100 : 1020 : && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
7101 : : {
7102 : 804 : gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
7103 : 804 : gfc_trans_vla_type_sizes (sym, &block);
7104 : : }
7105 : :
7106 : : /* gfc->data = cfi->base_addr - or for scalars: gfc = cfi->base_addr.
7107 : : assumed-size/explicit-size arrays end up here for character(len=*)
7108 : : only. */
7109 : 1746 : if (!sym->attr.dimension || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7110 : : {
7111 : 417 : tmp = gfc_get_cfi_desc_base_addr (cfi);
7112 : 417 : gfc_add_modify (&block, gfc_desc,
7113 : 417 : fold_convert (TREE_TYPE (gfc_desc), tmp));
7114 : 417 : if (!sym->attr.dimension)
7115 : 163 : goto done;
7116 : : }
7117 : :
7118 : 1583 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7119 : : {
7120 : : /* gfc->dtype = ... (from declaration, not from cfi). */
7121 : 1329 : etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
7122 : 1329 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc),
7123 : 1329 : gfc_get_dtype_rank_type (sym->as->rank, etype));
7124 : : /* gfc->data = cfi->base_addr. */
7125 : 1329 : gfc_conv_descriptor_data_set (&block, gfc_desc,
7126 : : gfc_get_cfi_desc_base_addr (cfi));
7127 : : }
7128 : :
7129 : 1583 : if (sym->ts.type == BT_ASSUMED)
7130 : : {
7131 : : /* For type(*), take elem_len + dtype.type from the actual argument. */
7132 : 19 : gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc),
7133 : : gfc_get_cfi_desc_elem_len (cfi));
7134 : 19 : tree cond;
7135 : 19 : tree ctype = gfc_get_cfi_desc_type (cfi);
7136 : 19 : ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
7137 : 19 : ctype, build_int_cst (TREE_TYPE (ctype),
7138 : 19 : CFI_type_mask));
7139 : 19 : tree type = gfc_conv_descriptor_type (gfc_desc);
7140 : :
7141 : : /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
7142 : : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
7143 : 19 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7144 : 19 : build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
7145 : 19 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7146 : 19 : build_int_cst (TREE_TYPE (type), BT_VOID));
7147 : 19 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7148 : : type,
7149 : 19 : build_int_cst (TREE_TYPE (type), BT_UNKNOWN));
7150 : 19 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7151 : : tmp, tmp2);
7152 : : /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
7153 : 19 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7154 : 19 : build_int_cst (TREE_TYPE (ctype),
7155 : 19 : CFI_type_struct));
7156 : 19 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7157 : 19 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
7158 : 19 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7159 : : tmp, tmp2);
7160 : : /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */
7161 : : /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
7162 : : before (see below, as generated bottom up). */
7163 : 19 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7164 : 19 : build_int_cst (TREE_TYPE (ctype),
7165 : 19 : CFI_type_Character));
7166 : 19 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7167 : 19 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
7168 : 19 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7169 : : tmp, tmp2);
7170 : : /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */
7171 : : /* Note: gfc->elem_len = cfi->elem_len/4. */
7172 : : /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
7173 : : gfc->elem_len == cfi->elem_len, which helps with operations which use
7174 : : sizeof() in Fortran and cfi->elem_len in C. */
7175 : 19 : tmp = gfc_get_cfi_desc_type (cfi);
7176 : 19 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
7177 : 19 : build_int_cst (TREE_TYPE (tmp),
7178 : 19 : CFI_type_ucs4_char));
7179 : 19 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7180 : 19 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
7181 : 19 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7182 : : tmp, tmp2);
7183 : : /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else < tmp2 > */
7184 : 19 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7185 : 19 : build_int_cst (TREE_TYPE (ctype),
7186 : 19 : CFI_type_Complex));
7187 : 19 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
7188 : 19 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
7189 : 19 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7190 : : tmp, tmp2);
7191 : : /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real)
7192 : : ctype else <tmp2> */
7193 : 19 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7194 : 19 : build_int_cst (TREE_TYPE (ctype),
7195 : 19 : CFI_type_Integer));
7196 : 19 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7197 : 19 : build_int_cst (TREE_TYPE (ctype),
7198 : 19 : CFI_type_Logical));
7199 : 19 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
7200 : : cond, tmp);
7201 : 19 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
7202 : 19 : build_int_cst (TREE_TYPE (ctype),
7203 : 19 : CFI_type_Real));
7204 : 19 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
7205 : : cond, tmp);
7206 : 19 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7207 : 19 : type, fold_convert (TREE_TYPE (type), ctype));
7208 : 19 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
7209 : : tmp, tmp2);
7210 : 19 : gfc_add_expr_to_block (&block, tmp2);
7211 : : }
7212 : :
7213 : 1583 : if (sym->as->rank < 0)
7214 : : {
7215 : : /* Set gfc->dtype.rank, if assumed-rank. */
7216 : 587 : rank = gfc_get_cfi_desc_rank (cfi);
7217 : 587 : gfc_add_modify (&block, gfc_conv_descriptor_rank (gfc_desc), rank);
7218 : : }
7219 : 996 : else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7220 : : /* In that case, the CFI rank and the declared rank can differ. */
7221 : 254 : rank = gfc_get_cfi_desc_rank (cfi);
7222 : : else
7223 : 742 : rank = build_int_cst (signed_char_type_node, sym->as->rank);
7224 : :
7225 : : /* With bind(C), the standard requires that both Fortran callers and callees
7226 : : handle noncontiguous arrays passed to an dummy with 'contiguous' attribute
7227 : : and with character(len=*) + assumed-size/explicit-size arrays.
7228 : : cf. Fortran 2018, 18.3.6, paragraph 5 (and for the caller: para. 6). */
7229 : 1583 : if ((sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length
7230 : 550 : && (sym->as->type == AS_ASSUMED_SIZE || sym->as->type == AS_EXPLICIT))
7231 : 1329 : || sym->attr.contiguous)
7232 : : {
7233 : 517 : do_copy_inout = true;
7234 : 517 : gcc_assert (!sym->attr.pointer);
7235 : 517 : stmtblock_t block2;
7236 : 517 : tree data;
7237 : 517 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7238 : 263 : data = gfc_conv_descriptor_data_get (gfc_desc);
7239 : 254 : else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc)))
7240 : 0 : data = gfc_build_addr_expr (NULL, gfc_desc);
7241 : : else
7242 : : data = gfc_desc;
7243 : :
7244 : : /* Is copy-in/out needed? */
7245 : : /* do_copyin = rank != 0 && !assumed-size */
7246 : 517 : tree cond_var = gfc_create_var (boolean_type_node, "do_copyin");
7247 : 517 : tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7248 : 517 : rank, build_zero_cst (TREE_TYPE (rank)));
7249 : : /* dim[rank-1].extent != -1 -> assumed size*/
7250 : 517 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (rank),
7251 : 517 : rank, build_int_cst (TREE_TYPE (rank), 1));
7252 : 517 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7253 : : gfc_get_cfi_dim_extent (cfi, tmp),
7254 : 517 : build_int_cst (gfc_array_index_type, -1));
7255 : 517 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
7256 : : boolean_type_node, cond, tmp);
7257 : 517 : gfc_add_modify (&block, cond_var, cond);
7258 : : /* if (do_copyin) do_copyin = ... || ... || ... */
7259 : 517 : gfc_init_block (&block2);
7260 : : /* dim[0].sm != elem_len */
7261 : 517 : tmp = fold_convert (gfc_array_index_type,
7262 : : gfc_get_cfi_desc_elem_len (cfi));
7263 : 517 : cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7264 : : gfc_get_cfi_dim_sm (cfi, gfc_index_zero_node),
7265 : : tmp);
7266 : 517 : gfc_add_modify (&block2, cond_var, cond);
7267 : :
7268 : : /* for (i = 1; i < rank; ++i)
7269 : : cond &&= dim[i].sm != (dv->dim[i - 1].sm * dv->dim[i - 1].extent) */
7270 : 517 : idx = gfc_create_var (TREE_TYPE (rank), "idx");
7271 : 517 : stmtblock_t loop_body;
7272 : 517 : gfc_init_block (&loop_body);
7273 : 517 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
7274 : 517 : idx, build_int_cst (TREE_TYPE (idx), 1));
7275 : 517 : tree tmp2 = gfc_get_cfi_dim_sm (cfi, tmp);
7276 : 517 : tmp = gfc_get_cfi_dim_extent (cfi, tmp);
7277 : 517 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
7278 : : tmp2, tmp);
7279 : 517 : cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7280 : : gfc_get_cfi_dim_sm (cfi, idx), tmp);
7281 : 517 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
7282 : : cond_var, cond);
7283 : 517 : gfc_add_modify (&loop_body, cond_var, cond);
7284 : 517 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1),
7285 : 517 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7286 : : gfc_finish_block (&loop_body));
7287 : 517 : tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2),
7288 : : build_empty_stmt (input_location));
7289 : 517 : gfc_add_expr_to_block (&block, tmp);
7290 : :
7291 : : /* Copy-in body. */
7292 : 517 : gfc_init_block (&block2);
7293 : : /* size = dim[0].extent; for (i = 1; i < rank; ++i) size *= dim[i].extent */
7294 : 517 : size_var = gfc_create_var (size_type_node, "size");
7295 : 517 : tmp = fold_convert (size_type_node,
7296 : : gfc_get_cfi_dim_extent (cfi, gfc_index_zero_node));
7297 : 517 : gfc_add_modify (&block2, size_var, tmp);
7298 : :
7299 : 517 : gfc_init_block (&loop_body);
7300 : 517 : tmp = fold_convert (size_type_node,
7301 : : gfc_get_cfi_dim_extent (cfi, idx));
7302 : 517 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
7303 : : size_var, fold_convert (size_type_node, tmp));
7304 : 517 : gfc_add_modify (&loop_body, size_var, tmp);
7305 : 517 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1),
7306 : 517 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7307 : : gfc_finish_block (&loop_body));
7308 : : /* data = malloc (size * elem_len) */
7309 : 517 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
7310 : : size_var, gfc_get_cfi_desc_elem_len (cfi));
7311 : 517 : tree call = builtin_decl_explicit (BUILT_IN_MALLOC);
7312 : 517 : call = build_call_expr_loc (input_location, call, 1, tmp);
7313 : 517 : gfc_add_modify (&block2, data, fold_convert (TREE_TYPE (data), call));
7314 : :
7315 : : /* Copy the data:
7316 : : for (idx = 0; idx < size; ++idx)
7317 : : {
7318 : : shift = 0;
7319 : : tmpidx = idx
7320 : : for (dim = 0; dim < rank; ++dim)
7321 : : {
7322 : : shift += (tmpidx % extent[d]) * sm[d]
7323 : : tmpidx = tmpidx / extend[d]
7324 : : }
7325 : : memcpy (lhs + idx*elem_len, rhs + shift, elem_len)
7326 : : } .*/
7327 : 517 : idx = gfc_create_var (size_type_node, "arrayidx");
7328 : 517 : gfc_init_block (&loop_body);
7329 : 517 : tree shift = gfc_create_var (size_type_node, "shift");
7330 : 517 : tree tmpidx = gfc_create_var (size_type_node, "tmpidx");
7331 : 517 : gfc_add_modify (&loop_body, shift, build_zero_cst (TREE_TYPE (shift)));
7332 : 517 : gfc_add_modify (&loop_body, tmpidx, idx);
7333 : 517 : stmtblock_t inner_loop;
7334 : 517 : gfc_init_block (&inner_loop);
7335 : 517 : tree dim = gfc_create_var (TREE_TYPE (rank), "dim");
7336 : : /* shift += (tmpidx % extent[d]) * sm[d] */
7337 : 517 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
7338 : : size_type_node, tmpidx,
7339 : : fold_convert (size_type_node,
7340 : : gfc_get_cfi_dim_extent (cfi, dim)));
7341 : 517 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7342 : : size_type_node, tmp,
7343 : : fold_convert (size_type_node,
7344 : : gfc_get_cfi_dim_sm (cfi, dim)));
7345 : 517 : gfc_add_modify (&inner_loop, shift,
7346 : : fold_build2_loc (input_location, PLUS_EXPR,
7347 : : size_type_node, shift, tmp));
7348 : : /* tmpidx = tmpidx / extend[d] */
7349 : 517 : tmp = fold_convert (size_type_node, gfc_get_cfi_dim_extent (cfi, dim));
7350 : 517 : gfc_add_modify (&inner_loop, tmpidx,
7351 : : fold_build2_loc (input_location, TRUNC_DIV_EXPR,
7352 : : size_type_node, tmpidx, tmp));
7353 : 517 : gfc_simple_for_loop (&loop_body, dim, build_zero_cst (TREE_TYPE (rank)),
7354 : 517 : rank, LT_EXPR, build_int_cst (TREE_TYPE (dim), 1),
7355 : : gfc_finish_block (&inner_loop));
7356 : : /* Assign. */
7357 : 517 : tmp = fold_convert (pchar_type_node, gfc_get_cfi_desc_base_addr (cfi));
7358 : 517 : tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift);
7359 : 517 : tree lhs;
7360 : : /* memcpy (lhs + idx*elem_len, rhs + shift, elem_len) */
7361 : 517 : tree elem_len;
7362 : 517 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7363 : 263 : elem_len = gfc_conv_descriptor_elem_len (gfc_desc);
7364 : : else
7365 : 254 : elem_len = gfc_get_cfi_desc_elem_len (cfi);
7366 : 517 : lhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
7367 : : elem_len, idx);
7368 : 517 : lhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pchar_type_node,
7369 : : fold_convert (pchar_type_node, data), lhs);
7370 : 517 : tmp = fold_convert (pvoid_type_node, tmp);
7371 : 517 : lhs = fold_convert (pvoid_type_node, lhs);
7372 : 517 : call = builtin_decl_explicit (BUILT_IN_MEMCPY);
7373 : 517 : call = build_call_expr_loc (input_location, call, 3, lhs, tmp, elem_len);
7374 : 517 : gfc_add_expr_to_block (&loop_body, fold_convert (void_type_node, call));
7375 : 517 : gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
7376 : 517 : size_var, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7377 : : gfc_finish_block (&loop_body));
7378 : : /* if (cond) { block2 } */
7379 : 517 : tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2),
7380 : : build_empty_stmt (input_location));
7381 : 517 : gfc_add_expr_to_block (&block, tmp);
7382 : : }
7383 : :
7384 : 1583 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7385 : : {
7386 : 254 : tree offset, type;
7387 : 254 : type = TREE_TYPE (gfc_desc);
7388 : 254 : gfc_trans_array_bounds (type, sym, &offset, &block);
7389 : 254 : if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7390 : 144 : gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
7391 : 254 : goto done;
7392 : : }
7393 : :
7394 : : /* If cfi->data != NULL. */
7395 : 1329 : stmtblock_t block2;
7396 : 1329 : gfc_init_block (&block2);
7397 : :
7398 : : /* if do_copy_inout: gfc->dspan = gfc->dtype.elem_len
7399 : : We use gfc instead of cfi on the RHS as this might be a constant. */
7400 : 1329 : tmp = fold_convert (gfc_array_index_type,
7401 : : gfc_conv_descriptor_elem_len (gfc_desc));
7402 : 1329 : if (!do_copy_inout)
7403 : : {
7404 : : /* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len)
7405 : : ? cfi->dim[0].sm : gfc->elem_len). */
7406 : 1066 : tree cond;
7407 : 1066 : tree tmp2 = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
7408 : 1066 : cond = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
7409 : : gfc_array_index_type, tmp2, tmp);
7410 : 1066 : cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7411 : : cond, gfc_index_zero_node);
7412 : 1066 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
7413 : : tmp2, tmp);
7414 : : }
7415 : 1329 : gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp);
7416 : :
7417 : : /* Calculate offset + set lbound, ubound and stride. */
7418 : 1329 : gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node);
7419 : 1329 : if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable)
7420 : 1274 : for (int i = 0; i < sym->as->rank; ++i)
7421 : : {
7422 : 718 : gfc_se se;
7423 : 718 : gfc_init_se (&se, NULL );
7424 : 718 : if (sym->as->lower[i])
7425 : : {
7426 : 718 : gfc_conv_expr (&se, sym->as->lower[i]);
7427 : 718 : tmp = se.expr;
7428 : : }
7429 : : else
7430 : 0 : tmp = gfc_index_one_node;
7431 : 718 : gfc_add_block_to_block (&block2, &se.pre);
7432 : 718 : gfc_conv_descriptor_lbound_set (&block2, gfc_desc, gfc_rank_cst[i],
7433 : : tmp);
7434 : 718 : gfc_add_block_to_block (&block2, &se.post);
7435 : : }
7436 : :
7437 : : /* Loop: for (i = 0; i < rank; ++i). */
7438 : 1329 : idx = gfc_create_var (TREE_TYPE (rank), "idx");
7439 : :
7440 : : /* Loop body. */
7441 : 1329 : stmtblock_t loop_body;
7442 : 1329 : gfc_init_block (&loop_body);
7443 : : /* gfc->dim[i].lbound = ... */
7444 : 1329 : if (sym->attr.pointer || sym->attr.allocatable)
7445 : : {
7446 : 276 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
7447 : 276 : gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, tmp);
7448 : : }
7449 : 1053 : else if (sym->as->rank < 0)
7450 : 497 : gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx,
7451 : : gfc_index_one_node);
7452 : :
7453 : : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
7454 : 1329 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7455 : : gfc_conv_descriptor_lbound_get (gfc_desc, idx),
7456 : : gfc_index_one_node);
7457 : 1329 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7458 : : gfc_get_cfi_dim_extent (cfi, idx), tmp);
7459 : 1329 : gfc_conv_descriptor_ubound_set (&loop_body, gfc_desc, idx, tmp);
7460 : :
7461 : 1329 : if (do_copy_inout)
7462 : : {
7463 : : /* gfc->dim[i].stride
7464 : : = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */
7465 : 263 : tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7466 : 263 : idx, build_zero_cst (TREE_TYPE (idx)));
7467 : 263 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
7468 : 263 : idx, build_int_cst (TREE_TYPE (idx), 1));
7469 : 263 : tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp);
7470 : 263 : tmp = gfc_conv_descriptor_stride_get (gfc_desc, tmp);
7471 : 263 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2),
7472 : : tmp2, tmp);
7473 : 263 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
7474 : : gfc_index_one_node, tmp);
7475 : : }
7476 : : else
7477 : : {
7478 : : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
7479 : 1066 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
7480 : 1066 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
7481 : : gfc_array_index_type, tmp,
7482 : : fold_convert (gfc_array_index_type,
7483 : : gfc_get_cfi_desc_elem_len (cfi)));
7484 : : }
7485 : 1329 : gfc_conv_descriptor_stride_set (&loop_body, gfc_desc, idx, tmp);
7486 : : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
7487 : 1329 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7488 : : gfc_conv_descriptor_stride_get (gfc_desc, idx),
7489 : : gfc_conv_descriptor_lbound_get (gfc_desc, idx));
7490 : 1329 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7491 : : gfc_conv_descriptor_offset_get (gfc_desc), tmp);
7492 : 1329 : gfc_conv_descriptor_offset_set (&loop_body, gfc_desc, tmp);
7493 : :
7494 : : /* Generate loop. */
7495 : 1329 : gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
7496 : 1329 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7497 : : gfc_finish_block (&loop_body));
7498 : 1329 : if (sym->attr.allocatable || sym->attr.pointer)
7499 : : {
7500 : 276 : tmp = gfc_get_cfi_desc_base_addr (cfi),
7501 : 276 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7502 : : tmp, null_pointer_node);
7503 : 276 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
7504 : : build_empty_stmt (input_location));
7505 : 276 : gfc_add_expr_to_block (&block, tmp);
7506 : : }
7507 : : else
7508 : 1053 : gfc_add_block_to_block (&block, &block2);
7509 : :
7510 : 1808 : done:
7511 : : /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */
7512 : 1808 : if (sym->attr.optional)
7513 : : {
7514 : 317 : tree present = fold_build2_loc (input_location, NE_EXPR,
7515 : : boolean_type_node, cfi_desc,
7516 : : null_pointer_node);
7517 : 317 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7518 : : sym->backend_decl,
7519 : 317 : fold_convert (TREE_TYPE (sym->backend_decl),
7520 : : null_pointer_node));
7521 : 317 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), tmp);
7522 : 317 : gfc_add_expr_to_block (init, tmp);
7523 : : }
7524 : : else
7525 : 1491 : gfc_add_block_to_block (init, &block);
7526 : :
7527 : 1808 : if (!sym->attr.referenced)
7528 : 973 : return;
7529 : :
7530 : : /* If pointer not changed, nothing to be done (except copy out) */
7531 : 1746 : if (!do_copy_inout && ((!sym->attr.pointer && !sym->attr.allocatable)
7532 : 380 : || sym->attr.intent == INTENT_IN))
7533 : : return;
7534 : :
7535 : 835 : gfc_init_block (&block);
7536 : :
7537 : : /* For bind(C), Fortran does not permit mixing 'pointer' with 'contiguous' (or
7538 : : len=*). Thus, when copy out is needed, the bounds ofthe descriptor remain
7539 : : unchanged. */
7540 : 835 : if (do_copy_inout)
7541 : : {
7542 : 517 : tree data, call;
7543 : 517 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7544 : 263 : data = gfc_conv_descriptor_data_get (gfc_desc);
7545 : 254 : else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc)))
7546 : 0 : data = gfc_build_addr_expr (NULL, gfc_desc);
7547 : : else
7548 : : data = gfc_desc;
7549 : 517 : gfc_init_block (&block2);
7550 : 517 : if (sym->attr.intent != INTENT_IN)
7551 : : {
7552 : : /* First, create the inner copy-out loop.
7553 : : for (idx = 0; idx < size; ++idx)
7554 : : {
7555 : : shift = 0;
7556 : : tmpidx = idx
7557 : : for (dim = 0; dim < rank; ++dim)
7558 : : {
7559 : : shift += (tmpidx % extent[d]) * sm[d]
7560 : : tmpidx = tmpidx / extend[d]
7561 : : }
7562 : : memcpy (lhs + shift, rhs + idx*elem_len, elem_len)
7563 : : } .*/
7564 : 292 : stmtblock_t loop_body;
7565 : 292 : idx = gfc_create_var (size_type_node, "arrayidx");
7566 : 292 : gfc_init_block (&loop_body);
7567 : 292 : tree shift = gfc_create_var (size_type_node, "shift");
7568 : 292 : tree tmpidx = gfc_create_var (size_type_node, "tmpidx");
7569 : 292 : gfc_add_modify (&loop_body, shift,
7570 : 292 : build_zero_cst (TREE_TYPE (shift)));
7571 : 292 : gfc_add_modify (&loop_body, tmpidx, idx);
7572 : 292 : stmtblock_t inner_loop;
7573 : 292 : gfc_init_block (&inner_loop);
7574 : 292 : tree dim = gfc_create_var (TREE_TYPE (rank), "dim");
7575 : : /* shift += (tmpidx % extent[d]) * sm[d] */
7576 : 292 : tmp = fold_convert (size_type_node,
7577 : : gfc_get_cfi_dim_extent (cfi, dim));
7578 : 292 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
7579 : : size_type_node, tmpidx, tmp);
7580 : 292 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7581 : : size_type_node, tmp,
7582 : : fold_convert (size_type_node,
7583 : : gfc_get_cfi_dim_sm (cfi, dim)));
7584 : 292 : gfc_add_modify (&inner_loop, shift,
7585 : : fold_build2_loc (input_location, PLUS_EXPR,
7586 : : size_type_node, shift, tmp));
7587 : : /* tmpidx = tmpidx / extend[d] */
7588 : 292 : tmp = fold_convert (size_type_node,
7589 : : gfc_get_cfi_dim_extent (cfi, dim));
7590 : 292 : gfc_add_modify (&inner_loop, tmpidx,
7591 : : fold_build2_loc (input_location, TRUNC_DIV_EXPR,
7592 : : size_type_node, tmpidx, tmp));
7593 : 584 : gfc_simple_for_loop (&loop_body, dim,
7594 : 292 : build_zero_cst (TREE_TYPE (rank)), rank, LT_EXPR,
7595 : 292 : build_int_cst (TREE_TYPE (dim), 1),
7596 : : gfc_finish_block (&inner_loop));
7597 : : /* Assign. */
7598 : 292 : tree rhs;
7599 : 292 : tmp = fold_convert (pchar_type_node,
7600 : : gfc_get_cfi_desc_base_addr (cfi));
7601 : 292 : tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift);
7602 : : /* memcpy (lhs + shift, rhs + idx*elem_len, elem_len) */
7603 : 292 : tree elem_len;
7604 : 292 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
7605 : 153 : elem_len = gfc_conv_descriptor_elem_len (gfc_desc);
7606 : : else
7607 : 139 : elem_len = gfc_get_cfi_desc_elem_len (cfi);
7608 : 292 : rhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
7609 : : elem_len, idx);
7610 : 292 : rhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
7611 : : pchar_type_node,
7612 : : fold_convert (pchar_type_node, data), rhs);
7613 : 292 : tmp = fold_convert (pvoid_type_node, tmp);
7614 : 292 : rhs = fold_convert (pvoid_type_node, rhs);
7615 : 292 : call = builtin_decl_explicit (BUILT_IN_MEMCPY);
7616 : 292 : call = build_call_expr_loc (input_location, call, 3, tmp, rhs,
7617 : : elem_len);
7618 : 292 : gfc_add_expr_to_block (&loop_body,
7619 : : fold_convert (void_type_node, call));
7620 : 292 : gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
7621 : : size_var, LT_EXPR,
7622 : 292 : build_int_cst (TREE_TYPE (idx), 1),
7623 : : gfc_finish_block (&loop_body));
7624 : : }
7625 : 517 : call = builtin_decl_explicit (BUILT_IN_FREE);
7626 : 517 : call = build_call_expr_loc (input_location, call, 1, data);
7627 : 517 : gfc_add_expr_to_block (&block2, call);
7628 : :
7629 : : /* if (cfi->base_addr != gfc->data) { copy out; free(var) }; return */
7630 : 517 : tree tmp2 = gfc_get_cfi_desc_base_addr (cfi);
7631 : 517 : tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7632 : 517 : tmp2, fold_convert (TREE_TYPE (tmp2), data));
7633 : 517 : tmp = build3_v (COND_EXPR, tmp2, gfc_finish_block (&block2),
7634 : : build_empty_stmt (input_location));
7635 : 517 : gfc_add_expr_to_block (&block, tmp);
7636 : 517 : goto done_finally;
7637 : : }
7638 : :
7639 : : /* Update pointer + array data data on exit. */
7640 : 318 : tmp = gfc_get_cfi_desc_base_addr (cfi);
7641 : 636 : tmp2 = (!sym->attr.dimension
7642 : 318 : ? gfc_desc : gfc_conv_descriptor_data_get (gfc_desc));
7643 : 318 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
7644 : :
7645 : : /* Set string length for len=:, only. */
7646 : 318 : if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
7647 : : {
7648 : 60 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
7649 : 60 : tmp = fold_convert (TREE_TYPE (tmp2), sym->ts.u.cl->backend_decl);
7650 : 60 : if (sym->ts.kind != 1)
7651 : 48 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7652 : 24 : TREE_TYPE (tmp2), tmp,
7653 : 24 : build_int_cst (TREE_TYPE (tmp2), sym->ts.kind));
7654 : 60 : gfc_add_modify (&block, tmp2, tmp);
7655 : : }
7656 : :
7657 : 318 : if (!sym->attr.dimension)
7658 : 102 : goto done_finally;
7659 : :
7660 : 216 : gfc_init_block (&block2);
7661 : :
7662 : : /* Loop: for (i = 0; i < rank; ++i). */
7663 : 216 : idx = gfc_create_var (TREE_TYPE (rank), "idx");
7664 : :
7665 : : /* Loop body. */
7666 : 216 : gfc_init_block (&loop_body);
7667 : : /* cfi->dim[i].lower_bound = gfc->dim[i].lbound */
7668 : 216 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx),
7669 : : gfc_conv_descriptor_lbound_get (gfc_desc, idx));
7670 : : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
7671 : 216 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7672 : : gfc_conv_descriptor_ubound_get (gfc_desc, idx),
7673 : : gfc_conv_descriptor_lbound_get (gfc_desc, idx));
7674 : 216 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp,
7675 : : gfc_index_one_node);
7676 : 216 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
7677 : : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
7678 : 216 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7679 : : gfc_conv_descriptor_stride_get (gfc_desc, idx),
7680 : : gfc_conv_descriptor_span_get (gfc_desc));
7681 : 216 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
7682 : :
7683 : : /* Generate loop. */
7684 : 216 : gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
7685 : 216 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
7686 : : gfc_finish_block (&loop_body));
7687 : : /* if (gfc->data != NULL) { block2 }. */
7688 : 216 : tmp = gfc_get_cfi_desc_base_addr (cfi),
7689 : 216 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7690 : : tmp, null_pointer_node);
7691 : 216 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
7692 : : build_empty_stmt (input_location));
7693 : 216 : gfc_add_expr_to_block (&block, tmp);
7694 : :
7695 : 835 : done_finally:
7696 : : /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */
7697 : 835 : if (sym->attr.optional)
7698 : : {
7699 : 180 : tree present = fold_build2_loc (input_location, NE_EXPR,
7700 : : boolean_type_node, cfi_desc,
7701 : : null_pointer_node);
7702 : 180 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
7703 : : build_empty_stmt (input_location));
7704 : 180 : gfc_add_expr_to_block (finally, tmp);
7705 : : }
7706 : : else
7707 : 655 : gfc_add_block_to_block (finally, &block);
7708 : : }
7709 : :
7710 : : /* Generate code for a function. */
7711 : :
7712 : : void
7713 : 74735 : gfc_generate_function_code (gfc_namespace * ns)
7714 : : {
7715 : 74735 : tree fndecl;
7716 : 74735 : tree old_context;
7717 : 74735 : tree decl;
7718 : 74735 : tree tmp;
7719 : 74735 : tree fpstate = NULL_TREE;
7720 : 74735 : stmtblock_t init, cleanup, outer_block;
7721 : 74735 : stmtblock_t body;
7722 : 74735 : gfc_wrapped_block try_block;
7723 : 74735 : tree recurcheckvar = NULL_TREE;
7724 : 74735 : gfc_symbol *sym;
7725 : 74735 : gfc_symbol *previous_procedure_symbol;
7726 : 74735 : int rank, ieee;
7727 : 74735 : bool is_recursive;
7728 : :
7729 : 74735 : sym = ns->proc_name;
7730 : 74735 : previous_procedure_symbol = current_procedure_symbol;
7731 : 74735 : current_procedure_symbol = sym;
7732 : :
7733 : : /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
7734 : : lost or worse. */
7735 : 74735 : sym->tlink = sym;
7736 : :
7737 : : /* Create the declaration for functions with global scope. */
7738 : 74735 : if (!sym->backend_decl)
7739 : 33702 : gfc_create_function_decl (ns, false);
7740 : :
7741 : 74735 : fndecl = sym->backend_decl;
7742 : 74735 : old_context = current_function_decl;
7743 : :
7744 : 74735 : if (old_context)
7745 : : {
7746 : 17418 : push_function_context ();
7747 : 17418 : saved_parent_function_decls = saved_function_decls;
7748 : 17418 : saved_function_decls = NULL_TREE;
7749 : : }
7750 : :
7751 : 74735 : trans_function_start (sym);
7752 : 74735 : gfc_current_locus = sym->declared_at;
7753 : :
7754 : 74735 : gfc_init_block (&init);
7755 : 74735 : gfc_init_block (&cleanup);
7756 : 74735 : gfc_init_block (&outer_block);
7757 : :
7758 : 74735 : if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
7759 : : {
7760 : : /* Copy length backend_decls to all entry point result
7761 : : symbols. */
7762 : 50 : gfc_entry_list *el;
7763 : 50 : tree backend_decl;
7764 : :
7765 : 50 : gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
7766 : 50 : backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
7767 : 186 : for (el = ns->entries; el; el = el->next)
7768 : 136 : el->sym->result->ts.u.cl->backend_decl = backend_decl;
7769 : : }
7770 : :
7771 : : /* Translate COMMON blocks. */
7772 : 74735 : gfc_trans_common (ns);
7773 : :
7774 : : /* Null the parent fake result declaration if this namespace is
7775 : : a module function or an external procedures. */
7776 : 74735 : if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
7777 : 51865 : || ns->parent == NULL)
7778 : 57317 : parent_fake_result_decl = NULL_TREE;
7779 : :
7780 : : /* For BIND(C):
7781 : : - deallocate intent-out allocatable dummy arguments.
7782 : : - Create GFC variable which will later be populated by convert_CFI_desc */
7783 : 74735 : if (sym->attr.is_bind_c)
7784 : 1878 : for (gfc_formal_arglist *formal = gfc_sym_get_dummy_args (sym);
7785 : 5865 : formal; formal = formal->next)
7786 : : {
7787 : 3987 : gfc_symbol *fsym = formal->sym;
7788 : 3987 : if (!is_CFI_desc (fsym, NULL))
7789 : 2179 : continue;
7790 : 1808 : if (!fsym->attr.referenced)
7791 : : {
7792 : 62 : gfc_conv_cfi_to_gfc (&init, &cleanup, fsym->backend_decl,
7793 : : NULL_TREE, fsym);
7794 : 62 : continue;
7795 : : }
7796 : : /* Let's now create a local GFI descriptor. Afterwards:
7797 : : desc is the local descriptor,
7798 : : desc_p is a pointer to it
7799 : : and stored in sym->backend_decl
7800 : : GFC_DECL_SAVED_DESCRIPTOR (desc_p) contains the CFI descriptor
7801 : : -> PARM_DECL and before sym->backend_decl.
7802 : : For scalars, decl == decl_p is a pointer variable. */
7803 : 1746 : tree desc_p, desc;
7804 : 1746 : location_t loc = gfc_get_location (&sym->declared_at);
7805 : 1746 : if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length)
7806 : 647 : fsym->ts.u.cl->backend_decl = gfc_create_var (gfc_array_index_type,
7807 : : fsym->name);
7808 : 1099 : else if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->backend_decl)
7809 : : {
7810 : 157 : gfc_se se;
7811 : 157 : gfc_init_se (&se, NULL );
7812 : 157 : gfc_conv_expr (&se, fsym->ts.u.cl->length);
7813 : 157 : gfc_add_block_to_block (&init, &se.pre);
7814 : 157 : fsym->ts.u.cl->backend_decl = se.expr;
7815 : 157 : gcc_assert(se.post.head == NULL_TREE);
7816 : : }
7817 : : /* Nullify, otherwise gfc_sym_type will return the CFI type. */
7818 : 1746 : tree tmp = fsym->backend_decl;
7819 : 1746 : fsym->backend_decl = NULL;
7820 : 1746 : tree type = gfc_sym_type (fsym);
7821 : 1746 : gcc_assert (POINTER_TYPE_P (type));
7822 : 1746 : if (POINTER_TYPE_P (TREE_TYPE (type)))
7823 : : /* For instance, allocatable scalars. */
7824 : 104 : type = TREE_TYPE (type);
7825 : 1746 : if (TREE_CODE (type) == REFERENCE_TYPE)
7826 : 1179 : type = build_pointer_type (TREE_TYPE (type));
7827 : 1746 : desc_p = build_decl (loc, VAR_DECL, get_identifier (fsym->name), type);
7828 : 1746 : if (!fsym->attr.dimension)
7829 : : desc = desc_p;
7830 : 1583 : else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc_p))))
7831 : : {
7832 : : /* Character(len=*) explicit-size/assumed-size array. */
7833 : 254 : desc = desc_p;
7834 : 254 : gfc_build_qualified_array (desc, fsym);
7835 : : }
7836 : : else
7837 : : {
7838 : 1329 : tree size = size_in_bytes (TREE_TYPE (TREE_TYPE (desc_p)));
7839 : 1329 : tree call = builtin_decl_explicit (BUILT_IN_ALLOCA);
7840 : 1329 : call = build_call_expr_loc (input_location, call, 1, size);
7841 : 1329 : gfc_add_modify (&outer_block, desc_p,
7842 : 1329 : fold_convert (TREE_TYPE(desc_p), call));
7843 : 1329 : desc = build_fold_indirect_ref_loc (input_location, desc_p);
7844 : : }
7845 : 1746 : pushdecl (desc_p);
7846 : 1746 : if (fsym->attr.optional)
7847 : : {
7848 : 311 : gfc_allocate_lang_decl (desc_p);
7849 : 311 : GFC_DECL_OPTIONAL_ARGUMENT (desc_p) = 1;
7850 : : }
7851 : 1746 : fsym->backend_decl = desc_p;
7852 : 1746 : gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym);
7853 : : }
7854 : :
7855 : 74735 : gfc_generate_contained_functions (ns);
7856 : :
7857 : 74735 : has_coarray_vars = false;
7858 : 74735 : generate_local_vars (ns);
7859 : :
7860 : 74735 : if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
7861 : 141 : generate_coarray_init (ns);
7862 : :
7863 : : /* Keep the parent fake result declaration in module functions
7864 : : or external procedures. */
7865 : 74735 : if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
7866 : 51865 : || ns->parent == NULL)
7867 : 57317 : current_fake_result_decl = parent_fake_result_decl;
7868 : : else
7869 : 17418 : current_fake_result_decl = NULL_TREE;
7870 : :
7871 : 149470 : is_recursive = sym->attr.recursive
7872 : 74735 : || (sym->attr.entry_master
7873 : 632 : && sym->ns->entries->sym->attr.recursive);
7874 : 74735 : if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
7875 : 1005 : && !is_recursive && !flag_recursive && !sym->attr.artificial)
7876 : : {
7877 : 839 : char * msg;
7878 : :
7879 : 839 : msg = xasprintf ("Recursive call to nonrecursive procedure '%s'",
7880 : : sym->name);
7881 : 839 : recurcheckvar = gfc_create_var (logical_type_node, "is_recursive");
7882 : 839 : TREE_STATIC (recurcheckvar) = 1;
7883 : 839 : DECL_INITIAL (recurcheckvar) = logical_false_node;
7884 : 839 : gfc_add_expr_to_block (&init, recurcheckvar);
7885 : 839 : gfc_trans_runtime_check (true, false, recurcheckvar, &init,
7886 : : &sym->declared_at, msg);
7887 : 839 : gfc_add_modify (&init, recurcheckvar, logical_true_node);
7888 : 839 : free (msg);
7889 : : }
7890 : :
7891 : : /* Check if an IEEE module is used in the procedure. If so, save
7892 : : the floating point state. */
7893 : 74735 : ieee = is_ieee_module_used (ns);
7894 : 74735 : if (ieee)
7895 : 388 : fpstate = gfc_save_fp_state (&init);
7896 : :
7897 : : /* Now generate the code for the body of this function. */
7898 : 74735 : gfc_init_block (&body);
7899 : :
7900 : 74735 : if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
7901 : 74735 : && sym->attr.subroutine)
7902 : : {
7903 : 42 : tree alternate_return;
7904 : 42 : alternate_return = gfc_get_fake_result_decl (sym, 0);
7905 : 42 : gfc_add_modify (&body, alternate_return, integer_zero_node);
7906 : : }
7907 : :
7908 : 74735 : if (ns->entries)
7909 : : {
7910 : : /* Jump to the correct entry point. */
7911 : 632 : tmp = gfc_trans_entry_master_switch (ns->entries);
7912 : 632 : gfc_add_expr_to_block (&body, tmp);
7913 : : }
7914 : :
7915 : : /* If bounds-checking is enabled, generate code to check passed in actual
7916 : : arguments against the expected dummy argument attributes (e.g. string
7917 : : lengths). */
7918 : 74735 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
7919 : 2453 : add_argument_checking (&body, sym);
7920 : :
7921 : 74735 : finish_oacc_declare (ns, sym, false);
7922 : :
7923 : 74735 : tmp = gfc_trans_code (ns->code);
7924 : 74735 : gfc_add_expr_to_block (&body, tmp);
7925 : :
7926 : 74735 : if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
7927 : 74735 : || (sym->result && sym->result != sym
7928 : 1060 : && sym->result->ts.type == BT_DERIVED
7929 : 101 : && sym->result->ts.u.derived->attr.alloc_comp))
7930 : : {
7931 : 10864 : bool artificial_result_decl = false;
7932 : 10864 : tree result = get_proc_result (sym);
7933 : 10864 : gfc_symbol *rsym = sym == sym->result ? sym : sym->result;
7934 : :
7935 : : /* Make sure that a function returning an object with
7936 : : alloc/pointer_components always has a result, where at least
7937 : : the allocatable/pointer components are set to zero. */
7938 : 10864 : if (result == NULL_TREE && sym->attr.function
7939 : 272 : && ((sym->result->ts.type == BT_DERIVED
7940 : 72 : && (sym->attr.allocatable
7941 : 72 : || sym->attr.pointer
7942 : 64 : || sym->result->ts.u.derived->attr.alloc_comp
7943 : 64 : || sym->result->ts.u.derived->attr.pointer_comp))
7944 : 246 : || (sym->result->ts.type == BT_CLASS
7945 : 46 : && (CLASS_DATA (sym)->attr.allocatable
7946 : 46 : || CLASS_DATA (sym)->attr.class_pointer
7947 : 0 : || CLASS_DATA (sym->result)->attr.alloc_comp
7948 : 0 : || CLASS_DATA (sym->result)->attr.pointer_comp))))
7949 : : {
7950 : 72 : artificial_result_decl = true;
7951 : 72 : result = gfc_get_fake_result_decl (sym, 0);
7952 : : }
7953 : :
7954 : 10864 : if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
7955 : : {
7956 : 10239 : if (sym->attr.allocatable && sym->attr.dimension == 0
7957 : 76 : && sym->result == sym)
7958 : 51 : gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
7959 : : null_pointer_node));
7960 : 10188 : else if (sym->ts.type == BT_CLASS
7961 : 680 : && CLASS_DATA (sym)->attr.allocatable
7962 : 680 : && CLASS_DATA (sym)->attr.dimension == 0
7963 : 309 : && sym->result == sym)
7964 : : {
7965 : 129 : tmp = gfc_class_data_get (result);
7966 : 129 : gfc_add_modify (&init, tmp,
7967 : 129 : fold_convert (TREE_TYPE (tmp),
7968 : : null_pointer_node));
7969 : 129 : gfc_reset_vptr (&init, nullptr, result,
7970 : 129 : sym->result->ts.u.derived);
7971 : : }
7972 : 10059 : else if (sym->ts.type == BT_DERIVED
7973 : 899 : && !sym->attr.allocatable)
7974 : : {
7975 : 881 : gfc_expr *init_exp;
7976 : : /* Arrays are not initialized using the default initializer of
7977 : : their elements. Therefore only check if a default
7978 : : initializer is available when the result is scalar. */
7979 : 881 : init_exp = rsym->as ? NULL
7980 : 874 : : gfc_generate_initializer (&rsym->ts, true);
7981 : 874 : if (init_exp)
7982 : : {
7983 : 390 : tmp = gfc_trans_structure_assign (result, init_exp, 0);
7984 : 390 : gfc_free_expr (init_exp);
7985 : 390 : gfc_add_expr_to_block (&init, tmp);
7986 : : }
7987 : 491 : else if (rsym->ts.u.derived->attr.alloc_comp)
7988 : : {
7989 : 7 : rank = rsym->as ? rsym->as->rank : 0;
7990 : 7 : tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result,
7991 : : rank);
7992 : 7 : gfc_prepend_expr_to_block (&body, tmp);
7993 : : }
7994 : : }
7995 : : }
7996 : :
7997 : 10864 : if (result == NULL_TREE || artificial_result_decl)
7998 : : {
7999 : : /* TODO: move to the appropriate place in resolve.cc. */
8000 : 272 : if (warn_return_type > 0 && sym == sym->result)
8001 : 40 : gfc_warning (OPT_Wreturn_type,
8002 : : "Return value of function %qs at %L not set",
8003 : : sym->name, &sym->declared_at);
8004 : 272 : if (warn_return_type > 0)
8005 : 45 : suppress_warning (sym->backend_decl);
8006 : : }
8007 : 272 : if (result != NULL_TREE)
8008 : 10664 : gfc_add_expr_to_block (&body, gfc_generate_return ());
8009 : : }
8010 : :
8011 : : /* Reset recursion-check variable. */
8012 : 74735 : if (recurcheckvar != NULL_TREE)
8013 : : {
8014 : 839 : gfc_add_modify (&cleanup, recurcheckvar, logical_false_node);
8015 : 839 : recurcheckvar = NULL;
8016 : : }
8017 : :
8018 : : /* If IEEE modules are loaded, restore the floating-point state. */
8019 : 74735 : if (ieee)
8020 : 388 : gfc_restore_fp_state (&cleanup, fpstate);
8021 : :
8022 : : /* Finish the function body and add init and cleanup code. */
8023 : 74735 : tmp = gfc_finish_block (&body);
8024 : : /* Add code to create and cleanup arrays. */
8025 : 74735 : gfc_start_wrapped_block (&try_block, tmp);
8026 : 74735 : gfc_trans_deferred_vars (sym, &try_block);
8027 : 74735 : gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
8028 : : gfc_finish_block (&cleanup));
8029 : :
8030 : : /* Add all the decls we created during processing. */
8031 : 74735 : decl = nreverse (saved_function_decls);
8032 : 409719 : while (decl)
8033 : : {
8034 : 260249 : tree next;
8035 : :
8036 : 260249 : next = DECL_CHAIN (decl);
8037 : 260249 : DECL_CHAIN (decl) = NULL_TREE;
8038 : 260249 : pushdecl (decl);
8039 : 260249 : decl = next;
8040 : : }
8041 : 74735 : saved_function_decls = NULL_TREE;
8042 : :
8043 : 74735 : gfc_add_expr_to_block (&outer_block, gfc_finish_wrapped_block (&try_block));
8044 : 74735 : DECL_SAVED_TREE (fndecl) = gfc_finish_block (&outer_block);
8045 : 74735 : decl = getdecls ();
8046 : :
8047 : : /* Finish off this function and send it for code generation. */
8048 : 74735 : poplevel (1, 1);
8049 : 74735 : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
8050 : :
8051 : 149470 : DECL_SAVED_TREE (fndecl)
8052 : 149470 : = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node,
8053 : 149470 : decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl));
8054 : :
8055 : : /* Output the GENERIC tree. */
8056 : 74735 : dump_function (TDI_original, fndecl);
8057 : :
8058 : : /* Store the end of the function, so that we get good line number
8059 : : info for the epilogue. */
8060 : 74735 : cfun->function_end_locus = input_location;
8061 : :
8062 : : /* We're leaving the context of this function, so zap cfun.
8063 : : It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
8064 : : tree_rest_of_compilation. */
8065 : 74735 : set_cfun (NULL);
8066 : :
8067 : 74735 : if (old_context)
8068 : : {
8069 : 17418 : pop_function_context ();
8070 : 17418 : saved_function_decls = saved_parent_function_decls;
8071 : : }
8072 : 74735 : current_function_decl = old_context;
8073 : :
8074 : 74735 : if (decl_function_context (fndecl))
8075 : : {
8076 : : /* Register this function with cgraph just far enough to get it
8077 : : added to our parent's nested function list.
8078 : : If there are static coarrays in this function, the nested _caf_init
8079 : : function has already called cgraph_create_node, which also created
8080 : : the cgraph node for this function. */
8081 : 17418 : if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB)
8082 : 17408 : (void) cgraph_node::get_create (fndecl);
8083 : : }
8084 : : else
8085 : 57317 : cgraph_node::finalize_function (fndecl, true);
8086 : :
8087 : 74735 : gfc_trans_use_stmts (ns);
8088 : 74735 : gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
8089 : :
8090 : 74735 : if (sym->attr.is_main_program)
8091 : 24870 : create_main_function (fndecl);
8092 : :
8093 : 74735 : current_procedure_symbol = previous_procedure_symbol;
8094 : 74735 : }
8095 : :
8096 : :
8097 : : void
8098 : 29864 : gfc_generate_constructors (void)
8099 : : {
8100 : 29864 : gcc_assert (gfc_static_ctors == NULL_TREE);
8101 : : #if 0
8102 : : tree fnname;
8103 : : tree type;
8104 : : tree fndecl;
8105 : : tree decl;
8106 : : tree tmp;
8107 : :
8108 : : if (gfc_static_ctors == NULL_TREE)
8109 : : return;
8110 : :
8111 : : fnname = get_file_function_name ("I");
8112 : : type = build_function_type_list (void_type_node, NULL_TREE);
8113 : :
8114 : : fndecl = build_decl (input_location,
8115 : : FUNCTION_DECL, fnname, type);
8116 : : TREE_PUBLIC (fndecl) = 1;
8117 : :
8118 : : decl = build_decl (input_location,
8119 : : RESULT_DECL, NULL_TREE, void_type_node);
8120 : : DECL_ARTIFICIAL (decl) = 1;
8121 : : DECL_IGNORED_P (decl) = 1;
8122 : : DECL_CONTEXT (decl) = fndecl;
8123 : : DECL_RESULT (fndecl) = decl;
8124 : :
8125 : : pushdecl (fndecl);
8126 : :
8127 : : current_function_decl = fndecl;
8128 : :
8129 : : rest_of_decl_compilation (fndecl, 1, 0);
8130 : :
8131 : : make_decl_rtl (fndecl);
8132 : :
8133 : : allocate_struct_function (fndecl, false);
8134 : :
8135 : : pushlevel ();
8136 : :
8137 : : for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
8138 : : {
8139 : : tmp = build_call_expr_loc (input_location,
8140 : : TREE_VALUE (gfc_static_ctors), 0);
8141 : : DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
8142 : : }
8143 : :
8144 : : decl = getdecls ();
8145 : : poplevel (1, 1);
8146 : :
8147 : : BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
8148 : : DECL_SAVED_TREE (fndecl)
8149 : : = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
8150 : : DECL_INITIAL (fndecl));
8151 : :
8152 : : free_after_parsing (cfun);
8153 : : free_after_compilation (cfun);
8154 : :
8155 : : tree_rest_of_compilation (fndecl);
8156 : :
8157 : : current_function_decl = NULL_TREE;
8158 : : #endif
8159 : 29864 : }
8160 : :
8161 : : /* Translates a BLOCK DATA program unit. This means emitting the
8162 : : commons contained therein plus their initializations. We also emit
8163 : : a globally visible symbol to make sure that each BLOCK DATA program
8164 : : unit remains unique. */
8165 : :
8166 : : void
8167 : 71 : gfc_generate_block_data (gfc_namespace * ns)
8168 : : {
8169 : 71 : tree decl;
8170 : 71 : tree id;
8171 : :
8172 : : /* Tell the backend the source location of the block data. */
8173 : 71 : if (ns->proc_name)
8174 : 28 : gfc_set_backend_locus (&ns->proc_name->declared_at);
8175 : : else
8176 : 43 : gfc_set_backend_locus (&gfc_current_locus);
8177 : :
8178 : : /* Process the DATA statements. */
8179 : 71 : gfc_trans_common (ns);
8180 : :
8181 : : /* Create a global symbol with the mane of the block data. This is to
8182 : : generate linker errors if the same name is used twice. It is never
8183 : : really used. */
8184 : 71 : if (ns->proc_name)
8185 : 28 : id = gfc_sym_mangled_function_id (ns->proc_name);
8186 : : else
8187 : 43 : id = get_identifier ("__BLOCK_DATA__");
8188 : :
8189 : 71 : decl = build_decl (input_location,
8190 : : VAR_DECL, id, gfc_array_index_type);
8191 : 71 : TREE_PUBLIC (decl) = 1;
8192 : 71 : TREE_STATIC (decl) = 1;
8193 : 71 : DECL_IGNORED_P (decl) = 1;
8194 : :
8195 : 71 : pushdecl (decl);
8196 : 71 : rest_of_decl_compilation (decl, 1, 0);
8197 : 71 : }
8198 : :
8199 : :
8200 : : /* Process the local variables of a BLOCK construct. */
8201 : :
8202 : : void
8203 : 12890 : gfc_process_block_locals (gfc_namespace* ns)
8204 : : {
8205 : 12890 : tree decl;
8206 : :
8207 : 12890 : saved_local_decls = NULL_TREE;
8208 : 12890 : has_coarray_vars = false;
8209 : :
8210 : 12890 : generate_local_vars (ns);
8211 : :
8212 : 12890 : if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
8213 : 26 : generate_coarray_init (ns);
8214 : :
8215 : 12890 : decl = nreverse (saved_local_decls);
8216 : 37800 : while (decl)
8217 : : {
8218 : 12020 : tree next;
8219 : :
8220 : 12020 : next = DECL_CHAIN (decl);
8221 : 12020 : DECL_CHAIN (decl) = NULL_TREE;
8222 : 12020 : pushdecl (decl);
8223 : 12020 : decl = next;
8224 : : }
8225 : 12890 : saved_local_decls = NULL_TREE;
8226 : 12890 : }
8227 : :
8228 : :
8229 : : #include "gt-fortran-trans-decl.h"
|
