]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/trans-decl.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
2005-08-10 Andrew Haley <aph@redhat.com>
[thirdparty/gcc.git] / gcc / fortran / trans-decl.c
CommitLineData
4ee9c684 1/* Backend function setup
7b3423b9 2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
4ee9c684 3 Contributed by Paul Brook
4
c84b470d 5This file is part of GCC.
4ee9c684 6
c84b470d 7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 2, or (at your option) any later
10version.
4ee9c684 11
c84b470d 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
4ee9c684 16
17You should have received a copy of the GNU General Public License
c84b470d 18along with GCC; see the file COPYING. If not, write to the Free
30d4ffea 19Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
2002110-1301, USA. */
4ee9c684 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"
88bce636 29#include "tree-gimple.h"
4ee9c684 30#include "ggc.h"
31#include "toplev.h"
32#include "tm.h"
33#include "target.h"
34#include "function.h"
4ee9c684 35#include "flags.h"
36#include "cgraph.h"
4ee9c684 37#include "gfortran.h"
38#include "trans.h"
39#include "trans-types.h"
40#include "trans-array.h"
41#include "trans-const.h"
42/* Only for gfc_trans_code. Shouldn't need to include this. */
43#include "trans-stmt.h"
44
45#define MAX_LABEL_VALUE 99999
46
47
48/* Holds the result of the function if no result variable specified. */
49
50static GTY(()) tree current_fake_result_decl;
51
52static GTY(()) tree current_function_return_label;
53
54
55/* Holds the variable DECLs for the current function. */
56
57static GTY(()) tree saved_function_decls = NULL_TREE;
58static GTY(()) tree saved_parent_function_decls = NULL_TREE;
59
60
61/* The namespace of the module we're currently generating. Only used while
62 outputting decls for module variables. Do not rely on this being set. */
63
64static gfc_namespace *module_namespace;
65
66
67/* List of static constructor functions. */
68
69tree gfc_static_ctors;
70
71
72/* Function declarations for builtin library functions. */
73
74tree gfor_fndecl_internal_malloc;
75tree gfor_fndecl_internal_malloc64;
76tree gfor_fndecl_internal_free;
77tree gfor_fndecl_allocate;
78tree gfor_fndecl_allocate64;
79tree gfor_fndecl_deallocate;
80tree gfor_fndecl_pause_numeric;
81tree gfor_fndecl_pause_string;
82tree gfor_fndecl_stop_numeric;
83tree gfor_fndecl_stop_string;
84tree gfor_fndecl_select_string;
85tree gfor_fndecl_runtime_error;
86tree gfor_fndecl_in_pack;
87tree gfor_fndecl_in_unpack;
88tree gfor_fndecl_associated;
89
90
91/* Math functions. Many other math functions are handled in
92 trans-intrinsic.c. */
93
76834664 94gfc_powdecl_list gfor_fndecl_math_powi[3][2];
4ee9c684 95tree gfor_fndecl_math_cpowf;
96tree gfor_fndecl_math_cpow;
4ee9c684 97tree gfor_fndecl_math_ishftc4;
98tree gfor_fndecl_math_ishftc8;
99tree gfor_fndecl_math_exponent4;
100tree gfor_fndecl_math_exponent8;
101
102
103/* String functions. */
104
105tree gfor_fndecl_copy_string;
106tree gfor_fndecl_compare_string;
107tree gfor_fndecl_concat_string;
108tree gfor_fndecl_string_len_trim;
109tree gfor_fndecl_string_index;
110tree gfor_fndecl_string_scan;
111tree gfor_fndecl_string_verify;
112tree gfor_fndecl_string_trim;
113tree gfor_fndecl_string_repeat;
114tree gfor_fndecl_adjustl;
115tree gfor_fndecl_adjustr;
116
117
118/* Other misc. runtime library functions. */
119
120tree gfor_fndecl_size0;
121tree gfor_fndecl_size1;
9b057c29 122tree gfor_fndecl_iargc;
4ee9c684 123
124/* Intrinsic functions implemented in FORTRAN. */
125tree gfor_fndecl_si_kind;
126tree gfor_fndecl_sr_kind;
127
128
129static void
130gfc_add_decl_to_parent_function (tree decl)
131{
22d678e8 132 gcc_assert (decl);
4ee9c684 133 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
134 DECL_NONLOCAL (decl) = 1;
135 TREE_CHAIN (decl) = saved_parent_function_decls;
136 saved_parent_function_decls = decl;
137}
138
139void
140gfc_add_decl_to_function (tree decl)
141{
22d678e8 142 gcc_assert (decl);
4ee9c684 143 TREE_USED (decl) = 1;
144 DECL_CONTEXT (decl) = current_function_decl;
145 TREE_CHAIN (decl) = saved_function_decls;
146 saved_function_decls = decl;
147}
148
149
b797d6d3 150/* Build a backend label declaration. Set TREE_USED for named labels.
151 The context of the label is always the current_function_decl. All
152 labels are marked artificial. */
4ee9c684 153
154tree
155gfc_build_label_decl (tree label_id)
156{
157 /* 2^32 temporaries should be enough. */
158 static unsigned int tmp_num = 1;
159 tree label_decl;
160 char *label_name;
161
162 if (label_id == NULL_TREE)
163 {
164 /* Build an internal label name. */
165 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
166 label_id = get_identifier (label_name);
167 }
168 else
169 label_name = NULL;
170
171 /* Build the LABEL_DECL node. Labels have no type. */
172 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
173 DECL_CONTEXT (label_decl) = current_function_decl;
174 DECL_MODE (label_decl) = VOIDmode;
175
b797d6d3 176 /* We always define the label as used, even if the original source
177 file never references the label. We don't want all kinds of
178 spurious warnings for old-style Fortran code with too many
179 labels. */
180 TREE_USED (label_decl) = 1;
4ee9c684 181
b797d6d3 182 DECL_ARTIFICIAL (label_decl) = 1;
4ee9c684 183 return label_decl;
184}
185
186
187/* Returns the return label for the current function. */
188
189tree
190gfc_get_return_label (void)
191{
192 char name[GFC_MAX_SYMBOL_LEN + 10];
193
194 if (current_function_return_label)
195 return current_function_return_label;
196
197 sprintf (name, "__return_%s",
198 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
199
200 current_function_return_label =
201 gfc_build_label_decl (get_identifier (name));
202
203 DECL_ARTIFICIAL (current_function_return_label) = 1;
204
205 return current_function_return_label;
206}
207
208
b31f705b 209/* Set the backend source location of a decl. */
210
211void
212gfc_set_decl_location (tree decl, locus * loc)
213{
214#ifdef USE_MAPPED_LOCATION
215 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
216#else
217 DECL_SOURCE_LINE (decl) = loc->lb->linenum;
218 DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
219#endif
220}
221
222
4ee9c684 223/* Return the backend label declaration for a given label structure,
224 or create it if it doesn't exist yet. */
225
226tree
227gfc_get_label_decl (gfc_st_label * lp)
228{
4ee9c684 229 if (lp->backend_decl)
230 return lp->backend_decl;
231 else
232 {
233 char label_name[GFC_MAX_SYMBOL_LEN + 1];
234 tree label_decl;
235
236 /* Validate the label declaration from the front end. */
22d678e8 237 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
4ee9c684 238
239 /* Build a mangled name for the label. */
240 sprintf (label_name, "__label_%.6d", lp->value);
241
242 /* Build the LABEL_DECL node. */
243 label_decl = gfc_build_label_decl (get_identifier (label_name));
244
245 /* Tell the debugger where the label came from. */
f888a3fb 246 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
b31f705b 247 gfc_set_decl_location (label_decl, &lp->where);
4ee9c684 248 else
249 DECL_ARTIFICIAL (label_decl) = 1;
250
251 /* Store the label in the label list and return the LABEL_DECL. */
252 lp->backend_decl = label_decl;
253 return label_decl;
254 }
255}
256
257
258/* Convert a gfc_symbol to an identifier of the same name. */
259
260static tree
261gfc_sym_identifier (gfc_symbol * sym)
262{
263 return (get_identifier (sym->name));
264}
265
266
267/* Construct mangled name from symbol name. */
268
269static tree
270gfc_sym_mangled_identifier (gfc_symbol * sym)
271{
272 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
273
4f0fae8e 274 if (sym->module == NULL)
4ee9c684 275 return gfc_sym_identifier (sym);
276 else
277 {
278 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
279 return get_identifier (name);
280 }
281}
282
283
284/* Construct mangled function name from symbol name. */
285
286static tree
287gfc_sym_mangled_function_id (gfc_symbol * sym)
288{
289 int has_underscore;
290 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
291
4f0fae8e 292 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
293 || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
4ee9c684 294 {
295 if (strcmp (sym->name, "MAIN__") == 0
296 || sym->attr.proc == PROC_INTRINSIC)
297 return get_identifier (sym->name);
298
299 if (gfc_option.flag_underscoring)
300 {
301 has_underscore = strchr (sym->name, '_') != 0;
302 if (gfc_option.flag_second_underscore && has_underscore)
303 snprintf (name, sizeof name, "%s__", sym->name);
304 else
305 snprintf (name, sizeof name, "%s_", sym->name);
306 return get_identifier (name);
307 }
308 else
309 return get_identifier (sym->name);
310 }
311 else
312 {
313 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
314 return get_identifier (name);
315 }
316}
317
318
5ed82495 319/* Returns true if a variable of specified size should go on the stack. */
320
321int
322gfc_can_put_var_on_stack (tree size)
323{
324 unsigned HOST_WIDE_INT low;
325
326 if (!INTEGER_CST_P (size))
327 return 0;
328
329 if (gfc_option.flag_max_stack_var_size < 0)
330 return 1;
331
332 if (TREE_INT_CST_HIGH (size) != 0)
333 return 0;
334
335 low = TREE_INT_CST_LOW (size);
336 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
337 return 0;
338
339/* TODO: Set a per-function stack size limit. */
340
341 return 1;
342}
343
344
4ee9c684 345/* Finish processing of a declaration and install its initial value. */
346
347static void
348gfc_finish_decl (tree decl, tree init)
349{
350 if (TREE_CODE (decl) == PARM_DECL)
22d678e8 351 gcc_assert (init == NULL_TREE);
4ee9c684 352 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
353 -- it overlaps DECL_ARG_TYPE. */
354 else if (init == NULL_TREE)
22d678e8 355 gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
4ee9c684 356 else
22d678e8 357 gcc_assert (DECL_INITIAL (decl) == error_mark_node);
4ee9c684 358
359 if (init != NULL_TREE)
360 {
361 if (TREE_CODE (decl) != TYPE_DECL)
362 DECL_INITIAL (decl) = init;
363 else
364 {
365 /* typedef foo = bar; store the type of bar as the type of foo. */
366 TREE_TYPE (decl) = TREE_TYPE (init);
367 DECL_INITIAL (decl) = init = 0;
368 }
369 }
370
371 if (TREE_CODE (decl) == VAR_DECL)
372 {
373 if (DECL_SIZE (decl) == NULL_TREE
374 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
375 layout_decl (decl, 0);
376
377 /* A static variable with an incomplete type is an error if it is
378 initialized. Also if it is not file scope. Otherwise, let it
379 through, but if it is not `extern' then it may cause an error
380 message later. */
381 /* An automatic variable with an incomplete type is an error. */
382 if (DECL_SIZE (decl) == NULL_TREE
383 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
384 || DECL_CONTEXT (decl) != 0)
385 : !DECL_EXTERNAL (decl)))
386 {
387 gfc_fatal_error ("storage size not known");
388 }
389
390 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
391 && (DECL_SIZE (decl) != 0)
392 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
393 {
394 gfc_fatal_error ("storage size not constant");
395 }
396 }
397
398}
399
400
401/* Apply symbol attributes to a variable, and add it to the function scope. */
402
403static void
404gfc_finish_var_decl (tree decl, gfc_symbol * sym)
405{
f888a3fb 406 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
4ee9c684 407 This is the equivalent of the TARGET variables.
408 We also need to set this if the variable is passed by reference in a
409 CALL statement. */
410 if (sym->attr.target)
411 TREE_ADDRESSABLE (decl) = 1;
412 /* If it wasn't used we wouldn't be getting it. */
413 TREE_USED (decl) = 1;
414
415 /* Chain this decl to the pending declarations. Don't do pushdecl()
416 because this would add them to the current scope rather than the
417 function scope. */
418 if (current_function_decl != NULL_TREE)
419 {
420 if (sym->ns->proc_name->backend_decl == current_function_decl)
421 gfc_add_decl_to_function (decl);
422 else
423 gfc_add_decl_to_parent_function (decl);
424 }
425
426 /* If a variable is USE associated, it's always external. */
427 if (sym->attr.use_assoc)
428 {
429 DECL_EXTERNAL (decl) = 1;
430 TREE_PUBLIC (decl) = 1;
431 }
4f0fae8e 432 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
4ee9c684 433 {
6b20224d 434 /* TODO: Don't set sym->module for result or dummy variables. */
22d678e8 435 gcc_assert (current_function_decl == NULL_TREE);
4ee9c684 436 /* This is the declaration of a module variable. */
437 TREE_PUBLIC (decl) = 1;
438 TREE_STATIC (decl) = 1;
439 }
440
441 if ((sym->attr.save || sym->attr.data || sym->value)
442 && !sym->attr.use_assoc)
443 TREE_STATIC (decl) = 1;
444
445 /* Keep variables larger than max-stack-var-size off stack. */
446 if (!sym->ns->proc_name->attr.recursive
447 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
448 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
449 TREE_STATIC (decl) = 1;
450}
451
452
453/* Allocate the lang-specific part of a decl. */
454
455void
456gfc_allocate_lang_decl (tree decl)
457{
458 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
459 ggc_alloc_cleared (sizeof (struct lang_decl));
460}
461
462/* Remember a symbol to generate initialization/cleanup code at function
463 entry/exit. */
464
465static void
466gfc_defer_symbol_init (gfc_symbol * sym)
467{
468 gfc_symbol *p;
469 gfc_symbol *last;
470 gfc_symbol *head;
471
472 /* Don't add a symbol twice. */
473 if (sym->tlink)
474 return;
475
476 last = head = sym->ns->proc_name;
477 p = last->tlink;
478
479 /* Make sure that setup code for dummy variables which are used in the
480 setup of other variables is generated first. */
481 if (sym->attr.dummy)
482 {
483 /* Find the first dummy arg seen after us, or the first non-dummy arg.
484 This is a circular list, so don't go past the head. */
485 while (p != head
486 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
487 {
488 last = p;
489 p = p->tlink;
490 }
491 }
492 /* Insert in between last and p. */
493 last->tlink = sym;
494 sym->tlink = p;
495}
496
497
498/* Create an array index type variable with function scope. */
499
500static tree
501create_index_var (const char * pfx, int nest)
502{
503 tree decl;
504
505 decl = gfc_create_var_np (gfc_array_index_type, pfx);
506 if (nest)
507 gfc_add_decl_to_parent_function (decl);
508 else
509 gfc_add_decl_to_function (decl);
510 return decl;
511}
512
513
514/* Create variables to hold all the non-constant bits of info for a
515 descriptorless array. Remember these in the lang-specific part of the
516 type. */
517
518static void
519gfc_build_qualified_array (tree decl, gfc_symbol * sym)
520{
521 tree type;
522 int dim;
523 int nest;
524
525 type = TREE_TYPE (decl);
526
527 /* We just use the descriptor, if there is one. */
528 if (GFC_DESCRIPTOR_TYPE_P (type))
529 return;
530
22d678e8 531 gcc_assert (GFC_ARRAY_TYPE_P (type));
4ee9c684 532 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
533 && !sym->attr.contained;
534
535 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
536 {
537 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
538 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
9ca15c9b 539 /* Don't try to use the unknown bound for assumed shape arrays. */
4ee9c684 540 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
541 && (sym->as->type != AS_ASSUMED_SIZE
542 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
543 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
544
545 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
546 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
547 }
548 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
549 {
550 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
551 "offset");
552 if (nest)
553 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
554 else
555 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
556 }
557}
558
559
560/* For some dummy arguments we don't use the actual argument directly.
5ed82495 561 Instead we create a local decl and use that. This allows us to perform
4ee9c684 562 initialization, and construct full type information. */
563
564static tree
565gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
566{
567 tree decl;
568 tree type;
569 gfc_array_spec *as;
570 char *name;
571 int packed;
572 int n;
573 bool known_size;
574
575 if (sym->attr.pointer || sym->attr.allocatable)
576 return dummy;
577
578 /* Add to list of variables if not a fake result variable. */
579 if (sym->attr.result || sym->attr.dummy)
580 gfc_defer_symbol_init (sym);
581
582 type = TREE_TYPE (dummy);
22d678e8 583 gcc_assert (TREE_CODE (dummy) == PARM_DECL
4ee9c684 584 && POINTER_TYPE_P (type));
585
f888a3fb 586 /* Do we know the element size? */
4ee9c684 587 known_size = sym->ts.type != BT_CHARACTER
588 || INTEGER_CST_P (sym->ts.cl->backend_decl);
589
590 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
591 {
592 /* For descriptorless arrays with known element size the actual
593 argument is sufficient. */
22d678e8 594 gcc_assert (GFC_ARRAY_TYPE_P (type));
4ee9c684 595 gfc_build_qualified_array (dummy, sym);
596 return dummy;
597 }
598
599 type = TREE_TYPE (type);
600 if (GFC_DESCRIPTOR_TYPE_P (type))
601 {
602 /* Create a decriptorless array pointer. */
603 as = sym->as;
604 packed = 0;
605 if (!gfc_option.flag_repack_arrays)
606 {
607 if (as->type == AS_ASSUMED_SIZE)
608 packed = 2;
609 }
610 else
611 {
612 if (as->type == AS_EXPLICIT)
613 {
614 packed = 2;
615 for (n = 0; n < as->rank; n++)
616 {
617 if (!(as->upper[n]
618 && as->lower[n]
619 && as->upper[n]->expr_type == EXPR_CONSTANT
620 && as->lower[n]->expr_type == EXPR_CONSTANT))
621 packed = 1;
622 }
623 }
624 else
625 packed = 1;
626 }
627
628 type = gfc_typenode_for_spec (&sym->ts);
629 type = gfc_get_nodesc_array_type (type, sym->as, packed);
630 }
631 else
632 {
633 /* We now have an expression for the element size, so create a fully
634 qualified type. Reset sym->backend decl or this will just return the
635 old type. */
636 sym->backend_decl = NULL_TREE;
637 type = gfc_sym_type (sym);
638 packed = 2;
639 }
640
641 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
642 decl = build_decl (VAR_DECL, get_identifier (name), type);
643
644 DECL_ARTIFICIAL (decl) = 1;
645 TREE_PUBLIC (decl) = 0;
646 TREE_STATIC (decl) = 0;
647 DECL_EXTERNAL (decl) = 0;
648
649 /* We should never get deferred shape arrays here. We used to because of
650 frontend bugs. */
22d678e8 651 gcc_assert (sym->as->type != AS_DEFERRED);
4ee9c684 652
653 switch (packed)
654 {
655 case 1:
656 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
657 break;
658
659 case 2:
660 GFC_DECL_PACKED_ARRAY (decl) = 1;
661 break;
662 }
663
664 gfc_build_qualified_array (decl, sym);
665
666 if (DECL_LANG_SPECIFIC (dummy))
667 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
668 else
669 gfc_allocate_lang_decl (decl);
670
671 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
672
673 if (sym->ns->proc_name->backend_decl == current_function_decl
674 || sym->attr.contained)
675 gfc_add_decl_to_function (decl);
676 else
677 gfc_add_decl_to_parent_function (decl);
678
679 return decl;
680}
681
682
683/* Return a constant or a variable to use as a string length. Does not
684 add the decl to the current scope. */
685
686static tree
687gfc_create_string_length (gfc_symbol * sym)
688{
689 tree length;
690
22d678e8 691 gcc_assert (sym->ts.cl);
4ee9c684 692 gfc_conv_const_charlen (sym->ts.cl);
693
694 if (sym->ts.cl->backend_decl == NULL_TREE)
695 {
696 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
697
698 /* Also prefix the mangled name. */
699 strcpy (&name[1], sym->name);
700 name[0] = '.';
701 length = build_decl (VAR_DECL, get_identifier (name),
9ad09405 702 gfc_charlen_type_node);
4ee9c684 703 DECL_ARTIFICIAL (length) = 1;
704 TREE_USED (length) = 1;
705 gfc_defer_symbol_init (sym);
706 sym->ts.cl->backend_decl = length;
707 }
708
709 return sym->ts.cl->backend_decl;
710}
711
712
713/* Return the decl for a gfc_symbol, create it if it doesn't already
714 exist. */
715
716tree
717gfc_get_symbol_decl (gfc_symbol * sym)
718{
719 tree decl;
720 tree length = NULL_TREE;
4ee9c684 721 int byref;
722
22d678e8 723 gcc_assert (sym->attr.referenced);
4ee9c684 724
725 if (sym->ns && sym->ns->proc_name->attr.function)
726 byref = gfc_return_by_reference (sym->ns->proc_name);
727 else
728 byref = 0;
729
730 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
731 {
732 /* Return via extra parameter. */
733 if (sym->attr.result && byref
734 && !sym->backend_decl)
735 {
736 sym->backend_decl =
737 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
c6871095 738 /* For entry master function skip over the __entry
739 argument. */
740 if (sym->ns->proc_name->attr.entry_master)
741 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
4ee9c684 742 }
743
744 /* Dummy variables should already have been created. */
22d678e8 745 gcc_assert (sym->backend_decl);
4ee9c684 746
747 /* Create a character length variable. */
748 if (sym->ts.type == BT_CHARACTER)
749 {
750 if (sym->ts.cl->backend_decl == NULL_TREE)
751 {
752 length = gfc_create_string_length (sym);
753 if (TREE_CODE (length) != INTEGER_CST)
754 {
755 gfc_finish_var_decl (length, sym);
756 gfc_defer_symbol_init (sym);
757 }
758 }
759 }
760
761 /* Use a copy of the descriptor for dummy arrays. */
762 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
763 {
764 sym->backend_decl =
765 gfc_build_dummy_array_decl (sym, sym->backend_decl);
766 }
767
768 TREE_USED (sym->backend_decl) = 1;
769 return sym->backend_decl;
770 }
771
772 if (sym->backend_decl)
773 return sym->backend_decl;
774
4ee9c684 775 /* Catch function declarations. Only used for actual parameters. */
776 if (sym->attr.flavor == FL_PROCEDURE)
777 {
778 decl = gfc_get_extern_function_decl (sym);
779 return decl;
780 }
781
782 if (sym->attr.intrinsic)
783 internal_error ("intrinsic variable which isn't a procedure");
784
785 /* Create string length decl first so that they can be used in the
786 type declaration. */
787 if (sym->ts.type == BT_CHARACTER)
788 length = gfc_create_string_length (sym);
789
790 /* Create the decl for the variable. */
791 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
792
b31f705b 793 gfc_set_decl_location (decl, &sym->declared_at);
794
f888a3fb 795 /* Symbols from modules should have their assembler names mangled.
4ee9c684 796 This is done here rather than in gfc_finish_var_decl because it
797 is different for string length variables. */
4f0fae8e 798 if (sym->module)
4ee9c684 799 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
800
801 if (sym->attr.dimension)
802 {
803 /* Create variables to hold the non-constant bits of array info. */
804 gfc_build_qualified_array (decl, sym);
805
806 /* Remember this variable for allocation/cleanup. */
807 gfc_defer_symbol_init (sym);
808
809 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
810 GFC_DECL_PACKED_ARRAY (decl) = 1;
811 }
812
813 gfc_finish_var_decl (decl, sym);
814
815 if (sym->attr.assign)
816 {
817 gfc_allocate_lang_decl (decl);
818 GFC_DECL_ASSIGN (decl) = 1;
9ad09405 819 length = gfc_create_var (gfc_charlen_type_node, sym->name);
4ee9c684 820 GFC_DECL_STRING_LEN (decl) = length;
821 GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
822 /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
823 TREE_STATIC (length) = TREE_STATIC (decl);
824 /* STRING_LENGTH is also used as flag. Less than -1 means that
825 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
826 target label's address. Other value is the length of format string
827 and ASSIGN_ADDR is the address of format string. */
7016c612 828 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
4ee9c684 829 }
830
bda1f152 831 if (sym->ts.type == BT_CHARACTER)
4ee9c684 832 {
4ee9c684 833 /* Character variables need special handling. */
834 gfc_allocate_lang_decl (decl);
835
bda1f152 836 if (TREE_CODE (length) != INTEGER_CST)
4ee9c684 837 {
838 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
839
4f0fae8e 840 if (sym->module)
4ee9c684 841 {
842 /* Also prefix the mangled name for symbols from modules. */
843 strcpy (&name[1], sym->name);
844 name[0] = '.';
845 strcpy (&name[1],
846 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
847 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
848 }
849 gfc_finish_var_decl (length, sym);
22d678e8 850 gcc_assert (!sym->value);
4ee9c684 851 }
4ee9c684 852 }
853 sym->backend_decl = decl;
854
bda1f152 855 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
856 {
857 /* Add static initializer. */
858 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
859 TREE_TYPE (decl), sym->attr.dimension,
860 sym->attr.pointer || sym->attr.allocatable);
861 }
862
4ee9c684 863 return decl;
864}
865
866
dbe60343 867/* Substitute a temporary variable in place of the real one. */
868
869void
870gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
871{
872 save->attr = sym->attr;
873 save->decl = sym->backend_decl;
874
875 gfc_clear_attr (&sym->attr);
876 sym->attr.referenced = 1;
877 sym->attr.flavor = FL_VARIABLE;
878
879 sym->backend_decl = decl;
880}
881
882
883/* Restore the original variable. */
884
885void
886gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
887{
888 sym->attr = save->attr;
889 sym->backend_decl = save->decl;
890}
891
892
4ee9c684 893/* Get a basic decl for an external function. */
894
895tree
896gfc_get_extern_function_decl (gfc_symbol * sym)
897{
898 tree type;
899 tree fndecl;
900 gfc_expr e;
901 gfc_intrinsic_sym *isym;
902 gfc_expr argexpr;
bdaed7d2 903 char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'. */
4ee9c684 904 tree name;
905 tree mangled_name;
906
907 if (sym->backend_decl)
908 return sym->backend_decl;
909
1b716045 910 /* We should never be creating external decls for alternate entry points.
911 The procedure may be an alternate entry point, but we don't want/need
912 to know that. */
22d678e8 913 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1b716045 914
4ee9c684 915 if (sym->attr.intrinsic)
916 {
917 /* Call the resolution function to get the actual name. This is
918 a nasty hack which relies on the resolution functions only looking
919 at the first argument. We pass NULL for the second argument
920 otherwise things like AINT get confused. */
921 isym = gfc_find_function (sym->name);
22d678e8 922 gcc_assert (isym->resolve.f0 != NULL);
4ee9c684 923
924 memset (&e, 0, sizeof (e));
925 e.expr_type = EXPR_FUNCTION;
926
927 memset (&argexpr, 0, sizeof (argexpr));
22d678e8 928 gcc_assert (isym->formal);
4ee9c684 929 argexpr.ts = isym->formal->ts;
930
931 if (isym->formal->next == NULL)
932 isym->resolve.f1 (&e, &argexpr);
933 else
934 {
935 /* All specific intrinsics take one or two arguments. */
22d678e8 936 gcc_assert (isym->formal->next->next == NULL);
4ee9c684 937 isym->resolve.f2 (&e, &argexpr, NULL);
938 }
bdaed7d2 939
940 if (gfc_option.flag_f2c
941 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
942 || e.ts.type == BT_COMPLEX))
943 {
944 /* Specific which needs a different implementation if f2c
945 calling conventions are used. */
946 sprintf (s, "f2c_specific%s", e.value.function.name);
947 }
948 else
949 sprintf (s, "specific%s", e.value.function.name);
950
4ee9c684 951 name = get_identifier (s);
952 mangled_name = name;
953 }
954 else
955 {
956 name = gfc_sym_identifier (sym);
957 mangled_name = gfc_sym_mangled_function_id (sym);
958 }
959
960 type = gfc_get_function_type (sym);
961 fndecl = build_decl (FUNCTION_DECL, name, type);
962
963 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
964 /* If the return type is a pointer, avoid alias issues by setting
965 DECL_IS_MALLOC to nonzero. This means that the function should be
966 treated as if it were a malloc, meaning it returns a pointer that
967 is not an alias. */
968 if (POINTER_TYPE_P (type))
969 DECL_IS_MALLOC (fndecl) = 1;
970
971 /* Set the context of this decl. */
972 if (0 && sym->ns && sym->ns->proc_name)
973 {
974 /* TODO: Add external decls to the appropriate scope. */
975 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
976 }
977 else
978 {
f888a3fb 979 /* Global declaration, e.g. intrinsic subroutine. */
4ee9c684 980 DECL_CONTEXT (fndecl) = NULL_TREE;
981 }
982
983 DECL_EXTERNAL (fndecl) = 1;
984
f888a3fb 985 /* This specifies if a function is globally addressable, i.e. it is
4ee9c684 986 the opposite of declaring static in C. */
987 TREE_PUBLIC (fndecl) = 1;
988
989 /* Set attributes for PURE functions. A call to PURE function in the
990 Fortran 95 sense is both pure and without side effects in the C
991 sense. */
992 if (sym->attr.pure || sym->attr.elemental)
993 {
be393645 994 if (sym->attr.function)
995 DECL_IS_PURE (fndecl) = 1;
996 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
997 parameters and don't use alternate returns (is this
998 allowed?). In that case, calls to them are meaningless, and
1b716045 999 can be optimized away. See also in build_function_decl(). */
be393645 1000 TREE_SIDE_EFFECTS (fndecl) = 0;
4ee9c684 1001 }
1002
1003 sym->backend_decl = fndecl;
1004
1005 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1006 pushdecl_top_level (fndecl);
1007
1008 return fndecl;
1009}
1010
1011
1012/* Create a declaration for a procedure. For external functions (in the C
1b716045 1013 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1014 a master function with alternate entry points. */
4ee9c684 1015
1b716045 1016static void
1017build_function_decl (gfc_symbol * sym)
4ee9c684 1018{
1b716045 1019 tree fndecl, type;
4ee9c684 1020 symbol_attribute attr;
1b716045 1021 tree result_decl;
4ee9c684 1022 gfc_formal_arglist *f;
1023
22d678e8 1024 gcc_assert (!sym->backend_decl);
1025 gcc_assert (!sym->attr.external);
4ee9c684 1026
b31f705b 1027 /* Set the line and filename. sym->declared_at seems to point to the
1028 last statement for subroutines, but it'll do for now. */
1029 gfc_set_backend_locus (&sym->declared_at);
1030
4ee9c684 1031 /* Allow only one nesting level. Allow public declarations. */
22d678e8 1032 gcc_assert (current_function_decl == NULL_TREE
4ee9c684 1033 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1034
1035 type = gfc_get_function_type (sym);
1036 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1037
1038 /* Perform name mangling if this is a top level or module procedure. */
1039 if (current_function_decl == NULL_TREE)
1040 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1041
1042 /* Figure out the return type of the declared function, and build a
f888a3fb 1043 RESULT_DECL for it. If this is a subroutine with alternate
4ee9c684 1044 returns, build a RESULT_DECL for it. */
1045 attr = sym->attr;
1046
1047 result_decl = NULL_TREE;
1048 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1049 if (attr.function)
1050 {
1051 if (gfc_return_by_reference (sym))
1052 type = void_type_node;
1053 else
1054 {
1055 if (sym->result != sym)
1056 result_decl = gfc_sym_identifier (sym->result);
1057
1058 type = TREE_TYPE (TREE_TYPE (fndecl));
1059 }
1060 }
1061 else
1062 {
1063 /* Look for alternate return placeholders. */
1064 int has_alternate_returns = 0;
1065 for (f = sym->formal; f; f = f->next)
1066 {
1067 if (f->sym == NULL)
1068 {
1069 has_alternate_returns = 1;
1070 break;
1071 }
1072 }
1073
1074 if (has_alternate_returns)
1075 type = integer_type_node;
1076 else
1077 type = void_type_node;
1078 }
1079
1080 result_decl = build_decl (RESULT_DECL, result_decl, type);
540edea7 1081 DECL_ARTIFICIAL (result_decl) = 1;
1082 DECL_IGNORED_P (result_decl) = 1;
4ee9c684 1083 DECL_CONTEXT (result_decl) = fndecl;
1084 DECL_RESULT (fndecl) = result_decl;
1085
1086 /* Don't call layout_decl for a RESULT_DECL.
f888a3fb 1087 layout_decl (result_decl, 0); */
4ee9c684 1088
1089 /* If the return type is a pointer, avoid alias issues by setting
1090 DECL_IS_MALLOC to nonzero. This means that the function should be
1091 treated as if it were a malloc, meaning it returns a pointer that
1092 is not an alias. */
1093 if (POINTER_TYPE_P (type))
1094 DECL_IS_MALLOC (fndecl) = 1;
1095
1096 /* Set up all attributes for the function. */
1097 DECL_CONTEXT (fndecl) = current_function_decl;
1098 DECL_EXTERNAL (fndecl) = 0;
1099
9d138f47 1100 /* This specifies if a function is globally visible, i.e. it is
dfc222eb 1101 the opposite of declaring static in C. */
1b716045 1102 if (DECL_CONTEXT (fndecl) == NULL_TREE
1103 && !sym->attr.entry_master)
4ee9c684 1104 TREE_PUBLIC (fndecl) = 1;
1105
1106 /* TREE_STATIC means the function body is defined here. */
e4b2c26c 1107 TREE_STATIC (fndecl) = 1;
4ee9c684 1108
f888a3fb 1109 /* Set attributes for PURE functions. A call to a PURE function in the
4ee9c684 1110 Fortran 95 sense is both pure and without side effects in the C
1111 sense. */
1112 if (attr.pure || attr.elemental)
1113 {
be393645 1114 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1115 including a alternate return. In that case it can also be
231e961a 1116 marked as PURE. See also in gfc_get_extern_function_decl(). */
be393645 1117 if (attr.function)
1118 DECL_IS_PURE (fndecl) = 1;
4ee9c684 1119 TREE_SIDE_EFFECTS (fndecl) = 0;
1120 }
1121
1122 /* Layout the function declaration and put it in the binding level
1123 of the current function. */
e4b2c26c 1124 pushdecl (fndecl);
1b716045 1125
1126 sym->backend_decl = fndecl;
1127}
1128
1129
1130/* Create the DECL_ARGUMENTS for a procedure. */
1131
1132static void
1133create_function_arglist (gfc_symbol * sym)
1134{
1135 tree fndecl;
1136 gfc_formal_arglist *f;
1137 tree typelist;
1138 tree arglist;
1139 tree length;
1140 tree type;
1141 tree parm;
1142
1143 fndecl = sym->backend_decl;
1144
e4b2c26c 1145 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1146 the new FUNCTION_DECL node. */
e4b2c26c 1147 arglist = NULL_TREE;
1148 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1b716045 1149
1150 if (sym->attr.entry_master)
1151 {
1152 type = TREE_VALUE (typelist);
1153 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1154
1155 DECL_CONTEXT (parm) = fndecl;
1156 DECL_ARG_TYPE (parm) = type;
1157 TREE_READONLY (parm) = 1;
1158 gfc_finish_decl (parm, NULL_TREE);
1159
1160 arglist = chainon (arglist, parm);
1161 typelist = TREE_CHAIN (typelist);
1162 }
1163
e4b2c26c 1164 if (gfc_return_by_reference (sym))
4ee9c684 1165 {
e4b2c26c 1166 type = TREE_VALUE (typelist);
1167 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
4ee9c684 1168
e4b2c26c 1169 DECL_CONTEXT (parm) = fndecl;
1170 DECL_ARG_TYPE (parm) = type;
1171 TREE_READONLY (parm) = 1;
b5b40b3f 1172 DECL_ARTIFICIAL (parm) = 1;
e4b2c26c 1173 gfc_finish_decl (parm, NULL_TREE);
4ee9c684 1174
e4b2c26c 1175 arglist = chainon (arglist, parm);
1176 typelist = TREE_CHAIN (typelist);
4ee9c684 1177
e4b2c26c 1178 if (sym->ts.type == BT_CHARACTER)
1179 {
1180 gfc_allocate_lang_decl (parm);
4ee9c684 1181
e4b2c26c 1182 /* Length of character result. */
1183 type = TREE_VALUE (typelist);
22d678e8 1184 gcc_assert (type == gfc_charlen_type_node);
4ee9c684 1185
e4b2c26c 1186 length = build_decl (PARM_DECL,
1187 get_identifier (".__result"),
1188 type);
1189 if (!sym->ts.cl->length)
1190 {
1191 sym->ts.cl->backend_decl = length;
1192 TREE_USED (length) = 1;
4ee9c684 1193 }
22d678e8 1194 gcc_assert (TREE_CODE (length) == PARM_DECL);
e4b2c26c 1195 arglist = chainon (arglist, length);
1196 typelist = TREE_CHAIN (typelist);
1197 DECL_CONTEXT (length) = fndecl;
1198 DECL_ARG_TYPE (length) = type;
1199 TREE_READONLY (length) = 1;
b5b40b3f 1200 DECL_ARTIFICIAL (length) = 1;
e4b2c26c 1201 gfc_finish_decl (length, NULL_TREE);
4ee9c684 1202 }
e4b2c26c 1203 }
4ee9c684 1204
e4b2c26c 1205 for (f = sym->formal; f; f = f->next)
1206 {
f888a3fb 1207 if (f->sym != NULL) /* ignore alternate returns. */
4ee9c684 1208 {
e4b2c26c 1209 length = NULL_TREE;
4ee9c684 1210
e4b2c26c 1211 type = TREE_VALUE (typelist);
4ee9c684 1212
e4b2c26c 1213 /* Build a the argument declaration. */
1214 parm = build_decl (PARM_DECL,
1215 gfc_sym_identifier (f->sym), type);
4ee9c684 1216
e4b2c26c 1217 /* Fill in arg stuff. */
1218 DECL_CONTEXT (parm) = fndecl;
1219 DECL_ARG_TYPE (parm) = type;
e4b2c26c 1220 /* All implementation args are read-only. */
1221 TREE_READONLY (parm) = 1;
4ee9c684 1222
e4b2c26c 1223 gfc_finish_decl (parm, NULL_TREE);
4ee9c684 1224
e4b2c26c 1225 f->sym->backend_decl = parm;
4ee9c684 1226
e4b2c26c 1227 arglist = chainon (arglist, parm);
1228 typelist = TREE_CHAIN (typelist);
1229 }
1230 }
4ee9c684 1231
e4b2c26c 1232 /* Add the hidden string length parameters. */
1233 parm = arglist;
1234 for (f = sym->formal; f; f = f->next)
1235 {
1236 char name[GFC_MAX_SYMBOL_LEN + 2];
1237 /* Ignore alternate returns. */
1238 if (f->sym == NULL)
1239 continue;
4ee9c684 1240
e4b2c26c 1241 if (f->sym->ts.type != BT_CHARACTER)
1242 continue;
4ee9c684 1243
e4b2c26c 1244 parm = f->sym->backend_decl;
1245 type = TREE_VALUE (typelist);
22d678e8 1246 gcc_assert (type == gfc_charlen_type_node);
4ee9c684 1247
e4b2c26c 1248 strcpy (&name[1], f->sym->name);
1249 name[0] = '_';
1250 length = build_decl (PARM_DECL, get_identifier (name), type);
4ee9c684 1251
e4b2c26c 1252 arglist = chainon (arglist, length);
1253 DECL_CONTEXT (length) = fndecl;
b5b40b3f 1254 DECL_ARTIFICIAL (length) = 1;
e4b2c26c 1255 DECL_ARG_TYPE (length) = type;
1256 TREE_READONLY (length) = 1;
1257 gfc_finish_decl (length, NULL_TREE);
4ee9c684 1258
e4b2c26c 1259 /* TODO: Check string lengths when -fbounds-check. */
4ee9c684 1260
e4b2c26c 1261 /* Use the passed value for assumed length variables. */
1262 if (!f->sym->ts.cl->length)
1263 {
1264 TREE_USED (length) = 1;
1265 if (!f->sym->ts.cl->backend_decl)
1266 f->sym->ts.cl->backend_decl = length;
1267 else
4ee9c684 1268 {
e4b2c26c 1269 /* there is already another variable using this
1270 gfc_charlen node, build a new one for this variable
1271 and chain it into the list of gfc_charlens.
1272 This happens for e.g. in the case
1273 CHARACTER(*)::c1,c2
1274 since CHARACTER declarations on the same line share
1275 the same gfc_charlen node. */
1276 gfc_charlen *cl;
1277
1278 cl = gfc_get_charlen ();
1279 cl->backend_decl = length;
1280 cl->next = f->sym->ts.cl->next;
1281 f->sym->ts.cl->next = cl;
1282 f->sym->ts.cl = cl;
4ee9c684 1283 }
4ee9c684 1284 }
1285
e4b2c26c 1286 parm = TREE_CHAIN (parm);
1287 typelist = TREE_CHAIN (typelist);
4ee9c684 1288 }
e4b2c26c 1289
22d678e8 1290 gcc_assert (TREE_VALUE (typelist) == void_type_node);
e4b2c26c 1291 DECL_ARGUMENTS (fndecl) = arglist;
1b716045 1292}
e4b2c26c 1293
1b716045 1294/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1295
1296static void
1297gfc_gimplify_function (tree fndecl)
1298{
1299 struct cgraph_node *cgn;
1300
1301 gimplify_function_tree (fndecl);
1302 dump_function (TDI_generic, fndecl);
1303
1304 /* Convert all nested functions to GIMPLE now. We do things in this order
1305 so that items like VLA sizes are expanded properly in the context of the
1306 correct function. */
1307 cgn = cgraph_node (fndecl);
1308 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1309 gfc_gimplify_function (cgn->decl);
1310}
1311
1312
1313/* Do the setup necessary before generating the body of a function. */
1314
1315static void
1316trans_function_start (gfc_symbol * sym)
1317{
1318 tree fndecl;
1319
1320 fndecl = sym->backend_decl;
1321
f888a3fb 1322 /* Let GCC know the current scope is this function. */
1b716045 1323 current_function_decl = fndecl;
1324
f888a3fb 1325 /* Let the world know what we're about to do. */
1b716045 1326 announce_function (fndecl);
1327
1328 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1329 {
f888a3fb 1330 /* Create RTL for function declaration. */
1b716045 1331 rest_of_decl_compilation (fndecl, 1, 0);
1332 }
1333
f888a3fb 1334 /* Create RTL for function definition. */
1b716045 1335 make_decl_rtl (fndecl);
1336
1b716045 1337 init_function_start (fndecl);
1338
1339 /* Even though we're inside a function body, we still don't want to
1340 call expand_expr to calculate the size of a variable-sized array.
1341 We haven't necessarily assigned RTL to all variables yet, so it's
1342 not safe to try to expand expressions involving them. */
1343 cfun->x_dont_save_pending_sizes_p = 1;
1344
f888a3fb 1345 /* function.c requires a push at the start of the function. */
1b716045 1346 pushlevel (0);
1347}
1348
1349/* Create thunks for alternate entry points. */
1350
1351static void
1352build_entry_thunks (gfc_namespace * ns)
1353{
1354 gfc_formal_arglist *formal;
1355 gfc_formal_arglist *thunk_formal;
1356 gfc_entry_list *el;
1357 gfc_symbol *thunk_sym;
1358 stmtblock_t body;
1359 tree thunk_fndecl;
1360 tree args;
1361 tree string_args;
1362 tree tmp;
b31f705b 1363 locus old_loc;
1b716045 1364
1365 /* This should always be a toplevel function. */
22d678e8 1366 gcc_assert (current_function_decl == NULL_TREE);
1b716045 1367
b31f705b 1368 gfc_get_backend_locus (&old_loc);
1b716045 1369 for (el = ns->entries; el; el = el->next)
1370 {
1371 thunk_sym = el->sym;
1372
1373 build_function_decl (thunk_sym);
1374 create_function_arglist (thunk_sym);
1375
1376 trans_function_start (thunk_sym);
1377
1378 thunk_fndecl = thunk_sym->backend_decl;
1379
1380 gfc_start_block (&body);
1381
f888a3fb 1382 /* Pass extra parameter identifying this entry point. */
7016c612 1383 tmp = build_int_cst (gfc_array_index_type, el->id);
1b716045 1384 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1385 string_args = NULL_TREE;
1386
c6871095 1387 if (thunk_sym->attr.function)
1388 {
1389 if (gfc_return_by_reference (ns->proc_name))
1390 {
1391 tree ref = DECL_ARGUMENTS (current_function_decl);
1392 args = tree_cons (NULL_TREE, ref, args);
1393 if (ns->proc_name->ts.type == BT_CHARACTER)
1394 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1395 args);
1396 }
1397 }
1398
1b716045 1399 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1400 {
c6871095 1401 /* Ignore alternate returns. */
1402 if (formal->sym == NULL)
1403 continue;
1404
1b716045 1405 /* We don't have a clever way of identifying arguments, so resort to
1406 a brute-force search. */
1407 for (thunk_formal = thunk_sym->formal;
1408 thunk_formal;
1409 thunk_formal = thunk_formal->next)
1410 {
1411 if (thunk_formal->sym == formal->sym)
1412 break;
1413 }
1414
1415 if (thunk_formal)
1416 {
1417 /* Pass the argument. */
1418 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1419 args);
1420 if (formal->sym->ts.type == BT_CHARACTER)
1421 {
1422 tmp = thunk_formal->sym->ts.cl->backend_decl;
1423 string_args = tree_cons (NULL_TREE, tmp, string_args);
1424 }
1425 }
1426 else
1427 {
1428 /* Pass NULL for a missing argument. */
1429 args = tree_cons (NULL_TREE, null_pointer_node, args);
1430 if (formal->sym->ts.type == BT_CHARACTER)
1431 {
9ad09405 1432 tmp = convert (gfc_charlen_type_node, integer_zero_node);
1b716045 1433 string_args = tree_cons (NULL_TREE, tmp, string_args);
1434 }
1435 }
1436 }
1437
1438 /* Call the master function. */
1439 args = nreverse (args);
1440 args = chainon (args, nreverse (string_args));
1441 tmp = ns->proc_name->backend_decl;
1442 tmp = gfc_build_function_call (tmp, args);
c6871095 1443 if (ns->proc_name->attr.mixed_entry_master)
1444 {
1445 tree union_decl, field;
1446 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1447
1448 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1449 TREE_TYPE (master_type));
1450 DECL_ARTIFICIAL (union_decl) = 1;
1451 DECL_EXTERNAL (union_decl) = 0;
1452 TREE_PUBLIC (union_decl) = 0;
1453 TREE_USED (union_decl) = 1;
1454 layout_decl (union_decl, 0);
1455 pushdecl (union_decl);
1456
1457 DECL_CONTEXT (union_decl) = current_function_decl;
1458 tmp = build2 (MODIFY_EXPR,
1459 TREE_TYPE (union_decl),
1460 union_decl, tmp);
1461 gfc_add_expr_to_block (&body, tmp);
1462
1463 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1464 field; field = TREE_CHAIN (field))
1465 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1466 thunk_sym->result->name) == 0)
1467 break;
1468 gcc_assert (field != NULL_TREE);
1469 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1470 NULL_TREE);
1471 tmp = build2 (MODIFY_EXPR,
1472 TREE_TYPE (DECL_RESULT (current_function_decl)),
1473 DECL_RESULT (current_function_decl), tmp);
1474 tmp = build1_v (RETURN_EXPR, tmp);
1475 }
1476 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1477 != void_type_node)
1478 {
1479 tmp = build2 (MODIFY_EXPR,
1480 TREE_TYPE (DECL_RESULT (current_function_decl)),
1481 DECL_RESULT (current_function_decl), tmp);
1482 tmp = build1_v (RETURN_EXPR, tmp);
1483 }
1b716045 1484 gfc_add_expr_to_block (&body, tmp);
1485
1486 /* Finish off this function and send it for code generation. */
1487 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1488 poplevel (1, 0, 1);
1489 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1490
1491 /* Output the GENERIC tree. */
1492 dump_function (TDI_original, thunk_fndecl);
1493
1494 /* Store the end of the function, so that we get good line number
1495 info for the epilogue. */
1496 cfun->function_end_locus = input_location;
1497
1498 /* We're leaving the context of this function, so zap cfun.
1499 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1500 tree_rest_of_compilation. */
1501 cfun = NULL;
1502
1503 current_function_decl = NULL_TREE;
1504
1505 gfc_gimplify_function (thunk_fndecl);
9d95b2b0 1506 cgraph_finalize_function (thunk_fndecl, false);
1b716045 1507
1508 /* We share the symbols in the formal argument list with other entry
1509 points and the master function. Clear them so that they are
1510 recreated for each function. */
1511 for (formal = thunk_sym->formal; formal; formal = formal->next)
c6871095 1512 if (formal->sym != NULL) /* Ignore alternate returns. */
1513 {
1514 formal->sym->backend_decl = NULL_TREE;
1515 if (formal->sym->ts.type == BT_CHARACTER)
1516 formal->sym->ts.cl->backend_decl = NULL_TREE;
1517 }
1518
1519 if (thunk_sym->attr.function)
1b716045 1520 {
c6871095 1521 if (thunk_sym->ts.type == BT_CHARACTER)
1522 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1523 if (thunk_sym->result->ts.type == BT_CHARACTER)
1524 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1b716045 1525 }
1526 }
b31f705b 1527
1528 gfc_set_backend_locus (&old_loc);
1b716045 1529}
1530
1531
1532/* Create a decl for a function, and create any thunks for alternate entry
1533 points. */
1534
1535void
1536gfc_create_function_decl (gfc_namespace * ns)
1537{
1538 /* Create a declaration for the master function. */
1539 build_function_decl (ns->proc_name);
1540
f888a3fb 1541 /* Compile the entry thunks. */
1b716045 1542 if (ns->entries)
1543 build_entry_thunks (ns);
1544
1545 /* Now create the read argument list. */
1546 create_function_arglist (ns->proc_name);
1547}
1548
4ee9c684 1549/* Return the decl used to hold the function return value. */
1550
1551tree
1552gfc_get_fake_result_decl (gfc_symbol * sym)
1553{
1554 tree decl;
1555 tree length;
1556
1557 char name[GFC_MAX_SYMBOL_LEN + 10];
1558
c6871095 1559 if (sym
1560 && sym->ns->proc_name->backend_decl == current_function_decl
1561 && sym->ns->proc_name->attr.mixed_entry_master
1562 && sym != sym->ns->proc_name)
1563 {
1564 decl = gfc_get_fake_result_decl (sym->ns->proc_name);
1565 if (decl)
1566 {
1567 tree field;
1568
1569 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1570 field; field = TREE_CHAIN (field))
1571 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1572 sym->name) == 0)
1573 break;
1574
1575 gcc_assert (field != NULL_TREE);
1576 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1577 NULL_TREE);
1578 }
1579 return decl;
1580 }
1581
4ee9c684 1582 if (current_fake_result_decl != NULL_TREE)
1583 return current_fake_result_decl;
1584
1585 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1586 sym is NULL. */
1587 if (!sym)
1588 return NULL_TREE;
1589
1590 if (sym->ts.type == BT_CHARACTER
1591 && !sym->ts.cl->backend_decl)
1592 {
1593 length = gfc_create_string_length (sym);
1594 gfc_finish_var_decl (length, sym);
1595 }
1596
1597 if (gfc_return_by_reference (sym))
1598 {
c6871095 1599 decl = DECL_ARGUMENTS (current_function_decl);
1600
1601 if (sym->ns->proc_name->backend_decl == current_function_decl
1602 && sym->ns->proc_name->attr.entry_master)
1603 decl = TREE_CHAIN (decl);
4ee9c684 1604
1605 TREE_USED (decl) = 1;
1606 if (sym->as)
1607 decl = gfc_build_dummy_array_decl (sym, decl);
1608 }
1609 else
1610 {
1611 sprintf (name, "__result_%.20s",
1612 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1613
1614 decl = build_decl (VAR_DECL, get_identifier (name),
1615 TREE_TYPE (TREE_TYPE (current_function_decl)));
1616
1617 DECL_ARTIFICIAL (decl) = 1;
1618 DECL_EXTERNAL (decl) = 0;
1619 TREE_PUBLIC (decl) = 0;
1620 TREE_USED (decl) = 1;
1621
1622 layout_decl (decl, 0);
1623
1624 gfc_add_decl_to_function (decl);
1625 }
1626
1627 current_fake_result_decl = decl;
1628
1629 return decl;
1630}
1631
1632
1633/* Builds a function decl. The remaining parameters are the types of the
1634 function arguments. Negative nargs indicates a varargs function. */
1635
1636tree
1637gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1638{
1639 tree arglist;
1640 tree argtype;
1641 tree fntype;
1642 tree fndecl;
1643 va_list p;
1644 int n;
1645
1646 /* Library functions must be declared with global scope. */
22d678e8 1647 gcc_assert (current_function_decl == NULL_TREE);
4ee9c684 1648
1649 va_start (p, nargs);
1650
1651
1652 /* Create a list of the argument types. */
1653 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1654 {
1655 argtype = va_arg (p, tree);
1656 arglist = gfc_chainon_list (arglist, argtype);
1657 }
1658
1659 if (nargs >= 0)
1660 {
1661 /* Terminate the list. */
1662 arglist = gfc_chainon_list (arglist, void_type_node);
1663 }
1664
1665 /* Build the function type and decl. */
1666 fntype = build_function_type (rettype, arglist);
1667 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1668
1669 /* Mark this decl as external. */
1670 DECL_EXTERNAL (fndecl) = 1;
1671 TREE_PUBLIC (fndecl) = 1;
1672
1673 va_end (p);
1674
1675 pushdecl (fndecl);
1676
b2c4af5e 1677 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 1678
1679 return fndecl;
1680}
1681
1682static void
1683gfc_build_intrinsic_function_decls (void)
1684{
90ba9145 1685 tree gfc_int4_type_node = gfc_get_int_type (4);
1686 tree gfc_int8_type_node = gfc_get_int_type (8);
1687 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1688 tree gfc_real4_type_node = gfc_get_real_type (4);
1689 tree gfc_real8_type_node = gfc_get_real_type (8);
1690 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1691 tree gfc_complex8_type_node = gfc_get_complex_type (8);
1692
4ee9c684 1693 /* String functions. */
1694 gfor_fndecl_copy_string =
1695 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1696 void_type_node,
1697 4,
9ad09405 1698 gfc_charlen_type_node, pchar_type_node,
1699 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1700
1701 gfor_fndecl_compare_string =
1702 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1703 gfc_int4_type_node,
1704 4,
9ad09405 1705 gfc_charlen_type_node, pchar_type_node,
1706 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1707
1708 gfor_fndecl_concat_string =
1709 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1710 void_type_node,
1711 6,
9ad09405 1712 gfc_charlen_type_node, pchar_type_node,
1713 gfc_charlen_type_node, pchar_type_node,
1714 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1715
1716 gfor_fndecl_string_len_trim =
1717 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1718 gfc_int4_type_node,
9ad09405 1719 2, gfc_charlen_type_node,
4ee9c684 1720 pchar_type_node);
1721
1722 gfor_fndecl_string_index =
1723 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1724 gfc_int4_type_node,
9ad09405 1725 5, gfc_charlen_type_node, pchar_type_node,
1726 gfc_charlen_type_node, pchar_type_node,
4ee9c684 1727 gfc_logical4_type_node);
1728
1729 gfor_fndecl_string_scan =
1730 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1731 gfc_int4_type_node,
9ad09405 1732 5, gfc_charlen_type_node, pchar_type_node,
1733 gfc_charlen_type_node, pchar_type_node,
4ee9c684 1734 gfc_logical4_type_node);
1735
1736 gfor_fndecl_string_verify =
1737 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1738 gfc_int4_type_node,
9ad09405 1739 5, gfc_charlen_type_node, pchar_type_node,
1740 gfc_charlen_type_node, pchar_type_node,
4ee9c684 1741 gfc_logical4_type_node);
1742
1743 gfor_fndecl_string_trim =
1744 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1745 void_type_node,
1746 4,
9ad09405 1747 build_pointer_type (gfc_charlen_type_node),
4ee9c684 1748 ppvoid_type_node,
9ad09405 1749 gfc_charlen_type_node,
4ee9c684 1750 pchar_type_node);
1751
1752 gfor_fndecl_string_repeat =
1753 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1754 void_type_node,
1755 4,
1756 pchar_type_node,
9ad09405 1757 gfc_charlen_type_node,
4ee9c684 1758 pchar_type_node,
1759 gfc_int4_type_node);
1760
1761 gfor_fndecl_adjustl =
1762 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1763 void_type_node,
1764 3,
1765 pchar_type_node,
9ad09405 1766 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1767
1768 gfor_fndecl_adjustr =
1769 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1770 void_type_node,
1771 3,
1772 pchar_type_node,
9ad09405 1773 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1774
1775 gfor_fndecl_si_kind =
1776 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1777 gfc_int4_type_node,
1778 1,
1779 pvoid_type_node);
1780
1781 gfor_fndecl_sr_kind =
1782 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1783 gfc_int4_type_node,
1784 2, pvoid_type_node,
1785 pvoid_type_node);
1786
4ee9c684 1787 /* Power functions. */
76834664 1788 {
1789 tree type;
1790 tree itype;
1791 int kind;
1792 int ikind;
1793 static int kinds[2] = {4, 8};
1794 char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1795
1796 for (ikind=0; ikind < 2; ikind++)
1797 {
1798 itype = gfc_get_int_type (kinds[ikind]);
1799 for (kind = 0; kind < 2; kind ++)
1800 {
1801 type = gfc_get_int_type (kinds[kind]);
1802 sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1803 gfor_fndecl_math_powi[kind][ikind].integer =
1804 gfc_build_library_function_decl (get_identifier (name),
1805 type, 2, type, itype);
1806
1807 type = gfc_get_real_type (kinds[kind]);
1808 sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1809 gfor_fndecl_math_powi[kind][ikind].real =
1810 gfc_build_library_function_decl (get_identifier (name),
1811 type, 2, type, itype);
1812
1813 type = gfc_get_complex_type (kinds[kind]);
1814 sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1815 gfor_fndecl_math_powi[kind][ikind].cmplx =
1816 gfc_build_library_function_decl (get_identifier (name),
1817 type, 2, type, itype);
1818 }
1819 }
1820 }
1821
4ee9c684 1822 gfor_fndecl_math_cpowf =
1823 gfc_build_library_function_decl (get_identifier ("cpowf"),
1824 gfc_complex4_type_node,
1825 1, gfc_complex4_type_node);
1826 gfor_fndecl_math_cpow =
1827 gfc_build_library_function_decl (get_identifier ("cpow"),
1828 gfc_complex8_type_node,
1829 1, gfc_complex8_type_node);
4ee9c684 1830 gfor_fndecl_math_ishftc4 =
1831 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1832 gfc_int4_type_node,
1833 3, gfc_int4_type_node,
1834 gfc_int4_type_node, gfc_int4_type_node);
1835 gfor_fndecl_math_ishftc8 =
1836 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1837 gfc_int8_type_node,
1838 3, gfc_int8_type_node,
1839 gfc_int8_type_node, gfc_int8_type_node);
1840 gfor_fndecl_math_exponent4 =
1841 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1842 gfc_int4_type_node,
1843 1, gfc_real4_type_node);
1844 gfor_fndecl_math_exponent8 =
1845 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1846 gfc_int4_type_node,
1847 1, gfc_real8_type_node);
1848
1849 /* Other functions. */
1850 gfor_fndecl_size0 =
1851 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1852 gfc_array_index_type,
1853 1, pvoid_type_node);
1854 gfor_fndecl_size1 =
1855 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1856 gfc_array_index_type,
1857 2, pvoid_type_node,
1858 gfc_array_index_type);
9b057c29 1859
1860 gfor_fndecl_iargc =
1861 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1862 gfc_int4_type_node,
1863 0);
4ee9c684 1864}
1865
1866
1867/* Make prototypes for runtime library functions. */
1868
1869void
1870gfc_build_builtin_function_decls (void)
1871{
90ba9145 1872 tree gfc_int4_type_node = gfc_get_int_type (4);
1873 tree gfc_int8_type_node = gfc_get_int_type (8);
1874 tree gfc_logical4_type_node = gfc_get_logical_type (4);
8302a4a2 1875 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
90ba9145 1876
9c0f3811 1877 /* Treat these two internal malloc wrappers as malloc. */
4ee9c684 1878 gfor_fndecl_internal_malloc =
1879 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1880 pvoid_type_node, 1, gfc_int4_type_node);
9c0f3811 1881 DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
4ee9c684 1882
1883 gfor_fndecl_internal_malloc64 =
1884 gfc_build_library_function_decl (get_identifier
1885 (PREFIX("internal_malloc64")),
1886 pvoid_type_node, 1, gfc_int8_type_node);
9c0f3811 1887 DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
4ee9c684 1888
1889 gfor_fndecl_internal_free =
1890 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1891 void_type_node, 1, pvoid_type_node);
1892
1893 gfor_fndecl_allocate =
1894 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1895 void_type_node, 2, ppvoid_type_node,
1896 gfc_int4_type_node);
1897
1898 gfor_fndecl_allocate64 =
1899 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1900 void_type_node, 2, ppvoid_type_node,
1901 gfc_int8_type_node);
1902
1903 gfor_fndecl_deallocate =
1904 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
8302a4a2 1905 void_type_node, 2, ppvoid_type_node,
1906 gfc_pint4_type_node);
4ee9c684 1907
1908 gfor_fndecl_stop_numeric =
1909 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1910 void_type_node, 1, gfc_int4_type_node);
1911
98ccec97 1912 /* Stop doesn't return. */
1913 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
1914
4ee9c684 1915 gfor_fndecl_stop_string =
1916 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1917 void_type_node, 2, pchar_type_node,
1918 gfc_int4_type_node);
98ccec97 1919 /* Stop doesn't return. */
1920 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
4ee9c684 1921
1922 gfor_fndecl_pause_numeric =
1923 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1924 void_type_node, 1, gfc_int4_type_node);
1925
1926 gfor_fndecl_pause_string =
1927 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1928 void_type_node, 2, pchar_type_node,
1929 gfc_int4_type_node);
1930
1931 gfor_fndecl_select_string =
1932 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1933 pvoid_type_node, 0);
1934
1935 gfor_fndecl_runtime_error =
1936 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1937 void_type_node,
1938 3,
1939 pchar_type_node, pchar_type_node,
1940 gfc_int4_type_node);
9c0f3811 1941 /* The runtime_error function does not return. */
1942 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
4ee9c684 1943
1944 gfor_fndecl_in_pack = gfc_build_library_function_decl (
1945 get_identifier (PREFIX("internal_pack")),
1946 pvoid_type_node, 1, pvoid_type_node);
1947
1948 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1949 get_identifier (PREFIX("internal_unpack")),
1950 pvoid_type_node, 1, pvoid_type_node);
1951
1952 gfor_fndecl_associated =
1953 gfc_build_library_function_decl (
1954 get_identifier (PREFIX("associated")),
1955 gfc_logical4_type_node,
1956 2,
1957 ppvoid_type_node,
1958 ppvoid_type_node);
1959
1960 gfc_build_intrinsic_function_decls ();
1961 gfc_build_intrinsic_lib_fndecls ();
1962 gfc_build_io_library_fndecls ();
1963}
1964
1965
231e961a 1966/* Evaluate the length of dummy character variables. */
4ee9c684 1967
1968static tree
1969gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1970{
1971 stmtblock_t body;
1972
1973 gfc_finish_decl (cl->backend_decl, NULL_TREE);
1974
1975 gfc_start_block (&body);
1976
1977 /* Evaluate the string length expression. */
1978 gfc_trans_init_string_length (cl, &body);
1979
1980 gfc_add_expr_to_block (&body, fnbody);
1981 return gfc_finish_block (&body);
1982}
1983
1984
1985/* Allocate and cleanup an automatic character variable. */
1986
1987static tree
1988gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1989{
1990 stmtblock_t body;
1991 tree decl;
4ee9c684 1992 tree tmp;
1993
22d678e8 1994 gcc_assert (sym->backend_decl);
1995 gcc_assert (sym->ts.cl && sym->ts.cl->length);
4ee9c684 1996
1997 gfc_start_block (&body);
1998
1999 /* Evaluate the string length expression. */
2000 gfc_trans_init_string_length (sym->ts.cl, &body);
2001
2002 decl = sym->backend_decl;
2003
afcf285e 2004 /* Emit a DECL_EXPR for this variable, which will cause the
4b3a701c 2005 gimplifier to allocate storage, and all that good stuff. */
ed52ef8b 2006 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4ee9c684 2007 gfc_add_expr_to_block (&body, tmp);
afcf285e 2008
4ee9c684 2009 gfc_add_expr_to_block (&body, fnbody);
2010 return gfc_finish_block (&body);
2011}
2012
2013
2014/* Generate function entry and exit code, and add it to the function body.
2015 This includes:
f888a3fb 2016 Allocation and initialization of array variables.
4ee9c684 2017 Allocation of character string variables.
2018 Initialization and possibly repacking of dummy arrays. */
2019
2020static tree
2021gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2022{
2023 locus loc;
2024 gfc_symbol *sym;
2025
2026 /* Deal with implicit return variables. Explicit return variables will
2027 already have been added. */
2028 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2029 {
2030 if (!current_fake_result_decl)
2031 {
c6871095 2032 gfc_entry_list *el = NULL;
2033 if (proc_sym->attr.entry_master)
2034 {
2035 for (el = proc_sym->ns->entries; el; el = el->next)
2036 if (el->sym != el->sym->result)
2037 break;
2038 }
2039 if (el == NULL)
2040 warning (0, "Function does not return a value");
4ee9c684 2041 }
c6871095 2042 else if (proc_sym->as)
4ee9c684 2043 {
2044 fnbody = gfc_trans_dummy_array_bias (proc_sym,
2045 current_fake_result_decl,
2046 fnbody);
2047 }
2048 else if (proc_sym->ts.type == BT_CHARACTER)
2049 {
2050 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2051 fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
2052 }
2053 else
bdaed7d2 2054 gcc_assert (gfc_option.flag_f2c
2055 && proc_sym->ts.type == BT_COMPLEX);
4ee9c684 2056 }
2057
2058 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2059 {
2060 if (sym->attr.dimension)
2061 {
2062 switch (sym->as->type)
2063 {
2064 case AS_EXPLICIT:
2065 if (sym->attr.dummy || sym->attr.result)
2066 fnbody =
2067 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2068 else if (sym->attr.pointer || sym->attr.allocatable)
2069 {
2070 if (TREE_STATIC (sym->backend_decl))
2071 gfc_trans_static_array_pointer (sym);
2072 else
2073 fnbody = gfc_trans_deferred_array (sym, fnbody);
2074 }
2075 else
2076 {
2077 gfc_get_backend_locus (&loc);
2078 gfc_set_backend_locus (&sym->declared_at);
2079 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2080 sym, fnbody);
2081 gfc_set_backend_locus (&loc);
2082 }
2083 break;
2084
2085 case AS_ASSUMED_SIZE:
2086 /* Must be a dummy parameter. */
22d678e8 2087 gcc_assert (sym->attr.dummy);
4ee9c684 2088
2089 /* We should always pass assumed size arrays the g77 way. */
4ee9c684 2090 fnbody = gfc_trans_g77_array (sym, fnbody);
2091 break;
2092
2093 case AS_ASSUMED_SHAPE:
2094 /* Must be a dummy parameter. */
22d678e8 2095 gcc_assert (sym->attr.dummy);
4ee9c684 2096
2097 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2098 fnbody);
2099 break;
2100
2101 case AS_DEFERRED:
2102 fnbody = gfc_trans_deferred_array (sym, fnbody);
2103 break;
2104
2105 default:
22d678e8 2106 gcc_unreachable ();
4ee9c684 2107 }
2108 }
2109 else if (sym->ts.type == BT_CHARACTER)
2110 {
2111 gfc_get_backend_locus (&loc);
2112 gfc_set_backend_locus (&sym->declared_at);
2113 if (sym->attr.dummy || sym->attr.result)
2114 fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
2115 else
2116 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2117 gfc_set_backend_locus (&loc);
2118 }
2119 else
22d678e8 2120 gcc_unreachable ();
4ee9c684 2121 }
2122
2123 return fnbody;
2124}
2125
2126
2127/* Output an initialized decl for a module variable. */
2128
2129static void
2130gfc_create_module_variable (gfc_symbol * sym)
2131{
2132 tree decl;
4ee9c684 2133
2134 /* Only output symbols from this module. */
2135 if (sym->ns != module_namespace)
2136 {
2137 /* I don't think this should ever happen. */
2138 internal_error ("module symbol %s in wrong namespace", sym->name);
2139 }
2140
7b3423b9 2141 /* Only output variables and array valued parameters. */
4ee9c684 2142 if (sym->attr.flavor != FL_VARIABLE
2143 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2144 return;
2145
d43a7f7f 2146 /* Don't generate variables from other modules. Variables from
2147 COMMONs will already have been generated. */
2148 if (sym->attr.use_assoc || sym->attr.in_common)
4ee9c684 2149 return;
2150
2151 if (sym->backend_decl)
2152 internal_error ("backend decl for module variable %s already exists",
2153 sym->name);
2154
2155 /* We always want module variables to be created. */
2156 sym->attr.referenced = 1;
2157 /* Create the decl. */
2158 decl = gfc_get_symbol_decl (sym);
2159
4ee9c684 2160 /* Create the variable. */
2161 pushdecl (decl);
b2c4af5e 2162 rest_of_decl_compilation (decl, 1, 0);
4ee9c684 2163
2164 /* Also add length of strings. */
2165 if (sym->ts.type == BT_CHARACTER)
2166 {
2167 tree length;
2168
2169 length = sym->ts.cl->backend_decl;
2170 if (!INTEGER_CST_P (length))
2171 {
2172 pushdecl (length);
b2c4af5e 2173 rest_of_decl_compilation (length, 1, 0);
4ee9c684 2174 }
2175 }
2176}
2177
2178
2179/* Generate all the required code for module variables. */
2180
2181void
2182gfc_generate_module_vars (gfc_namespace * ns)
2183{
2184 module_namespace = ns;
2185
dfc222eb 2186 /* Check if the frontend left the namespace in a reasonable state. */
22d678e8 2187 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4ee9c684 2188
d43a7f7f 2189 /* Generate COMMON blocks. */
2190 gfc_trans_common (ns);
2191
dfc222eb 2192 /* Create decls for all the module variables. */
4ee9c684 2193 gfc_traverse_ns (ns, gfc_create_module_variable);
2194}
2195
2196static void
2197gfc_generate_contained_functions (gfc_namespace * parent)
2198{
2199 gfc_namespace *ns;
2200
2201 /* We create all the prototypes before generating any code. */
2202 for (ns = parent->contained; ns; ns = ns->sibling)
2203 {
2204 /* Skip namespaces from used modules. */
2205 if (ns->parent != parent)
2206 continue;
2207
1b716045 2208 gfc_create_function_decl (ns);
4ee9c684 2209 }
2210
2211 for (ns = parent->contained; ns; ns = ns->sibling)
2212 {
2213 /* Skip namespaces from used modules. */
2214 if (ns->parent != parent)
2215 continue;
2216
2217 gfc_generate_function_code (ns);
2218 }
2219}
2220
2221
2222/* Generate decls for all local variables. We do this to ensure correct
2223 handling of expressions which only appear in the specification of
2224 other functions. */
2225
2226static void
2227generate_local_decl (gfc_symbol * sym)
2228{
2229 if (sym->attr.flavor == FL_VARIABLE)
2230 {
4ee9c684 2231 if (sym->attr.referenced)
2232 gfc_get_symbol_decl (sym);
14a3addc 2233 else if (sym->attr.dummy && warn_unused_parameter)
c3ceba8e 2234 warning (0, "unused parameter %qs", sym->name);
f888a3fb 2235 /* Warn for unused variables, but not if they're inside a common
14a3addc 2236 block or are use-associated. */
36609028 2237 else if (warn_unused_variable
2238 && !(sym->attr.in_common || sym->attr.use_assoc))
c3ceba8e 2239 warning (0, "unused variable %qs", sym->name);
4ee9c684 2240 }
2241}
2242
2243static void
2244generate_local_vars (gfc_namespace * ns)
2245{
2246 gfc_traverse_ns (ns, generate_local_decl);
2247}
2248
2249
1b716045 2250/* Generate a switch statement to jump to the correct entry point. Also
2251 creates the label decls for the entry points. */
4ee9c684 2252
1b716045 2253static tree
2254gfc_trans_entry_master_switch (gfc_entry_list * el)
4ee9c684 2255{
1b716045 2256 stmtblock_t block;
2257 tree label;
2258 tree tmp;
2259 tree val;
4ee9c684 2260
1b716045 2261 gfc_init_block (&block);
2262 for (; el; el = el->next)
2263 {
2264 /* Add the case label. */
b797d6d3 2265 label = gfc_build_label_decl (NULL_TREE);
7016c612 2266 val = build_int_cst (gfc_array_index_type, el->id);
ed52ef8b 2267 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
1b716045 2268 gfc_add_expr_to_block (&block, tmp);
2269
2270 /* And jump to the actual entry point. */
2271 label = gfc_build_label_decl (NULL_TREE);
1b716045 2272 tmp = build1_v (GOTO_EXPR, label);
2273 gfc_add_expr_to_block (&block, tmp);
2274
2275 /* Save the label decl. */
2276 el->label = label;
2277 }
2278 tmp = gfc_finish_block (&block);
2279 /* The first argument selects the entry point. */
2280 val = DECL_ARGUMENTS (current_function_decl);
ed52ef8b 2281 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
1b716045 2282 return tmp;
4ee9c684 2283}
2284
6374121b 2285
4ee9c684 2286/* Generate code for a function. */
2287
2288void
2289gfc_generate_function_code (gfc_namespace * ns)
2290{
2291 tree fndecl;
2292 tree old_context;
2293 tree decl;
2294 tree tmp;
2295 stmtblock_t block;
2296 stmtblock_t body;
2297 tree result;
2298 gfc_symbol *sym;
2299
2300 sym = ns->proc_name;
1b716045 2301
4ee9c684 2302 /* Check that the frontend isn't still using this. */
22d678e8 2303 gcc_assert (sym->tlink == NULL);
4ee9c684 2304 sym->tlink = sym;
2305
2306 /* Create the declaration for functions with global scope. */
2307 if (!sym->backend_decl)
1b716045 2308 gfc_create_function_decl (ns);
4ee9c684 2309
2310 fndecl = sym->backend_decl;
2311 old_context = current_function_decl;
2312
2313 if (old_context)
2314 {
2315 push_function_context ();
2316 saved_parent_function_decls = saved_function_decls;
2317 saved_function_decls = NULL_TREE;
2318 }
2319
1b716045 2320 trans_function_start (sym);
4ee9c684 2321
2322 /* Will be created as needed. */
2323 current_fake_result_decl = NULL_TREE;
2324
4ee9c684 2325 gfc_start_block (&block);
2326
2327 gfc_generate_contained_functions (ns);
2328
c6871095 2329 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2330 {
2331 /* Copy length backend_decls to all entry point result
2332 symbols. */
2333 gfc_entry_list *el;
2334 tree backend_decl;
2335
2336 gfc_conv_const_charlen (ns->proc_name->ts.cl);
2337 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2338 for (el = ns->entries; el; el = el->next)
2339 el->sym->result->ts.cl->backend_decl = backend_decl;
2340 }
2341
4ee9c684 2342 /* Translate COMMON blocks. */
2343 gfc_trans_common (ns);
2344
2345 generate_local_vars (ns);
2346
2347 current_function_return_label = NULL;
2348
2349 /* Now generate the code for the body of this function. */
2350 gfc_init_block (&body);
2351
2352 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2353 && sym->attr.subroutine)
2354 {
2355 tree alternate_return;
2356 alternate_return = gfc_get_fake_result_decl (sym);
2357 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2358 }
2359
1b716045 2360 if (ns->entries)
2361 {
2362 /* Jump to the correct entry point. */
2363 tmp = gfc_trans_entry_master_switch (ns->entries);
2364 gfc_add_expr_to_block (&body, tmp);
2365 }
2366
4ee9c684 2367 tmp = gfc_trans_code (ns->code);
2368 gfc_add_expr_to_block (&body, tmp);
2369
2370 /* Add a return label if needed. */
2371 if (current_function_return_label)
2372 {
2373 tmp = build1_v (LABEL_EXPR, current_function_return_label);
2374 gfc_add_expr_to_block (&body, tmp);
2375 }
2376
2377 tmp = gfc_finish_block (&body);
2378 /* Add code to create and cleanup arrays. */
2379 tmp = gfc_trans_deferred_vars (sym, tmp);
2380 gfc_add_expr_to_block (&block, tmp);
2381
2382 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2383 {
14a3addc 2384 if (sym->attr.subroutine || sym == sym->result)
4ee9c684 2385 {
2386 result = current_fake_result_decl;
2387 current_fake_result_decl = NULL_TREE;
2388 }
2389 else
2390 result = sym->result->backend_decl;
2391
2392 if (result == NULL_TREE)
c3ceba8e 2393 warning (0, "Function return value not set");
4ee9c684 2394 else
2395 {
f888a3fb 2396 /* Set the return value to the dummy result variable. */
ed52ef8b 2397 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2398 DECL_RESULT (fndecl), result);
2399 tmp = build1_v (RETURN_EXPR, tmp);
4ee9c684 2400 gfc_add_expr_to_block (&block, tmp);
2401 }
2402 }
2403
2404 /* Add all the decls we created during processing. */
2405 decl = saved_function_decls;
2406 while (decl)
2407 {
2408 tree next;
2409
2410 next = TREE_CHAIN (decl);
2411 TREE_CHAIN (decl) = NULL_TREE;
2412 pushdecl (decl);
2413 decl = next;
2414 }
2415 saved_function_decls = NULL_TREE;
2416
2417 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2418
2419 /* Finish off this function and send it for code generation. */
2420 poplevel (1, 0, 1);
2421 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2422
2423 /* Output the GENERIC tree. */
2424 dump_function (TDI_original, fndecl);
2425
2426 /* Store the end of the function, so that we get good line number
2427 info for the epilogue. */
2428 cfun->function_end_locus = input_location;
2429
2430 /* We're leaving the context of this function, so zap cfun.
2431 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2432 tree_rest_of_compilation. */
2433 cfun = NULL;
2434
2435 if (old_context)
2436 {
2437 pop_function_context ();
2438 saved_function_decls = saved_parent_function_decls;
2439 }
2440 current_function_decl = old_context;
2441
2442 if (decl_function_context (fndecl))
6374121b 2443 /* Register this function with cgraph just far enough to get it
2444 added to our parent's nested function list. */
2445 (void) cgraph_node (fndecl);
4ee9c684 2446 else
2447 {
6374121b 2448 gfc_gimplify_function (fndecl);
9d95b2b0 2449 cgraph_finalize_function (fndecl, false);
4ee9c684 2450 }
2451}
2452
4ee9c684 2453void
2454gfc_generate_constructors (void)
2455{
22d678e8 2456 gcc_assert (gfc_static_ctors == NULL_TREE);
4ee9c684 2457#if 0
2458 tree fnname;
2459 tree type;
2460 tree fndecl;
2461 tree decl;
2462 tree tmp;
2463
2464 if (gfc_static_ctors == NULL_TREE)
2465 return;
2466
2467 fnname = get_file_function_name ('I');
2468 type = build_function_type (void_type_node,
2469 gfc_chainon_list (NULL_TREE, void_type_node));
2470
2471 fndecl = build_decl (FUNCTION_DECL, fnname, type);
2472 TREE_PUBLIC (fndecl) = 1;
2473
2474 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
540edea7 2475 DECL_ARTIFICIAL (decl) = 1;
2476 DECL_IGNORED_P (decl) = 1;
4ee9c684 2477 DECL_CONTEXT (decl) = fndecl;
2478 DECL_RESULT (fndecl) = decl;
2479
2480 pushdecl (fndecl);
2481
2482 current_function_decl = fndecl;
2483
b2c4af5e 2484 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 2485
b2c4af5e 2486 make_decl_rtl (fndecl);
4ee9c684 2487
b31f705b 2488 init_function_start (fndecl);
4ee9c684 2489
4ee9c684 2490 pushlevel (0);
2491
2492 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2493 {
2494 tmp =
2495 gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2496 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2497 }
2498
2499 poplevel (1, 0, 1);
2500
2501 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2502
2503 free_after_parsing (cfun);
2504 free_after_compilation (cfun);
2505
6148a911 2506 tree_rest_of_compilation (fndecl);
4ee9c684 2507
2508 current_function_decl = NULL_TREE;
2509#endif
2510}
2511
9ec7c303 2512/* Translates a BLOCK DATA program unit. This means emitting the
2513 commons contained therein plus their initializations. We also emit
2514 a globally visible symbol to make sure that each BLOCK DATA program
2515 unit remains unique. */
2516
2517void
2518gfc_generate_block_data (gfc_namespace * ns)
2519{
2520 tree decl;
2521 tree id;
2522
b31f705b 2523 /* Tell the backend the source location of the block data. */
2524 if (ns->proc_name)
2525 gfc_set_backend_locus (&ns->proc_name->declared_at);
2526 else
2527 gfc_set_backend_locus (&gfc_current_locus);
2528
2529 /* Process the DATA statements. */
9ec7c303 2530 gfc_trans_common (ns);
2531
b31f705b 2532 /* Create a global symbol with the mane of the block data. This is to
2533 generate linker errors if the same name is used twice. It is never
2534 really used. */
9ec7c303 2535 if (ns->proc_name)
2536 id = gfc_sym_mangled_function_id (ns->proc_name);
2537 else
2538 id = get_identifier ("__BLOCK_DATA__");
2539
2540 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2541 TREE_PUBLIC (decl) = 1;
2542 TREE_STATIC (decl) = 1;
2543
2544 pushdecl (decl);
2545 rest_of_decl_compilation (decl, 1, 0);
2546}
2547
4ee9c684 2548#include "gt-fortran-trans-decl.h"
Mirror of https://gcc.gnu.org/git/gcc.git