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