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