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