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