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