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