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