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