]> 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
* gcc-interface/utils.c (gnat_type_for_mode): Handle vector modes.
[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;
5176859a 3196
0a96a7cc 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
5176859a 3209 /* Note: Nullifying is not needed. */
0a96a7cc 3210 tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL);
3211 gfc_add_expr_to_block (&block, tmp);
0a96a7cc 3212 fnbody = gfc_finish_block (&block);
3213 }
4ee9c684 3214 else if (sym->ts.type == BT_CHARACTER)
3215 {
3216 gfc_get_backend_locus (&loc);
3217 gfc_set_backend_locus (&sym->declared_at);
3218 if (sym->attr.dummy || sym->attr.result)
eeebe20b 3219 fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
4ee9c684 3220 else
3221 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3222 gfc_set_backend_locus (&loc);
3223 }
c8f1568f 3224 else if (sym->attr.assign)
3225 {
3226 gfc_get_backend_locus (&loc);
3227 gfc_set_backend_locus (&sym->declared_at);
3228 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3229 gfc_set_backend_locus (&loc);
3230 }
f0d4969f 3231 else if (sym->ts.type == BT_DERIVED
3232 && sym->value
3233 && !sym->attr.data
3234 && sym->attr.save == SAVE_NONE)
89e89e42 3235 fnbody = gfc_init_default_dt (sym, fnbody);
4ee9c684 3236 else
22d678e8 3237 gcc_unreachable ();
4ee9c684 3238 }
3239
d4163395 3240 gfc_init_block (&body);
3241
3242 for (f = proc_sym->formal; f; f = f->next)
1e853e89 3243 {
3244 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3245 {
eeebe20b 3246 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3247 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
1e853e89 3248 gfc_trans_vla_type_sizes (f->sym, &body);
3249 }
1e853e89 3250 }
d4163395 3251
3252 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3253 && current_fake_result_decl != NULL)
3254 {
eeebe20b 3255 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3256 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
d4163395 3257 gfc_trans_vla_type_sizes (proc_sym, &body);
3258 }
3259
3260 gfc_add_expr_to_block (&body, fnbody);
3261 return gfc_finish_block (&body);
4ee9c684 3262}
3263
df4d540f 3264static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3265
3266/* Hash and equality functions for module_htab. */
3267
3268static hashval_t
3269module_htab_do_hash (const void *x)
3270{
3271 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3272}
3273
3274static int
3275module_htab_eq (const void *x1, const void *x2)
3276{
3277 return strcmp ((((const struct module_htab_entry *)x1)->name),
3278 (const char *)x2) == 0;
3279}
3280
3281/* Hash and equality functions for module_htab's decls. */
3282
3283static hashval_t
3284module_htab_decls_hash (const void *x)
3285{
3286 const_tree t = (const_tree) x;
3287 const_tree n = DECL_NAME (t);
3288 if (n == NULL_TREE)
3289 n = TYPE_NAME (TREE_TYPE (t));
3290 return htab_hash_string (IDENTIFIER_POINTER (n));
3291}
3292
3293static int
3294module_htab_decls_eq (const void *x1, const void *x2)
3295{
3296 const_tree t1 = (const_tree) x1;
3297 const_tree n1 = DECL_NAME (t1);
3298 if (n1 == NULL_TREE)
3299 n1 = TYPE_NAME (TREE_TYPE (t1));
3300 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3301}
3302
3303struct module_htab_entry *
3304gfc_find_module (const char *name)
3305{
3306 void **slot;
3307
3308 if (! module_htab)
3309 module_htab = htab_create_ggc (10, module_htab_do_hash,
3310 module_htab_eq, NULL);
3311
3312 slot = htab_find_slot_with_hash (module_htab, name,
3313 htab_hash_string (name), INSERT);
3314 if (*slot == NULL)
3315 {
3316 struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3317
3318 entry->name = gfc_get_string (name);
3319 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3320 module_htab_decls_eq, NULL);
3321 *slot = (void *) entry;
3322 }
3323 return (struct module_htab_entry *) *slot;
3324}
3325
3326void
3327gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3328{
3329 void **slot;
3330 const char *name;
3331
3332 if (DECL_NAME (decl))
3333 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3334 else
3335 {
3336 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3337 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3338 }
3339 slot = htab_find_slot_with_hash (entry->decls, name,
3340 htab_hash_string (name), INSERT);
3341 if (*slot == NULL)
3342 *slot = (void *) decl;
3343}
3344
3345static struct module_htab_entry *cur_module;
4ee9c684 3346
3347/* Output an initialized decl for a module variable. */
3348
3349static void
3350gfc_create_module_variable (gfc_symbol * sym)
3351{
3352 tree decl;
4ee9c684 3353
d77f260f 3354 /* Module functions with alternate entries are dealt with later and
3355 would get caught by the next condition. */
3356 if (sym->attr.entry)
3357 return;
3358
c5d33754 3359 /* Make sure we convert the types of the derived types from iso_c_binding
3360 into (void *). */
3361 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3362 && sym->ts.type == BT_DERIVED)
3363 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3364
df4d540f 3365 if (sym->attr.flavor == FL_DERIVED
3366 && sym->backend_decl
3367 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3368 {
3369 decl = sym->backend_decl;
3370 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3371 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3372 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3373 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3374 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3375 == sym->ns->proc_name->backend_decl);
3376 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3377 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3378 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3379 }
3380
cf269acc 3381 /* Only output variables, procedure pointers and array valued,
3382 or derived type, parameters. */
4ee9c684 3383 if (sym->attr.flavor != FL_VARIABLE
be0f1581 3384 && !(sym->attr.flavor == FL_PARAMETER
cf269acc 3385 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3386 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4ee9c684 3387 return;
3388
df4d540f 3389 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3390 {
3391 decl = sym->backend_decl;
3392 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3393 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3394 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3395 gfc_module_add_decl (cur_module, decl);
3396 }
3397
d43a7f7f 3398 /* Don't generate variables from other modules. Variables from
3399 COMMONs will already have been generated. */
3400 if (sym->attr.use_assoc || sym->attr.in_common)
4ee9c684 3401 return;
3402
2b685f8e 3403 /* Equivalenced variables arrive here after creation. */
976d903a 3404 if (sym->backend_decl
df4d540f 3405 && (sym->equiv_built || sym->attr.in_equivalence))
3406 return;
2b685f8e 3407
4ee9c684 3408 if (sym->backend_decl)
3409 internal_error ("backend decl for module variable %s already exists",
3410 sym->name);
3411
3412 /* We always want module variables to be created. */
3413 sym->attr.referenced = 1;
3414 /* Create the decl. */
3415 decl = gfc_get_symbol_decl (sym);
3416
4ee9c684 3417 /* Create the variable. */
3418 pushdecl (decl);
df4d540f 3419 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3420 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3421 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
b2c4af5e 3422 rest_of_decl_compilation (decl, 1, 0);
df4d540f 3423 gfc_module_add_decl (cur_module, decl);
4ee9c684 3424
3425 /* Also add length of strings. */
3426 if (sym->ts.type == BT_CHARACTER)
3427 {
3428 tree length;
3429
eeebe20b 3430 length = sym->ts.u.cl->backend_decl;
4ee9c684 3431 if (!INTEGER_CST_P (length))
3432 {
3433 pushdecl (length);
b2c4af5e 3434 rest_of_decl_compilation (length, 1, 0);
4ee9c684 3435 }
3436 }
3437}
3438
51d9479b 3439/* Emit debug information for USE statements. */
df4d540f 3440
3441static void
3442gfc_trans_use_stmts (gfc_namespace * ns)
3443{
3444 gfc_use_list *use_stmt;
3445 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3446 {
3447 struct module_htab_entry *entry
3448 = gfc_find_module (use_stmt->module_name);
3449 gfc_use_rename *rent;
3450
3451 if (entry->namespace_decl == NULL)
3452 {
3453 entry->namespace_decl
e60a6f7b 3454 = build_decl (input_location,
3455 NAMESPACE_DECL,
df4d540f 3456 get_identifier (use_stmt->module_name),
3457 void_type_node);
3458 DECL_EXTERNAL (entry->namespace_decl) = 1;
3459 }
51d9479b 3460 gfc_set_backend_locus (&use_stmt->where);
df4d540f 3461 if (!use_stmt->only_flag)
3462 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3463 NULL_TREE,
3464 ns->proc_name->backend_decl,
3465 false);
3466 for (rent = use_stmt->rename; rent; rent = rent->next)
3467 {
3468 tree decl, local_name;
3469 void **slot;
3470
3471 if (rent->op != INTRINSIC_NONE)
3472 continue;
3473
3474 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3475 htab_hash_string (rent->use_name),
3476 INSERT);
3477 if (*slot == NULL)
3478 {
3479 gfc_symtree *st;
3480
3481 st = gfc_find_symtree (ns->sym_root,
3482 rent->local_name[0]
3483 ? rent->local_name : rent->use_name);
857c96ba 3484 gcc_assert (st);
3485
3486 /* Sometimes, generic interfaces wind up being over-ruled by a
3487 local symbol (see PR41062). */
3488 if (!st->n.sym->attr.use_assoc)
3489 continue;
3490
51d9479b 3491 if (st->n.sym->backend_decl
3492 && DECL_P (st->n.sym->backend_decl)
3493 && st->n.sym->module
3494 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
df4d540f 3495 {
51d9479b 3496 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3497 || (TREE_CODE (st->n.sym->backend_decl)
3498 != VAR_DECL));
df4d540f 3499 decl = copy_node (st->n.sym->backend_decl);
3500 DECL_CONTEXT (decl) = entry->namespace_decl;
3501 DECL_EXTERNAL (decl) = 1;
3502 DECL_IGNORED_P (decl) = 0;
3503 DECL_INITIAL (decl) = NULL_TREE;
3504 }
3505 else
3506 {
3507 *slot = error_mark_node;
3508 htab_clear_slot (entry->decls, slot);
3509 continue;
3510 }
3511 *slot = decl;
3512 }
3513 decl = (tree) *slot;
3514 if (rent->local_name[0])
3515 local_name = get_identifier (rent->local_name);
3516 else
3517 local_name = NULL_TREE;
51d9479b 3518 gfc_set_backend_locus (&rent->where);
df4d540f 3519 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3520 ns->proc_name->backend_decl,
3521 !use_stmt->only_flag);
3522 }
3523 }
4ee9c684 3524}
3525
51d9479b 3526
2eb674c9 3527/* Return true if expr is a constant initializer that gfc_conv_initializer
3528 will handle. */
3529
3530static bool
3531check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3532 bool pointer)
3533{
3534 gfc_constructor *c;
3535 gfc_component *cm;
3536
3537 if (pointer)
3538 return true;
3539 else if (array)
3540 {
3541 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3542 return true;
3543 else if (expr->expr_type == EXPR_STRUCTURE)
3544 return check_constant_initializer (expr, ts, false, false);
3545 else if (expr->expr_type != EXPR_ARRAY)
3546 return false;
3547 for (c = expr->value.constructor; c; c = c->next)
3548 {
3549 if (c->iterator)
3550 return false;
3551 if (c->expr->expr_type == EXPR_STRUCTURE)
3552 {
3553 if (!check_constant_initializer (c->expr, ts, false, false))
3554 return false;
3555 }
3556 else if (c->expr->expr_type != EXPR_CONSTANT)
3557 return false;
3558 }
3559 return true;
3560 }
3561 else switch (ts->type)
3562 {
3563 case BT_DERIVED:
3564 if (expr->expr_type != EXPR_STRUCTURE)
3565 return false;
eeebe20b 3566 cm = expr->ts.u.derived->components;
2eb674c9 3567 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3568 {
3569 if (!c->expr || cm->attr.allocatable)
3570 continue;
3571 if (!check_constant_initializer (c->expr, &cm->ts,
3572 cm->attr.dimension,
3573 cm->attr.pointer))
3574 return false;
3575 }
3576 return true;
3577 default:
3578 return expr->expr_type == EXPR_CONSTANT;
3579 }
3580}
3581
3582/* Emit debug info for parameters and unreferenced variables with
3583 initializers. */
3584
3585static void
3586gfc_emit_parameter_debug_info (gfc_symbol *sym)
3587{
3588 tree decl;
3589
3590 if (sym->attr.flavor != FL_PARAMETER
3591 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3592 return;
3593
3594 if (sym->backend_decl != NULL
3595 || sym->value == NULL
3596 || sym->attr.use_assoc
3597 || sym->attr.dummy
3598 || sym->attr.result
3599 || sym->attr.function
3600 || sym->attr.intrinsic
3601 || sym->attr.pointer
3602 || sym->attr.allocatable
3603 || sym->attr.cray_pointee
3604 || sym->attr.threadprivate
3605 || sym->attr.is_bind_c
3606 || sym->attr.subref_array_pointer
3607 || sym->attr.assign)
3608 return;
3609
3610 if (sym->ts.type == BT_CHARACTER)
3611 {
eeebe20b 3612 gfc_conv_const_charlen (sym->ts.u.cl);
3613 if (sym->ts.u.cl->backend_decl == NULL
3614 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
2eb674c9 3615 return;
3616 }
eeebe20b 3617 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
2eb674c9 3618 return;
3619
3620 if (sym->as)
3621 {
3622 int n;
3623
3624 if (sym->as->type != AS_EXPLICIT)
3625 return;
3626 for (n = 0; n < sym->as->rank; n++)
3627 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3628 || sym->as->upper[n] == NULL
3629 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3630 return;
3631 }
3632
3633 if (!check_constant_initializer (sym->value, &sym->ts,
3634 sym->attr.dimension, false))
3635 return;
3636
3637 /* Create the decl for the variable or constant. */
e60a6f7b 3638 decl = build_decl (input_location,
3639 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
2eb674c9 3640 gfc_sym_identifier (sym), gfc_sym_type (sym));
3641 if (sym->attr.flavor == FL_PARAMETER)
3642 TREE_READONLY (decl) = 1;
3643 gfc_set_decl_location (decl, &sym->declared_at);
3644 if (sym->attr.dimension)
3645 GFC_DECL_PACKED_ARRAY (decl) = 1;
3646 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3647 TREE_STATIC (decl) = 1;
3648 TREE_USED (decl) = 1;
3649 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3650 TREE_PUBLIC (decl) = 1;
3651 DECL_INITIAL (decl)
3652 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3653 sym->attr.dimension, 0);
3654 debug_hooks->global_decl (decl);
3655}
3656
51d9479b 3657/* Generate all the required code for module variables. */
3658
3659void
3660gfc_generate_module_vars (gfc_namespace * ns)
3661{
3662 module_namespace = ns;
3663 cur_module = gfc_find_module (ns->proc_name->name);
3664
3665 /* Check if the frontend left the namespace in a reasonable state. */
3666 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3667
3668 /* Generate COMMON blocks. */
3669 gfc_trans_common (ns);
3670
3671 /* Create decls for all the module variables. */
3672 gfc_traverse_ns (ns, gfc_create_module_variable);
3673
3674 cur_module = NULL;
3675
3676 gfc_trans_use_stmts (ns);
2eb674c9 3677 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
51d9479b 3678}
3679
3680
4ee9c684 3681static void
3682gfc_generate_contained_functions (gfc_namespace * parent)
3683{
3684 gfc_namespace *ns;
3685
3686 /* We create all the prototypes before generating any code. */
3687 for (ns = parent->contained; ns; ns = ns->sibling)
3688 {
3689 /* Skip namespaces from used modules. */
3690 if (ns->parent != parent)
3691 continue;
3692
1b716045 3693 gfc_create_function_decl (ns);
4ee9c684 3694 }
3695
3696 for (ns = parent->contained; ns; ns = ns->sibling)
3697 {
3698 /* Skip namespaces from used modules. */
3699 if (ns->parent != parent)
3700 continue;
3701
3702 gfc_generate_function_code (ns);
3703 }
3704}
3705
3706
d95efb59 3707/* Drill down through expressions for the array specification bounds and
3708 character length calling generate_local_decl for all those variables
3709 that have not already been declared. */
3710
3711static void
3712generate_local_decl (gfc_symbol *);
3713
1acb400a 3714/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
d95efb59 3715
1acb400a 3716static bool
3717expr_decls (gfc_expr *e, gfc_symbol *sym,
3718 int *f ATTRIBUTE_UNUSED)
3719{
3720 if (e->expr_type != EXPR_VARIABLE
3721 || sym == e->symtree->n.sym
d95efb59 3722 || e->symtree->n.sym->mark
3723 || e->symtree->n.sym->ns != sym->ns)
1acb400a 3724 return false;
d95efb59 3725
1acb400a 3726 generate_local_decl (e->symtree->n.sym);
3727 return false;
3728}
d95efb59 3729
1acb400a 3730static void
3731generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3732{
3733 gfc_traverse_expr (e, sym, expr_decls, 0);
d95efb59 3734}
3735
3736
f6d0e37a 3737/* Check for dependencies in the character length and array spec. */
d95efb59 3738
3739static void
3740generate_dependency_declarations (gfc_symbol *sym)
3741{
3742 int i;
3743
3744 if (sym->ts.type == BT_CHARACTER
eeebe20b 3745 && sym->ts.u.cl
3746 && sym->ts.u.cl->length
3747 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3748 generate_expr_decls (sym, sym->ts.u.cl->length);
d95efb59 3749
3750 if (sym->as && sym->as->rank)
3751 {
3752 for (i = 0; i < sym->as->rank; i++)
3753 {
3754 generate_expr_decls (sym, sym->as->lower[i]);
3755 generate_expr_decls (sym, sym->as->upper[i]);
3756 }
3757 }
3758}
3759
3760
4ee9c684 3761/* Generate decls for all local variables. We do this to ensure correct
3762 handling of expressions which only appear in the specification of
3763 other functions. */
3764
3765static void
3766generate_local_decl (gfc_symbol * sym)
3767{
3768 if (sym->attr.flavor == FL_VARIABLE)
3769 {
d95efb59 3770 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
8714fc76 3771 generate_dependency_declarations (sym);
d95efb59 3772
4ee9c684 3773 if (sym->attr.referenced)
8714fc76 3774 gfc_get_symbol_decl (sym);
76776e6d 3775 /* INTENT(out) dummy arguments are likely meant to be set. */
3776 else if (warn_unused_variable
3777 && sym->attr.dummy
3778 && sym->attr.intent == INTENT_OUT)
6ecfe89d 3779 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
76776e6d 3780 sym->name, &sym->declared_at);
3781 /* Specific warning for unused dummy arguments. */
3782 else if (warn_unused_variable && sym->attr.dummy)
6ecfe89d 3783 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
d974cfde 3784 &sym->declared_at);
f888a3fb 3785 /* Warn for unused variables, but not if they're inside a common
14a3addc 3786 block or are use-associated. */
36609028 3787 else if (warn_unused_variable
fa7b6574 3788 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
6ecfe89d 3789 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
d974cfde 3790 &sym->declared_at);
8714fc76 3791
d4163395 3792 /* For variable length CHARACTER parameters, the PARM_DECL already
3793 references the length variable, so force gfc_get_symbol_decl
3794 even when not referenced. If optimize > 0, it will be optimized
3795 away anyway. But do this only after emitting -Wunused-parameter
3796 warning if requested. */
8714fc76 3797 if (sym->attr.dummy && !sym->attr.referenced
3798 && sym->ts.type == BT_CHARACTER
eeebe20b 3799 && sym->ts.u.cl->backend_decl != NULL
3800 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
d4163395 3801 {
3802 sym->attr.referenced = 1;
3803 gfc_get_symbol_decl (sym);
3804 }
76776e6d 3805
d0163401 3806 /* INTENT(out) dummy arguments and result variables with allocatable
3807 components are reset by default and need to be set referenced to
3808 generate the code for nullification and automatic lengths. */
3809 if (!sym->attr.referenced
8714fc76 3810 && sym->ts.type == BT_DERIVED
eeebe20b 3811 && sym->ts.u.derived->attr.alloc_comp
c49db15e 3812 && !sym->attr.pointer
d0163401 3813 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
3814 ||
3815 (sym->attr.result && sym != sym->result)))
8714fc76 3816 {
3817 sym->attr.referenced = 1;
3818 gfc_get_symbol_decl (sym);
3819 }
3820
e72f979a 3821 /* Check for dependencies in the array specification and string
3822 length, adding the necessary declarations to the function. We
3823 mark the symbol now, as well as in traverse_ns, to prevent
3824 getting stuck in a circular dependency. */
3825 sym->mark = 1;
3826
76776e6d 3827 /* We do not want the middle-end to warn about unused parameters
3828 as this was already done above. */
3829 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3830 TREE_NO_WARNING(sym->backend_decl) = 1;
4ee9c684 3831 }
5dd246c1 3832 else if (sym->attr.flavor == FL_PARAMETER)
3833 {
6ecfe89d 3834 if (warn_unused_parameter
5dd246c1 3835 && !sym->attr.referenced
3836 && !sym->attr.use_assoc)
6ecfe89d 3837 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
5dd246c1 3838 &sym->declared_at);
3839 }
fa7b6574 3840 else if (sym->attr.flavor == FL_PROCEDURE)
3841 {
3842 /* TODO: move to the appropriate place in resolve.c. */
3843 if (warn_return_type
3844 && sym->attr.function
3845 && sym->result
3846 && sym != sym->result
3847 && !sym->result->attr.referenced
3848 && !sym->attr.use_assoc
3849 && sym->attr.if_source != IFSRC_IFBODY)
3850 {
3851 gfc_warning ("Return value '%s' of function '%s' declared at "
3852 "%L not set", sym->result->name, sym->name,
3853 &sym->result->declared_at);
3854
3855 /* Prevents "Unused variable" warning for RESULT variables. */
e72f979a 3856 sym->result->mark = 1;
fa7b6574 3857 }
3858 }
c5d33754 3859
19ba2ad8 3860 if (sym->attr.dummy == 1)
3861 {
3862 /* Modify the tree type for scalar character dummy arguments of bind(c)
3863 procedures if they are passed by value. The tree type for them will
3864 be promoted to INTEGER_TYPE for the middle end, which appears to be
3865 what C would do with characters passed by-value. The value attribute
3866 implies the dummy is a scalar. */
3867 if (sym->attr.value == 1 && sym->backend_decl != NULL
3868 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3869 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4c47c8b7 3870 gfc_conv_scalar_char_value (sym, NULL, NULL);
19ba2ad8 3871 }
3872
c5d33754 3873 /* Make sure we convert the types of the derived types from iso_c_binding
3874 into (void *). */
3875 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3876 && sym->ts.type == BT_DERIVED)
3877 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4ee9c684 3878}
3879
3880static void
3881generate_local_vars (gfc_namespace * ns)
3882{
3883 gfc_traverse_ns (ns, generate_local_decl);
3884}
3885
3886
1b716045 3887/* Generate a switch statement to jump to the correct entry point. Also
3888 creates the label decls for the entry points. */
4ee9c684 3889
1b716045 3890static tree
3891gfc_trans_entry_master_switch (gfc_entry_list * el)
4ee9c684 3892{
1b716045 3893 stmtblock_t block;
3894 tree label;
3895 tree tmp;
3896 tree val;
4ee9c684 3897
1b716045 3898 gfc_init_block (&block);
3899 for (; el; el = el->next)
3900 {
3901 /* Add the case label. */
b797d6d3 3902 label = gfc_build_label_decl (NULL_TREE);
7016c612 3903 val = build_int_cst (gfc_array_index_type, el->id);
ed52ef8b 3904 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
1b716045 3905 gfc_add_expr_to_block (&block, tmp);
5b11d932 3906
1b716045 3907 /* And jump to the actual entry point. */
3908 label = gfc_build_label_decl (NULL_TREE);
1b716045 3909 tmp = build1_v (GOTO_EXPR, label);
3910 gfc_add_expr_to_block (&block, tmp);
3911
3912 /* Save the label decl. */
3913 el->label = label;
3914 }
3915 tmp = gfc_finish_block (&block);
3916 /* The first argument selects the entry point. */
3917 val = DECL_ARGUMENTS (current_function_decl);
ed52ef8b 3918 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
1b716045 3919 return tmp;
4ee9c684 3920}
3921
6374121b 3922
a4abf8a0 3923/* Add code to string lengths of actual arguments passed to a function against
3924 the expected lengths of the dummy arguments. */
3925
3926static void
3927add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
3928{
3929 gfc_formal_arglist *formal;
3930
3931 for (formal = sym->formal; formal; formal = formal->next)
3932 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
3933 {
3934 enum tree_code comparison;
3935 tree cond;
3936 tree argname;
3937 gfc_symbol *fsym;
3938 gfc_charlen *cl;
3939 const char *message;
3940
3941 fsym = formal->sym;
eeebe20b 3942 cl = fsym->ts.u.cl;
a4abf8a0 3943
3944 gcc_assert (cl);
3945 gcc_assert (cl->passed_length != NULL_TREE);
3946 gcc_assert (cl->backend_decl != NULL_TREE);
3947
3948 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
3949 string lengths must match exactly. Otherwise, it is only required
be4be771 3950 that the actual string length is *at least* the expected one.
3951 Sequence association allows for a mismatch of the string length
3952 if the actual argument is (part of) an array, but only if the
3953 dummy argument is an array. (See "Sequence association" in
3954 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
a4abf8a0 3955 if (fsym->attr.pointer || fsym->attr.allocatable
3956 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
3957 {
3958 comparison = NE_EXPR;
3959 message = _("Actual string length does not match the declared one"
3960 " for dummy argument '%s' (%ld/%ld)");
3961 }
be4be771 3962 else if (fsym->as && fsym->as->rank != 0)
3963 continue;
a4abf8a0 3964 else
3965 {
3966 comparison = LT_EXPR;
3967 message = _("Actual string length is shorter than the declared one"
3968 " for dummy argument '%s' (%ld/%ld)");
3969 }
3970
3971 /* Build the condition. For optional arguments, an actual length
3972 of 0 is also acceptable if the associated string is NULL, which
3973 means the argument was not passed. */
3974 cond = fold_build2 (comparison, boolean_type_node,
3975 cl->passed_length, cl->backend_decl);
3976 if (fsym->attr.optional)
3977 {
3978 tree not_absent;
3979 tree not_0length;
3980 tree absent_failed;
3981
3982 not_0length = fold_build2 (NE_EXPR, boolean_type_node,
3983 cl->passed_length,
3984 fold_convert (gfc_charlen_type_node,
3985 integer_zero_node));
3986 not_absent = fold_build2 (NE_EXPR, boolean_type_node,
3987 fsym->backend_decl, null_pointer_node);
3988
3989 absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3990 not_0length, not_absent);
3991
3992 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3993 cond, absent_failed);
3994 }
3995
3996 /* Build the runtime check. */
3997 argname = gfc_build_cstring_const (fsym->name);
3998 argname = gfc_build_addr_expr (pchar_type_node, argname);
3999 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4000 message, argname,
4001 fold_convert (long_integer_type_node,
4002 cl->passed_length),
4003 fold_convert (long_integer_type_node,
4004 cl->backend_decl));
4005 }
4006}
4007
4008
7257a5d2 4009static void
4010create_main_function (tree fndecl)
4011{
43702da6 4012 tree old_context;
7257a5d2 4013 tree ftn_main;
4014 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4015 stmtblock_t body;
4016
43702da6 4017 old_context = current_function_decl;
4018
4019 if (old_context)
4020 {
4021 push_function_context ();
4022 saved_parent_function_decls = saved_function_decls;
4023 saved_function_decls = NULL_TREE;
4024 }
4025
7257a5d2 4026 /* main() function must be declared with global scope. */
4027 gcc_assert (current_function_decl == NULL_TREE);
4028
4029 /* Declare the function. */
4030 tmp = build_function_type_list (integer_type_node, integer_type_node,
4031 build_pointer_type (pchar_type_node),
4032 NULL_TREE);
0509d0ee 4033 main_identifier_node = get_identifier ("main");
e60a6f7b 4034 ftn_main = build_decl (input_location, FUNCTION_DECL,
4035 main_identifier_node, tmp);
7257a5d2 4036 DECL_EXTERNAL (ftn_main) = 0;
4037 TREE_PUBLIC (ftn_main) = 1;
4038 TREE_STATIC (ftn_main) = 1;
4039 DECL_ATTRIBUTES (ftn_main)
4040 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4041
4042 /* Setup the result declaration (for "return 0"). */
e60a6f7b 4043 result_decl = build_decl (input_location,
4044 RESULT_DECL, NULL_TREE, integer_type_node);
7257a5d2 4045 DECL_ARTIFICIAL (result_decl) = 1;
4046 DECL_IGNORED_P (result_decl) = 1;
4047 DECL_CONTEXT (result_decl) = ftn_main;
4048 DECL_RESULT (ftn_main) = result_decl;
4049
4050 pushdecl (ftn_main);
4051
4052 /* Get the arguments. */
4053
4054 arglist = NULL_TREE;
4055 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4056
4057 tmp = TREE_VALUE (typelist);
e60a6f7b 4058 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
7257a5d2 4059 DECL_CONTEXT (argc) = ftn_main;
4060 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4061 TREE_READONLY (argc) = 1;
4062 gfc_finish_decl (argc);
4063 arglist = chainon (arglist, argc);
4064
4065 typelist = TREE_CHAIN (typelist);
4066 tmp = TREE_VALUE (typelist);
e60a6f7b 4067 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
7257a5d2 4068 DECL_CONTEXT (argv) = ftn_main;
4069 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4070 TREE_READONLY (argv) = 1;
4071 DECL_BY_REFERENCE (argv) = 1;
4072 gfc_finish_decl (argv);
4073 arglist = chainon (arglist, argv);
4074
4075 DECL_ARGUMENTS (ftn_main) = arglist;
4076 current_function_decl = ftn_main;
4077 announce_function (ftn_main);
4078
4079 rest_of_decl_compilation (ftn_main, 1, 0);
4080 make_decl_rtl (ftn_main);
4081 init_function_start (ftn_main);
4082 pushlevel (0);
4083
4084 gfc_init_block (&body);
4085
4086 /* Call some libgfortran initialization routines, call then MAIN__(). */
4087
4088 /* Call _gfortran_set_args (argc, argv). */
43702da6 4089 TREE_USED (argc) = 1;
4090 TREE_USED (argv) = 1;
389dd41b 4091 tmp = build_call_expr_loc (input_location,
4092 gfor_fndecl_set_args, 2, argc, argv);
7257a5d2 4093 gfc_add_expr_to_block (&body, tmp);
4094
4095 /* Add a call to set_options to set up the runtime library Fortran
4096 language standard parameters. */
4097 {
4098 tree array_type, array, var;
4099
4100 /* Passing a new option to the library requires four modifications:
4101 + add it to the tree_cons list below
4102 + change the array size in the call to build_array_type
4103 + change the first argument to the library call
4104 gfor_fndecl_set_options
4105 + modify the library (runtime/compile_options.c)! */
4106
4107 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4108 gfc_option.warn_std), NULL_TREE);
4109 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4110 gfc_option.allow_std), array);
4111 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
4112 array);
4113 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4114 gfc_option.flag_dump_core), array);
4115 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4116 gfc_option.flag_backtrace), array);
4117 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4118 gfc_option.flag_sign_zero), array);
4119
4120 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4121 (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
4122
4123 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4124 gfc_option.flag_range_check), array);
4125
4126 array_type = build_array_type (integer_type_node,
4127 build_index_type (build_int_cst (NULL_TREE, 7)));
4128 array = build_constructor_from_list (array_type, nreverse (array));
4129 TREE_CONSTANT (array) = 1;
4130 TREE_STATIC (array) = 1;
4131
4132 /* Create a static variable to hold the jump table. */
4133 var = gfc_create_var (array_type, "options");
4134 TREE_CONSTANT (var) = 1;
4135 TREE_STATIC (var) = 1;
4136 TREE_READONLY (var) = 1;
4137 DECL_INITIAL (var) = array;
4138 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4139
389dd41b 4140 tmp = build_call_expr_loc (input_location,
4141 gfor_fndecl_set_options, 2,
7257a5d2 4142 build_int_cst (integer_type_node, 8), var);
4143 gfc_add_expr_to_block (&body, tmp);
4144 }
4145
4146 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4147 the library will raise a FPE when needed. */
4148 if (gfc_option.fpe != 0)
4149 {
389dd41b 4150 tmp = build_call_expr_loc (input_location,
4151 gfor_fndecl_set_fpe, 1,
7257a5d2 4152 build_int_cst (integer_type_node,
4153 gfc_option.fpe));
4154 gfc_add_expr_to_block (&body, tmp);
4155 }
4156
4157 /* If this is the main program and an -fconvert option was provided,
4158 add a call to set_convert. */
4159
4160 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4161 {
389dd41b 4162 tmp = build_call_expr_loc (input_location,
4163 gfor_fndecl_set_convert, 1,
7257a5d2 4164 build_int_cst (integer_type_node,
4165 gfc_option.convert));
4166 gfc_add_expr_to_block (&body, tmp);
4167 }
4168
4169 /* If this is the main program and an -frecord-marker option was provided,
4170 add a call to set_record_marker. */
4171
4172 if (gfc_option.record_marker != 0)
4173 {
389dd41b 4174 tmp = build_call_expr_loc (input_location,
4175 gfor_fndecl_set_record_marker, 1,
7257a5d2 4176 build_int_cst (integer_type_node,
4177 gfc_option.record_marker));
4178 gfc_add_expr_to_block (&body, tmp);
4179 }
4180
4181 if (gfc_option.max_subrecord_length != 0)
4182 {
389dd41b 4183 tmp = build_call_expr_loc (input_location,
4184 gfor_fndecl_set_max_subrecord_length, 1,
7257a5d2 4185 build_int_cst (integer_type_node,
4186 gfc_option.max_subrecord_length));
4187 gfc_add_expr_to_block (&body, tmp);
4188 }
4189
4190 /* Call MAIN__(). */
389dd41b 4191 tmp = build_call_expr_loc (input_location,
4192 fndecl, 0);
7257a5d2 4193 gfc_add_expr_to_block (&body, tmp);
4194
43702da6 4195 /* Mark MAIN__ as used. */
4196 TREE_USED (fndecl) = 1;
4197
7257a5d2 4198 /* "return 0". */
4199 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4200 build_int_cst (integer_type_node, 0));
4201 tmp = build1_v (RETURN_EXPR, tmp);
4202 gfc_add_expr_to_block (&body, tmp);
4203
4204
4205 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4206 decl = getdecls ();
4207
4208 /* Finish off this function and send it for code generation. */
4209 poplevel (1, 0, 1);
4210 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4211
4212 DECL_SAVED_TREE (ftn_main)
4213 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4214 DECL_INITIAL (ftn_main));
4215
4216 /* Output the GENERIC tree. */
4217 dump_function (TDI_original, ftn_main);
4218
bb982f66 4219 cgraph_finalize_function (ftn_main, true);
43702da6 4220
4221 if (old_context)
4222 {
4223 pop_function_context ();
4224 saved_function_decls = saved_parent_function_decls;
4225 }
4226 current_function_decl = old_context;
7257a5d2 4227}
4228
4229
4ee9c684 4230/* Generate code for a function. */
4231
4232void
4233gfc_generate_function_code (gfc_namespace * ns)
4234{
4235 tree fndecl;
4236 tree old_context;
4237 tree decl;
4238 tree tmp;
2294b616 4239 tree tmp2;
4ee9c684 4240 stmtblock_t block;
4241 stmtblock_t body;
4242 tree result;
a466adc9 4243 tree recurcheckvar = NULL;
4ee9c684 4244 gfc_symbol *sym;
2294b616 4245 int rank;
e50e62f5 4246 bool is_recursive;
4ee9c684 4247
4248 sym = ns->proc_name;
1b716045 4249
4ee9c684 4250 /* Check that the frontend isn't still using this. */
22d678e8 4251 gcc_assert (sym->tlink == NULL);
4ee9c684 4252 sym->tlink = sym;
4253
4254 /* Create the declaration for functions with global scope. */
4255 if (!sym->backend_decl)
1b716045 4256 gfc_create_function_decl (ns);
4ee9c684 4257
4258 fndecl = sym->backend_decl;
4259 old_context = current_function_decl;
4260
4261 if (old_context)
4262 {
4263 push_function_context ();
4264 saved_parent_function_decls = saved_function_decls;
4265 saved_function_decls = NULL_TREE;
4266 }
4267
1b716045 4268 trans_function_start (sym);
4ee9c684 4269
e5004242 4270 gfc_init_block (&block);
4ee9c684 4271
c6871095 4272 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4273 {
4274 /* Copy length backend_decls to all entry point result
4275 symbols. */
4276 gfc_entry_list *el;
4277 tree backend_decl;
4278
eeebe20b 4279 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4280 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
c6871095 4281 for (el = ns->entries; el; el = el->next)
eeebe20b 4282 el->sym->result->ts.u.cl->backend_decl = backend_decl;
c6871095 4283 }
4284
4ee9c684 4285 /* Translate COMMON blocks. */
4286 gfc_trans_common (ns);
4287
c750cc52 4288 /* Null the parent fake result declaration if this namespace is
4289 a module function or an external procedures. */
4290 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4291 || ns->parent == NULL)
4292 parent_fake_result_decl = NULL_TREE;
4293
2b685f8e 4294 gfc_generate_contained_functions (ns);
4295
9579733e 4296 nonlocal_dummy_decls = NULL;
4297 nonlocal_dummy_decl_pset = NULL;
4298
4ee9c684 4299 generate_local_vars (ns);
5b11d932 4300
c750cc52 4301 /* Keep the parent fake result declaration in module functions
4302 or external procedures. */
4303 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4304 || ns->parent == NULL)
4305 current_fake_result_decl = parent_fake_result_decl;
4306 else
4307 current_fake_result_decl = NULL_TREE;
4308
4ee9c684 4309 current_function_return_label = NULL;
4310
4311 /* Now generate the code for the body of this function. */
4312 gfc_init_block (&body);
4313
e50e62f5 4314 is_recursive = sym->attr.recursive
4315 || (sym->attr.entry_master
4316 && sym->ns->entries->sym->attr.recursive);
4317 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
a466adc9 4318 {
4319 char * msg;
4320
4321 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4322 sym->name);
4323 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4324 TREE_STATIC (recurcheckvar) = 1;
4325 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4326 gfc_add_expr_to_block (&block, recurcheckvar);
4327 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4328 &sym->declared_at, msg);
4329 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4330 gfc_free (msg);
4331 }
4332
4ee9c684 4333 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4334 && sym->attr.subroutine)
4335 {
4336 tree alternate_return;
c750cc52 4337 alternate_return = gfc_get_fake_result_decl (sym, 0);
75a70cf9 4338 gfc_add_modify (&body, alternate_return, integer_zero_node);
4ee9c684 4339 }
4340
1b716045 4341 if (ns->entries)
4342 {
4343 /* Jump to the correct entry point. */
4344 tmp = gfc_trans_entry_master_switch (ns->entries);
4345 gfc_add_expr_to_block (&body, tmp);
4346 }
4347
a4abf8a0 4348 /* If bounds-checking is enabled, generate code to check passed in actual
4349 arguments against the expected dummy argument attributes (e.g. string
4350 lengths). */
6ba3bda4 4351 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
a4abf8a0 4352 add_argument_checking (&body, sym);
4353
4ee9c684 4354 tmp = gfc_trans_code (ns->code);
4355 gfc_add_expr_to_block (&body, tmp);
4356
4357 /* Add a return label if needed. */
4358 if (current_function_return_label)
4359 {
4360 tmp = build1_v (LABEL_EXPR, current_function_return_label);
4361 gfc_add_expr_to_block (&body, tmp);
4362 }
4363
4364 tmp = gfc_finish_block (&body);
4365 /* Add code to create and cleanup arrays. */
4366 tmp = gfc_trans_deferred_vars (sym, tmp);
4ee9c684 4367
4368 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4369 {
14a3addc 4370 if (sym->attr.subroutine || sym == sym->result)
4ee9c684 4371 {
d4163395 4372 if (current_fake_result_decl != NULL)
4373 result = TREE_VALUE (current_fake_result_decl);
4374 else
4375 result = NULL_TREE;
4ee9c684 4376 current_fake_result_decl = NULL_TREE;
4377 }
4378 else
4379 result = sym->result->backend_decl;
4380
2294b616 4381 if (result != NULL_TREE && sym->attr.function
4382 && sym->ts.type == BT_DERIVED
eeebe20b 4383 && sym->ts.u.derived->attr.alloc_comp
091bff86 4384 && !sym->attr.pointer)
2294b616 4385 {
4386 rank = sym->as ? sym->as->rank : 0;
eeebe20b 4387 tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
2294b616 4388 gfc_add_expr_to_block (&block, tmp2);
4389 }
4390
fa7b6574 4391 gfc_add_expr_to_block (&block, tmp);
4392
e50e62f5 4393 /* Reset recursion-check variable. */
4394 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
5176859a 4395 {
4396 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4397 recurcheckvar = NULL;
4398 }
e50e62f5 4399
fa7b6574 4400 if (result == NULL_TREE)
4401 {
4402 /* TODO: move to the appropriate place in resolve.c. */
4403 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4404 gfc_warning ("Return value of function '%s' at %L not set",
4405 sym->name, &sym->declared_at);
2294b616 4406
fa7b6574 4407 TREE_NO_WARNING(sym->backend_decl) = 1;
4408 }
4ee9c684 4409 else
4410 {
3350e716 4411 /* Set the return value to the dummy result variable. The
4412 types may be different for scalar default REAL functions
4413 with -ff2c, therefore we have to convert. */
4414 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
f75d6b8a 4415 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4416 DECL_RESULT (fndecl), tmp);
ed52ef8b 4417 tmp = build1_v (RETURN_EXPR, tmp);
4ee9c684 4418 gfc_add_expr_to_block (&block, tmp);
4419 }
4420 }
2294b616 4421 else
e50e62f5 4422 {
4423 gfc_add_expr_to_block (&block, tmp);
4424 /* Reset recursion-check variable. */
4425 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4426 {
4427 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4428 recurcheckvar = NULL;
4429 }
4430 }
2294b616 4431
4ee9c684 4432
4433 /* Add all the decls we created during processing. */
4434 decl = saved_function_decls;
4435 while (decl)
4436 {
4437 tree next;
4438
4439 next = TREE_CHAIN (decl);
4440 TREE_CHAIN (decl) = NULL_TREE;
4441 pushdecl (decl);
4442 decl = next;
4443 }
4444 saved_function_decls = NULL_TREE;
4445
4446 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
e5004242 4447 decl = getdecls ();
4ee9c684 4448
4449 /* Finish off this function and send it for code generation. */
4450 poplevel (1, 0, 1);
4451 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4452
e5004242 4453 DECL_SAVED_TREE (fndecl)
4454 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4455 DECL_INITIAL (fndecl));
4456
9579733e 4457 if (nonlocal_dummy_decls)
4458 {
4459 BLOCK_VARS (DECL_INITIAL (fndecl))
4460 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4461 pointer_set_destroy (nonlocal_dummy_decl_pset);
4462 nonlocal_dummy_decls = NULL;
4463 nonlocal_dummy_decl_pset = NULL;
4464 }
4465
4ee9c684 4466 /* Output the GENERIC tree. */
4467 dump_function (TDI_original, fndecl);
4468
4469 /* Store the end of the function, so that we get good line number
4470 info for the epilogue. */
4471 cfun->function_end_locus = input_location;
4472
4473 /* We're leaving the context of this function, so zap cfun.
4474 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4475 tree_rest_of_compilation. */
87d4aa85 4476 set_cfun (NULL);
4ee9c684 4477
4478 if (old_context)
4479 {
4480 pop_function_context ();
4481 saved_function_decls = saved_parent_function_decls;
4482 }
4483 current_function_decl = old_context;
4484
4485 if (decl_function_context (fndecl))
6374121b 4486 /* Register this function with cgraph just far enough to get it
4487 added to our parent's nested function list. */
4488 (void) cgraph_node (fndecl);
4ee9c684 4489 else
bb982f66 4490 cgraph_finalize_function (fndecl, true);
df4d540f 4491
4492 gfc_trans_use_stmts (ns);
2eb674c9 4493 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
7257a5d2 4494
4495 if (sym->attr.is_main_program)
4496 create_main_function (fndecl);
4ee9c684 4497}
4498
7257a5d2 4499
4ee9c684 4500void
4501gfc_generate_constructors (void)
4502{
22d678e8 4503 gcc_assert (gfc_static_ctors == NULL_TREE);
4ee9c684 4504#if 0
4505 tree fnname;
4506 tree type;
4507 tree fndecl;
4508 tree decl;
4509 tree tmp;
4510
4511 if (gfc_static_ctors == NULL_TREE)
4512 return;
4513
db85cc4f 4514 fnname = get_file_function_name ("I");
4ee9c684 4515 type = build_function_type (void_type_node,
4516 gfc_chainon_list (NULL_TREE, void_type_node));
4517
e60a6f7b 4518 fndecl = build_decl (input_location,
4519 FUNCTION_DECL, fnname, type);
4ee9c684 4520 TREE_PUBLIC (fndecl) = 1;
4521
e60a6f7b 4522 decl = build_decl (input_location,
4523 RESULT_DECL, NULL_TREE, void_type_node);
540edea7 4524 DECL_ARTIFICIAL (decl) = 1;
4525 DECL_IGNORED_P (decl) = 1;
4ee9c684 4526 DECL_CONTEXT (decl) = fndecl;
4527 DECL_RESULT (fndecl) = decl;
4528
4529 pushdecl (fndecl);
4530
4531 current_function_decl = fndecl;
4532
b2c4af5e 4533 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 4534
b2c4af5e 4535 make_decl_rtl (fndecl);
4ee9c684 4536
b31f705b 4537 init_function_start (fndecl);
4ee9c684 4538
4ee9c684 4539 pushlevel (0);
4540
4541 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4542 {
389dd41b 4543 tmp = build_call_expr_loc (input_location,
4544 TREE_VALUE (gfc_static_ctors), 0);
e60a6f7b 4545 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4ee9c684 4546 }
4547
e5004242 4548 decl = getdecls ();
4ee9c684 4549 poplevel (1, 0, 1);
4550
4551 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
e5004242 4552 DECL_SAVED_TREE (fndecl)
4553 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4554 DECL_INITIAL (fndecl));
4ee9c684 4555
4556 free_after_parsing (cfun);
4557 free_after_compilation (cfun);
4558
6148a911 4559 tree_rest_of_compilation (fndecl);
4ee9c684 4560
4561 current_function_decl = NULL_TREE;
4562#endif
4563}
4564
9ec7c303 4565/* Translates a BLOCK DATA program unit. This means emitting the
4566 commons contained therein plus their initializations. We also emit
4567 a globally visible symbol to make sure that each BLOCK DATA program
4568 unit remains unique. */
4569
4570void
4571gfc_generate_block_data (gfc_namespace * ns)
4572{
4573 tree decl;
4574 tree id;
4575
b31f705b 4576 /* Tell the backend the source location of the block data. */
4577 if (ns->proc_name)
4578 gfc_set_backend_locus (&ns->proc_name->declared_at);
4579 else
4580 gfc_set_backend_locus (&gfc_current_locus);
4581
4582 /* Process the DATA statements. */
9ec7c303 4583 gfc_trans_common (ns);
4584
b31f705b 4585 /* Create a global symbol with the mane of the block data. This is to
4586 generate linker errors if the same name is used twice. It is never
4587 really used. */
9ec7c303 4588 if (ns->proc_name)
4589 id = gfc_sym_mangled_function_id (ns->proc_name);
4590 else
4591 id = get_identifier ("__BLOCK_DATA__");
4592
e60a6f7b 4593 decl = build_decl (input_location,
4594 VAR_DECL, id, gfc_array_index_type);
9ec7c303 4595 TREE_PUBLIC (decl) = 1;
4596 TREE_STATIC (decl) = 1;
df4d540f 4597 DECL_IGNORED_P (decl) = 1;
9ec7c303 4598
4599 pushdecl (decl);
4600 rest_of_decl_compilation (decl, 1, 0);
4601}
4602
b549d2a5 4603
6a7084d7 4604/* Process the local variables of a BLOCK construct. */
4605
4606void
4607gfc_process_block_locals (gfc_namespace* ns)
4608{
4609 tree decl;
4610
4611 gcc_assert (saved_local_decls == NULL_TREE);
4612 generate_local_vars (ns);
4613
4614 decl = saved_local_decls;
4615 while (decl)
4616 {
4617 tree next;
4618
4619 next = TREE_CHAIN (decl);
4620 TREE_CHAIN (decl) = NULL_TREE;
4621 pushdecl (decl);
4622 decl = next;
4623 }
4624 saved_local_decls = NULL_TREE;
4625}
4626
4627
4ee9c684 4628#include "gt-fortran-trans-decl.h"
Mirror of https://gcc.gnu.org/git/gcc.git