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