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