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