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