1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
11 * Copyright (C) 1992-2001 Free Software Foundation, Inc. *
13 * GNAT is free software; you can redistribute it and/or modify it under *
14 * terms of the GNU General Public License as published by the Free Soft- *
15 * ware Foundation; either version 2, or (at your option) any later ver- *
16 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
17 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
18 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
19 * for more details. You should have received a copy of the GNU General *
20 * Public License distributed with GNAT; see file COPYING. If not, write *
21 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
22 * MA 02111-1307, USA. *
24 * As a special exception, if you link this file with other files to *
25 * produce an executable, this file does not by itself cause the resulting *
26 * executable to be covered by the GNU General Public License. This except- *
27 * ion does not however invalidate any other reasons why the executable *
28 * file might be covered by the GNU Public License. *
30 * GNAT was originally developed by the GNAT team at New York University. *
31 * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
33 ****************************************************************************/
35 /* This file contains parts of the compiler that are required for interfacing
36 with GCC but otherwise do nothing and parts of Gigi that need to know
44 #include "diagnostic.h"
48 #include "insn-flags.h"
49 #include "insn-config.h"
55 #include "langhooks.h"
56 #include "langhooks-def.h"
72 extern FILE *asm_out_file
;
74 extern char **save_argv
;
76 /* Tables describing GCC tree codes used only by GNAT.
78 Table indexed by tree code giving a string containing a character
79 classifying the tree code. Possibilities are
80 t, d, s, c, r, <, 1 and 2. See cp-tree.def for details. */
82 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
84 char gnat_tree_code_type
[] = {
86 #include "ada-tree.def"
90 /* Table indexed by tree code giving number of expression
91 operands beyond the fixed part of the node structure.
92 Not used for types or decls. */
94 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
96 int gnat_tree_code_length
[] = {
98 #include "ada-tree.def"
102 /* Names of tree components.
103 Used for printing out the tree and error messages. */
104 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
106 const char *gnat_tree_code_name
[] = {
108 #include "ada-tree.def"
112 static void gnat_init
PARAMS ((void));
113 static void gnat_init_options
PARAMS ((void));
114 static int gnat_decode_option
PARAMS ((int, char **));
115 static HOST_WIDE_INT gnat_get_alias_set
PARAMS ((tree
));
117 /* Structure giving our language-specific hooks. */
119 #undef LANG_HOOKS_NAME
120 #define LANG_HOOKS_NAME "GNU Ada"
121 #undef LANG_HOOKS_IDENTIFIER_SIZE
122 #define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier)
123 #undef LANG_HOOKS_INIT
124 #define LANG_HOOKS_INIT gnat_init
125 #undef LANG_HOOKS_INIT_OPTIONS
126 #define LANG_HOOKS_INIT_OPTIONS gnat_init_options
127 #undef LANG_HOOKS_DECODE_OPTION
128 #define LANG_HOOKS_DECODE_OPTION gnat_decode_option
129 #undef LANG_HOOKS_HONOR_READONLY
130 #define LANG_HOOKS_HONOR_READONLY 1
131 #undef LANG_HOOKS_GET_ALIAS_SET
132 #define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set
134 const struct lang_hooks lang_hooks
= LANG_HOOKS_INITIALIZER
;
136 /* gnat standard argc argv */
138 extern int gnat_argc
;
139 extern char **gnat_argv
;
141 /* Global Variables Expected by gcc: */
143 int flag_traditional
; /* Used by dwarfout.c. */
146 static void internal_error_function
PARAMS ((const char *, va_list *));
147 static rtx gnat_expand_expr
PARAMS ((tree
, rtx
, enum machine_mode
,
148 enum expand_modifier
));
149 static tree gnat_expand_constant
PARAMS ((tree
));
150 static void gnat_adjust_rli
PARAMS ((record_layout_info
));
152 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
153 static char *convert_ada_name_to_qualified_name
PARAMS ((char *));
156 /* Routines Expected by gcc: */
158 /* For most front-ends, this is the parser for the language. For us, we
159 process the GNAT tree. */
161 /* Declare functions we use as part of startup. */
162 extern void __gnat_initialize
PARAMS((void));
163 extern void adainit
PARAMS((void));
164 extern void _ada_gnat1drv
PARAMS((void));
169 /* call the target specific initializations */
172 /* Call the front-end elaboration procedures */
175 immediate_size_expand
= 1;
177 /* Call the front end */
183 /* Decode all the language specific options that cannot be decoded by GCC.
184 The option decoding phase of GCC calls this routine on the flags that
185 it cannot decode. This routine returns 1 if it is successful, otherwise
189 gnat_decode_option (argc
, argv
)
190 int argc ATTRIBUTE_UNUSED
;
196 if (!strncmp (p
, "-I", 2))
198 /* Pass the -I switches as-is. */
199 gnat_argv
[gnat_argc
] = p
;
204 else if (!strncmp (p
, "-gant", 5))
206 char *q
= (char *) xmalloc (strlen (p
) + 1);
208 warning ("`-gnat' misspelled as `-gant'");
210 q
[2] = 'n', q
[3] = 'a';
215 else if (!strncmp (p
, "-gnat", 5))
217 /* Recopy the switches without the 'gnat' prefix */
219 gnat_argv
[gnat_argc
] = (char *) xmalloc (strlen (p
) - 3);
220 gnat_argv
[gnat_argc
][0] = '-';
221 strcpy (gnat_argv
[gnat_argc
] + 1, p
+ 5);
224 for (i
= 1; i
< save_argc
- 1; i
++)
225 if (!strncmp (save_argv
[i
], "-gnatO", 6))
226 if (save_argv
[++i
][0] != '-')
228 /* Preserve output filename as GCC doesn't save it for GNAT. */
229 gnat_argv
[gnat_argc
] = save_argv
[i
];
237 /* Ignore -W flags since people may want to use the same flags for all
239 else if (p
[0] == '-' && p
[1] == 'W' && p
[2] != 0)
245 /* Initialize for option processing. */
250 /* Initialize gnat_argv with save_argv size */
251 gnat_argv
= (char **) xmalloc ((save_argc
+ 1) * sizeof (gnat_argv
[0]));
252 gnat_argv
[0] = save_argv
[0]; /* name of the command */
260 switch (TREE_CODE (t
))
263 ggc_mark_tree (TYPE_CI_CO_LIST (t
));
267 if (TYPE_MODULAR_P (t
))
268 ggc_mark_tree (TYPE_MODULUS (t
));
269 else if (TYPE_VAX_FLOATING_POINT_P (t
))
271 else if (TYPE_HAS_ACTUAL_BOUNDS_P (t
))
272 ggc_mark_tree (TYPE_ACTUAL_BOUNDS (t
));
274 ggc_mark_tree (TYPE_INDEX_TYPE (t
));
278 ggc_mark_tree (TYPE_RM_SIZE_ENUM (t
));
282 ggc_mark_tree (TYPE_ACTUAL_BOUNDS (t
));
285 case RECORD_TYPE
: case UNION_TYPE
: case QUAL_UNION_TYPE
:
286 /* This is really TYPE_UNCONSTRAINED_ARRAY for fat pointers. */
287 ggc_mark_tree (TYPE_ADA_SIZE (t
));
291 ggc_mark_tree (DECL_CONST_CORRESPONDING_VAR (t
));
295 ggc_mark_tree (DECL_ORIGINAL_FIELD (t
));
303 /* Here we have the function to handle the compiler error processing in GCC.
304 Do this only if VPRINTF is available. */
306 #if defined(HAVE_VPRINTF)
307 #define DO_INTERNAL_ERROR_FUNCTION
310 internal_error_function (msgid
, ap
)
314 char buffer
[1000]; /* Assume this is big enough. */
316 String_Template temp
;
319 vsprintf (buffer
, msgid
, *ap
);
321 /* Go up to the first newline. */
322 for (p
= buffer
; *p
!= 0; p
++)
329 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (buffer
);
330 fp
.Array
= buffer
, fp
.Bounds
= &temp
;
332 Current_Error_Node
= error_gnat_node
;
333 Compiler_Abort (fp
, -1);
337 /* Perform all the initialization steps that are language-specific. */
342 /* Add the input filename as the last argument. */
343 gnat_argv
[gnat_argc
] = (char *) input_filename
;
345 gnat_argv
[gnat_argc
] = 0;
347 #ifdef DO_INTERNAL_ERROR_FUNCTION
348 set_internal_error_function (internal_error_function
);
351 /* Show that REFERENCE_TYPEs are internal and should be Pmode. */
352 internal_reference_types ();
354 /* Show we don't use the common language attributes. */
355 lang_attribute_common
= 0;
357 set_lang_adjust_rli (gnat_adjust_rli
);
359 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
360 dwarf2out_set_demangle_name_func (convert_ada_name_to_qualified_name
);
364 /* If DECL has a cleanup, build and return that cleanup here.
365 This is a callback called by expand_expr. */
368 maybe_build_cleanup (decl
)
369 tree decl ATTRIBUTE_UNUSED
;
371 /* There are no cleanups in C. */
375 /* Print any language-specific compilation statistics. */
378 print_lang_statistics ()
382 lang_print_xnode (file
, node
, indent
)
383 FILE *file ATTRIBUTE_UNUSED
;
384 tree node ATTRIBUTE_UNUSED
;
385 int indent ATTRIBUTE_UNUSED
;
389 /* integrate_decl_tree calls this function, but since we don't use the
390 DECL_LANG_SPECIFIC field, this is a no-op. */
393 copy_lang_decl (node
)
394 tree node ATTRIBUTE_UNUSED
;
398 /* Hooks for print-tree.c: */
401 print_lang_decl (file
, node
, indent
)
406 switch (TREE_CODE (node
))
409 print_node (file
, "const_corresponding_var",
410 DECL_CONST_CORRESPONDING_VAR (node
), indent
+ 4);
414 print_node (file
, "original field", DECL_ORIGINAL_FIELD (node
),
424 print_lang_type (file
, node
, indent
)
429 switch (TREE_CODE (node
))
432 print_node (file
, "ci_co_list", TYPE_CI_CO_LIST (node
), indent
+ 4);
436 print_node (file
, "RM size", TYPE_RM_SIZE_ENUM (node
), indent
+ 4);
440 if (TYPE_MODULAR_P (node
))
441 print_node (file
, "modulus", TYPE_MODULUS (node
), indent
+ 4);
442 else if (TYPE_HAS_ACTUAL_BOUNDS_P (node
))
443 print_node (file
, "actual bounds", TYPE_ACTUAL_BOUNDS (node
),
445 else if (TYPE_VAX_FLOATING_POINT_P (node
))
448 print_node (file
, "index type", TYPE_INDEX_TYPE (node
), indent
+ 4);
450 print_node (file
, "RM size", TYPE_RM_SIZE_INT (node
), indent
+ 4);
454 print_node (file
,"actual bounds", TYPE_ACTUAL_BOUNDS (node
), indent
+ 4);
458 if (TYPE_IS_FAT_POINTER_P (node
) || TYPE_CONTAINS_TEMPLATE_P (node
))
459 print_node (file
, "unconstrained array",
460 TYPE_UNCONSTRAINED_ARRAY (node
), indent
+ 4);
462 print_node (file
, "Ada size", TYPE_ADA_SIZE (node
), indent
+ 4);
466 case QUAL_UNION_TYPE
:
467 print_node (file
, "Ada size", TYPE_ADA_SIZE (node
), indent
+ 4);
476 print_lang_identifier (file
, node
, indent
)
477 FILE *file ATTRIBUTE_UNUSED
;
478 tree node ATTRIBUTE_UNUSED
;
479 int indent ATTRIBUTE_UNUSED
;
482 /* Expands GNAT-specific GCC tree nodes. The only ones we support
483 here are TRANSFORM_EXPR, UNCHECKED_CONVERT_EXPR, ALLOCATE_EXPR,
484 USE_EXPR and NULL_EXPR. */
487 gnat_expand_expr (exp
, target
, tmode
, modifier
)
490 enum machine_mode tmode
;
491 enum expand_modifier modifier
;
493 tree type
= TREE_TYPE (exp
);
499 /* Update EXP to be the new expression to expand. */
501 switch (TREE_CODE (exp
))
504 gnat_to_code (TREE_COMPLEXITY (exp
));
508 case UNCHECKED_CONVERT_EXPR
:
509 inner_type
= TREE_TYPE (TREE_OPERAND (exp
, 0));
511 /* The alignment is OK if the flag saying it is OK is set in either
512 type, if the inner type is already maximally aligned, if the
513 new type is no more strictly aligned than the old type, or
514 if byte accesses are not slow. */
515 align_ok
= (! SLOW_BYTE_ACCESS
516 || TYPE_ALIGN_OK_P (type
) || TYPE_ALIGN_OK_P (inner_type
)
517 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
518 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
));
520 /* If we're converting between an aggregate and non-aggregate type
521 and we have a MEM TARGET, we can't use it, since MEM_IN_STRUCT_P
522 would be set incorrectly. */
523 if (target
!= 0 && GET_CODE (target
) == MEM
524 && (MEM_IN_STRUCT_P (target
) != AGGREGATE_TYPE_P (inner_type
)))
527 /* If the input and output are both the same mode (usually BLKmode),
528 just return the expanded input since we want just the bits. But
529 we can't do this if the output is more strictly aligned than
530 the input or if the type is BLKmode and the sizes differ. */
531 if (TYPE_MODE (type
) == TYPE_MODE (inner_type
)
533 && ! (TYPE_MODE (type
) == BLKmode
534 && ! operand_equal_p (TYPE_SIZE (type
),
535 TYPE_SIZE (inner_type
), 0)))
537 new = TREE_OPERAND (exp
, 0);
539 /* If the new type is less strictly aligned than the inner type,
540 make a new type with the less strict alignment just for
541 code generation purposes of this node. If it is a decl,
542 we can't change the type, so make a NOP_EXPR. */
543 if (TYPE_ALIGN (type
) != TYPE_ALIGN (inner_type
))
545 tree copy_type
= copy_node (inner_type
);
547 TYPE_ALIGN (copy_type
) = TYPE_ALIGN (type
);
549 new = build1 (NOP_EXPR
, copy_type
, new);
552 /* If NEW is a constant, it might be coming from a CONST_DECL
554 if (TREE_CONSTANT (new))
555 new = copy_node (new);
557 TREE_TYPE (new) = copy_type
;
562 /* If either mode is BLKmode, memory will be involved, so do this
563 via pointer punning. Likewise, this doesn't work if there
564 is an alignment issue. But we must do it for types that are known
565 to be aligned properly. */
566 else if ((TYPE_MODE (type
) == BLKmode
567 || TYPE_MODE (inner_type
) == BLKmode
)
569 new = build_unary_op (INDIRECT_REF
, NULL_TREE
,
571 (build_pointer_type (type
),
572 build_unary_op (ADDR_EXPR
, NULL_TREE
,
573 TREE_OPERAND (exp
, 0))));
575 /* Otherwise make a union of the two types, convert to the union, and
576 extract the other value. */
579 tree union_type
, in_field
, out_field
;
581 /* If this is inside the LHS of an assignment, this would generate
582 bad code, so abort. */
583 if (TREE_ADDRESSABLE (exp
))
586 union_type
= make_node (UNION_TYPE
);
587 in_field
= create_field_decl (get_identifier ("in"),
588 inner_type
, union_type
, 0, 0, 0, 0);
589 out_field
= create_field_decl (get_identifier ("out"),
590 type
, union_type
, 0, 0, 0, 0);
592 TYPE_FIELDS (union_type
) = chainon (in_field
, out_field
);
593 layout_type (union_type
);
595 /* Though this is a "union", we can treat its size as that of
596 the output type in case the size of the input type is variable.
597 If the output size is a variable, use the input size. */
598 TYPE_SIZE (union_type
) = TYPE_SIZE (type
);
599 TYPE_SIZE_UNIT (union_type
) = TYPE_SIZE (type
);
600 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
601 && TREE_CODE (TYPE_SIZE (inner_type
)) == INTEGER_CST
)
603 TYPE_SIZE (union_type
) = TYPE_SIZE (inner_type
);
604 TYPE_SIZE_UNIT (union_type
) = TYPE_SIZE_UNIT (inner_type
);
607 new = build (COMPONENT_REF
, type
,
608 build1 (CONVERT_EXPR
, union_type
,
609 TREE_OPERAND (exp
, 0)),
613 result
= expand_expr (new, target
, tmode
, modifier
);
615 if (GET_CODE (result
) == MEM
)
617 /* Update so it looks like this is of the proper type. */
618 set_mem_alias_set (result
, 0);
619 set_mem_attributes (result
, exp
, 0);
624 expand_expr (TREE_OPERAND (exp
, 0), const0_rtx
, VOIDmode
, 0);
626 /* We aren't going to be doing anything with this memory, but allocate
627 it anyway. If it's variable size, make a bogus address. */
628 if (! host_integerp (TYPE_SIZE_UNIT (type
), 1))
629 result
= gen_rtx_MEM (BLKmode
, virtual_stack_vars_rtx
);
631 result
= assign_temp (type
, 0, TREE_ADDRESSABLE (exp
), 1);
637 allocate_dynamic_stack_space
638 (expand_expr (TREE_OPERAND (exp
, 0), NULL_RTX
, TYPE_MODE (sizetype
),
640 NULL_RTX
, tree_low_cst (TREE_OPERAND (exp
, 1), 1));
643 if (target
!= const0_rtx
)
646 /* First write a volatile ASM_INPUT to prevent anything from being
648 result
= gen_rtx_ASM_INPUT (VOIDmode
, "");
649 MEM_VOLATILE_P (result
) = 1;
652 result
= expand_expr (TREE_OPERAND (exp
, 0), NULL_RTX
, VOIDmode
,
654 emit_insn (gen_rtx_USE (VOIDmode
, result
));
658 return expand_expr (build1 (NOP_EXPR
, type
, TREE_OPERAND (exp
, 0)),
659 target
, tmode
, modifier
);
661 case UNCONSTRAINED_ARRAY_REF
:
662 /* If we are evaluating just for side-effects, just evaluate our
663 operand. Otherwise, abort since this code should never appear
664 in a tree to be evaluated (objects aren't unconstrained). */
665 if (target
== const0_rtx
|| TREE_CODE (type
) == VOID_TYPE
)
666 return expand_expr (TREE_OPERAND (exp
, 0), const0_rtx
,
669 /* ... fall through ... */
675 return expand_expr (new, target
, tmode
, modifier
);
678 /* Transform a constant into a form that the language-independent code
682 gnat_expand_constant (exp
)
685 /* If this is an unchecked conversion that does not change the size of the
686 object, return the operand since the underlying constant is still
687 the same. Otherwise, return our operand. */
688 if (TREE_CODE (exp
) == UNCHECKED_CONVERT_EXPR
689 && operand_equal_p (TYPE_SIZE_UNIT (TREE_TYPE (exp
)),
690 TYPE_SIZE_UNIT (TREE_TYPE (TREE_OPERAND (exp
, 0))),
692 return TREE_OPERAND (exp
, 0);
697 /* Adjusts the RLI used to layout a record after all the fields have been
698 added. We only handle the packed case and cause it to use the alignment
699 that will pad the record at the end. */
702 gnat_adjust_rli (rli
)
703 record_layout_info rli
;
705 if (TYPE_PACKED (rli
->t
))
706 rli
->record_align
= rli
->unpadded_align
;
709 /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code. */
712 make_transform_expr (gnat_node
)
715 tree gnu_result
= build (TRANSFORM_EXPR
, void_type_node
);
717 TREE_SIDE_EFFECTS (gnu_result
) = 1;
718 TREE_COMPLEXITY (gnu_result
) = gnat_node
;
722 /* Update the setjmp buffer BUF with the current stack pointer. We assume
723 here that a __builtin_setjmp was done to BUF. */
726 update_setjmp_buf (buf
)
729 enum machine_mode sa_mode
= Pmode
;
732 #ifdef HAVE_save_stack_nonlocal
733 if (HAVE_save_stack_nonlocal
)
734 sa_mode
= insn_operand_mode
[(int) CODE_FOR_save_stack_nonlocal
][0];
736 #ifdef STACK_SAVEAREA_MODE
737 sa_mode
= STACK_SAVEAREA_MODE (SAVE_NONLOCAL
);
741 = gen_rtx_MEM (sa_mode
,
744 plus_constant (expand_expr
745 (build_unary_op (ADDR_EXPR
, NULL_TREE
, buf
),
746 NULL_RTX
, VOIDmode
, 0),
747 2 * GET_MODE_SIZE (Pmode
))));
751 emit_insn (gen_setjmp ());
754 emit_stack_save (SAVE_NONLOCAL
, &stack_save
, NULL_RTX
);
757 /* See if DECL has an RTL that is indirect via a pseudo-register or a
758 memory location and replace it with an indirect reference if so.
759 This improves the debugger's ability to display the value. */
762 adjust_decl_rtl (decl
)
767 /* If this decl is already indirect, don't do anything. This should
768 mean that the decl cannot be indirect, but there's no point in
769 adding an abort to check that. */
770 if (TREE_CODE (decl
) != CONST_DECL
771 && ! DECL_BY_REF_P (decl
)
772 && (GET_CODE (DECL_RTL (decl
)) == MEM
773 && (GET_CODE (XEXP (DECL_RTL (decl
), 0)) == MEM
774 || (GET_CODE (XEXP (DECL_RTL (decl
), 0)) == REG
775 && (REGNO (XEXP (DECL_RTL (decl
), 0))
776 > LAST_VIRTUAL_REGISTER
))))
777 /* We can't do this if the reference type's mode is not the same
778 as the current mode, which means this may not work on mixed 32/64
780 && (new_type
= build_reference_type (TREE_TYPE (decl
))) != 0
781 && TYPE_MODE (new_type
) == GET_MODE (XEXP (DECL_RTL (decl
), 0))
782 /* If this is a PARM_DECL, we can only do it if DECL_INCOMING_RTL
783 is also an indirect and of the same mode and if the object is
784 readonly, the latter condition because we don't want to upset the
785 handling of CICO_LIST. */
786 && (TREE_CODE (decl
) != PARM_DECL
787 || (GET_CODE (DECL_INCOMING_RTL (decl
)) == MEM
788 && (TYPE_MODE (new_type
)
789 == GET_MODE (XEXP (DECL_INCOMING_RTL (decl
), 0)))
790 && TREE_READONLY (decl
))))
793 = build_qualified_type (new_type
,
794 (TYPE_QUALS (new_type
) | TYPE_QUAL_CONST
));
796 DECL_POINTS_TO_READONLY_P (decl
) = TREE_READONLY (decl
);
797 DECL_BY_REF_P (decl
) = 1;
798 SET_DECL_RTL (decl
, XEXP (DECL_RTL (decl
), 0));
799 TREE_TYPE (decl
) = new_type
;
800 DECL_MODE (decl
) = TYPE_MODE (new_type
);
801 DECL_ALIGN (decl
) = TYPE_ALIGN (new_type
);
802 DECL_SIZE (decl
) = TYPE_SIZE (new_type
);
804 if (TREE_CODE (decl
) == PARM_DECL
)
805 DECL_INCOMING_RTL (decl
) = XEXP (DECL_INCOMING_RTL (decl
), 0);
807 /* If DECL_INITIAL was set, it should be updated to show that
808 the decl is initialized to the address of that thing.
809 Otherwise, just set it to the address of this decl.
810 It needs to be set so that GCC does not think the decl is
813 = build1 (ADDR_EXPR
, new_type
,
814 DECL_INITIAL (decl
) != 0 ? DECL_INITIAL (decl
) : decl
);
818 /* Record the current code position in GNAT_NODE. */
821 record_code_position (gnat_node
)
824 if (global_bindings_p ())
826 /* Make a dummy entry so multiple things at the same location don't
827 end up in the same place. */
828 add_pending_elaborations (NULL_TREE
, NULL_TREE
);
829 save_gnu_tree (gnat_node
, get_elaboration_location (), 1);
832 /* Always emit another insn in case marking the last insn
833 addressable needs some fixups and also for above reason. */
834 save_gnu_tree (gnat_node
,
835 build (RTL_EXPR
, void_type_node
, NULL_TREE
,
836 (tree
) emit_note (0, NOTE_INSN_DELETED
)),
840 /* Insert the code for GNAT_NODE at the position saved for that node. */
843 insert_code_for (gnat_node
)
846 if (global_bindings_p ())
848 push_pending_elaborations ();
849 gnat_to_code (gnat_node
);
850 Check_Elaboration_Code_Allowed (gnat_node
);
851 insert_elaboration_list (get_gnu_tree (gnat_node
));
852 pop_pending_elaborations ();
859 mark_all_temps_used ();
860 gnat_to_code (gnat_node
);
861 insns
= get_insns ();
863 emit_insns_after (insns
, RTL_EXPR_RTL (get_gnu_tree (gnat_node
)));
867 /* Performs whatever initialization steps needed by the language-dependent
870 Define the additional tree codes here. This isn't the best place to put
871 it, but it's where g++ does it. */
874 init_parse (filename
)
875 const char *filename
;
877 lang_expand_expr
= gnat_expand_expr
;
878 lang_expand_constant
= gnat_expand_constant
;
880 memcpy ((char *) (tree_code_type
+ (int) LAST_AND_UNUSED_TREE_CODE
),
881 (char *) gnat_tree_code_type
,
882 ((LAST_GNAT_TREE_CODE
- (int) LAST_AND_UNUSED_TREE_CODE
)
885 memcpy ((char *) (tree_code_length
+ (int) LAST_AND_UNUSED_TREE_CODE
),
886 (char *) gnat_tree_code_length
,
887 ((LAST_GNAT_TREE_CODE
- (int) LAST_AND_UNUSED_TREE_CODE
)
890 memcpy ((char *) (tree_code_name
+ (int) LAST_AND_UNUSED_TREE_CODE
),
891 (char *) gnat_tree_code_name
,
892 ((LAST_GNAT_TREE_CODE
- (int) LAST_AND_UNUSED_TREE_CODE
)
903 /* Sets some debug flags for the parsed. It does nothing here. */
907 int value ATTRIBUTE_UNUSED
;
913 /* Return the alignment for GNAT_TYPE. */
916 get_type_alignment (gnat_type
)
919 return TYPE_ALIGN (gnat_to_gnu_type (gnat_type
)) / BITS_PER_UNIT
;
923 /* Get the alias set corresponding to a type or expression. */
926 gnat_get_alias_set (type
)
929 /* If this is a padding type, use the type of the first field. */
930 if (TREE_CODE (type
) == RECORD_TYPE
931 && TYPE_IS_PADDING_P (type
))
932 return get_alias_set (TREE_TYPE (TYPE_FIELDS (type
)));
937 /* Set default attributes for functions. We do nothing. */
940 insert_default_attributes (decl
)
941 tree decl ATTRIBUTE_UNUSED
;
945 /* GNU_TYPE is a type. Determine if it should be passed by reference by
949 default_pass_by_ref (gnu_type
)
954 INIT_CUMULATIVE_ARGS (cum
, NULL_TREE
, NULL_RTX
, 0);
956 /* We pass aggregates by reference if they are sufficiently large. The
957 choice of constant here is somewhat arbitrary. We also pass by
958 reference if the target machine would either pass or return by
959 reference. Strictly speaking, we need only check the return if this
960 is an In Out parameter, but it's probably best to err on the side of
961 passing more things by reference. */
963 #ifdef FUNCTION_ARG_PASS_BY_REFERENCE
964 || FUNCTION_ARG_PASS_BY_REFERENCE (cum
, TYPE_MODE (gnu_type
),
967 || RETURN_IN_MEMORY (gnu_type
)
968 || (AGGREGATE_TYPE_P (gnu_type
)
969 && (! host_integerp (TYPE_SIZE (gnu_type
), 1)
970 || 0 < compare_tree_int (TYPE_SIZE (gnu_type
),
971 8 * TYPE_ALIGN (gnu_type
)))));
974 /* GNU_TYPE is the type of a subprogram parameter. Determine from the type if
975 it should be passed by reference. */
978 must_pass_by_ref (gnu_type
)
981 /* We pass only unconstrained objects, those required by the language
982 to be passed by reference, and objects of variable size. The latter
983 is more efficient, avoids problems with variable size temporaries,
984 and does not produce compatibility problems with C, since C does
985 not have such objects. */
986 return (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
987 || (AGGREGATE_TYPE_P (gnu_type
) && TYPE_BY_REFERENCE_P (gnu_type
))
988 || (TYPE_SIZE (gnu_type
) != 0
989 && TREE_CODE (TYPE_SIZE (gnu_type
)) != INTEGER_CST
));
992 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
994 /* Convert NAME, which is possibly an Ada name, back to standard Ada
995 notation for SGI Workshop. */
998 convert_ada_name_to_qualified_name (name
)
1001 int len
= strlen (name
);
1002 char *new_name
= xstrdup (name
);
1005 char *qual_name_suffix
= 0;
1008 if (len
<= 3 || use_gnu_debug_info_extensions
)
1014 /* Find the position of the first "__" after the first character of
1015 NAME. This is the same as calling strstr except that we can't assume
1016 the host has that function. We start after the first character so
1017 we don't eliminate leading "__": these are emitted only by C
1018 programs and are not qualified names */
1019 for (p
= (char *) index (&name
[1], '_'); p
!= 0;
1020 p
= (char *) index (p
+1, '_'))
1023 qual_name_suffix
= p
;
1027 if (qual_name_suffix
== 0)
1033 start
= qual_name_suffix
- name
;
1034 buf
= new_name
+ start
;
1036 for (i
= start
; i
< len
; i
++)
1038 if (name
[i
] == '_' && name
[i
+ 1] == '_')
1040 if (islower (name
[i
+ 2]))
1043 *buf
++ = name
[i
+ 2];
1046 else if (name
[i
+ 2] == '_' && islower (name
[i
+ 3]))
1048 /* convert foo___c___XVN to foo.c___XVN */
1050 *buf
++ = name
[i
+ 3];
1053 else if (name
[i
+ 2] == 'T')
1055 /* convert foo__TtypeS to foo.__TTypeS */
1074 /* Emit a label UNITNAME_LABEL and specify that it is part of source
1075 file FILENAME. If this is being written for SGI's Workshop
1076 debugger, and we are writing Dwarf2 debugging information, add
1077 additional debug info. */
1080 emit_unit_label (unitname_label
, filename
)
1081 char *unitname_label
;
1082 char *filename ATTRIBUTE_UNUSED
;
1084 ASM_GLOBALIZE_LABEL (asm_out_file
, unitname_label
);
1085 ASM_OUTPUT_LABEL (asm_out_file
, unitname_label
);