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
));
116 static void gnat_print_decl
PARAMS ((FILE *, tree
, int));
117 static void gnat_print_type
PARAMS ((FILE *, tree
, int));
119 /* Structure giving our language-specific hooks. */
121 #undef LANG_HOOKS_NAME
122 #define LANG_HOOKS_NAME "GNU Ada"
123 #undef LANG_HOOKS_IDENTIFIER_SIZE
124 #define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier)
125 #undef LANG_HOOKS_INIT
126 #define LANG_HOOKS_INIT gnat_init
127 #undef LANG_HOOKS_INIT_OPTIONS
128 #define LANG_HOOKS_INIT_OPTIONS gnat_init_options
129 #undef LANG_HOOKS_DECODE_OPTION
130 #define LANG_HOOKS_DECODE_OPTION gnat_decode_option
131 #undef LANG_HOOKS_HONOR_READONLY
132 #define LANG_HOOKS_HONOR_READONLY 1
133 #undef LANG_HOOKS_GET_ALIAS_SET
134 #define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set
135 #undef LANG_HOOKS_PRINT_DECL
136 #define LANG_HOOKS_PRINT_DECL gnat_print_decl
137 #undef LANG_HOOKS_PRINT_TYPE
138 #define LANG_HOOKS_PRINT_TYPE gnat_print_type
140 const struct lang_hooks lang_hooks
= LANG_HOOKS_INITIALIZER
;
142 /* gnat standard argc argv */
144 extern int gnat_argc
;
145 extern char **gnat_argv
;
147 /* Global Variables Expected by gcc: */
149 int flag_traditional
; /* Used by dwarfout.c. */
152 static void internal_error_function
PARAMS ((const char *, va_list *));
153 static rtx gnat_expand_expr
PARAMS ((tree
, rtx
, enum machine_mode
,
154 enum expand_modifier
));
155 static tree gnat_expand_constant
PARAMS ((tree
));
156 static void gnat_adjust_rli
PARAMS ((record_layout_info
));
158 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
159 static char *convert_ada_name_to_qualified_name
PARAMS ((char *));
162 /* Routines Expected by gcc: */
164 /* For most front-ends, this is the parser for the language. For us, we
165 process the GNAT tree. */
167 /* Declare functions we use as part of startup. */
168 extern void __gnat_initialize
PARAMS((void));
169 extern void adainit
PARAMS((void));
170 extern void _ada_gnat1drv
PARAMS((void));
175 /* call the target specific initializations */
178 /* Call the front-end elaboration procedures */
181 immediate_size_expand
= 1;
183 /* Call the front end */
189 /* Decode all the language specific options that cannot be decoded by GCC.
190 The option decoding phase of GCC calls this routine on the flags that
191 it cannot decode. This routine returns 1 if it is successful, otherwise
195 gnat_decode_option (argc
, argv
)
196 int argc ATTRIBUTE_UNUSED
;
202 if (!strncmp (p
, "-I", 2))
204 /* Pass the -I switches as-is. */
205 gnat_argv
[gnat_argc
] = p
;
210 else if (!strncmp (p
, "-gant", 5))
212 char *q
= (char *) xmalloc (strlen (p
) + 1);
214 warning ("`-gnat' misspelled as `-gant'");
216 q
[2] = 'n', q
[3] = 'a';
221 else if (!strncmp (p
, "-gnat", 5))
223 /* Recopy the switches without the 'gnat' prefix */
225 gnat_argv
[gnat_argc
] = (char *) xmalloc (strlen (p
) - 3);
226 gnat_argv
[gnat_argc
][0] = '-';
227 strcpy (gnat_argv
[gnat_argc
] + 1, p
+ 5);
230 for (i
= 1; i
< save_argc
- 1; i
++)
231 if (!strncmp (save_argv
[i
], "-gnatO", 6))
232 if (save_argv
[++i
][0] != '-')
234 /* Preserve output filename as GCC doesn't save it for GNAT. */
235 gnat_argv
[gnat_argc
] = save_argv
[i
];
243 /* Ignore -W flags since people may want to use the same flags for all
245 else if (p
[0] == '-' && p
[1] == 'W' && p
[2] != 0)
251 /* Initialize for option processing. */
256 /* Initialize gnat_argv with save_argv size */
257 gnat_argv
= (char **) xmalloc ((save_argc
+ 1) * sizeof (gnat_argv
[0]));
258 gnat_argv
[0] = save_argv
[0]; /* name of the command */
266 switch (TREE_CODE (t
))
269 ggc_mark_tree (TYPE_CI_CO_LIST (t
));
273 if (TYPE_MODULAR_P (t
))
274 ggc_mark_tree (TYPE_MODULUS (t
));
275 else if (TYPE_VAX_FLOATING_POINT_P (t
))
277 else if (TYPE_HAS_ACTUAL_BOUNDS_P (t
))
278 ggc_mark_tree (TYPE_ACTUAL_BOUNDS (t
));
280 ggc_mark_tree (TYPE_INDEX_TYPE (t
));
284 ggc_mark_tree (TYPE_RM_SIZE_ENUM (t
));
288 ggc_mark_tree (TYPE_ACTUAL_BOUNDS (t
));
291 case RECORD_TYPE
: case UNION_TYPE
: case QUAL_UNION_TYPE
:
292 /* This is really TYPE_UNCONSTRAINED_ARRAY for fat pointers. */
293 ggc_mark_tree (TYPE_ADA_SIZE (t
));
297 ggc_mark_tree (DECL_CONST_CORRESPONDING_VAR (t
));
301 ggc_mark_tree (DECL_ORIGINAL_FIELD (t
));
309 /* Here we have the function to handle the compiler error processing in GCC.
310 Do this only if VPRINTF is available. */
312 #if defined(HAVE_VPRINTF)
313 #define DO_INTERNAL_ERROR_FUNCTION
316 internal_error_function (msgid
, ap
)
320 char buffer
[1000]; /* Assume this is big enough. */
322 String_Template temp
;
325 vsprintf (buffer
, msgid
, *ap
);
327 /* Go up to the first newline. */
328 for (p
= buffer
; *p
!= 0; p
++)
335 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (buffer
);
336 fp
.Array
= buffer
, fp
.Bounds
= &temp
;
338 Current_Error_Node
= error_gnat_node
;
339 Compiler_Abort (fp
, -1);
343 /* Perform all the initialization steps that are language-specific. */
348 /* Add the input filename as the last argument. */
349 gnat_argv
[gnat_argc
] = (char *) input_filename
;
351 gnat_argv
[gnat_argc
] = 0;
353 #ifdef DO_INTERNAL_ERROR_FUNCTION
354 set_internal_error_function (internal_error_function
);
357 /* Show that REFERENCE_TYPEs are internal and should be Pmode. */
358 internal_reference_types ();
360 /* Show we don't use the common language attributes. */
361 lang_attribute_common
= 0;
363 set_lang_adjust_rli (gnat_adjust_rli
);
365 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
366 dwarf2out_set_demangle_name_func (convert_ada_name_to_qualified_name
);
370 /* If DECL has a cleanup, build and return that cleanup here.
371 This is a callback called by expand_expr. */
374 maybe_build_cleanup (decl
)
375 tree decl ATTRIBUTE_UNUSED
;
377 /* There are no cleanups in C. */
381 /* integrate_decl_tree calls this function, but since we don't use the
382 DECL_LANG_SPECIFIC field, this is a no-op. */
385 copy_lang_decl (node
)
386 tree node ATTRIBUTE_UNUSED
;
390 /* Hooks for print-tree.c: */
393 gnat_print_decl (file
, node
, indent
)
398 switch (TREE_CODE (node
))
401 print_node (file
, "const_corresponding_var",
402 DECL_CONST_CORRESPONDING_VAR (node
), indent
+ 4);
406 print_node (file
, "original field", DECL_ORIGINAL_FIELD (node
),
416 gnat_print_type (file
, node
, indent
)
421 switch (TREE_CODE (node
))
424 print_node (file
, "ci_co_list", TYPE_CI_CO_LIST (node
), indent
+ 4);
428 print_node (file
, "RM size", TYPE_RM_SIZE_ENUM (node
), indent
+ 4);
432 if (TYPE_MODULAR_P (node
))
433 print_node (file
, "modulus", TYPE_MODULUS (node
), indent
+ 4);
434 else if (TYPE_HAS_ACTUAL_BOUNDS_P (node
))
435 print_node (file
, "actual bounds", TYPE_ACTUAL_BOUNDS (node
),
437 else if (TYPE_VAX_FLOATING_POINT_P (node
))
440 print_node (file
, "index type", TYPE_INDEX_TYPE (node
), indent
+ 4);
442 print_node (file
, "RM size", TYPE_RM_SIZE_INT (node
), indent
+ 4);
446 print_node (file
,"actual bounds", TYPE_ACTUAL_BOUNDS (node
), indent
+ 4);
450 if (TYPE_IS_FAT_POINTER_P (node
) || TYPE_CONTAINS_TEMPLATE_P (node
))
451 print_node (file
, "unconstrained array",
452 TYPE_UNCONSTRAINED_ARRAY (node
), indent
+ 4);
454 print_node (file
, "Ada size", TYPE_ADA_SIZE (node
), indent
+ 4);
458 case QUAL_UNION_TYPE
:
459 print_node (file
, "Ada size", TYPE_ADA_SIZE (node
), indent
+ 4);
467 /* Expands GNAT-specific GCC tree nodes. The only ones we support
468 here are TRANSFORM_EXPR, UNCHECKED_CONVERT_EXPR, ALLOCATE_EXPR,
469 USE_EXPR and NULL_EXPR. */
472 gnat_expand_expr (exp
, target
, tmode
, modifier
)
475 enum machine_mode tmode
;
476 enum expand_modifier modifier
;
478 tree type
= TREE_TYPE (exp
);
484 /* Update EXP to be the new expression to expand. */
486 switch (TREE_CODE (exp
))
489 gnat_to_code (TREE_COMPLEXITY (exp
));
493 case UNCHECKED_CONVERT_EXPR
:
494 inner_type
= TREE_TYPE (TREE_OPERAND (exp
, 0));
496 /* The alignment is OK if the flag saying it is OK is set in either
497 type, if the inner type is already maximally aligned, if the
498 new type is no more strictly aligned than the old type, or
499 if byte accesses are not slow. */
500 align_ok
= (! SLOW_BYTE_ACCESS
501 || TYPE_ALIGN_OK_P (type
) || TYPE_ALIGN_OK_P (inner_type
)
502 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
503 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
));
505 /* If we're converting between an aggregate and non-aggregate type
506 and we have a MEM TARGET, we can't use it, since MEM_IN_STRUCT_P
507 would be set incorrectly. */
508 if (target
!= 0 && GET_CODE (target
) == MEM
509 && (MEM_IN_STRUCT_P (target
) != AGGREGATE_TYPE_P (inner_type
)))
512 /* If the input and output are both the same mode (usually BLKmode),
513 just return the expanded input since we want just the bits. But
514 we can't do this if the output is more strictly aligned than
515 the input or if the type is BLKmode and the sizes differ. */
516 if (TYPE_MODE (type
) == TYPE_MODE (inner_type
)
518 && ! (TYPE_MODE (type
) == BLKmode
519 && ! operand_equal_p (TYPE_SIZE (type
),
520 TYPE_SIZE (inner_type
), 0)))
522 new = TREE_OPERAND (exp
, 0);
524 /* If the new type is less strictly aligned than the inner type,
525 make a new type with the less strict alignment just for
526 code generation purposes of this node. If it is a decl,
527 we can't change the type, so make a NOP_EXPR. */
528 if (TYPE_ALIGN (type
) != TYPE_ALIGN (inner_type
))
530 tree copy_type
= copy_node (inner_type
);
532 TYPE_ALIGN (copy_type
) = TYPE_ALIGN (type
);
534 new = build1 (NOP_EXPR
, copy_type
, new);
537 /* If NEW is a constant, it might be coming from a CONST_DECL
539 if (TREE_CONSTANT (new))
540 new = copy_node (new);
542 TREE_TYPE (new) = copy_type
;
547 /* If either mode is BLKmode, memory will be involved, so do this
548 via pointer punning. Likewise, this doesn't work if there
549 is an alignment issue. But we must do it for types that are known
550 to be aligned properly. */
551 else if ((TYPE_MODE (type
) == BLKmode
552 || TYPE_MODE (inner_type
) == BLKmode
)
554 new = build_unary_op (INDIRECT_REF
, NULL_TREE
,
556 (build_pointer_type (type
),
557 build_unary_op (ADDR_EXPR
, NULL_TREE
,
558 TREE_OPERAND (exp
, 0))));
560 /* Otherwise make a union of the two types, convert to the union, and
561 extract the other value. */
564 tree union_type
, in_field
, out_field
;
566 /* If this is inside the LHS of an assignment, this would generate
567 bad code, so abort. */
568 if (TREE_ADDRESSABLE (exp
))
571 union_type
= make_node (UNION_TYPE
);
572 in_field
= create_field_decl (get_identifier ("in"),
573 inner_type
, union_type
, 0, 0, 0, 0);
574 out_field
= create_field_decl (get_identifier ("out"),
575 type
, union_type
, 0, 0, 0, 0);
577 TYPE_FIELDS (union_type
) = chainon (in_field
, out_field
);
578 layout_type (union_type
);
580 /* Though this is a "union", we can treat its size as that of
581 the output type in case the size of the input type is variable.
582 If the output size is a variable, use the input size. */
583 TYPE_SIZE (union_type
) = TYPE_SIZE (type
);
584 TYPE_SIZE_UNIT (union_type
) = TYPE_SIZE (type
);
585 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
586 && TREE_CODE (TYPE_SIZE (inner_type
)) == INTEGER_CST
)
588 TYPE_SIZE (union_type
) = TYPE_SIZE (inner_type
);
589 TYPE_SIZE_UNIT (union_type
) = TYPE_SIZE_UNIT (inner_type
);
592 new = build (COMPONENT_REF
, type
,
593 build1 (CONVERT_EXPR
, union_type
,
594 TREE_OPERAND (exp
, 0)),
598 result
= expand_expr (new, target
, tmode
, modifier
);
600 if (GET_CODE (result
) == MEM
)
602 /* Update so it looks like this is of the proper type. */
603 set_mem_alias_set (result
, 0);
604 set_mem_attributes (result
, exp
, 0);
609 expand_expr (TREE_OPERAND (exp
, 0), const0_rtx
, VOIDmode
, 0);
611 /* We aren't going to be doing anything with this memory, but allocate
612 it anyway. If it's variable size, make a bogus address. */
613 if (! host_integerp (TYPE_SIZE_UNIT (type
), 1))
614 result
= gen_rtx_MEM (BLKmode
, virtual_stack_vars_rtx
);
616 result
= assign_temp (type
, 0, TREE_ADDRESSABLE (exp
), 1);
622 allocate_dynamic_stack_space
623 (expand_expr (TREE_OPERAND (exp
, 0), NULL_RTX
, TYPE_MODE (sizetype
),
625 NULL_RTX
, tree_low_cst (TREE_OPERAND (exp
, 1), 1));
628 if (target
!= const0_rtx
)
631 /* First write a volatile ASM_INPUT to prevent anything from being
633 result
= gen_rtx_ASM_INPUT (VOIDmode
, "");
634 MEM_VOLATILE_P (result
) = 1;
637 result
= expand_expr (TREE_OPERAND (exp
, 0), NULL_RTX
, VOIDmode
,
639 emit_insn (gen_rtx_USE (VOIDmode
, result
));
643 return expand_expr (build1 (NOP_EXPR
, type
, TREE_OPERAND (exp
, 0)),
644 target
, tmode
, modifier
);
646 case UNCONSTRAINED_ARRAY_REF
:
647 /* If we are evaluating just for side-effects, just evaluate our
648 operand. Otherwise, abort since this code should never appear
649 in a tree to be evaluated (objects aren't unconstrained). */
650 if (target
== const0_rtx
|| TREE_CODE (type
) == VOID_TYPE
)
651 return expand_expr (TREE_OPERAND (exp
, 0), const0_rtx
,
654 /* ... fall through ... */
660 return expand_expr (new, target
, tmode
, modifier
);
663 /* Transform a constant into a form that the language-independent code
667 gnat_expand_constant (exp
)
670 /* If this is an unchecked conversion that does not change the size of the
671 object, return the operand since the underlying constant is still
672 the same. Otherwise, return our operand. */
673 if (TREE_CODE (exp
) == UNCHECKED_CONVERT_EXPR
674 && operand_equal_p (TYPE_SIZE_UNIT (TREE_TYPE (exp
)),
675 TYPE_SIZE_UNIT (TREE_TYPE (TREE_OPERAND (exp
, 0))),
677 return TREE_OPERAND (exp
, 0);
682 /* Adjusts the RLI used to layout a record after all the fields have been
683 added. We only handle the packed case and cause it to use the alignment
684 that will pad the record at the end. */
687 gnat_adjust_rli (rli
)
688 record_layout_info rli
;
690 if (TYPE_PACKED (rli
->t
))
691 rli
->record_align
= rli
->unpadded_align
;
694 /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code. */
697 make_transform_expr (gnat_node
)
700 tree gnu_result
= build (TRANSFORM_EXPR
, void_type_node
);
702 TREE_SIDE_EFFECTS (gnu_result
) = 1;
703 TREE_COMPLEXITY (gnu_result
) = gnat_node
;
707 /* Update the setjmp buffer BUF with the current stack pointer. We assume
708 here that a __builtin_setjmp was done to BUF. */
711 update_setjmp_buf (buf
)
714 enum machine_mode sa_mode
= Pmode
;
717 #ifdef HAVE_save_stack_nonlocal
718 if (HAVE_save_stack_nonlocal
)
719 sa_mode
= insn_operand_mode
[(int) CODE_FOR_save_stack_nonlocal
][0];
721 #ifdef STACK_SAVEAREA_MODE
722 sa_mode
= STACK_SAVEAREA_MODE (SAVE_NONLOCAL
);
726 = gen_rtx_MEM (sa_mode
,
729 plus_constant (expand_expr
730 (build_unary_op (ADDR_EXPR
, NULL_TREE
, buf
),
731 NULL_RTX
, VOIDmode
, 0),
732 2 * GET_MODE_SIZE (Pmode
))));
736 emit_insn (gen_setjmp ());
739 emit_stack_save (SAVE_NONLOCAL
, &stack_save
, NULL_RTX
);
742 /* See if DECL has an RTL that is indirect via a pseudo-register or a
743 memory location and replace it with an indirect reference if so.
744 This improves the debugger's ability to display the value. */
747 adjust_decl_rtl (decl
)
752 /* If this decl is already indirect, don't do anything. This should
753 mean that the decl cannot be indirect, but there's no point in
754 adding an abort to check that. */
755 if (TREE_CODE (decl
) != CONST_DECL
756 && ! DECL_BY_REF_P (decl
)
757 && (GET_CODE (DECL_RTL (decl
)) == MEM
758 && (GET_CODE (XEXP (DECL_RTL (decl
), 0)) == MEM
759 || (GET_CODE (XEXP (DECL_RTL (decl
), 0)) == REG
760 && (REGNO (XEXP (DECL_RTL (decl
), 0))
761 > LAST_VIRTUAL_REGISTER
))))
762 /* We can't do this if the reference type's mode is not the same
763 as the current mode, which means this may not work on mixed 32/64
765 && (new_type
= build_reference_type (TREE_TYPE (decl
))) != 0
766 && TYPE_MODE (new_type
) == GET_MODE (XEXP (DECL_RTL (decl
), 0))
767 /* If this is a PARM_DECL, we can only do it if DECL_INCOMING_RTL
768 is also an indirect and of the same mode and if the object is
769 readonly, the latter condition because we don't want to upset the
770 handling of CICO_LIST. */
771 && (TREE_CODE (decl
) != PARM_DECL
772 || (GET_CODE (DECL_INCOMING_RTL (decl
)) == MEM
773 && (TYPE_MODE (new_type
)
774 == GET_MODE (XEXP (DECL_INCOMING_RTL (decl
), 0)))
775 && TREE_READONLY (decl
))))
778 = build_qualified_type (new_type
,
779 (TYPE_QUALS (new_type
) | TYPE_QUAL_CONST
));
781 DECL_POINTS_TO_READONLY_P (decl
) = TREE_READONLY (decl
);
782 DECL_BY_REF_P (decl
) = 1;
783 SET_DECL_RTL (decl
, XEXP (DECL_RTL (decl
), 0));
784 TREE_TYPE (decl
) = new_type
;
785 DECL_MODE (decl
) = TYPE_MODE (new_type
);
786 DECL_ALIGN (decl
) = TYPE_ALIGN (new_type
);
787 DECL_SIZE (decl
) = TYPE_SIZE (new_type
);
789 if (TREE_CODE (decl
) == PARM_DECL
)
790 DECL_INCOMING_RTL (decl
) = XEXP (DECL_INCOMING_RTL (decl
), 0);
792 /* If DECL_INITIAL was set, it should be updated to show that
793 the decl is initialized to the address of that thing.
794 Otherwise, just set it to the address of this decl.
795 It needs to be set so that GCC does not think the decl is
798 = build1 (ADDR_EXPR
, new_type
,
799 DECL_INITIAL (decl
) != 0 ? DECL_INITIAL (decl
) : decl
);
803 /* Record the current code position in GNAT_NODE. */
806 record_code_position (gnat_node
)
809 if (global_bindings_p ())
811 /* Make a dummy entry so multiple things at the same location don't
812 end up in the same place. */
813 add_pending_elaborations (NULL_TREE
, NULL_TREE
);
814 save_gnu_tree (gnat_node
, get_elaboration_location (), 1);
817 /* Always emit another insn in case marking the last insn
818 addressable needs some fixups and also for above reason. */
819 save_gnu_tree (gnat_node
,
820 build (RTL_EXPR
, void_type_node
, NULL_TREE
,
821 (tree
) emit_note (0, NOTE_INSN_DELETED
)),
825 /* Insert the code for GNAT_NODE at the position saved for that node. */
828 insert_code_for (gnat_node
)
831 if (global_bindings_p ())
833 push_pending_elaborations ();
834 gnat_to_code (gnat_node
);
835 Check_Elaboration_Code_Allowed (gnat_node
);
836 insert_elaboration_list (get_gnu_tree (gnat_node
));
837 pop_pending_elaborations ();
844 mark_all_temps_used ();
845 gnat_to_code (gnat_node
);
846 insns
= get_insns ();
848 emit_insns_after (insns
, RTL_EXPR_RTL (get_gnu_tree (gnat_node
)));
852 /* Performs whatever initialization steps needed by the language-dependent
855 Define the additional tree codes here. This isn't the best place to put
856 it, but it's where g++ does it. */
859 init_parse (filename
)
860 const char *filename
;
862 lang_expand_expr
= gnat_expand_expr
;
863 lang_expand_constant
= gnat_expand_constant
;
865 memcpy ((char *) (tree_code_type
+ (int) LAST_AND_UNUSED_TREE_CODE
),
866 (char *) gnat_tree_code_type
,
867 ((LAST_GNAT_TREE_CODE
- (int) LAST_AND_UNUSED_TREE_CODE
)
870 memcpy ((char *) (tree_code_length
+ (int) LAST_AND_UNUSED_TREE_CODE
),
871 (char *) gnat_tree_code_length
,
872 ((LAST_GNAT_TREE_CODE
- (int) LAST_AND_UNUSED_TREE_CODE
)
875 memcpy ((char *) (tree_code_name
+ (int) LAST_AND_UNUSED_TREE_CODE
),
876 (char *) gnat_tree_code_name
,
877 ((LAST_GNAT_TREE_CODE
- (int) LAST_AND_UNUSED_TREE_CODE
)
890 /* Return the alignment for GNAT_TYPE. */
893 get_type_alignment (gnat_type
)
896 return TYPE_ALIGN (gnat_to_gnu_type (gnat_type
)) / BITS_PER_UNIT
;
900 /* Get the alias set corresponding to a type or expression. */
903 gnat_get_alias_set (type
)
906 /* If this is a padding type, use the type of the first field. */
907 if (TREE_CODE (type
) == RECORD_TYPE
908 && TYPE_IS_PADDING_P (type
))
909 return get_alias_set (TREE_TYPE (TYPE_FIELDS (type
)));
914 /* Set default attributes for functions. We do nothing. */
917 insert_default_attributes (decl
)
918 tree decl ATTRIBUTE_UNUSED
;
922 /* GNU_TYPE is a type. Determine if it should be passed by reference by
926 default_pass_by_ref (gnu_type
)
931 INIT_CUMULATIVE_ARGS (cum
, NULL_TREE
, NULL_RTX
, 0);
933 /* We pass aggregates by reference if they are sufficiently large. The
934 choice of constant here is somewhat arbitrary. We also pass by
935 reference if the target machine would either pass or return by
936 reference. Strictly speaking, we need only check the return if this
937 is an In Out parameter, but it's probably best to err on the side of
938 passing more things by reference. */
940 #ifdef FUNCTION_ARG_PASS_BY_REFERENCE
941 || FUNCTION_ARG_PASS_BY_REFERENCE (cum
, TYPE_MODE (gnu_type
),
944 || RETURN_IN_MEMORY (gnu_type
)
945 || (AGGREGATE_TYPE_P (gnu_type
)
946 && (! host_integerp (TYPE_SIZE (gnu_type
), 1)
947 || 0 < compare_tree_int (TYPE_SIZE (gnu_type
),
948 8 * TYPE_ALIGN (gnu_type
)))));
951 /* GNU_TYPE is the type of a subprogram parameter. Determine from the type if
952 it should be passed by reference. */
955 must_pass_by_ref (gnu_type
)
958 /* We pass only unconstrained objects, those required by the language
959 to be passed by reference, and objects of variable size. The latter
960 is more efficient, avoids problems with variable size temporaries,
961 and does not produce compatibility problems with C, since C does
962 not have such objects. */
963 return (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
964 || (AGGREGATE_TYPE_P (gnu_type
) && TYPE_BY_REFERENCE_P (gnu_type
))
965 || (TYPE_SIZE (gnu_type
) != 0
966 && TREE_CODE (TYPE_SIZE (gnu_type
)) != INTEGER_CST
));
969 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
971 /* Convert NAME, which is possibly an Ada name, back to standard Ada
972 notation for SGI Workshop. */
975 convert_ada_name_to_qualified_name (name
)
978 int len
= strlen (name
);
979 char *new_name
= xstrdup (name
);
982 char *qual_name_suffix
= 0;
985 if (len
<= 3 || use_gnu_debug_info_extensions
)
991 /* Find the position of the first "__" after the first character of
992 NAME. This is the same as calling strstr except that we can't assume
993 the host has that function. We start after the first character so
994 we don't eliminate leading "__": these are emitted only by C
995 programs and are not qualified names */
996 for (p
= (char *) index (&name
[1], '_'); p
!= 0;
997 p
= (char *) index (p
+1, '_'))
1000 qual_name_suffix
= p
;
1004 if (qual_name_suffix
== 0)
1010 start
= qual_name_suffix
- name
;
1011 buf
= new_name
+ start
;
1013 for (i
= start
; i
< len
; i
++)
1015 if (name
[i
] == '_' && name
[i
+ 1] == '_')
1017 if (islower (name
[i
+ 2]))
1020 *buf
++ = name
[i
+ 2];
1023 else if (name
[i
+ 2] == '_' && islower (name
[i
+ 3]))
1025 /* convert foo___c___XVN to foo.c___XVN */
1027 *buf
++ = name
[i
+ 3];
1030 else if (name
[i
+ 2] == 'T')
1032 /* convert foo__TtypeS to foo.__TTypeS */
1051 /* Emit a label UNITNAME_LABEL and specify that it is part of source
1052 file FILENAME. If this is being written for SGI's Workshop
1053 debugger, and we are writing Dwarf2 debugging information, add
1054 additional debug info. */
1057 emit_unit_label (unitname_label
, filename
)
1058 char *unitname_label
;
1059 char *filename ATTRIBUTE_UNUSED
;
1061 ASM_GLOBALIZE_LABEL (asm_out_file
, unitname_label
);
1062 ASM_OUTPUT_LABEL (asm_out_file
, unitname_label
);