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