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