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