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