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