]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/trans-decl.c
projects / thirdparty / gcc.git / blob
? search:


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