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