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