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