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