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