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