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