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