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