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