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