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