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