-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Fname; use Fname;
+with Expander; use Expander;
with Freeze; use Freeze;
with Gnatvsn; use Gnatvsn;
with Itypes; use Itypes;
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 Uintp; use Uintp;
-----------------------
function Build_Array_VS_Func
- (A_Type : Entity_Id;
- Nod : Node_Id) return Entity_Id;
- -- Build function to test Valid_Scalars for array type A_Type. Nod is the
- -- Valid_Scalars attribute node, used to insert the function body, and the
- -- value returned is the entity of the constructed function body. We do not
- -- bother to generate a separate spec for this subprogram.
+ (Attr : Node_Id;
+ Formal_Typ : Entity_Id;
+ Array_Typ : Entity_Id;
+ Comp_Typ : Entity_Id) return Entity_Id;
+ -- Validate the components of an array type by means of a function. Return
+ -- the entity of the validation function. The parameters are as follows:
+ --
+ -- * Attr - the 'Valid_Scalars attribute for which the function is
+ -- generated.
+ --
+ -- * Formal_Typ - the type of the generated function's only formal
+ -- parameter.
+ --
+ -- * Array_Typ - the array type whose components are to be validated
+ --
+ -- * Comp_Typ - the component type of the array
+
+ function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id;
+ -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
function Build_Record_VS_Func
- (R_Type : Entity_Id;
- Nod : Node_Id) return Entity_Id;
- -- Build function to test Valid_Scalars for record type A_Type. Nod is the
- -- Valid_Scalars attribute node, used to insert the function body, and the
- -- value returned is the entity of the constructed function body. We do not
- -- bother to generate a separate spec for this subprogram.
+ (Attr : Node_Id;
+ Formal_Typ : Entity_Id;
+ Rec_Typ : Entity_Id) return Entity_Id;
+ -- Validate the components, discriminants, and variants of a record type by
+ -- means of a function. Return the entity of the validation function. The
+ -- parameters are as follows:
+ --
+ -- * Attr - the 'Valid_Scalars attribute for which the function is
+ -- generated.
+ --
+ -- * Formal_Typ - the type of the generated function's only formal
+ -- parameter.
+ --
+ -- * Rec_Typ - the record type whose internals are to be validated
procedure Compile_Stream_Body_In_Scope
(N : Node_Id;
-------------------------
function Build_Array_VS_Func
- (A_Type : Entity_Id;
- Nod : Node_Id) return Entity_Id
+ (Attr : Node_Id;
+ Formal_Typ : Entity_Id;
+ Array_Typ : Entity_Id;
+ Comp_Typ : Entity_Id) return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (Nod);
- Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
- Comp_Type : constant Entity_Id := Component_Type (A_Type);
- Body_Stmts : List_Id;
- Index_List : List_Id;
- Formals : List_Id;
-
- function Test_Component return List_Id;
- -- Create one statement to test validity of one component designated by
- -- a full set of indexes. Returns statement list containing test.
-
- function Test_One_Dimension (N : Int) return List_Id;
- -- Create loop to test one dimension of the array. The single statement
- -- in the loop body tests the inner dimensions if any, or else the
- -- single component. Note that this procedure is called recursively,
- -- with N being the dimension to be initialized. A call with N greater
- -- than the number of dimensions simply generates the component test,
- -- terminating the recursion. Returns statement list containing tests.
+ Loc : constant Source_Ptr := Sloc (Attr);
+
+ function Validate_Component
+ (Obj_Id : Entity_Id;
+ Indexes : List_Id) return Node_Id;
+ -- Process a single component denoted by indexes Indexes. Obj_Id denotes
+ -- the entity of the validation parameter. Return the check associated
+ -- with the component.
+
+ function Validate_Dimension
+ (Obj_Id : Entity_Id;
+ Dim : Int;
+ Indexes : List_Id) return Node_Id;
+ -- Process dimension Dim of the array type. Obj_Id denotes the entity
+ -- of the validation parameter. Indexes is a list where each dimension
+ -- deposits its loop variable, which will later identify a component.
+ -- Return the loop associated with the current dimension.
- --------------------
- -- Test_Component --
- --------------------
+ ------------------------
+ -- Validate_Component --
+ ------------------------
- function Test_Component return List_Id is
- Comp : Node_Id;
- Anam : Name_Id;
+ function Validate_Component
+ (Obj_Id : Entity_Id;
+ Indexes : List_Id) return Node_Id
+ is
+ Attr_Nam : Name_Id;
begin
- Comp :=
- Make_Indexed_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uA),
- Expressions => Index_List);
-
- if Is_Scalar_Type (Comp_Type) then
- Anam := Name_Valid;
+ if Is_Scalar_Type (Comp_Typ) then
+ Attr_Nam := Name_Valid;
else
- Anam := Name_Valid_Scalars;
+ Attr_Nam := Name_Valid_Scalars;
end if;
- return New_List (
+ -- Generate:
+ -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
+ -- return False;
+ -- end if;
+
+ return
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Attribute_Reference (Loc,
- Attribute_Name => Anam,
- Prefix => Comp)),
+ Prefix =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Array_Typ,
+ New_Occurrence_Of (Obj_Id, Loc)),
+ Expressions => Indexes),
+ Attribute_Name => Attr_Nam)),
+
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Standard_False, Loc)))));
- end Test_Component;
+ Expression => New_Occurrence_Of (Standard_False, Loc))));
+ end Validate_Component;
------------------------
- -- Test_One_Dimension --
+ -- Validate_Dimension --
------------------------
- function Test_One_Dimension (N : Int) return List_Id is
+ function Validate_Dimension
+ (Obj_Id : Entity_Id;
+ Dim : Int;
+ Indexes : List_Id) return Node_Id
+ is
Index : Entity_Id;
begin
- -- If all dimensions dealt with, we simply test the component
+ -- Validate the component once all dimensions have produced their
+ -- individual loops.
- if N > Number_Dimensions (A_Type) then
- return Test_Component;
+ if Dim > Number_Dimensions (Array_Typ) then
+ return Validate_Component (Obj_Id, Indexes);
- -- Here we generate the required loop
+ -- Process the current dimension
else
Index :=
- Make_Defining_Identifier (Loc, New_External_Name ('J', N));
+ Make_Defining_Identifier (Loc, New_External_Name ('J', Dim));
+
+ Append_To (Indexes, New_Occurrence_Of (Index, Loc));
- Append (New_Occurrence_Of (Index, Loc), Index_List);
+ -- Generate:
+ -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
+ -- for JN in Array_Typ (Obj_Id)'Range (N) loop
+ -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
+ -- end loop;
+ -- end loop;
- return New_List (
- Make_Implicit_Loop_Statement (Nod,
- Identifier => Empty,
+ return
+ Make_Implicit_Loop_Statement (Attr,
+ Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Index,
+ Defining_Identifier => Index,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_uA),
+ Prefix =>
+ Unchecked_Convert_To (Array_Typ,
+ New_Occurrence_Of (Obj_Id, Loc)),
Attribute_Name => Name_Range,
Expressions => New_List (
- Make_Integer_Literal (Loc, N))))),
- Statements => Test_One_Dimension (N + 1)),
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Standard_True, Loc)));
+ Make_Integer_Literal (Loc, Dim))))),
+ Statements => New_List (
+ Validate_Dimension (Obj_Id, Dim + 1, Indexes)));
end if;
- end Test_One_Dimension;
+ end Validate_Dimension;
+
+ -- Local variables
+
+ Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
+ Indexes : constant List_Id := New_List;
+ Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
+ Stmts : List_Id;
-- Start of processing for Build_Array_VS_Func
begin
- Index_List := New_List;
- Body_Stmts := Test_One_Dimension (1);
+ Stmts := New_List (Validate_Dimension (Obj_Id, 1, Indexes));
- -- Parameter is always (A : A_Typ)
+ -- Generate:
+ -- return True;
- Formals := New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA),
- In_Present => True,
- Out_Present => False,
- Parameter_Type => New_Occurrence_Of (A_Type, Loc)));
+ Append_To (Stmts,
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_True, Loc)));
- -- Build body
+ -- Generate:
+ -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
+ -- begin
+ -- Stmts
+ -- end Func_Id;
Set_Ekind (Func_Id, E_Function);
Set_Is_Internal (Func_Id);
+ Set_Is_Pure (Func_Id);
- Insert_Action (Nod,
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (Func_Id);
+ end if;
+
+ Insert_Action (Attr,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
- Parameter_Specifications => Formals,
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc)),
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Obj_Id,
+ In_Present => True,
+ Out_Present => False,
+ Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Body_Stmts)));
+ Statements => Stmts)));
- if not Debug_Generated_Code then
- Set_Debug_Info_Off (Func_Id);
- end if;
-
- Set_Is_Pure (Func_Id);
return Func_Id;
end Build_Array_VS_Func;
+ ---------------------------------
+ -- Build_Disp_Get_Task_Id_Call --
+ ---------------------------------
+
+ function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (Actual);
+ Typ : constant Entity_Id := Etype (Actual);
+ Subp : constant Entity_Id := Find_Prim_Op (Typ, Name_uDisp_Get_Task_Id);
+
+ begin
+ -- Generate:
+ -- _Disp_Get_Task_Id (Actual)
+
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Subp, Loc),
+ Parameter_Associations => New_List (Actual));
+ end Build_Disp_Get_Task_Id_Call;
+
--------------------------
-- Build_Record_VS_Func --
--------------------------
- -- Generates:
-
- -- function _Valid_Scalars (X : T) return Boolean is
- -- begin
- -- -- Check discriminants
-
- -- if not X.D1'Valid_Scalars or else
- -- not X.D2'Valid_Scalars or else
- -- ...
- -- then
- -- return False;
- -- end if;
-
- -- -- Check components
-
- -- if not X.C1'Valid_Scalars or else
- -- not X.C2'Valid_Scalars or else
- -- ...
- -- then
- -- return False;
- -- end if;
-
- -- -- Check variant part
-
- -- case X.D1 is
- -- when V1 =>
- -- if not X.C2'Valid_Scalars or else
- -- not X.C3'Valid_Scalars or else
- -- ...
- -- then
- -- return False;
- -- end if;
- -- ...
- -- when Vn =>
- -- if not X.Cn'Valid_Scalars or else
- -- ...
- -- then
- -- return False;
- -- end if;
- -- end case;
-
- -- return True;
- -- end _Valid_Scalars;
-
function Build_Record_VS_Func
- (R_Type : Entity_Id;
- Nod : Node_Id) return Entity_Id
+ (Attr : Node_Id;
+ Formal_Typ : Entity_Id;
+ Rec_Typ : Entity_Id) return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (R_Type);
- Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
- X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
-
- function Make_VS_Case
- (E : Entity_Id;
- CL : Node_Id;
- Discrs : Elist_Id := New_Elmt_List) return List_Id;
- -- Building block for variant valid scalars. Given a Component_List node
- -- CL, it generates an 'if' followed by a 'case' statement that compares
- -- all components of local temporaries named X and Y (that are declared
- -- as formals at some upper level). E provides the Sloc to be used for
- -- the generated code.
-
- function Make_VS_If
- (E : Entity_Id;
- L : List_Id) return Node_Id;
- -- Building block for variant validate scalars. Given the list, L, of
- -- components (or discriminants) L, it generates a return statement that
- -- compares all components of local temporaries named X and Y (that are
- -- declared as formals at some upper level). E provides the Sloc to be
- -- used for the generated code.
+ -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
+ -- It generates code only when there are components, discriminants,
+ -- or variant parts to validate.
+
+ -- NOTE: The routines within Build_Record_VS_Func are intentionally
+ -- unnested to avoid deep indentation of code.
+
+ Loc : constant Source_Ptr := Sloc (Attr);
+
+ procedure Validate_Component_List
+ (Obj_Id : Entity_Id;
+ Comp_List : Node_Id;
+ Stmts : in out List_Id);
+ -- Process all components and variant parts of component list Comp_List.
+ -- Obj_Id denotes the entity of the validation parameter. All new code
+ -- is added to list Stmts.
+
+ procedure Validate_Field
+ (Obj_Id : Entity_Id;
+ Field : Node_Id;
+ Cond : in out Node_Id);
+ -- Process component declaration or discriminant specification Field.
+ -- Obj_Id denotes the entity of the validation parameter. Cond denotes
+ -- an "or else" conditional expression which contains the new code (if
+ -- any).
+
+ procedure Validate_Fields
+ (Obj_Id : Entity_Id;
+ Fields : List_Id;
+ Stmts : in out List_Id);
+ -- Process component declarations or discriminant specifications in list
+ -- Fields. Obj_Id denotes the entity of the validation parameter. All
+ -- new code is added to list Stmts.
+
+ procedure Validate_Variant
+ (Obj_Id : Entity_Id;
+ Var : Node_Id;
+ Alts : in out List_Id);
+ -- Process variant Var. Obj_Id denotes the entity of the validation
+ -- parameter. Alts denotes a list of case statement alternatives which
+ -- contains the new code (if any).
+
+ procedure Validate_Variant_Part
+ (Obj_Id : Entity_Id;
+ Var_Part : Node_Id;
+ Stmts : in out List_Id);
+ -- Process variant part Var_Part. Obj_Id denotes the entity of the
+ -- validation parameter. All new code is added to list Stmts.
- ------------------
- -- Make_VS_Case --
- ------------------
+ -----------------------------
+ -- Validate_Component_List --
+ -----------------------------
- -- <Make_VS_If on shared components>
+ procedure Validate_Component_List
+ (Obj_Id : Entity_Id;
+ Comp_List : Node_Id;
+ Stmts : in out List_Id)
+ is
+ Var_Part : constant Node_Id := Variant_Part (Comp_List);
- -- case X.D1 is
- -- when V1 => <Make_VS_Case> on subcomponents
- -- ...
- -- when Vn => <Make_VS_Case> on subcomponents
- -- end case;
+ begin
+ -- Validate all components
- function Make_VS_Case
- (E : Entity_Id;
- CL : Node_Id;
- Discrs : Elist_Id := New_Elmt_List) return List_Id
+ Validate_Fields
+ (Obj_Id => Obj_Id,
+ Fields => Component_Items (Comp_List),
+ Stmts => Stmts);
+
+ -- Validate the variant part
+
+ if Present (Var_Part) then
+ Validate_Variant_Part
+ (Obj_Id => Obj_Id,
+ Var_Part => Var_Part,
+ Stmts => Stmts);
+ end if;
+ end Validate_Component_List;
+
+ --------------------
+ -- Validate_Field --
+ --------------------
+
+ procedure Validate_Field
+ (Obj_Id : Entity_Id;
+ Field : Node_Id;
+ Cond : in out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (E);
- Result : constant List_Id := New_List;
- Variant : Node_Id;
- Alt_List : List_Id;
+ Field_Id : constant Entity_Id := Defining_Entity (Field);
+ Field_Nam : constant Name_Id := Chars (Field_Id);
+ Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id));
+ Attr_Nam : Name_Id;
begin
- Append_To (Result, Make_VS_If (E, Component_Items (CL)));
+ -- Do not process internally-generated fields. Note that checking for
+ -- Comes_From_Source is not correct because this will eliminate the
+ -- components within the corresponding record of a protected type.
- if No (Variant_Part (CL)) then
- return Result;
- end if;
+ if Nam_In (Field_Nam, Name_uObject,
+ Name_uParent,
+ Name_uTag)
+ then
+ null;
+
+ -- Do not process fields without any scalar components
+
+ elsif not Scalar_Part_Present (Field_Typ) then
+ null;
+
+ -- Otherwise the field needs to be validated. Use Make_Identifier
+ -- rather than New_Occurrence_Of to identify the field because the
+ -- wrong entity may be picked up when private types are involved.
+
+ -- Generate:
+ -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
- Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
+ else
+ if Is_Scalar_Type (Field_Typ) then
+ Attr_Nam := Name_Valid;
+ else
+ Attr_Nam := Name_Valid_Scalars;
+ end if;
- if No (Variant) then
- return Result;
+ Evolve_Or_Else (Cond,
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Rec_Typ,
+ New_Occurrence_Of (Obj_Id, Loc)),
+ Selector_Name => Make_Identifier (Loc, Field_Nam)),
+ Attribute_Name => Attr_Nam)));
end if;
+ end Validate_Field;
- Alt_List := New_List;
- while Present (Variant) loop
- Append_To (Alt_List,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
- Statements =>
- Make_VS_Case (E, Component_List (Variant), Discrs)));
- Next_Non_Pragma (Variant);
- end loop;
+ ---------------------
+ -- Validate_Fields --
+ ---------------------
- Append_To (Result,
- Make_Case_Statement (Loc,
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_X),
- Selector_Name => New_Copy (Name (Variant_Part (CL)))),
- Alternatives => Alt_List));
+ procedure Validate_Fields
+ (Obj_Id : Entity_Id;
+ Fields : List_Id;
+ Stmts : in out List_Id)
+ is
+ Cond : Node_Id;
+ Field : Node_Id;
- return Result;
- end Make_VS_Case;
+ begin
+ -- Assume that none of the fields are eligible for verification
- ----------------
- -- Make_VS_If --
- ----------------
+ Cond := Empty;
+
+ -- Validate all fields
- -- Generates:
+ Field := First_Non_Pragma (Fields);
+ while Present (Field) loop
+ Validate_Field
+ (Obj_Id => Obj_Id,
+ Field => Field,
+ Cond => Cond);
- -- if
- -- not X.C1'Valid_Scalars
- -- or else
- -- not X.C2'Valid_Scalars
- -- ...
- -- then
- -- return False;
- -- end if;
+ Next_Non_Pragma (Field);
+ end loop;
- -- or a null statement if the list L is empty
+ -- Generate:
+ -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
+ -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
- function Make_VS_If
- (E : Entity_Id;
- L : List_Id) return Node_Id
+ if Present (Cond) then
+ Append_New_To (Stmts,
+ Make_Implicit_If_Statement (Attr,
+ Condition => Cond,
+ Then_Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_False, Loc)))));
+ end if;
+ end Validate_Fields;
+
+ ----------------------
+ -- Validate_Variant --
+ ----------------------
+
+ procedure Validate_Variant
+ (Obj_Id : Entity_Id;
+ Var : Node_Id;
+ Alts : in out List_Id)
is
- Loc : constant Source_Ptr := Sloc (E);
- C : Node_Id;
- Def_Id : Entity_Id;
- Field_Name : Name_Id;
- Cond : Node_Id;
+ Stmts : List_Id;
begin
- if No (L) then
- return Make_Null_Statement (Loc);
+ -- Assume that none of the components and variants are eligible for
+ -- verification.
- else
- Cond := Empty;
-
- C := First_Non_Pragma (L);
- while Present (C) loop
- Def_Id := Defining_Identifier (C);
- Field_Name := Chars (Def_Id);
+ Stmts := No_List;
- -- The tags need not be checked since they will always be valid
+ -- Validate components
- -- Note also that in the following, we use Make_Identifier for
- -- the component names. Use of New_Occurrence_Of to identify
- -- the components would be incorrect because wrong entities for
- -- discriminants could be picked up in the private type case.
+ Validate_Component_List
+ (Obj_Id => Obj_Id,
+ Comp_List => Component_List (Var),
+ Stmts => Stmts);
- -- Don't bother with abstract parent in interface case
+ -- Generate a null statement in case none of the components were
+ -- verified because this will otherwise eliminate an alternative
+ -- from the variant case statement and render the generated code
+ -- illegal.
- if Field_Name = Name_uParent
- and then Is_Interface (Etype (Def_Id))
- then
- null;
+ if No (Stmts) then
+ Append_New_To (Stmts, Make_Null_Statement (Loc));
+ end if;
- -- Don't bother with tag, always valid, and not scalar anyway
+ -- Generate:
+ -- when Discrete_Choices =>
+ -- Stmts
+
+ Append_New_To (Alts,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices =>
+ New_Copy_List_Tree (Discrete_Choices (Var)),
+ Statements => Stmts));
+ end Validate_Variant;
+
+ ---------------------------
+ -- Validate_Variant_Part --
+ ---------------------------
+
+ procedure Validate_Variant_Part
+ (Obj_Id : Entity_Id;
+ Var_Part : Node_Id;
+ Stmts : in out List_Id)
+ is
+ Vars : constant List_Id := Variants (Var_Part);
+ Alts : List_Id;
+ Var : Node_Id;
- elsif Field_Name = Name_uTag then
- null;
+ begin
+ -- Assume that none of the variants are eligible for verification
- -- Don't bother with component with no scalar components
+ Alts := No_List;
- elsif not Scalar_Part_Present (Etype (Def_Id)) then
- null;
+ -- Validate variants
- -- Normal case, generate Valid_Scalars attribute reference
+ Var := First_Non_Pragma (Vars);
+ while Present (Var) loop
+ Validate_Variant
+ (Obj_Id => Obj_Id,
+ Var => Var,
+ Alts => Alts);
- else
- Evolve_Or_Else (Cond,
- Make_Op_Not (Loc,
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_X),
- Selector_Name =>
- Make_Identifier (Loc, Field_Name)),
- Attribute_Name => Name_Valid_Scalars)));
- end if;
+ Next_Non_Pragma (Var);
+ end loop;
- Next_Non_Pragma (C);
- end loop;
+ -- Even though individual variants may lack eligible components, the
+ -- alternatives must still be generated.
- if No (Cond) then
- return Make_Null_Statement (Loc);
+ pragma Assert (Present (Alts));
- else
- return
- Make_Implicit_If_Statement (E,
- Condition => Cond,
- Then_Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression =>
- New_Occurrence_Of (Standard_False, Loc))));
- end if;
- end if;
- end Make_VS_If;
+ -- Generate:
+ -- case Rec_Typ (Obj_Id).Discriminant is
+ -- when Discrete_Choices_1 =>
+ -- Stmts_1
+ -- when Discrete_Choices_N =>
+ -- Stmts_N
+ -- end case;
+
+ Append_New_To (Stmts,
+ Make_Case_Statement (Loc,
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Rec_Typ,
+ New_Occurrence_Of (Obj_Id, Loc)),
+ Selector_Name => New_Copy_Tree (Name (Var_Part))),
+ Alternatives => Alts));
+ end Validate_Variant_Part;
-- Local variables
- Def : constant Node_Id := Parent (R_Type);
- Comps : constant Node_Id := Component_List (Type_Definition (Def));
- Stmts : constant List_Id := New_List;
- Pspecs : constant List_Id := New_List;
+ Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
+ Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
+ Comps : Node_Id;
+ Stmts : List_Id;
+ Typ : Entity_Id;
+ Typ_Decl : Node_Id;
+ Typ_Def : Node_Id;
+ Typ_Ext : Node_Id;
-- Start of processing for Build_Record_VS_Func
begin
- Append_To (Pspecs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => X,
- Parameter_Type => New_Occurrence_Of (R_Type, Loc)));
+ Typ := Rec_Typ;
- Append_To (Stmts,
- Make_VS_If (R_Type, Discriminant_Specifications (Def)));
- Append_List_To (Stmts, Make_VS_Case (R_Type, Comps));
+ -- Use the root type when dealing with a class-wide type
- Append_To (Stmts,
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ_Decl := Declaration_Node (Typ);
+ Typ_Def := Type_Definition (Typ_Decl);
+
+ -- The components of a derived type are located in the extension part
+
+ if Nkind (Typ_Def) = N_Derived_Type_Definition then
+ Typ_Ext := Record_Extension_Part (Typ_Def);
+
+ if Present (Typ_Ext) then
+ Comps := Component_List (Typ_Ext);
+ else
+ Comps := Empty;
+ end if;
+
+ -- Otherwise the components are available in the definition
+
+ else
+ Comps := Component_List (Typ_Def);
+ end if;
+
+ -- The code generated by this routine is as follows:
+ --
+ -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
+ -- begin
+ -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
+ -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
+ --
+ -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
+ -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
+ --
+ -- case Discriminant_1 is
+ -- when Choice_1 =>
+ -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
+ -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
+ -- then
+ -- return False;
+ -- end if;
+ --
+ -- case Discriminant_N is
+ -- ...
+ -- when Choice_N =>
+ -- ...
+ -- end case;
+ --
+ -- return True;
+ -- end Func_Id;
+
+ -- Assume that the record type lacks eligible components, discriminants,
+ -- and variant parts.
+
+ Stmts := No_List;
+
+ -- Validate the discriminants
+
+ if not Is_Unchecked_Union (Rec_Typ) then
+ Validate_Fields
+ (Obj_Id => Obj_Id,
+ Fields => Discriminant_Specifications (Typ_Decl),
+ Stmts => Stmts);
+ end if;
+
+ -- Validate the components and variant parts
+
+ Validate_Component_List
+ (Obj_Id => Obj_Id,
+ Comp_List => Comps,
+ Stmts => Stmts);
+
+ -- Generate:
+ -- return True;
+
+ Append_New_To (Stmts,
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)));
- Insert_Action (Nod,
+ -- Generate:
+ -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
+ -- begin
+ -- Stmts
+ -- end Func_Id;
+
+ Set_Ekind (Func_Id, E_Function);
+ Set_Is_Internal (Func_Id);
+ Set_Is_Pure (Func_Id);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (Func_Id);
+ end if;
+
+ Insert_Action (Attr,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
- Parameter_Specifications => Pspecs,
- Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Obj_Id,
+ Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)),
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts)),
Suppress => Discriminant_Check);
- if not Debug_Generated_Code then
- Set_Debug_Info_Off (Func_Id);
- end if;
-
- Set_Is_Pure (Func_Id);
return Func_Id;
end Build_Record_VS_Func;
-- Local variables
- Exprs : constant List_Id := Expressions (N);
Pref : constant Node_Id := Prefix (N);
- Typ : constant Entity_Id := Etype (Pref);
- Blk : Node_Id;
- CW_Decl : Node_Id;
- CW_Temp : Entity_Id;
- CW_Typ : Entity_Id;
+ Base_Typ : constant Entity_Id := Base_Type (Etype (Pref));
+ Exprs : constant List_Id := Expressions (N);
+ Aux_Decl : Node_Id;
+ Blk : Node_Id := Empty;
Decls : List_Id;
Installed : Boolean;
Loc : Source_Ptr;
Loop_Id : Entity_Id;
Loop_Stmt : Node_Id;
- Result : Node_Id;
+ Result : Node_Id := Empty;
Scheme : Node_Id;
Temp_Decl : Node_Id;
Temp_Id : Entity_Id;
Loop_Id := Entity (First (Exprs));
Loop_Stmt := Label_Construct (Parent (Loop_Id));
- -- Climb the parent chain to find the nearest enclosing loop. Skip all
- -- internally generated loops for quantified expressions and for
- -- element iterators over multidimensional arrays: pragma applies to
- -- source loop.
+ -- Climb the parent chain to find the nearest enclosing loop. Skip
+ -- all internally generated loops for quantified expressions and for
+ -- element iterators over multidimensional arrays because the pragma
+ -- applies to source loop.
else
Loop_Stmt := N;
while Present (Loop_Stmt) loop
if Nkind (Loop_Stmt) = N_Loop_Statement
- and then Comes_From_Source (Loop_Stmt)
+ and then Nkind (Original_Node (Loop_Stmt)) = N_Loop_Statement
+ and then Comes_From_Source (Original_Node (Loop_Stmt))
then
exit;
end if;
Decls := Declarations (Parent (Parent (Loop_Stmt)));
end if;
- Result := Empty;
-
-- Transform the loop into a conditional block
else
Stmts : List_Id;
begin
+ Func_Id := Make_Temporary (Loc, 'F');
+
-- Wrap the condition of the while loop in a Boolean function.
-- This avoids the duplication of the same code which may lead
-- to gigi issues with respect to multiple declaration of the
-- same entity in the presence of side effects or checks. Note
- -- that the condition actions must also be relocated to the
- -- wrapping function.
+ -- that the condition actions must also be relocated into the
+ -- wrapping function because they may contain itypes, e.g. in
+ -- the case of a comparison involving slices.
-- Generate:
-- <condition actions>
Append_To (Stmts,
Make_Simple_Return_Statement (Loc,
- Expression => Relocate_Node (Condition (Scheme))));
+ Expression =>
+ New_Copy_Tree (Condition (Scheme),
+ New_Scope => Func_Id)));
-- Generate:
-- function Fnn return Boolean is
-- <Stmts>
-- end Fnn;
- Func_Id := Make_Temporary (Loc, 'F');
Func_Decl :=
Make_Subprogram_Body (Loc,
Specification =>
Insert_Action (Loop_Stmt, Func_Decl);
Pop_Scope;
+ -- The analysis of the condition may have generated itypes
+ -- that are now used within the function: Adjust their
+ -- scopes accordingly so that their use appears in their
+ -- scope of definition.
+
+ declare
+ Ityp : Entity_Id;
+
+ begin
+ Ityp := First_Entity (Loop_Id);
+
+ while Present (Ityp) loop
+ if Is_Itype (Ityp) then
+ Set_Scope (Ityp, Func_Id);
+ end if;
+ Next_Entity (Ityp);
+ end loop;
+ end;
+
-- Transform the original while loop into an infinite loop
-- where the last statement checks the negated condition. This
-- placement ensures that the condition will not be evaluated
-- Preserve the tag of the prefix by offering a specific view of the
-- class-wide version of the prefix.
- if Is_Tagged_Type (Typ) then
+ if Is_Tagged_Type (Base_Typ) then
+ Tagged_Case : declare
+ CW_Temp : Entity_Id;
+ CW_Typ : Entity_Id;
- -- Generate:
- -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
+ begin
+ -- Generate:
+ -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
- CW_Temp := Make_Temporary (Loc, 'T');
- CW_Typ := Class_Wide_Type (Typ);
+ CW_Temp := Make_Temporary (Loc, 'T');
+ CW_Typ := Class_Wide_Type (Base_Typ);
- CW_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => CW_Temp,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
- Expression =>
- Convert_To (CW_Typ, Relocate_Node (Pref)));
- Append_To (Decls, CW_Decl);
+ Aux_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => CW_Temp,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
+ Expression =>
+ Convert_To (CW_Typ, Relocate_Node (Pref)));
+ Append_To (Decls, Aux_Decl);
- -- Generate:
- -- Temp : Typ renames Typ (CW_Temp);
+ -- Generate:
+ -- Temp : Base_Typ renames Base_Typ (CW_Temp);
- Temp_Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Name =>
- Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)));
- Append_To (Decls, Temp_Decl);
+ Temp_Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Subtype_Mark => New_Occurrence_Of (Base_Typ, Loc),
+ Name =>
+ Convert_To (Base_Typ, New_Occurrence_Of (CW_Temp, Loc)));
+ Append_To (Decls, Temp_Decl);
+ end Tagged_Case;
- -- Non-tagged case
+ -- Untagged case
else
- CW_Decl := Empty;
+ Untagged_Case : declare
+ Temp_Expr : Node_Id;
- -- Generate:
- -- Temp : constant Typ := Pref;
+ begin
+ Aux_Decl := Empty;
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression => Relocate_Node (Pref));
- Append_To (Decls, Temp_Decl);
+ -- Generate a nominal type for the constant when the prefix is of
+ -- a constrained type. This is achieved by setting the Etype of
+ -- the relocated prefix to its base type. Since the prefix is now
+ -- the initialization expression of the constant, its freezing
+ -- will produce a proper nominal type.
+
+ Temp_Expr := Relocate_Node (Pref);
+ Set_Etype (Temp_Expr, Base_Typ);
+
+ -- Generate:
+ -- Temp : constant Base_Typ := Pref;
+
+ Temp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Base_Typ, Loc),
+ Expression => Temp_Expr);
+ Append_To (Decls, Temp_Decl);
+ end Untagged_Case;
end if;
-- Step 4: Analyze all bits
-- the declaration of the constant.
else
- if Present (CW_Decl) then
- Analyze (CW_Decl);
+ if Present (Aux_Decl) then
+ Analyze (Aux_Decl);
end if;
Analyze (Temp_Decl);
-- generate conditionals in the code, so check the relevant restriction.
Check_Restriction (No_Implicit_Conditionals, N);
-
- -- In Modify_Tree_For_C mode, we rewrite as an if expression
-
- if Modify_Tree_For_C then
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Expr : constant Node_Id := First (Expressions (N));
- Left : constant Node_Id := Relocate_Node (Expr);
- Right : constant Node_Id := Relocate_Node (Next (Expr));
-
- function Make_Compare (Left, Right : Node_Id) return Node_Id;
- -- Returns Left >= Right for Max, Left <= Right for Min
-
- ------------------
- -- Make_Compare --
- ------------------
-
- function Make_Compare (Left, Right : Node_Id) return Node_Id is
- begin
- if Attribute_Name (N) = Name_Max then
- return
- Make_Op_Ge (Loc,
- Left_Opnd => Left,
- Right_Opnd => Right);
- else
- return
- Make_Op_Le (Loc,
- Left_Opnd => Left,
- Right_Opnd => Right);
- end if;
- end Make_Compare;
-
- -- Start of processing for Min_Max
-
- begin
- -- If both Left and Right are side effect free, then we can just
- -- use Duplicate_Expr to duplicate the references and return
-
- -- (if Left >=|<= Right then Left else Right)
-
- if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then
- Rewrite (N,
- Make_If_Expression (Loc,
- Expressions => New_List (
- Make_Compare (Left, Right),
- Duplicate_Subexpr_No_Checks (Left),
- Duplicate_Subexpr_No_Checks (Right))));
-
- -- Otherwise we generate declarations to capture the values.
-
- -- The translation is
-
- -- do
- -- T1 : constant typ := Left;
- -- T2 : constant typ := Right;
- -- in
- -- (if T1 >=|<= T2 then T1 else T2)
- -- end;
-
- else
- declare
- T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
- T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Right);
-
- begin
- Rewrite (N,
- Make_Expression_With_Actions (Loc,
- Actions => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => T1,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Etype (Left), Loc),
- Expression => Relocate_Node (Left)),
-
- Make_Object_Declaration (Loc,
- Defining_Identifier => T2,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Etype (Right), Loc),
- Expression => Relocate_Node (Right))),
-
- Expression =>
- Make_If_Expression (Loc,
- Expressions => New_List (
- Make_Compare
- (New_Occurrence_Of (T1, Loc),
- New_Occurrence_Of (T2, Loc)),
- New_Occurrence_Of (T1, Loc),
- New_Occurrence_Of (T2, Loc)))));
- end;
- end if;
-
- Analyze_And_Resolve (N, Typ);
- end;
- end if;
end Expand_Min_Max_Attribute;
----------------------------------
procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
Item : constant Node_Id := Next (First (Exprs));
+ Item_Typ : constant Entity_Id := Etype (Item);
Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
Formal_Typ : constant Entity_Id := Etype (Formal);
- Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
+ Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter;
begin
-- The expansion depends on Item, the second actual, which is
if Nkind (Item) = N_Indexed_Component
and then Is_Packed (Base_Type (Etype (Prefix (Item))))
- and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
+ and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
and then Is_Written
then
declare
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Formal_Typ, Loc));
+ Object_Definition => New_Occurrence_Of (Formal_Typ, Loc));
Set_Etype (Temp, Formal_Typ);
Assn :=
Make_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Item),
+ Name => New_Copy_Tree (Item),
Expression =>
Unchecked_Convert_To
- (Etype (Item), New_Occurrence_Of (Temp, Loc)));
+ (Item_Typ, New_Occurrence_Of (Temp, Loc)));
Rewrite (Item, New_Occurrence_Of (Temp, Loc));
Insert_Actions (N,
New_List (
Decl,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Pname, Loc),
+ Name => New_Occurrence_Of (Pname, Loc),
Parameter_Associations => Exprs),
Assn));
-- operation is not inherited), we are all set, and can use the
-- argument unchanged.
- -- For all other cases we do an unchecked conversion of the second
- -- parameter to the type of the formal of the procedure we are
- -- calling. This deals with the private type cases, and with going
- -- to the root type as required in elementary type case.
-
if not Is_Class_Wide_Type (Entity (Pref))
and then not Is_Class_Wide_Type (Etype (Item))
- and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
+ and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
then
- Rewrite (Item,
- Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
+ -- Perform a view conversion when either the argument or the
+ -- formal parameter are of a private type.
+
+ if Is_Private_Type (Base_Type (Formal_Typ))
+ or else Is_Private_Type (Base_Type (Item_Typ))
+ then
+ Rewrite (Item,
+ Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
+
+ -- Otherwise perform a regular type conversion to ensure that all
+ -- relevant checks are installed.
+
+ else
+ Rewrite (Item, Convert_To (Formal_Typ, Relocate_Node (Item)));
+ end if;
-- For untagged derived types set Assignment_OK, to prevent
-- copies from being created when the unchecked conversion
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Pname, Loc),
+ Name => New_Occurrence_Of (Pname, Loc),
Parameter_Associations => Exprs));
Analyze (N);
-- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
-- place function, then a temporary return object needs to be created
- -- and access to it must be passed to the function. Currently we limit
- -- such functions to those with inherently limited result subtypes, but
- -- eventually we plan to expand the functions that are treated as
- -- build-in-place to include other composite result types.
+ -- and access to it must be passed to the function.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Pref)
- then
- Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
+ if Is_Build_In_Place_Function_Call (Pref) then
+
+ -- If attribute is 'Old, the context is a postcondition, and
+ -- the temporary must go in the corresponding subprogram, not
+ -- the postcondition function or any created blocks, as when
+ -- the attribute appears in a quantified expression. This is
+ -- handled below in the expansion of the attribute.
+
+ if Attribute_Name (Parent (Pref)) = Name_Old then
+ null;
+ else
+ Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
+ end if;
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
end if;
-- If prefix is a protected type name, this is a reference to the
-- Attributes related to Ada 2012 iterators
- when Attribute_Constant_Indexing |
- Attribute_Default_Iterator |
- Attribute_Implicit_Dereference |
- Attribute_Iterable |
- Attribute_Iterator_Element |
- Attribute_Variable_Indexing =>
+ when Attribute_Constant_Indexing
+ | Attribute_Default_Iterator
+ | Attribute_Implicit_Dereference
+ | Attribute_Iterable
+ | Attribute_Iterator_Element
+ | Attribute_Variable_Indexing
+ =>
null;
-- Internal attributes used to deal with Ada 2012 delayed aspects. These
-- Access --
------------
- when Attribute_Access |
- Attribute_Unchecked_Access |
- Attribute_Unrestricted_Access =>
-
+ when Attribute_Access
+ | Attribute_Unchecked_Access
+ | Attribute_Unrestricted_Access
+ =>
Access_Cases : declare
Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
Btyp_DDT : Entity_Id;
Next_Formal (Old_Formal);
exit when No (Old_Formal);
- Set_Next_Entity (New_Formal,
- New_Copy (Old_Formal));
- Next_Entity (New_Formal);
+ Link_Entities (New_Formal, New_Copy (Old_Formal));
+ Next_Entity (New_Formal);
end loop;
- Set_Next_Entity (New_Formal, Empty);
+ Unlink_Next_Entity (New_Formal);
Set_Last_Entity (Subp_Typ, Extra);
end if;
(Etype (Prefix (Ref_Object))));
begin
-- No implicit conversion required if designated types
- -- match, or if we have an unrestricted access.
+ -- match.
if Obj_DDT /= Btyp_DDT
- and then Id /= Attribute_Unrestricted_Access
and then not (Is_Class_Wide_Type (Obj_DDT)
and then Etype (Obj_DDT) = Btyp_DDT)
then
when Attribute_Address => Address : declare
Task_Proc : Entity_Id;
+ function Is_Unnested_Component_Init (N : Node_Id) return Boolean;
+ -- Returns True if N is being used to initialize a component of
+ -- an activation record object where the component corresponds to
+ -- the object denoted by the prefix of the attribute N.
+
+ function Is_Unnested_Component_Init (N : Node_Id) return Boolean is
+ begin
+ return Present (Parent (N))
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ and then Is_Entity_Name (Pref)
+ and then Present (Activation_Record_Component (Entity (Pref)))
+ and then Nkind (Name (Parent (N))) = N_Selected_Component
+ and then Entity (Selector_Name (Name (Parent (N)))) =
+ Activation_Record_Component (Entity (Pref));
+ end Is_Unnested_Component_Init;
+
+ -- Start of processing for Address
+
begin
-- If the prefix is a task or a task type, the useful address is that
-- of the procedure for the task body, i.e. the actual program unit.
-- "displaced" to reference the tag associated with the interface
-- type. In order to obtain the real address of such objects we
-- generate a call to a run-time subprogram that returns the base
- -- address of the object.
-
- -- This processing is not needed in the VM case, where dispatching
- -- issues are taken care of by the virtual machine.
+ -- address of the object. This call is not generated in cases where
+ -- the attribute is being used to initialize a component of an
+ -- activation record object where the component corresponds to
+ -- prefix of the attribute (for back ends that require "unnesting"
+ -- of nested subprograms), since the address needs to be assigned
+ -- as-is to such components.
elsif Is_Class_Wide_Type (Ptyp)
- and then Is_Interface (Ptyp)
+ and then Is_Interface (Underlying_Type (Ptyp))
and then Tagged_Type_Expansion
and then not (Nkind (Pref) in N_Has_Entity
and then Is_Subprogram (Entity (Pref)))
+ and then not Is_Unnested_Component_Init (N)
then
Rewrite (N,
Make_Function_Call (Loc,
New_Node := Build_Get_Alignment (Loc, New_Node);
+ -- Case where the context is an unchecked conversion to a specific
+ -- integer type. We directly convert from the alignment's type.
+
+ if Nkind (Parent (N)) = N_Unchecked_Type_Conversion then
+ Rewrite (N, New_Node);
+ Analyze_And_Resolve (N);
+ return;
+
-- Case where the context is a specific integer type with which
- -- the original attribute was compatible. The function has a
- -- specific type as well, so to preserve the compatibility we
- -- must convert explicitly.
+ -- the original attribute was compatible. But the alignment has a
+ -- specific type in a-tags.ads (Standard.Natural) so, in order to
+ -- preserve type compatibility, we must convert explicitly.
- if Typ /= Standard_Integer then
+ elsif Typ /= Standard_Natural then
New_Node := Convert_To (Typ, New_Node);
end if;
-- A special exception occurs for Standard, where the string returned
-- is a copy of the library string in gnatvsn.ads.
- when Attribute_Body_Version | Attribute_Version => Version : declare
- E : constant Entity_Id := Make_Temporary (Loc, 'V');
- Pent : Entity_Id;
- S : String_Id;
+ when Attribute_Body_Version
+ | Attribute_Version
+ =>
+ Version : declare
+ E : constant Entity_Id := Make_Temporary (Loc, 'V');
+ Pent : Entity_Id;
+ S : String_Id;
- begin
- -- If not library unit, get to containing library unit
-
- Pent := Entity (Pref);
- while Pent /= Standard_Standard
- and then Scope (Pent) /= Standard_Standard
- and then not Is_Child_Unit (Pent)
- loop
- Pent := Scope (Pent);
- end loop;
+ begin
+ -- If not library unit, get to containing library unit
+
+ Pent := Entity (Pref);
+ while Pent /= Standard_Standard
+ and then Scope (Pent) /= Standard_Standard
+ and then not Is_Child_Unit (Pent)
+ loop
+ Pent := Scope (Pent);
+ end loop;
- -- Special case Standard and Standard.ASCII
+ -- Special case Standard and Standard.ASCII
- if Pent = Standard_Standard or else Pent = Standard_ASCII then
- Rewrite (N,
- Make_String_Literal (Loc,
- Strval => Verbose_Library_Version));
+ if Pent = Standard_Standard or else Pent = Standard_ASCII then
+ Rewrite (N,
+ Make_String_Literal (Loc,
+ Strval => Verbose_Library_Version));
- -- All other cases
+ -- All other cases
- else
- -- Build required string constant
+ else
+ -- Build required string constant
- Get_Name_String (Get_Unit_Name (Pent));
+ Get_Name_String (Get_Unit_Name (Pent));
- Start_String;
- for J in 1 .. Name_Len - 2 loop
- if Name_Buffer (J) = '.' then
- Store_String_Chars ("__");
- else
- Store_String_Char (Get_Char_Code (Name_Buffer (J)));
- end if;
- end loop;
+ Start_String;
+ for J in 1 .. Name_Len - 2 loop
+ if Name_Buffer (J) = '.' then
+ Store_String_Chars ("__");
+ else
+ Store_String_Char (Get_Char_Code (Name_Buffer (J)));
+ end if;
+ end loop;
- -- Case of subprogram acting as its own spec, always use body
+ -- Case of subprogram acting as its own spec, always use body
- if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
- and then Nkind (Parent (Declaration_Node (Pent))) =
- N_Subprogram_Body
- and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
- then
- Store_String_Chars ("B");
+ if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
+ and then Nkind (Parent (Declaration_Node (Pent))) =
+ N_Subprogram_Body
+ and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
+ then
+ Store_String_Chars ("B");
- -- Case of no body present, always use spec
+ -- Case of no body present, always use spec
- elsif not Unit_Requires_Body (Pent) then
- Store_String_Chars ("S");
+ elsif not Unit_Requires_Body (Pent) then
+ Store_String_Chars ("S");
- -- Otherwise use B for Body_Version, S for spec
+ -- Otherwise use B for Body_Version, S for spec
- elsif Id = Attribute_Body_Version then
- Store_String_Chars ("B");
- else
- Store_String_Chars ("S");
- end if;
+ elsif Id = Attribute_Body_Version then
+ Store_String_Chars ("B");
+ else
+ Store_String_Chars ("S");
+ end if;
- S := End_String;
- Lib.Version_Referenced (S);
+ S := End_String;
+ Lib.Version_Referenced (S);
- -- Insert the object declaration
+ -- Insert the object declaration
- Insert_Actions (N, New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => E,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
+ Insert_Actions (N, New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => E,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
- -- Set entity as imported with correct external name
+ -- Set entity as imported with correct external name
- Set_Is_Imported (E);
- Set_Interface_Name (E, Make_String_Literal (Loc, S));
+ Set_Is_Imported (E);
+ Set_Interface_Name (E, Make_String_Literal (Loc, S));
- -- Set entity as internal to ensure proper Sprint output of its
- -- implicit importation.
+ -- Set entity as internal to ensure proper Sprint output of its
+ -- implicit importation.
- Set_Is_Internal (E);
+ Set_Is_Internal (E);
- -- And now rewrite original reference
+ -- And now rewrite original reference
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (E, Loc))));
- end if;
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (E, Loc))));
+ end if;
- Analyze_And_Resolve (N, RTE (RE_Version_String));
- end Version;
+ Analyze_And_Resolve (N, RTE (RE_Version_String));
+ end Version;
-------------
-- Ceiling --
-- Transforms 'Callable attribute into a call to the Callable function
- when Attribute_Callable => Callable :
- begin
+ when Attribute_Callable =>
+
-- We have an object of a task interface class-wide type as a prefix
-- to Callable. Generate:
-- callable (Task_Id (Pref._disp_get_task_id));
then
Rewrite (N,
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Callable), Loc),
Parameter_Associations => New_List (
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Pref),
- Selector_Name =>
- Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
+ Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
else
- Rewrite (N,
- Build_Call_With_Task (Pref, RTE (RE_Callable)));
+ Rewrite (N, Build_Call_With_Task (Pref, RTE (RE_Callable)));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
- end Callable;
------------
-- Caller --
when Attribute_Constrained => Constrained : declare
Formal_Ent : constant Entity_Id := Param_Entity (Pref);
- function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
- -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
- -- view of an aliased object whose subtype is constrained.
-
- ---------------------------------
- -- Is_Constrained_Aliased_View --
- ---------------------------------
-
- function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
- E : Entity_Id;
-
- begin
- if Is_Entity_Name (Obj) then
- E := Entity (Obj);
-
- if Present (Renamed_Object (E)) then
- return Is_Constrained_Aliased_View (Renamed_Object (E));
- else
- return Is_Aliased (E) and then Is_Constrained (Etype (E));
- end if;
-
- else
- return Is_Aliased_View (Obj)
- and then
- (Is_Constrained (Etype (Obj))
- or else
- (Nkind (Obj) = N_Explicit_Dereference
- and then
- not Object_Type_Has_Constrained_Partial_View
- (Typ => Base_Type (Etype (Obj)),
- Scop => Current_Scope)));
- end if;
- end Is_Constrained_Aliased_View;
-
-- Start of processing for Constrained
begin
New_Occurrence_Of
(Extra_Constrained (Formal_Ent), Sloc (N)));
+ -- If the prefix is an access to object, the attribute applies to
+ -- the designated object, so rewrite with an explicit dereference.
+
+ elsif Is_Access_Type (Etype (Pref))
+ and then
+ (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
+ then
+ Rewrite (Pref,
+ Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
+ Analyze_And_Resolve (N, Standard_Boolean);
+ return;
+
-- For variables with a Extra_Constrained field, we use the
-- corresponding entity.
New_Occurrence_Of
(Extra_Constrained (Entity (Pref)), Sloc (N)));
- -- For all other entity names, we can tell at compile time
-
- elsif Is_Entity_Name (Pref) then
- declare
- Ent : constant Entity_Id := Entity (Pref);
- Res : Boolean;
-
- begin
- -- (RM J.4) obsolescent cases
-
- if Is_Type (Ent) then
-
- -- Private type
-
- if Is_Private_Type (Ent) then
- Res := not Has_Discriminants (Ent)
- or else Is_Constrained (Ent);
-
- -- It not a private type, must be a generic actual type
- -- that corresponded to a private type. We know that this
- -- correspondence holds, since otherwise the reference
- -- within the generic template would have been illegal.
-
- else
- if Is_Composite_Type (Underlying_Type (Ent)) then
- Res := Is_Constrained (Ent);
- else
- Res := True;
- end if;
- end if;
-
- -- If the prefix is not a variable or is aliased, then
- -- definitely true; if it's a formal parameter without an
- -- associated extra formal, then treat it as constrained.
-
- -- Ada 2005 (AI-363): An aliased prefix must be known to be
- -- constrained in order to set the attribute to True.
-
- elsif not Is_Variable (Pref)
- or else Present (Formal_Ent)
- or else (Ada_Version < Ada_2005
- and then Is_Aliased_View (Pref))
- or else (Ada_Version >= Ada_2005
- and then Is_Constrained_Aliased_View (Pref))
- then
- Res := True;
-
- -- Variable case, look at type to see if it is constrained.
- -- Note that the one case where this is not accurate (the
- -- procedure formal case), has been handled above.
+ -- For all other cases, we can tell at compile time
- -- We use the Underlying_Type here (and below) in case the
- -- type is private without discriminants, but the full type
- -- has discriminants. This case is illegal, but we generate it
- -- internally for passing to the Extra_Constrained parameter.
-
- else
- -- In Ada 2012, test for case of a limited tagged type, in
- -- which case the attribute is always required to return
- -- True. The underlying type is tested, to make sure we also
- -- return True for cases where there is an unconstrained
- -- object with an untagged limited partial view which has
- -- defaulted discriminants (such objects always produce a
- -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
-
- Res := Is_Constrained (Underlying_Type (Etype (Ent)))
- or else
- (Ada_Version >= Ada_2012
- and then Is_Tagged_Type (Underlying_Type (Ptyp))
- and then Is_Limited_Type (Ptyp));
- end if;
-
- Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
- end;
+ else
+ -- For access type, apply access check as needed
- -- Prefix is not an entity name. These are also cases where we can
- -- always tell at compile time by looking at the form and type of the
- -- prefix. If an explicit dereference of an object with constrained
- -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
- -- underlying type is a limited tagged type, then Constrained is
- -- required to always return True (Ada 2012: AI05-0214).
+ if Is_Entity_Name (Pref)
+ and then not Is_Type (Entity (Pref))
+ and then Is_Access_Type (Ptyp)
+ then
+ Apply_Access_Check (N);
+ end if;
- else
Rewrite (N,
- New_Occurrence_Of (
- Boolean_Literals (
- not Is_Variable (Pref)
- or else
- (Nkind (Pref) = N_Explicit_Dereference
- and then
- not Object_Type_Has_Constrained_Partial_View
- (Typ => Base_Type (Ptyp),
- Scop => Current_Scope))
- or else Is_Constrained (Underlying_Type (Ptyp))
- or else (Ada_Version >= Ada_2012
- and then Is_Tagged_Type (Underlying_Type (Ptyp))
- and then Is_Limited_Type (Ptyp))),
- Loc));
+ New_Occurrence_Of
+ (Boolean_Literals
+ (Exp_Util.Attribute_Constrained_Static_Value
+ (Pref)), Sloc (N)));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
-- Protected case
if Is_Protected_Type (Conctyp) then
+
+ -- No need to transform 'Count into a function call if the current
+ -- scope has been eliminated. In this case such transformation is
+ -- also not viable because the enclosing protected object is not
+ -- available.
+
+ if Is_Eliminated (Current_Scope) then
+ return;
+ end if;
+
case Corresponding_Runtime_Package (Conctyp) is
when System_Tasking_Protected_Objects_Entries =>
Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
Call :=
Make_Function_Call (Loc,
- Name => Name,
+ Name => Name,
Parameter_Associations => New_List (
New_Occurrence_Of
(Find_Protection_Object (Current_Scope), Loc),
Call :=
Make_Function_Call (Loc,
- Name => Name,
+ Name => Name,
Parameter_Associations => New_List (
New_Occurrence_Of
(Find_Protection_Object (Current_Scope), Loc)));
-- and then the Elab_Body/Spec attribute is replaced by a reference
-- to this defining identifier.
- when Attribute_Elab_Body |
- Attribute_Elab_Spec =>
-
+ when Attribute_Elab_Body
+ | Attribute_Elab_Spec
+ =>
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle these attributes directly.
-- Note: The Elaborated attribute is never passed to the back end
when Attribute_Elaborated => Elaborated : declare
- Ent : constant Entity_Id := Entity (Pref);
+ Elab_Id : constant Entity_Id := Elaboration_Entity (Entity (Pref));
begin
- if Present (Elaboration_Entity (Ent)) then
+ if Present (Elab_Id) then
Rewrite (N,
Make_Op_Ne (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Uint_0)));
+ Left_Opnd => New_Occurrence_Of (Elab_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)));
+
Analyze_And_Resolve (N, Typ);
else
Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
-- Enum_Rep --
--------------
- when Attribute_Enum_Rep => Enum_Rep :
- begin
- -- X'Enum_Rep (Y) expands to
-
- -- target-type (Y)
+ when Attribute_Enum_Rep => Enum_Rep : declare
+ Expr : Node_Id;
- -- This is simply a direct conversion from the enumeration type to
- -- the target integer type, which is treated by the back end as a
- -- normal integer conversion, treating the enumeration type as an
- -- integer, which is exactly what we want. We set Conversion_OK to
- -- make sure that the analyzer does not complain about what otherwise
- -- might be an illegal conversion.
+ begin
+ -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
+ -- X'Enum_Rep.
if Is_Non_Empty_List (Exprs) then
- Rewrite (N,
- OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
+ Expr := First (Exprs);
+ else
+ Expr := Pref;
+ end if;
- -- X'Enum_Rep where X is an enumeration literal is replaced by
- -- the literal value.
+ -- If the expression is an enumeration literal, it is replaced by the
+ -- literal value.
- elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
+ if Nkind (Expr) in N_Has_Entity
+ and then Ekind (Entity (Expr)) = E_Enumeration_Literal
+ then
Rewrite (N,
- Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
+ Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Expr))));
-- If this is a renaming of a literal, recover the representation
- -- of the original. If it renames an expression there is nothing
- -- to fold.
-
- elsif Ekind (Entity (Pref)) = E_Constant
- and then Present (Renamed_Object (Entity (Pref)))
- and then Is_Entity_Name (Renamed_Object (Entity (Pref)))
- and then Ekind (Entity (Renamed_Object (Entity (Pref)))) =
+ -- of the original. If it renames an expression there is nothing to
+ -- fold.
+
+ elsif Nkind (Expr) in N_Has_Entity
+ and then Ekind (Entity (Expr)) = E_Constant
+ and then Present (Renamed_Object (Entity (Expr)))
+ and then Is_Entity_Name (Renamed_Object (Entity (Expr)))
+ and then Ekind (Entity (Renamed_Object (Entity (Expr)))) =
E_Enumeration_Literal
then
Rewrite (N,
Make_Integer_Literal (Loc,
- Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
+ Enumeration_Rep (Entity (Renamed_Object (Entity (Expr))))));
+
+ -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
+ -- X'Enum_Rep expands to
- -- X'Enum_Rep where X is an object does a direct unchecked conversion
- -- of the object value, as described for the type case above.
+ -- target-type (X)
+
+ -- This is simply a direct conversion from the enumeration type to
+ -- the target integer type, which is treated by the back end as a
+ -- normal integer conversion, treating the enumeration type as an
+ -- integer, which is exactly what we want. We set Conversion_OK to
+ -- make sure that the analyzer does not complain about what otherwise
+ -- might be an illegal conversion.
else
- Rewrite (N,
- OK_Convert_To (Typ, Relocate_Node (Pref)));
+ Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr)));
end if;
Set_Etype (N, Typ);
Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
+ -- Ensure that the expression is not truncated since the "bad" bits
+ -- are desired.
+
+ if Nkind (Expr) = N_Unchecked_Type_Conversion then
+ Set_No_Truncation (Expr);
+ end if;
+
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
-- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
- when Attribute_External_Tag => External_Tag :
- begin
+ when Attribute_External_Tag =>
Rewrite (N,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_External_Tag), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_External_Tag), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Tag,
- Prefix => Prefix (N)))));
+ Prefix => Prefix (N)))));
Analyze_And_Resolve (N, Standard_String);
- end External_Tag;
+
+ -----------------------
+ -- Finalization_Size --
+ -----------------------
+
+ when Attribute_Finalization_Size => Finalization_Size : declare
+ function Calculate_Header_Size return Node_Id;
+ -- Generate a runtime call to calculate the size of the hidden header
+ -- along with any added padding which would precede a heap-allocated
+ -- object of the prefix type.
+
+ ---------------------------
+ -- Calculate_Header_Size --
+ ---------------------------
+
+ function Calculate_Header_Size return Node_Id is
+ begin
+ -- Generate:
+ -- Universal_Integer
+ -- (Header_Size_With_Padding (Pref'Alignment))
+
+ return
+ Convert_To (Universal_Integer,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc),
+
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Pref),
+ Attribute_Name => Name_Alignment))));
+ end Calculate_Header_Size;
+
+ -- Local variables
+
+ Size : Entity_Id;
+
+ -- Start of Finalization_Size
+
+ begin
+ -- An object of a class-wide type first requires a runtime check to
+ -- determine whether it is actually controlled or not. Depending on
+ -- the outcome of this check, the Finalization_Size of the object
+ -- may be zero or some positive value.
+ --
+ -- In this scenario, Pref'Finalization_Size is expanded into
+ --
+ -- Size : Integer := 0;
+ --
+ -- if Needs_Finalization (Pref'Tag) then
+ -- Size :=
+ -- Universal_Integer
+ -- (Header_Size_With_Padding (Pref'Alignment));
+ -- end if;
+ --
+ -- and the attribute reference is replaced with a reference to Size.
+
+ if Is_Class_Wide_Type (Ptyp) then
+ Size := Make_Temporary (Loc, 'S');
+
+ Insert_Actions (N, New_List (
+
+ -- Generate:
+ -- Size : Integer := 0;
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Size,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Integer, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)),
+
+ -- Generate:
+ -- if Needs_Finalization (Pref'Tag) then
+ -- Size :=
+ -- Universal_Integer
+ -- (Header_Size_With_Padding (Pref'Alignment));
+ -- end if;
+
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
+
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Pref),
+ Attribute_Name => Name_Tag))),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Size, Loc),
+ Expression => Calculate_Header_Size)))));
+
+ Rewrite (N, New_Occurrence_Of (Size, Loc));
+
+ -- The prefix is known to be controlled at compile time. Calculate
+ -- Finalization_Size by calling function Header_Size_With_Padding.
+
+ elsif Needs_Finalization (Ptyp) then
+ Rewrite (N, Calculate_Header_Size);
+
+ -- The prefix is not an object with controlled parts, so its
+ -- Finalization_Size is zero.
+
+ else
+ Rewrite (N, Make_Integer_Literal (Loc, 0));
+ end if;
+
+ -- Due to cases where the entity type of the attribute is already
+ -- resolved the rewritten N must get re-resolved to its appropriate
+ -- type.
+
+ Analyze_And_Resolve (N, Typ);
+ end Finalization_Size;
-----------
-- First --
end if;
end First_Bit_Attr;
- -----------------
- -- Fixed_Value --
- -----------------
+ --------------------------------
+ -- Fixed_Value, Integer_Value --
+ --------------------------------
- -- We transform:
+ -- We transform
-- fixtype'Fixed_Value (integer-value)
+ -- inttype'Integer_Value (fixed-value)
-- into
- -- fixtype(integer-value)
+ -- fixtype (integer-value)
+ -- inttype (fixed-value)
+
+ -- respectively.
- -- We do all the required analysis of the conversion here, because we do
- -- not want this to go through the fixed-point conversion circuits. Note
- -- that the back end always treats fixed-point as equivalent to the
- -- corresponding integer type anyway.
+ -- We set Conversion_OK on the conversion because we do not want it
+ -- to go through the fixed-point conversion circuits.
- when Attribute_Fixed_Value => Fixed_Value :
- begin
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
- Expression => Relocate_Node (First (Exprs))));
- Set_Etype (N, Entity (Pref));
- Set_Analyzed (N);
+ when Attribute_Fixed_Value
+ | Attribute_Integer_Value
+ =>
+ Rewrite (N, OK_Convert_To (Entity (Pref), First (Exprs)));
- -- Note: it might appear that a properly analyzed unchecked conversion
- -- would be just fine here, but that's not the case, since the full
- -- range checks performed by the following call are critical.
+ -- Note that it might appear that a properly analyzed unchecked
+ -- conversion would be just fine here, but that's not the case,
+ -- since the full range checks performed by the following calls
+ -- are critical.
Apply_Type_Conversion_Checks (N);
- end Fixed_Value;
+
+ -- Note that Apply_Type_Conversion_Checks only deals with the
+ -- overflow checks on conversions involving fixed-point types
+ -- so we must apply range checks manually on them and expand.
+
+ Apply_Scalar_Range_Check
+ (Expression (N), Etype (N), Fixed_Int => True);
+
+ Set_Analyzed (N);
+ Expand (N);
-----------
-- Floor --
-- Result_Type (System.Fore (Universal_Real (Type'First)),
-- Universal_Real (Type'Last))
- -- Note that we know that the type is a non-static subtype, or Fore
- -- would have itself been computed dynamically in Eval_Attribute.
+ -- Note that we know that the type is a nonstatic subtype, or Fore would
+ -- have itself been computed dynamically in Eval_Attribute.
- when Attribute_Fore => Fore : begin
+ when Attribute_Fore =>
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_Fore), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Fore), Loc),
Parameter_Associations => New_List (
Convert_To (Universal_Real,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_First)),
Convert_To (Universal_Real,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Last))))));
Analyze_And_Resolve (N, Typ);
- end Fore;
--------------
-- Fraction --
when Attribute_From_Any => From_Any : declare
P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
+
begin
Rewrite (N,
Build_From_Any_Call (P_Type,
----------------------
when Attribute_Has_Same_Storage => Has_Same_Storage : declare
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
- X : constant Node_Id := Prefix (N);
- Y : constant Node_Id := First (Expressions (N));
- -- The arguments
+ X : constant Node_Id := Prefix (N);
+ Y : constant Node_Id := First (Expressions (N));
+ -- The arguments
- X_Addr, Y_Addr : Node_Id;
- -- Rhe expressions for their addresses
+ X_Addr : Node_Id;
+ Y_Addr : Node_Id;
+ -- Rhe expressions for their addresses
- X_Size, Y_Size : Node_Id;
- -- Rhe expressions for their sizes
+ X_Size : Node_Id;
+ Y_Size : Node_Id;
+ -- Rhe expressions for their sizes
begin
-- The attribute is expanded as:
X_Addr :=
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => New_Copy_Tree (X));
+ Attribute_Name => Name_Address,
+ Prefix => New_Copy_Tree (X));
Y_Addr :=
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => New_Copy_Tree (Y));
+ Attribute_Name => Name_Address,
+ Prefix => New_Copy_Tree (Y));
X_Size :=
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Size,
- Prefix => New_Copy_Tree (X));
+ Attribute_Name => Name_Size,
+ Prefix => New_Copy_Tree (X));
Y_Size :=
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Size,
- Prefix => New_Copy_Tree (Y));
+ Attribute_Name => Name_Size,
+ Prefix => New_Copy_Tree (Y));
if Etype (X) = Etype (Y) then
Rewrite (N,
- (Make_Op_Eq (Loc,
- Left_Opnd => X_Addr,
- Right_Opnd => Y_Addr)));
+ Make_Op_Eq (Loc,
+ Left_Opnd => X_Addr,
+ Right_Opnd => Y_Addr));
else
Rewrite (N,
- Make_Op_And (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd => X_Addr,
- Right_Opnd => Y_Addr),
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd => X_Size,
- Right_Opnd => Y_Size)));
+ Make_Op_And (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => X_Addr,
+ Right_Opnd => Y_Addr),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => X_Size,
+ Right_Opnd => Y_Size)));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
and then Is_Task_Interface (Ptyp)
then
Rewrite (N,
- Unchecked_Convert_To (Id_Kind,
- Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Pref),
- Selector_Name =>
- Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
+ Unchecked_Convert_To
+ (Id_Kind, Build_Disp_Get_Task_Id_Call (Pref)));
else
Rewrite (N,
-- Image attribute is handled in separate unit Exp_Imgv
when Attribute_Image =>
- Exp_Imgv.Expand_Image_Attribute (N);
+
+ -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
+ -- back-end knows how to handle this attribute directly.
+
+ if CodePeer_Mode then
+ return;
+ end if;
+
+ Expand_Image_Attribute (N);
---------
-- Img --
-- X'Img is expanded to typ'Image (X), where typ is the type of X
- when Attribute_Img => Img :
- begin
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_Image,
- Expressions => New_List (Relocate_Node (Pref))));
-
- Analyze_And_Resolve (N, Standard_String);
- end Img;
+ when Attribute_Img =>
+ Expand_Image_Attribute (N);
-----------
-- Input --
-- A special case arises if we have a defined _Read routine,
-- since in this case we are required to call this routine.
- if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
- Build_Record_Or_Elementary_Input_Function
- (Loc, U_Type, Decl, Fname);
- Insert_Action (N, Decl);
+ declare
+ Typ : Entity_Id := P_Type;
+ begin
+ if Present (Full_View (Typ)) then
+ Typ := Full_View (Typ);
+ end if;
+
+ if Present (TSS (Base_Type (Typ), TSS_Stream_Read)) then
+ Build_Record_Or_Elementary_Input_Function
+ (Loc, Typ, Decl, Fname, Use_Underlying => False);
+ Insert_Action (N, Decl);
- -- For normal cases, we call the I_xxx routine directly
+ -- For normal cases, we call the I_xxx routine directly
- else
- Rewrite (N, Build_Elementary_Input_Call (N));
- Analyze_And_Resolve (N, P_Type);
- return;
- end if;
+ else
+ Rewrite (N, Build_Elementary_Input_Call (N));
+ Analyze_And_Resolve (N, P_Type);
+ return;
+ end if;
+ end;
-- Array type case
declare
Rtyp : constant Entity_Id := Root_Type (P_Type);
- Expr : Node_Id;
+
+ Expr : Node_Id; -- call to Descendant_Tag
+ Get_Tag : Node_Id; -- expression to read the 'Tag
begin
-- Read the internal tag (RM 13.13.2(34)) and use it to
- -- initialize a dummy tag value:
-
+ -- initialize a dummy tag value. We used to unconditionally
+ -- generate:
+ --
-- Descendant_Tag (String'Input (Strm), P_Type);
-
+ --
+ -- which turns into a call to String_Input_Blk_IO. However,
+ -- if the input is malformed, that could try to read an
+ -- enormous String, causing chaos. So instead we call
+ -- String_Input_Tag, which does the same thing as
+ -- String_Input_Blk_IO, except that if the String is
+ -- absurdly long, it raises an exception.
+ --
+ -- However, if the No_Stream_Optimizations restriction
+ -- is active, we disable this unnecessary attempt at
+ -- robustness; we really need to read the string
+ -- character-by-character.
+ --
-- This value is used only to provide a controlling
-- argument for the eventual _Input call. Descendant_Tag is
-- called rather than Internal_Tag to ensure that we have a
-- this constant in Cntrl, but this caused a secondary stack
-- leak.
+ if Restriction_Active (No_Stream_Optimizations) then
+ Get_Tag :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_String, Loc),
+ Attribute_Name => Name_Input,
+ Expressions => New_List (
+ Relocate_Node (Duplicate_Subexpr (Strm))));
+ else
+ Get_Tag :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_String_Input_Tag), Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Duplicate_Subexpr (Strm))));
+ end if;
+
Expr :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Standard_String, Loc),
- Attribute_Name => Name_Input,
- Expressions => New_List (
- Relocate_Node (Duplicate_Subexpr (Strm)))),
+ Get_Tag,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (P_Type, Loc),
Attribute_Name => Name_Tag)));
+
Set_Etype (Expr, RTE (RE_Tag));
-- Now we need to get the entity for the call, and construct
end if;
end Input;
- -------------------
- -- Integer_Value --
- -------------------
-
- -- We transform
-
- -- inttype'Fixed_Value (fixed-value)
-
- -- into
-
- -- inttype(integer-value))
-
- -- we do all the required analysis of the conversion here, because we do
- -- not want this to go through the fixed-point conversion circuits. Note
- -- that the back end always treats fixed-point as equivalent to the
- -- corresponding integer type anyway.
-
- when Attribute_Integer_Value => Integer_Value :
- begin
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
- Expression => Relocate_Node (First (Exprs))));
- Set_Etype (N, Entity (Pref));
- Set_Analyzed (N);
-
- -- Note: it might appear that a properly analyzed unchecked conversion
- -- would be just fine here, but that's not the case, since the full
- -- range checks performed by the following call are critical.
-
- Apply_Type_Conversion_Checks (N);
- end Integer_Value;
-
-------------------
-- Invalid_Value --
-------------------
when Attribute_Invalid_Value =>
Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
+ -- The value produced may be a conversion of a literal, which must be
+ -- resolved to establish its proper type.
+
+ Analyze_And_Resolve (N);
+
----------
-- Last --
----------
-- (Integer'Integer_Value (typ'First),
-- Integer'Integer_Value (typ'Last)));
- when Attribute_Mantissa => Mantissa : begin
+ when Attribute_Mantissa =>
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
Parameter_Associations => New_List (
-
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_Integer, Loc),
+ Prefix => New_Occurrence_Of (Standard_Integer, Loc),
Attribute_Name => Name_Integer_Value,
- Expressions => New_List (
-
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_First))),
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_Integer, Loc),
+ Prefix => New_Occurrence_Of (Standard_Integer, Loc),
Attribute_Name => Name_Integer_Value,
- Expressions => New_List (
-
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Last)))))));
Analyze_And_Resolve (N, Typ);
- end Mantissa;
---------
-- Max --
when Attribute_Mechanism_Code =>
- -- We must replace the prefix i the renamed case
+ -- We must replace the prefix in the renamed case
if Is_Entity_Name (Pref)
and then Present (Alias (Entity (Pref)))
-- _Postconditions must be in the tree (or inlined if we are
-- generating C code).
- pragma Assert (Present (Subp)
- or else (Modify_Tree_For_C and then In_Inlined_Body));
+ pragma Assert
+ (Present (Subp)
+ or else (Modify_Tree_For_C and then In_Inlined_Body));
Temp := Make_Temporary (Loc, 'T', Pref);
-- A special case arises if we have a defined _Write routine,
-- since in this case we are required to call this routine.
- if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
- Build_Record_Or_Elementary_Output_Procedure
- (Loc, U_Type, Decl, Pname);
- Insert_Action (N, Decl);
+ declare
+ Typ : Entity_Id := P_Type;
+ begin
+ if Present (Full_View (Typ)) then
+ Typ := Full_View (Typ);
+ end if;
+
+ if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then
+ Build_Record_Or_Elementary_Output_Procedure
+ (Loc, Typ, Decl, Pname);
+ Insert_Action (N, Decl);
- -- For normal cases, we call the W_xxx routine directly
+ -- For normal cases, we call the W_xxx routine directly
- else
- Rewrite (N, Build_Elementary_Write_Call (N));
- Analyze (N);
- return;
- end if;
+ else
+ Rewrite (N, Build_Elementary_Write_Call (N));
+ Analyze (N);
+ return;
+ end if;
+ end;
-- Array type case
-- For integer types, Pos is equivalent to a simple integer
-- conversion and we rewrite it as such
- when Attribute_Pos => Pos :
- declare
+ when Attribute_Pos => Pos : declare
Etyp : Entity_Id := Base_Type (Entity (Pref));
begin
-- the computation up to the back end, since we don't know what layout
-- will be chosen.
- when Attribute_Position => Position_Attr :
- declare
+ when Attribute_Position => Position_Attr : declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
-- 2. For floating-point, generate call to attribute function.
-- 3. For other cases, deal with constraint checking.
- when Attribute_Pred => Pred :
- declare
+ when Attribute_Pred => Pred : declare
Etyp : constant Entity_Id := Base_Type (Ptyp);
begin
Rep_To_Pos_Flag (Ptyp, Loc))))));
else
- -- Add Boolean parameter True, to request program errror if
+ -- Add Boolean parameter True, to request program error if
-- we have a bad representation on our hands. If checks are
-- suppressed, then add False instead
-- about complications that would other arise from X'Priority'Access,
-- which is illegal, because of the lack of aliasing.
- when Attribute_Priority =>
- declare
- Call : Node_Id;
- Conctyp : Entity_Id;
- Object_Parm : Node_Id;
- Subprg : Entity_Id;
- RT_Subprg_Name : Node_Id;
-
- begin
- -- Look for the enclosing concurrent type
+ when Attribute_Priority => Priority : declare
+ Call : Node_Id;
+ Conctyp : Entity_Id;
+ New_Itype : Entity_Id;
+ Object_Parm : Node_Id;
+ Subprg : Entity_Id;
+ RT_Subprg_Name : Node_Id;
- Conctyp := Current_Scope;
- while not Is_Concurrent_Type (Conctyp) loop
- Conctyp := Scope (Conctyp);
- end loop;
+ begin
+ -- Look for the enclosing concurrent type
- pragma Assert (Is_Protected_Type (Conctyp));
+ Conctyp := Current_Scope;
+ while not Is_Concurrent_Type (Conctyp) loop
+ Conctyp := Scope (Conctyp);
+ end loop;
- -- Generate the actual of the call
+ pragma Assert (Is_Protected_Type (Conctyp));
- Subprg := Current_Scope;
- while not Present (Protected_Body_Subprogram (Subprg)) loop
- Subprg := Scope (Subprg);
- end loop;
+ -- Generate the actual of the call
- -- Use of 'Priority inside protected entries and barriers (in
- -- both cases the type of the first formal of their expanded
- -- subprogram is Address)
+ Subprg := Current_Scope;
+ while not Present (Protected_Body_Subprogram (Subprg)) loop
+ Subprg := Scope (Subprg);
+ end loop;
- if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
- RTE (RE_Address)
- then
- declare
- New_Itype : Entity_Id;
+ -- Use of 'Priority inside protected entries and barriers (in both
+ -- cases the type of the first formal of their expanded subprogram
+ -- is Address)
- begin
- -- In the expansion of protected entries the type of the
- -- first formal of the Protected_Body_Subprogram is an
- -- Address. In order to reference the _object component
- -- we generate:
+ if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
+ RTE (RE_Address)
+ then
+ -- In the expansion of protected entries the type of the first
+ -- formal of the Protected_Body_Subprogram is an Address. In order
+ -- to reference the _object component we generate:
- -- type T is access p__ptTV;
- -- freeze T []
+ -- type T is access p__ptTV;
+ -- freeze T []
- New_Itype := Create_Itype (E_Access_Type, N);
- Set_Etype (New_Itype, New_Itype);
- Set_Directly_Designated_Type (New_Itype,
- Corresponding_Record_Type (Conctyp));
- Freeze_Itype (New_Itype, N);
+ New_Itype := Create_Itype (E_Access_Type, N);
+ Set_Etype (New_Itype, New_Itype);
+ Set_Directly_Designated_Type (New_Itype,
+ Corresponding_Record_Type (Conctyp));
+ Freeze_Itype (New_Itype, N);
- -- Generate:
- -- T!(O)._object'unchecked_access
+ -- Generate:
+ -- T!(O)._object'unchecked_access
- Object_Parm :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (New_Itype,
- New_Occurrence_Of
- (First_Entity
- (Protected_Body_Subprogram (Subprg)),
- Loc)),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access);
- end;
+ Object_Parm :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (New_Itype,
+ New_Occurrence_Of
+ (First_Entity (Protected_Body_Subprogram (Subprg)),
+ Loc)),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access);
- -- Use of 'Priority inside a protected subprogram
+ -- Use of 'Priority inside a protected subprogram
- else
- Object_Parm :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of
- (First_Entity
- (Protected_Body_Subprogram (Subprg)),
- Loc),
- Selector_Name => Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access);
- end if;
+ else
+ Object_Parm :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (First_Entity (Protected_Body_Subprogram (Subprg)),
+ Loc),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access);
+ end if;
- -- Select the appropriate run-time subprogram
+ -- Select the appropriate run-time subprogram
- if Number_Entries (Conctyp) = 0 then
- RT_Subprg_Name :=
- New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
- else
- RT_Subprg_Name :=
- New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
- end if;
+ if Number_Entries (Conctyp) = 0 then
+ RT_Subprg_Name := New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
+ else
+ RT_Subprg_Name := New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
+ end if;
- Call :=
- Make_Function_Call (Loc,
- Name => RT_Subprg_Name,
- Parameter_Associations => New_List (Object_Parm));
+ Call :=
+ Make_Function_Call (Loc,
+ Name => RT_Subprg_Name,
+ Parameter_Associations => New_List (Object_Parm));
- Rewrite (N, Call);
+ Rewrite (N, Call);
- -- Avoid the generation of extra checks on the pointer to the
- -- protected object.
+ -- Avoid the generation of extra checks on the pointer to the
+ -- protected object.
- Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
- end;
+ Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
+ end Priority;
------------------
-- Range_Length --
------------------
- when Attribute_Range_Length => Range_Length : begin
+ when Attribute_Range_Length =>
-- The only special processing required is for the case where
-- Range_Length is applied to an enumeration type with holes.
then
Rewrite (N,
Make_Op_Add (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Op_Subtract (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Expressions => New_List (
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
- Prefix => New_Occurrence_Of (Ptyp, Loc)))),
+ Prefix =>
+ New_Occurrence_Of (Ptyp, Loc)))),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Expressions => New_List (
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (Ptyp, Loc))))),
+ Prefix =>
+ New_Occurrence_Of (Ptyp, Loc))))),
Right_Opnd => Make_Integer_Literal (Loc, 1)));
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
- end Range_Length;
+
+ ------------
+ -- Reduce --
+ ------------
+
+ when Attribute_Reduce =>
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ E1 : constant Node_Id := First (Expressions (N));
+ E2 : constant Node_Id := Next (E1);
+ Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
+ Typ : constant Entity_Id := Etype (N);
+ New_Loop : Node_Id;
+
+ -- If the prefix is an aggregate, its unique component is an
+ -- Iterated_Element, and we create a loop out of its iterator.
+
+ begin
+ if Nkind (Prefix (N)) = N_Aggregate then
+ declare
+ Stream : constant Node_Id :=
+ First (Component_Associations (Prefix (N)));
+ Id : constant Node_Id := Defining_Identifier (Stream);
+ Expr : constant Node_Id := Expression (Stream);
+ Ch : constant Node_Id :=
+ First (Discrete_Choices (Stream));
+ begin
+ New_Loop := Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification => Empty,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => New_Copy (Id),
+ Discrete_Subtype_Definition =>
+ Relocate_Node (Ch))),
+ End_Label => Empty,
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression => Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Entity (E1), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Bnn, Loc),
+ Relocate_Node (Expr))))));
+ end;
+ else
+ -- If the prefix is a name, we construct an element iterator
+ -- over it. Its expansion will verify that it is an array or
+ -- a container with the proper aspects.
+
+ declare
+ Iter : Node_Id;
+ Elem : constant Entity_Id := Make_Temporary (Loc, 'E', N);
+
+ begin
+ Iter :=
+ Make_Iterator_Specification (Loc,
+ Defining_Identifier => Elem,
+ Name => Relocate_Node (Prefix (N)),
+ Subtype_Indication => Empty);
+ Set_Of_Present (Iter);
+
+ New_Loop := Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification => Iter,
+ Loop_Parameter_Specification => Empty),
+ End_Label => Empty,
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression => Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Entity (E1), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Bnn, Loc),
+ New_Occurrence_Of (Elem, Loc))))));
+ end;
+ end if;
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Bnn,
+ Object_Definition =>
+ New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (E2)), New_Loop),
+ Expression => New_Occurrence_Of (Bnn, Loc)));
+ Analyze_And_Resolve (N, Typ);
+ end;
----------
-- Read --
-- Ada 2005 (AI-216): Program_Error is raised when executing
-- the default implementation of the Read attribute of an
- -- Unchecked_Union type.
+ -- Unchecked_Union type. We replace the attribute with a
+ -- raise statement (rather than inserting it before) to handle
+ -- properly the case of an unchecked union that is a record
+ -- component.
if Is_Unchecked_Union (Base_Type (U_Type)) then
- Insert_Action (N,
+ Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
+ Set_Etype (N, B_Type);
+ return;
end if;
if Has_Discriminants (U_Type)
-- So the approach is as follows. First, when expanding a multiply or
-- divide whose type is universal fixed, we do nothing at all, instead
- -- deferring the operation till later.
-
- -- The actual processing is done in Expand_N_Type_Conversion which
- -- handles the special case of Round by looking at its parent to see if
- -- it is a Round attribute, and if it is, handling the conversion (or
- -- its fixed multiply/divide child) in an appropriate manner.
-
- -- This means that by the time we get to expanding the Round attribute
- -- itself, the Round is nothing more than a type conversion (and will
- -- often be a null type conversion), so we just replace it with the
- -- appropriate conversion operation.
-
- when Attribute_Round =>
- Rewrite (N,
- Convert_To (Etype (N), Relocate_Node (First (Exprs))));
- Analyze_And_Resolve (N);
-
- --------------
- -- Rounding --
- --------------
-
- -- Transforms 'Rounding into a call to the floating-point attribute
- -- function Rounding in Fat_xxx (where xxx is the root type)
- -- Expansion is avoided for cases the back end can handle directly.
-
- when Attribute_Rounding =>
- if not Is_Inline_Floating_Point_Attribute (N) then
- Expand_Fpt_Attribute_R (N);
- end if;
-
- -------------
- -- Scaling --
- -------------
-
- -- Transforms 'Scaling into a call to the floating-point attribute
- -- function Scaling in Fat_xxx (where xxx is the root type)
-
- when Attribute_Scaling =>
- Expand_Fpt_Attribute_RI (N);
-
- -------------------------
- -- Simple_Storage_Pool --
- -------------------------
-
- when Attribute_Simple_Storage_Pool =>
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
- Expression => New_Occurrence_Of (Entity (N), Loc)));
- Analyze_And_Resolve (N, Typ);
-
- ----------
- -- Size --
- ----------
-
- when Attribute_Size |
- Attribute_Object_Size |
- Attribute_Value_Size |
- Attribute_VADS_Size => Size :
-
- declare
- Siz : Uint;
- New_Node : Node_Id;
-
- begin
- -- Processing for VADS_Size case. Note that this processing removes
- -- all traces of VADS_Size from the tree, and completes all required
- -- processing for VADS_Size by translating the attribute reference
- -- to an appropriate Size or Object_Size reference.
-
- if Id = Attribute_VADS_Size
- or else (Use_VADS_Size and then Id = Attribute_Size)
- then
- -- If the size is specified, then we simply use the specified
- -- size. This applies to both types and objects. The size of an
- -- object can be specified in the following ways:
-
- -- An explicit size object is given for an object
- -- A component size is specified for an indexed component
- -- A component clause is specified for a selected component
- -- The object is a component of a packed composite object
-
- -- If the size is specified, then VADS_Size of an object
-
- if (Is_Entity_Name (Pref)
- and then Present (Size_Clause (Entity (Pref))))
- or else
- (Nkind (Pref) = N_Component_Clause
- and then (Present (Component_Clause
- (Entity (Selector_Name (Pref))))
- or else Is_Packed (Etype (Prefix (Pref)))))
- or else
- (Nkind (Pref) = N_Indexed_Component
- and then (Component_Size (Etype (Prefix (Pref))) /= 0
- or else Is_Packed (Etype (Prefix (Pref)))))
- then
- Set_Attribute_Name (N, Name_Size);
-
- -- Otherwise if we have an object rather than a type, then the
- -- VADS_Size attribute applies to the type of the object, rather
- -- than the object itself. This is one of the respects in which
- -- VADS_Size differs from Size.
-
- else
- if (not Is_Entity_Name (Pref)
- or else not Is_Type (Entity (Pref)))
- and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
- then
- Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
- end if;
-
- -- For a scalar type for which no size was explicitly given,
- -- VADS_Size means Object_Size. This is the other respect in
- -- which VADS_Size differs from Size.
-
- if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
- Set_Attribute_Name (N, Name_Object_Size);
-
- -- In all other cases, Size and VADS_Size are the sane
-
- else
- Set_Attribute_Name (N, Name_Size);
- end if;
- end if;
- end if;
-
- -- If the prefix is X'Class, we transform it into a direct reference
- -- to the class-wide type, because the back end must not see a 'Class
- -- reference.
-
- if Is_Entity_Name (Pref)
- and then Is_Class_Wide_Type (Entity (Pref))
- then
- Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
- return;
-
- -- For X'Size applied to an object of a class-wide type, transform
- -- X'Size into a call to the primitive operation _Size applied to X.
-
- elsif Is_Class_Wide_Type (Ptyp) then
-
- -- No need to do anything else compiling under restriction
- -- No_Dispatching_Calls. During the semantic analysis we
- -- already noted this restriction violation.
-
- if Restriction_Active (No_Dispatching_Calls) then
- return;
- end if;
-
- New_Node :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of
- (Find_Prim_Op (Ptyp, Name_uSize), Loc),
- Parameter_Associations => New_List (Pref));
-
- if Typ /= Standard_Long_Long_Integer then
+ -- deferring the operation till later.
- -- The context is a specific integer type with which the
- -- original attribute was compatible. The function has a
- -- specific type as well, so to preserve the compatibility
- -- we must convert explicitly.
+ -- The actual processing is done in Expand_N_Type_Conversion which
+ -- handles the special case of Round by looking at its parent to see if
+ -- it is a Round attribute, and if it is, handling the conversion (or
+ -- its fixed multiply/divide child) in an appropriate manner.
- New_Node := Convert_To (Typ, New_Node);
- end if;
+ -- This means that by the time we get to expanding the Round attribute
+ -- itself, the Round is nothing more than a type conversion (and will
+ -- often be a null type conversion), so we just replace it with the
+ -- appropriate conversion operation.
- Rewrite (N, New_Node);
- Analyze_And_Resolve (N, Typ);
- return;
+ when Attribute_Round =>
+ Rewrite (N,
+ Convert_To (Etype (N), Relocate_Node (First (Exprs))));
+ Analyze_And_Resolve (N);
- -- Case of known RM_Size of a type
+ --------------
+ -- Rounding --
+ --------------
- elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
- and then Is_Entity_Name (Pref)
- and then Is_Type (Entity (Pref))
- and then Known_Static_RM_Size (Entity (Pref))
- then
- Siz := RM_Size (Entity (Pref));
+ -- Transforms 'Rounding into a call to the floating-point attribute
+ -- function Rounding in Fat_xxx (where xxx is the root type)
+ -- Expansion is avoided for cases the back end can handle directly.
- -- Case of known Esize of a type
+ when Attribute_Rounding =>
+ if not Is_Inline_Floating_Point_Attribute (N) then
+ Expand_Fpt_Attribute_R (N);
+ end if;
- elsif Id = Attribute_Object_Size
- and then Is_Entity_Name (Pref)
- and then Is_Type (Entity (Pref))
- and then Known_Static_Esize (Entity (Pref))
- then
- Siz := Esize (Entity (Pref));
+ -------------
+ -- Scaling --
+ -------------
- -- Case of known size of object
+ -- Transforms 'Scaling into a call to the floating-point attribute
+ -- function Scaling in Fat_xxx (where xxx is the root type)
- elsif Id = Attribute_Size
- and then Is_Entity_Name (Pref)
- and then Is_Object (Entity (Pref))
- and then Known_Esize (Entity (Pref))
- and then Known_Static_Esize (Entity (Pref))
- then
- Siz := Esize (Entity (Pref));
+ when Attribute_Scaling =>
+ Expand_Fpt_Attribute_RI (N);
- -- For an array component, we can do Size in the front end
- -- if the component_size of the array is set.
+ -------------------------
+ -- Simple_Storage_Pool --
+ -------------------------
- elsif Nkind (Pref) = N_Indexed_Component then
- Siz := Component_Size (Etype (Prefix (Pref)));
+ when Attribute_Simple_Storage_Pool =>
+ Rewrite (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
+ Expression => New_Occurrence_Of (Entity (N), Loc)));
+ Analyze_And_Resolve (N, Typ);
- -- For a record component, we can do Size in the front end if there
- -- is a component clause, or if the record is packed and the
- -- component's size is known at compile time.
+ ----------
+ -- Size --
+ ----------
- elsif Nkind (Pref) = N_Selected_Component then
- declare
- Rec : constant Entity_Id := Etype (Prefix (Pref));
- Comp : constant Entity_Id := Entity (Selector_Name (Pref));
+ when Attribute_Object_Size
+ | Attribute_Size
+ | Attribute_Value_Size
+ | Attribute_VADS_Size
+ =>
+ Size : declare
+ New_Node : Node_Id;
- begin
- if Present (Component_Clause (Comp)) then
- Siz := Esize (Comp);
+ begin
+ -- Processing for VADS_Size case. Note that this processing
+ -- removes all traces of VADS_Size from the tree, and completes
+ -- all required processing for VADS_Size by translating the
+ -- attribute reference to an appropriate Size or Object_Size
+ -- reference.
+
+ if Id = Attribute_VADS_Size
+ or else (Use_VADS_Size and then Id = Attribute_Size)
+ then
+ -- If the size is specified, then we simply use the specified
+ -- size. This applies to both types and objects. The size of an
+ -- object can be specified in the following ways:
+
+ -- An explicit size object is given for an object
+ -- A component size is specified for an indexed component
+ -- A component clause is specified for a selected component
+ -- The object is a component of a packed composite object
+
+ -- If the size is specified, then VADS_Size of an object
+
+ if (Is_Entity_Name (Pref)
+ and then Present (Size_Clause (Entity (Pref))))
+ or else
+ (Nkind (Pref) = N_Component_Clause
+ and then (Present (Component_Clause
+ (Entity (Selector_Name (Pref))))
+ or else Is_Packed (Etype (Prefix (Pref)))))
+ or else
+ (Nkind (Pref) = N_Indexed_Component
+ and then (Component_Size (Etype (Prefix (Pref))) /= 0
+ or else Is_Packed (Etype (Prefix (Pref)))))
+ then
+ Set_Attribute_Name (N, Name_Size);
- elsif Is_Packed (Rec) then
- Siz := RM_Size (Ptyp);
+ -- Otherwise if we have an object rather than a type, then
+ -- the VADS_Size attribute applies to the type of the object,
+ -- rather than the object itself. This is one of the respects
+ -- in which VADS_Size differs from Size.
else
- Apply_Universal_Integer_Attribute_Checks (N);
- return;
- end if;
- end;
+ if (not Is_Entity_Name (Pref)
+ or else not Is_Type (Entity (Pref)))
+ and then (Is_Scalar_Type (Ptyp)
+ or else Is_Constrained (Ptyp))
+ then
+ Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
+ end if;
- -- All other cases are handled by the back end
+ -- For a scalar type for which no size was explicitly given,
+ -- VADS_Size means Object_Size. This is the other respect in
+ -- which VADS_Size differs from Size.
- else
- Apply_Universal_Integer_Attribute_Checks (N);
+ if Is_Scalar_Type (Ptyp)
+ and then No (Size_Clause (Ptyp))
+ then
+ Set_Attribute_Name (N, Name_Object_Size);
- -- If Size is applied to a formal parameter that is of a packed
- -- array subtype, then apply Size to the actual subtype.
+ -- In all other cases, Size and VADS_Size are the sane
- if Is_Entity_Name (Pref)
- and then Is_Formal (Entity (Pref))
- and then Is_Array_Type (Ptyp)
- and then Is_Packed (Ptyp)
- then
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
- Attribute_Name => Name_Size));
- Analyze_And_Resolve (N, Typ);
+ else
+ Set_Attribute_Name (N, Name_Size);
+ end if;
+ end if;
end if;
- -- If Size applies to a dereference of an access to unconstrained
- -- packed array, the back end needs to see its unconstrained
- -- nominal type, but also a hint to the actual constrained type.
+ -- If the prefix is X'Class, transform it into a direct reference
+ -- to the class-wide type, because the back end must not see a
+ -- 'Class reference.
- if Nkind (Pref) = N_Explicit_Dereference
- and then Is_Array_Type (Ptyp)
- and then not Is_Constrained (Ptyp)
- and then Is_Packed (Ptyp)
+ if Is_Entity_Name (Pref)
+ and then Is_Class_Wide_Type (Entity (Pref))
then
- Set_Actual_Designated_Subtype (Pref,
- Get_Actual_Subtype (Pref));
- end if;
+ Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
+ return;
- return;
- end if;
+ -- For X'Size applied to an object of a class-wide type, transform
+ -- X'Size into a call to the primitive operation _Size applied to
+ -- X.
- -- Common processing for record and array component case
+ elsif Is_Class_Wide_Type (Ptyp) then
- if Siz /= No_Uint and then Siz /= 0 then
- declare
- CS : constant Boolean := Comes_From_Source (N);
+ -- No need to do anything else compiling under restriction
+ -- No_Dispatching_Calls. During the semantic analysis we
+ -- already noted this restriction violation.
- begin
- Rewrite (N, Make_Integer_Literal (Loc, Siz));
+ if Restriction_Active (No_Dispatching_Calls) then
+ return;
+ end if;
- -- This integer literal is not a static expression. We do not
- -- call Analyze_And_Resolve here, because this would activate
- -- the circuit for deciding that a static value was out of
- -- range, and we don't want that.
+ New_Node :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Find_Prim_Op (Ptyp, Name_uSize), Loc),
+ Parameter_Associations => New_List (Pref));
- -- So just manually set the type, mark the expression as non-
- -- static, and then ensure that the result is checked properly
- -- if the attribute comes from source (if it was internally
- -- generated, we never need a constraint check).
+ if Typ /= Standard_Long_Long_Integer then
- Set_Etype (N, Typ);
- Set_Is_Static_Expression (N, False);
+ -- The context is a specific integer type with which the
+ -- original attribute was compatible. The function has a
+ -- specific type as well, so to preserve the compatibility
+ -- we must convert explicitly.
- if CS then
- Apply_Constraint_Check (N, Typ);
+ New_Node := Convert_To (Typ, New_Node);
end if;
- end;
- end if;
- end Size;
+
+ Rewrite (N, New_Node);
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
+
+ -- Call Expand_Size_Attribute to do the final part of the
+ -- expansion which is shared with GNATprove expansion.
+
+ Expand_Size_Attribute (N);
+ end Size;
------------------
-- Storage_Pool --
Etyp : constant Entity_Id := Base_Type (Ptyp);
begin
-
-- For enumeration types with non-standard representations, we
-- expand typ'Succ (x) into
Make_Integer_Literal (Loc, 1))),
Rep_To_Pos_Flag (Ptyp, Loc))))));
else
- -- Add Boolean parameter True, to request program errror if
+ -- Add Boolean parameter True, to request program error if
-- we have a bad representation on our hands. Add False if
-- checks are suppressed.
elsif Comes_From_Source (N)
and then Is_Class_Wide_Type (Etype (Prefix (N)))
- and then Is_Interface (Etype (Prefix (N)))
+ and then Is_Interface (Underlying_Type (Etype (Prefix (N))))
then
-- Generate:
-- (To_Tag_Ptr (Prefix'Address)).all
-- Transforms 'Terminated attribute into a call to Terminated function
- when Attribute_Terminated => Terminated :
- begin
+ when Attribute_Terminated => Terminated : begin
+
-- The prefix of Terminated is of a task interface class-wide type.
-- Generate:
- -- terminated (Task_Id (Pref._disp_get_task_id));
+ -- terminated (Task_Id (_disp_get_task_id (Pref)));
if Ada_Version >= Ada_2005
and then Ekind (Ptyp) = E_Class_Wide_Type
then
Rewrite (N,
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Terminated), Loc),
Parameter_Associations => New_List (
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Pref),
- Selector_Name =>
- Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
+ Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
elsif Restricted_Profile then
Rewrite (N,
----------------
-- Transforms System'To_Address (X) and System.Address'Ref (X) into
- -- unchecked conversion from (integral) type of X to type address.
+ -- unchecked conversion from (integral) type of X to type address. If
+ -- the To_Address is a static expression, the transformed expression
+ -- also needs to be static, because we do some legality checks (e.g.
+ -- for Thread_Local_Storage) after this transformation.
- when Attribute_To_Address | Attribute_Ref =>
- Rewrite (N,
- Unchecked_Convert_To (RTE (RE_Address),
- Relocate_Node (First (Exprs))));
- Analyze_And_Resolve (N, RTE (RE_Address));
+ when Attribute_Ref
+ | Attribute_To_Address
+ =>
+ To_Address : declare
+ Is_Static : constant Boolean := Is_Static_Expression (N);
+
+ begin
+ Rewrite (N,
+ Unchecked_Convert_To (RTE (RE_Address),
+ Relocate_Node (First (Exprs))));
+ Set_Is_Static_Expression (N, Is_Static);
+
+ Analyze_And_Resolve (N, RTE (RE_Address));
+ end To_Address;
------------
-- To_Any --
-- See separate sections below for the generated code in each case.
when Attribute_Valid => Valid : declare
- Btyp : Entity_Id := Base_Type (Ptyp);
- Tst : Node_Id;
+ PBtyp : Entity_Id := Base_Type (Ptyp);
Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
-- Save the validity checking mode. We always turn off validity
-- checking during process of 'Valid since this is one place
- -- where we do not want the implicit validity checks to intefere
+ -- where we do not want the implicit validity checks to interfere
-- with the explicit validity check that the programmer is doing.
function Make_Range_Test return Node_Id;
-- Build the code for a range test of the form
- -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
+ -- PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last)
---------------------
-- Make_Range_Test --
---------------------
function Make_Range_Test return Node_Id is
- Temp : constant Node_Id := Duplicate_Subexpr (Pref);
+ Temp : Node_Id;
begin
- -- The value whose validity is being checked has been captured in
- -- an object declaration. We certainly don't want this object to
- -- appear valid because the declaration initializes it.
+ -- The prefix of attribute 'Valid should always denote an object
+ -- reference. The reference is either coming directly from source
+ -- or is produced by validity check expansion. The object may be
+ -- wrapped in a conversion in which case the call to Unqual_Conv
+ -- will yield it.
+
+ -- If the prefix denotes a variable which captures the value of
+ -- an object for validation purposes, use the variable in the
+ -- range test. This ensures that no extra copies or extra reads
+ -- are produced as part of the test. Generate:
- if Is_Entity_Name (Temp) then
- Set_Is_Known_Valid (Entity (Temp), False);
+ -- Temp : ... := Object;
+ -- if not Temp in ... then
+
+ if Is_Validation_Variable_Reference (Pref) then
+ Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc);
+
+ -- Otherwise the prefix is either a source object or a constant
+ -- produced by validity check expansion. Generate:
+
+ -- Temp : constant ... := Pref;
+ -- if not Temp in ... then
+
+ else
+ Temp := Duplicate_Subexpr (Pref);
end if;
return
Make_In (Loc,
- Left_Opnd =>
- Unchecked_Convert_To (Btyp, Temp),
+ Left_Opnd => Unchecked_Convert_To (PBtyp, Temp),
Right_Opnd =>
Make_Range (Loc,
- Low_Bound =>
- Unchecked_Convert_To (Btyp,
+ Low_Bound =>
+ Unchecked_Convert_To (PBtyp,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_First)),
High_Bound =>
- Unchecked_Convert_To (Btyp,
+ Unchecked_Convert_To (PBtyp,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Last))));
end Make_Range_Test;
+ -- Local variables
+
+ Tst : Node_Id;
+
-- Start of processing for Attribute_Valid
begin
-- Retrieve the base type. Handle the case where the base type is a
-- private enumeration type.
- if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
- Btyp := Full_View (Btyp);
+ if Is_Private_Type (PBtyp) and then Present (Full_View (PBtyp)) then
+ PBtyp := Full_View (PBtyp);
end if;
-- Floating-point case. This case is handled by the Valid attribute
begin
-- The C and AAMP back-ends handle Valid for fpt types
- if Generate_C_Code or else Float_Rep (Btyp) = AAMP then
+ if Modify_Tree_For_C or else Float_Rep (PBtyp) = AAMP then
Analyze_And_Resolve (Pref, Ptyp);
Set_Etype (N, Standard_Boolean);
Set_Analyzed (N);
-- The way we do the range check is simply to create the
-- expression: Valid (N) and then Base_Type(Pref) in Typ.
- if not Subtypes_Statically_Match (Ptyp, Btyp) then
+ if not Subtypes_Statically_Match (Ptyp, PBtyp) then
Rewrite (N,
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (N),
Right_Opnd =>
Make_In (Loc,
- Left_Opnd => Convert_To (Btyp, Pref),
+ Left_Opnd => Convert_To (PBtyp, Pref),
Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
end if;
end Float_Valid;
-- (X >= type(X)'First and then type(X)'Last <= X)
elsif Is_Enumeration_Type (Ptyp)
- and then Present (Enum_Pos_To_Rep (Btyp))
+ and then Present (Enum_Pos_To_Rep (PBtyp))
then
Tst :=
Make_Op_Ge (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
+ New_Occurrence_Of (TSS (PBtyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations => New_List (
Pref,
New_Occurrence_Of (Standard_False, Loc))),
Right_Opnd => Make_Integer_Literal (Loc, 0));
- if Ptyp /= Btyp
+ if Ptyp /= PBtyp
and then
- (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
+ (Type_Low_Bound (Ptyp) /= Type_Low_Bound (PBtyp)
or else
- Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
+ Type_High_Bound (Ptyp) /= Type_High_Bound (PBtyp))
then
-- The call to Make_Range_Test will create declarations
-- that need a proper insertion point, but Pref is now
-- test has to take this into account, and the proper form of the
-- test is:
- -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
+ -- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length)
elsif Has_Biased_Representation (Ptyp) then
- Btyp := RTE (RE_Unsigned_32);
+ PBtyp := RTE (RE_Unsigned_32);
Rewrite (N,
Make_Op_Lt (Loc,
Left_Opnd =>
- Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
+ Unchecked_Convert_To (PBtyp, Duplicate_Subexpr (Pref)),
Right_Opnd =>
- Unchecked_Convert_To (Btyp,
+ Unchecked_Convert_To (PBtyp,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Range_Length))));
-- the Valid attribute is exactly that this test does not work).
-- What will work is:
- -- Btyp!(X) >= Btyp!(type(X)'First)
+ -- PBtyp!(X) >= PBtyp!(type(X)'First)
-- and then
- -- Btyp!(X) <= Btyp!(type(X)'Last)
+ -- PBtyp!(X) <= PBtyp!(type(X)'Last)
- -- where Btyp is an integer type large enough to cover the full
+ -- where PBtyp is an integer type large enough to cover the full
-- range of possible stored values (i.e. it is chosen on the basis
-- of the size of the type, not the range of the values). We write
-- this as two tests, rather than a range check, so that static
-- correct, even though a value greater than 127 looks signed to a
-- signed comparison.
- elsif Is_Unsigned_Type (Ptyp) then
+ elsif Is_Unsigned_Type (Ptyp)
+ or else (Is_Private_Type (Ptyp) and then Is_Unsigned_Type (Btyp))
+ then
if Esize (Ptyp) <= 32 then
- Btyp := RTE (RE_Unsigned_32);
+ PBtyp := RTE (RE_Unsigned_32);
else
- Btyp := RTE (RE_Unsigned_64);
+ PBtyp := RTE (RE_Unsigned_64);
end if;
Rewrite (N, Make_Range_Test);
else
if Esize (Ptyp) <= Esize (Standard_Integer) then
- Btyp := Standard_Integer;
+ PBtyp := Standard_Integer;
else
- Btyp := Universal_Integer;
+ PBtyp := Universal_Integer;
end if;
Rewrite (N, Make_Range_Test);
-------------------
when Attribute_Valid_Scalars => Valid_Scalars : declare
- Ftyp : Entity_Id;
+ Val_Typ : constant Entity_Id := Validated_View (Ptyp);
+ Comp_Typ : Entity_Id;
+ Expr : Node_Id;
begin
- if Present (Underlying_Type (Ptyp)) then
- Ftyp := Underlying_Type (Ptyp);
- else
- Ftyp := Ptyp;
- end if;
-
- -- Replace by True if no scalar parts
+ -- Assume that the prefix does not need validation
- if not Scalar_Part_Present (Ftyp) then
- Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
-
- -- For scalar types, Valid_Scalars is the same as Valid
+ Expr := Empty;
- elsif Is_Scalar_Type (Ftyp) then
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Valid,
- Prefix => Pref));
+ -- Attribute 'Valid_Scalars is not supported on private tagged types
- -- For array types, we construct a function that determines if there
- -- are any non-valid scalar subcomponents, and call the function.
- -- We only do this for arrays whose component type needs checking
+ if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then
+ null;
- elsif Is_Array_Type (Ftyp)
- and then Scalar_Part_Present (Component_Type (Ftyp))
- then
- Rewrite (N,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
- Parameter_Associations => New_List (Pref)));
+ -- Attribute 'Valid_Scalars evaluates to True when the type lacks
+ -- scalars.
- -- For record types, we construct a function that determines if there
- -- are any non-valid scalar subcomponents, and call the function.
+ elsif not Scalar_Part_Present (Val_Typ) then
+ null;
- elsif Is_Record_Type (Ftyp)
- and then Nkind (Type_Definition (Declaration_Node (Ftyp))) =
- N_Record_Definition
- then
- Rewrite (N,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc),
- Parameter_Associations => New_List (Pref)));
+ -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
+ -- validated type is a scalar type. Generate:
- -- Other record types or types with discriminants
+ -- Val_Typ (Pref)'Valid
- elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then
+ elsif Is_Scalar_Type (Val_Typ) then
+ Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)),
+ Attribute_Name => Name_Valid);
- -- Build expression with list of equality tests
+ -- Validate the scalar components of an array by iterating over all
+ -- dimensions of the array while checking individual components.
- declare
- C : Entity_Id;
- X : Node_Id;
- A : Name_Id;
+ elsif Is_Array_Type (Val_Typ) then
+ Comp_Typ := Validated_View (Component_Type (Val_Typ));
- begin
- X := New_Occurrence_Of (Standard_True, Loc);
- C := First_Component_Or_Discriminant (Ptyp);
- while Present (C) loop
- if not Scalar_Part_Present (Etype (C)) then
- goto Continue;
- elsif Is_Scalar_Type (Etype (C)) then
- A := Name_Valid;
- else
- A := Name_Valid_Scalars;
- end if;
+ if Scalar_Part_Present (Comp_Typ) then
+ Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Build_Array_VS_Func
+ (Attr => N,
+ Formal_Typ => Ptyp,
+ Array_Typ => Val_Typ,
+ Comp_Typ => Comp_Typ),
+ Loc),
+ Parameter_Associations => New_List (Pref));
+ end if;
- X :=
- Make_And_Then (Loc,
- Left_Opnd => X,
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => A,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Duplicate_Subexpr (Pref, Name_Req => True),
- Selector_Name =>
- New_Occurrence_Of (C, Loc))));
- <<Continue>>
- Next_Component_Or_Discriminant (C);
- end loop;
+ -- Validate the scalar components, discriminants of a record type by
+ -- examining the structure of a record type.
- Rewrite (N, X);
- end;
+ elsif Is_Record_Type (Val_Typ) then
+ Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Build_Record_VS_Func
+ (Attr => N,
+ Formal_Typ => Ptyp,
+ Rec_Typ => Val_Typ),
+ Loc),
+ Parameter_Associations => New_List (Pref));
+ end if;
- -- For all other types, result is True
+ -- Default the attribute to True when the type of the prefix does not
+ -- need validation.
- else
- Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
+ if No (Expr) then
+ Expr := New_Occurrence_Of (Standard_True, Loc);
end if;
- -- Result is always boolean, but never static
-
+ Rewrite (N, Expr);
Analyze_And_Resolve (N, Standard_Boolean);
Set_Is_Static_Expression (N, False);
end Valid_Scalars;
-- Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Image =>
+ -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
+ -- back-end knows how to handle this attribute directly.
+
+ if CodePeer_Mode then
+ return;
+ end if;
+
Exp_Imgv.Expand_Wide_Image_Attribute (N);
---------------------
-- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Wide_Image =>
+ -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
+ -- back-end knows how to handle this attribute directly.
+
+ if CodePeer_Mode then
+ return;
+ end if;
+
Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
----------------
-- is in use such as Shift-JIS, then characters that cannot be
-- represented using this encoding will not appear in any case.
- when Attribute_Wide_Value => Wide_Value :
- begin
+ when Attribute_Wide_Value =>
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Pref,
Intval => Int (Wide_Character_Encoding_Method)))))));
Analyze_And_Resolve (N, Typ);
- end Wide_Value;
---------------------
-- Wide_Wide_Value --
-- It's not quite right where typ = Wide_Wide_Character, because the
-- encoding method may not cover the whole character type ???
- when Attribute_Wide_Wide_Value => Wide_Wide_Value :
- begin
+ when Attribute_Wide_Wide_Value =>
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Pref,
Expressions => New_List (
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Occurrence_Of
(RTE (RE_Wide_Wide_String_To_String), Loc),
Intval => Int (Wide_Character_Encoding_Method)))))));
Analyze_And_Resolve (N, Typ);
- end Wide_Wide_Value;
---------------------
-- Wide_Wide_Width --
-- Unchecked_Union type. However, if the 'Write reference is
-- within the generated Output stream procedure, Write outputs
-- the components, and the default values of the discriminant
- -- are streamed by the Output procedure itself.
+ -- are streamed by the Output procedure itself. If there are
+ -- no default values this is also erroneous.
- if Is_Unchecked_Union (Base_Type (U_Type))
- and not Is_TSS (Current_Scope, TSS_Stream_Output)
- then
- Insert_Action (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction));
+ if Is_Unchecked_Union (Base_Type (U_Type)) then
+ if (not Is_TSS (Current_Scope, TSS_Stream_Output)
+ and not Is_TSS (Current_Scope, TSS_Stream_Write))
+ or else No (Discriminant_Default_Value
+ (First_Discriminant (U_Type)))
+ then
+ Rewrite (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+ Set_Etype (N, U_Type);
+ return;
+ end if;
end if;
if Has_Discriminants (U_Type)
-- The back end also handles the non-class-wide cases of Size
- when Attribute_Bit_Order |
- Attribute_Code_Address |
- Attribute_Definite |
- Attribute_Deref |
- Attribute_Null_Parameter |
- Attribute_Passed_By_Reference |
- Attribute_Pool_Address |
- Attribute_Scalar_Storage_Order =>
+ when Attribute_Bit_Order
+ | Attribute_Code_Address
+ | Attribute_Definite
+ | Attribute_Deref
+ | Attribute_Null_Parameter
+ | Attribute_Passed_By_Reference
+ | Attribute_Pool_Address
+ | Attribute_Scalar_Storage_Order
+ =>
null;
-- The following attributes are also handled by the back end, but return
-- a universal integer result, so may need a conversion for checking
-- that the result is in range.
- when Attribute_Aft |
- Attribute_Max_Alignment_For_Allocation =>
+ when Attribute_Aft
+ | Attribute_Max_Alignment_For_Allocation
+ =>
Apply_Universal_Integer_Attribute_Checks (N);
-- The following attributes should not appear at this stage, since they
-- have already been handled by the analyzer (and properly rewritten
-- with corresponding values or entities to represent the right values)
- when Attribute_Abort_Signal |
- Attribute_Address_Size |
- Attribute_Atomic_Always_Lock_Free |
- Attribute_Base |
- Attribute_Class |
- Attribute_Compiler_Version |
- Attribute_Default_Bit_Order |
- Attribute_Default_Scalar_Storage_Order |
- Attribute_Delta |
- Attribute_Denorm |
- Attribute_Digits |
- Attribute_Emax |
- Attribute_Enabled |
- Attribute_Epsilon |
- Attribute_Fast_Math |
- Attribute_First_Valid |
- Attribute_Has_Access_Values |
- Attribute_Has_Discriminants |
- Attribute_Has_Tagged_Values |
- Attribute_Large |
- Attribute_Last_Valid |
- Attribute_Library_Level |
- Attribute_Lock_Free |
- Attribute_Machine_Emax |
- Attribute_Machine_Emin |
- Attribute_Machine_Mantissa |
- Attribute_Machine_Overflows |
- Attribute_Machine_Radix |
- Attribute_Machine_Rounds |
- Attribute_Maximum_Alignment |
- Attribute_Model_Emin |
- Attribute_Model_Epsilon |
- Attribute_Model_Mantissa |
- Attribute_Model_Small |
- Attribute_Modulus |
- Attribute_Partition_ID |
- Attribute_Range |
- Attribute_Restriction_Set |
- Attribute_Safe_Emax |
- Attribute_Safe_First |
- Attribute_Safe_Large |
- Attribute_Safe_Last |
- Attribute_Safe_Small |
- Attribute_Scale |
- Attribute_Signed_Zeros |
- Attribute_Small |
- Attribute_Storage_Unit |
- Attribute_Stub_Type |
- Attribute_System_Allocator_Alignment |
- Attribute_Target_Name |
- Attribute_Type_Class |
- Attribute_Type_Key |
- Attribute_Unconstrained_Array |
- Attribute_Universal_Literal_String |
- Attribute_Wchar_T_Size |
- Attribute_Word_Size =>
+ when Attribute_Abort_Signal
+ | Attribute_Address_Size
+ | Attribute_Atomic_Always_Lock_Free
+ | Attribute_Base
+ | Attribute_Class
+ | Attribute_Compiler_Version
+ | Attribute_Default_Bit_Order
+ | Attribute_Default_Scalar_Storage_Order
+ | Attribute_Delta
+ | Attribute_Denorm
+ | Attribute_Digits
+ | Attribute_Emax
+ | Attribute_Enabled
+ | Attribute_Epsilon
+ | Attribute_Fast_Math
+ | Attribute_First_Valid
+ | Attribute_Has_Access_Values
+ | Attribute_Has_Discriminants
+ | Attribute_Has_Tagged_Values
+ | Attribute_Large
+ | Attribute_Last_Valid
+ | Attribute_Library_Level
+ | Attribute_Lock_Free
+ | Attribute_Machine_Emax
+ | Attribute_Machine_Emin
+ | Attribute_Machine_Mantissa
+ | Attribute_Machine_Overflows
+ | Attribute_Machine_Radix
+ | Attribute_Machine_Rounds
+ | Attribute_Maximum_Alignment
+ | Attribute_Model_Emin
+ | Attribute_Model_Epsilon
+ | Attribute_Model_Mantissa
+ | Attribute_Model_Small
+ | Attribute_Modulus
+ | Attribute_Partition_ID
+ | Attribute_Range
+ | Attribute_Restriction_Set
+ | Attribute_Safe_Emax
+ | Attribute_Safe_First
+ | Attribute_Safe_Large
+ | Attribute_Safe_Last
+ | Attribute_Safe_Small
+ | Attribute_Scale
+ | Attribute_Signed_Zeros
+ | Attribute_Small
+ | Attribute_Storage_Unit
+ | Attribute_Stub_Type
+ | Attribute_System_Allocator_Alignment
+ | Attribute_Target_Name
+ | Attribute_Type_Class
+ | Attribute_Type_Key
+ | Attribute_Unconstrained_Array
+ | Attribute_Universal_Literal_String
+ | Attribute_Wchar_T_Size
+ | Attribute_Word_Size
+ =>
raise Program_Error;
-- The Asm_Input and Asm_Output attributes are not expanded at this
-- stage, but will be eliminated in the expansion of the Asm call, see
-- Exp_Intr for details. So the back end will never see these either.
- when Attribute_Asm_Input |
- Attribute_Asm_Output =>
+ when Attribute_Asm_Input
+ | Attribute_Asm_Output
+ =>
null;
end case;
end if;
end Expand_Pred_Succ_Attribute;
+ ---------------------------
+ -- Expand_Size_Attribute --
+ ---------------------------
+
+ procedure Expand_Size_Attribute (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Pref : constant Node_Id := Prefix (N);
+ Ptyp : constant Entity_Id := Etype (Pref);
+ Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
+ Siz : Uint;
+
+ begin
+ -- Case of known RM_Size of a type
+
+ if (Id = Attribute_Size or else Id = Attribute_Value_Size)
+ and then Is_Entity_Name (Pref)
+ and then Is_Type (Entity (Pref))
+ and then Known_Static_RM_Size (Entity (Pref))
+ then
+ Siz := RM_Size (Entity (Pref));
+
+ -- Case of known Esize of a type
+
+ elsif Id = Attribute_Object_Size
+ and then Is_Entity_Name (Pref)
+ and then Is_Type (Entity (Pref))
+ and then Known_Static_Esize (Entity (Pref))
+ then
+ Siz := Esize (Entity (Pref));
+
+ -- Case of known size of object
+
+ elsif Id = Attribute_Size
+ and then Is_Entity_Name (Pref)
+ and then Is_Object (Entity (Pref))
+ and then Known_Esize (Entity (Pref))
+ and then Known_Static_Esize (Entity (Pref))
+ then
+ Siz := Esize (Entity (Pref));
+
+ -- For an array component, we can do Size in the front end if the
+ -- component_size of the array is set.
+
+ elsif Nkind (Pref) = N_Indexed_Component then
+ Siz := Component_Size (Etype (Prefix (Pref)));
+
+ -- For a record component, we can do Size in the front end if there is a
+ -- component clause, or if the record is packed and the component's size
+ -- is known at compile time.
+
+ elsif Nkind (Pref) = N_Selected_Component then
+ declare
+ Rec : constant Entity_Id := Etype (Prefix (Pref));
+ Comp : constant Entity_Id := Entity (Selector_Name (Pref));
+
+ begin
+ if Present (Component_Clause (Comp)) then
+ Siz := Esize (Comp);
+
+ elsif Is_Packed (Rec) then
+ Siz := RM_Size (Ptyp);
+
+ else
+ Apply_Universal_Integer_Attribute_Checks (N);
+ return;
+ end if;
+ end;
+
+ -- All other cases are handled by the back end
+
+ else
+ -- If Size is applied to a formal parameter that is of a packed
+ -- array subtype, then apply Size to the actual subtype.
+
+ if Is_Entity_Name (Pref)
+ and then Is_Formal (Entity (Pref))
+ and then Is_Array_Type (Ptyp)
+ and then Is_Packed (Ptyp)
+ then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
+ Attribute_Name => Name_Size));
+ Analyze_And_Resolve (N, Typ);
+
+ -- If Size is applied to a dereference of an access to unconstrained
+ -- packed array, the back end needs to see its unconstrained nominal
+ -- type, but also a hint to the actual constrained type.
+
+ elsif Nkind (Pref) = N_Explicit_Dereference
+ and then Is_Array_Type (Ptyp)
+ and then not Is_Constrained (Ptyp)
+ and then Is_Packed (Ptyp)
+ then
+ Set_Actual_Designated_Subtype (Pref, Get_Actual_Subtype (Pref));
+
+ -- If Size was applied to a slice of a bit-packed array, we rewrite
+ -- it into the product of Length and Component_Size. We need to do so
+ -- because bit-packed arrays are represented internally as arrays of
+ -- System.Unsigned_Types.Packed_Byte for code generation purposes so
+ -- the size is always rounded up in the back end.
+
+ elsif Nkind (Pref) = N_Slice and then Is_Bit_Packed_Array (Ptyp) then
+ Rewrite (N,
+ Make_Op_Multiply (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Pref, True),
+ Attribute_Name => Name_Length),
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Pref, True),
+ Attribute_Name => Name_Component_Size)));
+ Analyze_And_Resolve (N, Typ);
+ end if;
+
+ -- Apply the required checks last, after rewriting has taken place
+
+ Apply_Universal_Integer_Attribute_Checks (N);
+ return;
+ end if;
+
+ -- Common processing for record and array component case
+
+ if Siz /= No_Uint and then Siz /= 0 then
+ declare
+ CS : constant Boolean := Comes_From_Source (N);
+
+ begin
+ Rewrite (N, Make_Integer_Literal (Loc, Siz));
+
+ -- This integer literal is not a static expression. We do not
+ -- call Analyze_And_Resolve here, because this would activate
+ -- the circuit for deciding that a static value was out of range,
+ -- and we don't want that.
+
+ -- So just manually set the type, mark the expression as
+ -- nonstatic, and then ensure that the result is checked
+ -- properly if the attribute comes from source (if it was
+ -- internally generated, we never need a constraint check).
+
+ Set_Etype (N, Typ);
+ Set_Is_Static_Expression (N, False);
+
+ if CS then
+ Apply_Constraint_Check (N, Typ);
+ end if;
+ end;
+ end if;
+ end Expand_Size_Attribute;
+
-----------------------------
-- Expand_Update_Attribute --
-----------------------------
is
Base_Typ : constant Entity_Id := Base_Type (Typ);
Ent : constant Entity_Id := TSS (Typ, Nam);
-
- function Is_Available (Entity : RE_Id) return Boolean;
- pragma Inline (Is_Available);
- -- Function to check whether the specified run-time call is available
- -- in the run time used. In the case of a configurable run time, it
- -- is normal that some subprograms are not there.
- --
- -- I don't understand this routine at all, why is this not just a
- -- call to RTE_Available? And if for some reason we need a different
- -- routine with different semantics, why is not in Rtsfind ???
-
- ------------------
- -- Is_Available --
- ------------------
-
- function Is_Available (Entity : RE_Id) return Boolean is
- begin
- -- Assume that the unit will always be available when using a
- -- "normal" (not configurable) run time.
-
- return not Configurable_Run_Time_Mode or else RTE_Available (Entity);
- end Is_Available;
-
- -- Start of processing for Find_Stream_Subprogram
-
begin
if Present (Ent) then
return Ent;
-- that stream routines for string types are not present (they require
-- file system support). In this case, the specific stream routines for
-- strings are not used, relying on the regular stream mechanism
- -- instead. That is why we include the test Is_Available when dealing
+ -- instead. That is why we include the test RTE_Available when dealing
-- with these cases.
- if not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) then
+ if not Is_Predefined_Unit (Current_Sem_Unit) then
-- Storage_Array as defined in package System.Storage_Elements
if Is_RTE (Base_Typ, RE_Storage_Array) then
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Storage_Array_Input)
+ and then RTE_Available (RE_Storage_Array_Input)
then
return RTE (RE_Storage_Array_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Storage_Array_Output)
+ and then RTE_Available (RE_Storage_Array_Output)
then
return RTE (RE_Storage_Array_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Storage_Array_Read)
+ and then RTE_Available (RE_Storage_Array_Read)
then
return RTE (RE_Storage_Array_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Storage_Array_Write)
+ and then RTE_Available (RE_Storage_Array_Write)
then
return RTE (RE_Storage_Array_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Storage_Array_Input_Blk_IO)
+ and then RTE_Available (RE_Storage_Array_Input_Blk_IO)
then
return RTE (RE_Storage_Array_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Storage_Array_Output_Blk_IO)
+ and then RTE_Available (RE_Storage_Array_Output_Blk_IO)
then
return RTE (RE_Storage_Array_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Storage_Array_Read_Blk_IO)
+ and then RTE_Available (RE_Storage_Array_Read_Blk_IO)
then
return RTE (RE_Storage_Array_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Storage_Array_Write_Blk_IO)
+ and then RTE_Available (RE_Storage_Array_Write_Blk_IO)
then
return RTE (RE_Storage_Array_Write_Blk_IO);
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Stream_Element_Array_Input)
+ and then RTE_Available (RE_Stream_Element_Array_Input)
then
return RTE (RE_Stream_Element_Array_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Stream_Element_Array_Output)
+ and then RTE_Available (RE_Stream_Element_Array_Output)
then
return RTE (RE_Stream_Element_Array_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Stream_Element_Array_Read)
+ and then RTE_Available (RE_Stream_Element_Array_Read)
then
return RTE (RE_Stream_Element_Array_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Stream_Element_Array_Write)
+ and then RTE_Available (RE_Stream_Element_Array_Write)
then
return RTE (RE_Stream_Element_Array_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO)
+ and then RTE_Available (RE_Stream_Element_Array_Input_Blk_IO)
then
return RTE (RE_Stream_Element_Array_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO)
+ and then RTE_Available (RE_Stream_Element_Array_Output_Blk_IO)
then
return RTE (RE_Stream_Element_Array_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO)
+ and then RTE_Available (RE_Stream_Element_Array_Read_Blk_IO)
then
return RTE (RE_Stream_Element_Array_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO)
+ and then RTE_Available (RE_Stream_Element_Array_Write_Blk_IO)
then
return RTE (RE_Stream_Element_Array_Write_Blk_IO);
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_String_Input)
+ and then RTE_Available (RE_String_Input)
then
return RTE (RE_String_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_String_Output)
+ and then RTE_Available (RE_String_Output)
then
return RTE (RE_String_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_String_Read)
+ and then RTE_Available (RE_String_Read)
then
return RTE (RE_String_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_String_Write)
+ and then RTE_Available (RE_String_Write)
then
return RTE (RE_String_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_String_Input_Blk_IO)
+ and then RTE_Available (RE_String_Input_Blk_IO)
then
return RTE (RE_String_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_String_Output_Blk_IO)
+ and then RTE_Available (RE_String_Output_Blk_IO)
then
return RTE (RE_String_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_String_Read_Blk_IO)
+ and then RTE_Available (RE_String_Read_Blk_IO)
then
return RTE (RE_String_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_String_Write_Blk_IO)
+ and then RTE_Available (RE_String_Write_Blk_IO)
then
return RTE (RE_String_Write_Blk_IO);
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Wide_String_Input)
+ and then RTE_Available (RE_Wide_String_Input)
then
return RTE (RE_Wide_String_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Wide_String_Output)
+ and then RTE_Available (RE_Wide_String_Output)
then
return RTE (RE_Wide_String_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Wide_String_Read)
+ and then RTE_Available (RE_Wide_String_Read)
then
return RTE (RE_Wide_String_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Wide_String_Write)
+ and then RTE_Available (RE_Wide_String_Write)
then
return RTE (RE_Wide_String_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Wide_String_Input_Blk_IO)
+ and then RTE_Available (RE_Wide_String_Input_Blk_IO)
then
return RTE (RE_Wide_String_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Wide_String_Output_Blk_IO)
+ and then RTE_Available (RE_Wide_String_Output_Blk_IO)
then
return RTE (RE_Wide_String_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Wide_String_Read_Blk_IO)
+ and then RTE_Available (RE_Wide_String_Read_Blk_IO)
then
return RTE (RE_Wide_String_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Wide_String_Write_Blk_IO)
+ and then RTE_Available (RE_Wide_String_Write_Blk_IO)
then
return RTE (RE_Wide_String_Write_Blk_IO);
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Wide_Wide_String_Input)
+ and then RTE_Available (RE_Wide_Wide_String_Input)
then
return RTE (RE_Wide_Wide_String_Input);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Wide_Wide_String_Output)
+ and then RTE_Available (RE_Wide_Wide_String_Output)
then
return RTE (RE_Wide_Wide_String_Output);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Wide_Wide_String_Read)
+ and then RTE_Available (RE_Wide_Wide_String_Read)
then
return RTE (RE_Wide_Wide_String_Read);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Wide_Wide_String_Write)
+ and then RTE_Available (RE_Wide_Wide_String_Write)
then
return RTE (RE_Wide_Wide_String_Write);
else
if Nam = TSS_Stream_Input
- and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
+ and then RTE_Available (RE_Wide_Wide_String_Input_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Input_Blk_IO);
elsif Nam = TSS_Stream_Output
- and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
+ and then RTE_Available (RE_Wide_Wide_String_Output_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Output_Blk_IO);
elsif Nam = TSS_Stream_Read
- and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
+ and then RTE_Available (RE_Wide_Wide_String_Read_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Read_Blk_IO);
elsif Nam = TSS_Stream_Write
- and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
+ and then RTE_Available (RE_Wide_Wide_String_Write_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Write_Blk_IO);
function Is_GCC_Target return Boolean is
begin
return not CodePeer_Mode
- and then not AAMP_On_Target
- and then not Generate_C_Code;
+ and then not Modify_Tree_For_C;
end Is_GCC_Target;
-- Start of processing for Is_Inline_Floating_Point_Attribute
begin
- -- Machine and Model can be expanded by the GCC and AAMP back ends only
+ -- Machine and Model can be expanded by the GCC back end only
if Id = Attribute_Machine or else Id = Attribute_Model then
- return Is_GCC_Target or else AAMP_On_Target;
+ return Is_GCC_Target;
-- Remaining cases handled by all back ends are Rounding and Truncation
-- when appearing as the operand of a conversion to some integer type.
return False;
end if;
- -- Here we are in the integer conversion context
-
- -- Very probably we should also recognize the cases of Machine_Rounding
- -- and unbiased rounding in this conversion context, but the back end is
- -- not yet prepared to handle these cases ???
+ -- Here we are in the integer conversion context. We reuse Rounding for
+ -- Machine_Rounding as System.Fat_Gen, which is a permissible behavior.
- return Id = Attribute_Rounding or else Id = Attribute_Truncation;
+ return
+ Id = Attribute_Rounding
+ or else Id = Attribute_Machine_Rounding
+ or else Id = Attribute_Truncation;
end Is_Inline_Floating_Point_Attribute;
end Exp_Attr;
projects / thirdparty / gcc.git / blobdiff