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