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