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