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