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