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