]> 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
* builtins.c (fold_builtin_strchr): Use build_int_cst, not
[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"
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
76834664 96gfc_powdecl_list gfor_fndecl_math_powi[3][2];
4ee9c684 97tree gfor_fndecl_math_cpowf;
98tree gfor_fndecl_math_cpow;
4ee9c684 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;
9b057c29 124tree gfor_fndecl_iargc;
4ee9c684 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{
4ee9c684 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. */
f888a3fb 240 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
4ee9c684 241 {
b0057e95 242 DECL_SOURCE_LINE (label_decl) = lp->where.lb->linenum;
243 DECL_SOURCE_FILE (label_decl) = lp->where.lb->file->filename;
4ee9c684 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{
f888a3fb 377 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
4ee9c684 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
f888a3fb 557 /* Do we know the element size? */
4ee9c684 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),
9ad09405 673 gfc_charlen_type_node);
4ee9c684 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;
4ee9c684 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
4ee9c684 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
f888a3fb 760 /* Symbols from modules should have their assembler names mangled.
4ee9c684 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;
9ad09405 784 length = gfc_create_var (gfc_charlen_type_node, sym->name);
4ee9c684 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. */
7016c612 793 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
4ee9c684 794 }
795
bda1f152 796 if (sym->ts.type == BT_CHARACTER)
4ee9c684 797 {
4ee9c684 798 /* Character variables need special handling. */
799 gfc_allocate_lang_decl (decl);
800
bda1f152 801 if (TREE_CODE (length) != INTEGER_CST)
4ee9c684 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 }
4ee9c684 817 }
818 sym->backend_decl = decl;
819
bda1f152 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
4ee9c684 828 return decl;
829}
830
831
dbe60343 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
4ee9c684 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
1b716045 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
4ee9c684 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 {
f888a3fb 933 /* Global declaration, e.g. intrinsic subroutine. */
4ee9c684 934 DECL_CONTEXT (fndecl) = NULL_TREE;
935 }
936
937 DECL_EXTERNAL (fndecl) = 1;
938
f888a3fb 939 /* This specifies if a function is globally addressable, i.e. it is
4ee9c684 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 {
be393645 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
1b716045 953 can be optimized away. See also in build_function_decl(). */
be393645 954 TREE_SIDE_EFFECTS (fndecl) = 0;
4ee9c684 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
1b716045 967 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
968 a master function with alternate entry points. */
4ee9c684 969
1b716045 970static void
971build_function_decl (gfc_symbol * sym)
4ee9c684 972{
1b716045 973 tree fndecl, type;
4ee9c684 974 symbol_attribute attr;
1b716045 975 tree result_decl;
4ee9c684 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
f888a3fb 993 RESULT_DECL for it. If this is a subroutine with alternate
4ee9c684 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);
540edea7 1031 DECL_ARTIFICIAL (result_decl) = 1;
1032 DECL_IGNORED_P (result_decl) = 1;
4ee9c684 1033 DECL_CONTEXT (result_decl) = fndecl;
1034 DECL_RESULT (fndecl) = result_decl;
1035
1036 /* Don't call layout_decl for a RESULT_DECL.
f888a3fb 1037 layout_decl (result_decl, 0); */
4ee9c684 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
9d138f47 1050 /* This specifies if a function is globally visible, i.e. it is
dfc222eb 1051 the opposite of declaring static in C. */
1b716045 1052 if (DECL_CONTEXT (fndecl) == NULL_TREE
1053 && !sym->attr.entry_master)
4ee9c684 1054 TREE_PUBLIC (fndecl) = 1;
1055
1056 /* TREE_STATIC means the function body is defined here. */
e4b2c26c 1057 TREE_STATIC (fndecl) = 1;
4ee9c684 1058
f888a3fb 1059 /* Set attributes for PURE functions. A call to a PURE function in the
4ee9c684 1060 Fortran 95 sense is both pure and without side effects in the C
1061 sense. */
1062 if (attr.pure || attr.elemental)
1063 {
be393645 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;
4ee9c684 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. */
e4b2c26c 1074 pushdecl (fndecl);
1b716045 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
e4b2c26c 1095 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1096 the new FUNCTION_DECL node. */
e4b2c26c 1097 arglist = NULL_TREE;
1098 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1b716045 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
e4b2c26c 1114 if (gfc_return_by_reference (sym))
4ee9c684 1115 {
e4b2c26c 1116 type = TREE_VALUE (typelist);
1117 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
4ee9c684 1118
e4b2c26c 1119 DECL_CONTEXT (parm) = fndecl;
1120 DECL_ARG_TYPE (parm) = type;
1121 TREE_READONLY (parm) = 1;
1122 gfc_finish_decl (parm, NULL_TREE);
4ee9c684 1123
e4b2c26c 1124 arglist = chainon (arglist, parm);
1125 typelist = TREE_CHAIN (typelist);
4ee9c684 1126
e4b2c26c 1127 if (sym->ts.type == BT_CHARACTER)
1128 {
1129 gfc_allocate_lang_decl (parm);
4ee9c684 1130
e4b2c26c 1131 /* Length of character result. */
1132 type = TREE_VALUE (typelist);
9ad09405 1133 assert (type == gfc_charlen_type_node);
4ee9c684 1134
e4b2c26c 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;
4ee9c684 1142 }
e4b2c26c 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);
4ee9c684 1150 }
e4b2c26c 1151 }
4ee9c684 1152
e4b2c26c 1153 for (f = sym->formal; f; f = f->next)
1154 {
f888a3fb 1155 if (f->sym != NULL) /* ignore alternate returns. */
4ee9c684 1156 {
e4b2c26c 1157 length = NULL_TREE;
4ee9c684 1158
e4b2c26c 1159 type = TREE_VALUE (typelist);
4ee9c684 1160
e4b2c26c 1161 /* Build a the argument declaration. */
1162 parm = build_decl (PARM_DECL,
1163 gfc_sym_identifier (f->sym), type);
4ee9c684 1164
e4b2c26c 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;
4ee9c684 1171
e4b2c26c 1172 gfc_finish_decl (parm, NULL_TREE);
4ee9c684 1173
e4b2c26c 1174 f->sym->backend_decl = parm;
4ee9c684 1175
e4b2c26c 1176 arglist = chainon (arglist, parm);
1177 typelist = TREE_CHAIN (typelist);
1178 }
1179 }
4ee9c684 1180
e4b2c26c 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;
4ee9c684 1189
e4b2c26c 1190 if (f->sym->ts.type != BT_CHARACTER)
1191 continue;
4ee9c684 1192
e4b2c26c 1193 parm = f->sym->backend_decl;
1194 type = TREE_VALUE (typelist);
9ad09405 1195 assert (type == gfc_charlen_type_node);
4ee9c684 1196
e4b2c26c 1197 strcpy (&name[1], f->sym->name);
1198 name[0] = '_';
1199 length = build_decl (PARM_DECL, get_identifier (name), type);
4ee9c684 1200
e4b2c26c 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);
4ee9c684 1206
e4b2c26c 1207 /* TODO: Check string lengths when -fbounds-check. */
4ee9c684 1208
e4b2c26c 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
4ee9c684 1216 {
e4b2c26c 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;
4ee9c684 1231 }
4ee9c684 1232 }
1233
e4b2c26c 1234 parm = TREE_CHAIN (parm);
1235 typelist = TREE_CHAIN (typelist);
4ee9c684 1236 }
e4b2c26c 1237
1238 assert (TREE_VALUE (typelist) == void_type_node);
1239 DECL_ARGUMENTS (fndecl) = arglist;
1b716045 1240}
e4b2c26c 1241
e4b2c26c 1242
1b716045 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);
4ee9c684 1255}
1256
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
f888a3fb 1301 /* Set the line and filename. sym->declared_at seems to point to the
1b716045 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
f888a3fb 1313 /* function.c requires a push at the start of the function. */
1b716045 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
1b716045 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
f888a3fb 1348 /* Pass extra parameter identifying this entry point. */
7016c612 1349 tmp = build_int_cst (gfc_array_index_type, el->id);
1b716045 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 {
9ad09405 1386 tmp = convert (gfc_charlen_type_node, integer_zero_node);
1b716045 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
f888a3fb 1445 /* Compile the entry thunks. */
1b716045 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
4ee9c684 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
b2c4af5e 1554 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 1555
1556 return fndecl;
1557}
1558
1559static void
1560gfc_build_intrinsic_function_decls (void)
1561{
90ba9145 1562 tree gfc_int4_type_node = gfc_get_int_type (4);
1563 tree gfc_int8_type_node = gfc_get_int_type (8);
1564 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1565 tree gfc_real4_type_node = gfc_get_real_type (4);
1566 tree gfc_real8_type_node = gfc_get_real_type (8);
1567 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1568 tree gfc_complex8_type_node = gfc_get_complex_type (8);
1569
4ee9c684 1570 /* String functions. */
1571 gfor_fndecl_copy_string =
1572 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1573 void_type_node,
1574 4,
9ad09405 1575 gfc_charlen_type_node, pchar_type_node,
1576 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1577
1578 gfor_fndecl_compare_string =
1579 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1580 gfc_int4_type_node,
1581 4,
9ad09405 1582 gfc_charlen_type_node, pchar_type_node,
1583 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1584
1585 gfor_fndecl_concat_string =
1586 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1587 void_type_node,
1588 6,
9ad09405 1589 gfc_charlen_type_node, pchar_type_node,
1590 gfc_charlen_type_node, pchar_type_node,
1591 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1592
1593 gfor_fndecl_string_len_trim =
1594 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1595 gfc_int4_type_node,
9ad09405 1596 2, gfc_charlen_type_node,
4ee9c684 1597 pchar_type_node);
1598
1599 gfor_fndecl_string_index =
1600 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1601 gfc_int4_type_node,
9ad09405 1602 5, gfc_charlen_type_node, pchar_type_node,
1603 gfc_charlen_type_node, pchar_type_node,
4ee9c684 1604 gfc_logical4_type_node);
1605
1606 gfor_fndecl_string_scan =
1607 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1608 gfc_int4_type_node,
9ad09405 1609 5, gfc_charlen_type_node, pchar_type_node,
1610 gfc_charlen_type_node, pchar_type_node,
4ee9c684 1611 gfc_logical4_type_node);
1612
1613 gfor_fndecl_string_verify =
1614 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1615 gfc_int4_type_node,
9ad09405 1616 5, gfc_charlen_type_node, pchar_type_node,
1617 gfc_charlen_type_node, pchar_type_node,
4ee9c684 1618 gfc_logical4_type_node);
1619
1620 gfor_fndecl_string_trim =
1621 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1622 void_type_node,
1623 4,
9ad09405 1624 build_pointer_type (gfc_charlen_type_node),
4ee9c684 1625 ppvoid_type_node,
9ad09405 1626 gfc_charlen_type_node,
4ee9c684 1627 pchar_type_node);
1628
1629 gfor_fndecl_string_repeat =
1630 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1631 void_type_node,
1632 4,
1633 pchar_type_node,
9ad09405 1634 gfc_charlen_type_node,
4ee9c684 1635 pchar_type_node,
1636 gfc_int4_type_node);
1637
1638 gfor_fndecl_adjustl =
1639 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1640 void_type_node,
1641 3,
1642 pchar_type_node,
9ad09405 1643 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1644
1645 gfor_fndecl_adjustr =
1646 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1647 void_type_node,
1648 3,
1649 pchar_type_node,
9ad09405 1650 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1651
1652 gfor_fndecl_si_kind =
1653 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1654 gfc_int4_type_node,
1655 1,
1656 pvoid_type_node);
1657
1658 gfor_fndecl_sr_kind =
1659 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1660 gfc_int4_type_node,
1661 2, pvoid_type_node,
1662 pvoid_type_node);
1663
4ee9c684 1664 /* Power functions. */
76834664 1665 {
1666 tree type;
1667 tree itype;
1668 int kind;
1669 int ikind;
1670 static int kinds[2] = {4, 8};
1671 char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1672
1673 for (ikind=0; ikind < 2; ikind++)
1674 {
1675 itype = gfc_get_int_type (kinds[ikind]);
1676 for (kind = 0; kind < 2; kind ++)
1677 {
1678 type = gfc_get_int_type (kinds[kind]);
1679 sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1680 gfor_fndecl_math_powi[kind][ikind].integer =
1681 gfc_build_library_function_decl (get_identifier (name),
1682 type, 2, type, itype);
1683
1684 type = gfc_get_real_type (kinds[kind]);
1685 sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1686 gfor_fndecl_math_powi[kind][ikind].real =
1687 gfc_build_library_function_decl (get_identifier (name),
1688 type, 2, type, itype);
1689
1690 type = gfc_get_complex_type (kinds[kind]);
1691 sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1692 gfor_fndecl_math_powi[kind][ikind].cmplx =
1693 gfc_build_library_function_decl (get_identifier (name),
1694 type, 2, type, itype);
1695 }
1696 }
1697 }
1698
4ee9c684 1699 gfor_fndecl_math_cpowf =
1700 gfc_build_library_function_decl (get_identifier ("cpowf"),
1701 gfc_complex4_type_node,
1702 1, gfc_complex4_type_node);
1703 gfor_fndecl_math_cpow =
1704 gfc_build_library_function_decl (get_identifier ("cpow"),
1705 gfc_complex8_type_node,
1706 1, gfc_complex8_type_node);
4ee9c684 1707 gfor_fndecl_math_ishftc4 =
1708 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1709 gfc_int4_type_node,
1710 3, gfc_int4_type_node,
1711 gfc_int4_type_node, gfc_int4_type_node);
1712 gfor_fndecl_math_ishftc8 =
1713 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1714 gfc_int8_type_node,
1715 3, gfc_int8_type_node,
1716 gfc_int8_type_node, gfc_int8_type_node);
1717 gfor_fndecl_math_exponent4 =
1718 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1719 gfc_int4_type_node,
1720 1, gfc_real4_type_node);
1721 gfor_fndecl_math_exponent8 =
1722 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1723 gfc_int4_type_node,
1724 1, gfc_real8_type_node);
1725
1726 /* Other functions. */
1727 gfor_fndecl_size0 =
1728 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1729 gfc_array_index_type,
1730 1, pvoid_type_node);
1731 gfor_fndecl_size1 =
1732 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1733 gfc_array_index_type,
1734 2, pvoid_type_node,
1735 gfc_array_index_type);
9b057c29 1736
1737 gfor_fndecl_iargc =
1738 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1739 gfc_int4_type_node,
1740 0);
4ee9c684 1741}
1742
1743
1744/* Make prototypes for runtime library functions. */
1745
1746void
1747gfc_build_builtin_function_decls (void)
1748{
90ba9145 1749 tree gfc_int4_type_node = gfc_get_int_type (4);
1750 tree gfc_int8_type_node = gfc_get_int_type (8);
1751 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1752
4ee9c684 1753 gfor_fndecl_internal_malloc =
1754 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1755 pvoid_type_node, 1, gfc_int4_type_node);
1756
1757 gfor_fndecl_internal_malloc64 =
1758 gfc_build_library_function_decl (get_identifier
1759 (PREFIX("internal_malloc64")),
1760 pvoid_type_node, 1, gfc_int8_type_node);
1761
1762 gfor_fndecl_internal_free =
1763 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1764 void_type_node, 1, pvoid_type_node);
1765
1766 gfor_fndecl_allocate =
1767 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1768 void_type_node, 2, ppvoid_type_node,
1769 gfc_int4_type_node);
1770
1771 gfor_fndecl_allocate64 =
1772 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1773 void_type_node, 2, ppvoid_type_node,
1774 gfc_int8_type_node);
1775
1776 gfor_fndecl_deallocate =
1777 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1778 void_type_node, 1, ppvoid_type_node);
1779
1780 gfor_fndecl_stop_numeric =
1781 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1782 void_type_node, 1, gfc_int4_type_node);
1783
1784 gfor_fndecl_stop_string =
1785 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1786 void_type_node, 2, pchar_type_node,
1787 gfc_int4_type_node);
1788
1789 gfor_fndecl_pause_numeric =
1790 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1791 void_type_node, 1, gfc_int4_type_node);
1792
1793 gfor_fndecl_pause_string =
1794 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1795 void_type_node, 2, pchar_type_node,
1796 gfc_int4_type_node);
1797
1798 gfor_fndecl_select_string =
1799 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1800 pvoid_type_node, 0);
1801
1802 gfor_fndecl_runtime_error =
1803 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1804 void_type_node,
1805 3,
1806 pchar_type_node, pchar_type_node,
1807 gfc_int4_type_node);
1808
1809 gfor_fndecl_in_pack = gfc_build_library_function_decl (
1810 get_identifier (PREFIX("internal_pack")),
1811 pvoid_type_node, 1, pvoid_type_node);
1812
1813 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1814 get_identifier (PREFIX("internal_unpack")),
1815 pvoid_type_node, 1, pvoid_type_node);
1816
1817 gfor_fndecl_associated =
1818 gfc_build_library_function_decl (
1819 get_identifier (PREFIX("associated")),
1820 gfc_logical4_type_node,
1821 2,
1822 ppvoid_type_node,
1823 ppvoid_type_node);
1824
1825 gfc_build_intrinsic_function_decls ();
1826 gfc_build_intrinsic_lib_fndecls ();
1827 gfc_build_io_library_fndecls ();
1828}
1829
1830
1831/* Exaluate the length of dummy character variables. */
1832
1833static tree
1834gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1835{
1836 stmtblock_t body;
1837
1838 gfc_finish_decl (cl->backend_decl, NULL_TREE);
1839
1840 gfc_start_block (&body);
1841
1842 /* Evaluate the string length expression. */
1843 gfc_trans_init_string_length (cl, &body);
1844
1845 gfc_add_expr_to_block (&body, fnbody);
1846 return gfc_finish_block (&body);
1847}
1848
1849
1850/* Allocate and cleanup an automatic character variable. */
1851
1852static tree
1853gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1854{
1855 stmtblock_t body;
1856 tree decl;
4ee9c684 1857 tree tmp;
1858
1859 assert (sym->backend_decl);
1860 assert (sym->ts.cl && sym->ts.cl->length);
1861
1862 gfc_start_block (&body);
1863
1864 /* Evaluate the string length expression. */
1865 gfc_trans_init_string_length (sym->ts.cl, &body);
1866
1867 decl = sym->backend_decl;
1868
afcf285e 1869 /* Emit a DECL_EXPR for this variable, which will cause the
4b3a701c 1870 gimplifier to allocate storage, and all that good stuff. */
ed52ef8b 1871 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4ee9c684 1872 gfc_add_expr_to_block (&body, tmp);
afcf285e 1873
4ee9c684 1874 gfc_add_expr_to_block (&body, fnbody);
1875 return gfc_finish_block (&body);
1876}
1877
1878
1879/* Generate function entry and exit code, and add it to the function body.
1880 This includes:
f888a3fb 1881 Allocation and initialization of array variables.
4ee9c684 1882 Allocation of character string variables.
1883 Initialization and possibly repacking of dummy arrays. */
1884
1885static tree
1886gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
1887{
1888 locus loc;
1889 gfc_symbol *sym;
1890
1891 /* Deal with implicit return variables. Explicit return variables will
1892 already have been added. */
1893 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
1894 {
1895 if (!current_fake_result_decl)
1896 {
1897 warning ("Function does not return a value");
1898 return fnbody;
1899 }
1900
1901 if (proc_sym->as)
1902 {
1903 fnbody = gfc_trans_dummy_array_bias (proc_sym,
1904 current_fake_result_decl,
1905 fnbody);
1906 }
1907 else if (proc_sym->ts.type == BT_CHARACTER)
1908 {
1909 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
1910 fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
1911 }
1912 else
1913 gfc_todo_error ("Deferred non-array return by reference");
1914 }
1915
1916 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
1917 {
1918 if (sym->attr.dimension)
1919 {
1920 switch (sym->as->type)
1921 {
1922 case AS_EXPLICIT:
1923 if (sym->attr.dummy || sym->attr.result)
1924 fnbody =
1925 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
1926 else if (sym->attr.pointer || sym->attr.allocatable)
1927 {
1928 if (TREE_STATIC (sym->backend_decl))
1929 gfc_trans_static_array_pointer (sym);
1930 else
1931 fnbody = gfc_trans_deferred_array (sym, fnbody);
1932 }
1933 else
1934 {
1935 gfc_get_backend_locus (&loc);
1936 gfc_set_backend_locus (&sym->declared_at);
1937 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
1938 sym, fnbody);
1939 gfc_set_backend_locus (&loc);
1940 }
1941 break;
1942
1943 case AS_ASSUMED_SIZE:
1944 /* Must be a dummy parameter. */
1945 assert (sym->attr.dummy);
1946
1947 /* We should always pass assumed size arrays the g77 way. */
4ee9c684 1948 fnbody = gfc_trans_g77_array (sym, fnbody);
1949 break;
1950
1951 case AS_ASSUMED_SHAPE:
1952 /* Must be a dummy parameter. */
1953 assert (sym->attr.dummy);
1954
1955 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
1956 fnbody);
1957 break;
1958
1959 case AS_DEFERRED:
1960 fnbody = gfc_trans_deferred_array (sym, fnbody);
1961 break;
1962
1963 default:
1964 abort ();
1965 }
1966 }
1967 else if (sym->ts.type == BT_CHARACTER)
1968 {
1969 gfc_get_backend_locus (&loc);
1970 gfc_set_backend_locus (&sym->declared_at);
1971 if (sym->attr.dummy || sym->attr.result)
1972 fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
1973 else
1974 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
1975 gfc_set_backend_locus (&loc);
1976 }
1977 else
1978 abort ();
1979 }
1980
1981 return fnbody;
1982}
1983
1984
1985/* Output an initialized decl for a module variable. */
1986
1987static void
1988gfc_create_module_variable (gfc_symbol * sym)
1989{
1990 tree decl;
4ee9c684 1991
1992 /* Only output symbols from this module. */
1993 if (sym->ns != module_namespace)
1994 {
1995 /* I don't think this should ever happen. */
1996 internal_error ("module symbol %s in wrong namespace", sym->name);
1997 }
1998
4ee9c684 1999 /* Only output variables and array valued parametes. */
2000 if (sym->attr.flavor != FL_VARIABLE
2001 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2002 return;
2003
d43a7f7f 2004 /* Don't generate variables from other modules. Variables from
2005 COMMONs will already have been generated. */
2006 if (sym->attr.use_assoc || sym->attr.in_common)
4ee9c684 2007 return;
2008
2009 if (sym->backend_decl)
2010 internal_error ("backend decl for module variable %s already exists",
2011 sym->name);
2012
2013 /* We always want module variables to be created. */
2014 sym->attr.referenced = 1;
2015 /* Create the decl. */
2016 decl = gfc_get_symbol_decl (sym);
2017
4ee9c684 2018 /* Create the variable. */
2019 pushdecl (decl);
b2c4af5e 2020 rest_of_decl_compilation (decl, 1, 0);
4ee9c684 2021
2022 /* Also add length of strings. */
2023 if (sym->ts.type == BT_CHARACTER)
2024 {
2025 tree length;
2026
2027 length = sym->ts.cl->backend_decl;
2028 if (!INTEGER_CST_P (length))
2029 {
2030 pushdecl (length);
b2c4af5e 2031 rest_of_decl_compilation (length, 1, 0);
4ee9c684 2032 }
2033 }
2034}
2035
2036
2037/* Generate all the required code for module variables. */
2038
2039void
2040gfc_generate_module_vars (gfc_namespace * ns)
2041{
2042 module_namespace = ns;
2043
dfc222eb 2044 /* Check if the frontend left the namespace in a reasonable state. */
4ee9c684 2045 assert (ns->proc_name && !ns->proc_name->tlink);
2046
d43a7f7f 2047 /* Generate COMMON blocks. */
2048 gfc_trans_common (ns);
2049
dfc222eb 2050 /* Create decls for all the module variables. */
4ee9c684 2051 gfc_traverse_ns (ns, gfc_create_module_variable);
2052}
2053
2054static void
2055gfc_generate_contained_functions (gfc_namespace * parent)
2056{
2057 gfc_namespace *ns;
2058
2059 /* We create all the prototypes before generating any code. */
2060 for (ns = parent->contained; ns; ns = ns->sibling)
2061 {
2062 /* Skip namespaces from used modules. */
2063 if (ns->parent != parent)
2064 continue;
2065
1b716045 2066 gfc_create_function_decl (ns);
4ee9c684 2067 }
2068
2069 for (ns = parent->contained; ns; ns = ns->sibling)
2070 {
2071 /* Skip namespaces from used modules. */
2072 if (ns->parent != parent)
2073 continue;
2074
2075 gfc_generate_function_code (ns);
2076 }
2077}
2078
2079
2080/* Generate decls for all local variables. We do this to ensure correct
2081 handling of expressions which only appear in the specification of
2082 other functions. */
2083
2084static void
2085generate_local_decl (gfc_symbol * sym)
2086{
2087 if (sym->attr.flavor == FL_VARIABLE)
2088 {
4ee9c684 2089 if (sym->attr.referenced)
2090 gfc_get_symbol_decl (sym);
2091 else if (sym->attr.dummy)
2092 {
2093 if (warn_unused_parameter)
2094 warning ("unused parameter `%s'", sym->name);
2095 }
f888a3fb 2096 /* Warn for unused variables, but not if they're inside a common
36609028 2097 block or are use_associated. */
2098 else if (warn_unused_variable
2099 && !(sym->attr.in_common || sym->attr.use_assoc))
2100 warning ("unused variable `%s'", sym->name);
4ee9c684 2101 }
2102}
2103
2104static void
2105generate_local_vars (gfc_namespace * ns)
2106{
2107 gfc_traverse_ns (ns, generate_local_decl);
2108}
2109
2110
1b716045 2111/* Generate a switch statement to jump to the correct entry point. Also
2112 creates the label decls for the entry points. */
4ee9c684 2113
1b716045 2114static tree
2115gfc_trans_entry_master_switch (gfc_entry_list * el)
4ee9c684 2116{
1b716045 2117 stmtblock_t block;
2118 tree label;
2119 tree tmp;
2120 tree val;
4ee9c684 2121
1b716045 2122 gfc_init_block (&block);
2123 for (; el; el = el->next)
2124 {
2125 /* Add the case label. */
2126 label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2127 DECL_CONTEXT (label) = current_function_decl;
7016c612 2128 val = build_int_cst (gfc_array_index_type, el->id);
ed52ef8b 2129 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
1b716045 2130 gfc_add_expr_to_block (&block, tmp);
2131
2132 /* And jump to the actual entry point. */
2133 label = gfc_build_label_decl (NULL_TREE);
2134 TREE_USED (label) = 1;
2135 DECL_CONTEXT (label) = current_function_decl;
2136 tmp = build1_v (GOTO_EXPR, label);
2137 gfc_add_expr_to_block (&block, tmp);
2138
2139 /* Save the label decl. */
2140 el->label = label;
2141 }
2142 tmp = gfc_finish_block (&block);
2143 /* The first argument selects the entry point. */
2144 val = DECL_ARGUMENTS (current_function_decl);
ed52ef8b 2145 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
1b716045 2146 return tmp;
4ee9c684 2147}
2148
6374121b 2149
4ee9c684 2150/* Generate code for a function. */
2151
2152void
2153gfc_generate_function_code (gfc_namespace * ns)
2154{
2155 tree fndecl;
2156 tree old_context;
2157 tree decl;
2158 tree tmp;
2159 stmtblock_t block;
2160 stmtblock_t body;
2161 tree result;
2162 gfc_symbol *sym;
2163
2164 sym = ns->proc_name;
1b716045 2165
4ee9c684 2166 /* Check that the frontend isn't still using this. */
2167 assert (sym->tlink == NULL);
4ee9c684 2168 sym->tlink = sym;
2169
2170 /* Create the declaration for functions with global scope. */
2171 if (!sym->backend_decl)
1b716045 2172 gfc_create_function_decl (ns);
4ee9c684 2173
2174 fndecl = sym->backend_decl;
2175 old_context = current_function_decl;
2176
2177 if (old_context)
2178 {
2179 push_function_context ();
2180 saved_parent_function_decls = saved_function_decls;
2181 saved_function_decls = NULL_TREE;
2182 }
2183
1b716045 2184 trans_function_start (sym);
4ee9c684 2185
2186 /* Will be created as needed. */
2187 current_fake_result_decl = NULL_TREE;
2188
4ee9c684 2189 gfc_start_block (&block);
2190
2191 gfc_generate_contained_functions (ns);
2192
2193 /* Translate COMMON blocks. */
2194 gfc_trans_common (ns);
2195
2196 generate_local_vars (ns);
2197
2198 current_function_return_label = NULL;
2199
2200 /* Now generate the code for the body of this function. */
2201 gfc_init_block (&body);
2202
2203 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2204 && sym->attr.subroutine)
2205 {
2206 tree alternate_return;
2207 alternate_return = gfc_get_fake_result_decl (sym);
2208 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2209 }
2210
1b716045 2211 if (ns->entries)
2212 {
2213 /* Jump to the correct entry point. */
2214 tmp = gfc_trans_entry_master_switch (ns->entries);
2215 gfc_add_expr_to_block (&body, tmp);
2216 }
2217
4ee9c684 2218 tmp = gfc_trans_code (ns->code);
2219 gfc_add_expr_to_block (&body, tmp);
2220
2221 /* Add a return label if needed. */
2222 if (current_function_return_label)
2223 {
2224 tmp = build1_v (LABEL_EXPR, current_function_return_label);
2225 gfc_add_expr_to_block (&body, tmp);
2226 }
2227
2228 tmp = gfc_finish_block (&body);
2229 /* Add code to create and cleanup arrays. */
2230 tmp = gfc_trans_deferred_vars (sym, tmp);
2231 gfc_add_expr_to_block (&block, tmp);
2232
2233 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2234 {
2235 if (sym->attr.subroutine ||sym == sym->result)
2236 {
2237 result = current_fake_result_decl;
2238 current_fake_result_decl = NULL_TREE;
2239 }
2240 else
2241 result = sym->result->backend_decl;
2242
2243 if (result == NULL_TREE)
2244 warning ("Function return value not set");
2245 else
2246 {
f888a3fb 2247 /* Set the return value to the dummy result variable. */
ed52ef8b 2248 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2249 DECL_RESULT (fndecl), result);
2250 tmp = build1_v (RETURN_EXPR, tmp);
4ee9c684 2251 gfc_add_expr_to_block (&block, tmp);
2252 }
2253 }
2254
2255 /* Add all the decls we created during processing. */
2256 decl = saved_function_decls;
2257 while (decl)
2258 {
2259 tree next;
2260
2261 next = TREE_CHAIN (decl);
2262 TREE_CHAIN (decl) = NULL_TREE;
2263 pushdecl (decl);
2264 decl = next;
2265 }
2266 saved_function_decls = NULL_TREE;
2267
2268 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2269
2270 /* Finish off this function and send it for code generation. */
2271 poplevel (1, 0, 1);
2272 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2273
2274 /* Output the GENERIC tree. */
2275 dump_function (TDI_original, fndecl);
2276
2277 /* Store the end of the function, so that we get good line number
2278 info for the epilogue. */
2279 cfun->function_end_locus = input_location;
2280
2281 /* We're leaving the context of this function, so zap cfun.
2282 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2283 tree_rest_of_compilation. */
2284 cfun = NULL;
2285
2286 if (old_context)
2287 {
2288 pop_function_context ();
2289 saved_function_decls = saved_parent_function_decls;
2290 }
2291 current_function_decl = old_context;
2292
2293 if (decl_function_context (fndecl))
6374121b 2294 /* Register this function with cgraph just far enough to get it
2295 added to our parent's nested function list. */
2296 (void) cgraph_node (fndecl);
4ee9c684 2297 else
2298 {
6374121b 2299 gfc_gimplify_function (fndecl);
2300 lower_nested_functions (fndecl);
4ee9c684 2301 gfc_finalize (fndecl);
2302 }
2303}
2304
4ee9c684 2305void
2306gfc_generate_constructors (void)
2307{
2308 if (gfc_static_ctors != NULL_TREE)
2309 abort ();
2310#if 0
2311 tree fnname;
2312 tree type;
2313 tree fndecl;
2314 tree decl;
2315 tree tmp;
2316
2317 if (gfc_static_ctors == NULL_TREE)
2318 return;
2319
2320 fnname = get_file_function_name ('I');
2321 type = build_function_type (void_type_node,
2322 gfc_chainon_list (NULL_TREE, void_type_node));
2323
2324 fndecl = build_decl (FUNCTION_DECL, fnname, type);
2325 TREE_PUBLIC (fndecl) = 1;
2326
2327 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
540edea7 2328 DECL_ARTIFICIAL (decl) = 1;
2329 DECL_IGNORED_P (decl) = 1;
4ee9c684 2330 DECL_CONTEXT (decl) = fndecl;
2331 DECL_RESULT (fndecl) = decl;
2332
2333 pushdecl (fndecl);
2334
2335 current_function_decl = fndecl;
2336
b2c4af5e 2337 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 2338
b2c4af5e 2339 make_decl_rtl (fndecl);
4ee9c684 2340
2341 init_function_start (fndecl, input_filename, input_line);
2342
4ee9c684 2343 pushlevel (0);
2344
2345 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2346 {
2347 tmp =
2348 gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2349 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2350 }
2351
2352 poplevel (1, 0, 1);
2353
2354 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2355
2356 free_after_parsing (cfun);
2357 free_after_compilation (cfun);
2358
2359 tree_rest_of_compilation (fndecl, 0);
2360
2361 current_function_decl = NULL_TREE;
2362#endif
2363}
2364
9ec7c303 2365/* Translates a BLOCK DATA program unit. This means emitting the
2366 commons contained therein plus their initializations. We also emit
2367 a globally visible symbol to make sure that each BLOCK DATA program
2368 unit remains unique. */
2369
2370void
2371gfc_generate_block_data (gfc_namespace * ns)
2372{
2373 tree decl;
2374 tree id;
2375
2376 gfc_trans_common (ns);
2377
2378 if (ns->proc_name)
2379 id = gfc_sym_mangled_function_id (ns->proc_name);
2380 else
2381 id = get_identifier ("__BLOCK_DATA__");
2382
2383 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2384 TREE_PUBLIC (decl) = 1;
2385 TREE_STATIC (decl) = 1;
2386
2387 pushdecl (decl);
2388 rest_of_decl_compilation (decl, 1, 0);
2389}
2390
4ee9c684 2391#include "gt-fortran-trans-decl.h"
Mirror of https://gcc.gnu.org/git/gcc.git