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