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