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