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