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