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