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