?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2010-04-29 Janus Weil <janus@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-decl.c
blob2ad4e737259bf5fbae45d8e1cf3e4d81ad8134e2
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 /* Make sure that the vtab for the declared type is completed. */
1074 if (sym->ts.type == BT_CLASS)
1075 {
1076 gfc_component *c = gfc_find_component (sym->ts.u.derived,
1077 "$data", true, true);
1078 if (!c->ts.u.derived->backend_decl)
1079 gfc_find_derived_vtab (c->ts.u.derived, true);
1080 }
1081
1082 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1083 {
1084 /* Return via extra parameter. */
1085 if (sym->attr.result && byref
1086 && !sym->backend_decl)
1087 {
1088 sym->backend_decl =
1089 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1090 /* For entry master function skip over the __entry
1091 argument. */
1092 if (sym->ns->proc_name->attr.entry_master)
1093 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
1094 }
1095
1096 /* Dummy variables should already have been created. */
1097 gcc_assert (sym->backend_decl);
1098
1099 /* Create a character length variable. */
1100 if (sym->ts.type == BT_CHARACTER)
1101 {
1102 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1103 length = gfc_create_string_length (sym);
1104 else
1105 length = sym->ts.u.cl->backend_decl;
1106 if (TREE_CODE (length) == VAR_DECL
1107 && DECL_CONTEXT (length) == NULL_TREE)
1108 {
1109 /* Add the string length to the same context as the symbol. */
1110 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1111 gfc_add_decl_to_function (length);
1112 else
1113 gfc_add_decl_to_parent_function (length);
1114
1115 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1116 DECL_CONTEXT (length));
1117
1118 gfc_defer_symbol_init (sym);
1119 }
1120 }
1121
1122 /* Use a copy of the descriptor for dummy arrays. */
1123 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1124 {
1125 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1126 /* Prevent the dummy from being detected as unused if it is copied. */
1127 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1128 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1129 sym->backend_decl = decl;
1130 }
1131
1132 TREE_USED (sym->backend_decl) = 1;
1133 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1134 {
1135 gfc_add_assign_aux_vars (sym);
1136 }
1137
1138 if (sym->attr.dimension
1139 && DECL_LANG_SPECIFIC (sym->backend_decl)
1140 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1141 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1142 gfc_nonlocal_dummy_array_decl (sym);
1143
1144 return sym->backend_decl;
1145 }
1146
1147 if (sym->backend_decl)
1148 return sym->backend_decl;
1149
1150 /* If use associated and whole file compilation, use the module
1151 declaration. This is only needed for intrinsic types because
1152 they are substituted for one another during optimization. */
1153 if (gfc_option.flag_whole_file
1154 && sym->attr.flavor == FL_VARIABLE
1155 && sym->ts.type != BT_DERIVED
1156 && sym->attr.use_assoc
1157 && sym->module)
1158 {
1159 gfc_gsymbol *gsym;
1160
1161 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1162 if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1163 {
1164 gfc_symbol *s;
1165 s = NULL;
1166 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1167 if (s && s->backend_decl)
1168 {
1169 if (sym->ts.type == BT_CHARACTER)
1170 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1171 return s->backend_decl;
1172 }
1173 }
1174 }
1175
1176 /* Catch function declarations. Only used for actual parameters and
1177 procedure pointers. */
1178 if (sym->attr.flavor == FL_PROCEDURE)
1179 {
1180 decl = gfc_get_extern_function_decl (sym);
1181 gfc_set_decl_location (decl, &sym->declared_at);
1182 return decl;
1183 }
1184
1185 if (sym->attr.intrinsic)
1186 internal_error ("intrinsic variable which isn't a procedure");
1187
1188 /* Create string length decl first so that they can be used in the
1189 type declaration. */
1190 if (sym->ts.type == BT_CHARACTER)
1191 length = gfc_create_string_length (sym);
1192
1193 /* Create the decl for the variable. */
1194 decl = build_decl (sym->declared_at.lb->location,
1195 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1196
1197 /* Add attributes to variables. Functions are handled elsewhere. */
1198 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1199 decl_attributes (&decl, attributes, 0);
1200
1201 /* Symbols from modules should have their assembler names mangled.
1202 This is done here rather than in gfc_finish_var_decl because it
1203 is different for string length variables. */
1204 if (sym->module)
1205 {
1206 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1207 if (sym->attr.use_assoc)
1208 DECL_IGNORED_P (decl) = 1;
1209 }
1210
1211 if (sym->attr.dimension)
1212 {
1213 /* Create variables to hold the non-constant bits of array info. */
1214 gfc_build_qualified_array (decl, sym);
1215
1216 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1217 GFC_DECL_PACKED_ARRAY (decl) = 1;
1218 }
1219
1220 /* Remember this variable for allocation/cleanup. */
1221 if (sym->attr.dimension || sym->attr.allocatable
1222 || (sym->ts.type == BT_CLASS &&
1223 (sym->ts.u.derived->components->attr.dimension
1224 || sym->ts.u.derived->components->attr.allocatable))
1225 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1226 /* This applies a derived type default initializer. */
1227 || (sym->ts.type == BT_DERIVED
1228 && sym->attr.save == SAVE_NONE
1229 && !sym->attr.data
1230 && !sym->attr.allocatable
1231 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1232 && !sym->attr.use_assoc))
1233 gfc_defer_symbol_init (sym);
1234
1235 gfc_finish_var_decl (decl, sym);
1236
1237 if (sym->ts.type == BT_CHARACTER)
1238 {
1239 /* Character variables need special handling. */
1240 gfc_allocate_lang_decl (decl);
1241
1242 if (TREE_CODE (length) != INTEGER_CST)
1243 {
1244 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1245
1246 if (sym->module)
1247 {
1248 /* Also prefix the mangled name for symbols from modules. */
1249 strcpy (&name[1], sym->name);
1250 name[0] = '.';
1251 strcpy (&name[1],
1252 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1253 gfc_set_decl_assembler_name (decl, get_identifier (name));
1254 }
1255 gfc_finish_var_decl (length, sym);
1256 gcc_assert (!sym->value);
1257 }
1258 }
1259 else if (sym->attr.subref_array_pointer)
1260 {
1261 /* We need the span for these beasts. */
1262 gfc_allocate_lang_decl (decl);
1263 }
1264
1265 if (sym->attr.subref_array_pointer)
1266 {
1267 tree span;
1268 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1269 span = build_decl (input_location,
1270 VAR_DECL, create_tmp_var_name ("span"),
1271 gfc_array_index_type);
1272 gfc_finish_var_decl (span, sym);
1273 TREE_STATIC (span) = TREE_STATIC (decl);
1274 DECL_ARTIFICIAL (span) = 1;
1275 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1276
1277 GFC_DECL_SPAN (decl) = span;
1278 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1279 }
1280
1281 sym->backend_decl = decl;
1282
1283 if (sym->attr.assign)
1284 gfc_add_assign_aux_vars (sym);
1285
1286 if (TREE_STATIC (decl) && !sym->attr.use_assoc
1287 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1288 || gfc_option.flag_max_stack_var_size == 0
1289 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
1290 {
1291 /* Add static initializer. For procedures, it is only needed if
1292 SAVE is specified otherwise they need to be reinitialized
1293 every time the procedure is entered. The TREE_STATIC is
1294 in this case due to -fmax-stack-var-size=. */
1295 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1296 TREE_TYPE (decl), sym->attr.dimension,
1297 sym->attr.pointer || sym->attr.allocatable);
1298 }
1299
1300 if (!TREE_STATIC (decl)
1301 && POINTER_TYPE_P (TREE_TYPE (decl))
1302 && !sym->attr.pointer
1303 && !sym->attr.allocatable
1304 && !sym->attr.proc_pointer)
1305 DECL_BY_REFERENCE (decl) = 1;
1306
1307 return decl;
1308 }
1309
1310
1311 /* Substitute a temporary variable in place of the real one. */
1312
1313 void
1314 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1315 {
1316 save->attr = sym->attr;
1317 save->decl = sym->backend_decl;
1318
1319 gfc_clear_attr (&sym->attr);
1320 sym->attr.referenced = 1;
1321 sym->attr.flavor = FL_VARIABLE;
1322
1323 sym->backend_decl = decl;
1324 }
1325
1326
1327 /* Restore the original variable. */
1328
1329 void
1330 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1331 {
1332 sym->attr = save->attr;
1333 sym->backend_decl = save->decl;
1334 }
1335
1336
1337 /* Declare a procedure pointer. */
1338
1339 static tree
1340 get_proc_pointer_decl (gfc_symbol *sym)
1341 {
1342 tree decl;
1343 tree attributes;
1344
1345 decl = sym->backend_decl;
1346 if (decl)
1347 return decl;
1348
1349 decl = build_decl (input_location,
1350 VAR_DECL, get_identifier (sym->name),
1351 build_pointer_type (gfc_get_function_type (sym)));
1352
1353 if ((sym->ns->proc_name
1354 && sym->ns->proc_name->backend_decl == current_function_decl)
1355 || sym->attr.contained)
1356 gfc_add_decl_to_function (decl);
1357 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1358 gfc_add_decl_to_parent_function (decl);
1359
1360 sym->backend_decl = decl;
1361
1362 /* If a variable is USE associated, it's always external. */
1363 if (sym->attr.use_assoc)
1364 {
1365 DECL_EXTERNAL (decl) = 1;
1366 TREE_PUBLIC (decl) = 1;
1367 }
1368 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1369 {
1370 /* This is the declaration of a module variable. */
1371 TREE_PUBLIC (decl) = 1;
1372 TREE_STATIC (decl) = 1;
1373 }
1374
1375 if (!sym->attr.use_assoc
1376 && (sym->attr.save != SAVE_NONE || sym->attr.data
1377 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1378 TREE_STATIC (decl) = 1;
1379
1380 if (TREE_STATIC (decl) && sym->value)
1381 {
1382 /* Add static initializer. */
1383 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1384 TREE_TYPE (decl),
1385 sym->attr.proc_pointer ? false : sym->attr.dimension,
1386 sym->attr.proc_pointer);
1387 }
1388
1389 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1390 decl_attributes (&decl, attributes, 0);
1391
1392 return decl;
1393 }
1394
1395
1396 /* Get a basic decl for an external function. */
1397
1398 tree
1399 gfc_get_extern_function_decl (gfc_symbol * sym)
1400 {
1401 tree type;
1402 tree fndecl;
1403 tree attributes;
1404 gfc_expr e;
1405 gfc_intrinsic_sym *isym;
1406 gfc_expr argexpr;
1407 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1408 tree name;
1409 tree mangled_name;
1410 gfc_gsymbol *gsym;
1411
1412 if (sym->backend_decl)
1413 return sym->backend_decl;
1414
1415 /* We should never be creating external decls for alternate entry points.
1416 The procedure may be an alternate entry point, but we don't want/need
1417 to know that. */
1418 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1419
1420 if (sym->attr.proc_pointer)
1421 return get_proc_pointer_decl (sym);
1422
1423 /* See if this is an external procedure from the same file. If so,
1424 return the backend_decl. */
1425 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1426
1427 if (gfc_option.flag_whole_file
1428 && !sym->attr.use_assoc
1429 && !sym->backend_decl
1430 && gsym && gsym->ns
1431 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1432 && gsym->ns->proc_name->backend_decl)
1433 {
1434 /* If the namespace has entries, the proc_name is the
1435 entry master. Find the entry and use its backend_decl.
1436 otherwise, use the proc_name backend_decl. */
1437 if (gsym->ns->entries)
1438 {
1439 gfc_entry_list *entry = gsym->ns->entries;
1440
1441 for (; entry; entry = entry->next)
1442 {
1443 if (strcmp (gsym->name, entry->sym->name) == 0)
1444 {
1445 sym->backend_decl = entry->sym->backend_decl;
1446 break;
1447 }
1448 }
1449 }
1450 else
1451 {
1452 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1453 }
1454
1455 if (sym->backend_decl)
1456 return sym->backend_decl;
1457 }
1458
1459 /* See if this is a module procedure from the same file. If so,
1460 return the backend_decl. */
1461 if (sym->module)
1462 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1463
1464 if (gfc_option.flag_whole_file
1465 && gsym && gsym->ns
1466 && gsym->type == GSYM_MODULE)
1467 {
1468 gfc_symbol *s;
1469
1470 s = NULL;
1471 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1472 if (s && s->backend_decl)
1473 {
1474 sym->backend_decl = s->backend_decl;
1475 return sym->backend_decl;
1476 }
1477 }
1478
1479 if (sym->attr.intrinsic)
1480 {
1481 /* Call the resolution function to get the actual name. This is
1482 a nasty hack which relies on the resolution functions only looking
1483 at the first argument. We pass NULL for the second argument
1484 otherwise things like AINT get confused. */
1485 isym = gfc_find_function (sym->name);
1486 gcc_assert (isym->resolve.f0 != NULL);
1487
1488 memset (&e, 0, sizeof (e));
1489 e.expr_type = EXPR_FUNCTION;
1490
1491 memset (&argexpr, 0, sizeof (argexpr));
1492 gcc_assert (isym->formal);
1493 argexpr.ts = isym->formal->ts;
1494
1495 if (isym->formal->next == NULL)
1496 isym->resolve.f1 (&e, &argexpr);
1497 else
1498 {
1499 if (isym->formal->next->next == NULL)
1500 isym->resolve.f2 (&e, &argexpr, NULL);
1501 else
1502 {
1503 if (isym->formal->next->next->next == NULL)
1504 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1505 else
1506 {
1507 /* All specific intrinsics take less than 5 arguments. */
1508 gcc_assert (isym->formal->next->next->next->next == NULL);
1509 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1510 }
1511 }
1512 }
1513
1514 if (gfc_option.flag_f2c
1515 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1516 || e.ts.type == BT_COMPLEX))
1517 {
1518 /* Specific which needs a different implementation if f2c
1519 calling conventions are used. */
1520 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1521 }
1522 else
1523 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1524
1525 name = get_identifier (s);
1526 mangled_name = name;
1527 }
1528 else
1529 {
1530 name = gfc_sym_identifier (sym);
1531 mangled_name = gfc_sym_mangled_function_id (sym);
1532 }
1533
1534 type = gfc_get_function_type (sym);
1535 fndecl = build_decl (input_location,
1536 FUNCTION_DECL, name, type);
1537
1538 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1539 decl_attributes (&fndecl, attributes, 0);
1540
1541 gfc_set_decl_assembler_name (fndecl, mangled_name);
1542
1543 /* Set the context of this decl. */
1544 if (0 && sym->ns && sym->ns->proc_name)
1545 {
1546 /* TODO: Add external decls to the appropriate scope. */
1547 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1548 }
1549 else
1550 {
1551 /* Global declaration, e.g. intrinsic subroutine. */
1552 DECL_CONTEXT (fndecl) = NULL_TREE;
1553 }
1554
1555 DECL_EXTERNAL (fndecl) = 1;
1556
1557 /* This specifies if a function is globally addressable, i.e. it is
1558 the opposite of declaring static in C. */
1559 TREE_PUBLIC (fndecl) = 1;
1560
1561 /* Set attributes for PURE functions. A call to PURE function in the
1562 Fortran 95 sense is both pure and without side effects in the C
1563 sense. */
1564 if (sym->attr.pure || sym->attr.elemental)
1565 {
1566 if (sym->attr.function && !gfc_return_by_reference (sym))
1567 DECL_PURE_P (fndecl) = 1;
1568 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1569 parameters and don't use alternate returns (is this
1570 allowed?). In that case, calls to them are meaningless, and
1571 can be optimized away. See also in build_function_decl(). */
1572 TREE_SIDE_EFFECTS (fndecl) = 0;
1573 }
1574
1575 /* Mark non-returning functions. */
1576 if (sym->attr.noreturn)
1577 TREE_THIS_VOLATILE(fndecl) = 1;
1578
1579 sym->backend_decl = fndecl;
1580
1581 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1582 pushdecl_top_level (fndecl);
1583
1584 return fndecl;
1585 }
1586
1587
1588 /* Create a declaration for a procedure. For external functions (in the C
1589 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1590 a master function with alternate entry points. */
1591
1592 static void
1593 build_function_decl (gfc_symbol * sym)
1594 {
1595 tree fndecl, type, attributes;
1596 symbol_attribute attr;
1597 tree result_decl;
1598 gfc_formal_arglist *f;
1599
1600 gcc_assert (!sym->backend_decl);
1601 gcc_assert (!sym->attr.external);
1602
1603 /* Set the line and filename. sym->declared_at seems to point to the
1604 last statement for subroutines, but it'll do for now. */
1605 gfc_set_backend_locus (&sym->declared_at);
1606
1607 /* Allow only one nesting level. Allow public declarations. */
1608 gcc_assert (current_function_decl == NULL_TREE
1609 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1610 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1611 == NAMESPACE_DECL);
1612
1613 type = gfc_get_function_type (sym);
1614 fndecl = build_decl (input_location,
1615 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1616
1617 attr = sym->attr;
1618
1619 attributes = add_attributes_to_decl (attr, NULL_TREE);
1620 decl_attributes (&fndecl, attributes, 0);
1621
1622 /* Perform name mangling if this is a top level or module procedure. */
1623 if (current_function_decl == NULL_TREE)
1624 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1625
1626 /* Figure out the return type of the declared function, and build a
1627 RESULT_DECL for it. If this is a subroutine with alternate
1628 returns, build a RESULT_DECL for it. */
1629 result_decl = NULL_TREE;
1630 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1631 if (attr.function)
1632 {
1633 if (gfc_return_by_reference (sym))
1634 type = void_type_node;
1635 else
1636 {
1637 if (sym->result != sym)
1638 result_decl = gfc_sym_identifier (sym->result);
1639
1640 type = TREE_TYPE (TREE_TYPE (fndecl));
1641 }
1642 }
1643 else
1644 {
1645 /* Look for alternate return placeholders. */
1646 int has_alternate_returns = 0;
1647 for (f = sym->formal; f; f = f->next)
1648 {
1649 if (f->sym == NULL)
1650 {
1651 has_alternate_returns = 1;
1652 break;
1653 }
1654 }
1655
1656 if (has_alternate_returns)
1657 type = integer_type_node;
1658 else
1659 type = void_type_node;
1660 }
1661
1662 result_decl = build_decl (input_location,
1663 RESULT_DECL, result_decl, type);
1664 DECL_ARTIFICIAL (result_decl) = 1;
1665 DECL_IGNORED_P (result_decl) = 1;
1666 DECL_CONTEXT (result_decl) = fndecl;
1667 DECL_RESULT (fndecl) = result_decl;
1668
1669 /* Don't call layout_decl for a RESULT_DECL.
1670 layout_decl (result_decl, 0); */
1671
1672 /* Set up all attributes for the function. */
1673 DECL_CONTEXT (fndecl) = current_function_decl;
1674 DECL_EXTERNAL (fndecl) = 0;
1675
1676 /* This specifies if a function is globally visible, i.e. it is
1677 the opposite of declaring static in C. */
1678 if (DECL_CONTEXT (fndecl) == NULL_TREE
1679 && !sym->attr.entry_master && !sym->attr.is_main_program)
1680 TREE_PUBLIC (fndecl) = 1;
1681
1682 /* TREE_STATIC means the function body is defined here. */
1683 TREE_STATIC (fndecl) = 1;
1684
1685 /* Set attributes for PURE functions. A call to a PURE function in the
1686 Fortran 95 sense is both pure and without side effects in the C
1687 sense. */
1688 if (attr.pure || attr.elemental)
1689 {
1690 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1691 including an alternate return. In that case it can also be
1692 marked as PURE. See also in gfc_get_extern_function_decl(). */
1693 if (attr.function && !gfc_return_by_reference (sym))
1694 DECL_PURE_P (fndecl) = 1;
1695 TREE_SIDE_EFFECTS (fndecl) = 0;
1696 }
1697
1698
1699 /* Layout the function declaration and put it in the binding level
1700 of the current function. */
1701 pushdecl (fndecl);
1702
1703 sym->backend_decl = fndecl;
1704 }
1705
1706
1707 /* Create the DECL_ARGUMENTS for a procedure. */
1708
1709 static void
1710 create_function_arglist (gfc_symbol * sym)
1711 {
1712 tree fndecl;
1713 gfc_formal_arglist *f;
1714 tree typelist, hidden_typelist;
1715 tree arglist, hidden_arglist;
1716 tree type;
1717 tree parm;
1718
1719 fndecl = sym->backend_decl;
1720
1721 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1722 the new FUNCTION_DECL node. */
1723 arglist = NULL_TREE;
1724 hidden_arglist = NULL_TREE;
1725 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1726
1727 if (sym->attr.entry_master)
1728 {
1729 type = TREE_VALUE (typelist);
1730 parm = build_decl (input_location,
1731 PARM_DECL, get_identifier ("__entry"), type);
1732
1733 DECL_CONTEXT (parm) = fndecl;
1734 DECL_ARG_TYPE (parm) = type;
1735 TREE_READONLY (parm) = 1;
1736 gfc_finish_decl (parm);
1737 DECL_ARTIFICIAL (parm) = 1;
1738
1739 arglist = chainon (arglist, parm);
1740 typelist = TREE_CHAIN (typelist);
1741 }
1742
1743 if (gfc_return_by_reference (sym))
1744 {
1745 tree type = TREE_VALUE (typelist), length = NULL;
1746
1747 if (sym->ts.type == BT_CHARACTER)
1748 {
1749 /* Length of character result. */
1750 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1751 gcc_assert (len_type == gfc_charlen_type_node);
1752
1753 length = build_decl (input_location,
1754 PARM_DECL,
1755 get_identifier (".__result"),
1756 len_type);
1757 if (!sym->ts.u.cl->length)
1758 {
1759 sym->ts.u.cl->backend_decl = length;
1760 TREE_USED (length) = 1;
1761 }
1762 gcc_assert (TREE_CODE (length) == PARM_DECL);
1763 DECL_CONTEXT (length) = fndecl;
1764 DECL_ARG_TYPE (length) = len_type;
1765 TREE_READONLY (length) = 1;
1766 DECL_ARTIFICIAL (length) = 1;
1767 gfc_finish_decl (length);
1768 if (sym->ts.u.cl->backend_decl == NULL
1769 || sym->ts.u.cl->backend_decl == length)
1770 {
1771 gfc_symbol *arg;
1772 tree backend_decl;
1773
1774 if (sym->ts.u.cl->backend_decl == NULL)
1775 {
1776 tree len = build_decl (input_location,
1777 VAR_DECL,
1778 get_identifier ("..__result"),
1779 gfc_charlen_type_node);
1780 DECL_ARTIFICIAL (len) = 1;
1781 TREE_USED (len) = 1;
1782 sym->ts.u.cl->backend_decl = len;
1783 }
1784
1785 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1786 arg = sym->result ? sym->result : sym;
1787 backend_decl = arg->backend_decl;
1788 /* Temporary clear it, so that gfc_sym_type creates complete
1789 type. */
1790 arg->backend_decl = NULL;
1791 type = gfc_sym_type (arg);
1792 arg->backend_decl = backend_decl;
1793 type = build_reference_type (type);
1794 }
1795 }
1796
1797 parm = build_decl (input_location,
1798 PARM_DECL, get_identifier ("__result"), type);
1799
1800 DECL_CONTEXT (parm) = fndecl;
1801 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1802 TREE_READONLY (parm) = 1;
1803 DECL_ARTIFICIAL (parm) = 1;
1804 gfc_finish_decl (parm);
1805
1806 arglist = chainon (arglist, parm);
1807 typelist = TREE_CHAIN (typelist);
1808
1809 if (sym->ts.type == BT_CHARACTER)
1810 {
1811 gfc_allocate_lang_decl (parm);
1812 arglist = chainon (arglist, length);
1813 typelist = TREE_CHAIN (typelist);
1814 }
1815 }
1816
1817 hidden_typelist = typelist;
1818 for (f = sym->formal; f; f = f->next)
1819 if (f->sym != NULL) /* Ignore alternate returns. */
1820 hidden_typelist = TREE_CHAIN (hidden_typelist);
1821
1822 for (f = sym->formal; f; f = f->next)
1823 {
1824 char name[GFC_MAX_SYMBOL_LEN + 2];
1825
1826 /* Ignore alternate returns. */
1827 if (f->sym == NULL)
1828 continue;
1829
1830 type = TREE_VALUE (typelist);
1831
1832 if (f->sym->ts.type == BT_CHARACTER
1833 && (!sym->attr.is_bind_c || sym->attr.entry_master))
1834 {
1835 tree len_type = TREE_VALUE (hidden_typelist);
1836 tree length = NULL_TREE;
1837 gcc_assert (len_type == gfc_charlen_type_node);
1838
1839 strcpy (&name[1], f->sym->name);
1840 name[0] = '_';
1841 length = build_decl (input_location,
1842 PARM_DECL, get_identifier (name), len_type);
1843
1844 hidden_arglist = chainon (hidden_arglist, length);
1845 DECL_CONTEXT (length) = fndecl;
1846 DECL_ARTIFICIAL (length) = 1;
1847 DECL_ARG_TYPE (length) = len_type;
1848 TREE_READONLY (length) = 1;
1849 gfc_finish_decl (length);
1850
1851 /* Remember the passed value. */
1852 if (f->sym->ts.u.cl->passed_length != NULL)
1853 {
1854 /* This can happen if the same type is used for multiple
1855 arguments. We need to copy cl as otherwise
1856 cl->passed_length gets overwritten. */
1857 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
1858 }
1859 f->sym->ts.u.cl->passed_length = length;
1860
1861 /* Use the passed value for assumed length variables. */
1862 if (!f->sym->ts.u.cl->length)
1863 {
1864 TREE_USED (length) = 1;
1865 gcc_assert (!f->sym->ts.u.cl->backend_decl);
1866 f->sym->ts.u.cl->backend_decl = length;
1867 }
1868
1869 hidden_typelist = TREE_CHAIN (hidden_typelist);
1870
1871 if (f->sym->ts.u.cl->backend_decl == NULL
1872 || f->sym->ts.u.cl->backend_decl == length)
1873 {
1874 if (f->sym->ts.u.cl->backend_decl == NULL)
1875 gfc_create_string_length (f->sym);
1876
1877 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1878 if (f->sym->attr.flavor == FL_PROCEDURE)
1879 type = build_pointer_type (gfc_get_function_type (f->sym));
1880 else
1881 type = gfc_sym_type (f->sym);
1882 }
1883 }
1884
1885 /* For non-constant length array arguments, make sure they use
1886 a different type node from TYPE_ARG_TYPES type. */
1887 if (f->sym->attr.dimension
1888 && type == TREE_VALUE (typelist)
1889 && TREE_CODE (type) == POINTER_TYPE
1890 && GFC_ARRAY_TYPE_P (type)
1891 && f->sym->as->type != AS_ASSUMED_SIZE
1892 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1893 {
1894 if (f->sym->attr.flavor == FL_PROCEDURE)
1895 type = build_pointer_type (gfc_get_function_type (f->sym));
1896 else
1897 type = gfc_sym_type (f->sym);
1898 }
1899
1900 if (f->sym->attr.proc_pointer)
1901 type = build_pointer_type (type);
1902
1903 /* Build the argument declaration. */
1904 parm = build_decl (input_location,
1905 PARM_DECL, gfc_sym_identifier (f->sym), type);
1906
1907 /* Fill in arg stuff. */
1908 DECL_CONTEXT (parm) = fndecl;
1909 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1910 /* All implementation args are read-only. */
1911 TREE_READONLY (parm) = 1;
1912 if (POINTER_TYPE_P (type)
1913 && (!f->sym->attr.proc_pointer
1914 && f->sym->attr.flavor != FL_PROCEDURE))
1915 DECL_BY_REFERENCE (parm) = 1;
1916
1917 gfc_finish_decl (parm);
1918
1919 f->sym->backend_decl = parm;
1920
1921 arglist = chainon (arglist, parm);
1922 typelist = TREE_CHAIN (typelist);
1923 }
1924
1925 /* Add the hidden string length parameters, unless the procedure
1926 is bind(C). */
1927 if (!sym->attr.is_bind_c)
1928 arglist = chainon (arglist, hidden_arglist);
1929
1930 gcc_assert (hidden_typelist == NULL_TREE
1931 || TREE_VALUE (hidden_typelist) == void_type_node);
1932 DECL_ARGUMENTS (fndecl) = arglist;
1933 }
1934
1935 /* Do the setup necessary before generating the body of a function. */
1936
1937 static void
1938 trans_function_start (gfc_symbol * sym)
1939 {
1940 tree fndecl;
1941
1942 fndecl = sym->backend_decl;
1943
1944 /* Let GCC know the current scope is this function. */
1945 current_function_decl = fndecl;
1946
1947 /* Let the world know what we're about to do. */
1948 announce_function (fndecl);
1949
1950 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1951 {
1952 /* Create RTL for function declaration. */
1953 rest_of_decl_compilation (fndecl, 1, 0);
1954 }
1955
1956 /* Create RTL for function definition. */
1957 make_decl_rtl (fndecl);
1958
1959 init_function_start (fndecl);
1960
1961 /* Even though we're inside a function body, we still don't want to
1962 call expand_expr to calculate the size of a variable-sized array.
1963 We haven't necessarily assigned RTL to all variables yet, so it's
1964 not safe to try to expand expressions involving them. */
1965 cfun->dont_save_pending_sizes_p = 1;
1966
1967 /* function.c requires a push at the start of the function. */
1968 pushlevel (0);
1969 }
1970
1971 /* Create thunks for alternate entry points. */
1972
1973 static void
1974 build_entry_thunks (gfc_namespace * ns)
1975 {
1976 gfc_formal_arglist *formal;
1977 gfc_formal_arglist *thunk_formal;
1978 gfc_entry_list *el;
1979 gfc_symbol *thunk_sym;
1980 stmtblock_t body;
1981 tree thunk_fndecl;
1982 tree args;
1983 tree string_args;
1984 tree tmp;
1985 locus old_loc;
1986
1987 /* This should always be a toplevel function. */
1988 gcc_assert (current_function_decl == NULL_TREE);
1989
1990 gfc_get_backend_locus (&old_loc);
1991 for (el = ns->entries; el; el = el->next)
1992 {
1993 thunk_sym = el->sym;
1994
1995 build_function_decl (thunk_sym);
1996 create_function_arglist (thunk_sym);
1997
1998 trans_function_start (thunk_sym);
1999
2000 thunk_fndecl = thunk_sym->backend_decl;
2001
2002 gfc_init_block (&body);
2003
2004 /* Pass extra parameter identifying this entry point. */
2005 tmp = build_int_cst (gfc_array_index_type, el->id);
2006 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
2007 string_args = NULL_TREE;
2008
2009 if (thunk_sym->attr.function)
2010 {
2011 if (gfc_return_by_reference (ns->proc_name))
2012 {
2013 tree ref = DECL_ARGUMENTS (current_function_decl);
2014 args = tree_cons (NULL_TREE, ref, args);
2015 if (ns->proc_name->ts.type == BT_CHARACTER)
2016 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
2017 args);
2018 }
2019 }
2020
2021 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2022 {
2023 /* Ignore alternate returns. */
2024 if (formal->sym == NULL)
2025 continue;
2026
2027 /* We don't have a clever way of identifying arguments, so resort to
2028 a brute-force search. */
2029 for (thunk_formal = thunk_sym->formal;
2030 thunk_formal;
2031 thunk_formal = thunk_formal->next)
2032 {
2033 if (thunk_formal->sym == formal->sym)
2034 break;
2035 }
2036
2037 if (thunk_formal)
2038 {
2039 /* Pass the argument. */
2040 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2041 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
2042 args);
2043 if (formal->sym->ts.type == BT_CHARACTER)
2044 {
2045 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2046 string_args = tree_cons (NULL_TREE, tmp, string_args);
2047 }
2048 }
2049 else
2050 {
2051 /* Pass NULL for a missing argument. */
2052 args = tree_cons (NULL_TREE, null_pointer_node, args);
2053 if (formal->sym->ts.type == BT_CHARACTER)
2054 {
2055 tmp = build_int_cst (gfc_charlen_type_node, 0);
2056 string_args = tree_cons (NULL_TREE, tmp, string_args);
2057 }
2058 }
2059 }
2060
2061 /* Call the master function. */
2062 args = nreverse (args);
2063 args = chainon (args, nreverse (string_args));
2064 tmp = ns->proc_name->backend_decl;
2065 tmp = build_function_call_expr (input_location, tmp, args);
2066 if (ns->proc_name->attr.mixed_entry_master)
2067 {
2068 tree union_decl, field;
2069 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2070
2071 union_decl = build_decl (input_location,
2072 VAR_DECL, get_identifier ("__result"),
2073 TREE_TYPE (master_type));
2074 DECL_ARTIFICIAL (union_decl) = 1;
2075 DECL_EXTERNAL (union_decl) = 0;
2076 TREE_PUBLIC (union_decl) = 0;
2077 TREE_USED (union_decl) = 1;
2078 layout_decl (union_decl, 0);
2079 pushdecl (union_decl);
2080
2081 DECL_CONTEXT (union_decl) = current_function_decl;
2082 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
2083 union_decl, tmp);
2084 gfc_add_expr_to_block (&body, tmp);
2085
2086 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2087 field; field = TREE_CHAIN (field))
2088 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2089 thunk_sym->result->name) == 0)
2090 break;
2091 gcc_assert (field != NULL_TREE);
2092 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2093 union_decl, field, NULL_TREE);
2094 tmp = fold_build2 (MODIFY_EXPR,
2095 TREE_TYPE (DECL_RESULT (current_function_decl)),
2096 DECL_RESULT (current_function_decl), tmp);
2097 tmp = build1_v (RETURN_EXPR, tmp);
2098 }
2099 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2100 != void_type_node)
2101 {
2102 tmp = fold_build2 (MODIFY_EXPR,
2103 TREE_TYPE (DECL_RESULT (current_function_decl)),
2104 DECL_RESULT (current_function_decl), tmp);
2105 tmp = build1_v (RETURN_EXPR, tmp);
2106 }
2107 gfc_add_expr_to_block (&body, tmp);
2108
2109 /* Finish off this function and send it for code generation. */
2110 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2111 tmp = getdecls ();
2112 poplevel (1, 0, 1);
2113 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2114 DECL_SAVED_TREE (thunk_fndecl)
2115 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2116 DECL_INITIAL (thunk_fndecl));
2117
2118 /* Output the GENERIC tree. */
2119 dump_function (TDI_original, thunk_fndecl);
2120
2121 /* Store the end of the function, so that we get good line number
2122 info for the epilogue. */
2123 cfun->function_end_locus = input_location;
2124
2125 /* We're leaving the context of this function, so zap cfun.
2126 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2127 tree_rest_of_compilation. */
2128 set_cfun (NULL);
2129
2130 current_function_decl = NULL_TREE;
2131
2132 cgraph_finalize_function (thunk_fndecl, true);
2133
2134 /* We share the symbols in the formal argument list with other entry
2135 points and the master function. Clear them so that they are
2136 recreated for each function. */
2137 for (formal = thunk_sym->formal; formal; formal = formal->next)
2138 if (formal->sym != NULL) /* Ignore alternate returns. */
2139 {
2140 formal->sym->backend_decl = NULL_TREE;
2141 if (formal->sym->ts.type == BT_CHARACTER)
2142 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2143 }
2144
2145 if (thunk_sym->attr.function)
2146 {
2147 if (thunk_sym->ts.type == BT_CHARACTER)
2148 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2149 if (thunk_sym->result->ts.type == BT_CHARACTER)
2150 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2151 }
2152 }
2153
2154 gfc_set_backend_locus (&old_loc);
2155 }
2156
2157
2158 /* Create a decl for a function, and create any thunks for alternate entry
2159 points. */
2160
2161 void
2162 gfc_create_function_decl (gfc_namespace * ns)
2163 {
2164 /* Create a declaration for the master function. */
2165 build_function_decl (ns->proc_name);
2166
2167 /* Compile the entry thunks. */
2168 if (ns->entries)
2169 build_entry_thunks (ns);
2170
2171 /* Now create the read argument list. */
2172 create_function_arglist (ns->proc_name);
2173 }
2174
2175 /* Return the decl used to hold the function return value. If
2176 parent_flag is set, the context is the parent_scope. */
2177
2178 tree
2179 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2180 {
2181 tree decl;
2182 tree length;
2183 tree this_fake_result_decl;
2184 tree this_function_decl;
2185
2186 char name[GFC_MAX_SYMBOL_LEN + 10];
2187
2188 if (parent_flag)
2189 {
2190 this_fake_result_decl = parent_fake_result_decl;
2191 this_function_decl = DECL_CONTEXT (current_function_decl);
2192 }
2193 else
2194 {
2195 this_fake_result_decl = current_fake_result_decl;
2196 this_function_decl = current_function_decl;
2197 }
2198
2199 if (sym
2200 && sym->ns->proc_name->backend_decl == this_function_decl
2201 && sym->ns->proc_name->attr.entry_master
2202 && sym != sym->ns->proc_name)
2203 {
2204 tree t = NULL, var;
2205 if (this_fake_result_decl != NULL)
2206 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2207 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2208 break;
2209 if (t)
2210 return TREE_VALUE (t);
2211 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2212
2213 if (parent_flag)
2214 this_fake_result_decl = parent_fake_result_decl;
2215 else
2216 this_fake_result_decl = current_fake_result_decl;
2217
2218 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2219 {
2220 tree field;
2221
2222 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2223 field; field = TREE_CHAIN (field))
2224 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2225 sym->name) == 0)
2226 break;
2227
2228 gcc_assert (field != NULL_TREE);
2229 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2230 decl, field, NULL_TREE);
2231 }
2232
2233 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2234 if (parent_flag)
2235 gfc_add_decl_to_parent_function (var);
2236 else
2237 gfc_add_decl_to_function (var);
2238
2239 SET_DECL_VALUE_EXPR (var, decl);
2240 DECL_HAS_VALUE_EXPR_P (var) = 1;
2241 GFC_DECL_RESULT (var) = 1;
2242
2243 TREE_CHAIN (this_fake_result_decl)
2244 = tree_cons (get_identifier (sym->name), var,
2245 TREE_CHAIN (this_fake_result_decl));
2246 return var;
2247 }
2248
2249 if (this_fake_result_decl != NULL_TREE)
2250 return TREE_VALUE (this_fake_result_decl);
2251
2252 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2253 sym is NULL. */
2254 if (!sym)
2255 return NULL_TREE;
2256
2257 if (sym->ts.type == BT_CHARACTER)
2258 {
2259 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2260 length = gfc_create_string_length (sym);
2261 else
2262 length = sym->ts.u.cl->backend_decl;
2263 if (TREE_CODE (length) == VAR_DECL
2264 && DECL_CONTEXT (length) == NULL_TREE)
2265 gfc_add_decl_to_function (length);
2266 }
2267
2268 if (gfc_return_by_reference (sym))
2269 {
2270 decl = DECL_ARGUMENTS (this_function_decl);
2271
2272 if (sym->ns->proc_name->backend_decl == this_function_decl
2273 && sym->ns->proc_name->attr.entry_master)
2274 decl = TREE_CHAIN (decl);
2275
2276 TREE_USED (decl) = 1;
2277 if (sym->as)
2278 decl = gfc_build_dummy_array_decl (sym, decl);
2279 }
2280 else
2281 {
2282 sprintf (name, "__result_%.20s",
2283 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2284
2285 if (!sym->attr.mixed_entry_master && sym->attr.function)
2286 decl = build_decl (input_location,
2287 VAR_DECL, get_identifier (name),
2288 gfc_sym_type (sym));
2289 else
2290 decl = build_decl (input_location,
2291 VAR_DECL, get_identifier (name),
2292 TREE_TYPE (TREE_TYPE (this_function_decl)));
2293 DECL_ARTIFICIAL (decl) = 1;
2294 DECL_EXTERNAL (decl) = 0;
2295 TREE_PUBLIC (decl) = 0;
2296 TREE_USED (decl) = 1;
2297 GFC_DECL_RESULT (decl) = 1;
2298 TREE_ADDRESSABLE (decl) = 1;
2299
2300 layout_decl (decl, 0);
2301
2302 if (parent_flag)
2303 gfc_add_decl_to_parent_function (decl);
2304 else
2305 gfc_add_decl_to_function (decl);
2306 }
2307
2308 if (parent_flag)
2309 parent_fake_result_decl = build_tree_list (NULL, decl);
2310 else
2311 current_fake_result_decl = build_tree_list (NULL, decl);
2312
2313 return decl;
2314 }
2315
2316
2317 /* Builds a function decl. The remaining parameters are the types of the
2318 function arguments. Negative nargs indicates a varargs function. */
2319
2320 tree
2321 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2322 {
2323 tree arglist;
2324 tree argtype;
2325 tree fntype;
2326 tree fndecl;
2327 va_list p;
2328 int n;
2329
2330 /* Library functions must be declared with global scope. */
2331 gcc_assert (current_function_decl == NULL_TREE);
2332
2333 va_start (p, nargs);
2334
2335
2336 /* Create a list of the argument types. */
2337 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2338 {
2339 argtype = va_arg (p, tree);
2340 arglist = gfc_chainon_list (arglist, argtype);
2341 }
2342
2343 if (nargs >= 0)
2344 {
2345 /* Terminate the list. */
2346 arglist = gfc_chainon_list (arglist, void_type_node);
2347 }
2348
2349 /* Build the function type and decl. */
2350 fntype = build_function_type (rettype, arglist);
2351 fndecl = build_decl (input_location,
2352 FUNCTION_DECL, name, fntype);
2353
2354 /* Mark this decl as external. */
2355 DECL_EXTERNAL (fndecl) = 1;
2356 TREE_PUBLIC (fndecl) = 1;
2357
2358 va_end (p);
2359
2360 pushdecl (fndecl);
2361
2362 rest_of_decl_compilation (fndecl, 1, 0);
2363
2364 return fndecl;
2365 }
2366
2367 static void
2368 gfc_build_intrinsic_function_decls (void)
2369 {
2370 tree gfc_int4_type_node = gfc_get_int_type (4);
2371 tree gfc_int8_type_node = gfc_get_int_type (8);
2372 tree gfc_int16_type_node = gfc_get_int_type (16);
2373 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2374 tree pchar1_type_node = gfc_get_pchar_type (1);
2375 tree pchar4_type_node = gfc_get_pchar_type (4);
2376
2377 /* String functions. */
2378 gfor_fndecl_compare_string =
2379 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2380 integer_type_node, 4,
2381 gfc_charlen_type_node, pchar1_type_node,
2382 gfc_charlen_type_node, pchar1_type_node);
2383
2384 gfor_fndecl_concat_string =
2385 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2386 void_type_node, 6,
2387 gfc_charlen_type_node, pchar1_type_node,
2388 gfc_charlen_type_node, pchar1_type_node,
2389 gfc_charlen_type_node, pchar1_type_node);
2390
2391 gfor_fndecl_string_len_trim =
2392 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2393 gfc_int4_type_node, 2,
2394 gfc_charlen_type_node, pchar1_type_node);
2395
2396 gfor_fndecl_string_index =
2397 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2398 gfc_int4_type_node, 5,
2399 gfc_charlen_type_node, pchar1_type_node,
2400 gfc_charlen_type_node, pchar1_type_node,
2401 gfc_logical4_type_node);
2402
2403 gfor_fndecl_string_scan =
2404 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2405 gfc_int4_type_node, 5,
2406 gfc_charlen_type_node, pchar1_type_node,
2407 gfc_charlen_type_node, pchar1_type_node,
2408 gfc_logical4_type_node);
2409
2410 gfor_fndecl_string_verify =
2411 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2412 gfc_int4_type_node, 5,
2413 gfc_charlen_type_node, pchar1_type_node,
2414 gfc_charlen_type_node, pchar1_type_node,
2415 gfc_logical4_type_node);
2416
2417 gfor_fndecl_string_trim =
2418 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2419 void_type_node, 4,
2420 build_pointer_type (gfc_charlen_type_node),
2421 build_pointer_type (pchar1_type_node),
2422 gfc_charlen_type_node, pchar1_type_node);
2423
2424 gfor_fndecl_string_minmax =
2425 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2426 void_type_node, -4,
2427 build_pointer_type (gfc_charlen_type_node),
2428 build_pointer_type (pchar1_type_node),
2429 integer_type_node, integer_type_node);
2430
2431 gfor_fndecl_adjustl =
2432 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2433 void_type_node, 3, pchar1_type_node,
2434 gfc_charlen_type_node, pchar1_type_node);
2435
2436 gfor_fndecl_adjustr =
2437 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2438 void_type_node, 3, pchar1_type_node,
2439 gfc_charlen_type_node, pchar1_type_node);
2440
2441 gfor_fndecl_select_string =
2442 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2443 integer_type_node, 4, pvoid_type_node,
2444 integer_type_node, pchar1_type_node,
2445 gfc_charlen_type_node);
2446
2447 gfor_fndecl_compare_string_char4 =
2448 gfc_build_library_function_decl (get_identifier
2449 (PREFIX("compare_string_char4")),
2450 integer_type_node, 4,
2451 gfc_charlen_type_node, pchar4_type_node,
2452 gfc_charlen_type_node, pchar4_type_node);
2453
2454 gfor_fndecl_concat_string_char4 =
2455 gfc_build_library_function_decl (get_identifier
2456 (PREFIX("concat_string_char4")),
2457 void_type_node, 6,
2458 gfc_charlen_type_node, pchar4_type_node,
2459 gfc_charlen_type_node, pchar4_type_node,
2460 gfc_charlen_type_node, pchar4_type_node);
2461
2462 gfor_fndecl_string_len_trim_char4 =
2463 gfc_build_library_function_decl (get_identifier
2464 (PREFIX("string_len_trim_char4")),
2465 gfc_charlen_type_node, 2,
2466 gfc_charlen_type_node, pchar4_type_node);
2467
2468 gfor_fndecl_string_index_char4 =
2469 gfc_build_library_function_decl (get_identifier
2470 (PREFIX("string_index_char4")),
2471 gfc_charlen_type_node, 5,
2472 gfc_charlen_type_node, pchar4_type_node,
2473 gfc_charlen_type_node, pchar4_type_node,
2474 gfc_logical4_type_node);
2475
2476 gfor_fndecl_string_scan_char4 =
2477 gfc_build_library_function_decl (get_identifier
2478 (PREFIX("string_scan_char4")),
2479 gfc_charlen_type_node, 5,
2480 gfc_charlen_type_node, pchar4_type_node,
2481 gfc_charlen_type_node, pchar4_type_node,
2482 gfc_logical4_type_node);
2483
2484 gfor_fndecl_string_verify_char4 =
2485 gfc_build_library_function_decl (get_identifier
2486 (PREFIX("string_verify_char4")),
2487 gfc_charlen_type_node, 5,
2488 gfc_charlen_type_node, pchar4_type_node,
2489 gfc_charlen_type_node, pchar4_type_node,
2490 gfc_logical4_type_node);
2491
2492 gfor_fndecl_string_trim_char4 =
2493 gfc_build_library_function_decl (get_identifier
2494 (PREFIX("string_trim_char4")),
2495 void_type_node, 4,
2496 build_pointer_type (gfc_charlen_type_node),
2497 build_pointer_type (pchar4_type_node),
2498 gfc_charlen_type_node, pchar4_type_node);
2499
2500 gfor_fndecl_string_minmax_char4 =
2501 gfc_build_library_function_decl (get_identifier
2502 (PREFIX("string_minmax_char4")),
2503 void_type_node, -4,
2504 build_pointer_type (gfc_charlen_type_node),
2505 build_pointer_type (pchar4_type_node),
2506 integer_type_node, integer_type_node);
2507
2508 gfor_fndecl_adjustl_char4 =
2509 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2510 void_type_node, 3, pchar4_type_node,
2511 gfc_charlen_type_node, pchar4_type_node);
2512
2513 gfor_fndecl_adjustr_char4 =
2514 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2515 void_type_node, 3, pchar4_type_node,
2516 gfc_charlen_type_node, pchar4_type_node);
2517
2518 gfor_fndecl_select_string_char4 =
2519 gfc_build_library_function_decl (get_identifier
2520 (PREFIX("select_string_char4")),
2521 integer_type_node, 4, pvoid_type_node,
2522 integer_type_node, pvoid_type_node,
2523 gfc_charlen_type_node);
2524
2525
2526 /* Conversion between character kinds. */
2527
2528 gfor_fndecl_convert_char1_to_char4 =
2529 gfc_build_library_function_decl (get_identifier
2530 (PREFIX("convert_char1_to_char4")),
2531 void_type_node, 3,
2532 build_pointer_type (pchar4_type_node),
2533 gfc_charlen_type_node, pchar1_type_node);
2534
2535 gfor_fndecl_convert_char4_to_char1 =
2536 gfc_build_library_function_decl (get_identifier
2537 (PREFIX("convert_char4_to_char1")),
2538 void_type_node, 3,
2539 build_pointer_type (pchar1_type_node),
2540 gfc_charlen_type_node, pchar4_type_node);
2541
2542 /* Misc. functions. */
2543
2544 gfor_fndecl_ttynam =
2545 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2546 void_type_node,
2547 3,
2548 pchar_type_node,
2549 gfc_charlen_type_node,
2550 integer_type_node);
2551
2552 gfor_fndecl_fdate =
2553 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2554 void_type_node,
2555 2,
2556 pchar_type_node,
2557 gfc_charlen_type_node);
2558
2559 gfor_fndecl_ctime =
2560 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2561 void_type_node,
2562 3,
2563 pchar_type_node,
2564 gfc_charlen_type_node,
2565 gfc_int8_type_node);
2566
2567 gfor_fndecl_sc_kind =
2568 gfc_build_library_function_decl (get_identifier
2569 (PREFIX("selected_char_kind")),
2570 gfc_int4_type_node, 2,
2571 gfc_charlen_type_node, pchar_type_node);
2572
2573 gfor_fndecl_si_kind =
2574 gfc_build_library_function_decl (get_identifier
2575 (PREFIX("selected_int_kind")),
2576 gfc_int4_type_node, 1, pvoid_type_node);
2577
2578 gfor_fndecl_sr_kind =
2579 gfc_build_library_function_decl (get_identifier
2580 (PREFIX("selected_real_kind")),
2581 gfc_int4_type_node, 2,
2582 pvoid_type_node, pvoid_type_node);
2583
2584 /* Power functions. */
2585 {
2586 tree ctype, rtype, itype, jtype;
2587 int rkind, ikind, jkind;
2588 #define NIKINDS 3
2589 #define NRKINDS 4
2590 static int ikinds[NIKINDS] = {4, 8, 16};
2591 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2592 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2593
2594 for (ikind=0; ikind < NIKINDS; ikind++)
2595 {
2596 itype = gfc_get_int_type (ikinds[ikind]);
2597
2598 for (jkind=0; jkind < NIKINDS; jkind++)
2599 {
2600 jtype = gfc_get_int_type (ikinds[jkind]);
2601 if (itype && jtype)
2602 {
2603 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2604 ikinds[jkind]);
2605 gfor_fndecl_math_powi[jkind][ikind].integer =
2606 gfc_build_library_function_decl (get_identifier (name),
2607 jtype, 2, jtype, itype);
2608 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2609 }
2610 }
2611
2612 for (rkind = 0; rkind < NRKINDS; rkind ++)
2613 {
2614 rtype = gfc_get_real_type (rkinds[rkind]);
2615 if (rtype && itype)
2616 {
2617 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2618 ikinds[ikind]);
2619 gfor_fndecl_math_powi[rkind][ikind].real =
2620 gfc_build_library_function_decl (get_identifier (name),
2621 rtype, 2, rtype, itype);
2622 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2623 }
2624
2625 ctype = gfc_get_complex_type (rkinds[rkind]);
2626 if (ctype && itype)
2627 {
2628 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2629 ikinds[ikind]);
2630 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2631 gfc_build_library_function_decl (get_identifier (name),
2632 ctype, 2,ctype, itype);
2633 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2634 }
2635 }
2636 }
2637 #undef NIKINDS
2638 #undef NRKINDS
2639 }
2640
2641 gfor_fndecl_math_ishftc4 =
2642 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2643 gfc_int4_type_node,
2644 3, gfc_int4_type_node,
2645 gfc_int4_type_node, gfc_int4_type_node);
2646 gfor_fndecl_math_ishftc8 =
2647 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2648 gfc_int8_type_node,
2649 3, gfc_int8_type_node,
2650 gfc_int4_type_node, gfc_int4_type_node);
2651 if (gfc_int16_type_node)
2652 gfor_fndecl_math_ishftc16 =
2653 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2654 gfc_int16_type_node, 3,
2655 gfc_int16_type_node,
2656 gfc_int4_type_node,
2657 gfc_int4_type_node);
2658
2659 /* BLAS functions. */
2660 {
2661 tree pint = build_pointer_type (integer_type_node);
2662 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2663 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2664 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2665 tree pz = build_pointer_type
2666 (gfc_get_complex_type (gfc_default_double_kind));
2667
2668 gfor_fndecl_sgemm = gfc_build_library_function_decl
2669 (get_identifier
2670 (gfc_option.flag_underscoring ? "sgemm_"
2671 : "sgemm"),
2672 void_type_node, 15, pchar_type_node,
2673 pchar_type_node, pint, pint, pint, ps, ps, pint,
2674 ps, pint, ps, ps, pint, integer_type_node,
2675 integer_type_node);
2676 gfor_fndecl_dgemm = gfc_build_library_function_decl
2677 (get_identifier
2678 (gfc_option.flag_underscoring ? "dgemm_"
2679 : "dgemm"),
2680 void_type_node, 15, pchar_type_node,
2681 pchar_type_node, pint, pint, pint, pd, pd, pint,
2682 pd, pint, pd, pd, pint, integer_type_node,
2683 integer_type_node);
2684 gfor_fndecl_cgemm = gfc_build_library_function_decl
2685 (get_identifier
2686 (gfc_option.flag_underscoring ? "cgemm_"
2687 : "cgemm"),
2688 void_type_node, 15, pchar_type_node,
2689 pchar_type_node, pint, pint, pint, pc, pc, pint,
2690 pc, pint, pc, pc, pint, integer_type_node,
2691 integer_type_node);
2692 gfor_fndecl_zgemm = gfc_build_library_function_decl
2693 (get_identifier
2694 (gfc_option.flag_underscoring ? "zgemm_"
2695 : "zgemm"),
2696 void_type_node, 15, pchar_type_node,
2697 pchar_type_node, pint, pint, pint, pz, pz, pint,
2698 pz, pint, pz, pz, pint, integer_type_node,
2699 integer_type_node);
2700 }
2701
2702 /* Other functions. */
2703 gfor_fndecl_size0 =
2704 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2705 gfc_array_index_type,
2706 1, pvoid_type_node);
2707 gfor_fndecl_size1 =
2708 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2709 gfc_array_index_type,
2710 2, pvoid_type_node,
2711 gfc_array_index_type);
2712
2713 gfor_fndecl_iargc =
2714 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2715 gfc_int4_type_node,
2716 0);
2717
2718 if (gfc_type_for_size (128, true))
2719 {
2720 tree uint128 = gfc_type_for_size (128, true);
2721
2722 gfor_fndecl_clz128 =
2723 gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2724 integer_type_node, 1, uint128);
2725
2726 gfor_fndecl_ctz128 =
2727 gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2728 integer_type_node, 1, uint128);
2729 }
2730 }
2731
2732
2733 /* Make prototypes for runtime library functions. */
2734
2735 void
2736 gfc_build_builtin_function_decls (void)
2737 {
2738 tree gfc_int4_type_node = gfc_get_int_type (4);
2739
2740 gfor_fndecl_stop_numeric =
2741 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2742 void_type_node, 1, gfc_int4_type_node);
2743 /* Stop doesn't return. */
2744 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2745
2746 gfor_fndecl_stop_string =
2747 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2748 void_type_node, 2, pchar_type_node,
2749 gfc_int4_type_node);
2750 /* Stop doesn't return. */
2751 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2752
2753 gfor_fndecl_error_stop_string =
2754 gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
2755 void_type_node, 2, pchar_type_node,
2756 gfc_int4_type_node);
2757 /* ERROR STOP doesn't return. */
2758 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2759
2760 gfor_fndecl_pause_numeric =
2761 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2762 void_type_node, 1, gfc_int4_type_node);
2763
2764 gfor_fndecl_pause_string =
2765 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2766 void_type_node, 2, pchar_type_node,
2767 gfc_int4_type_node);
2768
2769 gfor_fndecl_runtime_error =
2770 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2771 void_type_node, -1, pchar_type_node);
2772 /* The runtime_error function does not return. */
2773 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2774
2775 gfor_fndecl_runtime_error_at =
2776 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2777 void_type_node, -2, pchar_type_node,
2778 pchar_type_node);
2779 /* The runtime_error_at function does not return. */
2780 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2781
2782 gfor_fndecl_runtime_warning_at =
2783 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2784 void_type_node, -2, pchar_type_node,
2785 pchar_type_node);
2786 gfor_fndecl_generate_error =
2787 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2788 void_type_node, 3, pvoid_type_node,
2789 integer_type_node, pchar_type_node);
2790
2791 gfor_fndecl_os_error =
2792 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2793 void_type_node, 1, pchar_type_node);
2794 /* The runtime_error function does not return. */
2795 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2796
2797 gfor_fndecl_set_args =
2798 gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2799 void_type_node, 2, integer_type_node,
2800 build_pointer_type (pchar_type_node));
2801
2802 gfor_fndecl_set_fpe =
2803 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2804 void_type_node, 1, integer_type_node);
2805
2806 /* Keep the array dimension in sync with the call, later in this file. */
2807 gfor_fndecl_set_options =
2808 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2809 void_type_node, 2, integer_type_node,
2810 build_pointer_type (integer_type_node));
2811
2812 gfor_fndecl_set_convert =
2813 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2814 void_type_node, 1, integer_type_node);
2815
2816 gfor_fndecl_set_record_marker =
2817 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2818 void_type_node, 1, integer_type_node);
2819
2820 gfor_fndecl_set_max_subrecord_length =
2821 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2822 void_type_node, 1, integer_type_node);
2823
2824 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2825 get_identifier (PREFIX("internal_pack")),
2826 pvoid_type_node, 1, pvoid_type_node);
2827
2828 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2829 get_identifier (PREFIX("internal_unpack")),
2830 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2831
2832 gfor_fndecl_associated =
2833 gfc_build_library_function_decl (
2834 get_identifier (PREFIX("associated")),
2835 integer_type_node, 2, ppvoid_type_node,
2836 ppvoid_type_node);
2837
2838 gfc_build_intrinsic_function_decls ();
2839 gfc_build_intrinsic_lib_fndecls ();
2840 gfc_build_io_library_fndecls ();
2841 }
2842
2843
2844 /* Evaluate the length of dummy character variables. */
2845
2846 static tree
2847 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2848 {
2849 stmtblock_t body;
2850
2851 gfc_finish_decl (cl->backend_decl);
2852
2853 gfc_start_block (&body);
2854
2855 /* Evaluate the string length expression. */
2856 gfc_conv_string_length (cl, NULL, &body);
2857
2858 gfc_trans_vla_type_sizes (sym, &body);
2859
2860 gfc_add_expr_to_block (&body, fnbody);
2861 return gfc_finish_block (&body);
2862 }
2863
2864
2865 /* Allocate and cleanup an automatic character variable. */
2866
2867 static tree
2868 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2869 {
2870 stmtblock_t body;
2871 tree decl;
2872 tree tmp;
2873
2874 gcc_assert (sym->backend_decl);
2875 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2876
2877 gfc_start_block (&body);
2878
2879 /* Evaluate the string length expression. */
2880 gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
2881
2882 gfc_trans_vla_type_sizes (sym, &body);
2883
2884 decl = sym->backend_decl;
2885
2886 /* Emit a DECL_EXPR for this variable, which will cause the
2887 gimplifier to allocate storage, and all that good stuff. */
2888 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2889 gfc_add_expr_to_block (&body, tmp);
2890
2891 gfc_add_expr_to_block (&body, fnbody);
2892 return gfc_finish_block (&body);
2893 }
2894
2895 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2896
2897 static tree
2898 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2899 {
2900 stmtblock_t body;
2901
2902 gcc_assert (sym->backend_decl);
2903 gfc_start_block (&body);
2904
2905 /* Set the initial value to length. See the comments in
2906 function gfc_add_assign_aux_vars in this file. */
2907 gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2908 build_int_cst (NULL_TREE, -2));
2909
2910 gfc_add_expr_to_block (&body, fnbody);
2911 return gfc_finish_block (&body);
2912 }
2913
2914 static void
2915 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2916 {
2917 tree t = *tp, var, val;
2918
2919 if (t == NULL || t == error_mark_node)
2920 return;
2921 if (TREE_CONSTANT (t) || DECL_P (t))
2922 return;
2923
2924 if (TREE_CODE (t) == SAVE_EXPR)
2925 {
2926 if (SAVE_EXPR_RESOLVED_P (t))
2927 {
2928 *tp = TREE_OPERAND (t, 0);
2929 return;
2930 }
2931 val = TREE_OPERAND (t, 0);
2932 }
2933 else
2934 val = t;
2935
2936 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2937 gfc_add_decl_to_function (var);
2938 gfc_add_modify (body, var, val);
2939 if (TREE_CODE (t) == SAVE_EXPR)
2940 TREE_OPERAND (t, 0) = var;
2941 *tp = var;
2942 }
2943
2944 static void
2945 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2946 {
2947 tree t;
2948
2949 if (type == NULL || type == error_mark_node)
2950 return;
2951
2952 type = TYPE_MAIN_VARIANT (type);
2953
2954 if (TREE_CODE (type) == INTEGER_TYPE)
2955 {
2956 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2957 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2958
2959 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2960 {
2961 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2962 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2963 }
2964 }
2965 else if (TREE_CODE (type) == ARRAY_TYPE)
2966 {
2967 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2968 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2969 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2970 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2971
2972 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2973 {
2974 TYPE_SIZE (t) = TYPE_SIZE (type);
2975 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2976 }
2977 }
2978 }
2979
2980 /* Make sure all type sizes and array domains are either constant,
2981 or variable or parameter decls. This is a simplified variant
2982 of gimplify_type_sizes, but we can't use it here, as none of the
2983 variables in the expressions have been gimplified yet.
2984 As type sizes and domains for various variable length arrays
2985 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2986 time, without this routine gimplify_type_sizes in the middle-end
2987 could result in the type sizes being gimplified earlier than where
2988 those variables are initialized. */
2989
2990 void
2991 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2992 {
2993 tree type = TREE_TYPE (sym->backend_decl);
2994
2995 if (TREE_CODE (type) == FUNCTION_TYPE
2996 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2997 {
2998 if (! current_fake_result_decl)
2999 return;
3000
3001 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3002 }
3003
3004 while (POINTER_TYPE_P (type))
3005 type = TREE_TYPE (type);
3006
3007 if (GFC_DESCRIPTOR_TYPE_P (type))
3008 {
3009 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3010
3011 while (POINTER_TYPE_P (etype))
3012 etype = TREE_TYPE (etype);
3013
3014 gfc_trans_vla_type_sizes_1 (etype, body);
3015 }
3016
3017 gfc_trans_vla_type_sizes_1 (type, body);
3018 }
3019
3020
3021 /* Initialize a derived type by building an lvalue from the symbol
3022 and using trans_assignment to do the work. Set dealloc to false
3023 if no deallocation prior the assignment is needed. */
3024 tree
3025 gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
3026 {
3027 stmtblock_t fnblock;
3028 gfc_expr *e;
3029 tree tmp;
3030 tree present;
3031
3032 gfc_init_block (&fnblock);
3033 gcc_assert (!sym->attr.allocatable);
3034 gfc_set_sym_referenced (sym);
3035 e = gfc_lval_expr_from_sym (sym);
3036 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3037 if (sym->attr.dummy && (sym->attr.optional
3038 || sym->ns->proc_name->attr.entry_master))
3039 {
3040 present = gfc_conv_expr_present (sym);
3041 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3042 tmp, build_empty_stmt (input_location));
3043 }
3044 gfc_add_expr_to_block (&fnblock, tmp);
3045 gfc_free_expr (e);
3046 if (body)
3047 gfc_add_expr_to_block (&fnblock, body);
3048 return gfc_finish_block (&fnblock);
3049 }
3050
3051
3052 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3053 them their default initializer, if they do not have allocatable
3054 components, they have their allocatable components deallocated. */
3055
3056 static tree
3057 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
3058 {
3059 stmtblock_t fnblock;
3060 gfc_formal_arglist *f;
3061 tree tmp;
3062 tree present;
3063
3064 gfc_init_block (&fnblock);
3065 for (f = proc_sym->formal; f; f = f->next)
3066 if (f->sym && f->sym->attr.intent == INTENT_OUT
3067 && !f->sym->attr.pointer
3068 && f->sym->ts.type == BT_DERIVED)
3069 {
3070 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3071 {
3072 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3073 f->sym->backend_decl,
3074 f->sym->as ? f->sym->as->rank : 0);
3075
3076 if (f->sym->attr.optional
3077 || f->sym->ns->proc_name->attr.entry_master)
3078 {
3079 present = gfc_conv_expr_present (f->sym);
3080 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3081 tmp, build_empty_stmt (input_location));
3082 }
3083
3084 gfc_add_expr_to_block (&fnblock, tmp);
3085 }
3086 else if (f->sym->value)
3087 body = gfc_init_default_dt (f->sym, body, true);
3088 }
3089
3090 gfc_add_expr_to_block (&fnblock, body);
3091 return gfc_finish_block (&fnblock);
3092 }
3093
3094
3095 /* Generate function entry and exit code, and add it to the function body.
3096 This includes:
3097 Allocation and initialization of array variables.
3098 Allocation of character string variables.
3099 Initialization and possibly repacking of dummy arrays.
3100 Initialization of ASSIGN statement auxiliary variable.
3101 Automatic deallocation. */
3102
3103 tree
3104 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
3105 {
3106 locus loc;
3107 gfc_symbol *sym;
3108 gfc_formal_arglist *f;
3109 stmtblock_t body;
3110 bool seen_trans_deferred_array = false;
3111
3112 /* Deal with implicit return variables. Explicit return variables will
3113 already have been added. */
3114 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3115 {
3116 if (!current_fake_result_decl)
3117 {
3118 gfc_entry_list *el = NULL;
3119 if (proc_sym->attr.entry_master)
3120 {
3121 for (el = proc_sym->ns->entries; el; el = el->next)
3122 if (el->sym != el->sym->result)
3123 break;
3124 }
3125 /* TODO: move to the appropriate place in resolve.c. */
3126 if (warn_return_type && el == NULL)
3127 gfc_warning ("Return value of function '%s' at %L not set",
3128 proc_sym->name, &proc_sym->declared_at);
3129 }
3130 else if (proc_sym->as)
3131 {
3132 tree result = TREE_VALUE (current_fake_result_decl);
3133 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
3134
3135 /* An automatic character length, pointer array result. */
3136 if (proc_sym->ts.type == BT_CHARACTER
3137 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3138 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3139 fnbody);
3140 }
3141 else if (proc_sym->ts.type == BT_CHARACTER)
3142 {
3143 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3144 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3145 fnbody);
3146 }
3147 else
3148 gcc_assert (gfc_option.flag_f2c
3149 && proc_sym->ts.type == BT_COMPLEX);
3150 }
3151
3152 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3153 should be done here so that the offsets and lbounds of arrays
3154 are available. */
3155 fnbody = init_intent_out_dt (proc_sym, fnbody);
3156
3157 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3158 {
3159 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3160 && sym->ts.u.derived->attr.alloc_comp;
3161 if (sym->attr.dimension)
3162 {
3163 switch (sym->as->type)
3164 {
3165 case AS_EXPLICIT:
3166 if (sym->attr.dummy || sym->attr.result)
3167 fnbody =
3168 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3169 else if (sym->attr.pointer || sym->attr.allocatable)
3170 {
3171 if (TREE_STATIC (sym->backend_decl))
3172 gfc_trans_static_array_pointer (sym);
3173 else
3174 {
3175 seen_trans_deferred_array = true;
3176 fnbody = gfc_trans_deferred_array (sym, fnbody);
3177 }
3178 }
3179 else
3180 {
3181 if (sym_has_alloc_comp)
3182 {
3183 seen_trans_deferred_array = true;
3184 fnbody = gfc_trans_deferred_array (sym, fnbody);
3185 }
3186 else if (sym->ts.type == BT_DERIVED
3187 && sym->value
3188 && !sym->attr.data
3189 && sym->attr.save == SAVE_NONE)
3190 fnbody = gfc_init_default_dt (sym, fnbody, false);
3191
3192 gfc_get_backend_locus (&loc);
3193 gfc_set_backend_locus (&sym->declared_at);
3194 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3195 sym, fnbody);
3196 gfc_set_backend_locus (&loc);
3197 }
3198 break;
3199
3200 case AS_ASSUMED_SIZE:
3201 /* Must be a dummy parameter. */
3202 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3203
3204 /* We should always pass assumed size arrays the g77 way. */
3205 if (sym->attr.dummy)
3206 fnbody = gfc_trans_g77_array (sym, fnbody);
3207 break;
3208
3209 case AS_ASSUMED_SHAPE:
3210 /* Must be a dummy parameter. */
3211 gcc_assert (sym->attr.dummy);
3212
3213 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3214 fnbody);
3215 break;
3216
3217 case AS_DEFERRED:
3218 seen_trans_deferred_array = true;
3219 fnbody = gfc_trans_deferred_array (sym, fnbody);
3220 break;
3221
3222 default:
3223 gcc_unreachable ();
3224 }
3225 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3226 fnbody = gfc_trans_deferred_array (sym, fnbody);
3227 }
3228 else if (sym_has_alloc_comp)
3229 fnbody = gfc_trans_deferred_array (sym, fnbody);
3230 else if (sym->attr.allocatable
3231 || (sym->ts.type == BT_CLASS
3232 && sym->ts.u.derived->components->attr.allocatable))
3233 {
3234 if (!sym->attr.save)
3235 {
3236 /* Nullify and automatic deallocation of allocatable
3237 scalars. */
3238 tree tmp;
3239 gfc_expr *e;
3240 gfc_se se;
3241 stmtblock_t block;
3242
3243 e = gfc_lval_expr_from_sym (sym);
3244 if (sym->ts.type == BT_CLASS)
3245 gfc_add_component_ref (e, "$data");
3246
3247 gfc_init_se (&se, NULL);
3248 se.want_pointer = 1;
3249 gfc_conv_expr (&se, e);
3250 gfc_free_expr (e);
3251
3252 /* Nullify when entering the scope. */
3253 gfc_start_block (&block);
3254 gfc_add_modify (&block, se.expr,
3255 fold_convert (TREE_TYPE (se.expr),
3256 null_pointer_node));
3257 gfc_add_expr_to_block (&block, fnbody);
3258
3259 /* Deallocate when leaving the scope. Nullifying is not
3260 needed. */
3261 tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
3262 NULL);
3263 gfc_add_expr_to_block (&block, tmp);
3264 fnbody = gfc_finish_block (&block);
3265 }
3266 }
3267 else if (sym->ts.type == BT_CHARACTER)
3268 {
3269 gfc_get_backend_locus (&loc);
3270 gfc_set_backend_locus (&sym->declared_at);
3271 if (sym->attr.dummy || sym->attr.result)
3272 fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
3273 else
3274 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3275 gfc_set_backend_locus (&loc);
3276 }
3277 else if (sym->attr.assign)
3278 {
3279 gfc_get_backend_locus (&loc);
3280 gfc_set_backend_locus (&sym->declared_at);
3281 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3282 gfc_set_backend_locus (&loc);
3283 }
3284 else if (sym->ts.type == BT_DERIVED
3285 && sym->value
3286 && !sym->attr.data
3287 && sym->attr.save == SAVE_NONE)
3288 fnbody = gfc_init_default_dt (sym, fnbody, false);
3289 else
3290 gcc_unreachable ();
3291 }
3292
3293 gfc_init_block (&body);
3294
3295 for (f = proc_sym->formal; f; f = f->next)
3296 {
3297 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3298 {
3299 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3300 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3301 gfc_trans_vla_type_sizes (f->sym, &body);
3302 }
3303 }
3304
3305 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3306 && current_fake_result_decl != NULL)
3307 {
3308 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3309 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3310 gfc_trans_vla_type_sizes (proc_sym, &body);
3311 }
3312
3313 gfc_add_expr_to_block (&body, fnbody);
3314 return gfc_finish_block (&body);
3315 }
3316
3317 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3318
3319 /* Hash and equality functions for module_htab. */
3320
3321 static hashval_t
3322 module_htab_do_hash (const void *x)
3323 {
3324 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3325 }
3326
3327 static int
3328 module_htab_eq (const void *x1, const void *x2)
3329 {
3330 return strcmp ((((const struct module_htab_entry *)x1)->name),
3331 (const char *)x2) == 0;
3332 }
3333
3334 /* Hash and equality functions for module_htab's decls. */
3335
3336 static hashval_t
3337 module_htab_decls_hash (const void *x)
3338 {
3339 const_tree t = (const_tree) x;
3340 const_tree n = DECL_NAME (t);
3341 if (n == NULL_TREE)
3342 n = TYPE_NAME (TREE_TYPE (t));
3343 return htab_hash_string (IDENTIFIER_POINTER (n));
3344 }
3345
3346 static int
3347 module_htab_decls_eq (const void *x1, const void *x2)
3348 {
3349 const_tree t1 = (const_tree) x1;
3350 const_tree n1 = DECL_NAME (t1);
3351 if (n1 == NULL_TREE)
3352 n1 = TYPE_NAME (TREE_TYPE (t1));
3353 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3354 }
3355
3356 struct module_htab_entry *
3357 gfc_find_module (const char *name)
3358 {
3359 void **slot;
3360
3361 if (! module_htab)
3362 module_htab = htab_create_ggc (10, module_htab_do_hash,
3363 module_htab_eq, NULL);
3364
3365 slot = htab_find_slot_with_hash (module_htab, name,
3366 htab_hash_string (name), INSERT);
3367 if (*slot == NULL)
3368 {
3369 struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3370
3371 entry->name = gfc_get_string (name);
3372 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3373 module_htab_decls_eq, NULL);
3374 *slot = (void *) entry;
3375 }
3376 return (struct module_htab_entry *) *slot;
3377 }
3378
3379 void
3380 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3381 {
3382 void **slot;
3383 const char *name;
3384
3385 if (DECL_NAME (decl))
3386 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3387 else
3388 {
3389 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3390 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3391 }
3392 slot = htab_find_slot_with_hash (entry->decls, name,
3393 htab_hash_string (name), INSERT);
3394 if (*slot == NULL)
3395 *slot = (void *) decl;
3396 }
3397
3398 static struct module_htab_entry *cur_module;
3399
3400 /* Output an initialized decl for a module variable. */
3401
3402 static void
3403 gfc_create_module_variable (gfc_symbol * sym)
3404 {
3405 tree decl;
3406
3407 /* Module functions with alternate entries are dealt with later and
3408 would get caught by the next condition. */
3409 if (sym->attr.entry)
3410 return;
3411
3412 /* Make sure we convert the types of the derived types from iso_c_binding
3413 into (void *). */
3414 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3415 && sym->ts.type == BT_DERIVED)
3416 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3417
3418 if (sym->attr.flavor == FL_DERIVED
3419 && sym->backend_decl
3420 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3421 {
3422 decl = sym->backend_decl;
3423 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3424
3425 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3426 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3427 {
3428 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3429 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3430 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3431 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3432 == sym->ns->proc_name->backend_decl);
3433 }
3434 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3435 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3436 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3437 }
3438
3439 /* Only output variables, procedure pointers and array valued,
3440 or derived type, parameters. */
3441 if (sym->attr.flavor != FL_VARIABLE
3442 && !(sym->attr.flavor == FL_PARAMETER
3443 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3444 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3445 return;
3446
3447 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3448 {
3449 decl = sym->backend_decl;
3450 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3451 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3452 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3453 gfc_module_add_decl (cur_module, decl);
3454 }
3455
3456 /* Don't generate variables from other modules. Variables from
3457 COMMONs will already have been generated. */
3458 if (sym->attr.use_assoc || sym->attr.in_common)
3459 return;
3460
3461 /* Equivalenced variables arrive here after creation. */
3462 if (sym->backend_decl
3463 && (sym->equiv_built || sym->attr.in_equivalence))
3464 return;
3465
3466 if (sym->backend_decl && !sym->attr.vtab)
3467 internal_error ("backend decl for module variable %s already exists",
3468 sym->name);
3469
3470 /* We always want module variables to be created. */
3471 sym->attr.referenced = 1;
3472 /* Create the decl. */
3473 decl = gfc_get_symbol_decl (sym);
3474
3475 /* Create the variable. */
3476 pushdecl (decl);
3477 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3478 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3479 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3480 rest_of_decl_compilation (decl, 1, 0);
3481 gfc_module_add_decl (cur_module, decl);
3482
3483 /* Also add length of strings. */
3484 if (sym->ts.type == BT_CHARACTER)
3485 {
3486 tree length;
3487
3488 length = sym->ts.u.cl->backend_decl;
3489 gcc_assert (length || sym->attr.proc_pointer);
3490 if (length && !INTEGER_CST_P (length))
3491 {
3492 pushdecl (length);
3493 rest_of_decl_compilation (length, 1, 0);
3494 }
3495 }
3496 }
3497
3498 /* Emit debug information for USE statements. */
3499
3500 static void
3501 gfc_trans_use_stmts (gfc_namespace * ns)
3502 {
3503 gfc_use_list *use_stmt;
3504 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3505 {
3506 struct module_htab_entry *entry
3507 = gfc_find_module (use_stmt->module_name);
3508 gfc_use_rename *rent;
3509
3510 if (entry->namespace_decl == NULL)
3511 {
3512 entry->namespace_decl
3513 = build_decl (input_location,
3514 NAMESPACE_DECL,
3515 get_identifier (use_stmt->module_name),
3516 void_type_node);
3517 DECL_EXTERNAL (entry->namespace_decl) = 1;
3518 }
3519 gfc_set_backend_locus (&use_stmt->where);
3520 if (!use_stmt->only_flag)
3521 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3522 NULL_TREE,
3523 ns->proc_name->backend_decl,
3524 false);
3525 for (rent = use_stmt->rename; rent; rent = rent->next)
3526 {
3527 tree decl, local_name;
3528 void **slot;
3529
3530 if (rent->op != INTRINSIC_NONE)
3531 continue;
3532
3533 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3534 htab_hash_string (rent->use_name),
3535 INSERT);
3536 if (*slot == NULL)
3537 {
3538 gfc_symtree *st;
3539
3540 st = gfc_find_symtree (ns->sym_root,
3541 rent->local_name[0]
3542 ? rent->local_name : rent->use_name);
3543 gcc_assert (st);
3544
3545 /* Sometimes, generic interfaces wind up being over-ruled by a
3546 local symbol (see PR41062). */
3547 if (!st->n.sym->attr.use_assoc)
3548 continue;
3549
3550 if (st->n.sym->backend_decl
3551 && DECL_P (st->n.sym->backend_decl)
3552 && st->n.sym->module
3553 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3554 {
3555 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3556 || (TREE_CODE (st->n.sym->backend_decl)
3557 != VAR_DECL));
3558 decl = copy_node (st->n.sym->backend_decl);
3559 DECL_CONTEXT (decl) = entry->namespace_decl;
3560 DECL_EXTERNAL (decl) = 1;
3561 DECL_IGNORED_P (decl) = 0;
3562 DECL_INITIAL (decl) = NULL_TREE;
3563 }
3564 else
3565 {
3566 *slot = error_mark_node;
3567 htab_clear_slot (entry->decls, slot);
3568 continue;
3569 }
3570 *slot = decl;
3571 }
3572 decl = (tree) *slot;
3573 if (rent->local_name[0])
3574 local_name = get_identifier (rent->local_name);
3575 else
3576 local_name = NULL_TREE;
3577 gfc_set_backend_locus (&rent->where);
3578 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3579 ns->proc_name->backend_decl,
3580 !use_stmt->only_flag);
3581 }
3582 }
3583 }
3584
3585
3586 /* Return true if expr is a constant initializer that gfc_conv_initializer
3587 will handle. */
3588
3589 static bool
3590 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3591 bool pointer)
3592 {
3593 gfc_constructor *c;
3594 gfc_component *cm;
3595
3596 if (pointer)
3597 return true;
3598 else if (array)
3599 {
3600 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3601 return true;
3602 else if (expr->expr_type == EXPR_STRUCTURE)
3603 return check_constant_initializer (expr, ts, false, false);
3604 else if (expr->expr_type != EXPR_ARRAY)
3605 return false;
3606 for (c = gfc_constructor_first (expr->value.constructor);
3607 c; c = gfc_constructor_next (c))
3608 {
3609 if (c->iterator)
3610 return false;
3611 if (c->expr->expr_type == EXPR_STRUCTURE)
3612 {
3613 if (!check_constant_initializer (c->expr, ts, false, false))
3614 return false;
3615 }
3616 else if (c->expr->expr_type != EXPR_CONSTANT)
3617 return false;
3618 }
3619 return true;
3620 }
3621 else switch (ts->type)
3622 {
3623 case BT_DERIVED:
3624 if (expr->expr_type != EXPR_STRUCTURE)
3625 return false;
3626 cm = expr->ts.u.derived->components;
3627 for (c = gfc_constructor_first (expr->value.constructor);
3628 c; c = gfc_constructor_next (c), cm = cm->next)
3629 {
3630 if (!c->expr || cm->attr.allocatable)
3631 continue;
3632 if (!check_constant_initializer (c->expr, &cm->ts,
3633 cm->attr.dimension,
3634 cm->attr.pointer))
3635 return false;
3636 }
3637 return true;
3638 default:
3639 return expr->expr_type == EXPR_CONSTANT;
3640 }
3641 }
3642
3643 /* Emit debug info for parameters and unreferenced variables with
3644 initializers. */
3645
3646 static void
3647 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3648 {
3649 tree decl;
3650
3651 if (sym->attr.flavor != FL_PARAMETER
3652 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3653 return;
3654
3655 if (sym->backend_decl != NULL
3656 || sym->value == NULL
3657 || sym->attr.use_assoc
3658 || sym->attr.dummy
3659 || sym->attr.result
3660 || sym->attr.function
3661 || sym->attr.intrinsic
3662 || sym->attr.pointer
3663 || sym->attr.allocatable
3664 || sym->attr.cray_pointee
3665 || sym->attr.threadprivate
3666 || sym->attr.is_bind_c
3667 || sym->attr.subref_array_pointer
3668 || sym->attr.assign)
3669 return;
3670
3671 if (sym->ts.type == BT_CHARACTER)
3672 {
3673 gfc_conv_const_charlen (sym->ts.u.cl);
3674 if (sym->ts.u.cl->backend_decl == NULL
3675 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
3676 return;
3677 }
3678 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
3679 return;
3680
3681 if (sym->as)
3682 {
3683 int n;
3684
3685 if (sym->as->type != AS_EXPLICIT)
3686 return;
3687 for (n = 0; n < sym->as->rank; n++)
3688 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3689 || sym->as->upper[n] == NULL
3690 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3691 return;
3692 }
3693
3694 if (!check_constant_initializer (sym->value, &sym->ts,
3695 sym->attr.dimension, false))
3696 return;
3697
3698 /* Create the decl for the variable or constant. */
3699 decl = build_decl (input_location,
3700 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3701 gfc_sym_identifier (sym), gfc_sym_type (sym));
3702 if (sym->attr.flavor == FL_PARAMETER)
3703 TREE_READONLY (decl) = 1;
3704 gfc_set_decl_location (decl, &sym->declared_at);
3705 if (sym->attr.dimension)
3706 GFC_DECL_PACKED_ARRAY (decl) = 1;
3707 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3708 TREE_STATIC (decl) = 1;
3709 TREE_USED (decl) = 1;
3710 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3711 TREE_PUBLIC (decl) = 1;
3712 DECL_INITIAL (decl)
3713 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3714 sym->attr.dimension, 0);
3715 debug_hooks->global_decl (decl);
3716 }
3717
3718 /* Generate all the required code for module variables. */
3719
3720 void
3721 gfc_generate_module_vars (gfc_namespace * ns)
3722 {
3723 module_namespace = ns;
3724 cur_module = gfc_find_module (ns->proc_name->name);
3725
3726 /* Check if the frontend left the namespace in a reasonable state. */
3727 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3728
3729 /* Generate COMMON blocks. */
3730 gfc_trans_common (ns);
3731
3732 /* Create decls for all the module variables. */
3733 gfc_traverse_ns (ns, gfc_create_module_variable);
3734
3735 cur_module = NULL;
3736
3737 gfc_trans_use_stmts (ns);
3738 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3739 }
3740
3741
3742 static void
3743 gfc_generate_contained_functions (gfc_namespace * parent)
3744 {
3745 gfc_namespace *ns;
3746
3747 /* We create all the prototypes before generating any code. */
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_create_function_decl (ns);
3755 }
3756
3757 for (ns = parent->contained; ns; ns = ns->sibling)
3758 {
3759 /* Skip namespaces from used modules. */
3760 if (ns->parent != parent)
3761 continue;
3762
3763 gfc_generate_function_code (ns);
3764 }
3765 }
3766
3767
3768 /* Drill down through expressions for the array specification bounds and
3769 character length calling generate_local_decl for all those variables
3770 that have not already been declared. */
3771
3772 static void
3773 generate_local_decl (gfc_symbol *);
3774
3775 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3776
3777 static bool
3778 expr_decls (gfc_expr *e, gfc_symbol *sym,
3779 int *f ATTRIBUTE_UNUSED)
3780 {
3781 if (e->expr_type != EXPR_VARIABLE
3782 || sym == e->symtree->n.sym
3783 || e->symtree->n.sym->mark
3784 || e->symtree->n.sym->ns != sym->ns)
3785 return false;
3786
3787 generate_local_decl (e->symtree->n.sym);
3788 return false;
3789 }
3790
3791 static void
3792 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3793 {
3794 gfc_traverse_expr (e, sym, expr_decls, 0);
3795 }
3796
3797
3798 /* Check for dependencies in the character length and array spec. */
3799
3800 static void
3801 generate_dependency_declarations (gfc_symbol *sym)
3802 {
3803 int i;
3804
3805 if (sym->ts.type == BT_CHARACTER
3806 && sym->ts.u.cl
3807 && sym->ts.u.cl->length
3808 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3809 generate_expr_decls (sym, sym->ts.u.cl->length);
3810
3811 if (sym->as && sym->as->rank)
3812 {
3813 for (i = 0; i < sym->as->rank; i++)
3814 {
3815 generate_expr_decls (sym, sym->as->lower[i]);
3816 generate_expr_decls (sym, sym->as->upper[i]);
3817 }
3818 }
3819 }
3820
3821
3822 /* Generate decls for all local variables. We do this to ensure correct
3823 handling of expressions which only appear in the specification of
3824 other functions. */
3825
3826 static void
3827 generate_local_decl (gfc_symbol * sym)
3828 {
3829 if (sym->attr.flavor == FL_VARIABLE)
3830 {
3831 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3832 generate_dependency_declarations (sym);
3833
3834 if (sym->attr.referenced)
3835 gfc_get_symbol_decl (sym);
3836 /* INTENT(out) dummy arguments are likely meant to be set. */
3837 else if (warn_unused_variable
3838 && sym->attr.dummy
3839 && sym->attr.intent == INTENT_OUT)
3840 {
3841 if (!(sym->ts.type == BT_DERIVED
3842 && sym->ts.u.derived->components->initializer))
3843 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
3844 "but was not set", sym->name, &sym->declared_at);
3845 }
3846 /* Specific warning for unused dummy arguments. */
3847 else if (warn_unused_variable && sym->attr.dummy)
3848 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3849 &sym->declared_at);
3850 /* Warn for unused variables, but not if they're inside a common
3851 block or are use-associated. */
3852 else if (warn_unused_variable
3853 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3854 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3855 &sym->declared_at);
3856
3857 /* For variable length CHARACTER parameters, the PARM_DECL already
3858 references the length variable, so force gfc_get_symbol_decl
3859 even when not referenced. If optimize > 0, it will be optimized
3860 away anyway. But do this only after emitting -Wunused-parameter
3861 warning if requested. */
3862 if (sym->attr.dummy && !sym->attr.referenced
3863 && sym->ts.type == BT_CHARACTER
3864 && sym->ts.u.cl->backend_decl != NULL
3865 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
3866 {
3867 sym->attr.referenced = 1;
3868 gfc_get_symbol_decl (sym);
3869 }
3870
3871 /* INTENT(out) dummy arguments and result variables with allocatable
3872 components are reset by default and need to be set referenced to
3873 generate the code for nullification and automatic lengths. */
3874 if (!sym->attr.referenced
3875 && sym->ts.type == BT_DERIVED
3876 && sym->ts.u.derived->attr.alloc_comp
3877 && !sym->attr.pointer
3878 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
3879 ||
3880 (sym->attr.result && sym != sym->result)))
3881 {
3882 sym->attr.referenced = 1;
3883 gfc_get_symbol_decl (sym);
3884 }
3885
3886 /* Check for dependencies in the array specification and string
3887 length, adding the necessary declarations to the function. We
3888 mark the symbol now, as well as in traverse_ns, to prevent
3889 getting stuck in a circular dependency. */
3890 sym->mark = 1;
3891
3892 /* We do not want the middle-end to warn about unused parameters
3893 as this was already done above. */
3894 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3895 TREE_NO_WARNING(sym->backend_decl) = 1;
3896 }
3897 else if (sym->attr.flavor == FL_PARAMETER)
3898 {
3899 if (warn_unused_parameter
3900 && !sym->attr.referenced
3901 && !sym->attr.use_assoc)
3902 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3903 &sym->declared_at);
3904 }
3905 else if (sym->attr.flavor == FL_PROCEDURE)
3906 {
3907 /* TODO: move to the appropriate place in resolve.c. */
3908 if (warn_return_type
3909 && sym->attr.function
3910 && sym->result
3911 && sym != sym->result
3912 && !sym->result->attr.referenced
3913 && !sym->attr.use_assoc
3914 && sym->attr.if_source != IFSRC_IFBODY)
3915 {
3916 gfc_warning ("Return value '%s' of function '%s' declared at "
3917 "%L not set", sym->result->name, sym->name,
3918 &sym->result->declared_at);
3919
3920 /* Prevents "Unused variable" warning for RESULT variables. */
3921 sym->result->mark = 1;
3922 }
3923 }
3924
3925 if (sym->attr.dummy == 1)
3926 {
3927 /* Modify the tree type for scalar character dummy arguments of bind(c)
3928 procedures if they are passed by value. The tree type for them will
3929 be promoted to INTEGER_TYPE for the middle end, which appears to be
3930 what C would do with characters passed by-value. The value attribute
3931 implies the dummy is a scalar. */
3932 if (sym->attr.value == 1 && sym->backend_decl != NULL
3933 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3934 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3935 gfc_conv_scalar_char_value (sym, NULL, NULL);
3936 }
3937
3938 /* Make sure we convert the types of the derived types from iso_c_binding
3939 into (void *). */
3940 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3941 && sym->ts.type == BT_DERIVED)
3942 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3943 }
3944
3945 static void
3946 generate_local_vars (gfc_namespace * ns)
3947 {
3948 gfc_traverse_ns (ns, generate_local_decl);
3949 }
3950
3951
3952 /* Generate a switch statement to jump to the correct entry point. Also
3953 creates the label decls for the entry points. */
3954
3955 static tree
3956 gfc_trans_entry_master_switch (gfc_entry_list * el)
3957 {
3958 stmtblock_t block;
3959 tree label;
3960 tree tmp;
3961 tree val;
3962
3963 gfc_init_block (&block);
3964 for (; el; el = el->next)
3965 {
3966 /* Add the case label. */
3967 label = gfc_build_label_decl (NULL_TREE);
3968 val = build_int_cst (gfc_array_index_type, el->id);
3969 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3970 gfc_add_expr_to_block (&block, tmp);
3971
3972 /* And jump to the actual entry point. */
3973 label = gfc_build_label_decl (NULL_TREE);
3974 tmp = build1_v (GOTO_EXPR, label);
3975 gfc_add_expr_to_block (&block, tmp);
3976
3977 /* Save the label decl. */
3978 el->label = label;
3979 }
3980 tmp = gfc_finish_block (&block);
3981 /* The first argument selects the entry point. */
3982 val = DECL_ARGUMENTS (current_function_decl);
3983 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3984 return tmp;
3985 }
3986
3987
3988 /* Add code to string lengths of actual arguments passed to a function against
3989 the expected lengths of the dummy arguments. */
3990
3991 static void
3992 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
3993 {
3994 gfc_formal_arglist *formal;
3995
3996 for (formal = sym->formal; formal; formal = formal->next)
3997 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
3998 {
3999 enum tree_code comparison;
4000 tree cond;
4001 tree argname;
4002 gfc_symbol *fsym;
4003 gfc_charlen *cl;
4004 const char *message;
4005
4006 fsym = formal->sym;
4007 cl = fsym->ts.u.cl;
4008
4009 gcc_assert (cl);
4010 gcc_assert (cl->passed_length != NULL_TREE);
4011 gcc_assert (cl->backend_decl != NULL_TREE);
4012
4013 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4014 string lengths must match exactly. Otherwise, it is only required
4015 that the actual string length is *at least* the expected one.
4016 Sequence association allows for a mismatch of the string length
4017 if the actual argument is (part of) an array, but only if the
4018 dummy argument is an array. (See "Sequence association" in
4019 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4020 if (fsym->attr.pointer || fsym->attr.allocatable
4021 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4022 {
4023 comparison = NE_EXPR;
4024 message = _("Actual string length does not match the declared one"
4025 " for dummy argument '%s' (%ld/%ld)");
4026 }
4027 else if (fsym->as && fsym->as->rank != 0)
4028 continue;
4029 else
4030 {
4031 comparison = LT_EXPR;
4032 message = _("Actual string length is shorter than the declared one"
4033 " for dummy argument '%s' (%ld/%ld)");
4034 }
4035
4036 /* Build the condition. For optional arguments, an actual length
4037 of 0 is also acceptable if the associated string is NULL, which
4038 means the argument was not passed. */
4039 cond = fold_build2 (comparison, boolean_type_node,
4040 cl->passed_length, cl->backend_decl);
4041 if (fsym->attr.optional)
4042 {
4043 tree not_absent;
4044 tree not_0length;
4045 tree absent_failed;
4046
4047 not_0length = fold_build2 (NE_EXPR, boolean_type_node,
4048 cl->passed_length,
4049 fold_convert (gfc_charlen_type_node,
4050 integer_zero_node));
4051 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4052 fsym->attr.referenced = 1;
4053 not_absent = gfc_conv_expr_present (fsym);
4054
4055 absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
4056 not_0length, not_absent);
4057
4058 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4059 cond, absent_failed);
4060 }
4061
4062 /* Build the runtime check. */
4063 argname = gfc_build_cstring_const (fsym->name);
4064 argname = gfc_build_addr_expr (pchar_type_node, argname);
4065 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4066 message, argname,
4067 fold_convert (long_integer_type_node,
4068 cl->passed_length),
4069 fold_convert (long_integer_type_node,
4070 cl->backend_decl));
4071 }
4072 }
4073
4074
4075 static void
4076 create_main_function (tree fndecl)
4077 {
4078 tree old_context;
4079 tree ftn_main;
4080 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4081 stmtblock_t body;
4082
4083 old_context = current_function_decl;
4084
4085 if (old_context)
4086 {
4087 push_function_context ();
4088 saved_parent_function_decls = saved_function_decls;
4089 saved_function_decls = NULL_TREE;
4090 }
4091
4092 /* main() function must be declared with global scope. */
4093 gcc_assert (current_function_decl == NULL_TREE);
4094
4095 /* Declare the function. */
4096 tmp = build_function_type_list (integer_type_node, integer_type_node,
4097 build_pointer_type (pchar_type_node),
4098 NULL_TREE);
4099 main_identifier_node = get_identifier ("main");
4100 ftn_main = build_decl (input_location, FUNCTION_DECL,
4101 main_identifier_node, tmp);
4102 DECL_EXTERNAL (ftn_main) = 0;
4103 TREE_PUBLIC (ftn_main) = 1;
4104 TREE_STATIC (ftn_main) = 1;
4105 DECL_ATTRIBUTES (ftn_main)
4106 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4107
4108 /* Setup the result declaration (for "return 0"). */
4109 result_decl = build_decl (input_location,
4110 RESULT_DECL, NULL_TREE, integer_type_node);
4111 DECL_ARTIFICIAL (result_decl) = 1;
4112 DECL_IGNORED_P (result_decl) = 1;
4113 DECL_CONTEXT (result_decl) = ftn_main;
4114 DECL_RESULT (ftn_main) = result_decl;
4115
4116 pushdecl (ftn_main);
4117
4118 /* Get the arguments. */
4119
4120 arglist = NULL_TREE;
4121 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4122
4123 tmp = TREE_VALUE (typelist);
4124 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4125 DECL_CONTEXT (argc) = ftn_main;
4126 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4127 TREE_READONLY (argc) = 1;
4128 gfc_finish_decl (argc);
4129 arglist = chainon (arglist, argc);
4130
4131 typelist = TREE_CHAIN (typelist);
4132 tmp = TREE_VALUE (typelist);
4133 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4134 DECL_CONTEXT (argv) = ftn_main;
4135 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4136 TREE_READONLY (argv) = 1;
4137 DECL_BY_REFERENCE (argv) = 1;
4138 gfc_finish_decl (argv);
4139 arglist = chainon (arglist, argv);
4140
4141 DECL_ARGUMENTS (ftn_main) = arglist;
4142 current_function_decl = ftn_main;
4143 announce_function (ftn_main);
4144
4145 rest_of_decl_compilation (ftn_main, 1, 0);
4146 make_decl_rtl (ftn_main);
4147 init_function_start (ftn_main);
4148 pushlevel (0);
4149
4150 gfc_init_block (&body);
4151
4152 /* Call some libgfortran initialization routines, call then MAIN__(). */
4153
4154 /* Call _gfortran_set_args (argc, argv). */
4155 TREE_USED (argc) = 1;
4156 TREE_USED (argv) = 1;
4157 tmp = build_call_expr_loc (input_location,
4158 gfor_fndecl_set_args, 2, argc, argv);
4159 gfc_add_expr_to_block (&body, tmp);
4160
4161 /* Add a call to set_options to set up the runtime library Fortran
4162 language standard parameters. */
4163 {
4164 tree array_type, array, var;
4165
4166 /* Passing a new option to the library requires four modifications:
4167 + add it to the tree_cons list below
4168 + change the array size in the call to build_array_type
4169 + change the first argument to the library call
4170 gfor_fndecl_set_options
4171 + modify the library (runtime/compile_options.c)! */
4172
4173 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4174 gfc_option.warn_std), NULL_TREE);
4175 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4176 gfc_option.allow_std), array);
4177 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
4178 array);
4179 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4180 gfc_option.flag_dump_core), array);
4181 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4182 gfc_option.flag_backtrace), array);
4183 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4184 gfc_option.flag_sign_zero), array);
4185
4186 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4187 (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
4188
4189 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4190 gfc_option.flag_range_check), array);
4191
4192 array_type = build_array_type (integer_type_node,
4193 build_index_type (build_int_cst (NULL_TREE, 7)));
4194 array = build_constructor_from_list (array_type, nreverse (array));
4195 TREE_CONSTANT (array) = 1;
4196 TREE_STATIC (array) = 1;
4197
4198 /* Create a static variable to hold the jump table. */
4199 var = gfc_create_var (array_type, "options");
4200 TREE_CONSTANT (var) = 1;
4201 TREE_STATIC (var) = 1;
4202 TREE_READONLY (var) = 1;
4203 DECL_INITIAL (var) = array;
4204 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4205
4206 tmp = build_call_expr_loc (input_location,
4207 gfor_fndecl_set_options, 2,
4208 build_int_cst (integer_type_node, 8), var);
4209 gfc_add_expr_to_block (&body, tmp);
4210 }
4211
4212 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4213 the library will raise a FPE when needed. */
4214 if (gfc_option.fpe != 0)
4215 {
4216 tmp = build_call_expr_loc (input_location,
4217 gfor_fndecl_set_fpe, 1,
4218 build_int_cst (integer_type_node,
4219 gfc_option.fpe));
4220 gfc_add_expr_to_block (&body, tmp);
4221 }
4222
4223 /* If this is the main program and an -fconvert option was provided,
4224 add a call to set_convert. */
4225
4226 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4227 {
4228 tmp = build_call_expr_loc (input_location,
4229 gfor_fndecl_set_convert, 1,
4230 build_int_cst (integer_type_node,
4231 gfc_option.convert));
4232 gfc_add_expr_to_block (&body, tmp);
4233 }
4234
4235 /* If this is the main program and an -frecord-marker option was provided,
4236 add a call to set_record_marker. */
4237
4238 if (gfc_option.record_marker != 0)
4239 {
4240 tmp = build_call_expr_loc (input_location,
4241 gfor_fndecl_set_record_marker, 1,
4242 build_int_cst (integer_type_node,
4243 gfc_option.record_marker));
4244 gfc_add_expr_to_block (&body, tmp);
4245 }
4246
4247 if (gfc_option.max_subrecord_length != 0)
4248 {
4249 tmp = build_call_expr_loc (input_location,
4250 gfor_fndecl_set_max_subrecord_length, 1,
4251 build_int_cst (integer_type_node,
4252 gfc_option.max_subrecord_length));
4253 gfc_add_expr_to_block (&body, tmp);
4254 }
4255
4256 /* Call MAIN__(). */
4257 tmp = build_call_expr_loc (input_location,
4258 fndecl, 0);
4259 gfc_add_expr_to_block (&body, tmp);
4260
4261 /* Mark MAIN__ as used. */
4262 TREE_USED (fndecl) = 1;
4263
4264 /* "return 0". */
4265 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4266 build_int_cst (integer_type_node, 0));
4267 tmp = build1_v (RETURN_EXPR, tmp);
4268 gfc_add_expr_to_block (&body, tmp);
4269
4270
4271 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4272 decl = getdecls ();
4273
4274 /* Finish off this function and send it for code generation. */
4275 poplevel (1, 0, 1);
4276 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4277
4278 DECL_SAVED_TREE (ftn_main)
4279 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4280 DECL_INITIAL (ftn_main));
4281
4282 /* Output the GENERIC tree. */
4283 dump_function (TDI_original, ftn_main);
4284
4285 cgraph_finalize_function (ftn_main, true);
4286
4287 if (old_context)
4288 {
4289 pop_function_context ();
4290 saved_function_decls = saved_parent_function_decls;
4291 }
4292 current_function_decl = old_context;
4293 }
4294
4295
4296 /* Generate code for a function. */
4297
4298 void
4299 gfc_generate_function_code (gfc_namespace * ns)
4300 {
4301 tree fndecl;
4302 tree old_context;
4303 tree decl;
4304 tree tmp;
4305 tree tmp2;
4306 stmtblock_t block;
4307 stmtblock_t body;
4308 tree result;
4309 tree recurcheckvar = NULL_TREE;
4310 gfc_symbol *sym;
4311 int rank;
4312 bool is_recursive;
4313
4314 sym = ns->proc_name;
4315
4316 /* Check that the frontend isn't still using this. */
4317 gcc_assert (sym->tlink == NULL);
4318 sym->tlink = sym;
4319
4320 /* Create the declaration for functions with global scope. */
4321 if (!sym->backend_decl)
4322 gfc_create_function_decl (ns);
4323
4324 fndecl = sym->backend_decl;
4325 old_context = current_function_decl;
4326
4327 if (old_context)
4328 {
4329 push_function_context ();
4330 saved_parent_function_decls = saved_function_decls;
4331 saved_function_decls = NULL_TREE;
4332 }
4333
4334 trans_function_start (sym);
4335
4336 gfc_init_block (&block);
4337
4338 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4339 {
4340 /* Copy length backend_decls to all entry point result
4341 symbols. */
4342 gfc_entry_list *el;
4343 tree backend_decl;
4344
4345 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4346 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4347 for (el = ns->entries; el; el = el->next)
4348 el->sym->result->ts.u.cl->backend_decl = backend_decl;
4349 }
4350
4351 /* Translate COMMON blocks. */
4352 gfc_trans_common (ns);
4353
4354 /* Null the parent fake result declaration if this namespace is
4355 a module function or an external procedures. */
4356 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4357 || ns->parent == NULL)
4358 parent_fake_result_decl = NULL_TREE;
4359
4360 gfc_generate_contained_functions (ns);
4361
4362 nonlocal_dummy_decls = NULL;
4363 nonlocal_dummy_decl_pset = NULL;
4364
4365 generate_local_vars (ns);
4366
4367 /* Keep the parent fake result declaration in module functions
4368 or external procedures. */
4369 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4370 || ns->parent == NULL)
4371 current_fake_result_decl = parent_fake_result_decl;
4372 else
4373 current_fake_result_decl = NULL_TREE;
4374
4375 current_function_return_label = NULL;
4376
4377 /* Now generate the code for the body of this function. */
4378 gfc_init_block (&body);
4379
4380 is_recursive = sym->attr.recursive
4381 || (sym->attr.entry_master
4382 && sym->ns->entries->sym->attr.recursive);
4383 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4384 && !is_recursive
4385 && !gfc_option.flag_recursive)
4386 {
4387 char * msg;
4388
4389 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4390 sym->name);
4391 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4392 TREE_STATIC (recurcheckvar) = 1;
4393 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4394 gfc_add_expr_to_block (&block, recurcheckvar);
4395 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4396 &sym->declared_at, msg);
4397 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4398 gfc_free (msg);
4399 }
4400
4401 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4402 && sym->attr.subroutine)
4403 {
4404 tree alternate_return;
4405 alternate_return = gfc_get_fake_result_decl (sym, 0);
4406 gfc_add_modify (&body, alternate_return, integer_zero_node);
4407 }
4408
4409 if (ns->entries)
4410 {
4411 /* Jump to the correct entry point. */
4412 tmp = gfc_trans_entry_master_switch (ns->entries);
4413 gfc_add_expr_to_block (&body, tmp);
4414 }
4415
4416 /* If bounds-checking is enabled, generate code to check passed in actual
4417 arguments against the expected dummy argument attributes (e.g. string
4418 lengths). */
4419 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4420 add_argument_checking (&body, sym);
4421
4422 tmp = gfc_trans_code (ns->code);
4423 gfc_add_expr_to_block (&body, tmp);
4424
4425 /* Add a return label if needed. */
4426 if (current_function_return_label)
4427 {
4428 tmp = build1_v (LABEL_EXPR, current_function_return_label);
4429 gfc_add_expr_to_block (&body, tmp);
4430 }
4431
4432 tmp = gfc_finish_block (&body);
4433 /* Add code to create and cleanup arrays. */
4434 tmp = gfc_trans_deferred_vars (sym, tmp);
4435
4436 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4437 {
4438 if (sym->attr.subroutine || sym == sym->result)
4439 {
4440 if (current_fake_result_decl != NULL)
4441 result = TREE_VALUE (current_fake_result_decl);
4442 else
4443 result = NULL_TREE;
4444 current_fake_result_decl = NULL_TREE;
4445 }
4446 else
4447 result = sym->result->backend_decl;
4448
4449 if (result != NULL_TREE
4450 && sym->attr.function
4451 && !sym->attr.pointer)
4452 {
4453 if (sym->ts.type == BT_DERIVED
4454 && sym->ts.u.derived->attr.alloc_comp)
4455 {
4456 rank = sym->as ? sym->as->rank : 0;
4457 tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4458 gfc_add_expr_to_block (&block, tmp2);
4459 }
4460 else if (sym->attr.allocatable && sym->attr.dimension == 0)
4461 gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
4462 null_pointer_node));
4463 }
4464
4465 gfc_add_expr_to_block (&block, tmp);
4466
4467 /* Reset recursion-check variable. */
4468 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4469 && !is_recursive
4470 && !gfc_option.flag_openmp
4471 && recurcheckvar != NULL_TREE)
4472 {
4473 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4474 recurcheckvar = NULL;
4475 }
4476
4477 if (result == NULL_TREE)
4478 {
4479 /* TODO: move to the appropriate place in resolve.c. */
4480 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4481 gfc_warning ("Return value of function '%s' at %L not set",
4482 sym->name, &sym->declared_at);
4483
4484 TREE_NO_WARNING(sym->backend_decl) = 1;
4485 }
4486 else
4487 {
4488 /* Set the return value to the dummy result variable. The
4489 types may be different for scalar default REAL functions
4490 with -ff2c, therefore we have to convert. */
4491 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4492 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4493 DECL_RESULT (fndecl), tmp);
4494 tmp = build1_v (RETURN_EXPR, tmp);
4495 gfc_add_expr_to_block (&block, tmp);
4496 }
4497 }
4498 else
4499 {
4500 gfc_add_expr_to_block (&block, tmp);
4501 /* Reset recursion-check variable. */
4502 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4503 && !is_recursive
4504 && !gfc_option.flag_openmp
4505 && recurcheckvar != NULL_TREE)
4506 {
4507 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4508 recurcheckvar = NULL_TREE;
4509 }
4510 }
4511
4512
4513 /* Add all the decls we created during processing. */
4514 decl = saved_function_decls;
4515 while (decl)
4516 {
4517 tree next;
4518
4519 next = TREE_CHAIN (decl);
4520 TREE_CHAIN (decl) = NULL_TREE;
4521 pushdecl (decl);
4522 decl = next;
4523 }
4524 saved_function_decls = NULL_TREE;
4525
4526 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4527 decl = getdecls ();
4528
4529 /* Finish off this function and send it for code generation. */
4530 poplevel (1, 0, 1);
4531 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4532
4533 DECL_SAVED_TREE (fndecl)
4534 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4535 DECL_INITIAL (fndecl));
4536
4537 if (nonlocal_dummy_decls)
4538 {
4539 BLOCK_VARS (DECL_INITIAL (fndecl))
4540 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4541 pointer_set_destroy (nonlocal_dummy_decl_pset);
4542 nonlocal_dummy_decls = NULL;
4543 nonlocal_dummy_decl_pset = NULL;
4544 }
4545
4546 /* Output the GENERIC tree. */
4547 dump_function (TDI_original, fndecl);
4548
4549 /* Store the end of the function, so that we get good line number
4550 info for the epilogue. */
4551 cfun->function_end_locus = input_location;
4552
4553 /* We're leaving the context of this function, so zap cfun.
4554 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4555 tree_rest_of_compilation. */
4556 set_cfun (NULL);
4557
4558 if (old_context)
4559 {
4560 pop_function_context ();
4561 saved_function_decls = saved_parent_function_decls;
4562 }
4563 current_function_decl = old_context;
4564
4565 if (decl_function_context (fndecl))
4566 /* Register this function with cgraph just far enough to get it
4567 added to our parent's nested function list. */
4568 (void) cgraph_node (fndecl);
4569 else
4570 cgraph_finalize_function (fndecl, true);
4571
4572 gfc_trans_use_stmts (ns);
4573 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4574
4575 if (sym->attr.is_main_program)
4576 create_main_function (fndecl);
4577 }
4578
4579
4580 void
4581 gfc_generate_constructors (void)
4582 {
4583 gcc_assert (gfc_static_ctors == NULL_TREE);
4584 #if 0
4585 tree fnname;
4586 tree type;
4587 tree fndecl;
4588 tree decl;
4589 tree tmp;
4590
4591 if (gfc_static_ctors == NULL_TREE)
4592 return;
4593
4594 fnname = get_file_function_name ("I");
4595 type = build_function_type (void_type_node,
4596 gfc_chainon_list (NULL_TREE, void_type_node));
4597
4598 fndecl = build_decl (input_location,
4599 FUNCTION_DECL, fnname, type);
4600 TREE_PUBLIC (fndecl) = 1;
4601
4602 decl = build_decl (input_location,
4603 RESULT_DECL, NULL_TREE, void_type_node);
4604 DECL_ARTIFICIAL (decl) = 1;
4605 DECL_IGNORED_P (decl) = 1;
4606 DECL_CONTEXT (decl) = fndecl;
4607 DECL_RESULT (fndecl) = decl;
4608
4609 pushdecl (fndecl);
4610
4611 current_function_decl = fndecl;
4612
4613 rest_of_decl_compilation (fndecl, 1, 0);
4614
4615 make_decl_rtl (fndecl);
4616
4617 init_function_start (fndecl);
4618
4619 pushlevel (0);
4620
4621 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4622 {
4623 tmp = build_call_expr_loc (input_location,
4624 TREE_VALUE (gfc_static_ctors), 0);
4625 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4626 }
4627
4628 decl = getdecls ();
4629 poplevel (1, 0, 1);
4630
4631 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4632 DECL_SAVED_TREE (fndecl)
4633 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4634 DECL_INITIAL (fndecl));
4635
4636 free_after_parsing (cfun);
4637 free_after_compilation (cfun);
4638
4639 tree_rest_of_compilation (fndecl);
4640
4641 current_function_decl = NULL_TREE;
4642 #endif
4643 }
4644
4645 /* Translates a BLOCK DATA program unit. This means emitting the
4646 commons contained therein plus their initializations. We also emit
4647 a globally visible symbol to make sure that each BLOCK DATA program
4648 unit remains unique. */
4649
4650 void
4651 gfc_generate_block_data (gfc_namespace * ns)
4652 {
4653 tree decl;
4654 tree id;
4655
4656 /* Tell the backend the source location of the block data. */
4657 if (ns->proc_name)
4658 gfc_set_backend_locus (&ns->proc_name->declared_at);
4659 else
4660 gfc_set_backend_locus (&gfc_current_locus);
4661
4662 /* Process the DATA statements. */
4663 gfc_trans_common (ns);
4664
4665 /* Create a global symbol with the mane of the block data. This is to
4666 generate linker errors if the same name is used twice. It is never
4667 really used. */
4668 if (ns->proc_name)
4669 id = gfc_sym_mangled_function_id (ns->proc_name);
4670 else
4671 id = get_identifier ("__BLOCK_DATA__");
4672
4673 decl = build_decl (input_location,
4674 VAR_DECL, id, gfc_array_index_type);
4675 TREE_PUBLIC (decl) = 1;
4676 TREE_STATIC (decl) = 1;
4677 DECL_IGNORED_P (decl) = 1;
4678
4679 pushdecl (decl);
4680 rest_of_decl_compilation (decl, 1, 0);
4681 }
4682
4683
4684 /* Process the local variables of a BLOCK construct. */
4685
4686 void
4687 gfc_process_block_locals (gfc_namespace* ns)
4688 {
4689 tree decl;
4690
4691 gcc_assert (saved_local_decls == NULL_TREE);
4692 generate_local_vars (ns);
4693
4694 decl = saved_local_decls;
4695 while (decl)
4696 {
4697 tree next;
4698
4699 next = TREE_CHAIN (decl);
4700 TREE_CHAIN (decl) = NULL_TREE;
4701 pushdecl (decl);
4702 decl = next;
4703 }
4704 saved_local_decls = NULL_TREE;
4705 }
4706
4707
4708 #include "gt-fortran-trans-decl.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org