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