?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2017-08-06 Andrew Pinski <apinski@cavium.com>
[official-gcc.git] / gcc / fortran / trans-decl.c
blob74d860689ee791f64b3369b555d21f20db553022
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, 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 false);
4957 }
4958 }
4959 }
4960
4961
4962 /* Return true if expr is a constant initializer that gfc_conv_initializer
4963 will handle. */
4964
4965 static bool
4966 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
4967 bool pointer)
4968 {
4969 gfc_constructor *c;
4970 gfc_component *cm;
4971
4972 if (pointer)
4973 return true;
4974 else if (array)
4975 {
4976 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
4977 return true;
4978 else if (expr->expr_type == EXPR_STRUCTURE)
4979 return check_constant_initializer (expr, ts, false, false);
4980 else if (expr->expr_type != EXPR_ARRAY)
4981 return false;
4982 for (c = gfc_constructor_first (expr->value.constructor);
4983 c; c = gfc_constructor_next (c))
4984 {
4985 if (c->iterator)
4986 return false;
4987 if (c->expr->expr_type == EXPR_STRUCTURE)
4988 {
4989 if (!check_constant_initializer (c->expr, ts, false, false))
4990 return false;
4991 }
4992 else if (c->expr->expr_type != EXPR_CONSTANT)
4993 return false;
4994 }
4995 return true;
4996 }
4997 else switch (ts->type)
4998 {
4999 case_bt_struct:
5000 if (expr->expr_type != EXPR_STRUCTURE)
5001 return false;
5002 cm = expr->ts.u.derived->components;
5003 for (c = gfc_constructor_first (expr->value.constructor);
5004 c; c = gfc_constructor_next (c), cm = cm->next)
5005 {
5006 if (!c->expr || cm->attr.allocatable)
5007 continue;
5008 if (!check_constant_initializer (c->expr, &cm->ts,
5009 cm->attr.dimension,
5010 cm->attr.pointer))
5011 return false;
5012 }
5013 return true;
5014 default:
5015 return expr->expr_type == EXPR_CONSTANT;
5016 }
5017 }
5018
5019 /* Emit debug info for parameters and unreferenced variables with
5020 initializers. */
5021
5022 static void
5023 gfc_emit_parameter_debug_info (gfc_symbol *sym)
5024 {
5025 tree decl;
5026
5027 if (sym->attr.flavor != FL_PARAMETER
5028 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
5029 return;
5030
5031 if (sym->backend_decl != NULL
5032 || sym->value == NULL
5033 || sym->attr.use_assoc
5034 || sym->attr.dummy
5035 || sym->attr.result
5036 || sym->attr.function
5037 || sym->attr.intrinsic
5038 || sym->attr.pointer
5039 || sym->attr.allocatable
5040 || sym->attr.cray_pointee
5041 || sym->attr.threadprivate
5042 || sym->attr.is_bind_c
5043 || sym->attr.subref_array_pointer
5044 || sym->attr.assign)
5045 return;
5046
5047 if (sym->ts.type == BT_CHARACTER)
5048 {
5049 gfc_conv_const_charlen (sym->ts.u.cl);
5050 if (sym->ts.u.cl->backend_decl == NULL
5051 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
5052 return;
5053 }
5054 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
5055 return;
5056
5057 if (sym->as)
5058 {
5059 int n;
5060
5061 if (sym->as->type != AS_EXPLICIT)
5062 return;
5063 for (n = 0; n < sym->as->rank; n++)
5064 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
5065 || sym->as->upper[n] == NULL
5066 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
5067 return;
5068 }
5069
5070 if (!check_constant_initializer (sym->value, &sym->ts,
5071 sym->attr.dimension, false))
5072 return;
5073
5074 if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
5075 return;
5076
5077 /* Create the decl for the variable or constant. */
5078 decl = build_decl (input_location,
5079 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
5080 gfc_sym_identifier (sym), gfc_sym_type (sym));
5081 if (sym->attr.flavor == FL_PARAMETER)
5082 TREE_READONLY (decl) = 1;
5083 gfc_set_decl_location (decl, &sym->declared_at);
5084 if (sym->attr.dimension)
5085 GFC_DECL_PACKED_ARRAY (decl) = 1;
5086 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5087 TREE_STATIC (decl) = 1;
5088 TREE_USED (decl) = 1;
5089 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
5090 TREE_PUBLIC (decl) = 1;
5091 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
5092 TREE_TYPE (decl),
5093 sym->attr.dimension,
5094 false, false);
5095 debug_hooks->early_global_decl (decl);
5096 }
5097
5098
5099 static void
5100 generate_coarray_sym_init (gfc_symbol *sym)
5101 {
5102 tree tmp, size, decl, token, desc;
5103 bool is_lock_type, is_event_type;
5104 int reg_type;
5105 gfc_se se;
5106 symbol_attribute attr;
5107
5108 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
5109 || sym->attr.use_assoc || !sym->attr.referenced
5110 || sym->attr.select_type_temporary)
5111 return;
5112
5113 decl = sym->backend_decl;
5114 TREE_USED(decl) = 1;
5115 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
5116
5117 is_lock_type = sym->ts.type == BT_DERIVED
5118 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5119 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
5120
5121 is_event_type = sym->ts.type == BT_DERIVED
5122 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5123 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
5124
5125 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
5126 to make sure the variable is not optimized away. */
5127 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
5128
5129 /* For lock types, we pass the array size as only the library knows the
5130 size of the variable. */
5131 if (is_lock_type || is_event_type)
5132 size = gfc_index_one_node;
5133 else
5134 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
5135
5136 /* Ensure that we do not have size=0 for zero-sized arrays. */
5137 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
5138 fold_convert (size_type_node, size),
5139 build_int_cst (size_type_node, 1));
5140
5141 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
5142 {
5143 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
5144 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5145 fold_convert (size_type_node, tmp), size);
5146 }
5147
5148 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
5149 token = gfc_build_addr_expr (ppvoid_type_node,
5150 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
5151 if (is_lock_type)
5152 reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
5153 else if (is_event_type)
5154 reg_type = GFC_CAF_EVENT_STATIC;
5155 else
5156 reg_type = GFC_CAF_COARRAY_STATIC;
5157
5158 /* Compile the symbol attribute. */
5159 if (sym->ts.type == BT_CLASS)
5160 {
5161 attr = CLASS_DATA (sym)->attr;
5162 /* The pointer attribute is always set on classes, overwrite it with the
5163 class_pointer attribute, which denotes the pointer for classes. */
5164 attr.pointer = attr.class_pointer;
5165 }
5166 else
5167 attr = sym->attr;
5168 gfc_init_se (&se, NULL);
5169 desc = gfc_conv_scalar_to_descriptor (&se, decl, attr);
5170 gfc_add_block_to_block (&caf_init_block, &se.pre);
5171
5172 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size,
5173 build_int_cst (integer_type_node, reg_type),
5174 token, gfc_build_addr_expr (pvoid_type_node, desc),
5175 null_pointer_node, /* stat. */
5176 null_pointer_node, /* errgmsg. */
5177 integer_zero_node); /* errmsg_len. */
5178 gfc_add_expr_to_block (&caf_init_block, tmp);
5179 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl),
5180 gfc_conv_descriptor_data_get (desc)));
5181
5182 /* Handle "static" initializer. */
5183 if (sym->value)
5184 {
5185 sym->attr.pointer = 1;
5186 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
5187 true, false);
5188 sym->attr.pointer = 0;
5189 gfc_add_expr_to_block (&caf_init_block, tmp);
5190 }
5191 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp)
5192 {
5193 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as
5194 ? sym->as->rank : 0,
5195 GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
5196 gfc_add_expr_to_block (&caf_init_block, tmp);
5197 }
5198 }
5199
5200
5201 /* Generate constructor function to initialize static, nonallocatable
5202 coarrays. */
5203
5204 static void
5205 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
5206 {
5207 tree fndecl, tmp, decl, save_fn_decl;
5208
5209 save_fn_decl = current_function_decl;
5210 push_function_context ();
5211
5212 tmp = build_function_type_list (void_type_node, NULL_TREE);
5213 fndecl = build_decl (input_location, FUNCTION_DECL,
5214 create_tmp_var_name ("_caf_init"), tmp);
5215
5216 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
5217 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
5218
5219 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
5220 DECL_ARTIFICIAL (decl) = 1;
5221 DECL_IGNORED_P (decl) = 1;
5222 DECL_CONTEXT (decl) = fndecl;
5223 DECL_RESULT (fndecl) = decl;
5224
5225 pushdecl (fndecl);
5226 current_function_decl = fndecl;
5227 announce_function (fndecl);
5228
5229 rest_of_decl_compilation (fndecl, 0, 0);
5230 make_decl_rtl (fndecl);
5231 allocate_struct_function (fndecl, false);
5232
5233 pushlevel ();
5234 gfc_init_block (&caf_init_block);
5235
5236 gfc_traverse_ns (ns, generate_coarray_sym_init);
5237
5238 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
5239 decl = getdecls ();
5240
5241 poplevel (1, 1);
5242 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5243
5244 DECL_SAVED_TREE (fndecl)
5245 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5246 DECL_INITIAL (fndecl));
5247 dump_function (TDI_original, fndecl);
5248
5249 cfun->function_end_locus = input_location;
5250 set_cfun (NULL);
5251
5252 if (decl_function_context (fndecl))
5253 (void) cgraph_node::create (fndecl);
5254 else
5255 cgraph_node::finalize_function (fndecl, true);
5256
5257 pop_function_context ();
5258 current_function_decl = save_fn_decl;
5259 }
5260
5261
5262 static void
5263 create_module_nml_decl (gfc_symbol *sym)
5264 {
5265 if (sym->attr.flavor == FL_NAMELIST)
5266 {
5267 tree decl = generate_namelist_decl (sym);
5268 pushdecl (decl);
5269 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5270 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5271 rest_of_decl_compilation (decl, 1, 0);
5272 gfc_module_add_decl (cur_module, decl);
5273 }
5274 }
5275
5276
5277 /* Generate all the required code for module variables. */
5278
5279 void
5280 gfc_generate_module_vars (gfc_namespace * ns)
5281 {
5282 module_namespace = ns;
5283 cur_module = gfc_find_module (ns->proc_name->name);
5284
5285 /* Check if the frontend left the namespace in a reasonable state. */
5286 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
5287
5288 /* Generate COMMON blocks. */
5289 gfc_trans_common (ns);
5290
5291 has_coarray_vars = false;
5292
5293 /* Create decls for all the module variables. */
5294 gfc_traverse_ns (ns, gfc_create_module_variable);
5295 gfc_traverse_ns (ns, create_module_nml_decl);
5296
5297 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5298 generate_coarray_init (ns);
5299
5300 cur_module = NULL;
5301
5302 gfc_trans_use_stmts (ns);
5303 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5304 }
5305
5306
5307 static void
5308 gfc_generate_contained_functions (gfc_namespace * parent)
5309 {
5310 gfc_namespace *ns;
5311
5312 /* We create all the prototypes before generating any code. */
5313 for (ns = parent->contained; ns; ns = ns->sibling)
5314 {
5315 /* Skip namespaces from used modules. */
5316 if (ns->parent != parent)
5317 continue;
5318
5319 gfc_create_function_decl (ns, false);
5320 }
5321
5322 for (ns = parent->contained; ns; ns = ns->sibling)
5323 {
5324 /* Skip namespaces from used modules. */
5325 if (ns->parent != parent)
5326 continue;
5327
5328 gfc_generate_function_code (ns);
5329 }
5330 }
5331
5332
5333 /* Drill down through expressions for the array specification bounds and
5334 character length calling generate_local_decl for all those variables
5335 that have not already been declared. */
5336
5337 static void
5338 generate_local_decl (gfc_symbol *);
5339
5340 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5341
5342 static bool
5343 expr_decls (gfc_expr *e, gfc_symbol *sym,
5344 int *f ATTRIBUTE_UNUSED)
5345 {
5346 if (e->expr_type != EXPR_VARIABLE
5347 || sym == e->symtree->n.sym
5348 || e->symtree->n.sym->mark
5349 || e->symtree->n.sym->ns != sym->ns)
5350 return false;
5351
5352 generate_local_decl (e->symtree->n.sym);
5353 return false;
5354 }
5355
5356 static void
5357 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
5358 {
5359 gfc_traverse_expr (e, sym, expr_decls, 0);
5360 }
5361
5362
5363 /* Check for dependencies in the character length and array spec. */
5364
5365 static void
5366 generate_dependency_declarations (gfc_symbol *sym)
5367 {
5368 int i;
5369
5370 if (sym->ts.type == BT_CHARACTER
5371 && sym->ts.u.cl
5372 && sym->ts.u.cl->length
5373 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5374 generate_expr_decls (sym, sym->ts.u.cl->length);
5375
5376 if (sym->as && sym->as->rank)
5377 {
5378 for (i = 0; i < sym->as->rank; i++)
5379 {
5380 generate_expr_decls (sym, sym->as->lower[i]);
5381 generate_expr_decls (sym, sym->as->upper[i]);
5382 }
5383 }
5384 }
5385
5386
5387 /* Generate decls for all local variables. We do this to ensure correct
5388 handling of expressions which only appear in the specification of
5389 other functions. */
5390
5391 static void
5392 generate_local_decl (gfc_symbol * sym)
5393 {
5394 if (sym->attr.flavor == FL_VARIABLE)
5395 {
5396 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
5397 && sym->attr.referenced && !sym->attr.use_assoc)
5398 has_coarray_vars = true;
5399
5400 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
5401 generate_dependency_declarations (sym);
5402
5403 if (sym->attr.referenced)
5404 gfc_get_symbol_decl (sym);
5405
5406 /* Warnings for unused dummy arguments. */
5407 else if (sym->attr.dummy && !sym->attr.in_namelist)
5408 {
5409 /* INTENT(out) dummy arguments are likely meant to be set. */
5410 if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT)
5411 {
5412 if (sym->ts.type != BT_DERIVED)
5413 gfc_warning (OPT_Wunused_dummy_argument,
5414 "Dummy argument %qs at %L was declared "
5415 "INTENT(OUT) but was not set", sym->name,
5416 &sym->declared_at);
5417 else if (!gfc_has_default_initializer (sym->ts.u.derived)
5418 && !sym->ts.u.derived->attr.zero_comp)
5419 gfc_warning (OPT_Wunused_dummy_argument,
5420 "Derived-type dummy argument %qs at %L was "
5421 "declared INTENT(OUT) but was not set and "
5422 "does not have a default initializer",
5423 sym->name, &sym->declared_at);
5424 if (sym->backend_decl != NULL_TREE)
5425 TREE_NO_WARNING(sym->backend_decl) = 1;
5426 }
5427 else if (warn_unused_dummy_argument)
5428 {
5429 gfc_warning (OPT_Wunused_dummy_argument,
5430 "Unused dummy argument %qs at %L", sym->name,
5431 &sym->declared_at);
5432 if (sym->backend_decl != NULL_TREE)
5433 TREE_NO_WARNING(sym->backend_decl) = 1;
5434 }
5435 }
5436
5437 /* Warn for unused variables, but not if they're inside a common
5438 block or a namelist. */
5439 else if (warn_unused_variable
5440 && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
5441 {
5442 if (sym->attr.use_only)
5443 {
5444 gfc_warning (OPT_Wunused_variable,
5445 "Unused module variable %qs which has been "
5446 "explicitly imported at %L", sym->name,
5447 &sym->declared_at);
5448 if (sym->backend_decl != NULL_TREE)
5449 TREE_NO_WARNING(sym->backend_decl) = 1;
5450 }
5451 else if (!sym->attr.use_assoc)
5452 {
5453 /* Corner case: the symbol may be an entry point. At this point,
5454 it may appear to be an unused variable. Suppress warning. */
5455 bool enter = false;
5456 gfc_entry_list *el;
5457
5458 for (el = sym->ns->entries; el; el=el->next)
5459 if (strcmp(sym->name, el->sym->name) == 0)
5460 enter = true;
5461
5462 if (!enter)
5463 gfc_warning (OPT_Wunused_variable,
5464 "Unused variable %qs declared at %L",
5465 sym->name, &sym->declared_at);
5466 if (sym->backend_decl != NULL_TREE)
5467 TREE_NO_WARNING(sym->backend_decl) = 1;
5468 }
5469 }
5470
5471 /* For variable length CHARACTER parameters, the PARM_DECL already
5472 references the length variable, so force gfc_get_symbol_decl
5473 even when not referenced. If optimize > 0, it will be optimized
5474 away anyway. But do this only after emitting -Wunused-parameter
5475 warning if requested. */
5476 if (sym->attr.dummy && !sym->attr.referenced
5477 && sym->ts.type == BT_CHARACTER
5478 && sym->ts.u.cl->backend_decl != NULL
5479 && VAR_P (sym->ts.u.cl->backend_decl))
5480 {
5481 sym->attr.referenced = 1;
5482 gfc_get_symbol_decl (sym);
5483 }
5484
5485 /* INTENT(out) dummy arguments and result variables with allocatable
5486 components are reset by default and need to be set referenced to
5487 generate the code for nullification and automatic lengths. */
5488 if (!sym->attr.referenced
5489 && sym->ts.type == BT_DERIVED
5490 && sym->ts.u.derived->attr.alloc_comp
5491 && !sym->attr.pointer
5492 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
5493 ||
5494 (sym->attr.result && sym != sym->result)))
5495 {
5496 sym->attr.referenced = 1;
5497 gfc_get_symbol_decl (sym);
5498 }
5499
5500 /* Check for dependencies in the array specification and string
5501 length, adding the necessary declarations to the function. We
5502 mark the symbol now, as well as in traverse_ns, to prevent
5503 getting stuck in a circular dependency. */
5504 sym->mark = 1;
5505 }
5506 else if (sym->attr.flavor == FL_PARAMETER)
5507 {
5508 if (warn_unused_parameter
5509 && !sym->attr.referenced)
5510 {
5511 if (!sym->attr.use_assoc)
5512 gfc_warning (OPT_Wunused_parameter,
5513 "Unused parameter %qs declared at %L", sym->name,
5514 &sym->declared_at);
5515 else if (sym->attr.use_only)
5516 gfc_warning (OPT_Wunused_parameter,
5517 "Unused parameter %qs which has been explicitly "
5518 "imported at %L", sym->name, &sym->declared_at);
5519 }
5520
5521 if (sym->ns
5522 && sym->ns->parent
5523 && sym->ns->parent->code
5524 && sym->ns->parent->code->op == EXEC_BLOCK)
5525 {
5526 if (sym->attr.referenced)
5527 gfc_get_symbol_decl (sym);
5528 sym->mark = 1;
5529 }
5530 }
5531 else if (sym->attr.flavor == FL_PROCEDURE)
5532 {
5533 /* TODO: move to the appropriate place in resolve.c. */
5534 if (warn_return_type
5535 && sym->attr.function
5536 && sym->result
5537 && sym != sym->result
5538 && !sym->result->attr.referenced
5539 && !sym->attr.use_assoc
5540 && sym->attr.if_source != IFSRC_IFBODY)
5541 {
5542 gfc_warning (OPT_Wreturn_type,
5543 "Return value %qs of function %qs declared at "
5544 "%L not set", sym->result->name, sym->name,
5545 &sym->result->declared_at);
5546
5547 /* Prevents "Unused variable" warning for RESULT variables. */
5548 sym->result->mark = 1;
5549 }
5550 }
5551
5552 if (sym->attr.dummy == 1)
5553 {
5554 /* Modify the tree type for scalar character dummy arguments of bind(c)
5555 procedures if they are passed by value. The tree type for them will
5556 be promoted to INTEGER_TYPE for the middle end, which appears to be
5557 what C would do with characters passed by-value. The value attribute
5558 implies the dummy is a scalar. */
5559 if (sym->attr.value == 1 && sym->backend_decl != NULL
5560 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
5561 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
5562 gfc_conv_scalar_char_value (sym, NULL, NULL);
5563
5564 /* Unused procedure passed as dummy argument. */
5565 if (sym->attr.flavor == FL_PROCEDURE)
5566 {
5567 if (!sym->attr.referenced)
5568 {
5569 if (warn_unused_dummy_argument)
5570 gfc_warning (OPT_Wunused_dummy_argument,
5571 "Unused dummy argument %qs at %L", sym->name,
5572 &sym->declared_at);
5573 }
5574
5575 /* Silence bogus "unused parameter" warnings from the
5576 middle end. */
5577 if (sym->backend_decl != NULL_TREE)
5578 TREE_NO_WARNING (sym->backend_decl) = 1;
5579 }
5580 }
5581
5582 /* Make sure we convert the types of the derived types from iso_c_binding
5583 into (void *). */
5584 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
5585 && sym->ts.type == BT_DERIVED)
5586 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
5587 }
5588
5589
5590 static void
5591 generate_local_nml_decl (gfc_symbol * sym)
5592 {
5593 if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
5594 {
5595 tree decl = generate_namelist_decl (sym);
5596 pushdecl (decl);
5597 }
5598 }
5599
5600
5601 static void
5602 generate_local_vars (gfc_namespace * ns)
5603 {
5604 gfc_traverse_ns (ns, generate_local_decl);
5605 gfc_traverse_ns (ns, generate_local_nml_decl);
5606 }
5607
5608
5609 /* Generate a switch statement to jump to the correct entry point. Also
5610 creates the label decls for the entry points. */
5611
5612 static tree
5613 gfc_trans_entry_master_switch (gfc_entry_list * el)
5614 {
5615 stmtblock_t block;
5616 tree label;
5617 tree tmp;
5618 tree val;
5619
5620 gfc_init_block (&block);
5621 for (; el; el = el->next)
5622 {
5623 /* Add the case label. */
5624 label = gfc_build_label_decl (NULL_TREE);
5625 val = build_int_cst (gfc_array_index_type, el->id);
5626 tmp = build_case_label (val, NULL_TREE, label);
5627 gfc_add_expr_to_block (&block, tmp);
5628
5629 /* And jump to the actual entry point. */
5630 label = gfc_build_label_decl (NULL_TREE);
5631 tmp = build1_v (GOTO_EXPR, label);
5632 gfc_add_expr_to_block (&block, tmp);
5633
5634 /* Save the label decl. */
5635 el->label = label;
5636 }
5637 tmp = gfc_finish_block (&block);
5638 /* The first argument selects the entry point. */
5639 val = DECL_ARGUMENTS (current_function_decl);
5640 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
5641 val, tmp, NULL_TREE);
5642 return tmp;
5643 }
5644
5645
5646 /* Add code to string lengths of actual arguments passed to a function against
5647 the expected lengths of the dummy arguments. */
5648
5649 static void
5650 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
5651 {
5652 gfc_formal_arglist *formal;
5653
5654 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
5655 if (formal->sym && formal->sym->ts.type == BT_CHARACTER
5656 && !formal->sym->ts.deferred)
5657 {
5658 enum tree_code comparison;
5659 tree cond;
5660 tree argname;
5661 gfc_symbol *fsym;
5662 gfc_charlen *cl;
5663 const char *message;
5664
5665 fsym = formal->sym;
5666 cl = fsym->ts.u.cl;
5667
5668 gcc_assert (cl);
5669 gcc_assert (cl->passed_length != NULL_TREE);
5670 gcc_assert (cl->backend_decl != NULL_TREE);
5671
5672 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
5673 string lengths must match exactly. Otherwise, it is only required
5674 that the actual string length is *at least* the expected one.
5675 Sequence association allows for a mismatch of the string length
5676 if the actual argument is (part of) an array, but only if the
5677 dummy argument is an array. (See "Sequence association" in
5678 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
5679 if (fsym->attr.pointer || fsym->attr.allocatable
5680 || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
5681 || fsym->as->type == AS_ASSUMED_RANK)))
5682 {
5683 comparison = NE_EXPR;
5684 message = _("Actual string length does not match the declared one"
5685 " for dummy argument '%s' (%ld/%ld)");
5686 }
5687 else if (fsym->as && fsym->as->rank != 0)
5688 continue;
5689 else
5690 {
5691 comparison = LT_EXPR;
5692 message = _("Actual string length is shorter than the declared one"
5693 " for dummy argument '%s' (%ld/%ld)");
5694 }
5695
5696 /* Build the condition. For optional arguments, an actual length
5697 of 0 is also acceptable if the associated string is NULL, which
5698 means the argument was not passed. */
5699 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
5700 cl->passed_length, cl->backend_decl);
5701 if (fsym->attr.optional)
5702 {
5703 tree not_absent;
5704 tree not_0length;
5705 tree absent_failed;
5706
5707 not_0length = fold_build2_loc (input_location, NE_EXPR,
5708 boolean_type_node,
5709 cl->passed_length,
5710 build_zero_cst (gfc_charlen_type_node));
5711 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
5712 fsym->attr.referenced = 1;
5713 not_absent = gfc_conv_expr_present (fsym);
5714
5715 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5716 boolean_type_node, not_0length,
5717 not_absent);
5718
5719 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5720 boolean_type_node, cond, absent_failed);
5721 }
5722
5723 /* Build the runtime check. */
5724 argname = gfc_build_cstring_const (fsym->name);
5725 argname = gfc_build_addr_expr (pchar_type_node, argname);
5726 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
5727 message, argname,
5728 fold_convert (long_integer_type_node,
5729 cl->passed_length),
5730 fold_convert (long_integer_type_node,
5731 cl->backend_decl));
5732 }
5733 }
5734
5735
5736 static void
5737 create_main_function (tree fndecl)
5738 {
5739 tree old_context;
5740 tree ftn_main;
5741 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
5742 stmtblock_t body;
5743
5744 old_context = current_function_decl;
5745
5746 if (old_context)
5747 {
5748 push_function_context ();
5749 saved_parent_function_decls = saved_function_decls;
5750 saved_function_decls = NULL_TREE;
5751 }
5752
5753 /* main() function must be declared with global scope. */
5754 gcc_assert (current_function_decl == NULL_TREE);
5755
5756 /* Declare the function. */
5757 tmp = build_function_type_list (integer_type_node, integer_type_node,
5758 build_pointer_type (pchar_type_node),
5759 NULL_TREE);
5760 main_identifier_node = get_identifier ("main");
5761 ftn_main = build_decl (input_location, FUNCTION_DECL,
5762 main_identifier_node, tmp);
5763 DECL_EXTERNAL (ftn_main) = 0;
5764 TREE_PUBLIC (ftn_main) = 1;
5765 TREE_STATIC (ftn_main) = 1;
5766 DECL_ATTRIBUTES (ftn_main)
5767 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
5768
5769 /* Setup the result declaration (for "return 0"). */
5770 result_decl = build_decl (input_location,
5771 RESULT_DECL, NULL_TREE, integer_type_node);
5772 DECL_ARTIFICIAL (result_decl) = 1;
5773 DECL_IGNORED_P (result_decl) = 1;
5774 DECL_CONTEXT (result_decl) = ftn_main;
5775 DECL_RESULT (ftn_main) = result_decl;
5776
5777 pushdecl (ftn_main);
5778
5779 /* Get the arguments. */
5780
5781 arglist = NULL_TREE;
5782 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
5783
5784 tmp = TREE_VALUE (typelist);
5785 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
5786 DECL_CONTEXT (argc) = ftn_main;
5787 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
5788 TREE_READONLY (argc) = 1;
5789 gfc_finish_decl (argc);
5790 arglist = chainon (arglist, argc);
5791
5792 typelist = TREE_CHAIN (typelist);
5793 tmp = TREE_VALUE (typelist);
5794 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
5795 DECL_CONTEXT (argv) = ftn_main;
5796 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
5797 TREE_READONLY (argv) = 1;
5798 DECL_BY_REFERENCE (argv) = 1;
5799 gfc_finish_decl (argv);
5800 arglist = chainon (arglist, argv);
5801
5802 DECL_ARGUMENTS (ftn_main) = arglist;
5803 current_function_decl = ftn_main;
5804 announce_function (ftn_main);
5805
5806 rest_of_decl_compilation (ftn_main, 1, 0);
5807 make_decl_rtl (ftn_main);
5808 allocate_struct_function (ftn_main, false);
5809 pushlevel ();
5810
5811 gfc_init_block (&body);
5812
5813 /* Call some libgfortran initialization routines, call then MAIN__(). */
5814
5815 /* Call _gfortran_caf_init (*argc, ***argv). */
5816 if (flag_coarray == GFC_FCOARRAY_LIB)
5817 {
5818 tree pint_type, pppchar_type;
5819 pint_type = build_pointer_type (integer_type_node);
5820 pppchar_type
5821 = build_pointer_type (build_pointer_type (pchar_type_node));
5822
5823 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
5824 gfc_build_addr_expr (pint_type, argc),
5825 gfc_build_addr_expr (pppchar_type, argv));
5826 gfc_add_expr_to_block (&body, tmp);
5827 }
5828
5829 /* Call _gfortran_set_args (argc, argv). */
5830 TREE_USED (argc) = 1;
5831 TREE_USED (argv) = 1;
5832 tmp = build_call_expr_loc (input_location,
5833 gfor_fndecl_set_args, 2, argc, argv);
5834 gfc_add_expr_to_block (&body, tmp);
5835
5836 /* Add a call to set_options to set up the runtime library Fortran
5837 language standard parameters. */
5838 {
5839 tree array_type, array, var;
5840 vec<constructor_elt, va_gc> *v = NULL;
5841 static const int noptions = 7;
5842
5843 /* Passing a new option to the library requires three modifications:
5844 + add it to the tree_cons list below
5845 + change the noptions variable above
5846 + modify the library (runtime/compile_options.c)! */
5847
5848 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5849 build_int_cst (integer_type_node,
5850 gfc_option.warn_std));
5851 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5852 build_int_cst (integer_type_node,
5853 gfc_option.allow_std));
5854 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5855 build_int_cst (integer_type_node, pedantic));
5856 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5857 build_int_cst (integer_type_node, flag_backtrace));
5858 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5859 build_int_cst (integer_type_node, flag_sign_zero));
5860 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5861 build_int_cst (integer_type_node,
5862 (gfc_option.rtcheck
5863 & GFC_RTCHECK_BOUNDS)));
5864 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5865 build_int_cst (integer_type_node,
5866 gfc_option.fpe_summary));
5867
5868 array_type = build_array_type_nelts (integer_type_node, noptions);
5869 array = build_constructor (array_type, v);
5870 TREE_CONSTANT (array) = 1;
5871 TREE_STATIC (array) = 1;
5872
5873 /* Create a static variable to hold the jump table. */
5874 var = build_decl (input_location, VAR_DECL,
5875 create_tmp_var_name ("options"), array_type);
5876 DECL_ARTIFICIAL (var) = 1;
5877 DECL_IGNORED_P (var) = 1;
5878 TREE_CONSTANT (var) = 1;
5879 TREE_STATIC (var) = 1;
5880 TREE_READONLY (var) = 1;
5881 DECL_INITIAL (var) = array;
5882 pushdecl (var);
5883 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
5884
5885 tmp = build_call_expr_loc (input_location,
5886 gfor_fndecl_set_options, 2,
5887 build_int_cst (integer_type_node, noptions), var);
5888 gfc_add_expr_to_block (&body, tmp);
5889 }
5890
5891 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5892 the library will raise a FPE when needed. */
5893 if (gfc_option.fpe != 0)
5894 {
5895 tmp = build_call_expr_loc (input_location,
5896 gfor_fndecl_set_fpe, 1,
5897 build_int_cst (integer_type_node,
5898 gfc_option.fpe));
5899 gfc_add_expr_to_block (&body, tmp);
5900 }
5901
5902 /* If this is the main program and an -fconvert option was provided,
5903 add a call to set_convert. */
5904
5905 if (flag_convert != GFC_FLAG_CONVERT_NATIVE)
5906 {
5907 tmp = build_call_expr_loc (input_location,
5908 gfor_fndecl_set_convert, 1,
5909 build_int_cst (integer_type_node, flag_convert));
5910 gfc_add_expr_to_block (&body, tmp);
5911 }
5912
5913 /* If this is the main program and an -frecord-marker option was provided,
5914 add a call to set_record_marker. */
5915
5916 if (flag_record_marker != 0)
5917 {
5918 tmp = build_call_expr_loc (input_location,
5919 gfor_fndecl_set_record_marker, 1,
5920 build_int_cst (integer_type_node,
5921 flag_record_marker));
5922 gfc_add_expr_to_block (&body, tmp);
5923 }
5924
5925 if (flag_max_subrecord_length != 0)
5926 {
5927 tmp = build_call_expr_loc (input_location,
5928 gfor_fndecl_set_max_subrecord_length, 1,
5929 build_int_cst (integer_type_node,
5930 flag_max_subrecord_length));
5931 gfc_add_expr_to_block (&body, tmp);
5932 }
5933
5934 /* Call MAIN__(). */
5935 tmp = build_call_expr_loc (input_location,
5936 fndecl, 0);
5937 gfc_add_expr_to_block (&body, tmp);
5938
5939 /* Mark MAIN__ as used. */
5940 TREE_USED (fndecl) = 1;
5941
5942 /* Coarray: Call _gfortran_caf_finalize(void). */
5943 if (flag_coarray == GFC_FCOARRAY_LIB)
5944 {
5945 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
5946 gfc_add_expr_to_block (&body, tmp);
5947 }
5948
5949 /* "return 0". */
5950 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
5951 DECL_RESULT (ftn_main),
5952 build_int_cst (integer_type_node, 0));
5953 tmp = build1_v (RETURN_EXPR, tmp);
5954 gfc_add_expr_to_block (&body, tmp);
5955
5956
5957 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
5958 decl = getdecls ();
5959
5960 /* Finish off this function and send it for code generation. */
5961 poplevel (1, 1);
5962 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
5963
5964 DECL_SAVED_TREE (ftn_main)
5965 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
5966 DECL_INITIAL (ftn_main));
5967
5968 /* Output the GENERIC tree. */
5969 dump_function (TDI_original, ftn_main);
5970
5971 cgraph_node::finalize_function (ftn_main, true);
5972
5973 if (old_context)
5974 {
5975 pop_function_context ();
5976 saved_function_decls = saved_parent_function_decls;
5977 }
5978 current_function_decl = old_context;
5979 }
5980
5981
5982 /* Get the result expression for a procedure. */
5983
5984 static tree
5985 get_proc_result (gfc_symbol* sym)
5986 {
5987 if (sym->attr.subroutine || sym == sym->result)
5988 {
5989 if (current_fake_result_decl != NULL)
5990 return TREE_VALUE (current_fake_result_decl);
5991
5992 return NULL_TREE;
5993 }
5994
5995 return sym->result->backend_decl;
5996 }
5997
5998
5999 /* Generate an appropriate return-statement for a procedure. */
6000
6001 tree
6002 gfc_generate_return (void)
6003 {
6004 gfc_symbol* sym;
6005 tree result;
6006 tree fndecl;
6007
6008 sym = current_procedure_symbol;
6009 fndecl = sym->backend_decl;
6010
6011 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
6012 result = NULL_TREE;
6013 else
6014 {
6015 result = get_proc_result (sym);
6016
6017 /* Set the return value to the dummy result variable. The
6018 types may be different for scalar default REAL functions
6019 with -ff2c, therefore we have to convert. */
6020 if (result != NULL_TREE)
6021 {
6022 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
6023 result = fold_build2_loc (input_location, MODIFY_EXPR,
6024 TREE_TYPE (result), DECL_RESULT (fndecl),
6025 result);
6026 }
6027 }
6028
6029 return build1_v (RETURN_EXPR, result);
6030 }
6031
6032
6033 static void
6034 is_from_ieee_module (gfc_symbol *sym)
6035 {
6036 if (sym->from_intmod == INTMOD_IEEE_FEATURES
6037 || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS
6038 || sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6039 seen_ieee_symbol = 1;
6040 }
6041
6042
6043 static int
6044 is_ieee_module_used (gfc_namespace *ns)
6045 {
6046 seen_ieee_symbol = 0;
6047 gfc_traverse_ns (ns, is_from_ieee_module);
6048 return seen_ieee_symbol;
6049 }
6050
6051
6052 static gfc_omp_clauses *module_oacc_clauses;
6053
6054
6055 static void
6056 add_clause (gfc_symbol *sym, gfc_omp_map_op map_op)
6057 {
6058 gfc_omp_namelist *n;
6059
6060 n = gfc_get_omp_namelist ();
6061 n->sym = sym;
6062 n->u.map_op = map_op;
6063
6064 if (!module_oacc_clauses)
6065 module_oacc_clauses = gfc_get_omp_clauses ();
6066
6067 if (module_oacc_clauses->lists[OMP_LIST_MAP])
6068 n->next = module_oacc_clauses->lists[OMP_LIST_MAP];
6069
6070 module_oacc_clauses->lists[OMP_LIST_MAP] = n;
6071 }
6072
6073
6074 static void
6075 find_module_oacc_declare_clauses (gfc_symbol *sym)
6076 {
6077 if (sym->attr.use_assoc)
6078 {
6079 gfc_omp_map_op map_op;
6080
6081 if (sym->attr.oacc_declare_create)
6082 map_op = OMP_MAP_FORCE_ALLOC;
6083
6084 if (sym->attr.oacc_declare_copyin)
6085 map_op = OMP_MAP_FORCE_TO;
6086
6087 if (sym->attr.oacc_declare_deviceptr)
6088 map_op = OMP_MAP_FORCE_DEVICEPTR;
6089
6090 if (sym->attr.oacc_declare_device_resident)
6091 map_op = OMP_MAP_DEVICE_RESIDENT;
6092
6093 if (sym->attr.oacc_declare_create
6094 || sym->attr.oacc_declare_copyin
6095 || sym->attr.oacc_declare_deviceptr
6096 || sym->attr.oacc_declare_device_resident)
6097 {
6098 sym->attr.referenced = 1;
6099 add_clause (sym, map_op);
6100 }
6101 }
6102 }
6103
6104
6105 void
6106 finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
6107 {
6108 gfc_code *code;
6109 gfc_oacc_declare *oc;
6110 locus where = gfc_current_locus;
6111 gfc_omp_clauses *omp_clauses = NULL;
6112 gfc_omp_namelist *n, *p;
6113
6114 gfc_traverse_ns (ns, find_module_oacc_declare_clauses);
6115
6116 if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM)
6117 {
6118 gfc_oacc_declare *new_oc;
6119
6120 new_oc = gfc_get_oacc_declare ();
6121 new_oc->next = ns->oacc_declare;
6122 new_oc->clauses = module_oacc_clauses;
6123
6124 ns->oacc_declare = new_oc;
6125 module_oacc_clauses = NULL;
6126 }
6127
6128 if (!ns->oacc_declare)
6129 return;
6130
6131 for (oc = ns->oacc_declare; oc; oc = oc->next)
6132 {
6133 if (oc->module_var)
6134 continue;
6135
6136 if (block)
6137 gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed "
6138 "in BLOCK construct", &oc->loc);
6139
6140
6141 if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP])
6142 {
6143 if (omp_clauses == NULL)
6144 {
6145 omp_clauses = oc->clauses;
6146 continue;
6147 }
6148
6149 for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next)
6150 ;
6151
6152 gcc_assert (p->next == NULL);
6153
6154 p->next = omp_clauses->lists[OMP_LIST_MAP];
6155 omp_clauses = oc->clauses;
6156 }
6157 }
6158
6159 if (!omp_clauses)
6160 return;
6161
6162 for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next)
6163 {
6164 switch (n->u.map_op)
6165 {
6166 case OMP_MAP_DEVICE_RESIDENT:
6167 n->u.map_op = OMP_MAP_FORCE_ALLOC;
6168 break;
6169
6170 default:
6171 break;
6172 }
6173 }
6174
6175 code = XCNEW (gfc_code);
6176 code->op = EXEC_OACC_DECLARE;
6177 code->loc = where;
6178
6179 code->ext.oacc_declare = gfc_get_oacc_declare ();
6180 code->ext.oacc_declare->clauses = omp_clauses;
6181
6182 code->block = XCNEW (gfc_code);
6183 code->block->op = EXEC_OACC_DECLARE;
6184 code->block->loc = where;
6185
6186 if (ns->code)
6187 code->block->next = ns->code;
6188
6189 ns->code = code;
6190
6191 return;
6192 }
6193
6194
6195 /* Generate code for a function. */
6196
6197 void
6198 gfc_generate_function_code (gfc_namespace * ns)
6199 {
6200 tree fndecl;
6201 tree old_context;
6202 tree decl;
6203 tree tmp;
6204 tree fpstate = NULL_TREE;
6205 stmtblock_t init, cleanup;
6206 stmtblock_t body;
6207 gfc_wrapped_block try_block;
6208 tree recurcheckvar = NULL_TREE;
6209 gfc_symbol *sym;
6210 gfc_symbol *previous_procedure_symbol;
6211 int rank, ieee;
6212 bool is_recursive;
6213
6214 sym = ns->proc_name;
6215 previous_procedure_symbol = current_procedure_symbol;
6216 current_procedure_symbol = sym;
6217
6218 /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
6219 lost or worse. */
6220 sym->tlink = sym;
6221
6222 /* Create the declaration for functions with global scope. */
6223 if (!sym->backend_decl)
6224 gfc_create_function_decl (ns, false);
6225
6226 fndecl = sym->backend_decl;
6227 old_context = current_function_decl;
6228
6229 if (old_context)
6230 {
6231 push_function_context ();
6232 saved_parent_function_decls = saved_function_decls;
6233 saved_function_decls = NULL_TREE;
6234 }
6235
6236 trans_function_start (sym);
6237
6238 gfc_init_block (&init);
6239
6240 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
6241 {
6242 /* Copy length backend_decls to all entry point result
6243 symbols. */
6244 gfc_entry_list *el;
6245 tree backend_decl;
6246
6247 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
6248 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
6249 for (el = ns->entries; el; el = el->next)
6250 el->sym->result->ts.u.cl->backend_decl = backend_decl;
6251 }
6252
6253 /* Translate COMMON blocks. */
6254 gfc_trans_common (ns);
6255
6256 /* Null the parent fake result declaration if this namespace is
6257 a module function or an external procedures. */
6258 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
6259 || ns->parent == NULL)
6260 parent_fake_result_decl = NULL_TREE;
6261
6262 gfc_generate_contained_functions (ns);
6263
6264 nonlocal_dummy_decls = NULL;
6265 nonlocal_dummy_decl_pset = NULL;
6266
6267 has_coarray_vars = false;
6268 generate_local_vars (ns);
6269
6270 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6271 generate_coarray_init (ns);
6272
6273 /* Keep the parent fake result declaration in module functions
6274 or external procedures. */
6275 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
6276 || ns->parent == NULL)
6277 current_fake_result_decl = parent_fake_result_decl;
6278 else
6279 current_fake_result_decl = NULL_TREE;
6280
6281 is_recursive = sym->attr.recursive
6282 || (sym->attr.entry_master
6283 && sym->ns->entries->sym->attr.recursive);
6284 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
6285 && !is_recursive && !flag_recursive)
6286 {
6287 char * msg;
6288
6289 msg = xasprintf ("Recursive call to nonrecursive procedure '%s'",
6290 sym->name);
6291 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
6292 TREE_STATIC (recurcheckvar) = 1;
6293 DECL_INITIAL (recurcheckvar) = boolean_false_node;
6294 gfc_add_expr_to_block (&init, recurcheckvar);
6295 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
6296 &sym->declared_at, msg);
6297 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
6298 free (msg);
6299 }
6300
6301 /* Check if an IEEE module is used in the procedure. If so, save
6302 the floating point state. */
6303 ieee = is_ieee_module_used (ns);
6304 if (ieee)
6305 fpstate = gfc_save_fp_state (&init);
6306
6307 /* Now generate the code for the body of this function. */
6308 gfc_init_block (&body);
6309
6310 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
6311 && sym->attr.subroutine)
6312 {
6313 tree alternate_return;
6314 alternate_return = gfc_get_fake_result_decl (sym, 0);
6315 gfc_add_modify (&body, alternate_return, integer_zero_node);
6316 }
6317
6318 if (ns->entries)
6319 {
6320 /* Jump to the correct entry point. */
6321 tmp = gfc_trans_entry_master_switch (ns->entries);
6322 gfc_add_expr_to_block (&body, tmp);
6323 }
6324
6325 /* If bounds-checking is enabled, generate code to check passed in actual
6326 arguments against the expected dummy argument attributes (e.g. string
6327 lengths). */
6328 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
6329 add_argument_checking (&body, sym);
6330
6331 finish_oacc_declare (ns, sym, false);
6332
6333 tmp = gfc_trans_code (ns->code);
6334 gfc_add_expr_to_block (&body, tmp);
6335
6336 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
6337 || (sym->result && sym->result != sym
6338 && sym->result->ts.type == BT_DERIVED
6339 && sym->result->ts.u.derived->attr.alloc_comp))
6340 {
6341 bool artificial_result_decl = false;
6342 tree result = get_proc_result (sym);
6343 gfc_symbol *rsym = sym == sym->result ? sym : sym->result;
6344
6345 /* Make sure that a function returning an object with
6346 alloc/pointer_components always has a result, where at least
6347 the allocatable/pointer components are set to zero. */
6348 if (result == NULL_TREE && sym->attr.function
6349 && ((sym->result->ts.type == BT_DERIVED
6350 && (sym->attr.allocatable
6351 || sym->attr.pointer
6352 || sym->result->ts.u.derived->attr.alloc_comp
6353 || sym->result->ts.u.derived->attr.pointer_comp))
6354 || (sym->result->ts.type == BT_CLASS
6355 && (CLASS_DATA (sym)->attr.allocatable
6356 || CLASS_DATA (sym)->attr.class_pointer
6357 || CLASS_DATA (sym->result)->attr.alloc_comp
6358 || CLASS_DATA (sym->result)->attr.pointer_comp))))
6359 {
6360 artificial_result_decl = true;
6361 result = gfc_get_fake_result_decl (sym, 0);
6362 }
6363
6364 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
6365 {
6366 if (sym->attr.allocatable && sym->attr.dimension == 0
6367 && sym->result == sym)
6368 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
6369 null_pointer_node));
6370 else if (sym->ts.type == BT_CLASS
6371 && CLASS_DATA (sym)->attr.allocatable
6372 && CLASS_DATA (sym)->attr.dimension == 0
6373 && sym->result == sym)
6374 {
6375 tmp = CLASS_DATA (sym)->backend_decl;
6376 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6377 TREE_TYPE (tmp), result, tmp, NULL_TREE);
6378 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
6379 null_pointer_node));
6380 }
6381 else if (sym->ts.type == BT_DERIVED
6382 && !sym->attr.allocatable)
6383 {
6384 gfc_expr *init_exp;
6385 /* Arrays are not initialized using the default initializer of
6386 their elements. Therefore only check if a default
6387 initializer is available when the result is scalar. */
6388 init_exp = rsym->as ? NULL
6389 : gfc_generate_initializer (&rsym->ts, true);
6390 if (init_exp)
6391 {
6392 tmp = gfc_trans_structure_assign (result, init_exp, 0);
6393 gfc_free_expr (init_exp);
6394 gfc_add_expr_to_block (&init, tmp);
6395 }
6396 else if (rsym->ts.u.derived->attr.alloc_comp)
6397 {
6398 rank = rsym->as ? rsym->as->rank : 0;
6399 tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result,
6400 rank);
6401 gfc_prepend_expr_to_block (&body, tmp);
6402 }
6403 }
6404 }
6405
6406 if (result == NULL_TREE || artificial_result_decl)
6407 {
6408 /* TODO: move to the appropriate place in resolve.c. */
6409 if (warn_return_type && sym == sym->result)
6410 gfc_warning (OPT_Wreturn_type,
6411 "Return value of function %qs at %L not set",
6412 sym->name, &sym->declared_at);
6413 if (warn_return_type)
6414 TREE_NO_WARNING(sym->backend_decl) = 1;
6415 }
6416 if (result != NULL_TREE)
6417 gfc_add_expr_to_block (&body, gfc_generate_return ());
6418 }
6419
6420 gfc_init_block (&cleanup);
6421
6422 /* Reset recursion-check variable. */
6423 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
6424 && !is_recursive && !flag_openmp && recurcheckvar != NULL_TREE)
6425 {
6426 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
6427 recurcheckvar = NULL;
6428 }
6429
6430 /* If IEEE modules are loaded, restore the floating-point state. */
6431 if (ieee)
6432 gfc_restore_fp_state (&cleanup, fpstate);
6433
6434 /* Finish the function body and add init and cleanup code. */
6435 tmp = gfc_finish_block (&body);
6436 gfc_start_wrapped_block (&try_block, tmp);
6437 /* Add code to create and cleanup arrays. */
6438 gfc_trans_deferred_vars (sym, &try_block);
6439 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
6440 gfc_finish_block (&cleanup));
6441
6442 /* Add all the decls we created during processing. */
6443 decl = nreverse (saved_function_decls);
6444 while (decl)
6445 {
6446 tree next;
6447
6448 next = DECL_CHAIN (decl);
6449 DECL_CHAIN (decl) = NULL_TREE;
6450 pushdecl (decl);
6451 decl = next;
6452 }
6453 saved_function_decls = NULL_TREE;
6454
6455 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
6456 decl = getdecls ();
6457
6458 /* Finish off this function and send it for code generation. */
6459 poplevel (1, 1);
6460 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
6461
6462 DECL_SAVED_TREE (fndecl)
6463 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
6464 DECL_INITIAL (fndecl));
6465
6466 if (nonlocal_dummy_decls)
6467 {
6468 BLOCK_VARS (DECL_INITIAL (fndecl))
6469 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
6470 delete nonlocal_dummy_decl_pset;
6471 nonlocal_dummy_decls = NULL;
6472 nonlocal_dummy_decl_pset = NULL;
6473 }
6474
6475 /* Output the GENERIC tree. */
6476 dump_function (TDI_original, fndecl);
6477
6478 /* Store the end of the function, so that we get good line number
6479 info for the epilogue. */
6480 cfun->function_end_locus = input_location;
6481
6482 /* We're leaving the context of this function, so zap cfun.
6483 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
6484 tree_rest_of_compilation. */
6485 set_cfun (NULL);
6486
6487 if (old_context)
6488 {
6489 pop_function_context ();
6490 saved_function_decls = saved_parent_function_decls;
6491 }
6492 current_function_decl = old_context;
6493
6494 if (decl_function_context (fndecl))
6495 {
6496 /* Register this function with cgraph just far enough to get it
6497 added to our parent's nested function list.
6498 If there are static coarrays in this function, the nested _caf_init
6499 function has already called cgraph_create_node, which also created
6500 the cgraph node for this function. */
6501 if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB)
6502 (void) cgraph_node::get_create (fndecl);
6503 }
6504 else
6505 cgraph_node::finalize_function (fndecl, true);
6506
6507 gfc_trans_use_stmts (ns);
6508 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
6509
6510 if (sym->attr.is_main_program)
6511 create_main_function (fndecl);
6512
6513 current_procedure_symbol = previous_procedure_symbol;
6514 }
6515
6516
6517 void
6518 gfc_generate_constructors (void)
6519 {
6520 gcc_assert (gfc_static_ctors == NULL_TREE);
6521 #if 0
6522 tree fnname;
6523 tree type;
6524 tree fndecl;
6525 tree decl;
6526 tree tmp;
6527
6528 if (gfc_static_ctors == NULL_TREE)
6529 return;
6530
6531 fnname = get_file_function_name ("I");
6532 type = build_function_type_list (void_type_node, NULL_TREE);
6533
6534 fndecl = build_decl (input_location,
6535 FUNCTION_DECL, fnname, type);
6536 TREE_PUBLIC (fndecl) = 1;
6537
6538 decl = build_decl (input_location,
6539 RESULT_DECL, NULL_TREE, void_type_node);
6540 DECL_ARTIFICIAL (decl) = 1;
6541 DECL_IGNORED_P (decl) = 1;
6542 DECL_CONTEXT (decl) = fndecl;
6543 DECL_RESULT (fndecl) = decl;
6544
6545 pushdecl (fndecl);
6546
6547 current_function_decl = fndecl;
6548
6549 rest_of_decl_compilation (fndecl, 1, 0);
6550
6551 make_decl_rtl (fndecl);
6552
6553 allocate_struct_function (fndecl, false);
6554
6555 pushlevel ();
6556
6557 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
6558 {
6559 tmp = build_call_expr_loc (input_location,
6560 TREE_VALUE (gfc_static_ctors), 0);
6561 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
6562 }
6563
6564 decl = getdecls ();
6565 poplevel (1, 1);
6566
6567 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
6568 DECL_SAVED_TREE (fndecl)
6569 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
6570 DECL_INITIAL (fndecl));
6571
6572 free_after_parsing (cfun);
6573 free_after_compilation (cfun);
6574
6575 tree_rest_of_compilation (fndecl);
6576
6577 current_function_decl = NULL_TREE;
6578 #endif
6579 }
6580
6581 /* Translates a BLOCK DATA program unit. This means emitting the
6582 commons contained therein plus their initializations. We also emit
6583 a globally visible symbol to make sure that each BLOCK DATA program
6584 unit remains unique. */
6585
6586 void
6587 gfc_generate_block_data (gfc_namespace * ns)
6588 {
6589 tree decl;
6590 tree id;
6591
6592 /* Tell the backend the source location of the block data. */
6593 if (ns->proc_name)
6594 gfc_set_backend_locus (&ns->proc_name->declared_at);
6595 else
6596 gfc_set_backend_locus (&gfc_current_locus);
6597
6598 /* Process the DATA statements. */
6599 gfc_trans_common (ns);
6600
6601 /* Create a global symbol with the mane of the block data. This is to
6602 generate linker errors if the same name is used twice. It is never
6603 really used. */
6604 if (ns->proc_name)
6605 id = gfc_sym_mangled_function_id (ns->proc_name);
6606 else
6607 id = get_identifier ("__BLOCK_DATA__");
6608
6609 decl = build_decl (input_location,
6610 VAR_DECL, id, gfc_array_index_type);
6611 TREE_PUBLIC (decl) = 1;
6612 TREE_STATIC (decl) = 1;
6613 DECL_IGNORED_P (decl) = 1;
6614
6615 pushdecl (decl);
6616 rest_of_decl_compilation (decl, 1, 0);
6617 }
6618
6619
6620 /* Process the local variables of a BLOCK construct. */
6621
6622 void
6623 gfc_process_block_locals (gfc_namespace* ns)
6624 {
6625 tree decl;
6626
6627 gcc_assert (saved_local_decls == NULL_TREE);
6628 has_coarray_vars = false;
6629
6630 generate_local_vars (ns);
6631
6632 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6633 generate_coarray_init (ns);
6634
6635 decl = nreverse (saved_local_decls);
6636 while (decl)
6637 {
6638 tree next;
6639
6640 next = DECL_CHAIN (decl);
6641 DECL_CHAIN (decl) = NULL_TREE;
6642 pushdecl (decl);
6643 decl = next;
6644 }
6645 saved_local_decls = NULL_TREE;
6646 }
6647
6648
6649 #include "gt-fortran-trans-decl.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org