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