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