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