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