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