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