projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
re PR fortran/48820 (TR 29113: Implement parts needed for MPI 3)
[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, 2012
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_deregister;
125 tree gfor_fndecl_caf_critical;
126 tree gfor_fndecl_caf_end_critical;
127 tree gfor_fndecl_caf_sync_all;
128 tree gfor_fndecl_caf_sync_images;
129 tree gfor_fndecl_caf_error_stop;
130 tree gfor_fndecl_caf_error_stop_str;
131
132 /* Coarray global variables for num_images/this_image. */
133
134 tree gfort_gvar_caf_num_images;
135 tree gfort_gvar_caf_this_image;
136
137
138 /* Math functions. Many other math functions are handled in
139 trans-intrinsic.c. */
140
141 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
142 tree gfor_fndecl_math_ishftc4;
143 tree gfor_fndecl_math_ishftc8;
144 tree gfor_fndecl_math_ishftc16;
145
146
147 /* String functions. */
148
149 tree gfor_fndecl_compare_string;
150 tree gfor_fndecl_concat_string;
151 tree gfor_fndecl_string_len_trim;
152 tree gfor_fndecl_string_index;
153 tree gfor_fndecl_string_scan;
154 tree gfor_fndecl_string_verify;
155 tree gfor_fndecl_string_trim;
156 tree gfor_fndecl_string_minmax;
157 tree gfor_fndecl_adjustl;
158 tree gfor_fndecl_adjustr;
159 tree gfor_fndecl_select_string;
160 tree gfor_fndecl_compare_string_char4;
161 tree gfor_fndecl_concat_string_char4;
162 tree gfor_fndecl_string_len_trim_char4;
163 tree gfor_fndecl_string_index_char4;
164 tree gfor_fndecl_string_scan_char4;
165 tree gfor_fndecl_string_verify_char4;
166 tree gfor_fndecl_string_trim_char4;
167 tree gfor_fndecl_string_minmax_char4;
168 tree gfor_fndecl_adjustl_char4;
169 tree gfor_fndecl_adjustr_char4;
170 tree gfor_fndecl_select_string_char4;
171
172
173 /* Conversion between character kinds. */
174 tree gfor_fndecl_convert_char1_to_char4;
175 tree gfor_fndecl_convert_char4_to_char1;
176
177
178 /* Other misc. runtime library functions. */
179 tree gfor_fndecl_size0;
180 tree gfor_fndecl_size1;
181 tree gfor_fndecl_iargc;
182
183 /* Intrinsic functions implemented in Fortran. */
184 tree gfor_fndecl_sc_kind;
185 tree gfor_fndecl_si_kind;
186 tree gfor_fndecl_sr_kind;
187
188 /* BLAS gemm functions. */
189 tree gfor_fndecl_sgemm;
190 tree gfor_fndecl_dgemm;
191 tree gfor_fndecl_cgemm;
192 tree gfor_fndecl_zgemm;
193
194
195 static void
196 gfc_add_decl_to_parent_function (tree decl)
197 {
198 gcc_assert (decl);
199 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
200 DECL_NONLOCAL (decl) = 1;
201 DECL_CHAIN (decl) = saved_parent_function_decls;
202 saved_parent_function_decls = decl;
203 }
204
205 void
206 gfc_add_decl_to_function (tree decl)
207 {
208 gcc_assert (decl);
209 TREE_USED (decl) = 1;
210 DECL_CONTEXT (decl) = current_function_decl;
211 DECL_CHAIN (decl) = saved_function_decls;
212 saved_function_decls = decl;
213 }
214
215 static void
216 add_decl_as_local (tree decl)
217 {
218 gcc_assert (decl);
219 TREE_USED (decl) = 1;
220 DECL_CONTEXT (decl) = current_function_decl;
221 DECL_CHAIN (decl) = saved_local_decls;
222 saved_local_decls = decl;
223 }
224
225
226 /* Build a backend label declaration. Set TREE_USED for named labels.
227 The context of the label is always the current_function_decl. All
228 labels are marked artificial. */
229
230 tree
231 gfc_build_label_decl (tree label_id)
232 {
233 /* 2^32 temporaries should be enough. */
234 static unsigned int tmp_num = 1;
235 tree label_decl;
236 char *label_name;
237
238 if (label_id == NULL_TREE)
239 {
240 /* Build an internal label name. */
241 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
242 label_id = get_identifier (label_name);
243 }
244 else
245 label_name = NULL;
246
247 /* Build the LABEL_DECL node. Labels have no type. */
248 label_decl = build_decl (input_location,
249 LABEL_DECL, label_id, void_type_node);
250 DECL_CONTEXT (label_decl) = current_function_decl;
251 DECL_MODE (label_decl) = VOIDmode;
252
253 /* We always define the label as used, even if the original source
254 file never references the label. We don't want all kinds of
255 spurious warnings for old-style Fortran code with too many
256 labels. */
257 TREE_USED (label_decl) = 1;
258
259 DECL_ARTIFICIAL (label_decl) = 1;
260 return label_decl;
261 }
262
263
264 /* Set the backend source location of a decl. */
265
266 void
267 gfc_set_decl_location (tree decl, locus * loc)
268 {
269 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
270 }
271
272
273 /* Return the backend label declaration for a given label structure,
274 or create it if it doesn't exist yet. */
275
276 tree
277 gfc_get_label_decl (gfc_st_label * lp)
278 {
279 if (lp->backend_decl)
280 return lp->backend_decl;
281 else
282 {
283 char label_name[GFC_MAX_SYMBOL_LEN + 1];
284 tree label_decl;
285
286 /* Validate the label declaration from the front end. */
287 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
288
289 /* Build a mangled name for the label. */
290 sprintf (label_name, "__label_%.6d", lp->value);
291
292 /* Build the LABEL_DECL node. */
293 label_decl = gfc_build_label_decl (get_identifier (label_name));
294
295 /* Tell the debugger where the label came from. */
296 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
297 gfc_set_decl_location (label_decl, &lp->where);
298 else
299 DECL_ARTIFICIAL (label_decl) = 1;
300
301 /* Store the label in the label list and return the LABEL_DECL. */
302 lp->backend_decl = label_decl;
303 return label_decl;
304 }
305 }
306
307
308 /* Convert a gfc_symbol to an identifier of the same name. */
309
310 static tree
311 gfc_sym_identifier (gfc_symbol * sym)
312 {
313 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
314 return (get_identifier ("MAIN__"));
315 else
316 return (get_identifier (sym->name));
317 }
318
319
320 /* Construct mangled name from symbol name. */
321
322 static tree
323 gfc_sym_mangled_identifier (gfc_symbol * sym)
324 {
325 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
326
327 /* Prevent the mangling of identifiers that have an assigned
328 binding label (mainly those that are bind(c)). */
329 if (sym->attr.is_bind_c == 1 && sym->binding_label)
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)
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 {
1488 TREE_READONLY (decl) = 1;
1489 GFC_DECL_PUSH_TOPLEVEL (decl) = 1;
1490 }
1491
1492 return decl;
1493 }
1494
1495
1496 /* Substitute a temporary variable in place of the real one. */
1497
1498 void
1499 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1500 {
1501 save->attr = sym->attr;
1502 save->decl = sym->backend_decl;
1503
1504 gfc_clear_attr (&sym->attr);
1505 sym->attr.referenced = 1;
1506 sym->attr.flavor = FL_VARIABLE;
1507
1508 sym->backend_decl = decl;
1509 }
1510
1511
1512 /* Restore the original variable. */
1513
1514 void
1515 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1516 {
1517 sym->attr = save->attr;
1518 sym->backend_decl = save->decl;
1519 }
1520
1521
1522 /* Declare a procedure pointer. */
1523
1524 static tree
1525 get_proc_pointer_decl (gfc_symbol *sym)
1526 {
1527 tree decl;
1528 tree attributes;
1529
1530 decl = sym->backend_decl;
1531 if (decl)
1532 return decl;
1533
1534 decl = build_decl (input_location,
1535 VAR_DECL, get_identifier (sym->name),
1536 build_pointer_type (gfc_get_function_type (sym)));
1537
1538 if ((sym->ns->proc_name
1539 && sym->ns->proc_name->backend_decl == current_function_decl)
1540 || sym->attr.contained)
1541 gfc_add_decl_to_function (decl);
1542 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1543 gfc_add_decl_to_parent_function (decl);
1544
1545 sym->backend_decl = decl;
1546
1547 /* If a variable is USE associated, it's always external. */
1548 if (sym->attr.use_assoc)
1549 {
1550 DECL_EXTERNAL (decl) = 1;
1551 TREE_PUBLIC (decl) = 1;
1552 }
1553 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1554 {
1555 /* This is the declaration of a module variable. */
1556 TREE_PUBLIC (decl) = 1;
1557 TREE_STATIC (decl) = 1;
1558 }
1559
1560 if (!sym->attr.use_assoc
1561 && (sym->attr.save != SAVE_NONE || sym->attr.data
1562 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1563 TREE_STATIC (decl) = 1;
1564
1565 if (TREE_STATIC (decl) && sym->value)
1566 {
1567 /* Add static initializer. */
1568 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1569 TREE_TYPE (decl),
1570 sym->attr.dimension,
1571 false, true);
1572 }
1573
1574 /* Handle threadprivate procedure pointers. */
1575 if (sym->attr.threadprivate
1576 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
1577 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
1578
1579 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1580 decl_attributes (&decl, attributes, 0);
1581
1582 return decl;
1583 }
1584
1585
1586 /* Get a basic decl for an external function. */
1587
1588 tree
1589 gfc_get_extern_function_decl (gfc_symbol * sym)
1590 {
1591 tree type;
1592 tree fndecl;
1593 tree attributes;
1594 gfc_expr e;
1595 gfc_intrinsic_sym *isym;
1596 gfc_expr argexpr;
1597 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1598 tree name;
1599 tree mangled_name;
1600 gfc_gsymbol *gsym;
1601
1602 if (sym->backend_decl)
1603 return sym->backend_decl;
1604
1605 /* We should never be creating external decls for alternate entry points.
1606 The procedure may be an alternate entry point, but we don't want/need
1607 to know that. */
1608 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1609
1610 if (sym->attr.proc_pointer)
1611 return get_proc_pointer_decl (sym);
1612
1613 /* See if this is an external procedure from the same file. If so,
1614 return the backend_decl. */
1615 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1616
1617 if (gfc_option.flag_whole_file
1618 && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1619 && !sym->backend_decl
1620 && gsym && gsym->ns
1621 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1622 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1623 {
1624 if (!gsym->ns->proc_name->backend_decl)
1625 {
1626 /* By construction, the external function cannot be
1627 a contained procedure. */
1628 locus old_loc;
1629 tree save_fn_decl = current_function_decl;
1630
1631 current_function_decl = NULL_TREE;
1632 gfc_save_backend_locus (&old_loc);
1633 push_cfun (cfun);
1634
1635 gfc_create_function_decl (gsym->ns, true);
1636
1637 pop_cfun ();
1638 gfc_restore_backend_locus (&old_loc);
1639 current_function_decl = save_fn_decl;
1640 }
1641
1642 /* If the namespace has entries, the proc_name is the
1643 entry master. Find the entry and use its backend_decl.
1644 otherwise, use the proc_name backend_decl. */
1645 if (gsym->ns->entries)
1646 {
1647 gfc_entry_list *entry = gsym->ns->entries;
1648
1649 for (; entry; entry = entry->next)
1650 {
1651 if (strcmp (gsym->name, entry->sym->name) == 0)
1652 {
1653 sym->backend_decl = entry->sym->backend_decl;
1654 break;
1655 }
1656 }
1657 }
1658 else
1659 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1660
1661 if (sym->backend_decl)
1662 {
1663 /* Avoid problems of double deallocation of the backend declaration
1664 later in gfc_trans_use_stmts; cf. PR 45087. */
1665 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1666 sym->attr.use_assoc = 0;
1667
1668 return sym->backend_decl;
1669 }
1670 }
1671
1672 /* See if this is a module procedure from the same file. If so,
1673 return the backend_decl. */
1674 if (sym->module)
1675 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1676
1677 if (gfc_option.flag_whole_file
1678 && gsym && gsym->ns
1679 && gsym->type == GSYM_MODULE)
1680 {
1681 gfc_symbol *s;
1682
1683 s = NULL;
1684 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1685 if (s && s->backend_decl)
1686 {
1687 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1688 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
1689 true);
1690 else if (sym->ts.type == BT_CHARACTER)
1691 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1692 sym->backend_decl = s->backend_decl;
1693 return sym->backend_decl;
1694 }
1695 }
1696
1697 if (sym->attr.intrinsic)
1698 {
1699 /* Call the resolution function to get the actual name. This is
1700 a nasty hack which relies on the resolution functions only looking
1701 at the first argument. We pass NULL for the second argument
1702 otherwise things like AINT get confused. */
1703 isym = gfc_find_function (sym->name);
1704 gcc_assert (isym->resolve.f0 != NULL);
1705
1706 memset (&e, 0, sizeof (e));
1707 e.expr_type = EXPR_FUNCTION;
1708
1709 memset (&argexpr, 0, sizeof (argexpr));
1710 gcc_assert (isym->formal);
1711 argexpr.ts = isym->formal->ts;
1712
1713 if (isym->formal->next == NULL)
1714 isym->resolve.f1 (&e, &argexpr);
1715 else
1716 {
1717 if (isym->formal->next->next == NULL)
1718 isym->resolve.f2 (&e, &argexpr, NULL);
1719 else
1720 {
1721 if (isym->formal->next->next->next == NULL)
1722 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1723 else
1724 {
1725 /* All specific intrinsics take less than 5 arguments. */
1726 gcc_assert (isym->formal->next->next->next->next == NULL);
1727 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1728 }
1729 }
1730 }
1731
1732 if (gfc_option.flag_f2c
1733 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1734 || e.ts.type == BT_COMPLEX))
1735 {
1736 /* Specific which needs a different implementation if f2c
1737 calling conventions are used. */
1738 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1739 }
1740 else
1741 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1742
1743 name = get_identifier (s);
1744 mangled_name = name;
1745 }
1746 else
1747 {
1748 name = gfc_sym_identifier (sym);
1749 mangled_name = gfc_sym_mangled_function_id (sym);
1750 }
1751
1752 type = gfc_get_function_type (sym);
1753 fndecl = build_decl (input_location,
1754 FUNCTION_DECL, name, type);
1755
1756 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1757 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1758 the opposite of declaring a function as static in C). */
1759 DECL_EXTERNAL (fndecl) = 1;
1760 TREE_PUBLIC (fndecl) = 1;
1761
1762 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1763 decl_attributes (&fndecl, attributes, 0);
1764
1765 gfc_set_decl_assembler_name (fndecl, mangled_name);
1766
1767 /* Set the context of this decl. */
1768 if (0 && sym->ns && sym->ns->proc_name)
1769 {
1770 /* TODO: Add external decls to the appropriate scope. */
1771 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1772 }
1773 else
1774 {
1775 /* Global declaration, e.g. intrinsic subroutine. */
1776 DECL_CONTEXT (fndecl) = NULL_TREE;
1777 }
1778
1779 /* Set attributes for PURE functions. A call to PURE function in the
1780 Fortran 95 sense is both pure and without side effects in the C
1781 sense. */
1782 if (sym->attr.pure || sym->attr.elemental)
1783 {
1784 if (sym->attr.function && !gfc_return_by_reference (sym))
1785 DECL_PURE_P (fndecl) = 1;
1786 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1787 parameters and don't use alternate returns (is this
1788 allowed?). In that case, calls to them are meaningless, and
1789 can be optimized away. See also in build_function_decl(). */
1790 TREE_SIDE_EFFECTS (fndecl) = 0;
1791 }
1792
1793 /* Mark non-returning functions. */
1794 if (sym->attr.noreturn)
1795 TREE_THIS_VOLATILE(fndecl) = 1;
1796
1797 sym->backend_decl = fndecl;
1798
1799 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1800 pushdecl_top_level (fndecl);
1801
1802 return fndecl;
1803 }
1804
1805
1806 /* Create a declaration for a procedure. For external functions (in the C
1807 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1808 a master function with alternate entry points. */
1809
1810 static void
1811 build_function_decl (gfc_symbol * sym, bool global)
1812 {
1813 tree fndecl, type, attributes;
1814 symbol_attribute attr;
1815 tree result_decl;
1816 gfc_formal_arglist *f;
1817
1818 gcc_assert (!sym->attr.external);
1819
1820 if (sym->backend_decl)
1821 return;
1822
1823 /* Set the line and filename. sym->declared_at seems to point to the
1824 last statement for subroutines, but it'll do for now. */
1825 gfc_set_backend_locus (&sym->declared_at);
1826
1827 /* Allow only one nesting level. Allow public declarations. */
1828 gcc_assert (current_function_decl == NULL_TREE
1829 || DECL_FILE_SCOPE_P (current_function_decl)
1830 || (TREE_CODE (DECL_CONTEXT (current_function_decl))
1831 == NAMESPACE_DECL));
1832
1833 type = gfc_get_function_type (sym);
1834 fndecl = build_decl (input_location,
1835 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1836
1837 attr = sym->attr;
1838
1839 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1840 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1841 the opposite of declaring a function as static in C). */
1842 DECL_EXTERNAL (fndecl) = 0;
1843
1844 if (!current_function_decl
1845 && !sym->attr.entry_master && !sym->attr.is_main_program)
1846 TREE_PUBLIC (fndecl) = 1;
1847
1848 attributes = add_attributes_to_decl (attr, NULL_TREE);
1849 decl_attributes (&fndecl, attributes, 0);
1850
1851 /* Figure out the return type of the declared function, and build a
1852 RESULT_DECL for it. If this is a subroutine with alternate
1853 returns, build a RESULT_DECL for it. */
1854 result_decl = NULL_TREE;
1855 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1856 if (attr.function)
1857 {
1858 if (gfc_return_by_reference (sym))
1859 type = void_type_node;
1860 else
1861 {
1862 if (sym->result != sym)
1863 result_decl = gfc_sym_identifier (sym->result);
1864
1865 type = TREE_TYPE (TREE_TYPE (fndecl));
1866 }
1867 }
1868 else
1869 {
1870 /* Look for alternate return placeholders. */
1871 int has_alternate_returns = 0;
1872 for (f = sym->formal; f; f = f->next)
1873 {
1874 if (f->sym == NULL)
1875 {
1876 has_alternate_returns = 1;
1877 break;
1878 }
1879 }
1880
1881 if (has_alternate_returns)
1882 type = integer_type_node;
1883 else
1884 type = void_type_node;
1885 }
1886
1887 result_decl = build_decl (input_location,
1888 RESULT_DECL, result_decl, type);
1889 DECL_ARTIFICIAL (result_decl) = 1;
1890 DECL_IGNORED_P (result_decl) = 1;
1891 DECL_CONTEXT (result_decl) = fndecl;
1892 DECL_RESULT (fndecl) = result_decl;
1893
1894 /* Don't call layout_decl for a RESULT_DECL.
1895 layout_decl (result_decl, 0); */
1896
1897 /* TREE_STATIC means the function body is defined here. */
1898 TREE_STATIC (fndecl) = 1;
1899
1900 /* Set attributes for PURE functions. A call to a PURE function in the
1901 Fortran 95 sense is both pure and without side effects in the C
1902 sense. */
1903 if (attr.pure || attr.elemental)
1904 {
1905 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1906 including an alternate return. In that case it can also be
1907 marked as PURE. See also in gfc_get_extern_function_decl(). */
1908 if (attr.function && !gfc_return_by_reference (sym))
1909 DECL_PURE_P (fndecl) = 1;
1910 TREE_SIDE_EFFECTS (fndecl) = 0;
1911 }
1912
1913
1914 /* Layout the function declaration and put it in the binding level
1915 of the current function. */
1916
1917 if (global
1918 || (sym->name[0] == '_' && strncmp ("__copy", sym->name, 6) == 0))
1919 pushdecl_top_level (fndecl);
1920 else
1921 pushdecl (fndecl);
1922
1923 /* Perform name mangling if this is a top level or module procedure. */
1924 if (current_function_decl == NULL_TREE)
1925 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1926
1927 sym->backend_decl = fndecl;
1928 }
1929
1930
1931 /* Create the DECL_ARGUMENTS for a procedure. */
1932
1933 static void
1934 create_function_arglist (gfc_symbol * sym)
1935 {
1936 tree fndecl;
1937 gfc_formal_arglist *f;
1938 tree typelist, hidden_typelist;
1939 tree arglist, hidden_arglist;
1940 tree type;
1941 tree parm;
1942
1943 fndecl = sym->backend_decl;
1944
1945 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1946 the new FUNCTION_DECL node. */
1947 arglist = NULL_TREE;
1948 hidden_arglist = NULL_TREE;
1949 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1950
1951 if (sym->attr.entry_master)
1952 {
1953 type = TREE_VALUE (typelist);
1954 parm = build_decl (input_location,
1955 PARM_DECL, get_identifier ("__entry"), type);
1956
1957 DECL_CONTEXT (parm) = fndecl;
1958 DECL_ARG_TYPE (parm) = type;
1959 TREE_READONLY (parm) = 1;
1960 gfc_finish_decl (parm);
1961 DECL_ARTIFICIAL (parm) = 1;
1962
1963 arglist = chainon (arglist, parm);
1964 typelist = TREE_CHAIN (typelist);
1965 }
1966
1967 if (gfc_return_by_reference (sym))
1968 {
1969 tree type = TREE_VALUE (typelist), length = NULL;
1970
1971 if (sym->ts.type == BT_CHARACTER)
1972 {
1973 /* Length of character result. */
1974 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1975
1976 length = build_decl (input_location,
1977 PARM_DECL,
1978 get_identifier (".__result"),
1979 len_type);
1980 if (!sym->ts.u.cl->length)
1981 {
1982 sym->ts.u.cl->backend_decl = length;
1983 TREE_USED (length) = 1;
1984 }
1985 gcc_assert (TREE_CODE (length) == PARM_DECL);
1986 DECL_CONTEXT (length) = fndecl;
1987 DECL_ARG_TYPE (length) = len_type;
1988 TREE_READONLY (length) = 1;
1989 DECL_ARTIFICIAL (length) = 1;
1990 gfc_finish_decl (length);
1991 if (sym->ts.u.cl->backend_decl == NULL
1992 || sym->ts.u.cl->backend_decl == length)
1993 {
1994 gfc_symbol *arg;
1995 tree backend_decl;
1996
1997 if (sym->ts.u.cl->backend_decl == NULL)
1998 {
1999 tree len = build_decl (input_location,
2000 VAR_DECL,
2001 get_identifier ("..__result"),
2002 gfc_charlen_type_node);
2003 DECL_ARTIFICIAL (len) = 1;
2004 TREE_USED (len) = 1;
2005 sym->ts.u.cl->backend_decl = len;
2006 }
2007
2008 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2009 arg = sym->result ? sym->result : sym;
2010 backend_decl = arg->backend_decl;
2011 /* Temporary clear it, so that gfc_sym_type creates complete
2012 type. */
2013 arg->backend_decl = NULL;
2014 type = gfc_sym_type (arg);
2015 arg->backend_decl = backend_decl;
2016 type = build_reference_type (type);
2017 }
2018 }
2019
2020 parm = build_decl (input_location,
2021 PARM_DECL, get_identifier ("__result"), type);
2022
2023 DECL_CONTEXT (parm) = fndecl;
2024 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2025 TREE_READONLY (parm) = 1;
2026 DECL_ARTIFICIAL (parm) = 1;
2027 gfc_finish_decl (parm);
2028
2029 arglist = chainon (arglist, parm);
2030 typelist = TREE_CHAIN (typelist);
2031
2032 if (sym->ts.type == BT_CHARACTER)
2033 {
2034 gfc_allocate_lang_decl (parm);
2035 arglist = chainon (arglist, length);
2036 typelist = TREE_CHAIN (typelist);
2037 }
2038 }
2039
2040 hidden_typelist = typelist;
2041 for (f = sym->formal; f; f = f->next)
2042 if (f->sym != NULL) /* Ignore alternate returns. */
2043 hidden_typelist = TREE_CHAIN (hidden_typelist);
2044
2045 for (f = sym->formal; f; f = f->next)
2046 {
2047 char name[GFC_MAX_SYMBOL_LEN + 2];
2048
2049 /* Ignore alternate returns. */
2050 if (f->sym == NULL)
2051 continue;
2052
2053 type = TREE_VALUE (typelist);
2054
2055 if (f->sym->ts.type == BT_CHARACTER
2056 && (!sym->attr.is_bind_c || sym->attr.entry_master))
2057 {
2058 tree len_type = TREE_VALUE (hidden_typelist);
2059 tree length = NULL_TREE;
2060 if (!f->sym->ts.deferred)
2061 gcc_assert (len_type == gfc_charlen_type_node);
2062 else
2063 gcc_assert (POINTER_TYPE_P (len_type));
2064
2065 strcpy (&name[1], f->sym->name);
2066 name[0] = '_';
2067 length = build_decl (input_location,
2068 PARM_DECL, get_identifier (name), len_type);
2069
2070 hidden_arglist = chainon (hidden_arglist, length);
2071 DECL_CONTEXT (length) = fndecl;
2072 DECL_ARTIFICIAL (length) = 1;
2073 DECL_ARG_TYPE (length) = len_type;
2074 TREE_READONLY (length) = 1;
2075 gfc_finish_decl (length);
2076
2077 /* Remember the passed value. */
2078 if (f->sym->ts.u.cl->passed_length != NULL)
2079 {
2080 /* This can happen if the same type is used for multiple
2081 arguments. We need to copy cl as otherwise
2082 cl->passed_length gets overwritten. */
2083 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2084 }
2085 f->sym->ts.u.cl->passed_length = length;
2086
2087 /* Use the passed value for assumed length variables. */
2088 if (!f->sym->ts.u.cl->length)
2089 {
2090 TREE_USED (length) = 1;
2091 gcc_assert (!f->sym->ts.u.cl->backend_decl);
2092 f->sym->ts.u.cl->backend_decl = length;
2093 }
2094
2095 hidden_typelist = TREE_CHAIN (hidden_typelist);
2096
2097 if (f->sym->ts.u.cl->backend_decl == NULL
2098 || f->sym->ts.u.cl->backend_decl == length)
2099 {
2100 if (f->sym->ts.u.cl->backend_decl == NULL)
2101 gfc_create_string_length (f->sym);
2102
2103 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2104 if (f->sym->attr.flavor == FL_PROCEDURE)
2105 type = build_pointer_type (gfc_get_function_type (f->sym));
2106 else
2107 type = gfc_sym_type (f->sym);
2108 }
2109 }
2110
2111 /* For non-constant length array arguments, make sure they use
2112 a different type node from TYPE_ARG_TYPES type. */
2113 if (f->sym->attr.dimension
2114 && type == TREE_VALUE (typelist)
2115 && TREE_CODE (type) == POINTER_TYPE
2116 && GFC_ARRAY_TYPE_P (type)
2117 && f->sym->as->type != AS_ASSUMED_SIZE
2118 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2119 {
2120 if (f->sym->attr.flavor == FL_PROCEDURE)
2121 type = build_pointer_type (gfc_get_function_type (f->sym));
2122 else
2123 type = gfc_sym_type (f->sym);
2124 }
2125
2126 if (f->sym->attr.proc_pointer)
2127 type = build_pointer_type (type);
2128
2129 if (f->sym->attr.volatile_)
2130 type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2131
2132 /* Build the argument declaration. */
2133 parm = build_decl (input_location,
2134 PARM_DECL, gfc_sym_identifier (f->sym), type);
2135
2136 if (f->sym->attr.volatile_)
2137 {
2138 TREE_THIS_VOLATILE (parm) = 1;
2139 TREE_SIDE_EFFECTS (parm) = 1;
2140 }
2141
2142 /* Fill in arg stuff. */
2143 DECL_CONTEXT (parm) = fndecl;
2144 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2145 /* All implementation args are read-only. */
2146 TREE_READONLY (parm) = 1;
2147 if (POINTER_TYPE_P (type)
2148 && (!f->sym->attr.proc_pointer
2149 && f->sym->attr.flavor != FL_PROCEDURE))
2150 DECL_BY_REFERENCE (parm) = 1;
2151
2152 gfc_finish_decl (parm);
2153
2154 f->sym->backend_decl = parm;
2155
2156 /* Coarrays which are descriptorless or assumed-shape pass with
2157 -fcoarray=lib the token and the offset as hidden arguments. */
2158 if (f->sym->attr.codimension
2159 && gfc_option.coarray == GFC_FCOARRAY_LIB
2160 && !f->sym->attr.allocatable)
2161 {
2162 tree caf_type;
2163 tree token;
2164 tree offset;
2165
2166 gcc_assert (f->sym->backend_decl != NULL_TREE
2167 && !sym->attr.is_bind_c);
2168 caf_type = TREE_TYPE (f->sym->backend_decl);
2169
2170 token = build_decl (input_location, PARM_DECL,
2171 create_tmp_var_name ("caf_token"),
2172 build_qualified_type (pvoid_type_node,
2173 TYPE_QUAL_RESTRICT));
2174 if (f->sym->as->type == AS_ASSUMED_SHAPE)
2175 {
2176 gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
2177 || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
2178 if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
2179 gfc_allocate_lang_decl (f->sym->backend_decl);
2180 GFC_DECL_TOKEN (f->sym->backend_decl) = token;
2181 }
2182 else
2183 {
2184 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
2185 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
2186 }
2187
2188 DECL_CONTEXT (token) = fndecl;
2189 DECL_ARTIFICIAL (token) = 1;
2190 DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
2191 TREE_READONLY (token) = 1;
2192 hidden_arglist = chainon (hidden_arglist, token);
2193 gfc_finish_decl (token);
2194
2195 offset = build_decl (input_location, PARM_DECL,
2196 create_tmp_var_name ("caf_offset"),
2197 gfc_array_index_type);
2198
2199 if (f->sym->as->type == AS_ASSUMED_SHAPE)
2200 {
2201 gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
2202 == NULL_TREE);
2203 GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
2204 }
2205 else
2206 {
2207 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
2208 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
2209 }
2210 DECL_CONTEXT (offset) = fndecl;
2211 DECL_ARTIFICIAL (offset) = 1;
2212 DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
2213 TREE_READONLY (offset) = 1;
2214 hidden_arglist = chainon (hidden_arglist, offset);
2215 gfc_finish_decl (offset);
2216 }
2217
2218 arglist = chainon (arglist, parm);
2219 typelist = TREE_CHAIN (typelist);
2220 }
2221
2222 /* Add the hidden string length parameters, unless the procedure
2223 is bind(C). */
2224 if (!sym->attr.is_bind_c)
2225 arglist = chainon (arglist, hidden_arglist);
2226
2227 gcc_assert (hidden_typelist == NULL_TREE
2228 || TREE_VALUE (hidden_typelist) == void_type_node);
2229 DECL_ARGUMENTS (fndecl) = arglist;
2230 }
2231
2232 /* Do the setup necessary before generating the body of a function. */
2233
2234 static void
2235 trans_function_start (gfc_symbol * sym)
2236 {
2237 tree fndecl;
2238
2239 fndecl = sym->backend_decl;
2240
2241 /* Let GCC know the current scope is this function. */
2242 current_function_decl = fndecl;
2243
2244 /* Let the world know what we're about to do. */
2245 announce_function (fndecl);
2246
2247 if (DECL_FILE_SCOPE_P (fndecl))
2248 {
2249 /* Create RTL for function declaration. */
2250 rest_of_decl_compilation (fndecl, 1, 0);
2251 }
2252
2253 /* Create RTL for function definition. */
2254 make_decl_rtl (fndecl);
2255
2256 init_function_start (fndecl);
2257
2258 /* function.c requires a push at the start of the function. */
2259 pushlevel (0);
2260 }
2261
2262 /* Create thunks for alternate entry points. */
2263
2264 static void
2265 build_entry_thunks (gfc_namespace * ns, bool global)
2266 {
2267 gfc_formal_arglist *formal;
2268 gfc_formal_arglist *thunk_formal;
2269 gfc_entry_list *el;
2270 gfc_symbol *thunk_sym;
2271 stmtblock_t body;
2272 tree thunk_fndecl;
2273 tree tmp;
2274 locus old_loc;
2275
2276 /* This should always be a toplevel function. */
2277 gcc_assert (current_function_decl == NULL_TREE);
2278
2279 gfc_save_backend_locus (&old_loc);
2280 for (el = ns->entries; el; el = el->next)
2281 {
2282 VEC(tree,gc) *args = NULL;
2283 VEC(tree,gc) *string_args = NULL;
2284
2285 thunk_sym = el->sym;
2286
2287 build_function_decl (thunk_sym, global);
2288 create_function_arglist (thunk_sym);
2289
2290 trans_function_start (thunk_sym);
2291
2292 thunk_fndecl = thunk_sym->backend_decl;
2293
2294 gfc_init_block (&body);
2295
2296 /* Pass extra parameter identifying this entry point. */
2297 tmp = build_int_cst (gfc_array_index_type, el->id);
2298 VEC_safe_push (tree, gc, args, tmp);
2299
2300 if (thunk_sym->attr.function)
2301 {
2302 if (gfc_return_by_reference (ns->proc_name))
2303 {
2304 tree ref = DECL_ARGUMENTS (current_function_decl);
2305 VEC_safe_push (tree, gc, args, ref);
2306 if (ns->proc_name->ts.type == BT_CHARACTER)
2307 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
2308 }
2309 }
2310
2311 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2312 {
2313 /* Ignore alternate returns. */
2314 if (formal->sym == NULL)
2315 continue;
2316
2317 /* We don't have a clever way of identifying arguments, so resort to
2318 a brute-force search. */
2319 for (thunk_formal = thunk_sym->formal;
2320 thunk_formal;
2321 thunk_formal = thunk_formal->next)
2322 {
2323 if (thunk_formal->sym == formal->sym)
2324 break;
2325 }
2326
2327 if (thunk_formal)
2328 {
2329 /* Pass the argument. */
2330 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2331 VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
2332 if (formal->sym->ts.type == BT_CHARACTER)
2333 {
2334 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2335 VEC_safe_push (tree, gc, string_args, tmp);
2336 }
2337 }
2338 else
2339 {
2340 /* Pass NULL for a missing argument. */
2341 VEC_safe_push (tree, gc, args, null_pointer_node);
2342 if (formal->sym->ts.type == BT_CHARACTER)
2343 {
2344 tmp = build_int_cst (gfc_charlen_type_node, 0);
2345 VEC_safe_push (tree, gc, string_args, tmp);
2346 }
2347 }
2348 }
2349
2350 /* Call the master function. */
2351 VEC_safe_splice (tree, gc, args, string_args);
2352 tmp = ns->proc_name->backend_decl;
2353 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2354 if (ns->proc_name->attr.mixed_entry_master)
2355 {
2356 tree union_decl, field;
2357 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2358
2359 union_decl = build_decl (input_location,
2360 VAR_DECL, get_identifier ("__result"),
2361 TREE_TYPE (master_type));
2362 DECL_ARTIFICIAL (union_decl) = 1;
2363 DECL_EXTERNAL (union_decl) = 0;
2364 TREE_PUBLIC (union_decl) = 0;
2365 TREE_USED (union_decl) = 1;
2366 layout_decl (union_decl, 0);
2367 pushdecl (union_decl);
2368
2369 DECL_CONTEXT (union_decl) = current_function_decl;
2370 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2371 TREE_TYPE (union_decl), union_decl, tmp);
2372 gfc_add_expr_to_block (&body, tmp);
2373
2374 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2375 field; field = DECL_CHAIN (field))
2376 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2377 thunk_sym->result->name) == 0)
2378 break;
2379 gcc_assert (field != NULL_TREE);
2380 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2381 TREE_TYPE (field), union_decl, field,
2382 NULL_TREE);
2383 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2384 TREE_TYPE (DECL_RESULT (current_function_decl)),
2385 DECL_RESULT (current_function_decl), tmp);
2386 tmp = build1_v (RETURN_EXPR, tmp);
2387 }
2388 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2389 != void_type_node)
2390 {
2391 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2392 TREE_TYPE (DECL_RESULT (current_function_decl)),
2393 DECL_RESULT (current_function_decl), tmp);
2394 tmp = build1_v (RETURN_EXPR, tmp);
2395 }
2396 gfc_add_expr_to_block (&body, tmp);
2397
2398 /* Finish off this function and send it for code generation. */
2399 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2400 tmp = getdecls ();
2401 poplevel (1, 0, 1);
2402 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2403 DECL_SAVED_TREE (thunk_fndecl)
2404 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2405 DECL_INITIAL (thunk_fndecl));
2406
2407 /* Output the GENERIC tree. */
2408 dump_function (TDI_original, thunk_fndecl);
2409
2410 /* Store the end of the function, so that we get good line number
2411 info for the epilogue. */
2412 cfun->function_end_locus = input_location;
2413
2414 /* We're leaving the context of this function, so zap cfun.
2415 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2416 tree_rest_of_compilation. */
2417 set_cfun (NULL);
2418
2419 current_function_decl = NULL_TREE;
2420
2421 cgraph_finalize_function (thunk_fndecl, true);
2422
2423 /* We share the symbols in the formal argument list with other entry
2424 points and the master function. Clear them so that they are
2425 recreated for each function. */
2426 for (formal = thunk_sym->formal; formal; formal = formal->next)
2427 if (formal->sym != NULL) /* Ignore alternate returns. */
2428 {
2429 formal->sym->backend_decl = NULL_TREE;
2430 if (formal->sym->ts.type == BT_CHARACTER)
2431 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2432 }
2433
2434 if (thunk_sym->attr.function)
2435 {
2436 if (thunk_sym->ts.type == BT_CHARACTER)
2437 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2438 if (thunk_sym->result->ts.type == BT_CHARACTER)
2439 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2440 }
2441 }
2442
2443 gfc_restore_backend_locus (&old_loc);
2444 }
2445
2446
2447 /* Create a decl for a function, and create any thunks for alternate entry
2448 points. If global is true, generate the function in the global binding
2449 level, otherwise in the current binding level (which can be global). */
2450
2451 void
2452 gfc_create_function_decl (gfc_namespace * ns, bool global)
2453 {
2454 /* Create a declaration for the master function. */
2455 build_function_decl (ns->proc_name, global);
2456
2457 /* Compile the entry thunks. */
2458 if (ns->entries)
2459 build_entry_thunks (ns, global);
2460
2461 /* Now create the read argument list. */
2462 create_function_arglist (ns->proc_name);
2463 }
2464
2465 /* Return the decl used to hold the function return value. If
2466 parent_flag is set, the context is the parent_scope. */
2467
2468 tree
2469 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2470 {
2471 tree decl;
2472 tree length;
2473 tree this_fake_result_decl;
2474 tree this_function_decl;
2475
2476 char name[GFC_MAX_SYMBOL_LEN + 10];
2477
2478 if (parent_flag)
2479 {
2480 this_fake_result_decl = parent_fake_result_decl;
2481 this_function_decl = DECL_CONTEXT (current_function_decl);
2482 }
2483 else
2484 {
2485 this_fake_result_decl = current_fake_result_decl;
2486 this_function_decl = current_function_decl;
2487 }
2488
2489 if (sym
2490 && sym->ns->proc_name->backend_decl == this_function_decl
2491 && sym->ns->proc_name->attr.entry_master
2492 && sym != sym->ns->proc_name)
2493 {
2494 tree t = NULL, var;
2495 if (this_fake_result_decl != NULL)
2496 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2497 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2498 break;
2499 if (t)
2500 return TREE_VALUE (t);
2501 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2502
2503 if (parent_flag)
2504 this_fake_result_decl = parent_fake_result_decl;
2505 else
2506 this_fake_result_decl = current_fake_result_decl;
2507
2508 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2509 {
2510 tree field;
2511
2512 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2513 field; field = DECL_CHAIN (field))
2514 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2515 sym->name) == 0)
2516 break;
2517
2518 gcc_assert (field != NULL_TREE);
2519 decl = fold_build3_loc (input_location, COMPONENT_REF,
2520 TREE_TYPE (field), decl, field, NULL_TREE);
2521 }
2522
2523 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2524 if (parent_flag)
2525 gfc_add_decl_to_parent_function (var);
2526 else
2527 gfc_add_decl_to_function (var);
2528
2529 SET_DECL_VALUE_EXPR (var, decl);
2530 DECL_HAS_VALUE_EXPR_P (var) = 1;
2531 GFC_DECL_RESULT (var) = 1;
2532
2533 TREE_CHAIN (this_fake_result_decl)
2534 = tree_cons (get_identifier (sym->name), var,
2535 TREE_CHAIN (this_fake_result_decl));
2536 return var;
2537 }
2538
2539 if (this_fake_result_decl != NULL_TREE)
2540 return TREE_VALUE (this_fake_result_decl);
2541
2542 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2543 sym is NULL. */
2544 if (!sym)
2545 return NULL_TREE;
2546
2547 if (sym->ts.type == BT_CHARACTER)
2548 {
2549 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2550 length = gfc_create_string_length (sym);
2551 else
2552 length = sym->ts.u.cl->backend_decl;
2553 if (TREE_CODE (length) == VAR_DECL
2554 && DECL_CONTEXT (length) == NULL_TREE)
2555 gfc_add_decl_to_function (length);
2556 }
2557
2558 if (gfc_return_by_reference (sym))
2559 {
2560 decl = DECL_ARGUMENTS (this_function_decl);
2561
2562 if (sym->ns->proc_name->backend_decl == this_function_decl
2563 && sym->ns->proc_name->attr.entry_master)
2564 decl = DECL_CHAIN (decl);
2565
2566 TREE_USED (decl) = 1;
2567 if (sym->as)
2568 decl = gfc_build_dummy_array_decl (sym, decl);
2569 }
2570 else
2571 {
2572 sprintf (name, "__result_%.20s",
2573 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2574
2575 if (!sym->attr.mixed_entry_master && sym->attr.function)
2576 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2577 VAR_DECL, get_identifier (name),
2578 gfc_sym_type (sym));
2579 else
2580 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2581 VAR_DECL, get_identifier (name),
2582 TREE_TYPE (TREE_TYPE (this_function_decl)));
2583 DECL_ARTIFICIAL (decl) = 1;
2584 DECL_EXTERNAL (decl) = 0;
2585 TREE_PUBLIC (decl) = 0;
2586 TREE_USED (decl) = 1;
2587 GFC_DECL_RESULT (decl) = 1;
2588 TREE_ADDRESSABLE (decl) = 1;
2589
2590 layout_decl (decl, 0);
2591
2592 if (parent_flag)
2593 gfc_add_decl_to_parent_function (decl);
2594 else
2595 gfc_add_decl_to_function (decl);
2596 }
2597
2598 if (parent_flag)
2599 parent_fake_result_decl = build_tree_list (NULL, decl);
2600 else
2601 current_fake_result_decl = build_tree_list (NULL, decl);
2602
2603 return decl;
2604 }
2605
2606
2607 /* Builds a function decl. The remaining parameters are the types of the
2608 function arguments. Negative nargs indicates a varargs function. */
2609
2610 static tree
2611 build_library_function_decl_1 (tree name, const char *spec,
2612 tree rettype, int nargs, va_list p)
2613 {
2614 VEC(tree,gc) *arglist;
2615 tree fntype;
2616 tree fndecl;
2617 int n;
2618
2619 /* Library functions must be declared with global scope. */
2620 gcc_assert (current_function_decl == NULL_TREE);
2621
2622 /* Create a list of the argument types. */
2623 arglist = VEC_alloc (tree, gc, abs (nargs));
2624 for (n = abs (nargs); n > 0; n--)
2625 {
2626 tree argtype = va_arg (p, tree);
2627 VEC_quick_push (tree, arglist, argtype);
2628 }
2629
2630 /* Build the function type and decl. */
2631 if (nargs >= 0)
2632 fntype = build_function_type_vec (rettype, arglist);
2633 else
2634 fntype = build_varargs_function_type_vec (rettype, arglist);
2635 if (spec)
2636 {
2637 tree attr_args = build_tree_list (NULL_TREE,
2638 build_string (strlen (spec), spec));
2639 tree attrs = tree_cons (get_identifier ("fn spec"),
2640 attr_args, TYPE_ATTRIBUTES (fntype));
2641 fntype = build_type_attribute_variant (fntype, attrs);
2642 }
2643 fndecl = build_decl (input_location,
2644 FUNCTION_DECL, name, fntype);
2645
2646 /* Mark this decl as external. */
2647 DECL_EXTERNAL (fndecl) = 1;
2648 TREE_PUBLIC (fndecl) = 1;
2649
2650 pushdecl (fndecl);
2651
2652 rest_of_decl_compilation (fndecl, 1, 0);
2653
2654 return fndecl;
2655 }
2656
2657 /* Builds a function decl. The remaining parameters are the types of the
2658 function arguments. Negative nargs indicates a varargs function. */
2659
2660 tree
2661 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2662 {
2663 tree ret;
2664 va_list args;
2665 va_start (args, nargs);
2666 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2667 va_end (args);
2668 return ret;
2669 }
2670
2671 /* Builds a function decl. The remaining parameters are the types of the
2672 function arguments. Negative nargs indicates a varargs function.
2673 The SPEC parameter specifies the function argument and return type
2674 specification according to the fnspec function type attribute. */
2675
2676 tree
2677 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2678 tree rettype, int nargs, ...)
2679 {
2680 tree ret;
2681 va_list args;
2682 va_start (args, nargs);
2683 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2684 va_end (args);
2685 return ret;
2686 }
2687
2688 static void
2689 gfc_build_intrinsic_function_decls (void)
2690 {
2691 tree gfc_int4_type_node = gfc_get_int_type (4);
2692 tree gfc_int8_type_node = gfc_get_int_type (8);
2693 tree gfc_int16_type_node = gfc_get_int_type (16);
2694 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2695 tree pchar1_type_node = gfc_get_pchar_type (1);
2696 tree pchar4_type_node = gfc_get_pchar_type (4);
2697
2698 /* String functions. */
2699 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2700 get_identifier (PREFIX("compare_string")), "..R.R",
2701 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2702 gfc_charlen_type_node, pchar1_type_node);
2703 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2704 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2705
2706 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2707 get_identifier (PREFIX("concat_string")), "..W.R.R",
2708 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2709 gfc_charlen_type_node, pchar1_type_node,
2710 gfc_charlen_type_node, pchar1_type_node);
2711 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2712
2713 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2714 get_identifier (PREFIX("string_len_trim")), "..R",
2715 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2716 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2717 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2718
2719 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2720 get_identifier (PREFIX("string_index")), "..R.R.",
2721 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2722 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2723 DECL_PURE_P (gfor_fndecl_string_index) = 1;
2724 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2725
2726 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2727 get_identifier (PREFIX("string_scan")), "..R.R.",
2728 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2729 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2730 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2731 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2732
2733 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2734 get_identifier (PREFIX("string_verify")), "..R.R.",
2735 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2736 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2737 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2738 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2739
2740 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2741 get_identifier (PREFIX("string_trim")), ".Ww.R",
2742 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2743 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2744 pchar1_type_node);
2745
2746 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2747 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2748 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2749 build_pointer_type (pchar1_type_node), integer_type_node,
2750 integer_type_node);
2751
2752 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2753 get_identifier (PREFIX("adjustl")), ".W.R",
2754 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2755 pchar1_type_node);
2756 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2757
2758 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2759 get_identifier (PREFIX("adjustr")), ".W.R",
2760 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2761 pchar1_type_node);
2762 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2763
2764 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2765 get_identifier (PREFIX("select_string")), ".R.R.",
2766 integer_type_node, 4, pvoid_type_node, integer_type_node,
2767 pchar1_type_node, gfc_charlen_type_node);
2768 DECL_PURE_P (gfor_fndecl_select_string) = 1;
2769 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2770
2771 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2772 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2773 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2774 gfc_charlen_type_node, pchar4_type_node);
2775 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2776 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2777
2778 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2779 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2780 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2781 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2782 pchar4_type_node);
2783 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2784
2785 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2786 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2787 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2788 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2789 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2790
2791 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2792 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2793 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2794 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2795 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2796 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2797
2798 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2799 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2800 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2801 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2802 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2803 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2804
2805 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2806 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2807 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2808 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2809 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2810 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2811
2812 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2813 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2814 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2815 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2816 pchar4_type_node);
2817
2818 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2819 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2820 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2821 build_pointer_type (pchar4_type_node), integer_type_node,
2822 integer_type_node);
2823
2824 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2825 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2826 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2827 pchar4_type_node);
2828 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2829
2830 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2831 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2832 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2833 pchar4_type_node);
2834 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2835
2836 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2837 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2838 integer_type_node, 4, pvoid_type_node, integer_type_node,
2839 pvoid_type_node, gfc_charlen_type_node);
2840 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2841 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2842
2843
2844 /* Conversion between character kinds. */
2845
2846 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2847 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2848 void_type_node, 3, build_pointer_type (pchar4_type_node),
2849 gfc_charlen_type_node, pchar1_type_node);
2850
2851 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2852 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2853 void_type_node, 3, build_pointer_type (pchar1_type_node),
2854 gfc_charlen_type_node, pchar4_type_node);
2855
2856 /* Misc. functions. */
2857
2858 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2859 get_identifier (PREFIX("ttynam")), ".W",
2860 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2861 integer_type_node);
2862
2863 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2864 get_identifier (PREFIX("fdate")), ".W",
2865 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2866
2867 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2868 get_identifier (PREFIX("ctime")), ".W",
2869 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2870 gfc_int8_type_node);
2871
2872 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2873 get_identifier (PREFIX("selected_char_kind")), "..R",
2874 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2875 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2876 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
2877
2878 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2879 get_identifier (PREFIX("selected_int_kind")), ".R",
2880 gfc_int4_type_node, 1, pvoid_type_node);
2881 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2882 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
2883
2884 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2885 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2886 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2887 pvoid_type_node);
2888 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2889 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
2890
2891 /* Power functions. */
2892 {
2893 tree ctype, rtype, itype, jtype;
2894 int rkind, ikind, jkind;
2895 #define NIKINDS 3
2896 #define NRKINDS 4
2897 static int ikinds[NIKINDS] = {4, 8, 16};
2898 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2899 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2900
2901 for (ikind=0; ikind < NIKINDS; ikind++)
2902 {
2903 itype = gfc_get_int_type (ikinds[ikind]);
2904
2905 for (jkind=0; jkind < NIKINDS; jkind++)
2906 {
2907 jtype = gfc_get_int_type (ikinds[jkind]);
2908 if (itype && jtype)
2909 {
2910 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2911 ikinds[jkind]);
2912 gfor_fndecl_math_powi[jkind][ikind].integer =
2913 gfc_build_library_function_decl (get_identifier (name),
2914 jtype, 2, jtype, itype);
2915 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2916 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2917 }
2918 }
2919
2920 for (rkind = 0; rkind < NRKINDS; rkind ++)
2921 {
2922 rtype = gfc_get_real_type (rkinds[rkind]);
2923 if (rtype && itype)
2924 {
2925 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2926 ikinds[ikind]);
2927 gfor_fndecl_math_powi[rkind][ikind].real =
2928 gfc_build_library_function_decl (get_identifier (name),
2929 rtype, 2, rtype, itype);
2930 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2931 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2932 }
2933
2934 ctype = gfc_get_complex_type (rkinds[rkind]);
2935 if (ctype && itype)
2936 {
2937 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2938 ikinds[ikind]);
2939 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2940 gfc_build_library_function_decl (get_identifier (name),
2941 ctype, 2,ctype, itype);
2942 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2943 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2944 }
2945 }
2946 }
2947 #undef NIKINDS
2948 #undef NRKINDS
2949 }
2950
2951 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2952 get_identifier (PREFIX("ishftc4")),
2953 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2954 gfc_int4_type_node);
2955 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2956 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
2957
2958 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2959 get_identifier (PREFIX("ishftc8")),
2960 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2961 gfc_int4_type_node);
2962 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
2963 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
2964
2965 if (gfc_int16_type_node)
2966 {
2967 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
2968 get_identifier (PREFIX("ishftc16")),
2969 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2970 gfc_int4_type_node);
2971 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
2972 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
2973 }
2974
2975 /* BLAS functions. */
2976 {
2977 tree pint = build_pointer_type (integer_type_node);
2978 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2979 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2980 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2981 tree pz = build_pointer_type
2982 (gfc_get_complex_type (gfc_default_double_kind));
2983
2984 gfor_fndecl_sgemm = gfc_build_library_function_decl
2985 (get_identifier
2986 (gfc_option.flag_underscoring ? "sgemm_"
2987 : "sgemm"),
2988 void_type_node, 15, pchar_type_node,
2989 pchar_type_node, pint, pint, pint, ps, ps, pint,
2990 ps, pint, ps, ps, pint, integer_type_node,
2991 integer_type_node);
2992 gfor_fndecl_dgemm = gfc_build_library_function_decl
2993 (get_identifier
2994 (gfc_option.flag_underscoring ? "dgemm_"
2995 : "dgemm"),
2996 void_type_node, 15, pchar_type_node,
2997 pchar_type_node, pint, pint, pint, pd, pd, pint,
2998 pd, pint, pd, pd, pint, integer_type_node,
2999 integer_type_node);
3000 gfor_fndecl_cgemm = gfc_build_library_function_decl
3001 (get_identifier
3002 (gfc_option.flag_underscoring ? "cgemm_"
3003 : "cgemm"),
3004 void_type_node, 15, pchar_type_node,
3005 pchar_type_node, pint, pint, pint, pc, pc, pint,
3006 pc, pint, pc, pc, pint, integer_type_node,
3007 integer_type_node);
3008 gfor_fndecl_zgemm = gfc_build_library_function_decl
3009 (get_identifier
3010 (gfc_option.flag_underscoring ? "zgemm_"
3011 : "zgemm"),
3012 void_type_node, 15, pchar_type_node,
3013 pchar_type_node, pint, pint, pint, pz, pz, pint,
3014 pz, pint, pz, pz, pint, integer_type_node,
3015 integer_type_node);
3016 }
3017
3018 /* Other functions. */
3019 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
3020 get_identifier (PREFIX("size0")), ".R",
3021 gfc_array_index_type, 1, pvoid_type_node);
3022 DECL_PURE_P (gfor_fndecl_size0) = 1;
3023 TREE_NOTHROW (gfor_fndecl_size0) = 1;
3024
3025 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
3026 get_identifier (PREFIX("size1")), ".R",
3027 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
3028 DECL_PURE_P (gfor_fndecl_size1) = 1;
3029 TREE_NOTHROW (gfor_fndecl_size1) = 1;
3030
3031 gfor_fndecl_iargc = gfc_build_library_function_decl (
3032 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
3033 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3034 }
3035
3036
3037 /* Make prototypes for runtime library functions. */
3038
3039 void
3040 gfc_build_builtin_function_decls (void)
3041 {
3042 tree gfc_int4_type_node = gfc_get_int_type (4);
3043
3044 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3045 get_identifier (PREFIX("stop_numeric")),
3046 void_type_node, 1, gfc_int4_type_node);
3047 /* STOP doesn't return. */
3048 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3049
3050 gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
3051 get_identifier (PREFIX("stop_numeric_f08")),
3052 void_type_node, 1, gfc_int4_type_node);
3053 /* STOP doesn't return. */
3054 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
3055
3056 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3057 get_identifier (PREFIX("stop_string")), ".R.",
3058 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3059 /* STOP doesn't return. */
3060 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3061
3062 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3063 get_identifier (PREFIX("error_stop_numeric")),
3064 void_type_node, 1, gfc_int4_type_node);
3065 /* ERROR STOP doesn't return. */
3066 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3067
3068 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3069 get_identifier (PREFIX("error_stop_string")), ".R.",
3070 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3071 /* ERROR STOP doesn't return. */
3072 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3073
3074 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3075 get_identifier (PREFIX("pause_numeric")),
3076 void_type_node, 1, gfc_int4_type_node);
3077
3078 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3079 get_identifier (PREFIX("pause_string")), ".R.",
3080 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3081
3082 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3083 get_identifier (PREFIX("runtime_error")), ".R",
3084 void_type_node, -1, pchar_type_node);
3085 /* The runtime_error function does not return. */
3086 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
3087
3088 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
3089 get_identifier (PREFIX("runtime_error_at")), ".RR",
3090 void_type_node, -2, pchar_type_node, pchar_type_node);
3091 /* The runtime_error_at function does not return. */
3092 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
3093
3094 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
3095 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3096 void_type_node, -2, pchar_type_node, pchar_type_node);
3097
3098 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
3099 get_identifier (PREFIX("generate_error")), ".R.R",
3100 void_type_node, 3, pvoid_type_node, integer_type_node,
3101 pchar_type_node);
3102
3103 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
3104 get_identifier (PREFIX("os_error")), ".R",
3105 void_type_node, 1, pchar_type_node);
3106 /* The runtime_error function does not return. */
3107 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
3108
3109 gfor_fndecl_set_args = gfc_build_library_function_decl (
3110 get_identifier (PREFIX("set_args")),
3111 void_type_node, 2, integer_type_node,
3112 build_pointer_type (pchar_type_node));
3113
3114 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
3115 get_identifier (PREFIX("set_fpe")),
3116 void_type_node, 1, integer_type_node);
3117
3118 /* Keep the array dimension in sync with the call, later in this file. */
3119 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3120 get_identifier (PREFIX("set_options")), "..R",
3121 void_type_node, 2, integer_type_node,
3122 build_pointer_type (integer_type_node));
3123
3124 gfor_fndecl_set_convert = gfc_build_library_function_decl (
3125 get_identifier (PREFIX("set_convert")),
3126 void_type_node, 1, integer_type_node);
3127
3128 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3129 get_identifier (PREFIX("set_record_marker")),
3130 void_type_node, 1, integer_type_node);
3131
3132 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3133 get_identifier (PREFIX("set_max_subrecord_length")),
3134 void_type_node, 1, integer_type_node);
3135
3136 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3137 get_identifier (PREFIX("internal_pack")), ".r",
3138 pvoid_type_node, 1, pvoid_type_node);
3139
3140 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3141 get_identifier (PREFIX("internal_unpack")), ".wR",
3142 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3143
3144 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3145 get_identifier (PREFIX("associated")), ".RR",
3146 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3147 DECL_PURE_P (gfor_fndecl_associated) = 1;
3148 TREE_NOTHROW (gfor_fndecl_associated) = 1;
3149
3150 /* Coarray library calls. */
3151 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
3152 {
3153 tree pint_type, pppchar_type;
3154
3155 pint_type = build_pointer_type (integer_type_node);
3156 pppchar_type
3157 = build_pointer_type (build_pointer_type (pchar_type_node));
3158
3159 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3160 get_identifier (PREFIX("caf_init")), void_type_node,
3161 4, pint_type, pppchar_type, pint_type, pint_type);
3162
3163 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3164 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3165
3166 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3167 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
3168 size_type_node, integer_type_node, ppvoid_type_node, pint_type,
3169 pchar_type_node, integer_type_node);
3170
3171 gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3172 get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
3173 ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
3174
3175 gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3176 get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3177
3178 gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3179 get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3180
3181 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3182 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3183 3, pint_type, build_pointer_type (pchar_type_node), integer_type_node);
3184
3185 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3186 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3187 5, integer_type_node, pint_type, pint_type,
3188 build_pointer_type (pchar_type_node), integer_type_node);
3189
3190 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3191 get_identifier (PREFIX("caf_error_stop")),
3192 void_type_node, 1, gfc_int4_type_node);
3193 /* CAF's ERROR STOP doesn't return. */
3194 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3195
3196 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3197 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3198 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3199 /* CAF's ERROR STOP doesn't return. */
3200 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3201 }
3202
3203 gfc_build_intrinsic_function_decls ();
3204 gfc_build_intrinsic_lib_fndecls ();
3205 gfc_build_io_library_fndecls ();
3206 }
3207
3208
3209 /* Evaluate the length of dummy character variables. */
3210
3211 static void
3212 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3213 gfc_wrapped_block *block)
3214 {
3215 stmtblock_t init;
3216
3217 gfc_finish_decl (cl->backend_decl);
3218
3219 gfc_start_block (&init);
3220
3221 /* Evaluate the string length expression. */
3222 gfc_conv_string_length (cl, NULL, &init);
3223
3224 gfc_trans_vla_type_sizes (sym, &init);
3225
3226 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3227 }
3228
3229
3230 /* Allocate and cleanup an automatic character variable. */
3231
3232 static void
3233 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3234 {
3235 stmtblock_t init;
3236 tree decl;
3237 tree tmp;
3238
3239 gcc_assert (sym->backend_decl);
3240 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3241
3242 gfc_init_block (&init);
3243
3244 /* Evaluate the string length expression. */
3245 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3246
3247 gfc_trans_vla_type_sizes (sym, &init);
3248
3249 decl = sym->backend_decl;
3250
3251 /* Emit a DECL_EXPR for this variable, which will cause the
3252 gimplifier to allocate storage, and all that good stuff. */
3253 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3254 gfc_add_expr_to_block (&init, tmp);
3255
3256 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3257 }
3258
3259 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3260
3261 static void
3262 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3263 {
3264 stmtblock_t init;
3265
3266 gcc_assert (sym->backend_decl);
3267 gfc_start_block (&init);
3268
3269 /* Set the initial value to length. See the comments in
3270 function gfc_add_assign_aux_vars in this file. */
3271 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3272 build_int_cst (gfc_charlen_type_node, -2));
3273
3274 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3275 }
3276
3277 static void
3278 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3279 {
3280 tree t = *tp, var, val;
3281
3282 if (t == NULL || t == error_mark_node)
3283 return;
3284 if (TREE_CONSTANT (t) || DECL_P (t))
3285 return;
3286
3287 if (TREE_CODE (t) == SAVE_EXPR)
3288 {
3289 if (SAVE_EXPR_RESOLVED_P (t))
3290 {
3291 *tp = TREE_OPERAND (t, 0);
3292 return;
3293 }
3294 val = TREE_OPERAND (t, 0);
3295 }
3296 else
3297 val = t;
3298
3299 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3300 gfc_add_decl_to_function (var);
3301 gfc_add_modify (body, var, val);
3302 if (TREE_CODE (t) == SAVE_EXPR)
3303 TREE_OPERAND (t, 0) = var;
3304 *tp = var;
3305 }
3306
3307 static void
3308 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3309 {
3310 tree t;
3311
3312 if (type == NULL || type == error_mark_node)
3313 return;
3314
3315 type = TYPE_MAIN_VARIANT (type);
3316
3317 if (TREE_CODE (type) == INTEGER_TYPE)
3318 {
3319 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3320 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3321
3322 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3323 {
3324 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3325 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3326 }
3327 }
3328 else if (TREE_CODE (type) == ARRAY_TYPE)
3329 {
3330 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3331 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3332 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3333 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3334
3335 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3336 {
3337 TYPE_SIZE (t) = TYPE_SIZE (type);
3338 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3339 }
3340 }
3341 }
3342
3343 /* Make sure all type sizes and array domains are either constant,
3344 or variable or parameter decls. This is a simplified variant
3345 of gimplify_type_sizes, but we can't use it here, as none of the
3346 variables in the expressions have been gimplified yet.
3347 As type sizes and domains for various variable length arrays
3348 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3349 time, without this routine gimplify_type_sizes in the middle-end
3350 could result in the type sizes being gimplified earlier than where
3351 those variables are initialized. */
3352
3353 void
3354 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3355 {
3356 tree type = TREE_TYPE (sym->backend_decl);
3357
3358 if (TREE_CODE (type) == FUNCTION_TYPE
3359 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3360 {
3361 if (! current_fake_result_decl)
3362 return;
3363
3364 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3365 }
3366
3367 while (POINTER_TYPE_P (type))
3368 type = TREE_TYPE (type);
3369
3370 if (GFC_DESCRIPTOR_TYPE_P (type))
3371 {
3372 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3373
3374 while (POINTER_TYPE_P (etype))
3375 etype = TREE_TYPE (etype);
3376
3377 gfc_trans_vla_type_sizes_1 (etype, body);
3378 }
3379
3380 gfc_trans_vla_type_sizes_1 (type, body);
3381 }
3382
3383
3384 /* Initialize a derived type by building an lvalue from the symbol
3385 and using trans_assignment to do the work. Set dealloc to false
3386 if no deallocation prior the assignment is needed. */
3387 void
3388 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3389 {
3390 gfc_expr *e;
3391 tree tmp;
3392 tree present;
3393
3394 gcc_assert (block);
3395
3396 gcc_assert (!sym->attr.allocatable);
3397 gfc_set_sym_referenced (sym);
3398 e = gfc_lval_expr_from_sym (sym);
3399 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3400 if (sym->attr.dummy && (sym->attr.optional
3401 || sym->ns->proc_name->attr.entry_master))
3402 {
3403 present = gfc_conv_expr_present (sym);
3404 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3405 tmp, build_empty_stmt (input_location));
3406 }
3407 gfc_add_expr_to_block (block, tmp);
3408 gfc_free_expr (e);
3409 }
3410
3411
3412 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3413 them their default initializer, if they do not have allocatable
3414 components, they have their allocatable components deallocated. */
3415
3416 static void
3417 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3418 {
3419 stmtblock_t init;
3420 gfc_formal_arglist *f;
3421 tree tmp;
3422 tree present;
3423
3424 gfc_init_block (&init);
3425 for (f = proc_sym->formal; f; f = f->next)
3426 if (f->sym && f->sym->attr.intent == INTENT_OUT
3427 && !f->sym->attr.pointer
3428 && f->sym->ts.type == BT_DERIVED)
3429 {
3430 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3431 {
3432 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3433 f->sym->backend_decl,
3434 f->sym->as ? f->sym->as->rank : 0);
3435
3436 if (f->sym->attr.optional
3437 || f->sym->ns->proc_name->attr.entry_master)
3438 {
3439 present = gfc_conv_expr_present (f->sym);
3440 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3441 present, tmp,
3442 build_empty_stmt (input_location));
3443 }
3444
3445 gfc_add_expr_to_block (&init, tmp);
3446 }
3447 else if (f->sym->value)
3448 gfc_init_default_dt (f->sym, &init, true);
3449 }
3450 else if (f->sym && f->sym->attr.intent == INTENT_OUT
3451 && f->sym->ts.type == BT_CLASS
3452 && !CLASS_DATA (f->sym)->attr.class_pointer
3453 && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
3454 {
3455 tree decl = build_fold_indirect_ref_loc (input_location,
3456 f->sym->backend_decl);
3457 tmp = CLASS_DATA (f->sym)->backend_decl;
3458 tmp = fold_build3_loc (input_location, COMPONENT_REF,
3459 TREE_TYPE (tmp), decl, tmp, NULL_TREE);
3460 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3461 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
3462 tmp,
3463 CLASS_DATA (f->sym)->as ?
3464 CLASS_DATA (f->sym)->as->rank : 0);
3465
3466 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3467 {
3468 present = gfc_conv_expr_present (f->sym);
3469 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3470 present, tmp,
3471 build_empty_stmt (input_location));
3472 }
3473
3474 gfc_add_expr_to_block (&init, tmp);
3475 }
3476
3477 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3478 }
3479
3480
3481 /* Generate function entry and exit code, and add it to the function body.
3482 This includes:
3483 Allocation and initialization of array variables.
3484 Allocation of character string variables.
3485 Initialization and possibly repacking of dummy arrays.
3486 Initialization of ASSIGN statement auxiliary variable.
3487 Initialization of ASSOCIATE names.
3488 Automatic deallocation. */
3489
3490 void
3491 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3492 {
3493 locus loc;
3494 gfc_symbol *sym;
3495 gfc_formal_arglist *f;
3496 stmtblock_t tmpblock;
3497 bool seen_trans_deferred_array = false;
3498 tree tmp = NULL;
3499 gfc_expr *e;
3500 gfc_se se;
3501 stmtblock_t init;
3502
3503 /* Deal with implicit return variables. Explicit return variables will
3504 already have been added. */
3505 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3506 {
3507 if (!current_fake_result_decl)
3508 {
3509 gfc_entry_list *el = NULL;
3510 if (proc_sym->attr.entry_master)
3511 {
3512 for (el = proc_sym->ns->entries; el; el = el->next)
3513 if (el->sym != el->sym->result)
3514 break;
3515 }
3516 /* TODO: move to the appropriate place in resolve.c. */
3517 if (warn_return_type && el == NULL)
3518 gfc_warning ("Return value of function '%s' at %L not set",
3519 proc_sym->name, &proc_sym->declared_at);
3520 }
3521 else if (proc_sym->as)
3522 {
3523 tree result = TREE_VALUE (current_fake_result_decl);
3524 gfc_trans_dummy_array_bias (proc_sym, result, block);
3525
3526 /* An automatic character length, pointer array result. */
3527 if (proc_sym->ts.type == BT_CHARACTER
3528 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3529 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3530 }
3531 else if (proc_sym->ts.type == BT_CHARACTER)
3532 {
3533 if (proc_sym->ts.deferred)
3534 {
3535 tmp = NULL;
3536 gfc_save_backend_locus (&loc);
3537 gfc_set_backend_locus (&proc_sym->declared_at);
3538 gfc_start_block (&init);
3539 /* Zero the string length on entry. */
3540 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3541 build_int_cst (gfc_charlen_type_node, 0));
3542 /* Null the pointer. */
3543 e = gfc_lval_expr_from_sym (proc_sym);
3544 gfc_init_se (&se, NULL);
3545 se.want_pointer = 1;
3546 gfc_conv_expr (&se, e);
3547 gfc_free_expr (e);
3548 tmp = se.expr;
3549 gfc_add_modify (&init, tmp,
3550 fold_convert (TREE_TYPE (se.expr),
3551 null_pointer_node));
3552 gfc_restore_backend_locus (&loc);
3553
3554 /* Pass back the string length on exit. */
3555 tmp = proc_sym->ts.u.cl->passed_length;
3556 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3557 tmp = fold_convert (gfc_charlen_type_node, tmp);
3558 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3559 gfc_charlen_type_node, tmp,
3560 proc_sym->ts.u.cl->backend_decl);
3561 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3562 }
3563 else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3564 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3565 }
3566 else
3567 gcc_assert (gfc_option.flag_f2c
3568 && proc_sym->ts.type == BT_COMPLEX);
3569 }
3570
3571 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3572 should be done here so that the offsets and lbounds of arrays
3573 are available. */
3574 gfc_save_backend_locus (&loc);
3575 gfc_set_backend_locus (&proc_sym->declared_at);
3576 init_intent_out_dt (proc_sym, block);
3577 gfc_restore_backend_locus (&loc);
3578
3579 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3580 {
3581 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3582 && sym->ts.u.derived->attr.alloc_comp;
3583 if (sym->assoc)
3584 continue;
3585
3586 if (sym->attr.subref_array_pointer
3587 && GFC_DECL_SPAN (sym->backend_decl)
3588 && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
3589 {
3590 gfc_init_block (&tmpblock);
3591 gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
3592 build_int_cst (gfc_array_index_type, 0));
3593 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3594 NULL_TREE);
3595 }
3596
3597 if (sym->attr.dimension || sym->attr.codimension)
3598 {
3599 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3600 array_type tmp = sym->as->type;
3601 if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
3602 tmp = AS_EXPLICIT;
3603 switch (tmp)
3604 {
3605 case AS_EXPLICIT:
3606 if (sym->attr.dummy || sym->attr.result)
3607 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3608 else if (sym->attr.pointer || sym->attr.allocatable)
3609 {
3610 if (TREE_STATIC (sym->backend_decl))
3611 {
3612 gfc_save_backend_locus (&loc);
3613 gfc_set_backend_locus (&sym->declared_at);
3614 gfc_trans_static_array_pointer (sym);
3615 gfc_restore_backend_locus (&loc);
3616 }
3617 else
3618 {
3619 seen_trans_deferred_array = true;
3620 gfc_trans_deferred_array (sym, block);
3621 }
3622 }
3623 else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
3624 {
3625 gfc_init_block (&tmpblock);
3626 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
3627 &tmpblock, sym);
3628 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3629 NULL_TREE);
3630 continue;
3631 }
3632 else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
3633 {
3634 gfc_save_backend_locus (&loc);
3635 gfc_set_backend_locus (&sym->declared_at);
3636
3637 if (sym_has_alloc_comp)
3638 {
3639 seen_trans_deferred_array = true;
3640 gfc_trans_deferred_array (sym, block);
3641 }
3642 else if (sym->ts.type == BT_DERIVED
3643 && sym->value
3644 && !sym->attr.data
3645 && sym->attr.save == SAVE_NONE)
3646 {
3647 gfc_start_block (&tmpblock);
3648 gfc_init_default_dt (sym, &tmpblock, false);
3649 gfc_add_init_cleanup (block,
3650 gfc_finish_block (&tmpblock),
3651 NULL_TREE);
3652 }
3653
3654 gfc_trans_auto_array_allocation (sym->backend_decl,
3655 sym, block);
3656 gfc_restore_backend_locus (&loc);
3657 }
3658 break;
3659
3660 case AS_ASSUMED_SIZE:
3661 /* Must be a dummy parameter. */
3662 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3663
3664 /* We should always pass assumed size arrays the g77 way. */
3665 if (sym->attr.dummy)
3666 gfc_trans_g77_array (sym, block);
3667 break;
3668
3669 case AS_ASSUMED_SHAPE:
3670 /* Must be a dummy parameter. */
3671 gcc_assert (sym->attr.dummy);
3672
3673 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3674 break;
3675
3676 case AS_DEFERRED:
3677 seen_trans_deferred_array = true;
3678 gfc_trans_deferred_array (sym, block);
3679 break;
3680
3681 default:
3682 gcc_unreachable ();
3683 }
3684 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3685 gfc_trans_deferred_array (sym, block);
3686 }
3687 else if ((!sym->attr.dummy || sym->ts.deferred)
3688 && (sym->ts.type == BT_CLASS
3689 && CLASS_DATA (sym)->attr.class_pointer))
3690 continue;
3691 else if ((!sym->attr.dummy || sym->ts.deferred)
3692 && (sym->attr.allocatable
3693 || (sym->ts.type == BT_CLASS
3694 && CLASS_DATA (sym)->attr.allocatable)))
3695 {
3696 if (!sym->attr.save)
3697 {
3698 tree descriptor = NULL_TREE;
3699
3700 /* Nullify and automatic deallocation of allocatable
3701 scalars. */
3702 e = gfc_lval_expr_from_sym (sym);
3703 if (sym->ts.type == BT_CLASS)
3704 gfc_add_data_component (e);
3705
3706 gfc_init_se (&se, NULL);
3707 if (sym->ts.type != BT_CLASS
3708 || sym->ts.u.derived->attr.dimension
3709 || sym->ts.u.derived->attr.codimension)
3710 {
3711 se.want_pointer = 1;
3712 gfc_conv_expr (&se, e);
3713 }
3714 else if (sym->ts.type == BT_CLASS
3715 && !CLASS_DATA (sym)->attr.dimension
3716 && !CLASS_DATA (sym)->attr.codimension)
3717 {
3718 se.want_pointer = 1;
3719 gfc_conv_expr (&se, e);
3720 }
3721 else
3722 {
3723 gfc_conv_expr (&se, e);
3724 descriptor = se.expr;
3725 se.expr = gfc_conv_descriptor_data_addr (se.expr);
3726 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
3727 }
3728 gfc_free_expr (e);
3729
3730 gfc_save_backend_locus (&loc);
3731 gfc_set_backend_locus (&sym->declared_at);
3732 gfc_start_block (&init);
3733
3734 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3735 {
3736 /* Nullify when entering the scope. */
3737 gfc_add_modify (&init, se.expr,
3738 fold_convert (TREE_TYPE (se.expr),
3739 null_pointer_node));
3740 }
3741
3742 if ((sym->attr.dummy ||sym->attr.result)
3743 && sym->ts.type == BT_CHARACTER
3744 && sym->ts.deferred)
3745 {
3746 /* Character length passed by reference. */
3747 tmp = sym->ts.u.cl->passed_length;
3748 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3749 tmp = fold_convert (gfc_charlen_type_node, tmp);
3750
3751 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3752 /* Zero the string length when entering the scope. */
3753 gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3754 build_int_cst (gfc_charlen_type_node, 0));
3755 else
3756 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3757
3758 gfc_restore_backend_locus (&loc);
3759
3760 /* Pass the final character length back. */
3761 if (sym->attr.intent != INTENT_IN)
3762 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3763 gfc_charlen_type_node, tmp,
3764 sym->ts.u.cl->backend_decl);
3765 else
3766 tmp = NULL_TREE;
3767 }
3768 else
3769 gfc_restore_backend_locus (&loc);
3770
3771 /* Deallocate when leaving the scope. Nullifying is not
3772 needed. */
3773 if (!sym->attr.result && !sym->attr.dummy)
3774 {
3775 if (sym->ts.type == BT_CLASS
3776 && CLASS_DATA (sym)->attr.codimension)
3777 tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
3778 NULL_TREE, NULL_TREE,
3779 NULL_TREE, true, NULL,
3780 true);
3781 else
3782 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL,
3783 true, NULL,
3784 sym->ts);
3785 }
3786 if (sym->ts.type == BT_CLASS)
3787 {
3788 /* Initialize _vptr to declared type. */
3789 gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
3790 tree rhs;
3791
3792 gfc_save_backend_locus (&loc);
3793 gfc_set_backend_locus (&sym->declared_at);
3794 e = gfc_lval_expr_from_sym (sym);
3795 gfc_add_vptr_component (e);
3796 gfc_init_se (&se, NULL);
3797 se.want_pointer = 1;
3798 gfc_conv_expr (&se, e);
3799 gfc_free_expr (e);
3800 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
3801 gfc_get_symbol_decl (vtab));
3802 gfc_add_modify (&init, se.expr, rhs);
3803 gfc_restore_backend_locus (&loc);
3804 }
3805
3806 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3807 }
3808 }
3809 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
3810 {
3811 tree tmp = NULL;
3812 stmtblock_t init;
3813
3814 /* If we get to here, all that should be left are pointers. */
3815 gcc_assert (sym->attr.pointer);
3816
3817 if (sym->attr.dummy)
3818 {
3819 gfc_start_block (&init);
3820
3821 /* Character length passed by reference. */
3822 tmp = sym->ts.u.cl->passed_length;
3823 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3824 tmp = fold_convert (gfc_charlen_type_node, tmp);
3825 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3826 /* Pass the final character length back. */
3827 if (sym->attr.intent != INTENT_IN)
3828 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3829 gfc_charlen_type_node, tmp,
3830 sym->ts.u.cl->backend_decl);
3831 else
3832 tmp = NULL_TREE;
3833 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3834 }
3835 }
3836 else if (sym->ts.deferred)
3837 gfc_fatal_error ("Deferred type parameter not yet supported");
3838 else if (sym_has_alloc_comp)
3839 gfc_trans_deferred_array (sym, block);
3840 else if (sym->ts.type == BT_CHARACTER)
3841 {
3842 gfc_save_backend_locus (&loc);
3843 gfc_set_backend_locus (&sym->declared_at);
3844 if (sym->attr.dummy || sym->attr.result)
3845 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3846 else
3847 gfc_trans_auto_character_variable (sym, block);
3848 gfc_restore_backend_locus (&loc);
3849 }
3850 else if (sym->attr.assign)
3851 {
3852 gfc_save_backend_locus (&loc);
3853 gfc_set_backend_locus (&sym->declared_at);
3854 gfc_trans_assign_aux_var (sym, block);
3855 gfc_restore_backend_locus (&loc);
3856 }
3857 else if (sym->ts.type == BT_DERIVED
3858 && sym->value
3859 && !sym->attr.data
3860 && sym->attr.save == SAVE_NONE)
3861 {
3862 gfc_start_block (&tmpblock);
3863 gfc_init_default_dt (sym, &tmpblock, false);
3864 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3865 NULL_TREE);
3866 }
3867 else
3868 gcc_unreachable ();
3869 }
3870
3871 gfc_init_block (&tmpblock);
3872
3873 for (f = proc_sym->formal; f; f = f->next)
3874 {
3875 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3876 {
3877 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3878 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3879 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3880 }
3881 }
3882
3883 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3884 && current_fake_result_decl != NULL)
3885 {
3886 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3887 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3888 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3889 }
3890
3891 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3892 }
3893
3894 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3895
3896 /* Hash and equality functions for module_htab. */
3897
3898 static hashval_t
3899 module_htab_do_hash (const void *x)
3900 {
3901 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3902 }
3903
3904 static int
3905 module_htab_eq (const void *x1, const void *x2)
3906 {
3907 return strcmp ((((const struct module_htab_entry *)x1)->name),
3908 (const char *)x2) == 0;
3909 }
3910
3911 /* Hash and equality functions for module_htab's decls. */
3912
3913 static hashval_t
3914 module_htab_decls_hash (const void *x)
3915 {
3916 const_tree t = (const_tree) x;
3917 const_tree n = DECL_NAME (t);
3918 if (n == NULL_TREE)
3919 n = TYPE_NAME (TREE_TYPE (t));
3920 return htab_hash_string (IDENTIFIER_POINTER (n));
3921 }
3922
3923 static int
3924 module_htab_decls_eq (const void *x1, const void *x2)
3925 {
3926 const_tree t1 = (const_tree) x1;
3927 const_tree n1 = DECL_NAME (t1);
3928 if (n1 == NULL_TREE)
3929 n1 = TYPE_NAME (TREE_TYPE (t1));
3930 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3931 }
3932
3933 struct module_htab_entry *
3934 gfc_find_module (const char *name)
3935 {
3936 void **slot;
3937
3938 if (! module_htab)
3939 module_htab = htab_create_ggc (10, module_htab_do_hash,
3940 module_htab_eq, NULL);
3941
3942 slot = htab_find_slot_with_hash (module_htab, name,
3943 htab_hash_string (name), INSERT);
3944 if (*slot == NULL)
3945 {
3946 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3947
3948 entry->name = gfc_get_string (name);
3949 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3950 module_htab_decls_eq, NULL);
3951 *slot = (void *) entry;
3952 }
3953 return (struct module_htab_entry *) *slot;
3954 }
3955
3956 void
3957 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3958 {
3959 void **slot;
3960 const char *name;
3961
3962 if (DECL_NAME (decl))
3963 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3964 else
3965 {
3966 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3967 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3968 }
3969 slot = htab_find_slot_with_hash (entry->decls, name,
3970 htab_hash_string (name), INSERT);
3971 if (*slot == NULL)
3972 *slot = (void *) decl;
3973 }
3974
3975 static struct module_htab_entry *cur_module;
3976
3977 /* Output an initialized decl for a module variable. */
3978
3979 static void
3980 gfc_create_module_variable (gfc_symbol * sym)
3981 {
3982 tree decl;
3983
3984 /* Module functions with alternate entries are dealt with later and
3985 would get caught by the next condition. */
3986 if (sym->attr.entry)
3987 return;
3988
3989 /* Make sure we convert the types of the derived types from iso_c_binding
3990 into (void *). */
3991 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3992 && sym->ts.type == BT_DERIVED)
3993 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3994
3995 if (sym->attr.flavor == FL_DERIVED
3996 && sym->backend_decl
3997 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3998 {
3999 decl = sym->backend_decl;
4000 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4001
4002 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
4003 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
4004 {
4005 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
4006 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
4007 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
4008 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
4009 == sym->ns->proc_name->backend_decl);
4010 }
4011 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4012 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
4013 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
4014 }
4015
4016 /* Only output variables, procedure pointers and array valued,
4017 or derived type, parameters. */
4018 if (sym->attr.flavor != FL_VARIABLE
4019 && !(sym->attr.flavor == FL_PARAMETER
4020 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
4021 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4022 return;
4023
4024 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
4025 {
4026 decl = sym->backend_decl;
4027 gcc_assert (DECL_FILE_SCOPE_P (decl));
4028 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4029 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4030 gfc_module_add_decl (cur_module, decl);
4031 }
4032
4033 /* Don't generate variables from other modules. Variables from
4034 COMMONs will already have been generated. */
4035 if (sym->attr.use_assoc || sym->attr.in_common)
4036 return;
4037
4038 /* Equivalenced variables arrive here after creation. */
4039 if (sym->backend_decl
4040 && (sym->equiv_built || sym->attr.in_equivalence))
4041 return;
4042
4043 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4044 internal_error ("backend decl for module variable %s already exists",
4045 sym->name);
4046
4047 /* We always want module variables to be created. */
4048 sym->attr.referenced = 1;
4049 /* Create the decl. */
4050 decl = gfc_get_symbol_decl (sym);
4051
4052 /* Create the variable. */
4053 pushdecl (decl);
4054 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4055 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4056 rest_of_decl_compilation (decl, 1, 0);
4057 gfc_module_add_decl (cur_module, decl);
4058
4059 /* Also add length of strings. */
4060 if (sym->ts.type == BT_CHARACTER)
4061 {
4062 tree length;
4063
4064 length = sym->ts.u.cl->backend_decl;
4065 gcc_assert (length || sym->attr.proc_pointer);
4066 if (length && !INTEGER_CST_P (length))
4067 {
4068 pushdecl (length);
4069 rest_of_decl_compilation (length, 1, 0);
4070 }
4071 }
4072
4073 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4074 && sym->attr.referenced && !sym->attr.use_assoc)
4075 has_coarray_vars = true;
4076 }
4077
4078 /* Emit debug information for USE statements. */
4079
4080 static void
4081 gfc_trans_use_stmts (gfc_namespace * ns)
4082 {
4083 gfc_use_list *use_stmt;
4084 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
4085 {
4086 struct module_htab_entry *entry
4087 = gfc_find_module (use_stmt->module_name);
4088 gfc_use_rename *rent;
4089
4090 if (entry->namespace_decl == NULL)
4091 {
4092 entry->namespace_decl
4093 = build_decl (input_location,
4094 NAMESPACE_DECL,
4095 get_identifier (use_stmt->module_name),
4096 void_type_node);
4097 DECL_EXTERNAL (entry->namespace_decl) = 1;
4098 }
4099 gfc_set_backend_locus (&use_stmt->where);
4100 if (!use_stmt->only_flag)
4101 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
4102 NULL_TREE,
4103 ns->proc_name->backend_decl,
4104 false);
4105 for (rent = use_stmt->rename; rent; rent = rent->next)
4106 {
4107 tree decl, local_name;
4108 void **slot;
4109
4110 if (rent->op != INTRINSIC_NONE)
4111 continue;
4112
4113 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
4114 htab_hash_string (rent->use_name),
4115 INSERT);
4116 if (*slot == NULL)
4117 {
4118 gfc_symtree *st;
4119
4120 st = gfc_find_symtree (ns->sym_root,
4121 rent->local_name[0]
4122 ? rent->local_name : rent->use_name);
4123
4124 /* The following can happen if a derived type is renamed. */
4125 if (!st)
4126 {
4127 char *name;
4128 name = xstrdup (rent->local_name[0]
4129 ? rent->local_name : rent->use_name);
4130 name[0] = (char) TOUPPER ((unsigned char) name[0]);
4131 st = gfc_find_symtree (ns->sym_root, name);
4132 free (name);
4133 gcc_assert (st);
4134 }
4135
4136 /* Sometimes, generic interfaces wind up being over-ruled by a
4137 local symbol (see PR41062). */
4138 if (!st->n.sym->attr.use_assoc)
4139 continue;
4140
4141 if (st->n.sym->backend_decl
4142 && DECL_P (st->n.sym->backend_decl)
4143 && st->n.sym->module
4144 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
4145 {
4146 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
4147 || (TREE_CODE (st->n.sym->backend_decl)
4148 != VAR_DECL));
4149 decl = copy_node (st->n.sym->backend_decl);
4150 DECL_CONTEXT (decl) = entry->namespace_decl;
4151 DECL_EXTERNAL (decl) = 1;
4152 DECL_IGNORED_P (decl) = 0;
4153 DECL_INITIAL (decl) = NULL_TREE;
4154 }
4155 else
4156 {
4157 *slot = error_mark_node;
4158 htab_clear_slot (entry->decls, slot);
4159 continue;
4160 }
4161 *slot = decl;
4162 }
4163 decl = (tree) *slot;
4164 if (rent->local_name[0])
4165 local_name = get_identifier (rent->local_name);
4166 else
4167 local_name = NULL_TREE;
4168 gfc_set_backend_locus (&rent->where);
4169 (*debug_hooks->imported_module_or_decl) (decl, local_name,
4170 ns->proc_name->backend_decl,
4171 !use_stmt->only_flag);
4172 }
4173 }
4174 }
4175
4176
4177 /* Return true if expr is a constant initializer that gfc_conv_initializer
4178 will handle. */
4179
4180 static bool
4181 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
4182 bool pointer)
4183 {
4184 gfc_constructor *c;
4185 gfc_component *cm;
4186
4187 if (pointer)
4188 return true;
4189 else if (array)
4190 {
4191 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
4192 return true;
4193 else if (expr->expr_type == EXPR_STRUCTURE)
4194 return check_constant_initializer (expr, ts, false, false);
4195 else if (expr->expr_type != EXPR_ARRAY)
4196 return false;
4197 for (c = gfc_constructor_first (expr->value.constructor);
4198 c; c = gfc_constructor_next (c))
4199 {
4200 if (c->iterator)
4201 return false;
4202 if (c->expr->expr_type == EXPR_STRUCTURE)
4203 {
4204 if (!check_constant_initializer (c->expr, ts, false, false))
4205 return false;
4206 }
4207 else if (c->expr->expr_type != EXPR_CONSTANT)
4208 return false;
4209 }
4210 return true;
4211 }
4212 else switch (ts->type)
4213 {
4214 case BT_DERIVED:
4215 if (expr->expr_type != EXPR_STRUCTURE)
4216 return false;
4217 cm = expr->ts.u.derived->components;
4218 for (c = gfc_constructor_first (expr->value.constructor);
4219 c; c = gfc_constructor_next (c), cm = cm->next)
4220 {
4221 if (!c->expr || cm->attr.allocatable)
4222 continue;
4223 if (!check_constant_initializer (c->expr, &cm->ts,
4224 cm->attr.dimension,
4225 cm->attr.pointer))
4226 return false;
4227 }
4228 return true;
4229 default:
4230 return expr->expr_type == EXPR_CONSTANT;
4231 }
4232 }
4233
4234 /* Emit debug info for parameters and unreferenced variables with
4235 initializers. */
4236
4237 static void
4238 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4239 {
4240 tree decl;
4241
4242 if (sym->attr.flavor != FL_PARAMETER
4243 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4244 return;
4245
4246 if (sym->backend_decl != NULL
4247 || sym->value == NULL
4248 || sym->attr.use_assoc
4249 || sym->attr.dummy
4250 || sym->attr.result
4251 || sym->attr.function
4252 || sym->attr.intrinsic
4253 || sym->attr.pointer
4254 || sym->attr.allocatable
4255 || sym->attr.cray_pointee
4256 || sym->attr.threadprivate
4257 || sym->attr.is_bind_c
4258 || sym->attr.subref_array_pointer
4259 || sym->attr.assign)
4260 return;
4261
4262 if (sym->ts.type == BT_CHARACTER)
4263 {
4264 gfc_conv_const_charlen (sym->ts.u.cl);
4265 if (sym->ts.u.cl->backend_decl == NULL
4266 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
4267 return;
4268 }
4269 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
4270 return;
4271
4272 if (sym->as)
4273 {
4274 int n;
4275
4276 if (sym->as->type != AS_EXPLICIT)
4277 return;
4278 for (n = 0; n < sym->as->rank; n++)
4279 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4280 || sym->as->upper[n] == NULL
4281 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4282 return;
4283 }
4284
4285 if (!check_constant_initializer (sym->value, &sym->ts,
4286 sym->attr.dimension, false))
4287 return;
4288
4289 if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
4290 return;
4291
4292 /* Create the decl for the variable or constant. */
4293 decl = build_decl (input_location,
4294 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
4295 gfc_sym_identifier (sym), gfc_sym_type (sym));
4296 if (sym->attr.flavor == FL_PARAMETER)
4297 TREE_READONLY (decl) = 1;
4298 gfc_set_decl_location (decl, &sym->declared_at);
4299 if (sym->attr.dimension)
4300 GFC_DECL_PACKED_ARRAY (decl) = 1;
4301 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4302 TREE_STATIC (decl) = 1;
4303 TREE_USED (decl) = 1;
4304 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4305 TREE_PUBLIC (decl) = 1;
4306 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4307 TREE_TYPE (decl),
4308 sym->attr.dimension,
4309 false, false);
4310 debug_hooks->global_decl (decl);
4311 }
4312
4313
4314 static void
4315 generate_coarray_sym_init (gfc_symbol *sym)
4316 {
4317 tree tmp, size, decl, token;
4318
4319 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
4320 || sym->attr.use_assoc || !sym->attr.referenced)
4321 return;
4322
4323 decl = sym->backend_decl;
4324 TREE_USED(decl) = 1;
4325 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
4326
4327 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4328 to make sure the variable is not optimized away. */
4329 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
4330
4331 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
4332
4333 /* Ensure that we do not have size=0 for zero-sized arrays. */
4334 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
4335 fold_convert (size_type_node, size),
4336 build_int_cst (size_type_node, 1));
4337
4338 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
4339 {
4340 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
4341 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4342 fold_convert (size_type_node, tmp), size);
4343 }
4344
4345 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
4346 token = gfc_build_addr_expr (ppvoid_type_node,
4347 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
4348
4349 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
4350 build_int_cst (integer_type_node,
4351 GFC_CAF_COARRAY_STATIC), /* type. */
4352 token, null_pointer_node, /* token, stat. */
4353 null_pointer_node, /* errgmsg, errmsg_len. */
4354 build_int_cst (integer_type_node, 0));
4355
4356 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
4357
4358
4359 /* Handle "static" initializer. */
4360 if (sym->value)
4361 {
4362 sym->attr.pointer = 1;
4363 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
4364 true, false);
4365 sym->attr.pointer = 0;
4366 gfc_add_expr_to_block (&caf_init_block, tmp);
4367 }
4368 }
4369
4370
4371 /* Generate constructor function to initialize static, nonallocatable
4372 coarrays. */
4373
4374 static void
4375 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
4376 {
4377 tree fndecl, tmp, decl, save_fn_decl;
4378
4379 save_fn_decl = current_function_decl;
4380 push_function_context ();
4381
4382 tmp = build_function_type_list (void_type_node, NULL_TREE);
4383 fndecl = build_decl (input_location, FUNCTION_DECL,
4384 create_tmp_var_name ("_caf_init"), tmp);
4385
4386 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
4387 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
4388
4389 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
4390 DECL_ARTIFICIAL (decl) = 1;
4391 DECL_IGNORED_P (decl) = 1;
4392 DECL_CONTEXT (decl) = fndecl;
4393 DECL_RESULT (fndecl) = decl;
4394
4395 pushdecl (fndecl);
4396 current_function_decl = fndecl;
4397 announce_function (fndecl);
4398
4399 rest_of_decl_compilation (fndecl, 0, 0);
4400 make_decl_rtl (fndecl);
4401 init_function_start (fndecl);
4402
4403 pushlevel (0);
4404 gfc_init_block (&caf_init_block);
4405
4406 gfc_traverse_ns (ns, generate_coarray_sym_init);
4407
4408 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
4409 decl = getdecls ();
4410
4411 poplevel (1, 0, 1);
4412 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4413
4414 DECL_SAVED_TREE (fndecl)
4415 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4416 DECL_INITIAL (fndecl));
4417 dump_function (TDI_original, fndecl);
4418
4419 cfun->function_end_locus = input_location;
4420 set_cfun (NULL);
4421
4422 if (decl_function_context (fndecl))
4423 (void) cgraph_create_node (fndecl);
4424 else
4425 cgraph_finalize_function (fndecl, true);
4426
4427 pop_function_context ();
4428 current_function_decl = save_fn_decl;
4429 }
4430
4431
4432 /* Generate all the required code for module variables. */
4433
4434 void
4435 gfc_generate_module_vars (gfc_namespace * ns)
4436 {
4437 module_namespace = ns;
4438 cur_module = gfc_find_module (ns->proc_name->name);
4439
4440 /* Check if the frontend left the namespace in a reasonable state. */
4441 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4442
4443 /* Generate COMMON blocks. */
4444 gfc_trans_common (ns);
4445
4446 has_coarray_vars = false;
4447
4448 /* Create decls for all the module variables. */
4449 gfc_traverse_ns (ns, gfc_create_module_variable);
4450
4451 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
4452 generate_coarray_init (ns);
4453
4454 cur_module = NULL;
4455
4456 gfc_trans_use_stmts (ns);
4457 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4458 }
4459
4460
4461 static void
4462 gfc_generate_contained_functions (gfc_namespace * parent)
4463 {
4464 gfc_namespace *ns;
4465
4466 /* We create all the prototypes before generating any code. */
4467 for (ns = parent->contained; ns; ns = ns->sibling)
4468 {
4469 /* Skip namespaces from used modules. */
4470 if (ns->parent != parent)
4471 continue;
4472
4473 gfc_create_function_decl (ns, false);
4474 }
4475
4476 for (ns = parent->contained; ns; ns = ns->sibling)
4477 {
4478 /* Skip namespaces from used modules. */
4479 if (ns->parent != parent)
4480 continue;
4481
4482 gfc_generate_function_code (ns);
4483 }
4484 }
4485
4486
4487 /* Drill down through expressions for the array specification bounds and
4488 character length calling generate_local_decl for all those variables
4489 that have not already been declared. */
4490
4491 static void
4492 generate_local_decl (gfc_symbol *);
4493
4494 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4495
4496 static bool
4497 expr_decls (gfc_expr *e, gfc_symbol *sym,
4498 int *f ATTRIBUTE_UNUSED)
4499 {
4500 if (e->expr_type != EXPR_VARIABLE
4501 || sym == e->symtree->n.sym
4502 || e->symtree->n.sym->mark
4503 || e->symtree->n.sym->ns != sym->ns)
4504 return false;
4505
4506 generate_local_decl (e->symtree->n.sym);
4507 return false;
4508 }
4509
4510 static void
4511 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4512 {
4513 gfc_traverse_expr (e, sym, expr_decls, 0);
4514 }
4515
4516
4517 /* Check for dependencies in the character length and array spec. */
4518
4519 static void
4520 generate_dependency_declarations (gfc_symbol *sym)
4521 {
4522 int i;
4523
4524 if (sym->ts.type == BT_CHARACTER
4525 && sym->ts.u.cl
4526 && sym->ts.u.cl->length
4527 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4528 generate_expr_decls (sym, sym->ts.u.cl->length);
4529
4530 if (sym->as && sym->as->rank)
4531 {
4532 for (i = 0; i < sym->as->rank; i++)
4533 {
4534 generate_expr_decls (sym, sym->as->lower[i]);
4535 generate_expr_decls (sym, sym->as->upper[i]);
4536 }
4537 }
4538 }
4539
4540
4541 /* Generate decls for all local variables. We do this to ensure correct
4542 handling of expressions which only appear in the specification of
4543 other functions. */
4544
4545 static void
4546 generate_local_decl (gfc_symbol * sym)
4547 {
4548 if (sym->attr.flavor == FL_VARIABLE)
4549 {
4550 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4551 && sym->attr.referenced && !sym->attr.use_assoc)
4552 has_coarray_vars = true;
4553
4554 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
4555 generate_dependency_declarations (sym);
4556
4557 if (sym->attr.referenced)
4558 gfc_get_symbol_decl (sym);
4559
4560 /* Warnings for unused dummy arguments. */
4561 else if (sym->attr.dummy)
4562 {
4563 /* INTENT(out) dummy arguments are likely meant to be set. */
4564 if (gfc_option.warn_unused_dummy_argument
4565 && sym->attr.intent == INTENT_OUT)
4566 {
4567 if (sym->ts.type != BT_DERIVED)
4568 gfc_warning ("Dummy argument '%s' at %L was declared "
4569 "INTENT(OUT) but was not set", sym->name,
4570 &sym->declared_at);
4571 else if (!gfc_has_default_initializer (sym->ts.u.derived))
4572 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4573 "declared INTENT(OUT) but was not set and "
4574 "does not have a default initializer",
4575 sym->name, &sym->declared_at);
4576 if (sym->backend_decl != NULL_TREE)
4577 TREE_NO_WARNING(sym->backend_decl) = 1;
4578 }
4579 else if (gfc_option.warn_unused_dummy_argument)
4580 {
4581 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4582 &sym->declared_at);
4583 if (sym->backend_decl != NULL_TREE)
4584 TREE_NO_WARNING(sym->backend_decl) = 1;
4585 }
4586 }
4587
4588 /* Warn for unused variables, but not if they're inside a common
4589 block, a namelist, or are use-associated. */
4590 else if (warn_unused_variable
4591 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
4592 || sym->attr.in_namelist))
4593 {
4594 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
4595 &sym->declared_at);
4596 if (sym->backend_decl != NULL_TREE)
4597 TREE_NO_WARNING(sym->backend_decl) = 1;
4598 }
4599 else if (warn_unused_variable && sym->attr.use_only)
4600 {
4601 gfc_warning ("Unused module variable '%s' which has been explicitly "
4602 "imported at %L", sym->name, &sym->declared_at);
4603 if (sym->backend_decl != NULL_TREE)
4604 TREE_NO_WARNING(sym->backend_decl) = 1;
4605 }
4606
4607 /* For variable length CHARACTER parameters, the PARM_DECL already
4608 references the length variable, so force gfc_get_symbol_decl
4609 even when not referenced. If optimize > 0, it will be optimized
4610 away anyway. But do this only after emitting -Wunused-parameter
4611 warning if requested. */
4612 if (sym->attr.dummy && !sym->attr.referenced
4613 && sym->ts.type == BT_CHARACTER
4614 && sym->ts.u.cl->backend_decl != NULL
4615 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4616 {
4617 sym->attr.referenced = 1;
4618 gfc_get_symbol_decl (sym);
4619 }
4620
4621 /* INTENT(out) dummy arguments and result variables with allocatable
4622 components are reset by default and need to be set referenced to
4623 generate the code for nullification and automatic lengths. */
4624 if (!sym->attr.referenced
4625 && sym->ts.type == BT_DERIVED
4626 && sym->ts.u.derived->attr.alloc_comp
4627 && !sym->attr.pointer
4628 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4629 ||
4630 (sym->attr.result && sym != sym->result)))
4631 {
4632 sym->attr.referenced = 1;
4633 gfc_get_symbol_decl (sym);
4634 }
4635
4636 /* Check for dependencies in the array specification and string
4637 length, adding the necessary declarations to the function. We
4638 mark the symbol now, as well as in traverse_ns, to prevent
4639 getting stuck in a circular dependency. */
4640 sym->mark = 1;
4641 }
4642 else if (sym->attr.flavor == FL_PARAMETER)
4643 {
4644 if (warn_unused_parameter
4645 && !sym->attr.referenced)
4646 {
4647 if (!sym->attr.use_assoc)
4648 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4649 &sym->declared_at);
4650 else if (sym->attr.use_only)
4651 gfc_warning ("Unused parameter '%s' which has been explicitly "
4652 "imported at %L", sym->name, &sym->declared_at);
4653 }
4654 }
4655 else if (sym->attr.flavor == FL_PROCEDURE)
4656 {
4657 /* TODO: move to the appropriate place in resolve.c. */
4658 if (warn_return_type
4659 && sym->attr.function
4660 && sym->result
4661 && sym != sym->result
4662 && !sym->result->attr.referenced
4663 && !sym->attr.use_assoc
4664 && sym->attr.if_source != IFSRC_IFBODY)
4665 {
4666 gfc_warning ("Return value '%s' of function '%s' declared at "
4667 "%L not set", sym->result->name, sym->name,
4668 &sym->result->declared_at);
4669
4670 /* Prevents "Unused variable" warning for RESULT variables. */
4671 sym->result->mark = 1;
4672 }
4673 }
4674
4675 if (sym->attr.dummy == 1)
4676 {
4677 /* Modify the tree type for scalar character dummy arguments of bind(c)
4678 procedures if they are passed by value. The tree type for them will
4679 be promoted to INTEGER_TYPE for the middle end, which appears to be
4680 what C would do with characters passed by-value. The value attribute
4681 implies the dummy is a scalar. */
4682 if (sym->attr.value == 1 && sym->backend_decl != NULL
4683 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4684 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4685 gfc_conv_scalar_char_value (sym, NULL, NULL);
4686
4687 /* Unused procedure passed as dummy argument. */
4688 if (sym->attr.flavor == FL_PROCEDURE)
4689 {
4690 if (!sym->attr.referenced)
4691 {
4692 if (gfc_option.warn_unused_dummy_argument)
4693 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4694 &sym->declared_at);
4695 }
4696
4697 /* Silence bogus "unused parameter" warnings from the
4698 middle end. */
4699 if (sym->backend_decl != NULL_TREE)
4700 TREE_NO_WARNING (sym->backend_decl) = 1;
4701 }
4702 }
4703
4704 /* Make sure we convert the types of the derived types from iso_c_binding
4705 into (void *). */
4706 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4707 && sym->ts.type == BT_DERIVED)
4708 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4709 }
4710
4711 static void
4712 generate_local_vars (gfc_namespace * ns)
4713 {
4714 gfc_traverse_ns (ns, generate_local_decl);
4715 }
4716
4717
4718 /* Generate a switch statement to jump to the correct entry point. Also
4719 creates the label decls for the entry points. */
4720
4721 static tree
4722 gfc_trans_entry_master_switch (gfc_entry_list * el)
4723 {
4724 stmtblock_t block;
4725 tree label;
4726 tree tmp;
4727 tree val;
4728
4729 gfc_init_block (&block);
4730 for (; el; el = el->next)
4731 {
4732 /* Add the case label. */
4733 label = gfc_build_label_decl (NULL_TREE);
4734 val = build_int_cst (gfc_array_index_type, el->id);
4735 tmp = build_case_label (val, NULL_TREE, label);
4736 gfc_add_expr_to_block (&block, tmp);
4737
4738 /* And jump to the actual entry point. */
4739 label = gfc_build_label_decl (NULL_TREE);
4740 tmp = build1_v (GOTO_EXPR, label);
4741 gfc_add_expr_to_block (&block, tmp);
4742
4743 /* Save the label decl. */
4744 el->label = label;
4745 }
4746 tmp = gfc_finish_block (&block);
4747 /* The first argument selects the entry point. */
4748 val = DECL_ARGUMENTS (current_function_decl);
4749 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4750 return tmp;
4751 }
4752
4753
4754 /* Add code to string lengths of actual arguments passed to a function against
4755 the expected lengths of the dummy arguments. */
4756
4757 static void
4758 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4759 {
4760 gfc_formal_arglist *formal;
4761
4762 for (formal = sym->formal; formal; formal = formal->next)
4763 if (formal->sym && formal->sym->ts.type == BT_CHARACTER
4764 && !formal->sym->ts.deferred)
4765 {
4766 enum tree_code comparison;
4767 tree cond;
4768 tree argname;
4769 gfc_symbol *fsym;
4770 gfc_charlen *cl;
4771 const char *message;
4772
4773 fsym = formal->sym;
4774 cl = fsym->ts.u.cl;
4775
4776 gcc_assert (cl);
4777 gcc_assert (cl->passed_length != NULL_TREE);
4778 gcc_assert (cl->backend_decl != NULL_TREE);
4779
4780 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4781 string lengths must match exactly. Otherwise, it is only required
4782 that the actual string length is *at least* the expected one.
4783 Sequence association allows for a mismatch of the string length
4784 if the actual argument is (part of) an array, but only if the
4785 dummy argument is an array. (See "Sequence association" in
4786 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4787 if (fsym->attr.pointer || fsym->attr.allocatable
4788 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4789 {
4790 comparison = NE_EXPR;
4791 message = _("Actual string length does not match the declared one"
4792 " for dummy argument '%s' (%ld/%ld)");
4793 }
4794 else if (fsym->as && fsym->as->rank != 0)
4795 continue;
4796 else
4797 {
4798 comparison = LT_EXPR;
4799 message = _("Actual string length is shorter than the declared one"
4800 " for dummy argument '%s' (%ld/%ld)");
4801 }
4802
4803 /* Build the condition. For optional arguments, an actual length
4804 of 0 is also acceptable if the associated string is NULL, which
4805 means the argument was not passed. */
4806 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4807 cl->passed_length, cl->backend_decl);
4808 if (fsym->attr.optional)
4809 {
4810 tree not_absent;
4811 tree not_0length;
4812 tree absent_failed;
4813
4814 not_0length = fold_build2_loc (input_location, NE_EXPR,
4815 boolean_type_node,
4816 cl->passed_length,
4817 build_zero_cst (gfc_charlen_type_node));
4818 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4819 fsym->attr.referenced = 1;
4820 not_absent = gfc_conv_expr_present (fsym);
4821
4822 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4823 boolean_type_node, not_0length,
4824 not_absent);
4825
4826 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4827 boolean_type_node, cond, absent_failed);
4828 }
4829
4830 /* Build the runtime check. */
4831 argname = gfc_build_cstring_const (fsym->name);
4832 argname = gfc_build_addr_expr (pchar_type_node, argname);
4833 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4834 message, argname,
4835 fold_convert (long_integer_type_node,
4836 cl->passed_length),
4837 fold_convert (long_integer_type_node,
4838 cl->backend_decl));
4839 }
4840 }
4841
4842
4843 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
4844 global variables for -fcoarray=lib. They are placed into the translation
4845 unit of the main program. Make sure that in one TU (the one of the main
4846 program), the first call to gfc_init_coarray_decl is done with true.
4847 Otherwise, expect link errors. */
4848
4849 void
4850 gfc_init_coarray_decl (bool main_tu)
4851 {
4852 tree save_fn_decl;
4853
4854 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
4855 return;
4856
4857 if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
4858 return;
4859
4860 save_fn_decl = current_function_decl;
4861 current_function_decl = NULL_TREE;
4862 push_cfun (cfun);
4863
4864 gfort_gvar_caf_this_image
4865 = build_decl (input_location, VAR_DECL,
4866 get_identifier (PREFIX("caf_this_image")),
4867 integer_type_node);
4868 DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
4869 TREE_USED (gfort_gvar_caf_this_image) = 1;
4870 TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
4871 TREE_READONLY (gfort_gvar_caf_this_image) = 0;
4872
4873 if (main_tu)
4874 TREE_STATIC (gfort_gvar_caf_this_image) = 1;
4875 else
4876 DECL_EXTERNAL (gfort_gvar_caf_this_image) = 1;
4877
4878 pushdecl_top_level (gfort_gvar_caf_this_image);
4879
4880 gfort_gvar_caf_num_images
4881 = build_decl (input_location, VAR_DECL,
4882 get_identifier (PREFIX("caf_num_images")),
4883 integer_type_node);
4884 DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
4885 TREE_USED (gfort_gvar_caf_num_images) = 1;
4886 TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
4887 TREE_READONLY (gfort_gvar_caf_num_images) = 0;
4888
4889 if (main_tu)
4890 TREE_STATIC (gfort_gvar_caf_num_images) = 1;
4891 else
4892 DECL_EXTERNAL (gfort_gvar_caf_num_images) = 1;
4893
4894 pushdecl_top_level (gfort_gvar_caf_num_images);
4895
4896 pop_cfun ();
4897 current_function_decl = save_fn_decl;
4898 }
4899
4900
4901 static void
4902 create_main_function (tree fndecl)
4903 {
4904 tree old_context;
4905 tree ftn_main;
4906 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4907 stmtblock_t body;
4908
4909 old_context = current_function_decl;
4910
4911 if (old_context)
4912 {
4913 push_function_context ();
4914 saved_parent_function_decls = saved_function_decls;
4915 saved_function_decls = NULL_TREE;
4916 }
4917
4918 /* main() function must be declared with global scope. */
4919 gcc_assert (current_function_decl == NULL_TREE);
4920
4921 /* Declare the function. */
4922 tmp = build_function_type_list (integer_type_node, integer_type_node,
4923 build_pointer_type (pchar_type_node),
4924 NULL_TREE);
4925 main_identifier_node = get_identifier ("main");
4926 ftn_main = build_decl (input_location, FUNCTION_DECL,
4927 main_identifier_node, tmp);
4928 DECL_EXTERNAL (ftn_main) = 0;
4929 TREE_PUBLIC (ftn_main) = 1;
4930 TREE_STATIC (ftn_main) = 1;
4931 DECL_ATTRIBUTES (ftn_main)
4932 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4933
4934 /* Setup the result declaration (for "return 0"). */
4935 result_decl = build_decl (input_location,
4936 RESULT_DECL, NULL_TREE, integer_type_node);
4937 DECL_ARTIFICIAL (result_decl) = 1;
4938 DECL_IGNORED_P (result_decl) = 1;
4939 DECL_CONTEXT (result_decl) = ftn_main;
4940 DECL_RESULT (ftn_main) = result_decl;
4941
4942 pushdecl (ftn_main);
4943
4944 /* Get the arguments. */
4945
4946 arglist = NULL_TREE;
4947 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4948
4949 tmp = TREE_VALUE (typelist);
4950 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4951 DECL_CONTEXT (argc) = ftn_main;
4952 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4953 TREE_READONLY (argc) = 1;
4954 gfc_finish_decl (argc);
4955 arglist = chainon (arglist, argc);
4956
4957 typelist = TREE_CHAIN (typelist);
4958 tmp = TREE_VALUE (typelist);
4959 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4960 DECL_CONTEXT (argv) = ftn_main;
4961 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4962 TREE_READONLY (argv) = 1;
4963 DECL_BY_REFERENCE (argv) = 1;
4964 gfc_finish_decl (argv);
4965 arglist = chainon (arglist, argv);
4966
4967 DECL_ARGUMENTS (ftn_main) = arglist;
4968 current_function_decl = ftn_main;
4969 announce_function (ftn_main);
4970
4971 rest_of_decl_compilation (ftn_main, 1, 0);
4972 make_decl_rtl (ftn_main);
4973 init_function_start (ftn_main);
4974 pushlevel (0);
4975
4976 gfc_init_block (&body);
4977
4978 /* Call some libgfortran initialization routines, call then MAIN__(). */
4979
4980 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
4981 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4982 {
4983 tree pint_type, pppchar_type;
4984 pint_type = build_pointer_type (integer_type_node);
4985 pppchar_type
4986 = build_pointer_type (build_pointer_type (pchar_type_node));
4987
4988 gfc_init_coarray_decl (true);
4989 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
4990 gfc_build_addr_expr (pint_type, argc),
4991 gfc_build_addr_expr (pppchar_type, argv),
4992 gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
4993 gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
4994 gfc_add_expr_to_block (&body, tmp);
4995 }
4996
4997 /* Call _gfortran_set_args (argc, argv). */
4998 TREE_USED (argc) = 1;
4999 TREE_USED (argv) = 1;
5000 tmp = build_call_expr_loc (input_location,
5001 gfor_fndecl_set_args, 2, argc, argv);
5002 gfc_add_expr_to_block (&body, tmp);
5003
5004 /* Add a call to set_options to set up the runtime library Fortran
5005 language standard parameters. */
5006 {
5007 tree array_type, array, var;
5008 VEC(constructor_elt,gc) *v = NULL;
5009
5010 /* Passing a new option to the library requires four modifications:
5011 + add it to the tree_cons list below
5012 + change the array size in the call to build_array_type
5013 + change the first argument to the library call
5014 gfor_fndecl_set_options
5015 + modify the library (runtime/compile_options.c)! */
5016
5017 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5018 build_int_cst (integer_type_node,
5019 gfc_option.warn_std));
5020 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5021 build_int_cst (integer_type_node,
5022 gfc_option.allow_std));
5023 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5024 build_int_cst (integer_type_node, pedantic));
5025 /* TODO: This is the old -fdump-core option, which is unused but
5026 passed due to ABI compatibility; remove when bumping the
5027 library ABI. */
5028 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5029 build_int_cst (integer_type_node,
5030 0));
5031 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5032 build_int_cst (integer_type_node,
5033 gfc_option.flag_backtrace));
5034 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5035 build_int_cst (integer_type_node,
5036 gfc_option.flag_sign_zero));
5037 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5038 build_int_cst (integer_type_node,
5039 (gfc_option.rtcheck
5040 & GFC_RTCHECK_BOUNDS)));
5041 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5042 build_int_cst (integer_type_node,
5043 gfc_option.flag_range_check));
5044
5045 array_type = build_array_type (integer_type_node,
5046 build_index_type (size_int (7)));
5047 array = build_constructor (array_type, v);
5048 TREE_CONSTANT (array) = 1;
5049 TREE_STATIC (array) = 1;
5050
5051 /* Create a static variable to hold the jump table. */
5052 var = gfc_create_var (array_type, "options");
5053 TREE_CONSTANT (var) = 1;
5054 TREE_STATIC (var) = 1;
5055 TREE_READONLY (var) = 1;
5056 DECL_INITIAL (var) = array;
5057 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
5058
5059 tmp = build_call_expr_loc (input_location,
5060 gfor_fndecl_set_options, 2,
5061 build_int_cst (integer_type_node, 8), var);
5062 gfc_add_expr_to_block (&body, tmp);
5063 }
5064
5065 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5066 the library will raise a FPE when needed. */
5067 if (gfc_option.fpe != 0)
5068 {
5069 tmp = build_call_expr_loc (input_location,
5070 gfor_fndecl_set_fpe, 1,
5071 build_int_cst (integer_type_node,
5072 gfc_option.fpe));
5073 gfc_add_expr_to_block (&body, tmp);
5074 }
5075
5076 /* If this is the main program and an -fconvert option was provided,
5077 add a call to set_convert. */
5078
5079 if (gfc_option.convert != GFC_CONVERT_NATIVE)
5080 {
5081 tmp = build_call_expr_loc (input_location,
5082 gfor_fndecl_set_convert, 1,
5083 build_int_cst (integer_type_node,
5084 gfc_option.convert));
5085 gfc_add_expr_to_block (&body, tmp);
5086 }
5087
5088 /* If this is the main program and an -frecord-marker option was provided,
5089 add a call to set_record_marker. */
5090
5091 if (gfc_option.record_marker != 0)
5092 {
5093 tmp = build_call_expr_loc (input_location,
5094 gfor_fndecl_set_record_marker, 1,
5095 build_int_cst (integer_type_node,
5096 gfc_option.record_marker));
5097 gfc_add_expr_to_block (&body, tmp);
5098 }
5099
5100 if (gfc_option.max_subrecord_length != 0)
5101 {
5102 tmp = build_call_expr_loc (input_location,
5103 gfor_fndecl_set_max_subrecord_length, 1,
5104 build_int_cst (integer_type_node,
5105 gfc_option.max_subrecord_length));
5106 gfc_add_expr_to_block (&body, tmp);
5107 }
5108
5109 /* Call MAIN__(). */
5110 tmp = build_call_expr_loc (input_location,
5111 fndecl, 0);
5112 gfc_add_expr_to_block (&body, tmp);
5113
5114 /* Mark MAIN__ as used. */
5115 TREE_USED (fndecl) = 1;
5116
5117 /* Coarray: Call _gfortran_caf_finalize(void). */
5118 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
5119 {
5120 /* Per F2008, 8.5.1 END of the main program implies a
5121 SYNC MEMORY. */
5122 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
5123 tmp = build_call_expr_loc (input_location, tmp, 0);
5124 gfc_add_expr_to_block (&body, tmp);
5125
5126 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
5127 gfc_add_expr_to_block (&body, tmp);
5128 }
5129
5130 /* "return 0". */
5131 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
5132 DECL_RESULT (ftn_main),
5133 build_int_cst (integer_type_node, 0));
5134 tmp = build1_v (RETURN_EXPR, tmp);
5135 gfc_add_expr_to_block (&body, tmp);
5136
5137
5138 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
5139 decl = getdecls ();
5140
5141 /* Finish off this function and send it for code generation. */
5142 poplevel (1, 0, 1);
5143 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
5144
5145 DECL_SAVED_TREE (ftn_main)
5146 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
5147 DECL_INITIAL (ftn_main));
5148
5149 /* Output the GENERIC tree. */
5150 dump_function (TDI_original, ftn_main);
5151
5152 cgraph_finalize_function (ftn_main, true);
5153
5154 if (old_context)
5155 {
5156 pop_function_context ();
5157 saved_function_decls = saved_parent_function_decls;
5158 }
5159 current_function_decl = old_context;
5160 }
5161
5162
5163 /* Get the result expression for a procedure. */
5164
5165 static tree
5166 get_proc_result (gfc_symbol* sym)
5167 {
5168 if (sym->attr.subroutine || sym == sym->result)
5169 {
5170 if (current_fake_result_decl != NULL)
5171 return TREE_VALUE (current_fake_result_decl);
5172
5173 return NULL_TREE;
5174 }
5175
5176 return sym->result->backend_decl;
5177 }
5178
5179
5180 /* Generate an appropriate return-statement for a procedure. */
5181
5182 tree
5183 gfc_generate_return (void)
5184 {
5185 gfc_symbol* sym;
5186 tree result;
5187 tree fndecl;
5188
5189 sym = current_procedure_symbol;
5190 fndecl = sym->backend_decl;
5191
5192 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
5193 result = NULL_TREE;
5194 else
5195 {
5196 result = get_proc_result (sym);
5197
5198 /* Set the return value to the dummy result variable. The
5199 types may be different for scalar default REAL functions
5200 with -ff2c, therefore we have to convert. */
5201 if (result != NULL_TREE)
5202 {
5203 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
5204 result = fold_build2_loc (input_location, MODIFY_EXPR,
5205 TREE_TYPE (result), DECL_RESULT (fndecl),
5206 result);
5207 }
5208 }
5209
5210 return build1_v (RETURN_EXPR, result);
5211 }
5212
5213
5214 /* Generate code for a function. */
5215
5216 void
5217 gfc_generate_function_code (gfc_namespace * ns)
5218 {
5219 tree fndecl;
5220 tree old_context;
5221 tree decl;
5222 tree tmp;
5223 stmtblock_t init, cleanup;
5224 stmtblock_t body;
5225 gfc_wrapped_block try_block;
5226 tree recurcheckvar = NULL_TREE;
5227 gfc_symbol *sym;
5228 gfc_symbol *previous_procedure_symbol;
5229 int rank;
5230 bool is_recursive;
5231
5232 sym = ns->proc_name;
5233 previous_procedure_symbol = current_procedure_symbol;
5234 current_procedure_symbol = sym;
5235
5236 /* Check that the frontend isn't still using this. */
5237 gcc_assert (sym->tlink == NULL);
5238 sym->tlink = sym;
5239
5240 /* Create the declaration for functions with global scope. */
5241 if (!sym->backend_decl)
5242 gfc_create_function_decl (ns, false);
5243
5244 fndecl = sym->backend_decl;
5245 old_context = current_function_decl;
5246
5247 if (old_context)
5248 {
5249 push_function_context ();
5250 saved_parent_function_decls = saved_function_decls;
5251 saved_function_decls = NULL_TREE;
5252 }
5253
5254 trans_function_start (sym);
5255
5256 gfc_init_block (&init);
5257
5258 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
5259 {
5260 /* Copy length backend_decls to all entry point result
5261 symbols. */
5262 gfc_entry_list *el;
5263 tree backend_decl;
5264
5265 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
5266 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
5267 for (el = ns->entries; el; el = el->next)
5268 el->sym->result->ts.u.cl->backend_decl = backend_decl;
5269 }
5270
5271 /* Translate COMMON blocks. */
5272 gfc_trans_common (ns);
5273
5274 /* Null the parent fake result declaration if this namespace is
5275 a module function or an external procedures. */
5276 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5277 || ns->parent == NULL)
5278 parent_fake_result_decl = NULL_TREE;
5279
5280 gfc_generate_contained_functions (ns);
5281
5282 nonlocal_dummy_decls = NULL;
5283 nonlocal_dummy_decl_pset = NULL;
5284
5285 has_coarray_vars = false;
5286 generate_local_vars (ns);
5287
5288 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5289 generate_coarray_init (ns);
5290
5291 /* Keep the parent fake result declaration in module functions
5292 or external procedures. */
5293 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5294 || ns->parent == NULL)
5295 current_fake_result_decl = parent_fake_result_decl;
5296 else
5297 current_fake_result_decl = NULL_TREE;
5298
5299 is_recursive = sym->attr.recursive
5300 || (sym->attr.entry_master
5301 && sym->ns->entries->sym->attr.recursive);
5302 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5303 && !is_recursive
5304 && !gfc_option.flag_recursive)
5305 {
5306 char * msg;
5307
5308 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
5309 sym->name);
5310 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
5311 TREE_STATIC (recurcheckvar) = 1;
5312 DECL_INITIAL (recurcheckvar) = boolean_false_node;
5313 gfc_add_expr_to_block (&init, recurcheckvar);
5314 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
5315 &sym->declared_at, msg);
5316 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
5317 free (msg);
5318 }
5319
5320 /* Now generate the code for the body of this function. */
5321 gfc_init_block (&body);
5322
5323 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
5324 && sym->attr.subroutine)
5325 {
5326 tree alternate_return;
5327 alternate_return = gfc_get_fake_result_decl (sym, 0);
5328 gfc_add_modify (&body, alternate_return, integer_zero_node);
5329 }
5330
5331 if (ns->entries)
5332 {
5333 /* Jump to the correct entry point. */
5334 tmp = gfc_trans_entry_master_switch (ns->entries);
5335 gfc_add_expr_to_block (&body, tmp);
5336 }
5337
5338 /* If bounds-checking is enabled, generate code to check passed in actual
5339 arguments against the expected dummy argument attributes (e.g. string
5340 lengths). */
5341 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
5342 add_argument_checking (&body, sym);
5343
5344 tmp = gfc_trans_code (ns->code);
5345 gfc_add_expr_to_block (&body, tmp);
5346
5347 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
5348 {
5349 tree result = get_proc_result (sym);
5350
5351 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
5352 {
5353 if (sym->attr.allocatable && sym->attr.dimension == 0
5354 && sym->result == sym)
5355 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
5356 null_pointer_node));
5357 else if (sym->ts.type == BT_CLASS
5358 && CLASS_DATA (sym)->attr.allocatable
5359 && CLASS_DATA (sym)->attr.dimension == 0
5360 && sym->result == sym)
5361 {
5362 tmp = CLASS_DATA (sym)->backend_decl;
5363 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5364 TREE_TYPE (tmp), result, tmp, NULL_TREE);
5365 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
5366 null_pointer_node));
5367 }
5368 else if (sym->ts.type == BT_DERIVED
5369 && sym->ts.u.derived->attr.alloc_comp
5370 && !sym->attr.allocatable)
5371 {
5372 rank = sym->as ? sym->as->rank : 0;
5373 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
5374 gfc_add_expr_to_block (&init, tmp);
5375 }
5376 }
5377
5378 if (result == NULL_TREE)
5379 {
5380 /* TODO: move to the appropriate place in resolve.c. */
5381 if (warn_return_type && sym == sym->result)
5382 gfc_warning ("Return value of function '%s' at %L not set",
5383 sym->name, &sym->declared_at);
5384 if (warn_return_type)
5385 TREE_NO_WARNING(sym->backend_decl) = 1;
5386 }
5387 else
5388 gfc_add_expr_to_block (&body, gfc_generate_return ());
5389 }
5390
5391 gfc_init_block (&cleanup);
5392
5393 /* Reset recursion-check variable. */
5394 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5395 && !is_recursive
5396 && !gfc_option.gfc_flag_openmp
5397 && recurcheckvar != NULL_TREE)
5398 {
5399 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
5400 recurcheckvar = NULL;
5401 }
5402
5403 /* Finish the function body and add init and cleanup code. */
5404 tmp = gfc_finish_block (&body);
5405 gfc_start_wrapped_block (&try_block, tmp);
5406 /* Add code to create and cleanup arrays. */
5407 gfc_trans_deferred_vars (sym, &try_block);
5408 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
5409 gfc_finish_block (&cleanup));
5410
5411 /* Add all the decls we created during processing. */
5412 decl = saved_function_decls;
5413 while (decl)
5414 {
5415 tree next;
5416
5417 next = DECL_CHAIN (decl);
5418 DECL_CHAIN (decl) = NULL_TREE;
5419 if (GFC_DECL_PUSH_TOPLEVEL (decl))
5420 pushdecl_top_level (decl);
5421 else
5422 pushdecl (decl);
5423 decl = next;
5424 }
5425 saved_function_decls = NULL_TREE;
5426
5427 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
5428 decl = getdecls ();
5429
5430 /* Finish off this function and send it for code generation. */
5431 poplevel (1, 0, 1);
5432 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5433
5434 DECL_SAVED_TREE (fndecl)
5435 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5436 DECL_INITIAL (fndecl));
5437
5438 if (nonlocal_dummy_decls)
5439 {
5440 BLOCK_VARS (DECL_INITIAL (fndecl))
5441 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5442 pointer_set_destroy (nonlocal_dummy_decl_pset);
5443 nonlocal_dummy_decls = NULL;
5444 nonlocal_dummy_decl_pset = NULL;
5445 }
5446
5447 /* Output the GENERIC tree. */
5448 dump_function (TDI_original, fndecl);
5449
5450 /* Store the end of the function, so that we get good line number
5451 info for the epilogue. */
5452 cfun->function_end_locus = input_location;
5453
5454 /* We're leaving the context of this function, so zap cfun.
5455 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5456 tree_rest_of_compilation. */
5457 set_cfun (NULL);
5458
5459 if (old_context)
5460 {
5461 pop_function_context ();
5462 saved_function_decls = saved_parent_function_decls;
5463 }
5464 current_function_decl = old_context;
5465
5466 if (decl_function_context (fndecl) && !gfc_option.coarray == GFC_FCOARRAY_LIB
5467 && has_coarray_vars)
5468 /* Register this function with cgraph just far enough to get it
5469 added to our parent's nested function list.
5470 If there are static coarrays in this function, the nested _caf_init
5471 function has already called cgraph_create_node, which also created
5472 the cgraph node for this function. */
5473 (void) cgraph_create_node (fndecl);
5474 else
5475 cgraph_finalize_function (fndecl, true);
5476
5477 gfc_trans_use_stmts (ns);
5478 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5479
5480 if (sym->attr.is_main_program)
5481 create_main_function (fndecl);
5482
5483 current_procedure_symbol = previous_procedure_symbol;
5484 }
5485
5486
5487 void
5488 gfc_generate_constructors (void)
5489 {
5490 gcc_assert (gfc_static_ctors == NULL_TREE);
5491 #if 0
5492 tree fnname;
5493 tree type;
5494 tree fndecl;
5495 tree decl;
5496 tree tmp;
5497
5498 if (gfc_static_ctors == NULL_TREE)
5499 return;
5500
5501 fnname = get_file_function_name ("I");
5502 type = build_function_type_list (void_type_node, NULL_TREE);
5503
5504 fndecl = build_decl (input_location,
5505 FUNCTION_DECL, fnname, type);
5506 TREE_PUBLIC (fndecl) = 1;
5507
5508 decl = build_decl (input_location,
5509 RESULT_DECL, NULL_TREE, void_type_node);
5510 DECL_ARTIFICIAL (decl) = 1;
5511 DECL_IGNORED_P (decl) = 1;
5512 DECL_CONTEXT (decl) = fndecl;
5513 DECL_RESULT (fndecl) = decl;
5514
5515 pushdecl (fndecl);
5516
5517 current_function_decl = fndecl;
5518
5519 rest_of_decl_compilation (fndecl, 1, 0);
5520
5521 make_decl_rtl (fndecl);
5522
5523 init_function_start (fndecl);
5524
5525 pushlevel (0);
5526
5527 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5528 {
5529 tmp = build_call_expr_loc (input_location,
5530 TREE_VALUE (gfc_static_ctors), 0);
5531 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
5532 }
5533
5534 decl = getdecls ();
5535 poplevel (1, 0, 1);
5536
5537 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5538 DECL_SAVED_TREE (fndecl)
5539 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5540 DECL_INITIAL (fndecl));
5541
5542 free_after_parsing (cfun);
5543 free_after_compilation (cfun);
5544
5545 tree_rest_of_compilation (fndecl);
5546
5547 current_function_decl = NULL_TREE;
5548 #endif
5549 }
5550
5551 /* Translates a BLOCK DATA program unit. This means emitting the
5552 commons contained therein plus their initializations. We also emit
5553 a globally visible symbol to make sure that each BLOCK DATA program
5554 unit remains unique. */
5555
5556 void
5557 gfc_generate_block_data (gfc_namespace * ns)
5558 {
5559 tree decl;
5560 tree id;
5561
5562 /* Tell the backend the source location of the block data. */
5563 if (ns->proc_name)
5564 gfc_set_backend_locus (&ns->proc_name->declared_at);
5565 else
5566 gfc_set_backend_locus (&gfc_current_locus);
5567
5568 /* Process the DATA statements. */
5569 gfc_trans_common (ns);
5570
5571 /* Create a global symbol with the mane of the block data. This is to
5572 generate linker errors if the same name is used twice. It is never
5573 really used. */
5574 if (ns->proc_name)
5575 id = gfc_sym_mangled_function_id (ns->proc_name);
5576 else
5577 id = get_identifier ("__BLOCK_DATA__");
5578
5579 decl = build_decl (input_location,
5580 VAR_DECL, id, gfc_array_index_type);
5581 TREE_PUBLIC (decl) = 1;
5582 TREE_STATIC (decl) = 1;
5583 DECL_IGNORED_P (decl) = 1;
5584
5585 pushdecl (decl);
5586 rest_of_decl_compilation (decl, 1, 0);
5587 }
5588
5589
5590 /* Process the local variables of a BLOCK construct. */
5591
5592 void
5593 gfc_process_block_locals (gfc_namespace* ns)
5594 {
5595 tree decl;
5596
5597 gcc_assert (saved_local_decls == NULL_TREE);
5598 has_coarray_vars = false;
5599
5600 generate_local_vars (ns);
5601
5602 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5603 generate_coarray_init (ns);
5604
5605 decl = saved_local_decls;
5606 while (decl)
5607 {
5608 tree next;
5609
5610 next = DECL_CHAIN (decl);
5611 DECL_CHAIN (decl) = NULL_TREE;
5612 pushdecl (decl);
5613 decl = next;
5614 }
5615 saved_local_decls = NULL_TREE;
5616 }
5617
5618
5619 #include "gt-fortran-trans-decl.h"