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