1 /* m2type.cc provides an interface to GCC type trees.
3 Copyright (C) 2012-2024 Free Software Foundation, Inc.
4 Contributed by Gaius Mulley <gaius@glam.ac.uk>.
6 This file is part of GNU Modula-2.
8 GNU Modula-2 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 GNU Modula-2 is distributed in the hope that it will be useful, but
14 WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Modula-2; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 #include "gcc-consolidation.h"
24 #include "../gm2-lang.h"
25 #include "../m2-tree.h"
30 #include "m2builtins.h"
31 #include "m2convert.h"
35 #include "m2linemap.h"
37 #include "m2treelib.h"
39 #include "m2options.h"
40 #include "m2configure.h"
43 static int broken_set_debugging_info
= true;
46 struct GTY (()) struct_constructor
48 /* Constructor_type, the type that we are constructing. */
49 tree
GTY ((skip (""))) constructor_type
;
50 /* Constructor_fields, the list of fields belonging to
51 constructor_type. Used by SET and RECORD constructors. */
52 tree
GTY ((skip (""))) constructor_fields
;
53 /* Constructor_element_list, the list of constants used by SET and
54 RECORD constructors. */
55 tree
GTY ((skip (""))) constructor_element_list
;
56 /* Constructor_elements, used by an ARRAY initializer all elements
57 are held in reverse order. */
58 vec
<constructor_elt
, va_gc
> *constructor_elements
;
59 /* Level, the next level down in the constructor stack. */
60 struct struct_constructor
*level
;
63 static GTY (()) struct struct_constructor
*top_constructor
= NULL
;
65 typedef struct GTY (()) array_desc
70 struct array_desc
*next
;
73 static GTY (()) array_desc
*list_of_arrays
= NULL
;
74 /* Used in BuildStartFunctionType. */
75 static GTY (()) tree param_type_list
;
77 static GTY (()) tree proc_type_node
;
78 static GTY (()) tree bitset_type_node
;
79 static GTY (()) tree bitnum_type_node
;
80 static GTY (()) tree m2_char_type_node
;
81 static GTY (()) tree m2_integer_type_node
;
82 static GTY (()) tree m2_cardinal_type_node
;
83 static GTY (()) tree m2_short_real_type_node
;
84 static GTY (()) tree m2_real_type_node
;
85 static GTY (()) tree m2_long_real_type_node
;
86 static GTY (()) tree m2_long_int_type_node
;
87 static GTY (()) tree m2_long_card_type_node
;
88 static GTY (()) tree m2_short_int_type_node
;
89 static GTY (()) tree m2_short_card_type_node
;
90 static GTY (()) tree m2_z_type_node
;
91 static GTY (()) tree m2_iso_loc_type_node
;
92 static GTY (()) tree m2_iso_byte_type_node
;
93 static GTY (()) tree m2_iso_word_type_node
;
94 static GTY (()) tree m2_integer8_type_node
;
95 static GTY (()) tree m2_integer16_type_node
;
96 static GTY (()) tree m2_integer32_type_node
;
97 static GTY (()) tree m2_integer64_type_node
;
98 static GTY (()) tree m2_cardinal8_type_node
;
99 static GTY (()) tree m2_cardinal16_type_node
;
100 static GTY (()) tree m2_cardinal32_type_node
;
101 static GTY (()) tree m2_cardinal64_type_node
;
102 static GTY (()) tree m2_word16_type_node
;
103 static GTY (()) tree m2_word32_type_node
;
104 static GTY (()) tree m2_word64_type_node
;
105 static GTY (()) tree m2_bitset8_type_node
;
106 static GTY (()) tree m2_bitset16_type_node
;
107 static GTY (()) tree m2_bitset32_type_node
;
108 static GTY (()) tree m2_real32_type_node
;
109 static GTY (()) tree m2_real64_type_node
;
110 static GTY (()) tree m2_real96_type_node
;
111 static GTY (()) tree m2_real128_type_node
;
112 static GTY (()) tree m2_complex_type_node
;
113 static GTY (()) tree m2_long_complex_type_node
;
114 static GTY (()) tree m2_short_complex_type_node
;
115 static GTY (()) tree m2_c_type_node
;
116 static GTY (()) tree m2_complex32_type_node
;
117 static GTY (()) tree m2_complex64_type_node
;
118 static GTY (()) tree m2_complex96_type_node
;
119 static GTY (()) tree m2_complex128_type_node
;
120 static GTY (()) tree m2_packed_boolean_type_node
;
121 static GTY (()) tree m2_cardinal_address_type_node
;
123 /* gm2_canonicalize_array - returns a unique array node based on
124 index_type and type. */
127 gm2_canonicalize_array (tree index_type
, int type
)
129 array_desc
*l
= list_of_arrays
;
133 if (l
->type
== type
&& l
->index
== index_type
)
138 l
= ggc_alloc
<array_desc
> ();
139 l
->next
= list_of_arrays
;
141 l
->index
= index_type
;
142 l
->array
= make_node (ARRAY_TYPE
);
143 TREE_TYPE (l
->array
) = NULL_TREE
;
144 TYPE_DOMAIN (l
->array
) = index_type
;
149 /* BuildStartArrayType - creates an array with an indextype and
150 elttype. The front end symbol type is also passed to allow the
151 gccgm2 to return the canonical edition of the array type even if
152 the GCC elttype is NULL_TREE. */
155 m2type_BuildStartArrayType (tree index_type
, tree elt_type
, int type
)
159 elt_type
= m2tree_skip_type_decl (elt_type
);
160 ASSERT_CONDITION (index_type
!= NULL_TREE
);
161 if (elt_type
== NULL_TREE
)
163 /* Cannot use GCC canonicalization routines yet, so we use our front
164 end version based on the front end type. */
165 return gm2_canonicalize_array (index_type
, type
);
167 t
= gm2_canonicalize_array (index_type
, type
);
168 if (TREE_TYPE (t
) == NULL_TREE
)
169 TREE_TYPE (t
) = elt_type
;
171 ASSERT_CONDITION (TREE_TYPE (t
) == elt_type
);
176 /* PutArrayType assignes TREE_TYPE (array) to the skipped type. */
179 m2type_PutArrayType (tree array
, tree type
)
181 TREE_TYPE (array
) = m2tree_skip_type_decl (type
);
184 /* gccgm2_GetArrayNoOfElements returns the number of elements in
188 m2type_GetArrayNoOfElements (location_t location
, tree arraytype
)
190 tree index_type
= TYPE_DOMAIN (m2tree_skip_type_decl (arraytype
));
191 tree min
= TYPE_MIN_VALUE (index_type
);
192 tree max
= TYPE_MAX_VALUE (index_type
);
194 m2assert_AssertLocation (location
);
195 return m2expr_FoldAndStrip (m2expr_BuildSub (location
, max
, min
, false));
198 /* gm2_finish_build_array_type complete building the partially
199 created array type, arrayType. The arrayType is now known to be
200 declared as: ARRAY index_type OF elt_type. There will only ever
201 be one gcc tree type for this array definition. The third
202 parameter type is a front end type and this is necessary so that
203 the canonicalization creates unique array types for each type. */
206 gm2_finish_build_array_type (tree arrayType
, tree elt_type
, tree index_type
,
209 tree old
= arrayType
;
211 elt_type
= m2tree_skip_type_decl (elt_type
);
212 ASSERT_CONDITION (index_type
!= NULL_TREE
);
213 if (TREE_CODE (elt_type
) == FUNCTION_TYPE
)
215 error ("arrays of functions are not meaningful");
216 elt_type
= integer_type_node
;
219 TREE_TYPE (arrayType
) = elt_type
;
220 TYPE_DOMAIN (arrayType
) = index_type
;
222 arrayType
= gm2_canonicalize_array (index_type
, type
);
223 if (arrayType
!= old
)
224 internal_error ("array declaration canonicalization has failed");
226 if (!COMPLETE_TYPE_P (arrayType
))
227 layout_type (arrayType
);
231 /* BuildEndArrayType returns a type which is an array indexed by
232 IndexType and which has ElementType elements. */
235 m2type_BuildEndArrayType (tree arraytype
, tree elementtype
, tree indextype
,
238 elementtype
= m2tree_skip_type_decl (elementtype
);
239 ASSERT (indextype
== TYPE_DOMAIN (arraytype
), indextype
);
241 if (TREE_CODE (elementtype
) == FUNCTION_TYPE
)
242 return gm2_finish_build_array_type (arraytype
, ptr_type_node
, indextype
,
245 return gm2_finish_build_array_type (
246 arraytype
, m2tree_skip_type_decl (elementtype
), indextype
, type
);
249 /* gm2_build_array_type returns a type which is an array indexed by
250 IndexType and which has ElementType elements. */
253 gm2_build_array_type (tree elementtype
, tree indextype
, int fetype
)
255 tree arrayType
= m2type_BuildStartArrayType (indextype
, elementtype
, fetype
);
256 return m2type_BuildEndArrayType (arrayType
, elementtype
, indextype
, fetype
);
259 /* ValueInTypeRange returns true if the constant, value, lies within
260 the range of type. */
263 m2type_ValueInTypeRange (tree type
, tree value
)
265 tree low_type
= m2tree_skip_type_decl (type
);
266 tree min_value
= TYPE_MIN_VALUE (low_type
);
267 tree max_value
= TYPE_MAX_VALUE (low_type
);
269 value
= m2expr_FoldAndStrip (value
);
270 return ((tree_int_cst_compare (min_value
, value
) <= 0)
271 && (tree_int_cst_compare (value
, max_value
) <= 0));
274 /* ValueOutOfTypeRange returns true if the constant, value, exceeds
275 the range of type. */
278 m2type_ValueOutOfTypeRange (tree type
, tree value
)
280 return (!m2type_ValueInTypeRange (type
, value
));
283 /* ExceedsTypeRange return true if low or high exceed the range of
287 m2type_ExceedsTypeRange (tree type
, tree low
, tree high
)
289 return (m2type_ValueOutOfTypeRange (type
, low
)
290 || m2type_ValueOutOfTypeRange (type
, high
));
293 /* WithinTypeRange return true if low and high are within the range
297 m2type_WithinTypeRange (tree type
, tree low
, tree high
)
299 return (m2type_ValueInTypeRange (type
, low
)
300 && m2type_ValueInTypeRange (type
, high
));
303 /* BuildArrayIndexType creates an integer index which accesses an
304 array. low and high are the min, max elements of the array. GCC
305 insists we access an array with an integer indice. */
308 m2type_BuildArrayIndexType (tree low
, tree high
)
310 tree sizelow
= convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (low
));
312 = convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (high
));
314 if (m2expr_TreeOverflow (sizelow
))
315 error ("low bound for the array is outside the ztype limits");
316 if (m2expr_TreeOverflow (sizehigh
))
317 error ("high bound for the array is outside the ztype limits");
319 return build_range_type (m2type_GetIntegerType (),
320 m2expr_FoldAndStrip (sizelow
),
321 m2expr_FoldAndStrip (sizehigh
));
324 /* build_m2_type_node_by_array builds a ISO Modula-2 word type from
325 ARRAY [low..high] OF arrayType. This matches the front end data
326 type fetype which is only used during canonicalization. */
329 build_m2_type_node_by_array (tree arrayType
, tree low
, tree high
, int fetype
)
331 return gm2_build_array_type (arrayType
,
332 m2type_BuildArrayIndexType (low
, high
), fetype
);
335 /* build_m2_word16_type_node build an ISO 16 bit word as an ARRAY
339 build_m2_word16_type_node (location_t location
, int loc
)
341 return build_m2_type_node_by_array (m2type_GetISOLocType (),
342 m2expr_GetIntegerZero (location
),
343 m2expr_GetIntegerOne (location
), loc
);
346 /* build_m2_word32_type_node build an ISO 32 bit word as an ARRAY
350 build_m2_word32_type_node (location_t location
, int loc
)
352 return build_m2_type_node_by_array (m2type_GetISOLocType (),
353 m2expr_GetIntegerZero (location
),
354 m2decl_BuildIntegerConstant (3), loc
);
357 /* build_m2_word64_type_node build an ISO 32 bit word as an ARRAY
361 build_m2_word64_type_node (location_t location
, int loc
)
363 return build_m2_type_node_by_array (m2type_GetISOLocType (),
364 m2expr_GetIntegerZero (location
),
365 m2decl_BuildIntegerConstant (7), loc
);
369 /* GetM2Complex32 return the fixed size complex type. */
372 m2type_GetM2Complex32 (void)
374 return m2_complex32_type_node
;
377 /* GetM2Complex64 return the fixed size complex type. */
380 m2type_GetM2Complex64 (void)
382 return m2_complex64_type_node
;
385 /* GetM2Complex96 return the fixed size complex type. */
388 m2type_GetM2Complex96 (void)
390 return m2_complex96_type_node
;
393 /* GetM2Complex128 return the fixed size complex type. */
396 m2type_GetM2Complex128 (void)
398 return m2_complex128_type_node
;
401 /* GetM2CType a test function. */
404 m2type_GetM2CType (void)
406 return m2_c_type_node
;
409 /* GetM2ShortComplexType return the short complex type. */
412 m2type_GetM2ShortComplexType (void)
414 return m2_short_complex_type_node
;
417 /* GetM2LongComplexType return the long complex type. */
420 m2type_GetM2LongComplexType (void)
422 return m2_long_complex_type_node
;
425 /* GetM2ComplexType return the complex type. */
428 m2type_GetM2ComplexType (void)
430 return m2_complex_type_node
;
433 /* GetM2Real128 return the real 128 bit type. */
436 m2type_GetM2Real128 (void)
438 return m2_real128_type_node
;
441 /* GetM2Real96 return the real 96 bit type. */
444 m2type_GetM2Real96 (void)
446 return m2_real96_type_node
;
449 /* GetM2Real64 return the real 64 bit type. */
452 m2type_GetM2Real64 (void)
454 return m2_real64_type_node
;
457 /* GetM2Real32 return the real 32 bit type. */
460 m2type_GetM2Real32 (void)
462 return m2_real32_type_node
;
465 /* GetM2Bitset32 return the bitset 32 bit type. */
468 m2type_GetM2Bitset32 (void)
470 return m2_bitset32_type_node
;
473 /* GetM2Bitset16 return the bitset 16 bit type. */
476 m2type_GetM2Bitset16 (void)
478 return m2_bitset16_type_node
;
481 /* GetM2Bitset8 return the bitset 8 bit type. */
484 m2type_GetM2Bitset8 (void)
486 return m2_bitset8_type_node
;
489 /* GetM2Word64 return the word 64 bit type. */
492 m2type_GetM2Word64 (void)
494 return m2_word64_type_node
;
497 /* GetM2Word32 return the word 32 bit type. */
500 m2type_GetM2Word32 (void)
502 return m2_word32_type_node
;
505 /* GetM2Word16 return the word 16 bit type. */
508 m2type_GetM2Word16 (void)
510 return m2_word16_type_node
;
513 /* GetM2Cardinal64 return the cardinal 64 bit type. */
516 m2type_GetM2Cardinal64 (void)
518 return m2_cardinal64_type_node
;
521 /* GetM2Cardinal32 return the cardinal 32 bit type. */
524 m2type_GetM2Cardinal32 (void)
526 return m2_cardinal32_type_node
;
529 /* GetM2Cardinal16 return the cardinal 16 bit type. */
532 m2type_GetM2Cardinal16 (void)
534 return m2_cardinal16_type_node
;
537 /* GetM2Cardinal8 return the cardinal 8 bit type. */
540 m2type_GetM2Cardinal8 (void)
542 return m2_cardinal8_type_node
;
545 /* GetM2Integer64 return the integer 64 bit type. */
548 m2type_GetM2Integer64 (void)
550 return m2_integer64_type_node
;
553 /* GetM2Integer32 return the integer 32 bit type. */
556 m2type_GetM2Integer32 (void)
558 return m2_integer32_type_node
;
561 /* GetM2Integer16 return the integer 16 bit type. */
564 m2type_GetM2Integer16 (void)
566 return m2_integer16_type_node
;
569 /* GetM2Integer8 return the integer 8 bit type. */
572 m2type_GetM2Integer8 (void)
574 return m2_integer8_type_node
;
577 /* GetM2RType return the ISO R data type, the longest real
581 m2type_GetM2RType (void)
583 return long_double_type_node
;
586 /* GetM2ZType return the ISO Z data type, the longest int datatype. */
589 m2type_GetM2ZType (void)
591 return m2_z_type_node
;
594 /* GetShortCardType return the C short unsigned data type. */
597 m2type_GetShortCardType (void)
599 return short_unsigned_type_node
;
602 /* GetM2ShortCardType return the m2 short cardinal data type. */
605 m2type_GetM2ShortCardType (void)
607 return m2_short_card_type_node
;
610 /* GetShortIntType return the C short int data type. */
613 m2type_GetShortIntType (void)
615 return short_integer_type_node
;
618 /* GetM2ShortIntType return the m2 short integer data type. */
621 m2type_GetM2ShortIntType (void)
623 return m2_short_int_type_node
;
626 /* GetM2LongCardType return the m2 long cardinal data type. */
629 m2type_GetM2LongCardType (void)
631 return m2_long_card_type_node
;
634 /* GetM2LongIntType return the m2 long integer data type. */
637 m2type_GetM2LongIntType (void)
639 return m2_long_int_type_node
;
642 /* GetM2LongRealType return the m2 long real data type. */
645 m2type_GetM2LongRealType (void)
647 return m2_long_real_type_node
;
650 /* GetM2RealType return the m2 real data type. */
653 m2type_GetM2RealType (void)
655 return m2_real_type_node
;
658 /* GetM2ShortRealType return the m2 short real data type. */
661 m2type_GetM2ShortRealType (void)
663 return m2_short_real_type_node
;
666 /* GetM2CardinalType return the m2 cardinal data type. */
669 m2type_GetM2CardinalType (void)
671 return m2_cardinal_type_node
;
674 /* GetM2IntegerType return the m2 integer data type. */
677 m2type_GetM2IntegerType (void)
679 return m2_integer_type_node
;
682 /* GetM2CharType return the m2 char data type. */
685 m2type_GetM2CharType (void)
687 return m2_char_type_node
;
690 /* GetProcType return the m2 proc data type. */
693 m2type_GetProcType (void)
695 return proc_type_node
;
698 /* GetISOWordType return the m2 iso word data type. */
701 m2type_GetISOWordType (void)
703 return m2_iso_word_type_node
;
706 /* GetISOByteType return the m2 iso byte data type. */
709 m2type_GetISOByteType (void)
711 return m2_iso_byte_type_node
;
714 /* GetISOLocType return the m2 loc word data type. */
717 m2type_GetISOLocType (void)
719 return m2_iso_loc_type_node
;
722 /* GetWordType return the C unsigned data type. */
725 m2type_GetWordType (void)
727 return unsigned_type_node
;
730 /* GetLongIntType return the C long int data type. */
733 m2type_GetLongIntType (void)
735 return long_integer_type_node
;
738 /* GetShortRealType return the C float data type. */
741 m2type_GetShortRealType (void)
743 return float_type_node
;
746 /* GetLongRealType return the C long double data type. */
749 m2type_GetLongRealType (void)
751 return long_double_type_node
;
754 /* GetRealType returns the C double_type_node. */
757 m2type_GetRealType (void)
759 return double_type_node
;
762 /* GetBitnumType return the ISO bitnum type. */
765 m2type_GetBitnumType (void)
767 return bitnum_type_node
;
770 /* GetBitsetType return the bitset type. */
773 m2type_GetBitsetType (void)
775 return bitset_type_node
;
778 /* GetCardinalType return the cardinal type. */
781 m2type_GetCardinalType (void)
783 return unsigned_type_node
;
786 /* GetPointerType return the GCC ptr type node. Equivalent to
790 m2type_GetPointerType (void)
792 return ptr_type_node
;
795 /* GetVoidType return the C void type. */
798 m2type_GetVoidType (void)
800 return void_type_node
;
803 /* GetByteType return the byte type node. */
806 m2type_GetByteType (void)
808 return unsigned_char_type_node
;
811 /* GetCharType return the char type node. */
814 m2type_GetCharType (void)
816 return char_type_node
;
819 /* GetIntegerType return the integer type node. */
822 m2type_GetIntegerType (void)
824 return integer_type_node
;
827 /* GetCSizeTType return a type representing, size_t on this system. */
830 m2type_GetCSizeTType (void)
835 /* GetCSSizeTType return a type representing, size_t on this
839 m2type_GetCSSizeTType (void)
844 /* GetPackedBooleanType return the packed boolean data type node. */
847 m2type_GetPackedBooleanType (void)
849 return m2_packed_boolean_type_node
;
852 /* GetBooleanTrue return modula-2 true. */
855 m2type_GetBooleanTrue (void)
857 #if defined(USE_BOOLEAN)
858 return boolean_true_node
;
859 #else /* !USE_BOOLEAN */
860 return m2expr_GetIntegerOne (m2linemap_BuiltinsLocation ());
861 #endif /* !USE_BOOLEAN */
864 /* GetBooleanFalse return modula-2 FALSE. */
867 m2type_GetBooleanFalse (void)
869 #if defined(USE_BOOLEAN)
870 return boolean_false_node
;
871 #else /* !USE_BOOLEAN */
872 return m2expr_GetIntegerZero (m2linemap_BuiltinsLocation ());
873 #endif /* !USE_BOOLEAN */
876 /* GetBooleanType return the modula-2 BOOLEAN type. */
879 m2type_GetBooleanType (void)
881 #if defined(USE_BOOLEAN)
882 return boolean_type_node
;
883 #else /* !USE_BOOLEAN */
884 return integer_type_node
;
885 #endif /* !USE_BOOLEAN */
888 /* GetCardinalAddressType returns the internal data type for
889 computing binary arithmetic upon the ADDRESS datatype. */
892 m2type_GetCardinalAddressType (void)
894 return m2_cardinal_address_type_node
;
898 /* build_set_type creates a set type from the, domain, [low..high].
899 The values low..high all have type, range_type. */
902 build_set_type (tree domain
, tree range_type
, int allow_void
, int ispacked
)
906 if (!m2tree_IsOrdinal (domain
)
907 && !(allow_void
&& TREE_CODE (domain
) == VOID_TYPE
))
909 error ("set base type must be an ordinal type");
913 if (TYPE_SIZE (range_type
) == 0)
914 layout_type (range_type
);
916 if (TYPE_SIZE (domain
) == 0)
917 layout_type (domain
);
919 type
= make_node (SET_TYPE
);
920 TREE_TYPE (type
) = range_type
;
921 TYPE_DOMAIN (type
) = domain
;
922 TYPE_PACKED (type
) = ispacked
;
927 /* convert_type_to_range does the conversion and copies the range
931 convert_type_to_range (tree type
)
936 if (!m2tree_IsOrdinal (type
))
938 error ("ordinal type expected");
939 return error_mark_node
;
942 min
= TYPE_MIN_VALUE (type
);
943 max
= TYPE_MAX_VALUE (type
);
945 if (TREE_TYPE (min
) != TREE_TYPE (max
))
947 error ("range limits are not of the same type");
948 return error_mark_node
;
951 itype
= build_range_type (TREE_TYPE (min
), min
, max
);
953 if (TREE_TYPE (type
) == NULL_TREE
)
956 TREE_TYPE (itype
) = type
;
960 layout_type (TREE_TYPE (type
));
961 TREE_TYPE (itype
) = TREE_TYPE (type
);
969 /* build_bitset_type builds the type BITSET which is exported from
970 SYSTEM. It also builds BITNUM (the subrange from which BITSET is
974 build_bitset_type (location_t location
)
976 m2assert_AssertLocation (location
);
977 bitnum_type_node
= build_range_type (
978 m2tree_skip_type_decl (m2type_GetCardinalType ()),
979 m2decl_BuildIntegerConstant (0),
980 m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset () - 1));
981 layout_type (bitnum_type_node
);
984 if (broken_set_debugging_info
)
985 return unsigned_type_node
;
988 ASSERT ((COMPLETE_TYPE_P (bitnum_type_node
)), bitnum_type_node
);
990 return m2type_BuildSetTypeFromSubrange (
991 location
, NULL
, bitnum_type_node
, m2decl_BuildIntegerConstant (0),
992 m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset () - 1), false);
995 /* BuildSetTypeFromSubrange constructs a set type from a
996 subrangeType. --fixme-- revisit once gdb/gcc supports dwarf-5 set type. */
999 m2type_BuildSetTypeFromSubrange (location_t location
,
1000 char *name
__attribute__ ((unused
)),
1001 tree subrangeType
__attribute__ ((unused
)),
1002 tree lowval
, tree highval
, bool ispacked
)
1004 m2assert_AssertLocation (location
);
1005 lowval
= m2expr_FoldAndStrip (lowval
);
1006 highval
= m2expr_FoldAndStrip (highval
);
1009 if (broken_set_debugging_info
)
1010 return unsigned_type_node
;
1015 tree noelements
= m2expr_BuildAdd (
1016 location
, m2expr_BuildSub (location
, highval
, lowval
, false),
1017 integer_one_node
, false);
1018 highval
= m2expr_FoldAndStrip (m2expr_BuildSub (
1019 location
, m2expr_BuildLSL (location
, m2expr_GetWordOne (location
),
1021 m2expr_GetIntegerOne (location
), false));
1022 lowval
= m2expr_GetIntegerZero (location
);
1023 return m2type_BuildSmallestTypeRange (location
, lowval
, highval
);
1026 return unsigned_type_node
;
1029 /* build_m2_size_set_type build and return a set type with
1033 build_m2_size_set_type (location_t location
, int precision
)
1035 tree bitnum_type_node
1036 = build_range_type (m2tree_skip_type_decl (m2type_GetCardinalType ()),
1037 m2decl_BuildIntegerConstant (0),
1038 m2decl_BuildIntegerConstant (precision
- 1));
1039 layout_type (bitnum_type_node
);
1040 m2assert_AssertLocation (location
);
1042 if (broken_set_debugging_info
)
1043 return unsigned_type_node
;
1045 ASSERT ((COMPLETE_TYPE_P (bitnum_type_node
)), bitnum_type_node
);
1047 return m2type_BuildSetTypeFromSubrange (
1048 location
, NULL
, bitnum_type_node
, m2decl_BuildIntegerConstant (0),
1049 m2decl_BuildIntegerConstant (precision
- 1), false);
1052 /* build_m2_specific_size_type build a specific data type matching
1053 number of bits precision whether it is_signed. It creates a
1054 set type if base == SET_TYPE or returns the already created real,
1055 if REAL_TYPE is specified. */
1058 build_m2_specific_size_type (location_t location
, enum tree_code base
,
1059 int precision
, int is_signed
)
1063 m2assert_AssertLocation (location
);
1065 c
= make_node (base
);
1066 TYPE_PRECISION (c
) = precision
;
1068 if (base
== REAL_TYPE
)
1070 if (!float_mode_for_size (TYPE_PRECISION (c
)).exists ())
1074 else if (base
== SET_TYPE
)
1075 return build_m2_size_set_type (location
, precision
);
1082 fixup_signed_type (c
);
1083 TYPE_UNSIGNED (c
) = false;
1087 fixup_unsigned_type (c
);
1088 TYPE_UNSIGNED (c
) = true;
1094 /* BuildSmallestTypeRange returns the smallest INTEGER_TYPE which
1095 is sufficient to contain values: low..high. */
1098 m2type_BuildSmallestTypeRange (location_t location
, tree low
, tree high
)
1102 m2assert_AssertLocation (location
);
1105 bits
= fold (m2expr_calcNbits (location
, low
, high
));
1106 return build_m2_specific_size_type (location
, INTEGER_TYPE
,
1107 TREE_INT_CST_LOW (bits
),
1108 tree_int_cst_sgn (low
) < 0);
1111 /* GetTreeType returns TREE_TYPE (t). */
1114 m2type_GetTreeType (tree t
)
1116 return TREE_TYPE (t
);
1119 /* finish_build_pointer_type finish building a POINTER_TYPE node.
1120 necessary to solve self references in procedure types. */
1122 /* Code taken from tree.cc:build_pointer_type_for_mode. */
1125 finish_build_pointer_type (tree t
, tree to_type
, enum machine_mode mode
,
1128 TREE_TYPE (t
) = to_type
;
1129 SET_TYPE_MODE (t
, mode
);
1130 TYPE_REF_CAN_ALIAS_ALL (t
) = can_alias_all
;
1131 TYPE_NEXT_PTR_TO (t
) = TYPE_POINTER_TO (to_type
);
1132 TYPE_POINTER_TO (to_type
) = t
;
1134 /* Lay out the type. */
1135 /* layout_type (t); */
1140 /* BuildParameterDeclaration creates and returns one parameter
1141 from, name, and, type. It appends this parameter to the internal
1145 m2type_BuildProcTypeParameterDeclaration (location_t location
, tree type
,
1148 m2assert_AssertLocation (location
);
1149 ASSERT_BOOL (isreference
);
1150 type
= m2tree_skip_type_decl (type
);
1152 type
= build_reference_type (type
);
1154 param_type_list
= tree_cons (NULL_TREE
, type
, param_type_list
);
1158 /* BuildEndFunctionType build a function type which would return a,
1159 value. The arguments have been created by
1160 BuildParameterDeclaration. */
1163 m2type_BuildEndFunctionType (tree func
, tree return_type
, bool uses_varargs
)
1167 if (return_type
== NULL_TREE
)
1168 return_type
= void_type_node
;
1170 return_type
= m2tree_skip_type_decl (return_type
);
1174 if (param_type_list
!= NULL_TREE
)
1176 param_type_list
= nreverse (param_type_list
);
1177 last
= param_type_list
;
1178 param_type_list
= nreverse (param_type_list
);
1179 gcc_assert (last
!= void_list_node
);
1182 else if (param_type_list
== NULL_TREE
)
1183 param_type_list
= void_list_node
;
1186 param_type_list
= nreverse (param_type_list
);
1187 last
= param_type_list
;
1188 param_type_list
= nreverse (param_type_list
);
1189 TREE_CHAIN (last
) = void_list_node
;
1191 param_type_list
= build_function_type (return_type
, param_type_list
);
1193 func
= finish_build_pointer_type (func
, param_type_list
, ptr_mode
, false);
1194 TYPE_SIZE (func
) = 0;
1199 /* BuildStartFunctionType creates a pointer type, necessary to
1200 create a function type. */
1203 m2type_BuildStartFunctionType (location_t location ATTRIBUTE_UNUSED
,
1204 char *name ATTRIBUTE_UNUSED
)
1206 tree n
= make_node (POINTER_TYPE
);
1208 m2assert_AssertLocation (location
);
1212 /* InitFunctionTypeParameters resets the current function type
1216 m2type_InitFunctionTypeParameters (void)
1218 param_type_list
= NULL_TREE
;
1221 /* gm2_finish_decl finishes VAR, TYPE and FUNCTION declarations. */
1224 gm2_finish_decl (location_t location
, tree decl
)
1226 tree type
= TREE_TYPE (decl
);
1227 int was_incomplete
= (DECL_SIZE (decl
) == 0);
1229 m2assert_AssertLocation (location
);
1232 if (DECL_SIZE (decl
) == 0 && TREE_TYPE (decl
) != error_mark_node
1233 && COMPLETE_TYPE_P (TREE_TYPE (decl
)))
1234 layout_decl (decl
, 0);
1236 if (DECL_SIZE (decl
) == 0
1237 /* Don't give an error if we already gave one earlier. */
1238 && TREE_TYPE (decl
) != error_mark_node
)
1240 error_at (location
, "storage size of %q+D isn%'t known", decl
);
1241 TREE_TYPE (decl
) = error_mark_node
;
1244 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
1245 && DECL_SIZE (decl
) != 0)
1247 if (TREE_CODE (DECL_SIZE (decl
)) == INTEGER_CST
)
1248 m2expr_ConstantExpressionWarning (DECL_SIZE (decl
));
1250 error_at (location
, "storage size of %q+D isn%'t constant", decl
);
1253 if (TREE_USED (type
))
1254 TREE_USED (decl
) = 1;
1257 /* Output the assembler code and/or RTL code for variables and
1258 functions, unless the type is an undefined structure or union. If
1259 not, it will get done when the type is completed. */
1261 if (VAR_P (decl
) || TREE_CODE (decl
) == FUNCTION_DECL
)
1263 if (DECL_FILE_SCOPE_P (decl
))
1265 if (DECL_INITIAL (decl
) == NULL_TREE
1266 || DECL_INITIAL (decl
) == error_mark_node
)
1268 /* Don't output anything when a tentative file-scope definition is
1269 seen. But at end of compilation, do output code for them. */
1270 DECL_DEFER_OUTPUT (decl
) = 1;
1271 rest_of_decl_compilation (decl
, true, 0);
1274 if (!DECL_FILE_SCOPE_P (decl
))
1277 /* Recompute the RTL of a local array now if it used to be an
1279 if (was_incomplete
&& !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
1281 /* If we used it already as memory, it must stay in memory. */
1282 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
1283 /* If it's still incomplete now, no init will save it. */
1284 if (DECL_SIZE (decl
) == 0)
1285 DECL_INITIAL (decl
) = 0;
1290 if (TREE_CODE (decl
) == TYPE_DECL
)
1292 if (!DECL_FILE_SCOPE_P (decl
)
1293 && variably_modified_type_p (TREE_TYPE (decl
), NULL_TREE
))
1294 m2block_pushDecl (build_stmt (location
, DECL_EXPR
, decl
));
1296 rest_of_decl_compilation (decl
, DECL_FILE_SCOPE_P (decl
), 0);
1300 /* BuildVariableArrayAndDeclare creates a variable length array.
1301 high is the maximum legal elements (which is a runtime variable).
1302 This creates and array index, array type and local variable. */
1305 m2type_BuildVariableArrayAndDeclare (location_t location
, tree elementtype
,
1306 tree high
, char *name
, tree scope
)
1308 tree indextype
= build_index_type (variable_size (high
));
1309 tree arraytype
= build_array_type (elementtype
, indextype
);
1310 tree id
= get_identifier (name
);
1313 m2assert_AssertLocation (location
);
1314 decl
= build_decl (location
, VAR_DECL
, id
, arraytype
);
1316 DECL_EXTERNAL (decl
) = false;
1317 TREE_PUBLIC (decl
) = true;
1318 DECL_CONTEXT (decl
) = scope
;
1319 TREE_USED (arraytype
) = true;
1320 TREE_USED (decl
) = true;
1322 m2block_pushDecl (decl
);
1324 gm2_finish_decl (location
, indextype
);
1325 gm2_finish_decl (location
, arraytype
);
1326 add_stmt (location
, build_stmt (location
, DECL_EXPR
, decl
));
1331 build_m2_iso_word_node (location_t location
, int loc
)
1335 m2assert_AssertLocation (location
);
1336 /* Define `WORD' as specified in ISO m2
1338 WORD = ARRAY [0..SizeOfWord / SizeOfLoc] OF LOC ; */
1340 if (m2decl_GetBitsPerInt () == BITS_PER_UNIT
)
1341 c
= m2type_GetISOLocType ();
1343 c
= gm2_build_array_type (
1344 m2type_GetISOLocType (),
1345 m2type_BuildArrayIndexType (
1346 m2expr_GetIntegerZero (location
),
1347 (m2expr_BuildSub (location
,
1348 m2decl_BuildIntegerConstant (
1349 m2decl_GetBitsPerInt () / BITS_PER_UNIT
),
1350 m2expr_GetIntegerOne (location
), false))),
1356 build_m2_iso_byte_node (location_t location
, int loc
)
1360 /* Define `BYTE' as specified in ISO m2
1362 BYTE = ARRAY [0..SizeOfByte / SizeOfLoc] OF LOC ; */
1364 if (BITS_PER_UNIT
== 8)
1365 c
= m2type_GetISOLocType ();
1367 c
= gm2_build_array_type (
1368 m2type_GetISOLocType (),
1369 m2type_BuildArrayIndexType (
1370 m2expr_GetIntegerZero (location
),
1371 m2decl_BuildIntegerConstant (BITS_PER_UNIT
/ 8)),
1376 /* m2type_InitSystemTypes initialise loc and word derivatives. */
1379 m2type_InitSystemTypes (location_t location
, int loc
)
1381 m2assert_AssertLocation (location
);
1383 m2_iso_word_type_node
= build_m2_iso_word_node (location
, loc
);
1384 m2_iso_byte_type_node
= build_m2_iso_byte_node (location
, loc
);
1386 m2_word16_type_node
= build_m2_word16_type_node (location
, loc
);
1387 m2_word32_type_node
= build_m2_word32_type_node (location
, loc
);
1388 m2_word64_type_node
= build_m2_word64_type_node (location
, loc
);
1392 build_m2_integer_node (void)
1394 return m2type_GetIntegerType ();
1398 build_m2_cardinal_node (void)
1400 return m2type_GetCardinalType ();
1404 build_m2_char_node (void)
1408 /* Define `CHAR', to be an unsigned char. */
1410 c
= make_unsigned_type (CHAR_TYPE_SIZE
);
1416 build_m2_short_real_node (void)
1420 /* Define `REAL'. */
1422 c
= make_node (REAL_TYPE
);
1423 TYPE_PRECISION (c
) = FLOAT_TYPE_SIZE
;
1429 build_m2_real_node (void)
1433 /* Define `REAL'. */
1435 c
= make_node (REAL_TYPE
);
1436 TYPE_PRECISION (c
) = DOUBLE_TYPE_SIZE
;
1442 build_m2_long_real_node (void)
1446 /* Define `LONGREAL'. */
1448 if (m2configure_M2CLongRealFloat128 ())
1449 c
= float128_type_node
;
1450 else if (m2configure_M2CLongRealIBM128 ())
1452 c
= make_node (REAL_TYPE
);
1453 TYPE_PRECISION (c
) = LONG_DOUBLE_TYPE_SIZE
;
1456 c
= long_double_type_node
;
1463 build_m2_ztype_node (void)
1467 /* Define `ZTYPE'. */
1469 if (targetm
.scalar_mode_supported_p (TImode
))
1470 ztype_node
= gm2_type_for_size (128, 0);
1472 ztype_node
= gm2_type_for_size (64, 0);
1473 layout_type (ztype_node
);
1478 build_m2_long_int_node (void)
1482 /* Define `LONGINT'. */
1484 c
= make_signed_type (LONG_LONG_TYPE_SIZE
);
1490 build_m2_long_card_node (void)
1494 /* Define `LONGCARD'. */
1496 c
= make_unsigned_type (LONG_LONG_TYPE_SIZE
);
1502 build_m2_short_int_node (void)
1506 /* Define `SHORTINT'. */
1508 c
= make_signed_type (SHORT_TYPE_SIZE
);
1514 build_m2_short_card_node (void)
1518 /* Define `SHORTCARD'. */
1520 c
= make_unsigned_type (SHORT_TYPE_SIZE
);
1526 build_m2_iso_loc_node (void)
1530 /* Define `LOC' as specified in ISO m2. */
1532 c
= make_node (INTEGER_TYPE
);
1533 TYPE_PRECISION (c
) = BITS_PER_UNIT
;
1536 fixup_unsigned_type (c
);
1537 TYPE_UNSIGNED (c
) = 1;
1542 build_m2_integer8_type_node (location_t location
)
1544 m2assert_AssertLocation (location
);
1545 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 8, true);
1549 build_m2_integer16_type_node (location_t location
)
1551 m2assert_AssertLocation (location
);
1552 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 16, true);
1556 build_m2_integer32_type_node (location_t location
)
1558 m2assert_AssertLocation (location
);
1559 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 32, true);
1563 build_m2_integer64_type_node (location_t location
)
1565 m2assert_AssertLocation (location
);
1566 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 64, true);
1570 build_m2_cardinal8_type_node (location_t location
)
1572 m2assert_AssertLocation (location
);
1573 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 8, false);
1577 build_m2_cardinal16_type_node (location_t location
)
1579 m2assert_AssertLocation (location
);
1580 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 16, false);
1584 build_m2_cardinal32_type_node (location_t location
)
1586 m2assert_AssertLocation (location
);
1587 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 32, false);
1591 build_m2_cardinal64_type_node (location_t location
)
1593 m2assert_AssertLocation (location
);
1594 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 64, false);
1598 build_m2_bitset8_type_node (location_t location
)
1600 m2assert_AssertLocation (location
);
1601 if (broken_set_debugging_info
)
1602 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 8, false);
1604 return build_m2_specific_size_type (location
, SET_TYPE
, 8, false);
1608 build_m2_bitset16_type_node (location_t location
)
1610 m2assert_AssertLocation (location
);
1611 if (broken_set_debugging_info
)
1612 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 16, false);
1614 return build_m2_specific_size_type (location
, SET_TYPE
, 16, false);
1618 build_m2_bitset32_type_node (location_t location
)
1620 m2assert_AssertLocation (location
);
1621 if (broken_set_debugging_info
)
1622 return build_m2_specific_size_type (location
, INTEGER_TYPE
, 32, false);
1624 return build_m2_specific_size_type (location
, SET_TYPE
, 32, false);
1628 build_m2_real32_type_node (location_t location
)
1630 m2assert_AssertLocation (location
);
1631 return build_m2_specific_size_type (location
, REAL_TYPE
, 32, true);
1635 build_m2_real64_type_node (location_t location
)
1637 m2assert_AssertLocation (location
);
1638 return build_m2_specific_size_type (location
, REAL_TYPE
, 64, true);
1642 build_m2_real96_type_node (location_t location
)
1644 m2assert_AssertLocation (location
);
1645 return build_m2_specific_size_type (location
, REAL_TYPE
, 96, true);
1649 build_m2_real128_type_node (location_t location
)
1651 m2assert_AssertLocation (location
);
1652 return build_m2_specific_size_type (location
, REAL_TYPE
, 128, true);
1656 build_m2_complex_type_from (tree scalar_type
)
1660 if (scalar_type
== NULL
)
1662 if (scalar_type
== float_type_node
)
1663 return complex_float_type_node
;
1664 if (scalar_type
== double_type_node
)
1665 return complex_double_type_node
;
1666 if (scalar_type
== long_double_type_node
)
1667 return complex_long_double_type_node
;
1669 new_type
= make_node (COMPLEX_TYPE
);
1670 TREE_TYPE (new_type
) = scalar_type
;
1671 layout_type (new_type
);
1676 build_m2_complex_type_node (void)
1678 return build_m2_complex_type_from (m2_real_type_node
);
1682 build_m2_long_complex_type_node (void)
1684 return build_m2_complex_type_from (m2_long_real_type_node
);
1688 build_m2_short_complex_type_node (void)
1690 return build_m2_complex_type_from (m2_short_real_type_node
);
1694 build_m2_complex32_type_node (void)
1696 return build_m2_complex_type_from (m2_real32_type_node
);
1700 build_m2_complex64_type_node (void)
1702 return build_m2_complex_type_from (m2_real64_type_node
);
1706 build_m2_complex96_type_node (void)
1708 return build_m2_complex_type_from (m2_real96_type_node
);
1712 build_m2_complex128_type_node (void)
1714 return build_m2_complex_type_from (m2_real128_type_node
);
1718 build_m2_cardinal_address_type_node (location_t location
)
1720 tree size
= size_in_bytes (ptr_type_node
);
1721 int bits
= TREE_INT_CST_LOW (size
) * BITS_PER_UNIT
;
1723 return build_m2_specific_size_type (location
, INTEGER_TYPE
, bits
, false);
1727 build_m2_boolean (location_t location
)
1729 tree tname
= get_identifier ("BOOLEAN");
1730 tree typedecl
= build_decl (location
, TYPE_DECL
, tname
, boolean_type_node
);
1731 DECL_ARTIFICIAL (typedecl
) = 1;
1732 TYPE_NAME (boolean_type_node
) = typedecl
;
1736 /* Return true if real types a and b are the same. */
1739 m2type_SameRealType (tree a
, tree b
)
1742 || (TYPE_PRECISION (a
) == TYPE_PRECISION (b
)));
1745 /* InitBaseTypes create the Modula-2 base types. */
1748 m2type_InitBaseTypes (location_t location
)
1750 m2assert_AssertLocation (location
);
1753 ptr_type_node
= build_pointer_type (void_type_node
);
1756 = build_pointer_type (build_function_type (void_type_node
, NULL_TREE
));
1758 bitset_type_node
= build_bitset_type (location
);
1759 m2_char_type_node
= build_m2_char_node ();
1760 m2_integer_type_node
= build_m2_integer_node ();
1761 m2_cardinal_type_node
= build_m2_cardinal_node ();
1762 m2_short_real_type_node
= build_m2_short_real_node ();
1763 m2_real_type_node
= build_m2_real_node ();
1764 m2_long_real_type_node
= build_m2_long_real_node ();
1765 m2_long_int_type_node
= build_m2_long_int_node ();
1766 m2_long_card_type_node
= build_m2_long_card_node ();
1767 m2_short_int_type_node
= build_m2_short_int_node ();
1768 m2_short_card_type_node
= build_m2_short_card_node ();
1769 m2_z_type_node
= build_m2_ztype_node ();
1770 m2_integer8_type_node
= build_m2_integer8_type_node (location
);
1771 m2_integer16_type_node
= build_m2_integer16_type_node (location
);
1772 m2_integer32_type_node
= build_m2_integer32_type_node (location
);
1773 m2_integer64_type_node
= build_m2_integer64_type_node (location
);
1774 m2_cardinal8_type_node
= build_m2_cardinal8_type_node (location
);
1775 m2_cardinal16_type_node
= build_m2_cardinal16_type_node (location
);
1776 m2_cardinal32_type_node
= build_m2_cardinal32_type_node (location
);
1777 m2_cardinal64_type_node
= build_m2_cardinal64_type_node (location
);
1778 m2_bitset8_type_node
= build_m2_bitset8_type_node (location
);
1779 m2_bitset16_type_node
= build_m2_bitset16_type_node (location
);
1780 m2_bitset32_type_node
= build_m2_bitset32_type_node (location
);
1781 m2_real32_type_node
= build_m2_real32_type_node (location
);
1782 m2_real64_type_node
= build_m2_real64_type_node (location
);
1783 m2_real96_type_node
= build_m2_real96_type_node (location
);
1784 m2_real128_type_node
= build_m2_real128_type_node (location
);
1785 m2_complex_type_node
= build_m2_complex_type_node ();
1786 m2_long_complex_type_node
= build_m2_long_complex_type_node ();
1787 m2_short_complex_type_node
= build_m2_short_complex_type_node ();
1788 m2_c_type_node
= m2_long_complex_type_node
;
1789 m2_complex32_type_node
= build_m2_complex32_type_node ();
1790 m2_complex64_type_node
= build_m2_complex64_type_node ();
1791 m2_complex96_type_node
= build_m2_complex96_type_node ();
1792 m2_complex128_type_node
= build_m2_complex128_type_node ();
1793 m2_iso_loc_type_node
= build_m2_iso_loc_node ();
1795 m2_cardinal_address_type_node
1796 = build_m2_cardinal_address_type_node (location
);
1798 m2_packed_boolean_type_node
= build_nonstandard_integer_type (1, true);
1799 build_m2_boolean (location
);
1801 if (M2Options_GetPPOnly ())
1804 m2builtins_init (location
);
1805 m2except_InitExceptions (location
);
1806 m2expr_init (location
);
1809 /* BuildStartType given a, type, with a, name, return a GCC
1810 declaration of this type. TYPE name = foo ;
1812 the type, foo, maybe a partially created type (which has
1813 yet to be 'gm2_finish_decl'ed). */
1816 m2type_BuildStartType (location_t location
, char *name
, tree type
)
1818 tree id
= get_identifier (name
);
1821 m2assert_AssertLocation (location
);
1822 ASSERT (m2tree_is_type (type
), type
);
1823 type
= m2tree_skip_type_decl (type
);
1824 decl
= build_decl (location
, TYPE_DECL
, id
, type
);
1826 tem
= m2block_pushDecl (decl
);
1827 ASSERT (tem
== decl
, decl
);
1828 ASSERT (m2tree_is_type (decl
), decl
);
1833 /* BuildEndType finish declaring, type, and return, type. */
1836 m2type_BuildEndType (location_t location
, tree type
)
1838 m2assert_AssertLocation (location
);
1839 layout_type (TREE_TYPE (type
));
1840 gm2_finish_decl (location
, type
);
1844 /* DeclareKnownType given a, type, with a, name, return a GCC
1845 declaration of this type. TYPE name = foo ; */
1848 m2type_DeclareKnownType (location_t location
, char *name
, tree type
)
1850 m2assert_AssertLocation (location
);
1851 return m2type_BuildEndType (location
,
1852 m2type_BuildStartType (location
, name
, type
));
1855 /* GetDefaultType given a, type, with a, name, return a GCC
1856 declaration of this type. Checks to see whether the type name has
1857 already been declared as a default type and if so it returns this
1858 declaration. Otherwise it declares the type. In Modula-2 this is
1863 We need this function during gm2 initialization as it allows
1864 gm2 to access default types before creating Modula-2 types. */
1867 m2type_GetDefaultType (location_t location
, char *name
, tree type
)
1869 tree id
= maybe_get_identifier (name
);
1871 m2assert_AssertLocation (location
);
1877 while (prev
!= NULL
)
1879 if (TYPE_NAME (prev
) == NULL
)
1880 TYPE_NAME (prev
) = get_identifier (name
);
1881 prev
= TREE_TYPE (prev
);
1883 t
= m2type_DeclareKnownType (location
, name
, type
);
1891 do_min_real (tree type
)
1895 enum machine_mode mode
= TYPE_MODE (type
);
1897 get_max_float (REAL_MODE_FORMAT (mode
), buf
, sizeof (buf
), false);
1898 real_from_string (&r
, buf
);
1899 return build1 (NEGATE_EXPR
, type
, build_real (type
, r
));
1902 /* GetMinFrom given a, type, return a constant representing the
1903 minimum legal value. */
1906 m2type_GetMinFrom (location_t location
, tree type
)
1908 m2assert_AssertLocation (location
);
1910 if (type
== m2_real_type_node
|| type
== m2type_GetRealType ())
1911 return do_min_real (type
);
1912 if (type
== m2_long_real_type_node
|| type
== m2type_GetLongRealType ())
1913 return do_min_real (type
);
1914 if (type
== m2_short_real_type_node
|| type
== m2type_GetShortRealType ())
1915 return do_min_real (type
);
1916 if (type
== ptr_type_node
)
1917 return m2expr_GetPointerZero (location
);
1919 return TYPE_MIN_VALUE (m2tree_skip_type_decl (type
));
1923 do_max_real (tree type
)
1927 enum machine_mode mode
= TYPE_MODE (type
);
1929 get_max_float (REAL_MODE_FORMAT (mode
), buf
, sizeof (buf
), false);
1930 real_from_string (&r
, buf
);
1931 return build_real (type
, r
);
1934 /* GetMaxFrom given a, type, return a constant representing the
1935 maximum legal value. */
1938 m2type_GetMaxFrom (location_t location
, tree type
)
1940 m2assert_AssertLocation (location
);
1942 if (type
== m2_real_type_node
|| type
== m2type_GetRealType ())
1943 return do_max_real (type
);
1944 if (type
== m2_long_real_type_node
|| type
== m2type_GetLongRealType ())
1945 return do_max_real (type
);
1946 if (type
== m2_short_real_type_node
|| type
== m2type_GetShortRealType ())
1947 return do_max_real (type
);
1948 if (type
== ptr_type_node
)
1949 return fold (m2expr_BuildSub (location
, m2expr_GetPointerZero (location
),
1950 m2expr_GetPointerOne (location
), false));
1952 return TYPE_MAX_VALUE (m2tree_skip_type_decl (type
));
1955 /* BuildTypeDeclaration adds the, type, to the current statement
1959 m2type_BuildTypeDeclaration (location_t location
, tree type
)
1961 enum tree_code code
= TREE_CODE (type
);
1963 m2assert_AssertLocation (location
);
1964 if (code
== TYPE_DECL
|| code
== RECORD_TYPE
|| code
== POINTER_TYPE
)
1966 m2block_pushDecl (build_decl (location
, TYPE_DECL
, NULL
, type
));
1968 else if (code
== VAR_DECL
)
1970 m2type_BuildTypeDeclaration (location
, TREE_TYPE (type
));
1972 build_stmt (location
, DECL_EXPR
,
1973 type
)); /* Is this safe? --fixme--. */
1977 /* Begin compiling the definition of an enumeration type. NAME is
1978 its name (or null if anonymous). Returns the type object, as yet
1979 incomplete. Also records info about it so that build_enumerator may
1980 be used to declare the individual values as they are read. */
1983 gm2_start_enum (location_t location
, tree name
, int ispacked
)
1985 tree enumtype
= make_node (ENUMERAL_TYPE
);
1987 m2assert_AssertLocation (location
);
1988 if (TYPE_VALUES (enumtype
) != 0)
1990 /* This enum is a named one that has been declared already. */
1991 error_at (location
, "redeclaration of enum %qs",
1992 IDENTIFIER_POINTER (name
));
1994 /* Completely replace its old definition. The old enumerators remain
1995 defined, however. */
1996 TYPE_VALUES (enumtype
) = 0;
1999 TYPE_PACKED (enumtype
) = ispacked
;
2000 TREE_TYPE (enumtype
) = m2type_GetIntegerType ();
2002 /* This is required as rest_of_type_compilation will use this field
2003 when called from gm2_finish_enum.
2005 Create a fake NULL-named TYPE_DECL node whose TREE_TYPE will be the
2006 tagged type we just added to the current scope. This fake NULL-named
2007 TYPE_DECL node helps dwarfout.cc to know when it needs to output a
2008 representation of a tagged type, and it also gives us a convenient
2009 place to record the "scope start" address for the tagged type. */
2011 TYPE_STUB_DECL (enumtype
) = m2block_pushDecl (
2012 build_decl (location
, TYPE_DECL
, NULL_TREE
, enumtype
));
2017 /* After processing and defining all the values of an enumeration
2018 type, install their decls in the enumeration type and finish it off.
2019 ENUMTYPE is the type object, VALUES a list of decl-value pairs, and
2020 ATTRIBUTES are the specified attributes. Returns ENUMTYPE. */
2023 gm2_finish_enum (location_t location
, tree enumtype
, tree values
)
2026 tree minnode
= 0, maxnode
= 0;
2030 /* Calculate the maximum value of any enumerator in this type. */
2032 if (values
== error_mark_node
)
2033 minnode
= maxnode
= integer_zero_node
;
2036 minnode
= maxnode
= TREE_VALUE (values
);
2037 for (pair
= TREE_CHAIN (values
); pair
; pair
= TREE_CHAIN (pair
))
2039 tree value
= TREE_VALUE (pair
);
2040 if (tree_int_cst_lt (maxnode
, value
))
2042 if (tree_int_cst_lt (value
, minnode
))
2047 /* Construct the final type of this enumeration. It is the same as
2048 one of the integral types the narrowest one that fits, except that
2049 normally we only go as narrow as int and signed iff any of the
2050 values are negative. */
2051 sign
= (tree_int_cst_sgn (minnode
) >= 0) ? UNSIGNED
: SIGNED
;
2052 precision
= MAX (tree_int_cst_min_precision (minnode
, sign
),
2053 tree_int_cst_min_precision (maxnode
, sign
));
2055 if (precision
> TYPE_PRECISION (integer_type_node
))
2057 warning (0, "enumeration values exceed range of integer");
2058 tem
= long_long_integer_type_node
;
2060 else if (TYPE_PACKED (enumtype
))
2061 tem
= m2type_BuildSmallestTypeRange (location
, minnode
, maxnode
);
2063 tem
= sign
== UNSIGNED
? unsigned_type_node
: integer_type_node
;
2065 TYPE_MIN_VALUE (enumtype
) = TYPE_MIN_VALUE (tem
);
2066 TYPE_MAX_VALUE (enumtype
) = TYPE_MAX_VALUE (tem
);
2067 TYPE_UNSIGNED (enumtype
) = TYPE_UNSIGNED (tem
);
2068 TYPE_SIZE (enumtype
) = 0;
2070 /* If the precision of the type was specific with an attribute and it
2071 was too small, give an error. Otherwise, use it. */
2072 if (TYPE_PRECISION (enumtype
))
2074 if (precision
> TYPE_PRECISION (enumtype
))
2075 error ("specified mode too small for enumerated values");
2078 TYPE_PRECISION (enumtype
) = TYPE_PRECISION (tem
);
2080 layout_type (enumtype
);
2082 if (values
!= error_mark_node
)
2085 /* Change the type of the enumerators to be the enum type. We need
2086 to do this irrespective of the size of the enum, for proper type
2087 checking. Replace the DECL_INITIALs of the enumerators, and the
2088 value slots of the list, with copies that have the enum type; they
2089 cannot be modified in place because they may be shared (e.g.
2090 integer_zero_node) Finally, change the purpose slots to point to the
2091 names of the decls. */
2092 for (pair
= values
; pair
; pair
= TREE_CHAIN (pair
))
2094 tree enu
= TREE_PURPOSE (pair
);
2095 tree ini
= DECL_INITIAL (enu
);
2097 TREE_TYPE (enu
) = enumtype
;
2099 if (TREE_TYPE (ini
) != integer_type_node
)
2100 ini
= convert (enumtype
, ini
);
2102 DECL_INITIAL (enu
) = ini
;
2103 TREE_PURPOSE (pair
) = DECL_NAME (enu
);
2104 TREE_VALUE (pair
) = ini
;
2107 TYPE_VALUES (enumtype
) = values
;
2110 /* Fix up all variant types of this enum type. */
2111 for (tem
= TYPE_MAIN_VARIANT (enumtype
); tem
; tem
= TYPE_NEXT_VARIANT (tem
))
2113 if (tem
== enumtype
)
2115 TYPE_VALUES (tem
) = TYPE_VALUES (enumtype
);
2116 TYPE_MIN_VALUE (tem
) = TYPE_MIN_VALUE (enumtype
);
2117 TYPE_MAX_VALUE (tem
) = TYPE_MAX_VALUE (enumtype
);
2118 TYPE_SIZE (tem
) = TYPE_SIZE (enumtype
);
2119 TYPE_SIZE_UNIT (tem
) = TYPE_SIZE_UNIT (enumtype
);
2120 SET_TYPE_MODE (tem
, TYPE_MODE (enumtype
));
2121 TYPE_PRECISION (tem
) = TYPE_PRECISION (enumtype
);
2122 SET_TYPE_ALIGN (tem
, TYPE_ALIGN (enumtype
));
2123 TYPE_USER_ALIGN (tem
) = TYPE_USER_ALIGN (enumtype
);
2124 TYPE_UNSIGNED (tem
) = TYPE_UNSIGNED (enumtype
);
2125 TYPE_LANG_SPECIFIC (tem
) = TYPE_LANG_SPECIFIC (enumtype
);
2128 /* Finish debugging output for this type. */
2129 rest_of_type_compilation (enumtype
, m2block_toplevel ());
2133 /* BuildStartEnumeration create an enumerated type in gcc. */
2136 m2type_BuildStartEnumeration (location_t location
, char *name
, bool ispacked
)
2140 m2assert_AssertLocation (location
);
2141 if ((name
== NULL
) || (strcmp (name
, "") == 0))
2144 id
= get_identifier (name
);
2146 return gm2_start_enum (location
, id
, ispacked
);
2149 /* BuildEndEnumeration finish building the enumeration, it uses the
2150 enum list, enumvalues, and returns a enumeration type tree. */
2153 m2type_BuildEndEnumeration (location_t location
, tree enumtype
,
2156 tree finished ATTRIBUTE_UNUSED
2157 = gm2_finish_enum (location
, enumtype
, enumvalues
);
2161 /* Build and install a CONST_DECL for one value of the current
2162 enumeration type (one that was begun with start_enum). Return a
2163 tree-list containing the CONST_DECL and its value. Assignment of
2164 sequential values by default is handled here. */
2167 gm2_build_enumerator (location_t location
, tree name
, tree value
)
2171 m2assert_AssertLocation (location
);
2172 /* Remove no-op casts from the value. */
2174 STRIP_TYPE_NOPS (value
);
2176 /* Now create a declaration for the enum value name. */
2178 type
= TREE_TYPE (value
);
2180 decl
= build_decl (location
, CONST_DECL
, name
, type
);
2181 DECL_INITIAL (decl
) = convert (type
, value
);
2182 m2block_pushDecl (decl
);
2184 return tree_cons (decl
, value
, NULL_TREE
);
2187 /* BuildEnumerator build an enumerator and add it to the,
2188 enumvalues, list. It returns a copy of the value. */
2191 m2type_BuildEnumerator (location_t location
, char *name
, tree value
,
2194 tree id
= get_identifier (name
);
2195 tree copy_of_value
= copy_node (value
);
2196 tree gccenum
= gm2_build_enumerator (location
, id
, copy_of_value
);
2198 m2assert_AssertLocation (location
);
2199 /* Choose copy_of_value for enum value. */
2200 *enumvalues
= chainon (gccenum
, *enumvalues
);
2201 return copy_of_value
;
2204 /* BuildPointerType returns a type which is a pointer to, totype. */
2207 m2type_BuildPointerType (tree totype
)
2209 return build_pointer_type (m2tree_skip_type_decl (totype
));
2212 /* BuildConstPointerType returns a type which is a const pointer
2216 m2type_BuildConstPointerType (tree totype
)
2218 tree t
= build_pointer_type (m2tree_skip_type_decl (totype
));
2219 TYPE_READONLY (t
) = true;
2223 /* BuildSetType creates a SET OF [lowval..highval]. */
2226 m2type_BuildSetType (location_t location
, char *name
, tree type
, tree lowval
,
2227 tree highval
, bool ispacked
)
2229 tree range
= build_range_type (m2tree_skip_type_decl (type
),
2230 m2expr_FoldAndStrip (lowval
),
2231 m2expr_FoldAndStrip (highval
));
2233 TYPE_PACKED (range
) = ispacked
;
2234 m2assert_AssertLocation (location
);
2235 return m2type_BuildSetTypeFromSubrange (location
, name
, range
,
2236 m2expr_FoldAndStrip (lowval
),
2237 m2expr_FoldAndStrip (highval
),
2241 /* push_constructor returns a new compound constructor frame. */
2243 static struct struct_constructor
*
2244 push_constructor (void)
2246 struct struct_constructor
*p
= ggc_alloc
<struct_constructor
> ();
2248 p
->level
= top_constructor
;
2249 top_constructor
= p
;
2253 /* pop_constructor throws away the top constructor frame on the
2257 pop_constructor (struct struct_constructor
*p
)
2260 == top_constructor
); /* p should be the top_constructor. */
2261 top_constructor
= top_constructor
->level
;
2264 /* BuildStartSetConstructor starts to create a set constant.
2265 Remember that type is really a record type. */
2268 m2type_BuildStartSetConstructor (tree type
)
2270 struct struct_constructor
*p
= push_constructor ();
2272 type
= m2tree_skip_type_decl (type
);
2274 p
->constructor_type
= type
;
2275 p
->constructor_fields
= TYPE_FIELDS (type
);
2276 p
->constructor_element_list
= NULL_TREE
;
2277 vec_alloc (p
->constructor_elements
, 1);
2281 /* BuildSetConstructorElement adds, value, to the
2282 constructor_element_list. */
2285 m2type_BuildSetConstructorElement (void *p
, tree value
)
2287 struct struct_constructor
*c
= (struct struct_constructor
*)p
;
2289 if (value
== NULL_TREE
)
2291 internal_error ("set type cannot be initialized with a %qs",
2296 if (c
->constructor_fields
== NULL
)
2298 internal_error ("set type does not take another integer value");
2302 c
->constructor_element_list
2303 = tree_cons (c
->constructor_fields
, value
, c
->constructor_element_list
);
2304 c
->constructor_fields
= TREE_CHAIN (c
->constructor_fields
);
2307 /* BuildEndSetConstructor finishes building a set constant. */
2310 m2type_BuildEndSetConstructor (void *p
)
2314 struct struct_constructor
*c
= (struct struct_constructor
*)p
;
2316 for (link
= c
->constructor_element_list
; link
; link
= TREE_CHAIN (link
))
2318 tree field
= TREE_PURPOSE (link
);
2319 DECL_SIZE (field
) = bitsize_int (SET_WORD_SIZE
);
2320 DECL_BIT_FIELD (field
) = 1;
2323 constructor
= build_constructor_from_list (
2324 c
->constructor_type
, nreverse (c
->constructor_element_list
));
2325 TREE_CONSTANT (constructor
) = 1;
2326 TREE_STATIC (constructor
) = 1;
2328 pop_constructor (c
);
2333 /* BuildStartRecordConstructor initializes a record compound
2334 constructor frame. */
2337 m2type_BuildStartRecordConstructor (tree type
)
2339 struct struct_constructor
*p
= push_constructor ();
2341 type
= m2tree_skip_type_decl (type
);
2343 p
->constructor_type
= type
;
2344 p
->constructor_fields
= TYPE_FIELDS (type
);
2345 p
->constructor_element_list
= NULL_TREE
;
2346 vec_alloc (p
->constructor_elements
, 1);
2350 /* BuildEndRecordConstructor returns a tree containing the record
2351 compound literal. */
2354 m2type_BuildEndRecordConstructor (void *p
)
2356 struct struct_constructor
*c
= (struct struct_constructor
*)p
;
2357 tree constructor
= build_constructor_from_list (
2358 c
->constructor_type
, nreverse (c
->constructor_element_list
));
2359 TREE_CONSTANT (constructor
) = 1;
2360 TREE_STATIC (constructor
) = 1;
2362 pop_constructor (c
);
2367 /* BuildRecordConstructorElement adds, value, to the
2368 constructor_element_list. */
2371 m2type_BuildRecordConstructorElement (void *p
, tree value
)
2373 m2type_BuildSetConstructorElement (p
, value
);
2376 /* BuildStartArrayConstructor initializes an array compound
2377 constructor frame. */
2380 m2type_BuildStartArrayConstructor (tree type
)
2382 struct struct_constructor
*p
= push_constructor ();
2384 type
= m2tree_skip_type_decl (type
);
2386 p
->constructor_type
= type
;
2387 p
->constructor_fields
= TREE_TYPE (type
);
2388 p
->constructor_element_list
= NULL_TREE
;
2389 vec_alloc (p
->constructor_elements
, 1);
2393 /* BuildEndArrayConstructor returns a tree containing the array
2394 compound literal. */
2397 m2type_BuildEndArrayConstructor (void *p
)
2399 struct struct_constructor
*c
= (struct struct_constructor
*)p
;
2403 = build_constructor (c
->constructor_type
, c
->constructor_elements
);
2404 TREE_CONSTANT (constructor
) = true;
2405 TREE_STATIC (constructor
) = true;
2407 pop_constructor (c
);
2412 /* BuildArrayConstructorElement adds, value, to the
2413 constructor_element_list. */
2416 m2type_BuildArrayConstructorElement (void *p
, tree value
, tree indice
)
2418 struct struct_constructor
*c
= (struct struct_constructor
*)p
;
2419 constructor_elt celt
;
2421 if (value
== NULL_TREE
)
2423 internal_error ("array cannot be initialized with a %qs", "NULL_TREE");
2427 if (c
->constructor_fields
== NULL_TREE
)
2429 internal_error ("array type must be initialized");
2433 if (c
->constructor_fields
!= TREE_TYPE (value
))
2436 "array element value must be the same type as its declaration");
2440 celt
.index
= indice
;
2442 vec_safe_push (c
->constructor_elements
, celt
);
2445 /* BuildArrayStringConstructor creates an array constructor for,
2446 arrayType, consisting of the character elements defined by, str,
2447 of, length, characters. */
2450 m2type_BuildArrayStringConstructor (location_t location
, tree arrayType
,
2451 tree str
, tree length
)
2456 const char *p
= TREE_STRING_POINTER (str
);
2457 tree type
= m2tree_skip_type_decl (TREE_TYPE (arrayType
));
2458 struct struct_constructor
*c
2459 = (struct struct_constructor
*)m2type_BuildStartArrayConstructor (
2462 int len
= strlen (p
);
2466 m2assert_AssertLocation (location
);
2467 n
= m2expr_GetIntegerZero (location
);
2468 while (m2expr_CompareTrees (n
, length
) < 0)
2471 val
= m2convert_BuildConvert (
2472 location
, type
, m2type_BuildCharConstant (location
, &p
[i
]), false);
2474 val
= m2type_BuildCharConstant (location
, &nul
[0]);
2475 m2type_BuildArrayConstructorElement (c
, val
, n
);
2477 n
= m2expr_BuildAdd (location
, n
, m2expr_GetIntegerOne (location
),
2480 return m2type_BuildEndArrayConstructor (c
);
2483 /* BuildSubrangeType creates a subrange of, type, with, lowval,
2487 m2type_BuildSubrangeType (location_t location
, char *name
, tree type
,
2488 tree lowval
, tree highval
)
2492 m2assert_AssertLocation (location
);
2493 type
= m2tree_skip_type_decl (type
);
2495 lowval
= m2expr_FoldAndStrip (lowval
);
2496 highval
= m2expr_FoldAndStrip (highval
);
2498 if (m2expr_TreeOverflow (lowval
))
2499 error ("low bound for the subrange has overflowed");
2500 if (m2expr_TreeOverflow (highval
))
2501 error ("high bound for the subrange has overflowed");
2503 /* First build a type with the base range. */
2504 range_type
= build_range_type (type
, lowval
, highval
);
2506 TYPE_UNSIGNED (range_type
) = TYPE_UNSIGNED (type
);
2508 /* Then set the actual range. */
2509 SET_TYPE_RM_MIN_VALUE (range_type
, lowval
);
2510 SET_TYPE_RM_MAX_VALUE (range_type
, highval
);
2513 if ((name
!= NULL
) && (strcmp (name
, "") != 0))
2515 /* Declared as TYPE foo = [x..y]; */
2516 range_type
= m2type_DeclareKnownType (location
, name
, range_type
);
2517 layout_type (m2tree_skip_type_decl (range_type
));
2523 /* BuildCharConstantChar creates a character constant given a character, ch. */
2526 m2type_BuildCharConstantChar (location_t location
, char ch
)
2528 tree id
= build_int_cst (char_type_node
, (int) ch
);
2529 id
= m2convert_BuildConvert (location
, m2type_GetM2CharType (), id
, false);
2530 return m2block_RememberConstant (id
);
2533 /* BuildCharConstant creates a character constant given a, string. */
2536 m2type_BuildCharConstant (location_t location
, const char *string
)
2538 return m2type_BuildCharConstantChar (location
, string
[0]);
2541 /* RealToTree convert a real number into a Tree. */
2544 m2type_RealToTree (char *name
)
2547 m2type_GetLongRealType (),
2548 REAL_VALUE_ATOF (name
, TYPE_MODE (m2type_GetLongRealType ())));
2551 /* gm2_start_struct start to create a struct. */
2554 gm2_start_struct (location_t location
, enum tree_code code
, char *name
)
2556 tree s
= make_node (code
);
2559 m2assert_AssertLocation (location
);
2560 if ((name
== NULL
) || (strcmp (name
, "") == 0))
2563 id
= get_identifier (name
);
2565 /* This maybe set true later if necessary. */
2566 TYPE_PACKED (s
) = false;
2568 m2block_pushDecl (build_decl (location
, TYPE_DECL
, id
, s
));
2572 /* BuildStartRecord return a RECORD tree. */
2575 m2type_BuildStartRecord (location_t location
, char *name
)
2577 m2assert_AssertLocation (location
);
2578 return gm2_start_struct (location
, RECORD_TYPE
, name
);
2581 /* BuildStartUnion return a union tree. */
2584 m2type_BuildStartUnion (location_t location
, char *name
)
2586 m2assert_AssertLocation (location
);
2587 return gm2_start_struct (location
, UNION_TYPE
, name
);
2590 /* m2type_BuildStartVarient builds a varient record. It creates a
2591 record field which has a, name, and whose type is a union. */
2594 m2type_BuildStartVarient (location_t location
, char *name
)
2596 tree varient
= m2type_BuildStartUnion (location
, name
);
2597 tree field
= m2type_BuildStartFieldRecord (location
, name
, varient
);
2598 m2assert_AssertLocation (location
);
2602 /* m2type_BuildEndVarient finish the varientField by calling
2603 decl_finish and also finish the type of varientField (which is a
2607 m2type_BuildEndVarient (location_t location
, tree varientField
,
2608 tree varientList
, bool isPacked
)
2610 tree varient
= TREE_TYPE (varientField
);
2611 m2assert_AssertLocation (location
);
2612 varient
= m2type_BuildEndRecord (location
, varient
, varientList
, isPacked
);
2613 gm2_finish_decl (location
, varientField
);
2614 return varientField
;
2617 /* m2type_BuildStartFieldVarient builds a field varient record. It
2618 creates a record field which has a, name, and whose type is a
2622 m2type_BuildStartFieldVarient (location_t location
, char *name
)
2624 tree record
= m2type_BuildStartRecord (location
, name
);
2625 tree field
= m2type_BuildStartFieldRecord (location
, name
, record
);
2626 m2assert_AssertLocation (location
);
2630 /* BuildEndRecord a heavily pruned finish_struct from c-decl.cc. It
2631 sets the context for each field to, t, propagates isPacked
2632 throughout the fields in the structure. */
2635 m2type_BuildEndRecord (location_t location
, tree record
, tree fieldlist
,
2640 m2assert_AssertLocation (location
);
2642 /* If this type was previously laid out as a forward reference, make
2643 sure we lay it out again. */
2645 TYPE_SIZE (record
) = 0;
2647 /* Install struct as DECL_CONTEXT of each field decl. Also process
2648 specified field sizes, found in the DECL_INITIAL, storing 0 there
2649 after the type has been changed to precision equal to its width,
2650 rather than the precision of the specified standard type. (Correct
2651 layout requires the original type to have been preserved until now). */
2653 for (x
= fieldlist
; x
; x
= TREE_CHAIN (x
))
2655 DECL_CONTEXT (x
) = record
;
2657 if (TYPE_PACKED (record
) && TYPE_ALIGN (TREE_TYPE (x
)) > BITS_PER_UNIT
)
2658 DECL_PACKED (x
) = 1;
2662 DECL_PACKED (x
) = 1;
2663 DECL_BIT_FIELD (x
) = 1;
2667 /* Now we have the nearly final fieldlist. Record it, then lay out
2668 the structure or union (including the fields). */
2670 TYPE_FIELDS (record
) = fieldlist
;
2671 layout_type (record
);
2673 /* Now we have the truly final field list. Store it in this type and
2676 for (x
= TYPE_MAIN_VARIANT (record
); x
; x
= TYPE_NEXT_VARIANT (x
))
2678 TYPE_FIELDS (x
) = TYPE_FIELDS (record
);
2679 TYPE_LANG_SPECIFIC (x
) = TYPE_LANG_SPECIFIC (record
);
2680 SET_TYPE_ALIGN (x
, TYPE_ALIGN (record
));
2681 TYPE_USER_ALIGN (x
) = TYPE_USER_ALIGN (record
);
2684 d
= build_decl (location
, TYPE_DECL
, NULL
, record
);
2685 TYPE_STUB_DECL (record
) = d
;
2687 /* Finish debugging output for this type. This must be done after we have
2688 called build_decl. */
2689 rest_of_type_compilation (record
, m2block_toplevel ());
2694 /* m2type_BuildEndFieldVarient finish the varientField by calling
2695 decl_finish and also finish the type of varientField (which is a
2699 m2type_BuildEndFieldVarient (location_t location
, tree varientField
,
2700 tree varientList
, bool isPacked
)
2702 tree record
= TREE_TYPE (varientField
);
2704 m2assert_AssertLocation (location
);
2705 record
= m2type_BuildEndRecord (location
, record
, varientList
, isPacked
);
2706 gm2_finish_decl (location
, varientField
);
2707 return varientField
;
2710 /* m2type_BuildStartFieldRecord starts building a field record. It
2711 returns the field which must be completed by calling
2715 m2type_BuildStartFieldRecord (location_t location
, char *name
, tree type
)
2717 tree field
, declarator
;
2719 m2assert_AssertLocation (location
);
2720 if ((name
== NULL
) || (strcmp (name
, "") == 0))
2721 declarator
= NULL_TREE
;
2723 declarator
= get_identifier (name
);
2725 field
= build_decl (location
, FIELD_DECL
, declarator
,
2726 m2tree_skip_type_decl (type
));
2730 /* Build a record field with name (name maybe NULL), returning the
2731 new field declaration, FIELD_DECL.
2733 This is done during the parsing of the struct declaration. The
2734 FIELD_DECL nodes are chained together and the lot of them are
2735 ultimately passed to `build_struct' to make the RECORD_TYPE node. */
2738 m2type_BuildFieldRecord (location_t location
, char *name
, tree type
)
2740 tree field
= m2type_BuildStartFieldRecord (location
, name
, type
);
2742 m2assert_AssertLocation (location
);
2743 gm2_finish_decl (location
, field
);
2747 /* ChainOn interface so that Modula-2 can also create chains of
2751 m2type_ChainOn (tree t1
, tree t2
)
2753 return chainon (t1
, t2
);
2756 /* ChainOnParamValue adds a list node {{name, str}, value} into the
2760 m2type_ChainOnParamValue (tree list
, tree name
, tree str
, tree value
)
2762 return chainon (list
, build_tree_list (build_tree_list (name
, str
), value
));
2765 /* AddStringToTreeList adds, string, to list. */
2768 m2type_AddStringToTreeList (tree list
, tree string
)
2770 return tree_cons (NULL_TREE
, string
, list
);
2773 /* SetAlignment sets the alignment of a, node, to, align. It
2774 duplicates the, node, and sets the alignment to prevent alignment
2775 effecting behaviour elsewhere. */
2778 m2type_SetAlignment (tree node
, tree align
)
2780 tree type
= NULL_TREE
;
2781 tree decl
= NULL_TREE
;
2782 bool is_type
= false;
2788 is_type
= (TREE_CODE (node
) == TYPE_DECL
);
2789 type
= TREE_TYPE (decl
);
2791 else if (TYPE_P (node
))
2797 if (TREE_CODE (align
) != INTEGER_CST
)
2798 error ("requested alignment is not a constant");
2799 else if ((i
= tree_log2 (align
)) == -1)
2800 error ("requested alignment is not a power of 2");
2801 else if (i
> HOST_BITS_PER_INT
- 2)
2802 error ("requested alignment is too large");
2805 /* If we have a TYPE_DECL, then copy the type, so that we don't
2806 accidentally modify a builtin type. See pushdecl. */
2807 if (decl
&& TREE_TYPE (decl
) != error_mark_node
2808 && DECL_ORIGINAL_TYPE (decl
) == NULL_TREE
)
2810 tree tt
= TREE_TYPE (decl
);
2811 type
= build_variant_type_copy (type
);
2812 DECL_ORIGINAL_TYPE (decl
) = tt
;
2813 TYPE_NAME (type
) = decl
;
2814 TREE_USED (type
) = TREE_USED (decl
);
2815 TREE_TYPE (decl
) = type
;
2818 SET_TYPE_ALIGN (type
, (1 << i
) * BITS_PER_UNIT
);
2819 TYPE_USER_ALIGN (type
) = 1;
2823 SET_DECL_ALIGN (decl
, (1 << i
) * BITS_PER_UNIT
);
2824 DECL_USER_ALIGN (decl
) = 1;
2827 else if (TREE_CODE (decl
) != VAR_DECL
&& TREE_CODE (decl
) != FIELD_DECL
)
2828 error ("alignment may not be specified for %qD", decl
);
2831 SET_DECL_ALIGN (decl
, (1 << i
) * BITS_PER_UNIT
);
2832 DECL_USER_ALIGN (decl
) = 1;
2837 /* SetDeclPacked sets the packed bit in decl TREE, node. It
2838 returns the node. */
2841 m2type_SetDeclPacked (tree node
)
2843 DECL_PACKED (node
) = 1;
2847 /* SetTypePacked sets the packed bit in type TREE, node. It
2848 returns the node. */
2851 m2type_SetTypePacked (tree node
)
2853 TYPE_PACKED (node
) = 1;
2857 /* SetRecordFieldOffset returns field after the byteOffset and
2858 bitOffset has been applied to it. */
2861 m2type_SetRecordFieldOffset (tree field
, tree byteOffset
, tree bitOffset
,
2862 tree fieldtype
, tree nbits
)
2864 DECL_FIELD_OFFSET (field
) = byteOffset
;
2865 DECL_FIELD_BIT_OFFSET (field
) = bitOffset
;
2866 TREE_TYPE (field
) = m2tree_skip_type_decl (fieldtype
);
2867 DECL_SIZE (field
) = bitsize_int (TREE_INT_CST_LOW (nbits
));
2871 /* BuildPackedFieldRecord builds a packed field record of, name,
2875 m2type_BuildPackedFieldRecord (location_t location
, char *name
, tree fieldtype
)
2877 m2assert_AssertLocation (location
);
2878 return m2type_BuildFieldRecord (location
, name
, fieldtype
);
2881 /* BuildNumberOfArrayElements returns the number of elements in an
2885 m2type_BuildNumberOfArrayElements (location_t location
, tree arrayType
)
2887 tree index
= TYPE_DOMAIN (arrayType
);
2888 tree high
= TYPE_MAX_VALUE (index
);
2889 tree low
= TYPE_MIN_VALUE (index
);
2890 tree elements
= m2expr_BuildAdd (
2891 location
, m2expr_BuildSub (location
, high
, low
, false),
2892 m2expr_GetIntegerOne (location
), false);
2893 m2assert_AssertLocation (location
);
2897 /* AddStatement maps onto add_stmt. */
2900 m2type_AddStatement (location_t location
, tree t
)
2903 add_stmt (location
, t
);
2906 /* MarkFunctionReferenced marks a function as referenced. */
2909 m2type_MarkFunctionReferenced (tree f
)
2912 if (TREE_CODE (f
) == FUNCTION_DECL
)
2913 mark_decl_referenced (f
);
2916 /* GarbageCollect force gcc to garbage collect. */
2919 m2type_GarbageCollect (void)
2924 /* gm2_type_for_size return an integer type with BITS bits of
2925 precision, that is unsigned if UNSIGNEDP is nonzero, otherwise
2929 m2type_gm2_type_for_size (unsigned int bits
, bool unsignedp
)
2931 if (bits
== TYPE_PRECISION (integer_type_node
))
2932 return unsignedp
? unsigned_type_node
: integer_type_node
;
2934 if (bits
== TYPE_PRECISION (signed_char_type_node
))
2935 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
2937 if (bits
== TYPE_PRECISION (short_integer_type_node
))
2938 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
2940 if (bits
== TYPE_PRECISION (long_integer_type_node
))
2941 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
2943 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
2944 return (unsignedp
? long_long_unsigned_type_node
2945 : long_long_integer_type_node
);
2947 if (bits
<= TYPE_PRECISION (intQI_type_node
))
2948 return unsignedp
? unsigned_intQI_type_node
: intQI_type_node
;
2950 if (bits
<= TYPE_PRECISION (intHI_type_node
))
2951 return unsignedp
? unsigned_intHI_type_node
: intHI_type_node
;
2953 if (bits
<= TYPE_PRECISION (intSI_type_node
))
2954 return unsignedp
? unsigned_intSI_type_node
: intSI_type_node
;
2956 if (bits
<= TYPE_PRECISION (intDI_type_node
))
2957 return unsignedp
? unsigned_intDI_type_node
: intDI_type_node
;
2962 /* gm2_unsigned_type return an unsigned type the same as TYPE in
2966 m2type_gm2_unsigned_type (tree type
)
2968 tree type1
= TYPE_MAIN_VARIANT (type
);
2969 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
2970 return unsigned_char_type_node
;
2971 if (type1
== integer_type_node
)
2972 return unsigned_type_node
;
2973 if (type1
== short_integer_type_node
)
2974 return short_unsigned_type_node
;
2975 if (type1
== long_integer_type_node
)
2976 return long_unsigned_type_node
;
2977 if (type1
== long_long_integer_type_node
)
2978 return long_long_unsigned_type_node
;
2980 #if HOST_BITS_PER_WIDE_INT >= 64
2981 if (type1
== intTI_type_node
)
2982 return unsigned_intTI_type_node
;
2984 if (type1
== intDI_type_node
)
2985 return unsigned_intDI_type_node
;
2986 if (type1
== intSI_type_node
)
2987 return unsigned_intSI_type_node
;
2988 if (type1
== intHI_type_node
)
2989 return unsigned_intHI_type_node
;
2990 if (type1
== intQI_type_node
)
2991 return unsigned_intQI_type_node
;
2993 return m2type_gm2_signed_or_unsigned_type (true, type
);
2996 /* gm2_signed_type return a signed type the same as TYPE in other
3000 m2type_gm2_signed_type (tree type
)
3002 tree type1
= TYPE_MAIN_VARIANT (type
);
3003 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
3004 return signed_char_type_node
;
3005 if (type1
== unsigned_type_node
)
3006 return integer_type_node
;
3007 if (type1
== short_unsigned_type_node
)
3008 return short_integer_type_node
;
3009 if (type1
== long_unsigned_type_node
)
3010 return long_integer_type_node
;
3011 if (type1
== long_long_unsigned_type_node
)
3012 return long_long_integer_type_node
;
3014 #if HOST_BITS_PER_WIDE_INT >= 64
3015 if (type1
== unsigned_intTI_type_node
)
3016 return intTI_type_node
;
3018 if (type1
== unsigned_intDI_type_node
)
3019 return intDI_type_node
;
3020 if (type1
== unsigned_intSI_type_node
)
3021 return intSI_type_node
;
3022 if (type1
== unsigned_intHI_type_node
)
3023 return intHI_type_node
;
3024 if (type1
== unsigned_intQI_type_node
)
3025 return intQI_type_node
;
3027 return m2type_gm2_signed_or_unsigned_type (false, type
);
3030 /* check_type if the precision of baseType and type are the same
3031 then return true and set the signed or unsigned type in result
3032 else return false. */
3035 check_type (tree baseType
, tree type
, int unsignedp
, tree baseu
, tree bases
,
3038 if (TYPE_PRECISION (baseType
) == TYPE_PRECISION (type
))
3049 /* gm2_signed_or_unsigned_type return a type the same as TYPE
3050 except unsigned or signed according to UNSIGNEDP. */
3053 m2type_gm2_signed_or_unsigned_type (int unsignedp
, tree type
)
3057 if (!INTEGRAL_TYPE_P (type
) || TYPE_UNSIGNED (type
) == unsignedp
)
3060 /* For INTEGER_TYPEs we must check the precision as well, so as to
3061 yield correct results for bit-field types. */
3063 if (check_type (signed_char_type_node
, type
, unsignedp
,
3064 unsigned_char_type_node
, signed_char_type_node
, &result
))
3066 if (check_type (integer_type_node
, type
, unsignedp
, unsigned_type_node
,
3067 integer_type_node
, &result
))
3069 if (check_type (short_integer_type_node
, type
, unsignedp
,
3070 short_unsigned_type_node
, short_integer_type_node
, &result
))
3072 if (check_type (long_integer_type_node
, type
, unsignedp
,
3073 long_unsigned_type_node
, long_integer_type_node
, &result
))
3075 if (check_type (long_long_integer_type_node
, type
, unsignedp
,
3076 long_long_unsigned_type_node
, long_long_integer_type_node
,
3080 #if HOST_BITS_PER_WIDE_INT >= 64
3081 if (check_type (intTI_type_node
, type
, unsignedp
, unsigned_intTI_type_node
,
3082 intTI_type_node
, &result
))
3085 if (check_type (intDI_type_node
, type
, unsignedp
, unsigned_intDI_type_node
,
3086 intDI_type_node
, &result
))
3088 if (check_type (intSI_type_node
, type
, unsignedp
, unsigned_intSI_type_node
,
3089 intSI_type_node
, &result
))
3091 if (check_type (intHI_type_node
, type
, unsignedp
, unsigned_intHI_type_node
,
3092 intHI_type_node
, &result
))
3094 if (check_type (intQI_type_node
, type
, unsignedp
, unsigned_intQI_type_node
,
3095 intQI_type_node
, &result
))
3102 /* IsAddress returns true if the type is an ADDRESS. */
3105 m2type_IsAddress (tree type
)
3107 return type
== ptr_type_node
;
3110 #include "gt-m2-m2type.h"