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