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