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