procedure Validity_Check_Range
(N : Node_Id;
- Related_Id : Entity_Id := Empty)
- is
+ Related_Id : Entity_Id := Empty) is
begin
if Validity_Checks_On and Validity_Check_Operands then
if Nkind (N) = N_Range then
end if;
end Validity_Check_Range;
- --------------------------------
- -- Validity_Checks_Suppressed --
- --------------------------------
-
- function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is
- begin
- if Present (E) and then Checks_May_Be_Suppressed (E) then
- return Is_Check_Suppressed (E, Validity_Check);
- else
- return Scope_Suppress.Suppress (Validity_Check);
- end if;
- end Validity_Checks_Suppressed;
-
end Checks;
function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
- function Validity_Checks_Suppressed (E : Entity_Id) return Boolean;
-- These functions check to see if the named check is suppressed, either
-- by an active scope suppress setting, or because the check has been
-- specifically suppressed for the given entity. If no entity is relevant
Tmp_Id : Entity_Id;
begin
- -- No action of the call has already been processed
+ -- No action if the call has already been processed
if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
return;
procedure Warn_BIP (Func_Call : Node_Id) is
begin
if Debug_Flag_Underscore_BB then
- Error_Msg_N ("build-in-place function call?", Func_Call);
+ Error_Msg_N ("build-in-place function call??", Func_Call);
end if;
end Warn_BIP;
end if;
end Make_Adjust_Call;
- ----------------------
- -- Make_Detach_Call --
- ----------------------
-
- function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (Obj_Ref);
-
- begin
- return
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Detach), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
- end Make_Detach_Call;
-
---------------
-- Make_Call --
---------------
-- only the components (if any) are adjusted. Return Empty if Adjust or
-- Deep_Adjust is not available, possibly due to previous errors.
- function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id;
- -- Create a call to unhook an object from an arbitrary list. Obj_Ref is the
- -- object. Generate the following:
- --
- -- Ada.Finalization.Heap_Management.Detach
- -- (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
-
function Make_Final_Call
(Obj_Ref : Node_Id;
Typ : Entity_Id;
Right : constant Node_Id := Right_Opnd (N);
begin
- -- Suppress expansion of a fixed-by-fixed division if the
- -- operation is supported directly by the target.
-
- if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then
- return;
- end if;
-
if Etype (Left) = Universal_Real then
Do_Divide_Universal_Fixed (N);
-- Start of processing for Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
begin
- -- Suppress expansion of a fixed-by-fixed multiplication if the
- -- operation is supported directly by the target.
-
- if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then
- return;
- end if;
-
if Etype (Left) = Universal_Real then
if Nkind (Left) = N_Real_Literal then
Do_Multiply_Fixed_Universal (N, Left => Right, Right => Left);
return Empty;
end TSS;
- function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
- FN : constant Node_Id := Freeze_Node (Typ);
- Elmt : Elmt_Id;
- Subp : Entity_Id;
-
- begin
- if No (FN) then
- return Empty;
-
- elsif No (TSS_Elist (FN)) then
- return Empty;
-
- else
- Elmt := First_Elmt (TSS_Elist (FN));
- while Present (Elmt) loop
- if Chars (Node (Elmt)) = Nam then
- Subp := Node (Elmt);
-
- -- For stream subprograms, the TSS entity may be a renaming-
- -- as-body of an already generated entity. Use that one rather
- -- the one introduced by the renaming, which is an artifact of
- -- current stream handling.
-
- if Nkind (Parent (Parent (Subp))) =
- N_Subprogram_Renaming_Declaration
- and then
- Present (Corresponding_Spec (Parent (Parent (Subp))))
- then
- return Corresponding_Spec (Parent (Parent (Subp)));
- else
- return Subp;
- end if;
-
- else
- Next_Elmt (Elmt);
- end if;
- end loop;
- end if;
-
- return Empty;
- end TSS;
-
end Exp_Tss;
-- be explicitly frozen, so the N_Freeze_Entity node always exists).
function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id;
- function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id;
-- Finds the TSS with the given name associated with the given type.
-- If no such TSS exists, then Empty is returned.
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
-with Urealp; use Urealp;
with Validsw; use Validsw;
with GNAT.HTable;
end if;
end Integer_Type_For;
- ----------------------------
- -- Is_All_Null_Statements --
- ----------------------------
-
- function Is_All_Null_Statements (L : List_Id) return Boolean is
- Stm : Node_Id;
-
- begin
- Stm := First (L);
- while Present (Stm) loop
- if Nkind (Stm) /= N_Null_Statement then
- return False;
- end if;
-
- Next (Stm);
- end loop;
-
- return True;
- end Is_All_Null_Statements;
-
--------------------------------------------------
-- Is_Displacement_Of_Object_Or_Function_Result --
--------------------------------------------------
end if;
end Kill_Dead_Code;
- ------------------------
- -- Known_Non_Negative --
- ------------------------
-
- function Known_Non_Negative (Opnd : Node_Id) return Boolean is
- begin
- if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
- return True;
-
- else
- declare
- Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
- begin
- return
- Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
- end;
- end if;
- end Known_Non_Negative;
-
-----------------------------
-- Make_CW_Equivalent_Type --
-----------------------------
return Res;
end New_Class_Wide_Subtype;
- --------------------------------
- -- Non_Limited_Designated_Type --
- ---------------------------------
-
- function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
- Desig : constant Entity_Id := Designated_Type (T);
- begin
- if Has_Non_Limited_View (Desig) then
- return Non_Limited_View (Desig);
- else
- return Desig;
- end if;
- end Non_Limited_Designated_Type;
-
-----------------------------------
-- OK_To_Do_Constant_Replacement --
-----------------------------------
end if;
end Small_Integer_Type_For;
- --------------------------
- -- Target_Has_Fixed_Ops --
- --------------------------
-
- Integer_Sized_Small : Ureal;
- -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
- -- called (we don't want to compute it more than once).
-
- Long_Integer_Sized_Small : Ureal;
- -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
- -- is called (we don't want to compute it more than once)
-
- First_Time_For_THFO : Boolean := True;
- -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
-
- function Target_Has_Fixed_Ops
- (Left_Typ : Entity_Id;
- Right_Typ : Entity_Id;
- Result_Typ : Entity_Id) return Boolean
- is
- function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
- -- Return True if the given type is a fixed-point type with a small
- -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
- -- an absolute value less than 1.0. This is currently limited to
- -- fixed-point types that map to Integer or Long_Integer.
-
- ------------------------
- -- Is_Fractional_Type --
- ------------------------
-
- function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
- begin
- if Esize (Typ) = Standard_Integer_Size then
- return Small_Value (Typ) = Integer_Sized_Small;
-
- elsif Esize (Typ) = Standard_Long_Integer_Size then
- return Small_Value (Typ) = Long_Integer_Sized_Small;
-
- else
- return False;
- end if;
- end Is_Fractional_Type;
-
- -- Start of processing for Target_Has_Fixed_Ops
-
- begin
- -- Return False if Fractional_Fixed_Ops_On_Target is false
-
- if not Fractional_Fixed_Ops_On_Target then
- return False;
- end if;
-
- -- Here the target has Fractional_Fixed_Ops, if first time, compute
- -- standard constants used by Is_Fractional_Type.
-
- if First_Time_For_THFO then
- First_Time_For_THFO := False;
-
- Integer_Sized_Small :=
- UR_From_Components
- (Num => Uint_1,
- Den => UI_From_Int (Standard_Integer_Size - 1),
- Rbase => 2);
-
- Long_Integer_Sized_Small :=
- UR_From_Components
- (Num => Uint_1,
- Den => UI_From_Int (Standard_Long_Integer_Size - 1),
- Rbase => 2);
- end if;
-
- -- Return True if target supports fixed-by-fixed multiply/divide for
- -- fractional fixed-point types (see Is_Fractional_Type) and the operand
- -- and result types are equivalent fractional types.
-
- return Is_Fractional_Type (Base_Type (Left_Typ))
- and then Is_Fractional_Type (Base_Type (Right_Typ))
- and then Is_Fractional_Type (Base_Type (Result_Typ))
- and then Esize (Left_Typ) = Esize (Right_Typ)
- and then Esize (Left_Typ) = Esize (Result_Typ);
- end Target_Has_Fixed_Ops;
-
-------------------
-- Type_Map_Hash --
-------------------
-- Return a suitable standard integer type containing at least S bits and
-- of the signedness given by Uns.
- function Is_All_Null_Statements (L : List_Id) return Boolean;
- -- Return True if all the items of the list are N_Null_Statement nodes.
- -- False otherwise. True for an empty list. It is an error to call this
- -- routine with No_List as the argument.
-
function Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id : Entity_Id) return Boolean;
-- Determine whether Obj_Id is a source entity that has been initialized by
-- list. If Warn is True, a warning will be output at the start of N
-- indicating the deletion of the code.
- function Known_Non_Negative (Opnd : Node_Id) return Boolean;
- -- Given a node for a subexpression, determines if it represents a value
- -- that cannot possibly be negative, and if so returns True. A value of
- -- False means that it is not known if the value is positive or negative.
-
function Make_Invariant_Call (Expr : Node_Id) return Node_Id;
-- Generate a call to the Invariant_Procedure associated with the type of
-- expression Expr. Expr is passed as an actual parameter in the call.
-- consist of constants, when the object has a nontrivial initialization
-- or is controlled.
- function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id;
- -- An anonymous access type may designate a limited view. Check whether
- -- non-limited view is available during expansion, to examine components
- -- or other characteristics of the full type.
-
function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean;
-- This function is used when testing whether or not to replace a reference
-- to entity E by a known constant value. Such replacement must be done
-- Return the smallest standard integer type containing at least S bits and
-- of the signedness given by Uns.
- function Target_Has_Fixed_Ops
- (Left_Typ : Entity_Id;
- Right_Typ : Entity_Id;
- Result_Typ : Entity_Id) return Boolean;
- -- Returns True if and only if the target machine has direct support
- -- for fixed-by-fixed multiplications and divisions for the given
- -- operand and result types. This is called in package Exp_Fixd to
- -- determine whether to expand such operations.
-
function Type_May_Have_Bit_Aligned_Components
(Typ : Entity_Id) return Boolean;
-- Determines if Typ is a composite type that has within it (looking down
-- by the backend where possible).
Sem_Ch13.Validate_Address_Clauses;
-
- -- Validate independence pragmas (again using values annotated by the
- -- back end for component layout where possible) but only for non-GCC
- -- back ends, as this is done a priori for GCC back ends.
- -- ??? We use to test for AAMP_On_Target which is now gone, consider
- --
- -- if AAMP_On_Target then
- -- Sem_Ch13.Validate_Independence;
- -- end if;
end Post_Compilation_Validation_Checks;
-----------------------------------
Finalize_Address_Table.Remove (Obj);
end Delete_Finalize_Address_Unprotected;
- ------------
- -- Detach --
- ------------
-
- procedure Detach (N : not null FM_Node_Ptr) is
- begin
- Lock_Task.all;
- Detach_Unprotected (N);
- Unlock_Task.all;
-
- -- Note: No need to unlock in case of an exception because the above
- -- code can never raise one.
- end Detach;
-
------------------------
-- Detach_Unprotected --
------------------------
-- Destroy the relation pair object - Finalize_Address from the internal
-- hash table.
- procedure Detach (N : not null FM_Node_Ptr);
- -- Compiler interface, do not call from within the run-time. Remove a node
- -- from an arbitrary finalization master.
-
procedure Detach_Unprotected (N : not null FM_Node_Ptr);
-- Remove a node from an arbitrary finalization master
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := True;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := True;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := True;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := True;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
Table_Increment => Alloc.Rep_Table_Increment,
Table_Name => "BE_Rep_Table");
- --------------------------------------------------------------
- -- Representation of Front-End Dynamic Size/Offset Entities --
- --------------------------------------------------------------
-
- package Dynamic_SO_Entity_Table is new Table.Table (
- Table_Component_Type => Entity_Id,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => Alloc.Rep_Table_Initial,
- Table_Increment => Alloc.Rep_Table_Increment,
- Table_Name => "FE_Rep_Table");
-
Unit_Casing : Casing_Type;
-- Identifier casing for current unit. This is set by List_Rep_Info for
-- each unit, before calling subprograms which may read it.
-- Local Subprograms --
-----------------------
- function Back_End_Layout return Boolean;
- -- Test for layout mode, True = back end, False = front end. This function
- -- is used rather than checking the configuration parameter because we do
- -- not want Repinfo to depend on Targparm.
-
procedure List_Entities
(Ent : Entity_Id;
Bytes_Big_Endian : Boolean;
-- flag Paren is set, then the output is surrounded in parentheses if it is
-- other than a simple value.
- ---------------------
- -- Back_End_Layout --
- ---------------------
-
- function Back_End_Layout return Boolean is
- begin
- -- We have back-end layout if the back end has made any entries in the
- -- table of GCC expressions, otherwise we have front-end layout.
-
- return Rep_Table.Last > 0;
- end Back_End_Layout;
-
------------------------
-- Create_Discrim_Ref --
------------------------
Op1 => Discriminant_Number (Discr));
end Create_Discrim_Ref;
- ---------------------------
- -- Create_Dynamic_SO_Ref --
- ---------------------------
-
- function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
- begin
- Dynamic_SO_Entity_Table.Append (E);
- return UI_From_Int (-Dynamic_SO_Entity_Table.Last);
- end Create_Dynamic_SO_Ref;
-
-----------------
-- Create_Node --
-----------------
return Entity_Header_Num (Id mod Relevant_Entities_Size);
end Entity_Hash;
- ---------------------------
- -- Get_Dynamic_SO_Entity --
- ---------------------------
-
- function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is
- begin
- return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
- end Get_Dynamic_SO_Entity;
-
- -----------------------
- -- Is_Dynamic_SO_Ref --
- -----------------------
-
- function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
- begin
- return U < Uint_0;
- end Is_Dynamic_SO_Ref;
-
- ----------------------
- -- Is_Static_SO_Ref --
- ----------------------
-
- function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
- begin
- return U >= Uint_0;
- end Is_Static_SO_Ref;
-
---------
-- lgx --
---------
else
Write_Val (Esiz, Paren => not List_Representation_Info_To_JSON);
- -- If in front-end layout mode, then dynamic size is stored in
- -- storage units, so renormalize for output.
-
- if not Back_End_Layout then
- Write_Str (" * ");
- Write_Int (SSU);
- end if;
-
-- Add appropriate first bit offset
if not List_Representation_Info_To_JSON then
Write_Char ('(');
end if;
- if Back_End_Layout then
- List_GCC_Expression (Val);
- else
- Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
- end if;
+ List_GCC_Expression (Val);
if Paren then
Write_Char (')');
-- the corresponding entities as constant non-negative integers,
-- and the Uint values are stored directly in these fields.
- -- For composite types, there are three cases:
+ -- For composite types, there are two cases:
-- 1. In some cases the front end knows the values statically,
-- for example in the case where representation clauses or
-- pragmas specify the values.
- -- 2. If Frontend_Layout is False, then the backend is responsible
- -- for layout of all types and objects not laid out by the
- -- front end. This includes all dynamic values, and also
- -- static values (e.g. record sizes) when not set by the
- -- front end.
-
- -- 3. If Frontend_Layout is True, then the front end lays out
- -- all data, according to target dependent size and alignment
- -- information, creating dynamic inlinable functions where
- -- needed in the case of sizes not known till runtime.
+ -- 2. Otherwise the backend is responsible for layout of all types and
+ -- objects not laid out by the front end. This includes all dynamic
+ -- values, and also static values (e.g. record sizes) when not set by
+ -- the front end.
-----------------------------
-- Back Annotation by Gigi --
-----------------------------
- -- The following interface is used by gigi if Frontend_Layout is False
+ -- The following interface is used by gigi
-- As part of the processing in gigi, the types are laid out and
-- appropriate values computed for the sizes and component positions
function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref;
-- Creates a reference to the discriminant whose entity is Discr
- --------------------------------------------------------
- -- Front-End Interface for Dynamic Size/Offset Values --
- --------------------------------------------------------
-
- -- If Frontend_Layout is True, then the front-end deals with all
- -- dynamic size and offset fields. There are two cases:
-
- -- 1. The value can be computed at the time of type freezing, and
- -- is stored in a run-time constant. In this case, the field
- -- contains a reference to this entity. In the case of sizes
- -- the value stored is the size in storage units, since dynamic
- -- sizes are always a multiple of storage units.
-
- -- 2. The size/offset depends on the value of discriminants at
- -- run-time. In this case, the front end builds a function to
- -- compute the value. This function has a single parameter
- -- which is the discriminated record object in question. Any
- -- references to discriminant values are simply references to
- -- the appropriate discriminant in this single argument, and
- -- to compute the required size/offset value at run time, the
- -- code generator simply constructs a call to the function
- -- with the appropriate argument. The size/offset field in
- -- this case contains a reference to the function entity.
- -- Note that as for case 1, if such a function is used to
- -- return a size, then the size in storage units is returned,
- -- not the size in bits.
-
- -- The interface here allows these created entities to be referenced
- -- using negative Unit values, so that they can be stored in the
- -- appropriate size and offset fields in the tree.
-
- -- In the case of components, if the location of the component is static,
- -- then all four fields (Component_Bit_Offset, Normalized_Position, Esize,
- -- and Normalized_First_Bit) are set to appropriate values. In the case of
- -- a non-static component location, Component_Bit_Offset is not used and
- -- is left set to Unknown. Normalized_Position and Normalized_First_Bit
- -- are set appropriately.
-
- subtype SO_Ref is Uint;
- -- Type used to represent a Uint value that represents a static or
- -- dynamic size/offset value (non-negative if static, negative if
- -- the size value is dynamic).
-
- subtype Dynamic_SO_Ref is Uint;
- -- Type used to represent a negative Uint value used to store
- -- a dynamic size/offset value.
-
- function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean;
- pragma Inline (Is_Dynamic_SO_Ref);
- -- Given a SO_Ref (Uint) value, returns True iff the SO_Ref value
- -- represents a dynamic Size/Offset value (i.e. it is negative).
-
- function Is_Static_SO_Ref (U : SO_Ref) return Boolean;
- pragma Inline (Is_Static_SO_Ref);
- -- Given a SO_Ref (Uint) value, returns True iff the SO_Ref value
- -- represents a static Size/Offset value (i.e. it is non-negative).
-
- function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref;
- -- Given the Entity_Id for a constant (case 1), the Node_Id for an
- -- expression (case 2), or the Entity_Id for a function (case 3),
- -- this function returns a (negative) Uint value that can be used
- -- to retrieve the entity or expression for later use.
-
- function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id;
- -- Retrieve the Node_Id or Entity_Id stored by a previous call to
- -- Create_Dynamic_SO_Ref. The approach is that the front end makes
- -- the necessary Create_Dynamic_SO_Ref calls to associate the node
- -- and entity id values and the back end makes Get_Dynamic_SO_Ref
- -- calls to retrieve them.
-
------------------------------
-- External tools Interface --
------------------------------
RE_Add_Offset_To_Address, -- System.Finalization_Masters
RE_Attach, -- System.Finalization_Masters
RE_Base_Pool, -- System.Finalization_Masters
- RE_Detach, -- System.Finalization_Masters
RE_Finalization_Master, -- System.Finalization_Masters
RE_Finalization_Master_Ptr, -- System.Finalization_Masters
RE_Set_Base_Pool, -- System.Finalization_Masters
RE_Add_Offset_To_Address => System_Finalization_Masters,
RE_Attach => System_Finalization_Masters,
RE_Base_Pool => System_Finalization_Masters,
- RE_Detach => System_Finalization_Masters,
RE_Finalization_Master => System_Finalization_Masters,
RE_Finalization_Master_Ptr => System_Finalization_Masters,
RE_Set_Base_Pool => System_Finalization_Masters,
with Atree; use Atree;
with Einfo; use Einfo;
with Nlists; use Nlists;
+with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Uintp; use Uintp;
return Empty;
end First_Tag_Component;
- ---------------------
- -- Get_Binary_Nkind --
- ---------------------
-
- function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
- begin
- case Chars (Op) is
- when Name_Op_Add => return N_Op_Add;
- when Name_Op_Concat => return N_Op_Concat;
- when Name_Op_Expon => return N_Op_Expon;
- when Name_Op_Subtract => return N_Op_Subtract;
- when Name_Op_Mod => return N_Op_Mod;
- when Name_Op_Multiply => return N_Op_Multiply;
- when Name_Op_Divide => return N_Op_Divide;
- when Name_Op_Rem => return N_Op_Rem;
- when Name_Op_And => return N_Op_And;
- when Name_Op_Eq => return N_Op_Eq;
- when Name_Op_Ge => return N_Op_Ge;
- when Name_Op_Gt => return N_Op_Gt;
- when Name_Op_Le => return N_Op_Le;
- when Name_Op_Lt => return N_Op_Lt;
- when Name_Op_Ne => return N_Op_Ne;
- when Name_Op_Or => return N_Op_Or;
- when Name_Op_Xor => return N_Op_Xor;
- when others => raise Program_Error;
- end case;
- end Get_Binary_Nkind;
-
-----------------------
-- Get_Called_Entity --
-----------------------
return Empty;
end Get_Rep_Pragma;
- ---------------------
- -- Get_Unary_Nkind --
- ---------------------
-
- function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
- begin
- case Chars (Op) is
- when Name_Op_Abs => return N_Op_Abs;
- when Name_Op_Subtract => return N_Op_Minus;
- when Name_Op_Not => return N_Op_Not;
- when Name_Op_Add => return N_Op_Plus;
- when others => raise Program_Error;
- end case;
- end Get_Unary_Nkind;
-
---------------------------------
-- Has_External_Tag_Rep_Clause --
---------------------------------
end if;
end Is_Limited_View;
- ----------------------------
- -- Is_Protected_Operation --
- ----------------------------
-
- function Is_Protected_Operation (E : Entity_Id) return Boolean is
- begin
- return
- Is_Entry (E)
- or else (Is_Subprogram (E)
- and then Nkind (Parent (Unit_Declaration_Node (E))) =
- N_Protected_Definition);
- end Is_Protected_Operation;
-
-------------------------------
-- Is_Record_Or_Limited_Type --
-------------------------------
return Empty;
end Next_Tag_Component;
- -----------------------
- -- Number_Components --
- -----------------------
-
- function Number_Components (Typ : Entity_Id) return Nat is
- N : Nat := 0;
- Comp : Entity_Id;
-
- begin
- -- We do not call Einfo.First_Component_Or_Discriminant, as this
- -- function does not skip completely hidden discriminants, which we
- -- want to skip here.
-
- if Has_Discriminants (Typ) then
- Comp := First_Discriminant (Typ);
- else
- Comp := First_Component (Typ);
- end if;
-
- while Present (Comp) loop
- N := N + 1;
- Next_Component_Or_Discriminant (Comp);
- end loop;
-
- return N;
- end Number_Components;
-
--------------------------
-- Number_Discriminants --
--------------------------
and then Has_Discriminants (Typ));
end Object_Type_Has_Constrained_Partial_View;
- ------------------
- -- Package_Body --
- ------------------
-
- function Package_Body (E : Entity_Id) return Node_Id is
- N : Node_Id;
-
- begin
- if Ekind (E) = E_Package_Body then
- N := Parent (E);
-
- if Nkind (N) = N_Defining_Program_Unit_Name then
- N := Parent (N);
- end if;
-
- else
- N := Package_Spec (E);
-
- if Present (Corresponding_Body (N)) then
- N := Parent (Corresponding_Body (N));
-
- if Nkind (N) = N_Defining_Program_Unit_Name then
- N := Parent (N);
- end if;
- else
- N := Empty;
- end if;
- end if;
-
- return N;
- end Package_Body;
-
------------------
-- Package_Spec --
------------------
with Namet; use Namet;
with Table;
with Types; use Types;
-with Sinfo; use Sinfo;
package Sem_Aux is
-- Typ must be a tagged record type. This function returns the Entity for
-- the first _Tag field in the record type.
- function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind;
- -- Op must be an entity with an Ekind of E_Operator. This function returns
- -- the Nkind value that would be used to construct a binary operator node
- -- referencing this entity. It is an error to call this function if Ekind
- -- (Op) /= E_Operator.
-
function Get_Called_Entity (Call : Node_Id) return Entity_Id;
-- Obtain the entity of the entry, operator, or subprogram being invoked
-- by call Call.
- function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind;
- -- Op must be an entity with an Ekind of E_Operator. This function returns
- -- the Nkind value that would be used to construct a unary operator node
- -- referencing this entity. It is an error to call this function if Ekind
- -- (Op) /= E_Operator.
-
function Get_Rep_Item
(E : Entity_Id;
Nam : Name_Id;
-- these types). This older routine overlaps with the previous one, this
-- should be cleaned up???
- function Is_Protected_Operation (E : Entity_Id) return Boolean;
- -- Given a subprogram or entry, determines whether E is a protected entry
- -- or subprogram.
-
function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean;
-- Return True if Typ requires is a record or limited type.
-- The result returned is the next _Tag field in this record, or Empty
-- if this is the last such field.
- function Number_Components (Typ : Entity_Id) return Nat;
- -- Typ is a record type, yields number of components (including
- -- discriminants) in type.
-
function Number_Discriminants (Typ : Entity_Id) return Pos;
-- Typ is a type with discriminants, yields number of discriminants in type
-- derived type, and the subtype is not an unconstrained array subtype
-- (RM 3.3(23.10/3)).
- function Package_Body (E : Entity_Id) return Node_Id;
- -- Given an entity for a package (spec or body), return the corresponding
- -- package body if any, or else Empty.
-
function Package_Spec (E : Entity_Id) return Node_Id;
-- Given an entity for a package spec, return the corresponding package
-- spec if any, or else Empty.
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
+with Table;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
end loop;
end Validate_Address_Clauses;
- ---------------------------
- -- Validate_Independence --
- ---------------------------
-
- procedure Validate_Independence is
- SU : constant Uint := UI_From_Int (System_Storage_Unit);
- N : Node_Id;
- E : Entity_Id;
- IC : Boolean;
- Comp : Entity_Id;
- Addr : Node_Id;
- P : Node_Id;
-
- procedure Check_Array_Type (Atyp : Entity_Id);
- -- Checks if the array type Atyp has independent components, and
- -- if not, outputs an appropriate set of error messages.
-
- procedure No_Independence;
- -- Output message that independence cannot be guaranteed
-
- function OK_Component (C : Entity_Id) return Boolean;
- -- Checks one component to see if it is independently accessible, and
- -- if so yields True, otherwise yields False if independent access
- -- cannot be guaranteed. This is a conservative routine, it only
- -- returns True if it knows for sure, it returns False if it knows
- -- there is a problem, or it cannot be sure there is no problem.
-
- procedure Reason_Bad_Component (C : Entity_Id);
- -- Outputs continuation message if a reason can be determined for
- -- the component C being bad.
-
- ----------------------
- -- Check_Array_Type --
- ----------------------
-
- procedure Check_Array_Type (Atyp : Entity_Id) is
- Ctyp : constant Entity_Id := Component_Type (Atyp);
-
- begin
- -- OK if no alignment clause, no pack, and no component size
-
- if not Has_Component_Size_Clause (Atyp)
- and then not Has_Alignment_Clause (Atyp)
- and then not Is_Packed (Atyp)
- then
- return;
- end if;
-
- -- Case where component size is greater than or equal to the maximum
- -- integer size and the alignment of the array is at least as large
- -- as the alignment of the component. We are OK in this situation.
-
- if Known_Component_Size (Atyp)
- and then Component_Size (Atyp) >= System_Max_Integer_Size
- and then Known_Alignment (Atyp)
- and then Known_Alignment (Ctyp)
- and then Alignment (Atyp) >= Alignment (Ctyp)
- then
- return;
- end if;
-
- -- Check actual component size
-
- if not Known_Component_Size (Atyp)
- or else not Addressable (Component_Size (Atyp))
- or else Component_Size (Atyp) mod Esize (Ctyp) /= 0
- then
- No_Independence;
-
- -- Bad component size, check reason
-
- if Has_Component_Size_Clause (Atyp) then
- P := Get_Attribute_Definition_Clause
- (Atyp, Attribute_Component_Size);
-
- if Present (P) then
- Error_Msg_Sloc := Sloc (P);
- Error_Msg_N ("\because of Component_Size clause#", N);
- return;
- end if;
- end if;
-
- if Is_Packed (Atyp) then
- P := Get_Rep_Pragma (Atyp, Name_Pack);
-
- if Present (P) then
- Error_Msg_Sloc := Sloc (P);
- Error_Msg_N ("\because of pragma Pack#", N);
- return;
- end if;
- end if;
-
- -- No reason found, just return
-
- return;
- end if;
-
- -- Array type is OK independence-wise
-
- return;
- end Check_Array_Type;
-
- ---------------------
- -- No_Independence --
- ---------------------
-
- procedure No_Independence is
- begin
- if Pragma_Name (N) = Name_Independent then
- Error_Msg_NE ("independence cannot be guaranteed for&", N, E);
- else
- Error_Msg_NE
- ("independent components cannot be guaranteed for&", N, E);
- end if;
- end No_Independence;
-
- ------------------
- -- OK_Component --
- ------------------
-
- function OK_Component (C : Entity_Id) return Boolean is
- Rec : constant Entity_Id := Scope (C);
- Ctyp : constant Entity_Id := Etype (C);
-
- begin
- -- OK if no component clause, no Pack, and no alignment clause
-
- if No (Component_Clause (C))
- and then not Is_Packed (Rec)
- and then not Has_Alignment_Clause (Rec)
- then
- return True;
- end if;
-
- -- Here we look at the actual component layout. A component is
- -- addressable if its size is a multiple of the Esize of the
- -- component type, and its starting position in the record has
- -- appropriate alignment, and the record itself has appropriate
- -- alignment to guarantee the component alignment.
-
- -- Make sure sizes are static, always assume the worst for any
- -- cases where we cannot check static values.
-
- if not (Known_Static_Esize (C)
- and then
- Known_Static_Esize (Ctyp))
- then
- return False;
- end if;
-
- -- Size of component must be addressable or greater than the maximum
- -- integer size and a multiple of bytes.
-
- if not Addressable (Esize (C))
- and then Esize (C) < System_Max_Integer_Size
- then
- return False;
- end if;
-
- -- Check size is proper multiple
-
- if Esize (C) mod Esize (Ctyp) /= 0 then
- return False;
- end if;
-
- -- Check alignment of component is OK
-
- if not Known_Component_Bit_Offset (C)
- or else Component_Bit_Offset (C) < Uint_0
- or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0
- then
- return False;
- end if;
-
- -- Check alignment of record type is OK
-
- if not Known_Alignment (Rec)
- or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
- then
- return False;
- end if;
-
- -- All tests passed, component is addressable
-
- return True;
- end OK_Component;
-
- --------------------------
- -- Reason_Bad_Component --
- --------------------------
-
- procedure Reason_Bad_Component (C : Entity_Id) is
- Rec : constant Entity_Id := Scope (C);
- Ctyp : constant Entity_Id := Etype (C);
-
- begin
- -- If component clause present assume that's the problem
-
- if Present (Component_Clause (C)) then
- Error_Msg_Sloc := Sloc (Component_Clause (C));
- Error_Msg_N ("\because of Component_Clause#", N);
- return;
- end if;
-
- -- If pragma Pack clause present, assume that's the problem
-
- if Is_Packed (Rec) then
- P := Get_Rep_Pragma (Rec, Name_Pack);
-
- if Present (P) then
- Error_Msg_Sloc := Sloc (P);
- Error_Msg_N ("\because of pragma Pack#", N);
- return;
- end if;
- end if;
-
- -- See if record has bad alignment clause
-
- if Has_Alignment_Clause (Rec)
- and then Known_Alignment (Rec)
- and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
- then
- P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment);
-
- if Present (P) then
- Error_Msg_Sloc := Sloc (P);
- Error_Msg_N ("\because of Alignment clause#", N);
- end if;
- end if;
-
- -- Couldn't find a reason, so return without a message
-
- return;
- end Reason_Bad_Component;
-
- -- Start of processing for Validate_Independence
-
- begin
- for J in Independence_Checks.First .. Independence_Checks.Last loop
- N := Independence_Checks.Table (J).N;
- E := Independence_Checks.Table (J).E;
- IC := Pragma_Name (N) = Name_Independent_Components;
-
- -- Deal with component case
-
- if Ekind (E) in E_Component | E_Discriminant then
- if not OK_Component (E) then
- No_Independence;
- Reason_Bad_Component (E);
- goto Continue;
- end if;
- end if;
-
- -- Deal with record with Independent_Components
-
- if IC and then Is_Record_Type (E) then
- Comp := First_Component_Or_Discriminant (E);
- while Present (Comp) loop
- if not OK_Component (Comp) then
- No_Independence;
- Reason_Bad_Component (Comp);
- goto Continue;
- end if;
-
- Next_Component_Or_Discriminant (Comp);
- end loop;
- end if;
-
- -- Deal with address clause case
-
- if Is_Object (E) then
- Addr := Address_Clause (E);
-
- if Present (Addr) then
- No_Independence;
- Error_Msg_Sloc := Sloc (Addr);
- Error_Msg_N ("\because of Address clause#", N);
- goto Continue;
- end if;
- end if;
-
- -- Deal with independent components for array type
-
- if IC and then Is_Array_Type (E) then
- Check_Array_Type (E);
- end if;
-
- -- Deal with independent components for array object
-
- if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then
- Check_Array_Type (Etype (E));
- end if;
-
- <<Continue>> null;
- end loop;
- end Validate_Independence;
-
------------------------------
-- Validate_Iterable_Aspect --
------------------------------
-- --
------------------------------------------------------------------------------
-with Table;
with Types; use Types;
with Sem_Disp; use Sem_Disp;
with Uintp; use Uintp;
-- table of saved address clauses checking for suspicious alignments and
-- if necessary issuing warnings.
- procedure Validate_Independence;
- -- This is called after the back end has been called (and thus after the
- -- layout of components has been back annotated). It goes through the
- -- table of saved pragma Independent[_Component] entries, checking that
- -- independence can be achieved, and if necessary issuing error messages.
-
- -------------------------------------
- -- Table for Validate_Independence --
- -------------------------------------
-
- -- If a legal pragma Independent or Independent_Components is given for
- -- an entity, then an entry is made in this table, to be checked by a
- -- call to Validate_Independence after back annotation of layout is done.
-
- type Independence_Check_Record is record
- N : Node_Id;
- -- The pragma Independent or Independent_Components
-
- E : Entity_Id;
- -- The entity to which it applies
- end record;
-
- package Independence_Checks is new Table.Table (
- Table_Component_Type => Independence_Check_Record,
- Table_Index_Type => Int,
- Table_Low_Bound => 1,
- Table_Initial => 20,
- Table_Increment => 200,
- Table_Name => "Independence_Checks");
-
-----------------------------------
-- Handling of Aspect Visibility --
-----------------------------------
function Build_Discriminal_Array_Constraint return List_Id;
-- If one or more of the bounds of the component depends on
- -- discriminants, build actual constraint using the discriminants
+ -- discriminants, build actual constraint using the discriminants
-- of the prefix.
function Build_Discriminal_Record_Constraint return List_Id;
-- The following array defines a tag name for each entry
type Targparm_Tags is
- (AAM, -- AAMP
- ACR, -- Always_Compatible_Rep
+ (ACR, -- Always_Compatible_Rep
ASD, -- Atomic_Sync_Default
BDC, -- Backend_Divide_Checks
BOC, -- Backend_Overflow_Checks
D32, -- Duration_32_Bits
DEN, -- Denorm
EXS, -- Exit_Status_Supported
- FEL, -- Frontend_Layout
FEX, -- Frontend_Exceptions
- FFO, -- Fractional_Fixed_Ops
MOV, -- Machine_Overflows
MRN, -- Machine_Rounds
PAS, -- Preallocated_Stacks
-- The following list of string constants gives the parameter names
- AAM_Str : aliased constant Source_Buffer := "AAMP";
ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep";
ASD_Str : aliased constant Source_Buffer := "Atomic_Sync_Default";
BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";
D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";
DEN_Str : aliased constant Source_Buffer := "Denorm";
EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
- FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
FEX_Str : aliased constant Source_Buffer := "Frontend_Exceptions";
- FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";
MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks";
type Buffer_Ptr is access constant Source_Buffer;
Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
- (AAM => AAM_Str'Access,
- ACR => ACR_Str'Access,
+ (ACR => ACR_Str'Access,
ASD => ASD_Str'Access,
BDC => BDC_Str'Access,
BOC => BOC_Str'Access,
D32 => D32_Str'Access,
DEN => DEN_Str'Access,
EXS => EXS_Str'Access,
- FEL => FEL_Str'Access,
FEX => FEX_Str'Access,
- FFO => FFO_Str'Access,
MOV => MOV_Str'Access,
MRN => MRN_Str'Access,
PAS => PAS_Str'Access,
Result := (System_Text (P) = 'T');
case K is
- when AAM => null;
when ACR => Always_Compatible_Rep_On_Target := Result;
when ASD => Atomic_Sync_Default_On_Target := Result;
when BDC => Backend_Divide_Checks_On_Target := Result;
when D32 => Duration_32_Bits_On_Target := Result;
when DEN => Denorm_On_Target := Result;
when EXS => Exit_Status_Supported_On_Target := Result;
- when FEL => null;
when FEX => Frontend_Exceptions_On_Target := Result;
- when FFO => Fractional_Fixed_Ops_On_Target := Result;
when MOV => Machine_Overflows_On_Target := Result;
when MRN => Machine_Rounds_On_Target := Result;
when PAS => Preallocated_Stacks_On_Target := Result;
-- WARNING: There is a matching C declaration of this variable in fe.h
- -------------------------------------------
- -- Boolean-Valued Fixed-Point Attributes --
- -------------------------------------------
-
- Fractional_Fixed_Ops_On_Target : Boolean := False;
- -- Set to True for targets that support fixed-by-fixed multiplication
- -- and division for fixed-point types with a small value equal to
- -- 2 ** (-(T'Object_Size - 1)) and whose values have an absolute
- -- value less than 1.0.
-
-----------------
-- Subprograms --
-----------------
Validity_Check_Tests := False;
end Reset_Validity_Check_Options;
- ---------------------------------
- -- Save_Validity_Check_Options --
- ---------------------------------
-
- procedure Save_Validity_Check_Options
- (Options : out Validity_Check_Options)
- is
- P : Natural := 0;
-
- procedure Add (C : Character; S : Boolean);
- -- Add given character C to string if switch S is true
-
- procedure Add (C : Character; S : Boolean) is
- begin
- if S then
- P := P + 1;
- Options (P) := C;
- end if;
- end Add;
-
- -- Start of processing for Save_Validity_Check_Options
-
- begin
- for K in Options'Range loop
- Options (K) := ' ';
- end loop;
-
- Add ('e', Validity_Check_Components);
- Add ('c', Validity_Check_Copies);
- Add ('d', Validity_Check_Default);
- Add ('f', Validity_Check_Floating_Point);
- Add ('i', Validity_Check_In_Params);
- Add ('m', Validity_Check_In_Out_Params);
- Add ('o', Validity_Check_Operands);
- Add ('p', Validity_Check_Parameters);
- Add ('r', Validity_Check_Returns);
- Add ('s', Validity_Check_Subscripts);
- Add ('t', Validity_Check_Tests);
- end Save_Validity_Check_Options;
-
- ----------------------------------------
- -- Set_Default_Validity_Check_Options --
- ----------------------------------------
-
- procedure Set_Default_Validity_Check_Options is
- begin
- Reset_Validity_Check_Options;
- Set_Validity_Check_Options ("d");
- end Set_Default_Validity_Check_Options;
-
--------------------------------
-- Set_Validity_Check_Options --
--------------------------------
-- Subprograms --
-----------------
- procedure Set_Default_Validity_Check_Options;
- -- This procedure is called to set the default validity checking options
- -- that apply if no Validity_Check switches or pragma is given.
-
procedure Set_Validity_Check_Options
(Options : String;
OK : out Boolean;
procedure Set_Validity_Check_Options (Options : String);
-- Like the above procedure, except that the call is simply ignored if
-- there are any error conditions, this is for example appropriate for
- -- calls where the string is known to be valid, e.g. because it was
- -- obtained by Save_Validity_Check_Options.
+ -- calls where the string is known to be valid.
procedure Reset_Validity_Check_Options;
-- Sets all validity check options to off
subtype Validity_Check_Options is String (1 .. 16);
-- Long enough string to hold all options from Save call below
- procedure Save_Validity_Check_Options
- (Options : out Validity_Check_Options);
- -- Sets Options to represent current selection of options. This
- -- set can be restored by first calling Reset_Validity_Check_Options,
- -- and then calling Set_Validity_Check_Options with the Options string.
-
end Validsw;
projects / gcc.git / commitdiff