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