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