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