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