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