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