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