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