-- Assertions in this package are too slow, and are mostly needed when working
-- on this package itself, or on gen_il, so we disable them.
--- To debug low-level bugs in this area, comment out the following pragmas,
+-- To debug low-level bugs in this area, comment out the following pragma,
-- and run with -gnatd_v.
pragma Assertion_Policy (Ignore);
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
is
function Get_Field is new Get_32_Bit_Field (Field_Type) with Inline;
+ Result : Field_Type;
begin
-- If the field has not yet been set, it will be equal to zero.
-- That is of the "wrong" type, so we fetch it as a
-- Field_Size_32_Bit.
if Get_32_Bit_Val (N, Offset) = 0 then
- return Default_Val;
+ Result := Default_Val;
else
- return Get_Field (N, Offset);
+ Result := Get_Field (N, Offset);
end if;
+
+ return Result;
end Get_32_Bit_Field_With_Default;
+ function Get_Valid_32_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ is
+ pragma Assert (Get_32_Bit_Val (N, Offset) /= 0);
+ -- If the field has not yet been set, it will be equal to zero.
+ -- This asserts that we don't call Get_ before Set_. Note that
+ -- the predicate on the Val parameter of Set_ checks for the No_...
+ -- value, so it can't possibly be (for example) No_Uint here.
+
+ function Get_Field is new Get_32_Bit_Field (Field_Type) with Inline;
+ Result : constant Field_Type := Get_Field (N, Offset);
+ begin
+ return Result;
+ end Get_Valid_32_Bit_Field;
+
procedure Set_1_Bit_Field
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
is
with Inline;
-- If the field has not yet been set, return Default_Val
+ generic
+ type Field_Type is private;
+ function Get_Valid_32_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ with Inline;
+ -- Assert that the field has already been set. This is currently used
+ -- only for Uints, but could be used more generally.
+
generic
type Field_Type is private;
procedure Set_1_Bit_Field
INLINE unsigned int Get_32_Bit_Field (Node_Id, Field_Offset);
INLINE unsigned int Get_32_Bit_Field_With_Default (Node_Id, Field_Offset,
unsigned int);
+INLINE unsigned int Get_Valid_32_Bit_Field (Node_Id, Field_Offset);
INLINE unsigned int
Get_1_Bit_Field (Node_Id N, Field_Offset Offset)
return slot == Empty ? Default_Value : slot;
}
+INLINE unsigned int
+Get_Valid_32_Bit_Field (Node_Id N, Field_Offset Offset)
+{
+ any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
+ gcc_assert (slot != Empty);
+ return slot;
+}
+
#ifdef __cplusplus
}
#endif
procedure Init_Alignment (Id : E) is
begin
- Set_Alignment (Id, Uint_0);
+ Reinit_Field_To_Zero (Id, F_Alignment);
end Init_Alignment;
procedure Init_Alignment (Id : E; V : Int) is
Set_RM_Size (Id, UI_From_Int (V));
end Init_RM_Size;
+ procedure Copy_Alignment (To, From : E) is
+ begin
+ if Known_Alignment (From) then
+ Set_Alignment (To, Alignment (From));
+ else
+ Init_Alignment (To);
+ end if;
+ end Copy_Alignment;
+
-----------------------------
-- Init_Component_Location --
-----------------------------
procedure Init_Object_Size_Align (Id : E) is
begin
- Set_Esize (Id, Uint_0);
- Set_Alignment (Id, Uint_0);
+ Init_Esize (Id);
+ Init_Alignment (Id);
end Init_Object_Size_Align;
---------------
procedure Init_Size_Align (Id : E) is
begin
pragma Assert (Ekind (Id) in Type_Kind | E_Void);
- Set_Esize (Id, Uint_0);
- Set_RM_Size (Id, Uint_0);
- Set_Alignment (Id, Uint_0);
+ Init_Esize (Id);
+ Init_RM_Size (Id);
+ Init_Alignment (Id);
end Init_Size_Align;
----------------------------------------------
----------------------------------------------
function Known_Alignment (E : Entity_Id) return B is
+ Result : constant B := not Field_Is_Initial_Zero (E, F_Alignment);
begin
- return Alignment (E) /= Uint_0
- and then Alignment (E) /= No_Uint;
+ return Result;
end Known_Alignment;
function Known_Component_Bit_Offset (E : Entity_Id) return B is
procedure Init_Normalized_Position_Max (Id : E);
procedure Init_RM_Size (Id : E);
+ -- The following Copy_xxx procedures copy the value of xxx from From to
+ -- To. If xxx is set to its initial invalid (zero-bits) value, then it is
+ -- reset to invalid in To. We only have Copy_Alignment so far, but more are
+ -- planned.
+
+ procedure Copy_Alignment (To, From : E);
+
pragma Inline (Init_Alignment);
pragma Inline (Init_Component_Bit_Offset);
pragma Inline (Init_Component_Size);
-- within an accept statement. For all remaining cases (discriminants,
-- loop parameters) the field is Empty.
--- Renaming_Map
--- Defined in generic subprograms, generic packages, and their
--- instances. Also defined in the instances of the corresponding
--- bodies. Denotes the renaming map (generic entities => instance
--- entities) used to construct the instance by giving an index into
--- the tables used to represent these maps. See Sem_Ch12 for further
--- details. The maps for package instances are also used when the
--- instance is the actual corresponding to a formal package.
-
-- Requires_Overriding
-- Defined in all subprograms and entries. Set for subprograms that
-- require overriding as defined by RM-2005-3.9.3(6/2). Note that this
-- E_Function
-- E_Generic_Function
-- Mechanism (Mechanism_Type)
- -- Renaming_Map
-- Handler_Records (non-generic case only)
-- Protected_Body_Subprogram
-- Next_Inlined_Subprogram
-- E_Package
-- E_Generic_Package
-- Dependent_Instances (for an instance)
- -- Renaming_Map
-- Handler_Records (non-generic case only)
-- Generic_Homonym (generic case only)
-- Associated_Formal_Package
-- E_Procedure
-- E_Generic_Procedure
-- Associated_Node_For_Itype $$$ E_Procedure
- -- Renaming_Map
-- Handler_Records (non-generic case only)
-- Protected_Body_Subprogram
-- Next_Inlined_Subprogram
-- type or component, take it into account.
if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0
- or else Alignment (Typ) = 1
+ or else (Known_Alignment (Typ) and then Alignment (Typ) = 1)
or else Component_Alignment (Typ) = Calign_Storage_Unit
then
if Reverse_Storage_Order (Typ) then
end if;
elsif Csize mod 4 /= 0
- or else Alignment (Typ) = 2
+ or else (Known_Alignment (Typ) and then Alignment (Typ) = 2)
then
if Reverse_Storage_Order (Typ) then
PB_Type := RTE (RE_Rev_Packed_Bytes2);
#define Known_Static_RM_Size einfo__utils__known_static_rm_size
B Known_Static_RM_Size (Entity_Id E);
+#define Copy_Alignment einfo__utils__copy_alignment
+B Copy_Alignment(Entity_Id To, Entity_Id From);
+
#define Is_Discrete_Or_Fixed_Point_Type einfo__utils__is_discrete_or_fixed_point_type
B Is_Discrete_Or_Fixed_Point_Type (E Id);
-- cases of types whose alignment exceeds their size (the
-- padded type cases).
- if Csiz /= 0 then
+ if Csiz /= 0 and then Known_Alignment (Ctyp) then
declare
A : constant Uint := Alignment_In_Bits (Ctyp);
begin
-- Processing that is done only for subtypes
else
- -- Acquire alignment from base type
+ -- Acquire alignment from base type. Known_Alignment of the base
+ -- type is False for Wide_String, for example.
- if not Known_Alignment (Arr) then
+ if not Known_Alignment (Arr)
+ and then Known_Alignment (Base_Type (Arr))
+ then
Set_Alignment (Arr, Alignment (Base_Type (Arr)));
Adjust_Esize_Alignment (Arr);
end if;
end if;
if not Has_Alignment_Clause (Arr) then
- Set_Alignment (Arr, Alignment (Packed_Array_Impl_Type (Arr)));
+ Copy_Alignment
+ (To => Arr, From => Packed_Array_Impl_Type (Arr));
end if;
end if;
const bool derived_p = Is_Derived_Type (gnat_entity);
const Entity_Id gnat_parent
= derived_p ? Etype (Base_Type (gnat_entity)) : Empty;
+ /* The following test for Known_Alignment preserves the old behavior,
+ but is probably wrong. */
const unsigned int inherited_align
= derived_p
- ? UI_To_Int (Alignment (gnat_parent)) * BITS_PER_UNIT
+ ? (Known_Alignment (gnat_parent)
+ ? UI_To_Int (Alignment (gnat_parent)) * BITS_PER_UNIT
+ : 0)
: POINTER_SIZE;
const unsigned int align
= MAX (TYPE_ALIGN (gnu_type), inherited_align);
&& Present (gnat_annotate_type))
{
if (!Known_Alignment (gnat_entity))
- Set_Alignment (gnat_entity, Alignment (gnat_annotate_type));
+ Copy_Alignment (gnat_entity, gnat_annotate_type);
if (!Known_Esize (gnat_entity))
Set_Esize (gnat_entity, Esize (gnat_annotate_type));
if (!Known_RM_Size (gnat_entity))
/* Propagate back-annotations from full view to partial view. */
if (!Known_Alignment (gnat_entity))
- Set_Alignment (gnat_entity, Alignment (full_view));
+ Copy_Alignment (gnat_entity, full_view);
if (!Known_Esize (gnat_entity))
Set_Esize (gnat_entity, Esize (full_view));
Relative_Deadline_Variable,
Renamed_In_Spec,
Renamed_Or_Alias, -- Shared among Alias, Renamed_Entity, Renamed_Object
- Renaming_Map,
Requires_Overriding,
Return_Applies_To,
Return_Present,
-- dummy type for the return type of a procedure (the reason we create
-- this type is to share the circuits for performing overload
-- resolution on calls).
- (Sm (Alignment, Uint),
+ (Sm (Alignment, Unat),
Sm (Contract, Node_Id),
Sm (Is_Elaboration_Warnings_OK_Id, Flag),
Sm (Original_Record_Component, Node_Id),
Sm (Debug_Renaming_Link, Node_Id),
Sm (Discriminal_Link, Node_Id),
Sm (Discriminant_Default_Value, Node_Id),
- Sm (Discriminant_Number, Uint),
+ Sm (Discriminant_Number, Upos),
Sm (Enclosing_Scope, Node_Id),
Sm (Entry_Bodies_Array, Node_Id,
Pre => "Has_Entries (N)"),
Sm (Last_Entity, Node_Id),
Sm (Next_Inlined_Subprogram, Node_Id),
Sm (Renamed_Or_Alias, Node_Id), -- See Einfo.Utils
- Sm (Renaming_Map, Uint),
Sm (Return_Applies_To, Node_Id),
Sm (Scalar_Range, Node_Id),
Sm (Scale_Value, Uint),
Ab (Allocatable_Kind, Object_Kind,
(Sm (Activation_Record_Component, Node_Id),
- Sm (Alignment, Uint),
+ Sm (Alignment, Unat),
Sm (Esize, Uint),
Sm (Interface_Name, Node_Id),
Sm (Is_Finalized_Transient, Flag),
Sm (CR_Discriminant, Node_Id),
Sm (Discriminal, Node_Id),
Sm (Discriminant_Default_Value, Node_Id),
- Sm (Discriminant_Number, Uint),
+ Sm (Discriminant_Number, Upos),
Sm (Is_Completely_Hidden, Flag)));
Cc (E_Loop_Parameter, Allocatable_Kind);
-- Formal parameters are also objects
(Sm (Activation_Record_Component, Node_Id),
Sm (Actual_Subtype, Node_Id),
- Sm (Alignment, Uint),
+ Sm (Alignment, Unat),
Sm (Default_Expr_Function, Node_Id),
Sm (Default_Value, Node_Id),
Sm (Entry_Component, Node_Id),
-- Named numbers created by a number declaration with a real value
Ab (Type_Kind, Void_Or_Type_Kind,
- (Sm (Alignment, Uint),
+ (Sm (Alignment, Unat),
Sm (Associated_Node_For_Itype, Node_Id),
Sm (Can_Use_Internal_Rep, Flag, Base_Type_Only,
Pre => "Ekind (Base_Type (N)) in Access_Subprogram_Kind"),
Cc (E_String_Literal_Subtype, Array_Kind,
-- A special string subtype, used only to describe the type of a string
-- literal (will always be one dimensional, with literal bounds).
- (Sm (String_Literal_Length, Uint),
+ (Sm (String_Literal_Length, Unat),
Sm (String_Literal_Low_Bound, Node_Id)));
Ab (Class_Wide_Kind, Aggregate_Kind,
Cc (E_Enumeration_Literal, Overloadable_Kind,
-- An enumeration literal, created by the use of the literal in an
-- enumeration type definition.
- (Sm (Enumeration_Pos, Uint),
- Sm (Enumeration_Rep, Uint),
+ (Sm (Enumeration_Pos, Unat),
+ Sm (Enumeration_Rep, Valid_Uint),
Sm (Enumeration_Rep_Expr, Node_Id),
Sm (Esize, Uint),
- Sm (Alignment, Uint),
+ Sm (Alignment, Unat),
Sm (Interface_Name, Node_Id)));
Ab (Subprogram_Kind, Overloadable_Kind,
Sm (Protected_Subprogram, Node_Id),
Sm (Protection_Object, Node_Id),
Sm (Related_Expression, Node_Id),
- Sm (Renaming_Map, Uint),
Sm (Rewritten_For_C, Flag),
Sm (Thunk_Entity, Node_Id,
Pre => "Is_Thunk (N)"),
Sm (Protected_Subprogram, Node_Id),
Sm (Protection_Object, Node_Id),
Sm (Receiving_Entry, Node_Id),
- Sm (Renaming_Map, Uint),
Sm (Static_Initialization, Node_Id,
Pre => "not Is_Dispatching_Operation (N)"),
Sm (Thunk_Entity, Node_Id,
-- An exception created by an exception declaration. The exception
-- itself uses E_Exception for the Ekind, the implicit type that is
-- created to represent its type uses the Ekind E_Exception_Type.
- (Sm (Alignment, Uint),
+ (Sm (Alignment, Unat),
Sm (Esize, Uint),
Sm (Interface_Name, Node_Id),
Sm (Is_Raised, Flag),
Sm (Is_Elaboration_Warnings_OK_Id, Flag),
Sm (Last_Entity, Node_Id),
Sm (Renamed_Or_Alias, Node_Id),
- Sm (Renaming_Map, Uint),
Sm (Scope_Depth_Value, Uint),
Sm (SPARK_Pragma, Node_Id),
Sm (SPARK_Pragma_Inherited, Flag)));
Sm (Related_Instance, Node_Id),
Sm (Renamed_In_Spec, Flag),
Sm (Renamed_Or_Alias, Node_Id),
- Sm (Renaming_Map, Uint),
Sm (Scope_Depth_Value, Uint),
Sm (SPARK_Aux_Pragma, Node_Id),
Sm (SPARK_Aux_Pragma_Inherited, Flag),
Cc (N_Character_Literal, N_Direct_Name,
(Sy (Chars, Name_Id, Default_No_Name),
- Sy (Char_Literal_Value, Uint)));
+ Sy (Char_Literal_Value, Unat)));
Ab (N_Op, N_Has_Entity,
(Sm (Do_Overflow_Check, Flag),
Cc (N_Raise_Constraint_Error, N_Raise_xxx_Error,
(Sy (Condition, Node_Id, Default_Empty),
- Sy (Reason, Uint)));
+ Sy (Reason, Unat)));
Cc (N_Raise_Program_Error, N_Raise_xxx_Error,
(Sy (Condition, Node_Id, Default_Empty),
- Sy (Reason, Uint)));
+ Sy (Reason, Unat)));
Cc (N_Raise_Storage_Error, N_Raise_xxx_Error,
(Sy (Condition, Node_Id, Default_Empty),
- Sy (Reason, Uint)));
+ Sy (Reason, Unat)));
Ab (N_Numeric_Or_String_Literal, N_Subexpr);
Cc (N_Integer_Literal, N_Numeric_Or_String_Literal,
- (Sy (Intval, Uint),
+ (Sy (Intval, Valid_Uint),
Sm (Original_Entity, Node_Id),
Sm (Print_In_Hex, Flag)));
Cc (N_Real_Literal, N_Numeric_Or_String_Literal,
(Sy (Realval, Ureal),
- Sm (Corresponding_Integer_Value, Uint),
+ Sm (Corresponding_Integer_Value, Valid_Uint),
Sm (Is_Machine_Number, Flag),
Sm (Original_Entity, Node_Id)));
| Name_Id
| String_Id
| Uint
+ | Uint_Subtype
| Ureal
| Source_Ptr
| Union_Id
(S : in out Sink; T : Type_Enum)
is
begin
- -- Special case for types that have defaults; instantiate
- -- Get_32_Bit_Field_With_Default and pass in the Default_Val.
+ -- Special case for subtypes of Uint that have predicates. Use
+ -- Get_Valid_32_Bit_Field in that case.
- if T in Elist_Id | Uint then
+ if T in Uint_Subtype then
pragma Assert (Field_Size (T) = 32);
+ Put (S, LF & "function " & Low_Level_Getter_Name (T) &
+ " is new Get_Valid_32_Bit_Field (" &
+ Get_Set_Id_Image (T) &
+ ") with " & Inline & ";" & LF);
- declare
- Default_Val : constant String :=
- (if T = Elist_Id then "No_Elist" else "Uint_0");
+ -- Special case for types that have special defaults; instantiate
+ -- Get_32_Bit_Field_With_Default and pass in the Default_Val.
- begin
- Put (S, LF & "function " & Low_Level_Getter_Name (T) &
- " is new Get_32_Bit_Field_With_Default (" &
- Get_Set_Id_Image (T) & ", " & Default_Val &
- ") with " & Inline & ";" & LF);
- end;
+ elsif Field_Has_Special_Default (T) then
+ pragma Assert (Field_Size (T) = 32);
+ Put (S, LF & "function " & Low_Level_Getter_Name (T) &
+ " is new Get_32_Bit_Field_With_Default (" &
+ Get_Set_Id_Image (T) & ", " & Special_Default (T) &
+ ") with " & Inline & ";" & LF);
-- Otherwise, instantiate the normal getter for the right size in
-- bits.
Get_Set_Id_Image (T) & ") with " & Inline & ";" & LF);
end if;
- -- No special case for the setter
-
if T in Node_Kind_Type | Entity_Kind_Type then
Put (S, "pragma Warnings (Off);" & LF);
-- Set_Node_Kind_Type and Set_Entity_Kind_Type might not be called
end if;
+ -- No special cases for the setter
+
Put (S, "procedure " & Low_Level_Setter_Name (T) & " is new Set_" &
- Image (Field_Size (T)) & "_Bit_Field (" & Get_Set_Id_Image (T) &
- ") with " & Inline & ";" & LF);
+ Image (Field_Size (T)) & "_Bit_Field (" & Get_Set_Id_Image (T) &
+ ") with " & Inline & ";" & LF);
if T in Node_Kind_Type | Entity_Kind_Type then
Put (S, "pragma Warnings (On);" & LF);
procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum) is
begin
- Put (S, "function " & Image (F) & LF);
- Increase_Indent (S, 2);
- Put (S, "(N : " & N_Type (F) & ") return " &
+ Put (S, "function " & Image (F));
+ Put (S, " (N : " & N_Type (F) & ") return " &
Get_Set_Id_Image (Field_Table (F).Field_Type));
- Decrease_Indent (S, 2);
end Put_Getter_Spec;
---------------------
Default : constant String :=
(if Rec.Field_Type = Flag then " := True" else "");
begin
- Put (S, "procedure Set_" & Image (F) & LF);
- Increase_Indent (S, 2);
- Put (S, "(N : " & N_Type (F) & "; Val : " &
+ Put (S, "procedure Set_" & Image (F));
+ Put (S, " (N : " & N_Type (F) & "; Val : " &
Get_Set_Id_Image (Rec.Field_Type) & Default & ")");
- Decrease_Indent (S, 2);
end Put_Setter_Spec;
---------------------
Put (S, "-- This package is not used by the compiler." & LF);
Put (S, "-- The body contains tables that are intended to be used by humans to" & LF);
- Put (S, "-- help understand the layout of various data structures." & LF & LF);
+ Put (S, "-- help understand the layout of various data structures." & LF);
+ Put (S, "-- Search for ""--"" to find major sections of code." & LF & LF);
Put (S, "pragma Elaborate_Body;" & LF);
Increase_Indent (S, 3);
- -- Same special case as in Put_Low_Level_Accessor_Instantiations
+ -- Same special cases for getters as in
+ -- Put_Low_Level_Accessor_Instantiations.
- if T in Elist_Id | Uint then
+ if T in Uint_Subtype then
pragma Assert (Field_Size (T) = 32);
+ Put (S, "{ return (" & T_Image &
+ ") Get_Valid_32_Bit_Field(N, Offset); }" & LF & LF);
- declare
- Default_Val : constant String :=
- (if T = Elist_Id then "No_Elist" else "Uint_0");
-
- begin
- Put (S, "{ return (" & T_Image &
- ") Get_32_Bit_Field_With_Default(N, Offset, " &
- Default_Val & "); }" & LF & LF);
- end;
+ elsif Field_Has_Special_Default (T) then
+ pragma Assert (Field_Size (T) = 32);
+ Put (S, "{ return (" & T_Image &
+ ") Get_32_Bit_Field_With_Default(N, Offset, " &
+ Special_Default (T) & "); }" & LF & LF);
else
Put (S, "{ return (" & T_Image & ") Get_" &
-- Table mapping from enumeration literals representing fields to
-- information about the field.
+ -- Getters for fields of types Elist_Id and Uint need special treatment of
+ -- defaults. In particular, if the field has its initial 0 value, getters
+ -- need to return the appropriate default value. Note that these defaults
+ -- have nothing to do with the defaults mentioned above for Nmake
+ -- functions.
+
+ function Field_Has_Special_Default
+ (Field_Type : Type_Enum) return Boolean is
+ (Field_Type in Elist_Id | Uint);
+ -- These are the field types that have a default value that is not
+ -- represented as zero.
+
+ function Special_Default
+ (Field_Type : Type_Enum) return String is
+ (if Field_Type = Elist_Id then "No_Elist" else "Uint_0");
+
+ function Invalid_Val
+ (Field_Type : Uint_Subtype) return String is
+ ("No_Uint");
+ -- We could generalize this to other than Uint at some point
+
----------------
subtype Node_Field is
Name_Id,
String_Id,
Uint,
+ Valid_Uint,
+ Unat,
+ Upos,
+ Nonzero_Uint,
Ureal,
Node_Kind_Type, -- Type of result of Nkind function, i.e. Node_Kind
| N_Defining_Operator_Symbol;
subtype Opt_Abstract_Type is Opt_Type_Enum with
- Predicate => Opt_Abstract_Type = No_Type or
- Opt_Abstract_Type in Abstract_Type;
+ Predicate => Opt_Abstract_Type = No_Type or
+ Opt_Abstract_Type in Abstract_Type;
subtype Type_Boundaries is Type_Enum with
- Predicate => Type_Boundaries in
- Between_Abstract_Node_And_Abstract_Entity_Types |
- Between_Abstract_Entity_And_Concrete_Node_Types |
- Between_Concrete_Node_And_Concrete_Entity_Types;
+ Predicate => Type_Boundaries in
+ Between_Abstract_Node_And_Abstract_Entity_Types |
+ Between_Abstract_Entity_And_Concrete_Node_Types |
+ Between_Concrete_Node_And_Concrete_Entity_Types;
-- These are not used, other than to separate the various subranges.
+ subtype Uint_Subtype is Type_Enum with
+ Predicate => Uint_Subtype in Valid_Uint | Unat | Upos | Nonzero_Uint;
+
end Gen_IL.Types;
Set_RM_Size (E, RM_Size (PAT));
end if;
- if not Known_Alignment (E) then
+ if not Known_Alignment (E) and then Known_Alignment (PAT) then
Set_Alignment (E, Alignment (PAT));
end if;
end;
end if;
end if;
- if List_Representation_Info_To_JSON then
- Write_Str (" ""Alignment"": ");
- Write_Val (Alignment (Ent));
+ if Known_Alignment (Ent) then
+ if List_Representation_Info_To_JSON then
+ Write_Str (" ""Alignment"": ");
+ Write_Val (Alignment (Ent));
+ else
+ Write_Str ("for ");
+ List_Name (Ent);
+ Write_Str ("'Alignment use ");
+ Write_Val (Alignment (Ent));
+ Write_Line (";");
+ end if;
+
+ -- Alignment is not always set for task and protected types
+
else
- Write_Str ("for ");
- List_Name (Ent);
- Write_Str ("'Alignment use ");
- Write_Val (Alignment (Ent));
- Write_Line (";");
+ pragma Assert
+ (Is_Concurrent_Type (Ent) or else Is_Class_Wide_Type (Ent));
end if;
end List_Common_Type_Info;
-- scanned literal.
Real_Literal_Value : Ureal;
- -- Valid only when Token is Tok_Real_Literal, contains the value of the
+ -- Valid only when Token is Tok_Real_Literal. Contains the value of the
-- scanned literal.
Int_Literal_Value : Uint;
- -- Valid only when Token = Tok_Integer_Literal, contains the value of the
- -- scanned literal.
+ -- Valid only when Token = Tok_Integer_Literal, and we are not in
+ -- syntax-only mode. Contains the value of the scanned literal.
Based_Literal_Uses_Colon : Boolean;
-- Valid only when Token = Tok_Integer_Literal or Tok_Real_Literal. Set
when Tok_Integer_Literal =>
Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
- Set_Intval (Token_Node, Int_Literal_Value);
+
+ -- Int_Literal_Value can be No_Uint in some cases in syntax-only
+ -- mode (see Scng.Scan.Nlit).
+
+ if Int_Literal_Value /= No_Uint then
+ Set_Intval (Token_Node, Int_Literal_Value);
+ end if;
+
Check_Obsolete_Base_Char;
when Tok_String_Literal =>
elsif Val < Lo or else Hi < Val then
Error_Msg_N ("value outside permitted range", Expr);
Err := True;
+
+ else
+ Set_Enumeration_Rep (Elit, Val);
+ Set_Enumeration_Rep_Expr (Elit, Expr);
end if;
- Set_Enumeration_Rep (Elit, Val);
- Set_Enumeration_Rep_Expr (Elit, Expr);
Next (Expr);
Next (Elit);
end loop;
elsif Val < Lo or else Hi < Val then
Error_Msg_N ("value outside permitted range", Expr);
Err := True;
- end if;
- Set_Enumeration_Rep (Elit, Val);
+ else
+ Set_Enumeration_Rep (Elit, Val);
+ end if;
end if;
end if;
end if;
Set_Enum_Esize (Enumtype);
end if;
- Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype));
- Set_Esize (Base_Type (Enumtype), Esize (Enumtype));
- Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
+ Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype));
+ Set_Esize (Base_Type (Enumtype), Esize (Enumtype));
+
+ Copy_Alignment (To => Base_Type (Enumtype), From => Enumtype);
end;
end if;
X_Offs : Uint;
begin
- -- Skip processing of this entry if warning already posted
+ -- Skip processing of this entry if warning already posted, or if
+ -- alignments are not set.
- if not Address_Warning_Posted (ACCR.N) then
+ if not Address_Warning_Posted (ACCR.N)
+ and then Known_Alignment (ACCR.X)
+ and then Known_Alignment (ACCR.Y)
+ then
Expr := Original_Node (Expression (ACCR.N));
-- Get alignments, sizes and offset, if any
end if;
if not Has_Alignment_Clause (Ent) then
- Set_Alignment (Ent, Uint_0);
+ Init_Alignment (Ent);
end if;
end Set_Atomic_VFA;
-- do it when there is an address clause since we can do more if the
-- alignment is known.
- if not Known_Alignment (Obj) then
+ if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then
Set_Alignment (Obj, Alignment (Etype (Obj)));
end if;
Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
end if;
- Set_Alignment (T1, Alignment (T2));
+ Copy_Alignment (To => T1, From => T2);
end Set_Size_Info;
------------------------------
-- Present in an N_Variant node. This has a meaningful value only after
-- Gigi has back annotated the tree with representation information. At
-- this point, it contains a reference to a gcc expression that depends
- -- on the values of one or more discriminants. Give a set of discriminant
- -- values, this expression evaluates to False (zero) if variant is not
- -- present, and True (non-zero) if it is present. See unit Repinfo for
- -- further details on gigi back annotation. This field is used during
- -- back-annotation processing (for -gnatR -gnatc) to determine if a field
- -- is present or not.
+ -- on the values of one or more discriminants. Given a set of
+ -- discriminant values, this expression evaluates to False (zero) if
+ -- variant is not present, and True (non-zero) if it is present. See
+ -- unit Repinfo for further details on gigi back annotation. This field
+ -- is used during back-annotation processing (for -gnatR -gnatc) to
+ -- determine if a field is present or not.
-- Prev_Use_Clause
-- Present in both N_Use_Package_Clause and N_Use_Type_Clause. Used in
function Get_Uint is new Get_32_Bit_Field_With_Default
(Uint, Uint_0) with Inline;
+ function Get_Valid_Uint is new Get_32_Bit_Field
+ (Uint) with Inline;
+ -- Used for both Valid_Uint and other subtypes of Uint. Note that we don't
+ -- instantiate Get_Valid_32_Bit_Field; we don't want to blow up if the
+ -- value is wrong.
+
function Get_Ureal is new Get_32_Bit_Field
(Ureal) with Inline;
Val : constant Uint := Get_Uint (N, FD.Offset);
function Cast is new Unchecked_Conversion (Uint, Int);
begin
- if Val /= No_Uint then
- Print_Initial;
- UI_Write (Val, Format);
- Write_Str (" (Uint = ");
- Write_Int (Cast (Val));
- Write_Char (')');
- end if;
+ -- Do this even if Val = No_Uint, because Uint fields default
+ -- to Uint_0.
+
+ Print_Initial;
+ UI_Write (Val, Format);
+ Write_Str (" (Uint = ");
+ Write_Int (Cast (Val));
+ Write_Char (')');
+ end;
+
+ when Valid_Uint_Field | Unat_Field | Upos_Field
+ | Nonzero_Uint_Field =>
+ declare
+ Val : constant Uint := Get_Valid_Uint (N, FD.Offset);
+ function Cast is new Unchecked_Conversion (Uint, Int);
+ begin
+ Print_Initial;
+ UI_Write (Val, Format);
+
+ case FD.Kind is
+ when Valid_Uint_Field => Write_Str (" v");
+ when Unat_Field => Write_Str (" n");
+ when Upos_Field => Write_Str (" p");
+ when Nonzero_Uint_Field => Write_Str (" nz");
+ when others => raise Program_Error;
+ end case;
+
+ Write_Str (" (Uint = ");
+ Write_Int (Cast (Val));
+ Write_Char (')');
end;
when Ureal_Field =>
/* Type used for representation of universal integers. */
typedef Int Uint;
+typedef Int Valid_Uint;
+typedef Int Unat;
+typedef Int Upos;
+typedef Int Nonzero_Uint;
/* Used to indicate missing Uint value. */
#define No_Uint Uint_Low_Bound
Uint_Minus_127 : constant Uint;
Uint_Minus_128 : constant Uint;
+ subtype Valid_Uint is Uint with Predicate => Valid_Uint /= No_Uint;
+ subtype Unat is Valid_Uint with Predicate => Unat >= Uint_0;
+ subtype Upos is Valid_Uint with Predicate => Upos >= Uint_0;
+ subtype Nonzero_Uint is Valid_Uint with Predicate => Nonzero_Uint /= Uint_0;
+
type UI_Vector is array (Pos range <>) of Int;
-- Vector containing the integer values of a Uint value
projects / thirdparty / gcc.git / commitdiff
