]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/trans-decl.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
2011-05-04 Richard Guenther <rguenther@suse.de>
[thirdparty/gcc.git] / gcc / fortran / trans-decl.c
CommitLineData
4ee9c684 1/* Backend function setup
617125a6 2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
3 2011
cfaf579d 4 Free Software Foundation, Inc.
4ee9c684 5 Contributed by Paul Brook
6
c84b470d 7This file is part of GCC.
4ee9c684 8
c84b470d 9GCC is free software; you can redistribute it and/or modify it under
10the terms of the GNU General Public License as published by the Free
bdabe786 11Software Foundation; either version 3, or (at your option) any later
c84b470d 12version.
4ee9c684 13
c84b470d 14GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15WARRANTY; without even the implied warranty of MERCHANTABILITY or
16FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17for more details.
4ee9c684 18
19You should have received a copy of the GNU General Public License
bdabe786 20along with GCC; see the file COPYING3. If not see
21<http://www.gnu.org/licenses/>. */
4ee9c684 22
23/* trans-decl.c -- Handling of backend function and variable decls, etc */
24
25#include "config.h"
26#include "system.h"
27#include "coretypes.h"
cb4070e0 28#include "tm.h"
4ee9c684 29#include "tree.h"
30#include "tree-dump.h"
989adef3 31#include "gimple.h" /* For create_tmp_var_raw. */
4ee9c684 32#include "ggc.h"
7cbc820e 33#include "diagnostic-core.h" /* For internal_error. */
34#include "toplev.h" /* For announce_function. */
cb4070e0 35#include "output.h" /* For decl_default_tls_model. */
4ee9c684 36#include "target.h"
37#include "function.h"
4ee9c684 38#include "flags.h"
39#include "cgraph.h"
df4d540f 40#include "debug.h"
4ee9c684 41#include "gfortran.h"
9579733e 42#include "pointer-set.h"
126387b5 43#include "constructor.h"
4ee9c684 44#include "trans.h"
45#include "trans-types.h"
46#include "trans-array.h"
47#include "trans-const.h"
48/* Only for gfc_trans_code. Shouldn't need to include this. */
49#include "trans-stmt.h"
50
51#define MAX_LABEL_VALUE 99999
52
53
54/* Holds the result of the function if no result variable specified. */
55
56static GTY(()) tree current_fake_result_decl;
c750cc52 57static GTY(()) tree parent_fake_result_decl;
4ee9c684 58
4ee9c684 59
60/* Holds the variable DECLs for the current function. */
61
d4163395 62static GTY(()) tree saved_function_decls;
63static GTY(()) tree saved_parent_function_decls;
4ee9c684 64
9579733e 65static struct pointer_set_t *nonlocal_dummy_decl_pset;
66static GTY(()) tree nonlocal_dummy_decls;
4ee9c684 67
6a7084d7 68/* Holds the variable DECLs that are locals. */
69
70static GTY(()) tree saved_local_decls;
71
4ee9c684 72/* The namespace of the module we're currently generating. Only used while
73 outputting decls for module variables. Do not rely on this being set. */
74
75static gfc_namespace *module_namespace;
76
89ac8ba1 77/* The currently processed procedure symbol. */
78static gfc_symbol* current_procedure_symbol = NULL;
79
4ee9c684 80
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
2119 /* Even though we're inside a function body, we still don't want to
2120 call expand_expr to calculate the size of a variable-sized array.
2121 We haven't necessarily assigned RTL to all variables yet, so it's
2122 not safe to try to expand expressions involving them. */
18d50ae6 2123 cfun->dont_save_pending_sizes_p = 1;
1b716045 2124
f888a3fb 2125 /* function.c requires a push at the start of the function. */
1b716045 2126 pushlevel (0);
2127}
2128
2129/* Create thunks for alternate entry points. */
2130
2131static void
d896f9b3 2132build_entry_thunks (gfc_namespace * ns, bool global)
1b716045 2133{
2134 gfc_formal_arglist *formal;
2135 gfc_formal_arglist *thunk_formal;
2136 gfc_entry_list *el;
2137 gfc_symbol *thunk_sym;
2138 stmtblock_t body;
2139 tree thunk_fndecl;
1b716045 2140 tree tmp;
b31f705b 2141 locus old_loc;
1b716045 2142
2143 /* This should always be a toplevel function. */
22d678e8 2144 gcc_assert (current_function_decl == NULL_TREE);
1b716045 2145
4671339c 2146 gfc_save_backend_locus (&old_loc);
1b716045 2147 for (el = ns->entries; el; el = el->next)
2148 {
414c3a2c 2149 VEC(tree,gc) *args = NULL;
2150 VEC(tree,gc) *string_args = NULL;
2151
1b716045 2152 thunk_sym = el->sym;
2153
d896f9b3 2154 build_function_decl (thunk_sym, global);
1b716045 2155 create_function_arglist (thunk_sym);
2156
2157 trans_function_start (thunk_sym);
2158
2159 thunk_fndecl = thunk_sym->backend_decl;
2160
e5004242 2161 gfc_init_block (&body);
1b716045 2162
f888a3fb 2163 /* Pass extra parameter identifying this entry point. */
7016c612 2164 tmp = build_int_cst (gfc_array_index_type, el->id);
414c3a2c 2165 VEC_safe_push (tree, gc, args, tmp);
1b716045 2166
c6871095 2167 if (thunk_sym->attr.function)
2168 {
2169 if (gfc_return_by_reference (ns->proc_name))
2170 {
2171 tree ref = DECL_ARGUMENTS (current_function_decl);
414c3a2c 2172 VEC_safe_push (tree, gc, args, ref);
c6871095 2173 if (ns->proc_name->ts.type == BT_CHARACTER)
1767a056 2174 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
c6871095 2175 }
2176 }
2177
1b716045 2178 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2179 {
c6871095 2180 /* Ignore alternate returns. */
2181 if (formal->sym == NULL)
2182 continue;
2183
1b716045 2184 /* We don't have a clever way of identifying arguments, so resort to
2185 a brute-force search. */
2186 for (thunk_formal = thunk_sym->formal;
2187 thunk_formal;
2188 thunk_formal = thunk_formal->next)
2189 {
2190 if (thunk_formal->sym == formal->sym)
2191 break;
2192 }
2193
2194 if (thunk_formal)
2195 {
2196 /* Pass the argument. */
d95efb59 2197 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
414c3a2c 2198 VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
1b716045 2199 if (formal->sym->ts.type == BT_CHARACTER)
2200 {
eeebe20b 2201 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
414c3a2c 2202 VEC_safe_push (tree, gc, string_args, tmp);
1b716045 2203 }
2204 }
2205 else
2206 {
2207 /* Pass NULL for a missing argument. */
414c3a2c 2208 VEC_safe_push (tree, gc, args, null_pointer_node);
1b716045 2209 if (formal->sym->ts.type == BT_CHARACTER)
2210 {
7d3075f6 2211 tmp = build_int_cst (gfc_charlen_type_node, 0);
414c3a2c 2212 VEC_safe_push (tree, gc, string_args, tmp);
1b716045 2213 }
2214 }
2215 }
2216
2217 /* Call the master function. */
414c3a2c 2218 VEC_safe_splice (tree, gc, args, string_args);
1b716045 2219 tmp = ns->proc_name->backend_decl;
414c3a2c 2220 tmp = build_call_expr_loc_vec (input_location, tmp, args);
c6871095 2221 if (ns->proc_name->attr.mixed_entry_master)
2222 {
2223 tree union_decl, field;
2224 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2225
e60a6f7b 2226 union_decl = build_decl (input_location,
2227 VAR_DECL, get_identifier ("__result"),
c6871095 2228 TREE_TYPE (master_type));
2229 DECL_ARTIFICIAL (union_decl) = 1;
2230 DECL_EXTERNAL (union_decl) = 0;
2231 TREE_PUBLIC (union_decl) = 0;
2232 TREE_USED (union_decl) = 1;
2233 layout_decl (union_decl, 0);
2234 pushdecl (union_decl);
2235
2236 DECL_CONTEXT (union_decl) = current_function_decl;
fd779e1d 2237 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2238 TREE_TYPE (union_decl), union_decl, tmp);
c6871095 2239 gfc_add_expr_to_block (&body, tmp);
2240
2241 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1767a056 2242 field; field = DECL_CHAIN (field))
c6871095 2243 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2244 thunk_sym->result->name) == 0)
2245 break;
2246 gcc_assert (field != NULL_TREE);
fd779e1d 2247 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2248 TREE_TYPE (field), union_decl, field,
2249 NULL_TREE);
2250 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
f75d6b8a 2251 TREE_TYPE (DECL_RESULT (current_function_decl)),
2252 DECL_RESULT (current_function_decl), tmp);
c6871095 2253 tmp = build1_v (RETURN_EXPR, tmp);
2254 }
2255 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2256 != void_type_node)
2257 {
fd779e1d 2258 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
f75d6b8a 2259 TREE_TYPE (DECL_RESULT (current_function_decl)),
2260 DECL_RESULT (current_function_decl), tmp);
c6871095 2261 tmp = build1_v (RETURN_EXPR, tmp);
2262 }
1b716045 2263 gfc_add_expr_to_block (&body, tmp);
2264
2265 /* Finish off this function and send it for code generation. */
2266 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
e5004242 2267 tmp = getdecls ();
1b716045 2268 poplevel (1, 0, 1);
2269 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
e5004242 2270 DECL_SAVED_TREE (thunk_fndecl)
2271 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2272 DECL_INITIAL (thunk_fndecl));
1b716045 2273
2274 /* Output the GENERIC tree. */
2275 dump_function (TDI_original, thunk_fndecl);
2276
2277 /* Store the end of the function, so that we get good line number
2278 info for the epilogue. */
2279 cfun->function_end_locus = input_location;
2280
2281 /* We're leaving the context of this function, so zap cfun.
2282 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2283 tree_rest_of_compilation. */
87d4aa85 2284 set_cfun (NULL);
1b716045 2285
2286 current_function_decl = NULL_TREE;
2287
bb982f66 2288 cgraph_finalize_function (thunk_fndecl, true);
1b716045 2289
2290 /* We share the symbols in the formal argument list with other entry
2291 points and the master function. Clear them so that they are
2292 recreated for each function. */
2293 for (formal = thunk_sym->formal; formal; formal = formal->next)
c6871095 2294 if (formal->sym != NULL) /* Ignore alternate returns. */
2295 {
2296 formal->sym->backend_decl = NULL_TREE;
2297 if (formal->sym->ts.type == BT_CHARACTER)
eeebe20b 2298 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
c6871095 2299 }
2300
2301 if (thunk_sym->attr.function)
1b716045 2302 {
c6871095 2303 if (thunk_sym->ts.type == BT_CHARACTER)
eeebe20b 2304 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
c6871095 2305 if (thunk_sym->result->ts.type == BT_CHARACTER)
eeebe20b 2306 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
1b716045 2307 }
2308 }
b31f705b 2309
4671339c 2310 gfc_restore_backend_locus (&old_loc);
1b716045 2311}
2312
2313
2314/* Create a decl for a function, and create any thunks for alternate entry
d896f9b3 2315 points. If global is true, generate the function in the global binding
2316 level, otherwise in the current binding level (which can be global). */
1b716045 2317
2318void
d896f9b3 2319gfc_create_function_decl (gfc_namespace * ns, bool global)
1b716045 2320{
2321 /* Create a declaration for the master function. */
d896f9b3 2322 build_function_decl (ns->proc_name, global);
1b716045 2323
f888a3fb 2324 /* Compile the entry thunks. */
1b716045 2325 if (ns->entries)
d896f9b3 2326 build_entry_thunks (ns, global);
1b716045 2327
2328 /* Now create the read argument list. */
2329 create_function_arglist (ns->proc_name);
2330}
2331
c750cc52 2332/* Return the decl used to hold the function return value. If
3350e716 2333 parent_flag is set, the context is the parent_scope. */
4ee9c684 2334
2335tree
c750cc52 2336gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
4ee9c684 2337{
c750cc52 2338 tree decl;
2339 tree length;
2340 tree this_fake_result_decl;
2341 tree this_function_decl;
4ee9c684 2342
2343 char name[GFC_MAX_SYMBOL_LEN + 10];
2344
c750cc52 2345 if (parent_flag)
2346 {
2347 this_fake_result_decl = parent_fake_result_decl;
2348 this_function_decl = DECL_CONTEXT (current_function_decl);
2349 }
2350 else
2351 {
2352 this_fake_result_decl = current_fake_result_decl;
2353 this_function_decl = current_function_decl;
2354 }
2355
c6871095 2356 if (sym
c750cc52 2357 && sym->ns->proc_name->backend_decl == this_function_decl
d4163395 2358 && sym->ns->proc_name->attr.entry_master
c6871095 2359 && sym != sym->ns->proc_name)
2360 {
d4163395 2361 tree t = NULL, var;
c750cc52 2362 if (this_fake_result_decl != NULL)
2363 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
d4163395 2364 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2365 break;
2366 if (t)
2367 return TREE_VALUE (t);
c750cc52 2368 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2369
2370 if (parent_flag)
2371 this_fake_result_decl = parent_fake_result_decl;
2372 else
2373 this_fake_result_decl = current_fake_result_decl;
2374
d4163395 2375 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
c6871095 2376 {
2377 tree field;
2378
2379 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1767a056 2380 field; field = DECL_CHAIN (field))
c6871095 2381 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2382 sym->name) == 0)
2383 break;
2384
2385 gcc_assert (field != NULL_TREE);
fd779e1d 2386 decl = fold_build3_loc (input_location, COMPONENT_REF,
2387 TREE_TYPE (field), decl, field, NULL_TREE);
c6871095 2388 }
c750cc52 2389
2390 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2391 if (parent_flag)
2392 gfc_add_decl_to_parent_function (var);
2393 else
2394 gfc_add_decl_to_function (var);
2395
d4163395 2396 SET_DECL_VALUE_EXPR (var, decl);
2397 DECL_HAS_VALUE_EXPR_P (var) = 1;
2cf330c4 2398 GFC_DECL_RESULT (var) = 1;
c750cc52 2399
2400 TREE_CHAIN (this_fake_result_decl)
2401 = tree_cons (get_identifier (sym->name), var,
2402 TREE_CHAIN (this_fake_result_decl));
d4163395 2403 return var;
c6871095 2404 }
2405
c750cc52 2406 if (this_fake_result_decl != NULL_TREE)
2407 return TREE_VALUE (this_fake_result_decl);
4ee9c684 2408
2409 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2410 sym is NULL. */
2411 if (!sym)
2412 return NULL_TREE;
2413
d4163395 2414 if (sym->ts.type == BT_CHARACTER)
4ee9c684 2415 {
eeebe20b 2416 if (sym->ts.u.cl->backend_decl == NULL_TREE)
d4163395 2417 length = gfc_create_string_length (sym);
2418 else
eeebe20b 2419 length = sym->ts.u.cl->backend_decl;
d4163395 2420 if (TREE_CODE (length) == VAR_DECL
2421 && DECL_CONTEXT (length) == NULL_TREE)
99042714 2422 gfc_add_decl_to_function (length);
4ee9c684 2423 }
2424
2425 if (gfc_return_by_reference (sym))
2426 {
c750cc52 2427 decl = DECL_ARGUMENTS (this_function_decl);
c6871095 2428
c750cc52 2429 if (sym->ns->proc_name->backend_decl == this_function_decl
c6871095 2430 && sym->ns->proc_name->attr.entry_master)
1767a056 2431 decl = DECL_CHAIN (decl);
4ee9c684 2432
2433 TREE_USED (decl) = 1;
2434 if (sym->as)
2435 decl = gfc_build_dummy_array_decl (sym, decl);
2436 }
2437 else
2438 {
2439 sprintf (name, "__result_%.20s",
c750cc52 2440 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
4ee9c684 2441
3350e716 2442 if (!sym->attr.mixed_entry_master && sym->attr.function)
1e71b314 2443 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
e60a6f7b 2444 VAR_DECL, get_identifier (name),
3350e716 2445 gfc_sym_type (sym));
2446 else
1e71b314 2447 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
e60a6f7b 2448 VAR_DECL, get_identifier (name),
3350e716 2449 TREE_TYPE (TREE_TYPE (this_function_decl)));
4ee9c684 2450 DECL_ARTIFICIAL (decl) = 1;
2451 DECL_EXTERNAL (decl) = 0;
2452 TREE_PUBLIC (decl) = 0;
2453 TREE_USED (decl) = 1;
764f1175 2454 GFC_DECL_RESULT (decl) = 1;
a379e3a9 2455 TREE_ADDRESSABLE (decl) = 1;
4ee9c684 2456
2457 layout_decl (decl, 0);
2458
c750cc52 2459 if (parent_flag)
2460 gfc_add_decl_to_parent_function (decl);
2461 else
2462 gfc_add_decl_to_function (decl);
4ee9c684 2463 }
2464
c750cc52 2465 if (parent_flag)
2466 parent_fake_result_decl = build_tree_list (NULL, decl);
2467 else
2468 current_fake_result_decl = build_tree_list (NULL, decl);
4ee9c684 2469
2470 return decl;
2471}
2472
2473
2474/* Builds a function decl. The remaining parameters are the types of the
2475 function arguments. Negative nargs indicates a varargs function. */
2476
8ce86007 2477static tree
2478build_library_function_decl_1 (tree name, const char *spec,
2479 tree rettype, int nargs, va_list p)
4ee9c684 2480{
2481 tree arglist;
2482 tree argtype;
2483 tree fntype;
2484 tree fndecl;
4ee9c684 2485 int n;
2486
2487 /* Library functions must be declared with global scope. */
22d678e8 2488 gcc_assert (current_function_decl == NULL_TREE);
4ee9c684 2489
4ee9c684 2490 /* Create a list of the argument types. */
2491 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2492 {
2493 argtype = va_arg (p, tree);
2494 arglist = gfc_chainon_list (arglist, argtype);
2495 }
2496
2497 if (nargs >= 0)
2498 {
2499 /* Terminate the list. */
571704e8 2500 arglist = chainon (arglist, void_list_node);
4ee9c684 2501 }
2502
2503 /* Build the function type and decl. */
2504 fntype = build_function_type (rettype, arglist);
8ce86007 2505 if (spec)
2506 {
2507 tree attr_args = build_tree_list (NULL_TREE,
2508 build_string (strlen (spec), spec));
2509 tree attrs = tree_cons (get_identifier ("fn spec"),
2510 attr_args, TYPE_ATTRIBUTES (fntype));
2511 fntype = build_type_attribute_variant (fntype, attrs);
2512 }
e60a6f7b 2513 fndecl = build_decl (input_location,
2514 FUNCTION_DECL, name, fntype);
4ee9c684 2515
2516 /* Mark this decl as external. */
2517 DECL_EXTERNAL (fndecl) = 1;
2518 TREE_PUBLIC (fndecl) = 1;
2519
4ee9c684 2520 pushdecl (fndecl);
2521
b2c4af5e 2522 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 2523
2524 return fndecl;
2525}
2526
8ce86007 2527/* Builds a function decl. The remaining parameters are the types of the
2528 function arguments. Negative nargs indicates a varargs function. */
2529
2530tree
2531gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2532{
2533 tree ret;
2534 va_list args;
2535 va_start (args, nargs);
2536 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2537 va_end (args);
2538 return ret;
2539}
2540
2541/* Builds a function decl. The remaining parameters are the types of the
2542 function arguments. Negative nargs indicates a varargs function.
2543 The SPEC parameter specifies the function argument and return type
2544 specification according to the fnspec function type attribute. */
2545
4bf69bc3 2546tree
8ce86007 2547gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2548 tree rettype, int nargs, ...)
2549{
2550 tree ret;
2551 va_list args;
2552 va_start (args, nargs);
2553 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2554 va_end (args);
2555 return ret;
2556}
2557
4ee9c684 2558static void
2559gfc_build_intrinsic_function_decls (void)
2560{
90ba9145 2561 tree gfc_int4_type_node = gfc_get_int_type (4);
2562 tree gfc_int8_type_node = gfc_get_int_type (8);
920e54ef 2563 tree gfc_int16_type_node = gfc_get_int_type (16);
90ba9145 2564 tree gfc_logical4_type_node = gfc_get_logical_type (4);
40b806de 2565 tree pchar1_type_node = gfc_get_pchar_type (1);
2566 tree pchar4_type_node = gfc_get_pchar_type (4);
90ba9145 2567
4ee9c684 2568 /* String functions. */
241ecdc7 2569 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2570 get_identifier (PREFIX("compare_string")), "..R.R",
2571 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2572 gfc_charlen_type_node, pchar1_type_node);
537824d1 2573 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
bc351485 2574 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
241ecdc7 2575
2576 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2577 get_identifier (PREFIX("concat_string")), "..W.R.R",
2578 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2579 gfc_charlen_type_node, pchar1_type_node,
2580 gfc_charlen_type_node, pchar1_type_node);
bc351485 2581 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
241ecdc7 2582
2583 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2584 get_identifier (PREFIX("string_len_trim")), "..R",
2585 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
537824d1 2586 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
bc351485 2587 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
241ecdc7 2588
2589 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2590 get_identifier (PREFIX("string_index")), "..R.R.",
2591 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2592 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
537824d1 2593 DECL_PURE_P (gfor_fndecl_string_index) = 1;
bc351485 2594 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
241ecdc7 2595
2596 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2597 get_identifier (PREFIX("string_scan")), "..R.R.",
2598 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2599 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
537824d1 2600 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
bc351485 2601 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
241ecdc7 2602
2603 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2604 get_identifier (PREFIX("string_verify")), "..R.R.",
2605 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2606 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
537824d1 2607 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
bc351485 2608 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
241ecdc7 2609
2610 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2611 get_identifier (PREFIX("string_trim")), ".Ww.R",
2612 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2613 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2614 pchar1_type_node);
2615
2616 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2617 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2618 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2619 build_pointer_type (pchar1_type_node), integer_type_node,
2620 integer_type_node);
2621
2622 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2623 get_identifier (PREFIX("adjustl")), ".W.R",
2624 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2625 pchar1_type_node);
bc351485 2626 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
241ecdc7 2627
2628 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2629 get_identifier (PREFIX("adjustr")), ".W.R",
2630 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2631 pchar1_type_node);
bc351485 2632 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
241ecdc7 2633
2634 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2635 get_identifier (PREFIX("select_string")), ".R.R.",
2636 integer_type_node, 4, pvoid_type_node, integer_type_node,
2637 pchar1_type_node, gfc_charlen_type_node);
537824d1 2638 DECL_PURE_P (gfor_fndecl_select_string) = 1;
bc351485 2639 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
241ecdc7 2640
2641 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2642 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2643 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2644 gfc_charlen_type_node, pchar4_type_node);
537824d1 2645 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
bc351485 2646 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
241ecdc7 2647
2648 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2649 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2650 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2651 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2652 pchar4_type_node);
bc351485 2653 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
241ecdc7 2654
2655 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2656 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2657 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
537824d1 2658 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
bc351485 2659 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
241ecdc7 2660
2661 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2662 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2663 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2664 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
537824d1 2665 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
bc351485 2666 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
241ecdc7 2667
2668 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2669 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2670 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2671 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
537824d1 2672 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
bc351485 2673 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
241ecdc7 2674
2675 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2676 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2677 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2678 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
537824d1 2679 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
bc351485 2680 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
241ecdc7 2681
2682 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2683 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2684 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2685 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2686 pchar4_type_node);
2687
2688 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2689 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2690 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2691 build_pointer_type (pchar4_type_node), integer_type_node,
2692 integer_type_node);
2693
2694 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2695 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2696 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2697 pchar4_type_node);
bc351485 2698 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
241ecdc7 2699
2700 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2701 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2702 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2703 pchar4_type_node);
bc351485 2704 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
241ecdc7 2705
2706 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2707 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2708 integer_type_node, 4, pvoid_type_node, integer_type_node,
2709 pvoid_type_node, gfc_charlen_type_node);
537824d1 2710 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
bc351485 2711 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
b44437b9 2712
2713
2714 /* Conversion between character kinds. */
2715
241ecdc7 2716 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2717 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2718 void_type_node, 3, build_pointer_type (pchar4_type_node),
2719 gfc_charlen_type_node, pchar1_type_node);
b44437b9 2720
241ecdc7 2721 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2722 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2723 void_type_node, 3, build_pointer_type (pchar1_type_node),
2724 gfc_charlen_type_node, pchar4_type_node);
b44437b9 2725
40b806de 2726 /* Misc. functions. */
5fcc6ec2 2727
241ecdc7 2728 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2729 get_identifier (PREFIX("ttynam")), ".W",
2730 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2731 integer_type_node);
2732
2733 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2734 get_identifier (PREFIX("fdate")), ".W",
2735 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2736
2737 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2738 get_identifier (PREFIX("ctime")), ".W",
2739 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2740 gfc_int8_type_node);
2741
2742 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2743 get_identifier (PREFIX("selected_char_kind")), "..R",
2744 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
537824d1 2745 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
bc351485 2746 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
241ecdc7 2747
2748 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2749 get_identifier (PREFIX("selected_int_kind")), ".R",
2750 gfc_int4_type_node, 1, pvoid_type_node);
537824d1 2751 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
bc351485 2752 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
241ecdc7 2753
2754 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2755 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2756 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2757 pvoid_type_node);
537824d1 2758 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
bc351485 2759 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
4ee9c684 2760
4ee9c684 2761 /* Power functions. */
76834664 2762 {
920e54ef 2763 tree ctype, rtype, itype, jtype;
2764 int rkind, ikind, jkind;
2765#define NIKINDS 3
2766#define NRKINDS 4
2767 static int ikinds[NIKINDS] = {4, 8, 16};
2768 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2769 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2770
2771 for (ikind=0; ikind < NIKINDS; ikind++)
76834664 2772 {
920e54ef 2773 itype = gfc_get_int_type (ikinds[ikind]);
2774
2775 for (jkind=0; jkind < NIKINDS; jkind++)
2776 {
2777 jtype = gfc_get_int_type (ikinds[jkind]);
2778 if (itype && jtype)
2779 {
2780 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2781 ikinds[jkind]);
2782 gfor_fndecl_math_powi[jkind][ikind].integer =
2783 gfc_build_library_function_decl (get_identifier (name),
2784 jtype, 2, jtype, itype);
2177d98b 2785 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
bc351485 2786 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
920e54ef 2787 }
2788 }
2789
2790 for (rkind = 0; rkind < NRKINDS; rkind ++)
76834664 2791 {
920e54ef 2792 rtype = gfc_get_real_type (rkinds[rkind]);
2793 if (rtype && itype)
2794 {
2795 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2796 ikinds[ikind]);
2797 gfor_fndecl_math_powi[rkind][ikind].real =
2798 gfc_build_library_function_decl (get_identifier (name),
2799 rtype, 2, rtype, itype);
2177d98b 2800 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
bc351485 2801 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
920e54ef 2802 }
2803
2804 ctype = gfc_get_complex_type (rkinds[rkind]);
2805 if (ctype && itype)
2806 {
2807 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2808 ikinds[ikind]);
2809 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2810 gfc_build_library_function_decl (get_identifier (name),
2811 ctype, 2,ctype, itype);
2177d98b 2812 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
bc351485 2813 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
920e54ef 2814 }
76834664 2815 }
2816 }
920e54ef 2817#undef NIKINDS
2818#undef NRKINDS
76834664 2819 }
2820
241ecdc7 2821 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2822 get_identifier (PREFIX("ishftc4")),
2823 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2824 gfc_int4_type_node);
bc351485 2825 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2826 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
241ecdc7 2827
2828 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2829 get_identifier (PREFIX("ishftc8")),
2830 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2831 gfc_int4_type_node);
bc351485 2832 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
2833 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
241ecdc7 2834
920e54ef 2835 if (gfc_int16_type_node)
bc351485 2836 {
2837 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
241ecdc7 2838 get_identifier (PREFIX("ishftc16")),
2839 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2840 gfc_int4_type_node);
bc351485 2841 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
2842 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
2843 }
920e54ef 2844
4e8e57b0 2845 /* BLAS functions. */
2846 {
36c921b9 2847 tree pint = build_pointer_type (integer_type_node);
4e8e57b0 2848 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2849 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2850 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2851 tree pz = build_pointer_type
2852 (gfc_get_complex_type (gfc_default_double_kind));
2853
2854 gfor_fndecl_sgemm = gfc_build_library_function_decl
2855 (get_identifier
2856 (gfc_option.flag_underscoring ? "sgemm_"
2857 : "sgemm"),
2858 void_type_node, 15, pchar_type_node,
2859 pchar_type_node, pint, pint, pint, ps, ps, pint,
36c921b9 2860 ps, pint, ps, ps, pint, integer_type_node,
2861 integer_type_node);
4e8e57b0 2862 gfor_fndecl_dgemm = gfc_build_library_function_decl
2863 (get_identifier
2864 (gfc_option.flag_underscoring ? "dgemm_"
2865 : "dgemm"),
2866 void_type_node, 15, pchar_type_node,
2867 pchar_type_node, pint, pint, pint, pd, pd, pint,
36c921b9 2868 pd, pint, pd, pd, pint, integer_type_node,
2869 integer_type_node);
4e8e57b0 2870 gfor_fndecl_cgemm = gfc_build_library_function_decl
2871 (get_identifier
2872 (gfc_option.flag_underscoring ? "cgemm_"
2873 : "cgemm"),
2874 void_type_node, 15, pchar_type_node,
2875 pchar_type_node, pint, pint, pint, pc, pc, pint,
36c921b9 2876 pc, pint, pc, pc, pint, integer_type_node,
2877 integer_type_node);
4e8e57b0 2878 gfor_fndecl_zgemm = gfc_build_library_function_decl
2879 (get_identifier
2880 (gfc_option.flag_underscoring ? "zgemm_"
2881 : "zgemm"),
2882 void_type_node, 15, pchar_type_node,
2883 pchar_type_node, pint, pint, pint, pz, pz, pint,
36c921b9 2884 pz, pint, pz, pz, pint, integer_type_node,
2885 integer_type_node);
4e8e57b0 2886 }
2887
4ee9c684 2888 /* Other functions. */
241ecdc7 2889 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
2890 get_identifier (PREFIX("size0")), ".R",
2891 gfc_array_index_type, 1, pvoid_type_node);
537824d1 2892 DECL_PURE_P (gfor_fndecl_size0) = 1;
bc351485 2893 TREE_NOTHROW (gfor_fndecl_size0) = 1;
241ecdc7 2894
2895 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
2896 get_identifier (PREFIX("size1")), ".R",
2897 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
537824d1 2898 DECL_PURE_P (gfor_fndecl_size1) = 1;
bc351485 2899 TREE_NOTHROW (gfor_fndecl_size1) = 1;
241ecdc7 2900
2901 gfor_fndecl_iargc = gfc_build_library_function_decl (
2902 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
bc351485 2903 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
4ee9c684 2904}
2905
2906
2907/* Make prototypes for runtime library functions. */
2908
2909void
2910gfc_build_builtin_function_decls (void)
2911{
90ba9145 2912 tree gfc_int4_type_node = gfc_get_int_type (4);
4ee9c684 2913
241ecdc7 2914 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
2915 get_identifier (PREFIX("stop_numeric")),
2916 void_type_node, 1, gfc_int4_type_node);
070cc790 2917 /* STOP doesn't return. */
98ccec97 2918 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2919
dff2ea5f 2920 gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
2921 get_identifier (PREFIX("stop_numeric_f08")),
2922 void_type_node, 1, gfc_int4_type_node);
2923 /* STOP doesn't return. */
2924 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
2925
241ecdc7 2926 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
2927 get_identifier (PREFIX("stop_string")), ".R.",
2928 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
070cc790 2929 /* STOP doesn't return. */
241ecdc7 2930 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
537824d1 2931
241ecdc7 2932 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
2933 get_identifier (PREFIX("error_stop_numeric")),
2934 void_type_node, 1, gfc_int4_type_node);
070cc790 2935 /* ERROR STOP doesn't return. */
2936 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
2937
241ecdc7 2938 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
2939 get_identifier (PREFIX("error_stop_string")), ".R.",
2940 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
c6cd3066 2941 /* ERROR STOP doesn't return. */
2942 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2943
241ecdc7 2944 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
2945 get_identifier (PREFIX("pause_numeric")),
2946 void_type_node, 1, gfc_int4_type_node);
070cc790 2947
241ecdc7 2948 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
2949 get_identifier (PREFIX("pause_string")), ".R.",
2950 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
4ee9c684 2951
241ecdc7 2952 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
2953 get_identifier (PREFIX("runtime_error")), ".R",
2954 void_type_node, -1, pchar_type_node);
9c0f3811 2955 /* The runtime_error function does not return. */
2956 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
4ee9c684 2957
241ecdc7 2958 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
2959 get_identifier (PREFIX("runtime_error_at")), ".RR",
2960 void_type_node, -2, pchar_type_node, pchar_type_node);
50ad5fa2 2961 /* The runtime_error_at function does not return. */
2962 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2963
241ecdc7 2964 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
2965 get_identifier (PREFIX("runtime_warning_at")), ".RR",
2966 void_type_node, -2, pchar_type_node, pchar_type_node);
2967
2968 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
2969 get_identifier (PREFIX("generate_error")), ".R.R",
2970 void_type_node, 3, pvoid_type_node, integer_type_node,
2971 pchar_type_node);
2972
2973 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
2974 get_identifier (PREFIX("os_error")), ".R",
2975 void_type_node, 1, pchar_type_node);
9915365e 2976 /* The runtime_error function does not return. */
2977 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2978
241ecdc7 2979 gfor_fndecl_set_args = gfc_build_library_function_decl (
2980 get_identifier (PREFIX("set_args")),
2981 void_type_node, 2, integer_type_node,
2982 build_pointer_type (pchar_type_node));
7257a5d2 2983
241ecdc7 2984 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
2985 get_identifier (PREFIX("set_fpe")),
2986 void_type_node, 1, integer_type_node);
8c84a5de 2987
56c7c2d7 2988 /* Keep the array dimension in sync with the call, later in this file. */
241ecdc7 2989 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
2990 get_identifier (PREFIX("set_options")), "..R",
2991 void_type_node, 2, integer_type_node,
2992 build_pointer_type (integer_type_node));
64fc3c4c 2993
241ecdc7 2994 gfor_fndecl_set_convert = gfc_build_library_function_decl (
2995 get_identifier (PREFIX("set_convert")),
2996 void_type_node, 1, integer_type_node);
15774a8b 2997
241ecdc7 2998 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
2999 get_identifier (PREFIX("set_record_marker")),
3000 void_type_node, 1, integer_type_node);
f23886ab 3001
241ecdc7 3002 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3003 get_identifier (PREFIX("set_max_subrecord_length")),
3004 void_type_node, 1, integer_type_node);
bbaaa7b1 3005
8ce86007 3006 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
241ecdc7 3007 get_identifier (PREFIX("internal_pack")), ".r",
3008 pvoid_type_node, 1, pvoid_type_node);
4ee9c684 3009
8ce86007 3010 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
241ecdc7 3011 get_identifier (PREFIX("internal_unpack")), ".wR",
3012 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3013
3014 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3015 get_identifier (PREFIX("associated")), ".RR",
3016 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
537824d1 3017 DECL_PURE_P (gfor_fndecl_associated) = 1;
bc351485 3018 TREE_NOTHROW (gfor_fndecl_associated) = 1;
4ee9c684 3019
70b5944a 3020 /* Coarray library calls. */
3021 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
3022 {
3023 tree pint_type, pppchar_type;
3024
3025 pint_type = build_pointer_type (integer_type_node);
3026 pppchar_type
3027 = build_pointer_type (build_pointer_type (pchar_type_node));
3028
3029 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3030 get_identifier (PREFIX("caf_init")), void_type_node,
3031 4, pint_type, pppchar_type, pint_type, pint_type);
3032
3033 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3034 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3035
3036 gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3037 get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3038
3039 gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3040 get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3041
3042 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3043 get_identifier (PREFIX("caf_sync_all")), ".W", integer_type_node,
3044 2, build_pointer_type (pchar_type_node), integer_type_node);
3045
3046 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3047 get_identifier (PREFIX("caf_sync_images")), ".RRW", integer_type_node,
3048 4, integer_type_node, pint_type, build_pointer_type (pchar_type_node),
3049 integer_type_node);
3050
3051 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3052 get_identifier (PREFIX("caf_error_stop")),
3053 void_type_node, 1, gfc_int4_type_node);
3054 /* CAF's ERROR STOP doesn't return. */
3055 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3056
3057 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3058 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3059 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3060 /* CAF's ERROR STOP doesn't return. */
3061 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3062 }
3063
4ee9c684 3064 gfc_build_intrinsic_function_decls ();
3065 gfc_build_intrinsic_lib_fndecls ();
3066 gfc_build_io_library_fndecls ();
3067}
3068
3069
231e961a 3070/* Evaluate the length of dummy character variables. */
4ee9c684 3071
c5faa799 3072static void
3073gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3074 gfc_wrapped_block *block)
4ee9c684 3075{
c5faa799 3076 stmtblock_t init;
4ee9c684 3077
b9c7fce7 3078 gfc_finish_decl (cl->backend_decl);
4ee9c684 3079
c5faa799 3080 gfc_start_block (&init);
4ee9c684 3081
3082 /* Evaluate the string length expression. */
c5faa799 3083 gfc_conv_string_length (cl, NULL, &init);
d4163395 3084
c5faa799 3085 gfc_trans_vla_type_sizes (sym, &init);
d4163395 3086
c5faa799 3087 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4ee9c684 3088}
3089
3090
3091/* Allocate and cleanup an automatic character variable. */
3092
c5faa799 3093static void
3094gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
4ee9c684 3095{
c5faa799 3096 stmtblock_t init;
4ee9c684 3097 tree decl;
4ee9c684 3098 tree tmp;
3099
22d678e8 3100 gcc_assert (sym->backend_decl);
eeebe20b 3101 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
4ee9c684 3102
3714c8b6 3103 gfc_init_block (&init);
4ee9c684 3104
3105 /* Evaluate the string length expression. */
c5faa799 3106 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4ee9c684 3107
c5faa799 3108 gfc_trans_vla_type_sizes (sym, &init);
d4163395 3109
4ee9c684 3110 decl = sym->backend_decl;
3111
afcf285e 3112 /* Emit a DECL_EXPR for this variable, which will cause the
4b3a701c 3113 gimplifier to allocate storage, and all that good stuff. */
fd779e1d 3114 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
c5faa799 3115 gfc_add_expr_to_block (&init, tmp);
afcf285e 3116
c5faa799 3117 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4ee9c684 3118}
3119
c8f1568f 3120/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3121
c5faa799 3122static void
3123gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
c8f1568f 3124{
c5faa799 3125 stmtblock_t init;
c8f1568f 3126
3127 gcc_assert (sym->backend_decl);
c5faa799 3128 gfc_start_block (&init);
c8f1568f 3129
3130 /* Set the initial value to length. See the comments in
3131 function gfc_add_assign_aux_vars in this file. */
c5faa799 3132 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
35bf1214 3133 build_int_cst (gfc_charlen_type_node, -2));
c8f1568f 3134
c5faa799 3135 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
c8f1568f 3136}
3137
d4163395 3138static void
3139gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3140{
3141 tree t = *tp, var, val;
3142
3143 if (t == NULL || t == error_mark_node)
3144 return;
3145 if (TREE_CONSTANT (t) || DECL_P (t))
3146 return;
3147
3148 if (TREE_CODE (t) == SAVE_EXPR)
3149 {
3150 if (SAVE_EXPR_RESOLVED_P (t))
3151 {
3152 *tp = TREE_OPERAND (t, 0);
3153 return;
3154 }
3155 val = TREE_OPERAND (t, 0);
3156 }
3157 else
3158 val = t;
3159
3160 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3161 gfc_add_decl_to_function (var);
75a70cf9 3162 gfc_add_modify (body, var, val);
d4163395 3163 if (TREE_CODE (t) == SAVE_EXPR)
3164 TREE_OPERAND (t, 0) = var;
3165 *tp = var;
3166}
3167
3168static void
3169gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3170{
3171 tree t;
3172
3173 if (type == NULL || type == error_mark_node)
3174 return;
3175
3176 type = TYPE_MAIN_VARIANT (type);
3177
3178 if (TREE_CODE (type) == INTEGER_TYPE)
3179 {
3180 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3181 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3182
3183 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3184 {
3185 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3186 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3187 }
3188 }
3189 else if (TREE_CODE (type) == ARRAY_TYPE)
3190 {
3191 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3192 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3193 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3194 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3195
3196 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3197 {
3198 TYPE_SIZE (t) = TYPE_SIZE (type);
3199 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3200 }
3201 }
3202}
3203
3204/* Make sure all type sizes and array domains are either constant,
3205 or variable or parameter decls. This is a simplified variant
3206 of gimplify_type_sizes, but we can't use it here, as none of the
3207 variables in the expressions have been gimplified yet.
3208 As type sizes and domains for various variable length arrays
3209 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3210 time, without this routine gimplify_type_sizes in the middle-end
3211 could result in the type sizes being gimplified earlier than where
3212 those variables are initialized. */
3213
3214void
3215gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3216{
3217 tree type = TREE_TYPE (sym->backend_decl);
3218
3219 if (TREE_CODE (type) == FUNCTION_TYPE
3220 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3221 {
3222 if (! current_fake_result_decl)
3223 return;
3224
3225 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3226 }
3227
3228 while (POINTER_TYPE_P (type))
3229 type = TREE_TYPE (type);
3230
3231 if (GFC_DESCRIPTOR_TYPE_P (type))
3232 {
3233 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3234
3235 while (POINTER_TYPE_P (etype))
3236 etype = TREE_TYPE (etype);
3237
3238 gfc_trans_vla_type_sizes_1 (etype, body);
3239 }
3240
3241 gfc_trans_vla_type_sizes_1 (type, body);
3242}
3243
4ee9c684 3244
f0d4969f 3245/* Initialize a derived type by building an lvalue from the symbol
a545a8f8 3246 and using trans_assignment to do the work. Set dealloc to false
3247 if no deallocation prior the assignment is needed. */
c5faa799 3248void
3249gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
87114d2e 3250{
f0d4969f 3251 gfc_expr *e;
87114d2e 3252 tree tmp;
3253 tree present;
3254
c5faa799 3255 gcc_assert (block);
3256
f0d4969f 3257 gcc_assert (!sym->attr.allocatable);
3258 gfc_set_sym_referenced (sym);
3259 e = gfc_lval_expr_from_sym (sym);
a545a8f8 3260 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
c38054a8 3261 if (sym->attr.dummy && (sym->attr.optional
3262 || sym->ns->proc_name->attr.entry_master))
87114d2e 3263 {
f0d4969f 3264 present = gfc_conv_expr_present (sym);
2be9d8f1 3265 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3266 tmp, build_empty_stmt (input_location));
87114d2e 3267 }
c5faa799 3268 gfc_add_expr_to_block (block, tmp);
f0d4969f 3269 gfc_free_expr (e);
87114d2e 3270}
3271
3272
8714fc76 3273/* Initialize INTENT(OUT) derived type dummies. As well as giving
3274 them their default initializer, if they do not have allocatable
3275 components, they have their allocatable components deallocated. */
3276
c5faa799 3277static void
3278init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
f0d4969f 3279{
c5faa799 3280 stmtblock_t init;
f0d4969f 3281 gfc_formal_arglist *f;
8714fc76 3282 tree tmp;
5907c3ea 3283 tree present;
f0d4969f 3284
c5faa799 3285 gfc_init_block (&init);
f0d4969f 3286 for (f = proc_sym->formal; f; f = f->next)
3287 if (f->sym && f->sym->attr.intent == INTENT_OUT
c49db15e 3288 && !f->sym->attr.pointer
3289 && f->sym->ts.type == BT_DERIVED)
8714fc76 3290 {
c38054a8 3291 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
8714fc76 3292 {
eeebe20b 3293 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
8714fc76 3294 f->sym->backend_decl,
3295 f->sym->as ? f->sym->as->rank : 0);
5907c3ea 3296
c38054a8 3297 if (f->sym->attr.optional
3298 || f->sym->ns->proc_name->attr.entry_master)
3299 {
3300 present = gfc_conv_expr_present (f->sym);
2be9d8f1 3301 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3302 present, tmp,
3303 build_empty_stmt (input_location));
c38054a8 3304 }
5907c3ea 3305
c5faa799 3306 gfc_add_expr_to_block (&init, tmp);
8714fc76 3307 }
c38054a8 3308 else if (f->sym->value)
c5faa799 3309 gfc_init_default_dt (f->sym, &init, true);
8714fc76 3310 }
c56d57d6 3311 else if (f->sym && f->sym->attr.intent == INTENT_OUT
3312 && f->sym->ts.type == BT_CLASS
3313 && !CLASS_DATA (f->sym)->attr.class_pointer
3314 && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
3315 {
3316 tree decl = build_fold_indirect_ref_loc (input_location,
3317 f->sym->backend_decl);
3318 tmp = CLASS_DATA (f->sym)->backend_decl;
3319 tmp = fold_build3_loc (input_location, COMPONENT_REF,
3320 TREE_TYPE (tmp), decl, tmp, NULL_TREE);
3321 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3322 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
3323 tmp,
3324 CLASS_DATA (f->sym)->as ?
3325 CLASS_DATA (f->sym)->as->rank : 0);
3326
3327 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3328 {
3329 present = gfc_conv_expr_present (f->sym);
3330 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3331 present, tmp,
3332 build_empty_stmt (input_location));
3333 }
3334
3335 gfc_add_expr_to_block (&init, tmp);
3336 }
f0d4969f 3337
c5faa799 3338 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
f0d4969f 3339}
3340
87114d2e 3341
4ee9c684 3342/* Generate function entry and exit code, and add it to the function body.
3343 This includes:
f888a3fb 3344 Allocation and initialization of array variables.
4ee9c684 3345 Allocation of character string variables.
c8f1568f 3346 Initialization and possibly repacking of dummy arrays.
0a96a7cc 3347 Initialization of ASSIGN statement auxiliary variable.
8f3f9eab 3348 Initialization of ASSOCIATE names.
0a96a7cc 3349 Automatic deallocation. */
4ee9c684 3350
89ac8ba1 3351void
3352gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
4ee9c684 3353{
3354 locus loc;
3355 gfc_symbol *sym;
d4163395 3356 gfc_formal_arglist *f;
c5faa799 3357 stmtblock_t tmpblock;
25dd7350 3358 bool seen_trans_deferred_array = false;
617125a6 3359 tree tmp = NULL;
3360 gfc_expr *e;
3361 gfc_se se;
3362 stmtblock_t init;
4ee9c684 3363
3364 /* Deal with implicit return variables. Explicit return variables will
3365 already have been added. */
3366 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3367 {
3368 if (!current_fake_result_decl)
3369 {
c6871095 3370 gfc_entry_list *el = NULL;
3371 if (proc_sym->attr.entry_master)
3372 {
3373 for (el = proc_sym->ns->entries; el; el = el->next)
3374 if (el->sym != el->sym->result)
3375 break;
3376 }
fa7b6574 3377 /* TODO: move to the appropriate place in resolve.c. */
3378 if (warn_return_type && el == NULL)
3379 gfc_warning ("Return value of function '%s' at %L not set",
3380 proc_sym->name, &proc_sym->declared_at);
4ee9c684 3381 }
c6871095 3382 else if (proc_sym->as)
4ee9c684 3383 {
d4163395 3384 tree result = TREE_VALUE (current_fake_result_decl);
89ac8ba1 3385 gfc_trans_dummy_array_bias (proc_sym, result, block);
10b07432 3386
3387 /* An automatic character length, pointer array result. */
3388 if (proc_sym->ts.type == BT_CHARACTER
eeebe20b 3389 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
89ac8ba1 3390 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
4ee9c684 3391 }
3392 else if (proc_sym->ts.type == BT_CHARACTER)
3393 {
617125a6 3394 if (proc_sym->ts.deferred)
3395 {
3396 tmp = NULL;
da2c4122 3397 gfc_save_backend_locus (&loc);
3398 gfc_set_backend_locus (&proc_sym->declared_at);
617125a6 3399 gfc_start_block (&init);
3400 /* Zero the string length on entry. */
3401 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3402 build_int_cst (gfc_charlen_type_node, 0));
3403 /* Null the pointer. */
3404 e = gfc_lval_expr_from_sym (proc_sym);
3405 gfc_init_se (&se, NULL);
3406 se.want_pointer = 1;
3407 gfc_conv_expr (&se, e);
3408 gfc_free_expr (e);
3409 tmp = se.expr;
3410 gfc_add_modify (&init, tmp,
3411 fold_convert (TREE_TYPE (se.expr),
3412 null_pointer_node));
da2c4122 3413 gfc_restore_backend_locus (&loc);
617125a6 3414
3415 /* Pass back the string length on exit. */
3416 tmp = proc_sym->ts.u.cl->passed_length;
3417 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3418 tmp = fold_convert (gfc_charlen_type_node, tmp);
3419 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3420 gfc_charlen_type_node, tmp,
3421 proc_sym->ts.u.cl->backend_decl);
3422 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3423 }
3424 else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
89ac8ba1 3425 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
4ee9c684 3426 }
3427 else
bdaed7d2 3428 gcc_assert (gfc_option.flag_f2c
3429 && proc_sym->ts.type == BT_COMPLEX);
4ee9c684 3430 }
3431
87114d2e 3432 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3433 should be done here so that the offsets and lbounds of arrays
3434 are available. */
da2c4122 3435 gfc_save_backend_locus (&loc);
3436 gfc_set_backend_locus (&proc_sym->declared_at);
89ac8ba1 3437 init_intent_out_dt (proc_sym, block);
da2c4122 3438 gfc_restore_backend_locus (&loc);
87114d2e 3439
4ee9c684 3440 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3441 {
2294b616 3442 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
eeebe20b 3443 && sym->ts.u.derived->attr.alloc_comp;
8f3f9eab 3444 if (sym->assoc)
3c82e013 3445 continue;
3446
3447 if (sym->attr.dimension)
4ee9c684 3448 {
3449 switch (sym->as->type)
3450 {
3451 case AS_EXPLICIT:
3452 if (sym->attr.dummy || sym->attr.result)
89ac8ba1 3453 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4ee9c684 3454 else if (sym->attr.pointer || sym->attr.allocatable)
3455 {
3456 if (TREE_STATIC (sym->backend_decl))
da2c4122 3457 {
3458 gfc_save_backend_locus (&loc);
3459 gfc_set_backend_locus (&sym->declared_at);
3460 gfc_trans_static_array_pointer (sym);
3461 gfc_restore_backend_locus (&loc);
3462 }
4ee9c684 3463 else
25dd7350 3464 {
3465 seen_trans_deferred_array = true;
89ac8ba1 3466 gfc_trans_deferred_array (sym, block);
25dd7350 3467 }
4ee9c684 3468 }
3469 else
3470 {
da2c4122 3471 gfc_save_backend_locus (&loc);
3472 gfc_set_backend_locus (&sym->declared_at);
3473
25dd7350 3474 if (sym_has_alloc_comp)
3475 {
3476 seen_trans_deferred_array = true;
89ac8ba1 3477 gfc_trans_deferred_array (sym, block);
25dd7350 3478 }
f0d4969f 3479 else if (sym->ts.type == BT_DERIVED
3480 && sym->value
3481 && !sym->attr.data
3482 && sym->attr.save == SAVE_NONE)
c5faa799 3483 {
3484 gfc_start_block (&tmpblock);
3485 gfc_init_default_dt (sym, &tmpblock, false);
89ac8ba1 3486 gfc_add_init_cleanup (block,
c5faa799 3487 gfc_finish_block (&tmpblock),
3488 NULL_TREE);
3489 }
25dd7350 3490
c5faa799 3491 gfc_trans_auto_array_allocation (sym->backend_decl,
89ac8ba1 3492 sym, block);
4671339c 3493 gfc_restore_backend_locus (&loc);
4ee9c684 3494 }
3495 break;
3496
3497 case AS_ASSUMED_SIZE:
3498 /* Must be a dummy parameter. */
452695a8 3499 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
4ee9c684 3500
3501 /* We should always pass assumed size arrays the g77 way. */
452695a8 3502 if (sym->attr.dummy)
89ac8ba1 3503 gfc_trans_g77_array (sym, block);
c5faa799 3504 break;
4ee9c684 3505
3506 case AS_ASSUMED_SHAPE:
3507 /* Must be a dummy parameter. */
22d678e8 3508 gcc_assert (sym->attr.dummy);
4ee9c684 3509
89ac8ba1 3510 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4ee9c684 3511 break;
3512
3513 case AS_DEFERRED:
25dd7350 3514 seen_trans_deferred_array = true;
89ac8ba1 3515 gfc_trans_deferred_array (sym, block);
4ee9c684 3516 break;
3517
3518 default:
22d678e8 3519 gcc_unreachable ();
4ee9c684 3520 }
25dd7350 3521 if (sym_has_alloc_comp && !seen_trans_deferred_array)
89ac8ba1 3522 gfc_trans_deferred_array (sym, block);
4ee9c684 3523 }
617125a6 3524 else if ((!sym->attr.dummy || sym->ts.deferred)
456dd7d6 3525 && (sym->attr.allocatable
3526 || (sym->ts.type == BT_CLASS
3527 && CLASS_DATA (sym)->attr.allocatable)))
0a96a7cc 3528 {
908e9973 3529 if (!sym->attr.save)
3530 {
3531 /* Nullify and automatic deallocation of allocatable
3532 scalars. */
908e9973 3533 e = gfc_lval_expr_from_sym (sym);
3534 if (sym->ts.type == BT_CLASS)
607ae689 3535 gfc_add_data_component (e);
908e9973 3536
3537 gfc_init_se (&se, NULL);
3538 se.want_pointer = 1;
3539 gfc_conv_expr (&se, e);
3540 gfc_free_expr (e);
3541
da2c4122 3542 gfc_save_backend_locus (&loc);
3543 gfc_set_backend_locus (&sym->declared_at);
c5faa799 3544 gfc_start_block (&init);
617125a6 3545
3546 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3547 {
3548 /* Nullify when entering the scope. */
3549 gfc_add_modify (&init, se.expr,
3550 fold_convert (TREE_TYPE (se.expr),
3551 null_pointer_node));
3552 }
3553
3554 if ((sym->attr.dummy ||sym->attr.result)
3555 && sym->ts.type == BT_CHARACTER
3556 && sym->ts.deferred)
3557 {
3558 /* Character length passed by reference. */
3559 tmp = sym->ts.u.cl->passed_length;
3560 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3561 tmp = fold_convert (gfc_charlen_type_node, tmp);
3562
3563 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3564 /* Zero the string length when entering the scope. */
3565 gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3566 build_int_cst (gfc_charlen_type_node, 0));
3567 else
3568 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3569
da2c4122 3570 gfc_restore_backend_locus (&loc);
3571
617125a6 3572 /* Pass the final character length back. */
3573 if (sym->attr.intent != INTENT_IN)
3574 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3575 gfc_charlen_type_node, tmp,
3576 sym->ts.u.cl->backend_decl);
3577 else
3578 tmp = NULL_TREE;
3579 }
da2c4122 3580 else
3581 gfc_restore_backend_locus (&loc);
908e9973 3582
3583 /* Deallocate when leaving the scope. Nullifying is not
3584 needed. */
617125a6 3585 if (!sym->attr.result && !sym->attr.dummy)
2bf70a2a 3586 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
3587 NULL, sym->ts);
afc44c79 3588
3589 if (sym->ts.type == BT_CLASS)
3590 {
3591 /* Initialize _vptr to declared type. */
3592 gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
3593 tree rhs;
da2c4122 3594
3595 gfc_save_backend_locus (&loc);
3596 gfc_set_backend_locus (&sym->declared_at);
afc44c79 3597 e = gfc_lval_expr_from_sym (sym);
3598 gfc_add_vptr_component (e);
3599 gfc_init_se (&se, NULL);
3600 se.want_pointer = 1;
3601 gfc_conv_expr (&se, e);
3602 gfc_free_expr (e);
3603 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
3604 gfc_get_symbol_decl (vtab));
3605 gfc_add_modify (&init, se.expr, rhs);
da2c4122 3606 gfc_restore_backend_locus (&loc);
afc44c79 3607 }
3608
89ac8ba1 3609 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
908e9973 3610 }
0a96a7cc 3611 }
617125a6 3612 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
3613 {
3614 tree tmp = NULL;
3615 stmtblock_t init;
3616
3617 /* If we get to here, all that should be left are pointers. */
3618 gcc_assert (sym->attr.pointer);
3619
3620 if (sym->attr.dummy)
3621 {
3622 gfc_start_block (&init);
3623
3624 /* Character length passed by reference. */
3625 tmp = sym->ts.u.cl->passed_length;
3626 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3627 tmp = fold_convert (gfc_charlen_type_node, tmp);
3628 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3629 /* Pass the final character length back. */
3630 if (sym->attr.intent != INTENT_IN)
3631 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3632 gfc_charlen_type_node, tmp,
3633 sym->ts.u.cl->backend_decl);
3634 else
3635 tmp = NULL_TREE;
3636 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3637 }
3638 }
3e715c81 3639 else if (sym->ts.deferred)
3640 gfc_fatal_error ("Deferred type parameter not yet supported");
fabc1fc9 3641 else if (sym_has_alloc_comp)
89ac8ba1 3642 gfc_trans_deferred_array (sym, block);
4ee9c684 3643 else if (sym->ts.type == BT_CHARACTER)
3644 {
4671339c 3645 gfc_save_backend_locus (&loc);
4ee9c684 3646 gfc_set_backend_locus (&sym->declared_at);
3647 if (sym->attr.dummy || sym->attr.result)
89ac8ba1 3648 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
4ee9c684 3649 else
89ac8ba1 3650 gfc_trans_auto_character_variable (sym, block);
4671339c 3651 gfc_restore_backend_locus (&loc);
4ee9c684 3652 }
c8f1568f 3653 else if (sym->attr.assign)
3654 {
4671339c 3655 gfc_save_backend_locus (&loc);
c8f1568f 3656 gfc_set_backend_locus (&sym->declared_at);
89ac8ba1 3657 gfc_trans_assign_aux_var (sym, block);
4671339c 3658 gfc_restore_backend_locus (&loc);
c8f1568f 3659 }
f0d4969f 3660 else if (sym->ts.type == BT_DERIVED
3661 && sym->value
3662 && !sym->attr.data
3663 && sym->attr.save == SAVE_NONE)
c5faa799 3664 {
3665 gfc_start_block (&tmpblock);
3666 gfc_init_default_dt (sym, &tmpblock, false);
89ac8ba1 3667 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
c5faa799 3668 NULL_TREE);
3669 }
4ee9c684 3670 else
22d678e8 3671 gcc_unreachable ();
4ee9c684 3672 }
3673
c5faa799 3674 gfc_init_block (&tmpblock);
d4163395 3675
3676 for (f = proc_sym->formal; f; f = f->next)
1e853e89 3677 {
3678 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3679 {
eeebe20b 3680 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3681 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
c5faa799 3682 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
1e853e89 3683 }
1e853e89 3684 }
d4163395 3685
3686 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3687 && current_fake_result_decl != NULL)
3688 {
eeebe20b 3689 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3690 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
c5faa799 3691 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
d4163395 3692 }
3693
89ac8ba1 3694 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
4ee9c684 3695}
3696
df4d540f 3697static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3698
3699/* Hash and equality functions for module_htab. */
3700
3701static hashval_t
3702module_htab_do_hash (const void *x)
3703{
3704 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3705}
3706
3707static int
3708module_htab_eq (const void *x1, const void *x2)
3709{
3710 return strcmp ((((const struct module_htab_entry *)x1)->name),
3711 (const char *)x2) == 0;
3712}
3713
3714/* Hash and equality functions for module_htab's decls. */
3715
3716static hashval_t
3717module_htab_decls_hash (const void *x)
3718{
3719 const_tree t = (const_tree) x;
3720 const_tree n = DECL_NAME (t);
3721 if (n == NULL_TREE)
3722 n = TYPE_NAME (TREE_TYPE (t));
8f1e8e0e 3723 return htab_hash_string (IDENTIFIER_POINTER (n));
df4d540f 3724}
3725
3726static int
3727module_htab_decls_eq (const void *x1, const void *x2)
3728{
3729 const_tree t1 = (const_tree) x1;
3730 const_tree n1 = DECL_NAME (t1);
3731 if (n1 == NULL_TREE)
3732 n1 = TYPE_NAME (TREE_TYPE (t1));
3733 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3734}
3735
3736struct module_htab_entry *
3737gfc_find_module (const char *name)
3738{
3739 void **slot;
3740
3741 if (! module_htab)
3742 module_htab = htab_create_ggc (10, module_htab_do_hash,
3743 module_htab_eq, NULL);
3744
3745 slot = htab_find_slot_with_hash (module_htab, name,
3746 htab_hash_string (name), INSERT);
3747 if (*slot == NULL)
3748 {
ba72912a 3749 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
df4d540f 3750
3751 entry->name = gfc_get_string (name);
3752 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3753 module_htab_decls_eq, NULL);
3754 *slot = (void *) entry;
3755 }
3756 return (struct module_htab_entry *) *slot;
3757}
3758
3759void
3760gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3761{
3762 void **slot;
3763 const char *name;
3764
3765 if (DECL_NAME (decl))
3766 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3767 else
3768 {
3769 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3770 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3771 }
3772 slot = htab_find_slot_with_hash (entry->decls, name,
3773 htab_hash_string (name), INSERT);
3774 if (*slot == NULL)
3775 *slot = (void *) decl;
3776}
3777
3778static struct module_htab_entry *cur_module;
4ee9c684 3779
3780/* Output an initialized decl for a module variable. */
3781
3782static void
3783gfc_create_module_variable (gfc_symbol * sym)
3784{
3785 tree decl;
4ee9c684 3786
d77f260f 3787 /* Module functions with alternate entries are dealt with later and
3788 would get caught by the next condition. */
3789 if (sym->attr.entry)
3790 return;
3791
c5d33754 3792 /* Make sure we convert the types of the derived types from iso_c_binding
3793 into (void *). */
3794 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3795 && sym->ts.type == BT_DERIVED)
3796 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3797
df4d540f 3798 if (sym->attr.flavor == FL_DERIVED
3799 && sym->backend_decl
3800 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3801 {
3802 decl = sym->backend_decl;
3803 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
9f1470cb 3804
3805 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3806 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3807 {
3808 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3809 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3810 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3811 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3812 == sym->ns->proc_name->backend_decl);
3813 }
df4d540f 3814 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3815 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3816 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3817 }
3818
cf269acc 3819 /* Only output variables, procedure pointers and array valued,
3820 or derived type, parameters. */
4ee9c684 3821 if (sym->attr.flavor != FL_VARIABLE
be0f1581 3822 && !(sym->attr.flavor == FL_PARAMETER
cf269acc 3823 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3824 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4ee9c684 3825 return;
3826
df4d540f 3827 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3828 {
3829 decl = sym->backend_decl;
16a40513 3830 gcc_assert (DECL_FILE_SCOPE_P (decl));
df4d540f 3831 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3832 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3833 gfc_module_add_decl (cur_module, decl);
3834 }
3835
d43a7f7f 3836 /* Don't generate variables from other modules. Variables from
3837 COMMONs will already have been generated. */
3838 if (sym->attr.use_assoc || sym->attr.in_common)
4ee9c684 3839 return;
3840
2b685f8e 3841 /* Equivalenced variables arrive here after creation. */
976d903a 3842 if (sym->backend_decl
df4d540f 3843 && (sym->equiv_built || sym->attr.in_equivalence))
3844 return;
2b685f8e 3845
23d075f4 3846 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4ee9c684 3847 internal_error ("backend decl for module variable %s already exists",
3848 sym->name);
3849
3850 /* We always want module variables to be created. */
3851 sym->attr.referenced = 1;
3852 /* Create the decl. */
3853 decl = gfc_get_symbol_decl (sym);
3854
4ee9c684 3855 /* Create the variable. */
3856 pushdecl (decl);
df4d540f 3857 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3858 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
b2c4af5e 3859 rest_of_decl_compilation (decl, 1, 0);
df4d540f 3860 gfc_module_add_decl (cur_module, decl);
4ee9c684 3861
3862 /* Also add length of strings. */
3863 if (sym->ts.type == BT_CHARACTER)
3864 {
3865 tree length;
3866
eeebe20b 3867 length = sym->ts.u.cl->backend_decl;
cf4b41d8 3868 gcc_assert (length || sym->attr.proc_pointer);
3869 if (length && !INTEGER_CST_P (length))
4ee9c684 3870 {
3871 pushdecl (length);
b2c4af5e 3872 rest_of_decl_compilation (length, 1, 0);
4ee9c684 3873 }
3874 }
3875}
3876
51d9479b 3877/* Emit debug information for USE statements. */
df4d540f 3878
3879static void
3880gfc_trans_use_stmts (gfc_namespace * ns)
3881{
3882 gfc_use_list *use_stmt;
3883 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3884 {
3885 struct module_htab_entry *entry
3886 = gfc_find_module (use_stmt->module_name);
3887 gfc_use_rename *rent;
3888
3889 if (entry->namespace_decl == NULL)
3890 {
3891 entry->namespace_decl
e60a6f7b 3892 = build_decl (input_location,
3893 NAMESPACE_DECL,
df4d540f 3894 get_identifier (use_stmt->module_name),
3895 void_type_node);
3896 DECL_EXTERNAL (entry->namespace_decl) = 1;
3897 }
51d9479b 3898 gfc_set_backend_locus (&use_stmt->where);
df4d540f 3899 if (!use_stmt->only_flag)
3900 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3901 NULL_TREE,
3902 ns->proc_name->backend_decl,
3903 false);
3904 for (rent = use_stmt->rename; rent; rent = rent->next)
3905 {
3906 tree decl, local_name;
3907 void **slot;
3908
3909 if (rent->op != INTRINSIC_NONE)
3910 continue;
3911
3912 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3913 htab_hash_string (rent->use_name),
3914 INSERT);
3915 if (*slot == NULL)
3916 {
3917 gfc_symtree *st;
3918
3919 st = gfc_find_symtree (ns->sym_root,
3920 rent->local_name[0]
3921 ? rent->local_name : rent->use_name);
857c96ba 3922 gcc_assert (st);
3923
3924 /* Sometimes, generic interfaces wind up being over-ruled by a
3925 local symbol (see PR41062). */
3926 if (!st->n.sym->attr.use_assoc)
3927 continue;
3928
51d9479b 3929 if (st->n.sym->backend_decl
3930 && DECL_P (st->n.sym->backend_decl)
3931 && st->n.sym->module
3932 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
df4d540f 3933 {
51d9479b 3934 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3935 || (TREE_CODE (st->n.sym->backend_decl)
3936 != VAR_DECL));
df4d540f 3937 decl = copy_node (st->n.sym->backend_decl);
3938 DECL_CONTEXT (decl) = entry->namespace_decl;
3939 DECL_EXTERNAL (decl) = 1;
3940 DECL_IGNORED_P (decl) = 0;
3941 DECL_INITIAL (decl) = NULL_TREE;
3942 }
3943 else
3944 {
3945 *slot = error_mark_node;
3946 htab_clear_slot (entry->decls, slot);
3947 continue;
3948 }
3949 *slot = decl;
3950 }
3951 decl = (tree) *slot;
3952 if (rent->local_name[0])
3953 local_name = get_identifier (rent->local_name);
3954 else
3955 local_name = NULL_TREE;
51d9479b 3956 gfc_set_backend_locus (&rent->where);
df4d540f 3957 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3958 ns->proc_name->backend_decl,
3959 !use_stmt->only_flag);
3960 }
3961 }
4ee9c684 3962}
3963
51d9479b 3964
2eb674c9 3965/* Return true if expr is a constant initializer that gfc_conv_initializer
3966 will handle. */
3967
3968static bool
3969check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3970 bool pointer)
3971{
3972 gfc_constructor *c;
3973 gfc_component *cm;
3974
3975 if (pointer)
3976 return true;
3977 else if (array)
3978 {
3979 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3980 return true;
3981 else if (expr->expr_type == EXPR_STRUCTURE)
3982 return check_constant_initializer (expr, ts, false, false);
3983 else if (expr->expr_type != EXPR_ARRAY)
3984 return false;
126387b5 3985 for (c = gfc_constructor_first (expr->value.constructor);
3986 c; c = gfc_constructor_next (c))
2eb674c9 3987 {
3988 if (c->iterator)
3989 return false;
3990 if (c->expr->expr_type == EXPR_STRUCTURE)
3991 {
3992 if (!check_constant_initializer (c->expr, ts, false, false))
3993 return false;
3994 }
3995 else if (c->expr->expr_type != EXPR_CONSTANT)
3996 return false;
3997 }
3998 return true;
3999 }
4000 else switch (ts->type)
4001 {
4002 case BT_DERIVED:
4003 if (expr->expr_type != EXPR_STRUCTURE)
4004 return false;
eeebe20b 4005 cm = expr->ts.u.derived->components;
126387b5 4006 for (c = gfc_constructor_first (expr->value.constructor);
4007 c; c = gfc_constructor_next (c), cm = cm->next)
2eb674c9 4008 {
4009 if (!c->expr || cm->attr.allocatable)
4010 continue;
4011 if (!check_constant_initializer (c->expr, &cm->ts,
4012 cm->attr.dimension,
4013 cm->attr.pointer))
4014 return false;
4015 }
4016 return true;
4017 default:
4018 return expr->expr_type == EXPR_CONSTANT;
4019 }
4020}
4021
4022/* Emit debug info for parameters and unreferenced variables with
4023 initializers. */
4024
4025static void
4026gfc_emit_parameter_debug_info (gfc_symbol *sym)
4027{
4028 tree decl;
4029
4030 if (sym->attr.flavor != FL_PARAMETER
4031 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4032 return;
4033
4034 if (sym->backend_decl != NULL
4035 || sym->value == NULL
4036 || sym->attr.use_assoc
4037 || sym->attr.dummy
4038 || sym->attr.result
4039 || sym->attr.function
4040 || sym->attr.intrinsic
4041 || sym->attr.pointer
4042 || sym->attr.allocatable
4043 || sym->attr.cray_pointee
4044 || sym->attr.threadprivate
4045 || sym->attr.is_bind_c
4046 || sym->attr.subref_array_pointer
4047 || sym->attr.assign)
4048 return;
4049
4050 if (sym->ts.type == BT_CHARACTER)
4051 {
eeebe20b 4052 gfc_conv_const_charlen (sym->ts.u.cl);
4053 if (sym->ts.u.cl->backend_decl == NULL
4054 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
2eb674c9 4055 return;
4056 }
eeebe20b 4057 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
2eb674c9 4058 return;
4059
4060 if (sym->as)
4061 {
4062 int n;
4063
4064 if (sym->as->type != AS_EXPLICIT)
4065 return;
4066 for (n = 0; n < sym->as->rank; n++)
4067 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4068 || sym->as->upper[n] == NULL
4069 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4070 return;
4071 }
4072
4073 if (!check_constant_initializer (sym->value, &sym->ts,
4074 sym->attr.dimension, false))
4075 return;
4076
4077 /* Create the decl for the variable or constant. */
e60a6f7b 4078 decl = build_decl (input_location,
4079 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
2eb674c9 4080 gfc_sym_identifier (sym), gfc_sym_type (sym));
4081 if (sym->attr.flavor == FL_PARAMETER)
4082 TREE_READONLY (decl) = 1;
4083 gfc_set_decl_location (decl, &sym->declared_at);
4084 if (sym->attr.dimension)
4085 GFC_DECL_PACKED_ARRAY (decl) = 1;
4086 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4087 TREE_STATIC (decl) = 1;
4088 TREE_USED (decl) = 1;
4089 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4090 TREE_PUBLIC (decl) = 1;
802532b9 4091 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4092 TREE_TYPE (decl),
4093 sym->attr.dimension,
4094 false, false);
2eb674c9 4095 debug_hooks->global_decl (decl);
4096}
4097
51d9479b 4098/* Generate all the required code for module variables. */
4099
4100void
4101gfc_generate_module_vars (gfc_namespace * ns)
4102{
4103 module_namespace = ns;
4104 cur_module = gfc_find_module (ns->proc_name->name);
4105
4106 /* Check if the frontend left the namespace in a reasonable state. */
4107 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4108
4109 /* Generate COMMON blocks. */
4110 gfc_trans_common (ns);
4111
4112 /* Create decls for all the module variables. */
4113 gfc_traverse_ns (ns, gfc_create_module_variable);
4114
4115 cur_module = NULL;
4116
4117 gfc_trans_use_stmts (ns);
2eb674c9 4118 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
51d9479b 4119}
4120
4121
4ee9c684 4122static void
4123gfc_generate_contained_functions (gfc_namespace * parent)
4124{
4125 gfc_namespace *ns;
4126
4127 /* We create all the prototypes before generating any code. */
4128 for (ns = parent->contained; ns; ns = ns->sibling)
4129 {
4130 /* Skip namespaces from used modules. */
4131 if (ns->parent != parent)
4132 continue;
4133
d896f9b3 4134 gfc_create_function_decl (ns, false);
4ee9c684 4135 }
4136
4137 for (ns = parent->contained; ns; ns = ns->sibling)
4138 {
4139 /* Skip namespaces from used modules. */
4140 if (ns->parent != parent)
4141 continue;
4142
4143 gfc_generate_function_code (ns);
4144 }
4145}
4146
4147
d95efb59 4148/* Drill down through expressions for the array specification bounds and
4149 character length calling generate_local_decl for all those variables
4150 that have not already been declared. */
4151
4152static void
4153generate_local_decl (gfc_symbol *);
4154
1acb400a 4155/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
d95efb59 4156
1acb400a 4157static bool
4158expr_decls (gfc_expr *e, gfc_symbol *sym,
4159 int *f ATTRIBUTE_UNUSED)
4160{
4161 if (e->expr_type != EXPR_VARIABLE
4162 || sym == e->symtree->n.sym
d95efb59 4163 || e->symtree->n.sym->mark
4164 || e->symtree->n.sym->ns != sym->ns)
1acb400a 4165 return false;
d95efb59 4166
1acb400a 4167 generate_local_decl (e->symtree->n.sym);
4168 return false;
4169}
d95efb59 4170
1acb400a 4171static void
4172generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4173{
4174 gfc_traverse_expr (e, sym, expr_decls, 0);
d95efb59 4175}
4176
4177
f6d0e37a 4178/* Check for dependencies in the character length and array spec. */
d95efb59 4179
4180static void
4181generate_dependency_declarations (gfc_symbol *sym)
4182{
4183 int i;
4184
4185 if (sym->ts.type == BT_CHARACTER
eeebe20b 4186 && sym->ts.u.cl
4187 && sym->ts.u.cl->length
4188 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4189 generate_expr_decls (sym, sym->ts.u.cl->length);
d95efb59 4190
4191 if (sym->as && sym->as->rank)
4192 {
4193 for (i = 0; i < sym->as->rank; i++)
4194 {
4195 generate_expr_decls (sym, sym->as->lower[i]);
4196 generate_expr_decls (sym, sym->as->upper[i]);
4197 }
4198 }
4199}
4200
4201
4ee9c684 4202/* Generate decls for all local variables. We do this to ensure correct
4203 handling of expressions which only appear in the specification of
4204 other functions. */
4205
4206static void
4207generate_local_decl (gfc_symbol * sym)
4208{
4209 if (sym->attr.flavor == FL_VARIABLE)
4210 {
d95efb59 4211 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
8714fc76 4212 generate_dependency_declarations (sym);
d95efb59 4213
4ee9c684 4214 if (sym->attr.referenced)
8714fc76 4215 gfc_get_symbol_decl (sym);
4acad347 4216
4217 /* Warnings for unused dummy arguments. */
4218 else if (sym->attr.dummy)
7c0ca46e 4219 {
4acad347 4220 /* INTENT(out) dummy arguments are likely meant to be set. */
4221 if (gfc_option.warn_unused_dummy_argument
4222 && sym->attr.intent == INTENT_OUT)
4223 {
4224 if (sym->ts.type != BT_DERIVED)
4225 gfc_warning ("Dummy argument '%s' at %L was declared "
4226 "INTENT(OUT) but was not set", sym->name,
4227 &sym->declared_at);
4228 else if (!gfc_has_default_initializer (sym->ts.u.derived))
4229 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4230 "declared INTENT(OUT) but was not set and "
4231 "does not have a default initializer",
4232 sym->name, &sym->declared_at);
4233 }
4234 else if (gfc_option.warn_unused_dummy_argument)
4235 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4236 &sym->declared_at);
7c0ca46e 4237 }
4acad347 4238
f888a3fb 4239 /* Warn for unused variables, but not if they're inside a common
72c9bfbc 4240 block, a namelist, or are use-associated. */
36609028 4241 else if (warn_unused_variable
72c9bfbc 4242 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
4243 || sym->attr.in_namelist))
6ecfe89d 4244 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
d974cfde 4245 &sym->declared_at);
8714fc76 4246
d4163395 4247 /* For variable length CHARACTER parameters, the PARM_DECL already
4248 references the length variable, so force gfc_get_symbol_decl
4249 even when not referenced. If optimize > 0, it will be optimized
4250 away anyway. But do this only after emitting -Wunused-parameter
4251 warning if requested. */
8714fc76 4252 if (sym->attr.dummy && !sym->attr.referenced
4253 && sym->ts.type == BT_CHARACTER
eeebe20b 4254 && sym->ts.u.cl->backend_decl != NULL
4255 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
d4163395 4256 {
4257 sym->attr.referenced = 1;
4258 gfc_get_symbol_decl (sym);
4259 }
76776e6d 4260
d0163401 4261 /* INTENT(out) dummy arguments and result variables with allocatable
4262 components are reset by default and need to be set referenced to
4263 generate the code for nullification and automatic lengths. */
4264 if (!sym->attr.referenced
8714fc76 4265 && sym->ts.type == BT_DERIVED
eeebe20b 4266 && sym->ts.u.derived->attr.alloc_comp
c49db15e 4267 && !sym->attr.pointer
d0163401 4268 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4269 ||
4270 (sym->attr.result && sym != sym->result)))
8714fc76 4271 {
4272 sym->attr.referenced = 1;
4273 gfc_get_symbol_decl (sym);
4274 }
4275
e72f979a 4276 /* Check for dependencies in the array specification and string
4277 length, adding the necessary declarations to the function. We
4278 mark the symbol now, as well as in traverse_ns, to prevent
4279 getting stuck in a circular dependency. */
4280 sym->mark = 1;
4281
76776e6d 4282 /* We do not want the middle-end to warn about unused parameters
4283 as this was already done above. */
4284 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
4285 TREE_NO_WARNING(sym->backend_decl) = 1;
4ee9c684 4286 }
5dd246c1 4287 else if (sym->attr.flavor == FL_PARAMETER)
4288 {
6ecfe89d 4289 if (warn_unused_parameter
5dd246c1 4290 && !sym->attr.referenced
4291 && !sym->attr.use_assoc)
6ecfe89d 4292 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
5dd246c1 4293 &sym->declared_at);
4294 }
fa7b6574 4295 else if (sym->attr.flavor == FL_PROCEDURE)
4296 {
4297 /* TODO: move to the appropriate place in resolve.c. */
4298 if (warn_return_type
4299 && sym->attr.function
4300 && sym->result
4301 && sym != sym->result
4302 && !sym->result->attr.referenced
4303 && !sym->attr.use_assoc
4304 && sym->attr.if_source != IFSRC_IFBODY)
4305 {
4306 gfc_warning ("Return value '%s' of function '%s' declared at "
4307 "%L not set", sym->result->name, sym->name,
4308 &sym->result->declared_at);
4309
4310 /* Prevents "Unused variable" warning for RESULT variables. */
e72f979a 4311 sym->result->mark = 1;
fa7b6574 4312 }
4313 }
c5d33754 4314
19ba2ad8 4315 if (sym->attr.dummy == 1)
4316 {
4317 /* Modify the tree type for scalar character dummy arguments of bind(c)
4318 procedures if they are passed by value. The tree type for them will
4319 be promoted to INTEGER_TYPE for the middle end, which appears to be
4320 what C would do with characters passed by-value. The value attribute
4321 implies the dummy is a scalar. */
4322 if (sym->attr.value == 1 && sym->backend_decl != NULL
4323 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4324 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4c47c8b7 4325 gfc_conv_scalar_char_value (sym, NULL, NULL);
19ba2ad8 4326 }
4327
c5d33754 4328 /* Make sure we convert the types of the derived types from iso_c_binding
4329 into (void *). */
4330 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4331 && sym->ts.type == BT_DERIVED)
4332 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4ee9c684 4333}
4334
4335static void
4336generate_local_vars (gfc_namespace * ns)
4337{
4338 gfc_traverse_ns (ns, generate_local_decl);
4339}
4340
4341
1b716045 4342/* Generate a switch statement to jump to the correct entry point. Also
4343 creates the label decls for the entry points. */
4ee9c684 4344
1b716045 4345static tree
4346gfc_trans_entry_master_switch (gfc_entry_list * el)
4ee9c684 4347{
1b716045 4348 stmtblock_t block;
4349 tree label;
4350 tree tmp;
4351 tree val;
4ee9c684 4352
1b716045 4353 gfc_init_block (&block);
4354 for (; el; el = el->next)
4355 {
4356 /* Add the case label. */
b797d6d3 4357 label = gfc_build_label_decl (NULL_TREE);
7016c612 4358 val = build_int_cst (gfc_array_index_type, el->id);
ed52ef8b 4359 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
1b716045 4360 gfc_add_expr_to_block (&block, tmp);
5b11d932 4361
1b716045 4362 /* And jump to the actual entry point. */
4363 label = gfc_build_label_decl (NULL_TREE);
1b716045 4364 tmp = build1_v (GOTO_EXPR, label);
4365 gfc_add_expr_to_block (&block, tmp);
4366
4367 /* Save the label decl. */
4368 el->label = label;
4369 }
4370 tmp = gfc_finish_block (&block);
4371 /* The first argument selects the entry point. */
4372 val = DECL_ARGUMENTS (current_function_decl);
ed52ef8b 4373 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
1b716045 4374 return tmp;
4ee9c684 4375}
4376
6374121b 4377
a4abf8a0 4378/* Add code to string lengths of actual arguments passed to a function against
4379 the expected lengths of the dummy arguments. */
4380
4381static void
4382add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4383{
4384 gfc_formal_arglist *formal;
4385
4386 for (formal = sym->formal; formal; formal = formal->next)
4387 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4388 {
4389 enum tree_code comparison;
4390 tree cond;
4391 tree argname;
4392 gfc_symbol *fsym;
4393 gfc_charlen *cl;
4394 const char *message;
4395
4396 fsym = formal->sym;
eeebe20b 4397 cl = fsym->ts.u.cl;
a4abf8a0 4398
4399 gcc_assert (cl);
4400 gcc_assert (cl->passed_length != NULL_TREE);
4401 gcc_assert (cl->backend_decl != NULL_TREE);
4402
4403 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4404 string lengths must match exactly. Otherwise, it is only required
be4be771 4405 that the actual string length is *at least* the expected one.
4406 Sequence association allows for a mismatch of the string length
4407 if the actual argument is (part of) an array, but only if the
4408 dummy argument is an array. (See "Sequence association" in
4409 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
a4abf8a0 4410 if (fsym->attr.pointer || fsym->attr.allocatable
4411 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4412 {
4413 comparison = NE_EXPR;
4414 message = _("Actual string length does not match the declared one"
4415 " for dummy argument '%s' (%ld/%ld)");
4416 }
be4be771 4417 else if (fsym->as && fsym->as->rank != 0)
4418 continue;
a4abf8a0 4419 else
4420 {
4421 comparison = LT_EXPR;
4422 message = _("Actual string length is shorter than the declared one"
4423 " for dummy argument '%s' (%ld/%ld)");
4424 }
4425
4426 /* Build the condition. For optional arguments, an actual length
4427 of 0 is also acceptable if the associated string is NULL, which
4428 means the argument was not passed. */
fd779e1d 4429 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4430 cl->passed_length, cl->backend_decl);
a4abf8a0 4431 if (fsym->attr.optional)
4432 {
4433 tree not_absent;
4434 tree not_0length;
4435 tree absent_failed;
4436
fd779e1d 4437 not_0length = fold_build2_loc (input_location, NE_EXPR,
4438 boolean_type_node,
4439 cl->passed_length,
385f3f36 4440 build_zero_cst (gfc_charlen_type_node));
5fa0fdc2 4441 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4442 fsym->attr.referenced = 1;
4443 not_absent = gfc_conv_expr_present (fsym);
a4abf8a0 4444
fd779e1d 4445 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4446 boolean_type_node, not_0length,
4447 not_absent);
a4abf8a0 4448
fd779e1d 4449 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4450 boolean_type_node, cond, absent_failed);
a4abf8a0 4451 }
4452
4453 /* Build the runtime check. */
4454 argname = gfc_build_cstring_const (fsym->name);
4455 argname = gfc_build_addr_expr (pchar_type_node, argname);
4456 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4457 message, argname,
4458 fold_convert (long_integer_type_node,
4459 cl->passed_length),
4460 fold_convert (long_integer_type_node,
4461 cl->backend_decl));
4462 }
4463}
4464
4465
70b5944a 4466void
4467gfc_init_coarray_decl (void)
4468{
4469 tree save_fn_decl = current_function_decl;
4470
4471 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
4472 return;
4473
4474 if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
4475 return;
4476
4477 save_fn_decl = current_function_decl;
4478 current_function_decl = NULL_TREE;
4479 push_cfun (cfun);
4480
4481 gfort_gvar_caf_this_image = gfc_create_var (integer_type_node,
4482 PREFIX("caf_this_image"));
4483 DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
4484 TREE_USED (gfort_gvar_caf_this_image) = 1;
4485 TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
4486 TREE_STATIC (gfort_gvar_caf_this_image) = 1;
4487
4488 gfort_gvar_caf_num_images = gfc_create_var (integer_type_node,
4489 PREFIX("caf_num_images"));
4490 DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
4491 TREE_USED (gfort_gvar_caf_num_images) = 1;
4492 TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
4493 TREE_STATIC (gfort_gvar_caf_num_images) = 1;
4494
4495 pop_cfun ();
4496 current_function_decl = save_fn_decl;
4497}
4498
4499
7257a5d2 4500static void
4501create_main_function (tree fndecl)
4502{
43702da6 4503 tree old_context;
7257a5d2 4504 tree ftn_main;
4505 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4506 stmtblock_t body;
4507
43702da6 4508 old_context = current_function_decl;
4509
4510 if (old_context)
4511 {
4512 push_function_context ();
4513 saved_parent_function_decls = saved_function_decls;
4514 saved_function_decls = NULL_TREE;
4515 }
4516
7257a5d2 4517 /* main() function must be declared with global scope. */
4518 gcc_assert (current_function_decl == NULL_TREE);
4519
4520 /* Declare the function. */
4521 tmp = build_function_type_list (integer_type_node, integer_type_node,
4522 build_pointer_type (pchar_type_node),
4523 NULL_TREE);
0509d0ee 4524 main_identifier_node = get_identifier ("main");
e60a6f7b 4525 ftn_main = build_decl (input_location, FUNCTION_DECL,
4526 main_identifier_node, tmp);
7257a5d2 4527 DECL_EXTERNAL (ftn_main) = 0;
4528 TREE_PUBLIC (ftn_main) = 1;
4529 TREE_STATIC (ftn_main) = 1;
4530 DECL_ATTRIBUTES (ftn_main)
4531 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4532
4533 /* Setup the result declaration (for "return 0"). */
e60a6f7b 4534 result_decl = build_decl (input_location,
4535 RESULT_DECL, NULL_TREE, integer_type_node);
7257a5d2 4536 DECL_ARTIFICIAL (result_decl) = 1;
4537 DECL_IGNORED_P (result_decl) = 1;
4538 DECL_CONTEXT (result_decl) = ftn_main;
4539 DECL_RESULT (ftn_main) = result_decl;
4540
4541 pushdecl (ftn_main);
4542
4543 /* Get the arguments. */
4544
4545 arglist = NULL_TREE;
4546 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4547
4548 tmp = TREE_VALUE (typelist);
e60a6f7b 4549 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
7257a5d2 4550 DECL_CONTEXT (argc) = ftn_main;
4551 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4552 TREE_READONLY (argc) = 1;
4553 gfc_finish_decl (argc);
4554 arglist = chainon (arglist, argc);
4555
4556 typelist = TREE_CHAIN (typelist);
4557 tmp = TREE_VALUE (typelist);
e60a6f7b 4558 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
7257a5d2 4559 DECL_CONTEXT (argv) = ftn_main;
4560 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4561 TREE_READONLY (argv) = 1;
4562 DECL_BY_REFERENCE (argv) = 1;
4563 gfc_finish_decl (argv);
4564 arglist = chainon (arglist, argv);
4565
4566 DECL_ARGUMENTS (ftn_main) = arglist;
4567 current_function_decl = ftn_main;
4568 announce_function (ftn_main);
4569
4570 rest_of_decl_compilation (ftn_main, 1, 0);
4571 make_decl_rtl (ftn_main);
4572 init_function_start (ftn_main);
4573 pushlevel (0);
4574
4575 gfc_init_block (&body);
4576
4577 /* Call some libgfortran initialization routines, call then MAIN__(). */
4578
70b5944a 4579 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
4580 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4581 {
4582 tree pint_type, pppchar_type;
4583 pint_type = build_pointer_type (integer_type_node);
4584 pppchar_type
4585 = build_pointer_type (build_pointer_type (pchar_type_node));
4586
4587 gfc_init_coarray_decl ();
4588 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
4589 gfc_build_addr_expr (pint_type, argc),
4590 gfc_build_addr_expr (pppchar_type, argv),
4591 gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
4592 gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
4593 gfc_add_expr_to_block (&body, tmp);
4594 }
4595
7257a5d2 4596 /* Call _gfortran_set_args (argc, argv). */
43702da6 4597 TREE_USED (argc) = 1;
4598 TREE_USED (argv) = 1;
389dd41b 4599 tmp = build_call_expr_loc (input_location,
4600 gfor_fndecl_set_args, 2, argc, argv);
7257a5d2 4601 gfc_add_expr_to_block (&body, tmp);
4602
4603 /* Add a call to set_options to set up the runtime library Fortran
4604 language standard parameters. */
4605 {
4606 tree array_type, array, var;
06f13dc1 4607 VEC(constructor_elt,gc) *v = NULL;
7257a5d2 4608
4609 /* Passing a new option to the library requires four modifications:
4610 + add it to the tree_cons list below
4611 + change the array size in the call to build_array_type
4612 + change the first argument to the library call
4613 gfor_fndecl_set_options
4614 + modify the library (runtime/compile_options.c)! */
4615
06f13dc1 4616 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4617 build_int_cst (integer_type_node,
4618 gfc_option.warn_std));
4619 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4620 build_int_cst (integer_type_node,
4621 gfc_option.allow_std));
4622 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4623 build_int_cst (integer_type_node, pedantic));
4624 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4625 build_int_cst (integer_type_node,
4626 gfc_option.flag_dump_core));
4627 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4628 build_int_cst (integer_type_node,
4629 gfc_option.flag_backtrace));
4630 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4631 build_int_cst (integer_type_node,
4632 gfc_option.flag_sign_zero));
4633 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4634 build_int_cst (integer_type_node,
4635 (gfc_option.rtcheck
4636 & GFC_RTCHECK_BOUNDS)));
4637 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4638 build_int_cst (integer_type_node,
4639 gfc_option.flag_range_check));
7257a5d2 4640
4641 array_type = build_array_type (integer_type_node,
35bf1214 4642 build_index_type (size_int (7)));
06f13dc1 4643 array = build_constructor (array_type, v);
7257a5d2 4644 TREE_CONSTANT (array) = 1;
4645 TREE_STATIC (array) = 1;
4646
4647 /* Create a static variable to hold the jump table. */
4648 var = gfc_create_var (array_type, "options");
4649 TREE_CONSTANT (var) = 1;
4650 TREE_STATIC (var) = 1;
4651 TREE_READONLY (var) = 1;
4652 DECL_INITIAL (var) = array;
4653 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4654
389dd41b 4655 tmp = build_call_expr_loc (input_location,
4656 gfor_fndecl_set_options, 2,
7257a5d2 4657 build_int_cst (integer_type_node, 8), var);
4658 gfc_add_expr_to_block (&body, tmp);
4659 }
4660
4661 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4662 the library will raise a FPE when needed. */
4663 if (gfc_option.fpe != 0)
4664 {
389dd41b 4665 tmp = build_call_expr_loc (input_location,
4666 gfor_fndecl_set_fpe, 1,
7257a5d2 4667 build_int_cst (integer_type_node,
4668 gfc_option.fpe));
4669 gfc_add_expr_to_block (&body, tmp);
4670 }
4671
4672 /* If this is the main program and an -fconvert option was provided,
4673 add a call to set_convert. */
4674
4675 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4676 {
389dd41b 4677 tmp = build_call_expr_loc (input_location,
4678 gfor_fndecl_set_convert, 1,
7257a5d2 4679 build_int_cst (integer_type_node,
4680 gfc_option.convert));
4681 gfc_add_expr_to_block (&body, tmp);
4682 }
4683
4684 /* If this is the main program and an -frecord-marker option was provided,
4685 add a call to set_record_marker. */
4686
4687 if (gfc_option.record_marker != 0)
4688 {
389dd41b 4689 tmp = build_call_expr_loc (input_location,
4690 gfor_fndecl_set_record_marker, 1,
7257a5d2 4691 build_int_cst (integer_type_node,
4692 gfc_option.record_marker));
4693 gfc_add_expr_to_block (&body, tmp);
4694 }
4695
4696 if (gfc_option.max_subrecord_length != 0)
4697 {
389dd41b 4698 tmp = build_call_expr_loc (input_location,
4699 gfor_fndecl_set_max_subrecord_length, 1,
7257a5d2 4700 build_int_cst (integer_type_node,
4701 gfc_option.max_subrecord_length));
4702 gfc_add_expr_to_block (&body, tmp);
4703 }
4704
4705 /* Call MAIN__(). */
389dd41b 4706 tmp = build_call_expr_loc (input_location,
4707 fndecl, 0);
7257a5d2 4708 gfc_add_expr_to_block (&body, tmp);
4709
43702da6 4710 /* Mark MAIN__ as used. */
4711 TREE_USED (fndecl) = 1;
4712
70b5944a 4713 /* Coarray: Call _gfortran_caf_finalize(void). */
4714 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4715 {
4716 /* Per F2008, 8.5.1 END of the main program implies a
4717 SYNC MEMORY. */
4718 tmp = built_in_decls [BUILT_IN_SYNCHRONIZE];
4719 tmp = build_call_expr_loc (input_location, tmp, 0);
4720 gfc_add_expr_to_block (&body, tmp);
4721
4722 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
4723 gfc_add_expr_to_block (&body, tmp);
4724 }
4725
7257a5d2 4726 /* "return 0". */
fd779e1d 4727 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
4728 DECL_RESULT (ftn_main),
4729 build_int_cst (integer_type_node, 0));
7257a5d2 4730 tmp = build1_v (RETURN_EXPR, tmp);
4731 gfc_add_expr_to_block (&body, tmp);
4732
4733
4734 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4735 decl = getdecls ();
4736
4737 /* Finish off this function and send it for code generation. */
4738 poplevel (1, 0, 1);
4739 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4740
4741 DECL_SAVED_TREE (ftn_main)
4742 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4743 DECL_INITIAL (ftn_main));
4744
4745 /* Output the GENERIC tree. */
4746 dump_function (TDI_original, ftn_main);
4747
bb982f66 4748 cgraph_finalize_function (ftn_main, true);
43702da6 4749
4750 if (old_context)
4751 {
4752 pop_function_context ();
4753 saved_function_decls = saved_parent_function_decls;
4754 }
4755 current_function_decl = old_context;
7257a5d2 4756}
4757
4758
89ac8ba1 4759/* Get the result expression for a procedure. */
4760
4761static tree
4762get_proc_result (gfc_symbol* sym)
4763{
4764 if (sym->attr.subroutine || sym == sym->result)
4765 {
4766 if (current_fake_result_decl != NULL)
4767 return TREE_VALUE (current_fake_result_decl);
4768
4769 return NULL_TREE;
4770 }
4771
4772 return sym->result->backend_decl;
4773}
4774
4775
4776/* Generate an appropriate return-statement for a procedure. */
4777
4778tree
4779gfc_generate_return (void)
4780{
4781 gfc_symbol* sym;
4782 tree result;
4783 tree fndecl;
4784
4785 sym = current_procedure_symbol;
4786 fndecl = sym->backend_decl;
4787
4788 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
4789 result = NULL_TREE;
4790 else
4791 {
4792 result = get_proc_result (sym);
4793
4794 /* Set the return value to the dummy result variable. The
4795 types may be different for scalar default REAL functions
4796 with -ff2c, therefore we have to convert. */
4797 if (result != NULL_TREE)
4798 {
4799 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
fd779e1d 4800 result = fold_build2_loc (input_location, MODIFY_EXPR,
4801 TREE_TYPE (result), DECL_RESULT (fndecl),
4802 result);
89ac8ba1 4803 }
4804 }
4805
4806 return build1_v (RETURN_EXPR, result);
4807}
4808
4809
4ee9c684 4810/* Generate code for a function. */
4811
4812void
4813gfc_generate_function_code (gfc_namespace * ns)
4814{
4815 tree fndecl;
4816 tree old_context;
4817 tree decl;
4818 tree tmp;
89ac8ba1 4819 stmtblock_t init, cleanup;
4ee9c684 4820 stmtblock_t body;
89ac8ba1 4821 gfc_wrapped_block try_block;
5fa0fdc2 4822 tree recurcheckvar = NULL_TREE;
4ee9c684 4823 gfc_symbol *sym;
89ac8ba1 4824 gfc_symbol *previous_procedure_symbol;
2294b616 4825 int rank;
e50e62f5 4826 bool is_recursive;
4ee9c684 4827
4828 sym = ns->proc_name;
89ac8ba1 4829 previous_procedure_symbol = current_procedure_symbol;
4830 current_procedure_symbol = sym;
1b716045 4831
4ee9c684 4832 /* Check that the frontend isn't still using this. */
22d678e8 4833 gcc_assert (sym->tlink == NULL);
4ee9c684 4834 sym->tlink = sym;
4835
4836 /* Create the declaration for functions with global scope. */
4837 if (!sym->backend_decl)
d896f9b3 4838 gfc_create_function_decl (ns, false);
4ee9c684 4839
4840 fndecl = sym->backend_decl;
4841 old_context = current_function_decl;
4842
4843 if (old_context)
4844 {
4845 push_function_context ();
4846 saved_parent_function_decls = saved_function_decls;
4847 saved_function_decls = NULL_TREE;
4848 }
4849
1b716045 4850 trans_function_start (sym);
4ee9c684 4851
89ac8ba1 4852 gfc_init_block (&init);
4ee9c684 4853
c6871095 4854 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4855 {
4856 /* Copy length backend_decls to all entry point result
4857 symbols. */
4858 gfc_entry_list *el;
4859 tree backend_decl;
4860
eeebe20b 4861 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4862 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
c6871095 4863 for (el = ns->entries; el; el = el->next)
eeebe20b 4864 el->sym->result->ts.u.cl->backend_decl = backend_decl;
c6871095 4865 }
4866
4ee9c684 4867 /* Translate COMMON blocks. */
4868 gfc_trans_common (ns);
4869
c750cc52 4870 /* Null the parent fake result declaration if this namespace is
4871 a module function or an external procedures. */
4872 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4873 || ns->parent == NULL)
4874 parent_fake_result_decl = NULL_TREE;
4875
2b685f8e 4876 gfc_generate_contained_functions (ns);
4877
9579733e 4878 nonlocal_dummy_decls = NULL;
4879 nonlocal_dummy_decl_pset = NULL;
4880
4ee9c684 4881 generate_local_vars (ns);
5b11d932 4882
c750cc52 4883 /* Keep the parent fake result declaration in module functions
4884 or external procedures. */
4885 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4886 || ns->parent == NULL)
4887 current_fake_result_decl = parent_fake_result_decl;
4888 else
4889 current_fake_result_decl = NULL_TREE;
4890
89ac8ba1 4891 is_recursive = sym->attr.recursive
4892 || (sym->attr.entry_master
4893 && sym->ns->entries->sym->attr.recursive);
4894 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4895 && !is_recursive
4896 && !gfc_option.flag_recursive)
4897 {
4898 char * msg;
4899
4900 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4901 sym->name);
4902 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4903 TREE_STATIC (recurcheckvar) = 1;
4904 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4905 gfc_add_expr_to_block (&init, recurcheckvar);
4906 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
4907 &sym->declared_at, msg);
4908 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
434f0922 4909 free (msg);
89ac8ba1 4910 }
4ee9c684 4911
4912 /* Now generate the code for the body of this function. */
4913 gfc_init_block (&body);
4914
4915 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
89ac8ba1 4916 && sym->attr.subroutine)
4ee9c684 4917 {
4918 tree alternate_return;
c750cc52 4919 alternate_return = gfc_get_fake_result_decl (sym, 0);
75a70cf9 4920 gfc_add_modify (&body, alternate_return, integer_zero_node);
4ee9c684 4921 }
4922
1b716045 4923 if (ns->entries)
4924 {
4925 /* Jump to the correct entry point. */
4926 tmp = gfc_trans_entry_master_switch (ns->entries);
4927 gfc_add_expr_to_block (&body, tmp);
4928 }
4929
a4abf8a0 4930 /* If bounds-checking is enabled, generate code to check passed in actual
4931 arguments against the expected dummy argument attributes (e.g. string
4932 lengths). */
c1630d65 4933 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
a4abf8a0 4934 add_argument_checking (&body, sym);
4935
4ee9c684 4936 tmp = gfc_trans_code (ns->code);
4937 gfc_add_expr_to_block (&body, tmp);
4938
4ee9c684 4939 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4940 {
89ac8ba1 4941 tree result = get_proc_result (sym);
4ee9c684 4942
5fa0fdc2 4943 if (result != NULL_TREE
4944 && sym->attr.function
4945 && !sym->attr.pointer)
2294b616 4946 {
deb7edfc 4947 if (sym->attr.allocatable && sym->attr.dimension == 0
4948 && sym->result == sym)
4949 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
4950 null_pointer_node));
4951 else if (sym->ts.type == BT_DERIVED
4952 && sym->ts.u.derived->attr.alloc_comp
4953 && !sym->attr.allocatable)
53169279 4954 {
4955 rank = sym->as ? sym->as->rank : 0;
89ac8ba1 4956 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4957 gfc_add_expr_to_block (&init, tmp);
53169279 4958 }
5176859a 4959 }
e50e62f5 4960
fa7b6574 4961 if (result == NULL_TREE)
4962 {
4963 /* TODO: move to the appropriate place in resolve.c. */
4964 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4965 gfc_warning ("Return value of function '%s' at %L not set",
4966 sym->name, &sym->declared_at);
2294b616 4967
fa7b6574 4968 TREE_NO_WARNING(sym->backend_decl) = 1;
4969 }
4ee9c684 4970 else
89ac8ba1 4971 gfc_add_expr_to_block (&body, gfc_generate_return ());
4ee9c684 4972 }
89ac8ba1 4973
4974 gfc_init_block (&cleanup);
4975
4976 /* Reset recursion-check variable. */
4977 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4978 && !is_recursive
5ae82d58 4979 && !gfc_option.gfc_flag_openmp
89ac8ba1 4980 && recurcheckvar != NULL_TREE)
e50e62f5 4981 {
89ac8ba1 4982 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
4983 recurcheckvar = NULL;
e50e62f5 4984 }
2294b616 4985
89ac8ba1 4986 /* Finish the function body and add init and cleanup code. */
4987 tmp = gfc_finish_block (&body);
4988 gfc_start_wrapped_block (&try_block, tmp);
4989 /* Add code to create and cleanup arrays. */
4990 gfc_trans_deferred_vars (sym, &try_block);
4991 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
4992 gfc_finish_block (&cleanup));
4ee9c684 4993
4994 /* Add all the decls we created during processing. */
4995 decl = saved_function_decls;
4996 while (decl)
4997 {
4998 tree next;
4999
1767a056 5000 next = DECL_CHAIN (decl);
5001 DECL_CHAIN (decl) = NULL_TREE;
4ee9c684 5002 pushdecl (decl);
5003 decl = next;
5004 }
5005 saved_function_decls = NULL_TREE;
5006
89ac8ba1 5007 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
e5004242 5008 decl = getdecls ();
4ee9c684 5009
5010 /* Finish off this function and send it for code generation. */
5011 poplevel (1, 0, 1);
5012 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5013
e5004242 5014 DECL_SAVED_TREE (fndecl)
5015 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5016 DECL_INITIAL (fndecl));
5017
9579733e 5018 if (nonlocal_dummy_decls)
5019 {
5020 BLOCK_VARS (DECL_INITIAL (fndecl))
5021 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5022 pointer_set_destroy (nonlocal_dummy_decl_pset);
5023 nonlocal_dummy_decls = NULL;
5024 nonlocal_dummy_decl_pset = NULL;
5025 }
5026
4ee9c684 5027 /* Output the GENERIC tree. */
5028 dump_function (TDI_original, fndecl);
5029
5030 /* Store the end of the function, so that we get good line number
5031 info for the epilogue. */
5032 cfun->function_end_locus = input_location;
5033
5034 /* We're leaving the context of this function, so zap cfun.
5035 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5036 tree_rest_of_compilation. */
87d4aa85 5037 set_cfun (NULL);
4ee9c684 5038
5039 if (old_context)
5040 {
5041 pop_function_context ();
5042 saved_function_decls = saved_parent_function_decls;
5043 }
5044 current_function_decl = old_context;
5045
5046 if (decl_function_context (fndecl))
6374121b 5047 /* Register this function with cgraph just far enough to get it
5048 added to our parent's nested function list. */
460beda6 5049 (void) cgraph_create_node (fndecl);
4ee9c684 5050 else
bb982f66 5051 cgraph_finalize_function (fndecl, true);
df4d540f 5052
5053 gfc_trans_use_stmts (ns);
2eb674c9 5054 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
7257a5d2 5055
5056 if (sym->attr.is_main_program)
5057 create_main_function (fndecl);
89ac8ba1 5058
5059 current_procedure_symbol = previous_procedure_symbol;
4ee9c684 5060}
5061
7257a5d2 5062
4ee9c684 5063void
5064gfc_generate_constructors (void)
5065{
22d678e8 5066 gcc_assert (gfc_static_ctors == NULL_TREE);
4ee9c684 5067#if 0
5068 tree fnname;
5069 tree type;
5070 tree fndecl;
5071 tree decl;
5072 tree tmp;
5073
5074 if (gfc_static_ctors == NULL_TREE)
5075 return;
5076
db85cc4f 5077 fnname = get_file_function_name ("I");
e1036019 5078 type = build_function_type_list (void_type_node, NULL_TREE);
4ee9c684 5079
e60a6f7b 5080 fndecl = build_decl (input_location,
5081 FUNCTION_DECL, fnname, type);
4ee9c684 5082 TREE_PUBLIC (fndecl) = 1;
5083
e60a6f7b 5084 decl = build_decl (input_location,
5085 RESULT_DECL, NULL_TREE, void_type_node);
540edea7 5086 DECL_ARTIFICIAL (decl) = 1;
5087 DECL_IGNORED_P (decl) = 1;
4ee9c684 5088 DECL_CONTEXT (decl) = fndecl;
5089 DECL_RESULT (fndecl) = decl;
5090
5091 pushdecl (fndecl);
5092
5093 current_function_decl = fndecl;
5094
b2c4af5e 5095 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 5096
b2c4af5e 5097 make_decl_rtl (fndecl);
4ee9c684 5098
b31f705b 5099 init_function_start (fndecl);
4ee9c684 5100
4ee9c684 5101 pushlevel (0);
5102
5103 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5104 {
389dd41b 5105 tmp = build_call_expr_loc (input_location,
5106 TREE_VALUE (gfc_static_ctors), 0);
e60a6f7b 5107 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4ee9c684 5108 }
5109
e5004242 5110 decl = getdecls ();
4ee9c684 5111 poplevel (1, 0, 1);
5112
5113 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
e5004242 5114 DECL_SAVED_TREE (fndecl)
5115 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5116 DECL_INITIAL (fndecl));
4ee9c684 5117
5118 free_after_parsing (cfun);
5119 free_after_compilation (cfun);
5120
6148a911 5121 tree_rest_of_compilation (fndecl);
4ee9c684 5122
5123 current_function_decl = NULL_TREE;
5124#endif
5125}
5126
9ec7c303 5127/* Translates a BLOCK DATA program unit. This means emitting the
5128 commons contained therein plus their initializations. We also emit
5129 a globally visible symbol to make sure that each BLOCK DATA program
5130 unit remains unique. */
5131
5132void
5133gfc_generate_block_data (gfc_namespace * ns)
5134{
5135 tree decl;
5136 tree id;
5137
b31f705b 5138 /* Tell the backend the source location of the block data. */
5139 if (ns->proc_name)
5140 gfc_set_backend_locus (&ns->proc_name->declared_at);
5141 else
5142 gfc_set_backend_locus (&gfc_current_locus);
5143
5144 /* Process the DATA statements. */
9ec7c303 5145 gfc_trans_common (ns);
5146
b31f705b 5147 /* Create a global symbol with the mane of the block data. This is to
5148 generate linker errors if the same name is used twice. It is never
5149 really used. */
9ec7c303 5150 if (ns->proc_name)
5151 id = gfc_sym_mangled_function_id (ns->proc_name);
5152 else
5153 id = get_identifier ("__BLOCK_DATA__");
5154
e60a6f7b 5155 decl = build_decl (input_location,
5156 VAR_DECL, id, gfc_array_index_type);
9ec7c303 5157 TREE_PUBLIC (decl) = 1;
5158 TREE_STATIC (decl) = 1;
df4d540f 5159 DECL_IGNORED_P (decl) = 1;
9ec7c303 5160
5161 pushdecl (decl);
5162 rest_of_decl_compilation (decl, 1, 0);
5163}
5164
b549d2a5 5165
6a7084d7 5166/* Process the local variables of a BLOCK construct. */
5167
5168void
3c82e013 5169gfc_process_block_locals (gfc_namespace* ns)
6a7084d7 5170{
5171 tree decl;
5172
5173 gcc_assert (saved_local_decls == NULL_TREE);
5174 generate_local_vars (ns);
5175
5176 decl = saved_local_decls;
5177 while (decl)
5178 {
5179 tree next;
5180
1767a056 5181 next = DECL_CHAIN (decl);
5182 DECL_CHAIN (decl) = NULL_TREE;
6a7084d7 5183 pushdecl (decl);
5184 decl = next;
5185 }
5186 saved_local_decls = NULL_TREE;
5187}
5188
5189
4ee9c684 5190#include "gt-fortran-trans-decl.h"
Mirror of https://gcc.gnu.org/git/gcc.git