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-codes.h"
49 #include "insn-flags.h"
50 #include "insn-config.h"
57 #include "langhooks.h"
58 #include "langhooks-def.h"
74 extern FILE *asm_out_file
;
76 extern char **save_argv
;
78 /* Tables describing GCC tree codes used only by GNAT.
80 Table indexed by tree code giving a string containing a character
81 classifying the tree code. Possibilities are
82 t, d, s, c, r, <, 1 and 2. See cp-tree.def for details. */
84 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
86 static char const gnat_tree_code_type
[] = {
88 #include "ada-tree.def"
92 /* Table indexed by tree code giving number of expression
93 operands beyond the fixed part of the node structure.
94 Not used for types or decls. */
96 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
98 static int const gnat_tree_code_length
[] = {
100 #include "ada-tree.def"
104 /* Names of tree components.
105 Used for printing out the tree and error messages. */
106 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
108 static const char *gnat_tree_code_name
[] = {
110 #include "ada-tree.def"
114 static const char *gnat_init
PARAMS ((const char *));
115 static void gnat_init_options
PARAMS ((void));
116 static int gnat_decode_option
PARAMS ((int, char **));
117 static HOST_WIDE_INT gnat_get_alias_set
PARAMS ((tree
));
118 static void gnat_print_decl
PARAMS ((FILE *, tree
, int));
119 static void gnat_print_type
PARAMS ((FILE *, tree
, int));
120 extern void gnat_init_decl_processing
PARAMS ((void));
121 static tree gnat_expand_constant
PARAMS ((tree
));
123 /* Structure giving our language-specific hooks. */
125 #undef LANG_HOOKS_NAME
126 #define LANG_HOOKS_NAME "GNU Ada"
127 #undef LANG_HOOKS_IDENTIFIER_SIZE
128 #define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier)
129 #undef LANG_HOOKS_INIT
130 #define LANG_HOOKS_INIT gnat_init
131 #undef LANG_HOOKS_INIT_OPTIONS
132 #define LANG_HOOKS_INIT_OPTIONS gnat_init_options
133 #undef LANG_HOOKS_DECODE_OPTION
134 #define LANG_HOOKS_DECODE_OPTION gnat_decode_option
135 #undef LANG_HOOKS_HONOR_READONLY
136 #define LANG_HOOKS_HONOR_READONLY 1
137 #undef LANG_HOOKS_GET_ALIAS_SET
138 #define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set
139 #undef LANG_HOOKS_PRINT_DECL
140 #define LANG_HOOKS_PRINT_DECL gnat_print_decl
141 #undef LANG_HOOKS_PRINT_TYPE
142 #define LANG_HOOKS_PRINT_TYPE gnat_print_type
143 #undef LANG_HOOKS_EXPAND_CONSTANT
144 #define LANG_HOOKS_EXPAND_CONSTANT gnat_expand_constant
146 const struct lang_hooks lang_hooks
= LANG_HOOKS_INITIALIZER
;
148 /* gnat standard argc argv */
150 extern int gnat_argc
;
151 extern char **gnat_argv
;
153 /* Global Variables Expected by gcc: */
157 static void internal_error_function
PARAMS ((const char *, va_list *));
158 static rtx gnat_expand_expr
PARAMS ((tree
, rtx
, enum machine_mode
,
159 enum expand_modifier
));
160 static void gnat_adjust_rli
PARAMS ((record_layout_info
));
162 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
163 static char *convert_ada_name_to_qualified_name
PARAMS ((char *));
166 /* Routines Expected by gcc: */
168 /* For most front-ends, this is the parser for the language. For us, we
169 process the GNAT tree. */
171 /* Declare functions we use as part of startup. */
172 extern void __gnat_initialize
PARAMS((void));
173 extern void adainit
PARAMS((void));
174 extern void _ada_gnat1drv
PARAMS((void));
179 /* call the target specific initializations */
182 /* Call the front-end elaboration procedures */
185 immediate_size_expand
= 1;
187 /* Call the front end */
193 /* Decode all the language specific options that cannot be decoded by GCC.
194 The option decoding phase of GCC calls this routine on the flags that
195 it cannot decode. This routine returns 1 if it is successful, otherwise
199 gnat_decode_option (argc
, argv
)
200 int argc ATTRIBUTE_UNUSED
;
206 if (!strncmp (p
, "-I", 2))
208 /* Pass the -I switches as-is. */
209 gnat_argv
[gnat_argc
] = p
;
214 else if (!strncmp (p
, "-gant", 5))
216 char *q
= (char *) xmalloc (strlen (p
) + 1);
218 warning ("`-gnat' misspelled as `-gant'");
220 q
[2] = 'n', q
[3] = 'a';
225 else if (!strncmp (p
, "-gnat", 5))
227 /* Recopy the switches without the 'gnat' prefix */
229 gnat_argv
[gnat_argc
] = (char *) xmalloc (strlen (p
) - 3);
230 gnat_argv
[gnat_argc
][0] = '-';
231 strcpy (gnat_argv
[gnat_argc
] + 1, p
+ 5);
234 for (i
= 1; i
< save_argc
- 1; i
++)
235 if (!strncmp (save_argv
[i
], "-gnatO", 6))
236 if (save_argv
[++i
][0] != '-')
238 /* Preserve output filename as GCC doesn't save it for GNAT. */
239 gnat_argv
[gnat_argc
] = save_argv
[i
];
247 /* Ignore -W flags since people may want to use the same flags for all
249 else if (p
[0] == '-' && p
[1] == 'W' && p
[2] != 0)
255 /* Initialize for option processing. */
260 /* Initialize gnat_argv with save_argv size */
261 gnat_argv
= (char **) xmalloc ((save_argc
+ 1) * sizeof (gnat_argv
[0]));
262 gnat_argv
[0] = save_argv
[0]; /* name of the command */
270 switch (TREE_CODE (t
))
273 ggc_mark_tree (TYPE_CI_CO_LIST (t
));
277 if (TYPE_MODULAR_P (t
))
278 ggc_mark_tree (TYPE_MODULUS (t
));
279 else if (TYPE_VAX_FLOATING_POINT_P (t
))
281 else if (TYPE_HAS_ACTUAL_BOUNDS_P (t
))
282 ggc_mark_tree (TYPE_ACTUAL_BOUNDS (t
));
284 ggc_mark_tree (TYPE_INDEX_TYPE (t
));
288 ggc_mark_tree (TYPE_RM_SIZE_ENUM (t
));
292 ggc_mark_tree (TYPE_ACTUAL_BOUNDS (t
));
295 case RECORD_TYPE
: case UNION_TYPE
: case QUAL_UNION_TYPE
:
296 /* This is really TYPE_UNCONSTRAINED_ARRAY for fat pointers. */
297 ggc_mark_tree (TYPE_ADA_SIZE (t
));
301 ggc_mark_tree (DECL_CONST_CORRESPONDING_VAR (t
));
305 ggc_mark_tree (DECL_ORIGINAL_FIELD (t
));
313 /* Here we have the function to handle the compiler error processing in GCC. */
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);
342 /* Perform all the initialization steps that are language-specific. */
346 const char *filename
;
348 /* Performs whatever initialization steps needed by the language-dependent
351 Define the additional tree codes here. This isn't the best place to put
352 it, but it's where g++ does it. */
354 lang_expand_expr
= gnat_expand_expr
;
356 memcpy ((char *) (tree_code_type
+ (int) LAST_AND_UNUSED_TREE_CODE
),
357 (char *) gnat_tree_code_type
,
358 ((LAST_GNAT_TREE_CODE
- (int) LAST_AND_UNUSED_TREE_CODE
)
361 memcpy ((char *) (tree_code_length
+ (int) LAST_AND_UNUSED_TREE_CODE
),
362 (char *) gnat_tree_code_length
,
363 ((LAST_GNAT_TREE_CODE
- (int) LAST_AND_UNUSED_TREE_CODE
)
366 memcpy ((char *) (tree_code_name
+ (int) LAST_AND_UNUSED_TREE_CODE
),
367 (char *) gnat_tree_code_name
,
368 ((LAST_GNAT_TREE_CODE
- (int) LAST_AND_UNUSED_TREE_CODE
)
371 gnat_init_decl_processing ();
373 /* Add the input filename as the last argument. */
374 gnat_argv
[gnat_argc
] = (char *) filename
;
376 gnat_argv
[gnat_argc
] = 0;
378 set_internal_error_function (internal_error_function
);
380 /* Show that REFERENCE_TYPEs are internal and should be Pmode. */
381 internal_reference_types ();
383 /* Show we don't use the common language attributes. */
384 lang_attribute_common
= 0;
386 set_lang_adjust_rli (gnat_adjust_rli
);
388 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
389 dwarf2out_set_demangle_name_func (convert_ada_name_to_qualified_name
);
398 /* If DECL has a cleanup, build and return that cleanup here.
399 This is a callback called by expand_expr. */
402 maybe_build_cleanup (decl
)
403 tree decl ATTRIBUTE_UNUSED
;
405 /* There are no cleanups in C. */
409 /* integrate_decl_tree calls this function, but since we don't use the
410 DECL_LANG_SPECIFIC field, this is a no-op. */
413 copy_lang_decl (node
)
414 tree node ATTRIBUTE_UNUSED
;
418 /* Hooks for print-tree.c: */
421 gnat_print_decl (file
, node
, indent
)
426 switch (TREE_CODE (node
))
429 print_node (file
, "const_corresponding_var",
430 DECL_CONST_CORRESPONDING_VAR (node
), indent
+ 4);
434 print_node (file
, "original field", DECL_ORIGINAL_FIELD (node
),
444 gnat_print_type (file
, node
, indent
)
449 switch (TREE_CODE (node
))
452 print_node (file
, "ci_co_list", TYPE_CI_CO_LIST (node
), indent
+ 4);
456 print_node (file
, "RM size", TYPE_RM_SIZE_ENUM (node
), indent
+ 4);
460 if (TYPE_MODULAR_P (node
))
461 print_node (file
, "modulus", TYPE_MODULUS (node
), indent
+ 4);
462 else if (TYPE_HAS_ACTUAL_BOUNDS_P (node
))
463 print_node (file
, "actual bounds", TYPE_ACTUAL_BOUNDS (node
),
465 else if (TYPE_VAX_FLOATING_POINT_P (node
))
468 print_node (file
, "index type", TYPE_INDEX_TYPE (node
), indent
+ 4);
470 print_node (file
, "RM size", TYPE_RM_SIZE_INT (node
), indent
+ 4);
474 print_node (file
,"actual bounds", TYPE_ACTUAL_BOUNDS (node
), indent
+ 4);
478 if (TYPE_IS_FAT_POINTER_P (node
) || TYPE_CONTAINS_TEMPLATE_P (node
))
479 print_node (file
, "unconstrained array",
480 TYPE_UNCONSTRAINED_ARRAY (node
), indent
+ 4);
482 print_node (file
, "Ada size", TYPE_ADA_SIZE (node
), indent
+ 4);
486 case QUAL_UNION_TYPE
:
487 print_node (file
, "Ada size", TYPE_ADA_SIZE (node
), indent
+ 4);
495 /* Expands GNAT-specific GCC tree nodes. The only ones we support
496 here are TRANSFORM_EXPR, UNCHECKED_CONVERT_EXPR, ALLOCATE_EXPR,
497 USE_EXPR and NULL_EXPR. */
500 gnat_expand_expr (exp
, target
, tmode
, modifier
)
503 enum machine_mode tmode
;
504 enum expand_modifier modifier
;
506 tree type
= TREE_TYPE (exp
);
512 /* Update EXP to be the new expression to expand. */
514 switch (TREE_CODE (exp
))
517 gnat_to_code (TREE_COMPLEXITY (exp
));
521 case UNCHECKED_CONVERT_EXPR
:
522 inner_type
= TREE_TYPE (TREE_OPERAND (exp
, 0));
524 /* The alignment is OK if the flag saying it is OK is set in either
525 type, if the inner type is already maximally aligned, if the
526 new type is no more strictly aligned than the old type, or
527 if byte accesses are not slow. */
528 align_ok
= (! SLOW_BYTE_ACCESS
529 || TYPE_ALIGN_OK_P (type
) || TYPE_ALIGN_OK_P (inner_type
)
530 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
531 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
));
533 /* If we're converting between an aggregate and non-aggregate type
534 and we have a MEM TARGET, we can't use it, since MEM_IN_STRUCT_P
535 would be set incorrectly. */
536 if (target
!= 0 && GET_CODE (target
) == MEM
537 && (MEM_IN_STRUCT_P (target
) != AGGREGATE_TYPE_P (inner_type
)))
540 /* If the input and output are both the same mode (usually BLKmode),
541 just return the expanded input since we want just the bits. But
542 we can't do this if the output is more strictly aligned than
543 the input or if the type is BLKmode and the sizes differ. */
544 if (TYPE_MODE (type
) == TYPE_MODE (inner_type
)
546 && ! (TYPE_MODE (type
) == BLKmode
547 && ! operand_equal_p (TYPE_SIZE (type
),
548 TYPE_SIZE (inner_type
), 0)))
550 new = TREE_OPERAND (exp
, 0);
552 /* If the new type is less strictly aligned than the inner type,
553 make a new type with the less strict alignment just for
554 code generation purposes of this node. If it is a decl,
555 we can't change the type, so make a NOP_EXPR. */
556 if (TYPE_ALIGN (type
) != TYPE_ALIGN (inner_type
))
558 tree copy_type
= copy_node (inner_type
);
560 TYPE_ALIGN (copy_type
) = TYPE_ALIGN (type
);
562 new = build1 (NOP_EXPR
, copy_type
, new);
565 /* If NEW is a constant, it might be coming from a CONST_DECL
567 if (TREE_CONSTANT (new))
568 new = copy_node (new);
570 TREE_TYPE (new) = copy_type
;
575 /* If either mode is BLKmode, memory will be involved, so do this
576 via pointer punning. Likewise, this doesn't work if there
577 is an alignment issue. But we must do it for types that are known
578 to be aligned properly. */
579 else if ((TYPE_MODE (type
) == BLKmode
580 || TYPE_MODE (inner_type
) == BLKmode
)
582 new = build_unary_op (INDIRECT_REF
, NULL_TREE
,
584 (build_pointer_type (type
),
585 build_unary_op (ADDR_EXPR
, NULL_TREE
,
586 TREE_OPERAND (exp
, 0))));
588 /* Otherwise make a union of the two types, convert to the union, and
589 extract the other value. */
592 tree union_type
, in_field
, out_field
;
594 /* If this is inside the LHS of an assignment, this would generate
595 bad code, so abort. */
596 if (TREE_ADDRESSABLE (exp
))
599 union_type
= make_node (UNION_TYPE
);
600 in_field
= create_field_decl (get_identifier ("in"),
601 inner_type
, union_type
, 0, 0, 0, 0);
602 out_field
= create_field_decl (get_identifier ("out"),
603 type
, union_type
, 0, 0, 0, 0);
605 TYPE_FIELDS (union_type
) = chainon (in_field
, out_field
);
606 layout_type (union_type
);
608 /* Though this is a "union", we can treat its size as that of
609 the output type in case the size of the input type is variable.
610 If the output size is a variable, use the input size. */
611 TYPE_SIZE (union_type
) = TYPE_SIZE (type
);
612 TYPE_SIZE_UNIT (union_type
) = TYPE_SIZE (type
);
613 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
614 && TREE_CODE (TYPE_SIZE (inner_type
)) == INTEGER_CST
)
616 TYPE_SIZE (union_type
) = TYPE_SIZE (inner_type
);
617 TYPE_SIZE_UNIT (union_type
) = TYPE_SIZE_UNIT (inner_type
);
620 new = build (COMPONENT_REF
, type
,
621 build1 (CONVERT_EXPR
, union_type
,
622 TREE_OPERAND (exp
, 0)),
626 result
= expand_expr (new, target
, tmode
, modifier
);
628 if (GET_CODE (result
) == MEM
)
630 /* Update so it looks like this is of the proper type. */
631 set_mem_alias_set (result
, 0);
632 set_mem_attributes (result
, exp
, 0);
637 expand_expr (TREE_OPERAND (exp
, 0), const0_rtx
, VOIDmode
, 0);
639 /* We aren't going to be doing anything with this memory, but allocate
640 it anyway. If it's variable size, make a bogus address. */
641 if (! host_integerp (TYPE_SIZE_UNIT (type
), 1))
642 result
= gen_rtx_MEM (BLKmode
, virtual_stack_vars_rtx
);
644 result
= assign_temp (type
, 0, TREE_ADDRESSABLE (exp
), 1);
650 allocate_dynamic_stack_space
651 (expand_expr (TREE_OPERAND (exp
, 0), NULL_RTX
, TYPE_MODE (sizetype
),
653 NULL_RTX
, tree_low_cst (TREE_OPERAND (exp
, 1), 1));
656 if (target
!= const0_rtx
)
659 /* First write a volatile ASM_INPUT to prevent anything from being
661 result
= gen_rtx_ASM_INPUT (VOIDmode
, "");
662 MEM_VOLATILE_P (result
) = 1;
665 result
= expand_expr (TREE_OPERAND (exp
, 0), NULL_RTX
, VOIDmode
,
667 emit_insn (gen_rtx_USE (VOIDmode
, result
));
671 return expand_expr (build1 (NOP_EXPR
, type
, TREE_OPERAND (exp
, 0)),
672 target
, tmode
, modifier
);
674 case UNCONSTRAINED_ARRAY_REF
:
675 /* If we are evaluating just for side-effects, just evaluate our
676 operand. Otherwise, abort since this code should never appear
677 in a tree to be evaluated (objects aren't unconstrained). */
678 if (target
== const0_rtx
|| TREE_CODE (type
) == VOID_TYPE
)
679 return expand_expr (TREE_OPERAND (exp
, 0), const0_rtx
,
682 /* ... fall through ... */
688 return expand_expr (new, target
, tmode
, modifier
);
691 /* Transform a constant into a form that the language-independent code
695 gnat_expand_constant (exp
)
698 /* If this is an unchecked conversion that does not change the size of the
699 object and the object is not a CONSTRUCTOR return the operand since the
700 underlying constant is still the same. Otherwise, return our operand. */
701 if (TREE_CODE (exp
) == UNCHECKED_CONVERT_EXPR
702 && operand_equal_p (TYPE_SIZE_UNIT (TREE_TYPE (exp
)),
703 TYPE_SIZE_UNIT (TREE_TYPE (TREE_OPERAND (exp
, 0))),
705 && TREE_CODE (TREE_OPERAND (exp
, 0)) != CONSTRUCTOR
)
706 return TREE_OPERAND (exp
, 0);
711 /* Adjusts the RLI used to layout a record after all the fields have been
712 added. We only handle the packed case and cause it to use the alignment
713 that will pad the record at the end. */
716 gnat_adjust_rli (rli
)
717 record_layout_info rli
;
719 if (TYPE_PACKED (rli
->t
))
720 rli
->record_align
= rli
->unpadded_align
;
723 /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code. */
726 make_transform_expr (gnat_node
)
729 tree gnu_result
= build (TRANSFORM_EXPR
, void_type_node
);
731 TREE_SIDE_EFFECTS (gnu_result
) = 1;
732 TREE_COMPLEXITY (gnu_result
) = gnat_node
;
736 /* Update the setjmp buffer BUF with the current stack pointer. We assume
737 here that a __builtin_setjmp was done to BUF. */
740 update_setjmp_buf (buf
)
743 enum machine_mode sa_mode
= Pmode
;
746 #ifdef HAVE_save_stack_nonlocal
747 if (HAVE_save_stack_nonlocal
)
748 sa_mode
= insn_data
[(int) CODE_FOR_save_stack_nonlocal
].operand
[0].mode
;
751 #ifdef STACK_SAVEAREA_MODE
752 sa_mode
= STACK_SAVEAREA_MODE (SAVE_NONLOCAL
);
756 = gen_rtx_MEM (sa_mode
,
759 plus_constant (expand_expr
760 (build_unary_op (ADDR_EXPR
, NULL_TREE
, buf
),
761 NULL_RTX
, VOIDmode
, 0),
762 2 * GET_MODE_SIZE (Pmode
))));
766 emit_insn (gen_setjmp ());
769 emit_stack_save (SAVE_NONLOCAL
, &stack_save
, NULL_RTX
);
772 /* See if DECL has an RTL that is indirect via a pseudo-register or a
773 memory location and replace it with an indirect reference if so.
774 This improves the debugger's ability to display the value. */
777 adjust_decl_rtl (decl
)
782 /* If this decl is already indirect, don't do anything. This should
783 mean that the decl cannot be indirect, but there's no point in
784 adding an abort to check that. */
785 if (TREE_CODE (decl
) != CONST_DECL
786 && ! DECL_BY_REF_P (decl
)
787 && (GET_CODE (DECL_RTL (decl
)) == MEM
788 && (GET_CODE (XEXP (DECL_RTL (decl
), 0)) == MEM
789 || (GET_CODE (XEXP (DECL_RTL (decl
), 0)) == REG
790 && (REGNO (XEXP (DECL_RTL (decl
), 0))
791 > LAST_VIRTUAL_REGISTER
))))
792 /* We can't do this if the reference type's mode is not the same
793 as the current mode, which means this may not work on mixed 32/64
795 && (new_type
= build_reference_type (TREE_TYPE (decl
))) != 0
796 && TYPE_MODE (new_type
) == GET_MODE (XEXP (DECL_RTL (decl
), 0))
797 /* If this is a PARM_DECL, we can only do it if DECL_INCOMING_RTL
798 is also an indirect and of the same mode and if the object is
799 readonly, the latter condition because we don't want to upset the
800 handling of CICO_LIST. */
801 && (TREE_CODE (decl
) != PARM_DECL
802 || (GET_CODE (DECL_INCOMING_RTL (decl
)) == MEM
803 && (TYPE_MODE (new_type
)
804 == GET_MODE (XEXP (DECL_INCOMING_RTL (decl
), 0)))
805 && TREE_READONLY (decl
))))
808 = build_qualified_type (new_type
,
809 (TYPE_QUALS (new_type
) | TYPE_QUAL_CONST
));
811 DECL_POINTS_TO_READONLY_P (decl
) = TREE_READONLY (decl
);
812 DECL_BY_REF_P (decl
) = 1;
813 SET_DECL_RTL (decl
, XEXP (DECL_RTL (decl
), 0));
814 TREE_TYPE (decl
) = new_type
;
815 DECL_MODE (decl
) = TYPE_MODE (new_type
);
816 DECL_ALIGN (decl
) = TYPE_ALIGN (new_type
);
817 DECL_SIZE (decl
) = TYPE_SIZE (new_type
);
819 if (TREE_CODE (decl
) == PARM_DECL
)
820 DECL_INCOMING_RTL (decl
) = XEXP (DECL_INCOMING_RTL (decl
), 0);
822 /* If DECL_INITIAL was set, it should be updated to show that
823 the decl is initialized to the address of that thing.
824 Otherwise, just set it to the address of this decl.
825 It needs to be set so that GCC does not think the decl is
828 = build1 (ADDR_EXPR
, new_type
,
829 DECL_INITIAL (decl
) != 0 ? DECL_INITIAL (decl
) : decl
);
833 /* Record the current code position in GNAT_NODE. */
836 record_code_position (gnat_node
)
839 if (global_bindings_p ())
841 /* Make a dummy entry so multiple things at the same location don't
842 end up in the same place. */
843 add_pending_elaborations (NULL_TREE
, NULL_TREE
);
844 save_gnu_tree (gnat_node
, get_elaboration_location (), 1);
847 /* Always emit another insn in case marking the last insn
848 addressable needs some fixups and also for above reason. */
849 save_gnu_tree (gnat_node
,
850 build (RTL_EXPR
, void_type_node
, NULL_TREE
,
851 (tree
) emit_note (0, NOTE_INSN_DELETED
)),
855 /* Insert the code for GNAT_NODE at the position saved for that node. */
858 insert_code_for (gnat_node
)
861 if (global_bindings_p ())
863 push_pending_elaborations ();
864 gnat_to_code (gnat_node
);
865 Check_Elaboration_Code_Allowed (gnat_node
);
866 insert_elaboration_list (get_gnu_tree (gnat_node
));
867 pop_pending_elaborations ();
874 mark_all_temps_used ();
875 gnat_to_code (gnat_node
);
876 insns
= get_insns ();
878 emit_insns_after (insns
, RTL_EXPR_RTL (get_gnu_tree (gnat_node
)));
884 /* Return the alignment for GNAT_TYPE. */
887 get_type_alignment (gnat_type
)
890 return TYPE_ALIGN (gnat_to_gnu_type (gnat_type
)) / BITS_PER_UNIT
;
894 /* Get the alias set corresponding to a type or expression. */
897 gnat_get_alias_set (type
)
900 /* If this is a padding type, use the type of the first field. */
901 if (TREE_CODE (type
) == RECORD_TYPE
902 && TYPE_IS_PADDING_P (type
))
903 return get_alias_set (TREE_TYPE (TYPE_FIELDS (type
)));
908 /* Set default attributes for functions. We do nothing. */
911 insert_default_attributes (decl
)
912 tree decl ATTRIBUTE_UNUSED
;
916 /* GNU_TYPE is a type. Determine if it should be passed by reference by
920 default_pass_by_ref (gnu_type
)
925 INIT_CUMULATIVE_ARGS (cum
, NULL_TREE
, NULL_RTX
, 0);
927 /* We pass aggregates by reference if they are sufficiently large. The
928 choice of constant here is somewhat arbitrary. We also pass by
929 reference if the target machine would either pass or return by
930 reference. Strictly speaking, we need only check the return if this
931 is an In Out parameter, but it's probably best to err on the side of
932 passing more things by reference. */
934 #ifdef FUNCTION_ARG_PASS_BY_REFERENCE
935 || FUNCTION_ARG_PASS_BY_REFERENCE (cum
, TYPE_MODE (gnu_type
),
938 || RETURN_IN_MEMORY (gnu_type
)
939 || (AGGREGATE_TYPE_P (gnu_type
)
940 && (! host_integerp (TYPE_SIZE (gnu_type
), 1)
941 || 0 < compare_tree_int (TYPE_SIZE (gnu_type
),
942 8 * TYPE_ALIGN (gnu_type
)))));
945 /* GNU_TYPE is the type of a subprogram parameter. Determine from the type if
946 it should be passed by reference. */
949 must_pass_by_ref (gnu_type
)
952 /* We pass only unconstrained objects, those required by the language
953 to be passed by reference, and objects of variable size. The latter
954 is more efficient, avoids problems with variable size temporaries,
955 and does not produce compatibility problems with C, since C does
956 not have such objects. */
957 return (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
958 || (AGGREGATE_TYPE_P (gnu_type
) && TYPE_BY_REFERENCE_P (gnu_type
))
959 || (TYPE_SIZE (gnu_type
) != 0
960 && TREE_CODE (TYPE_SIZE (gnu_type
)) != INTEGER_CST
));
963 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
965 /* Convert NAME, which is possibly an Ada name, back to standard Ada
966 notation for SGI Workshop. */
969 convert_ada_name_to_qualified_name (name
)
972 int len
= strlen (name
);
973 char *new_name
= xstrdup (name
);
976 char *qual_name_suffix
= 0;
979 if (len
<= 3 || use_gnu_debug_info_extensions
)
985 /* Find the position of the first "__" after the first character of
986 NAME. This is the same as calling strstr except that we can't assume
987 the host has that function. We start after the first character so
988 we don't eliminate leading "__": these are emitted only by C
989 programs and are not qualified names */
990 for (p
= (char *) index (&name
[1], '_'); p
!= 0;
991 p
= (char *) index (p
+1, '_'))
994 qual_name_suffix
= p
;
998 if (qual_name_suffix
== 0)
1004 start
= qual_name_suffix
- name
;
1005 buf
= new_name
+ start
;
1007 for (i
= start
; i
< len
; i
++)
1009 if (name
[i
] == '_' && name
[i
+ 1] == '_')
1011 if (islower (name
[i
+ 2]))
1014 *buf
++ = name
[i
+ 2];
1017 else if (name
[i
+ 2] == '_' && islower (name
[i
+ 3]))
1019 /* convert foo___c___XVN to foo.c___XVN */
1021 *buf
++ = name
[i
+ 3];
1024 else if (name
[i
+ 2] == 'T')
1026 /* convert foo__TtypeS to foo.__TTypeS */
1045 /* Emit a label UNITNAME_LABEL and specify that it is part of source
1046 file FILENAME. If this is being written for SGI's Workshop
1047 debugger, and we are writing Dwarf2 debugging information, add
1048 additional debug info. */
1051 emit_unit_label (unitname_label
, filename
)
1052 char *unitname_label
;
1053 char *filename ATTRIBUTE_UNUSED
;
1055 ASM_GLOBALIZE_LABEL (asm_out_file
, unitname_label
);
1056 ASM_OUTPUT_LABEL (asm_out_file
, unitname_label
);