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