gnat_ugn.texi: Minor spelling correction.
2014-07-30 Robert Dewar <dewar@adacore.com> * gnat_ugn.texi: Minor spelling correction. * makeutl.adb: Minor code reorganization. * exp_ch4.adb, exp_aggr.adb, exp_ch3.adb: Minor reformatting. 2014-07-30 Robert Dewar <dewar@adacore.com> * einfo.ads (Has_Unchecked_Union): Document that this is used to check for illegal Valid_Scalars attribute references. * exp_attr.adb (Build_Record_VS_Func): New function (Expand_N_Attribute_Reference, case Valid_Scalars): Call this function. * gnat_rm.texi: Document 'Valid_Scalars cannot be applied to Unchecked_Union Add note on 'Valid_Scalars generating a lot of code. * sem_attr.adb (Analyze_Attribute, case Valid_Scalars): Give error on attempt to apply Valid_Scalars to Unchecked_Union type. From-SVN: r213298
This commit is contained in:
Robert Dewar
Arnaud Charlet
parent
ad9560ea43
commit
45ec05e18a
@ -1,3 +1,22 @@
|
||||
2014-07-30 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* gnat_ugn.texi: Minor spelling correction.
|
||||
* makeutl.adb: Minor code reorganization.
|
||||
* exp_ch4.adb, exp_aggr.adb, exp_ch3.adb: Minor reformatting.
|
||||
|
||||
2014-07-30 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* einfo.ads (Has_Unchecked_Union): Document that this is used
|
||||
to check for illegal Valid_Scalars attribute references.
|
||||
* exp_attr.adb (Build_Record_VS_Func): New function
|
||||
(Expand_N_Attribute_Reference, case Valid_Scalars): Call this
|
||||
function.
|
||||
* gnat_rm.texi: Document 'Valid_Scalars cannot be applied to
|
||||
Unchecked_Union Add note on 'Valid_Scalars generating a lot
|
||||
of code.
|
||||
* sem_attr.adb (Analyze_Attribute, case Valid_Scalars): Give
|
||||
error on attempt to apply Valid_Scalars to Unchecked_Union type.
|
||||
|
||||
2014-07-30 Steve Baird <baird@adacore.com>
|
||||
|
||||
* exp_ch4.adb (Expand_N_Indexed_Component): Disable optimized handling
|
||||
|
||||
@ -1955,9 +1955,9 @@ package Einfo is
|
||||
-- Defined in all type entities. Set on unchecked unions themselves
|
||||
-- and (recursively) on any composite type which has a component for
|
||||
-- which Has_Unchecked_Union is set. The meaning is that a comparison
|
||||
-- operation for the type is not permitted. Note that the flag is not
|
||||
-- set on access types, even if they designate an object that has
|
||||
-- the flag Has_Unchecked_Union set.
|
||||
-- operation or 'Valid_Scalars reference for the type is not permitted.
|
||||
-- Note that the flag is not set on access types, even if they designate
|
||||
-- an object that has the flag Has_Unchecked_Union set.
|
||||
|
||||
-- Has_Unknown_Discriminants (Flag72)
|
||||
-- Defined in all entities. Set for types with unknown discriminants.
|
||||
|
||||
@ -2847,12 +2847,11 @@ package body Exp_Aggr is
|
||||
then
|
||||
declare
|
||||
Assoc : constant Node_Id :=
|
||||
First (Component_Associations (Expr_Q));
|
||||
First (Component_Associations (Expr_Q));
|
||||
Decl : Node_Id;
|
||||
|
||||
begin
|
||||
if
|
||||
Nkind (First (Choices (Assoc))) = N_Others_Choice
|
||||
if Nkind (First (Choices (Assoc))) = N_Others_Choice
|
||||
then
|
||||
Decl :=
|
||||
Build_Actual_Subtype_Of_Component
|
||||
|
||||
@ -84,6 +84,14 @@ package body Exp_Attr is
|
||||
-- value returned is the entity of the constructed function body. We do not
|
||||
-- bother to generate a separate spec for this subprogram.
|
||||
|
||||
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.
|
||||
|
||||
procedure Compile_Stream_Body_In_Scope
|
||||
(N : Node_Id;
|
||||
Decl : Node_Id;
|
||||
@ -202,10 +210,10 @@ package body Exp_Attr is
|
||||
Nod : Node_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;
|
||||
Func_Id : Entity_Id;
|
||||
Formals : List_Id;
|
||||
|
||||
function Test_Component return List_Id;
|
||||
@ -298,8 +306,6 @@ package body Exp_Attr is
|
||||
|
||||
begin
|
||||
Index_List := New_List;
|
||||
Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
|
||||
|
||||
Body_Stmts := Test_One_Dimension (1);
|
||||
|
||||
-- Parameter is always (A : A_Typ)
|
||||
@ -333,9 +339,279 @@ package body Exp_Attr is
|
||||
Set_Debug_Info_Off (Func_Id);
|
||||
end if;
|
||||
|
||||
Set_Is_Pure (Func_Id);
|
||||
return Func_Id;
|
||||
end Build_Array_VS_Func;
|
||||
|
||||
--------------------------
|
||||
-- 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
|
||||
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.
|
||||
|
||||
------------------
|
||||
-- Make_VS_Case --
|
||||
------------------
|
||||
|
||||
-- <Make_VS_If on shared components>
|
||||
|
||||
-- case X.D1 is
|
||||
-- when V1 => <Make_VS_Case> on subcomponents
|
||||
-- ...
|
||||
-- when Vn => <Make_VS_Case> on subcomponents
|
||||
-- end case;
|
||||
|
||||
function Make_VS_Case
|
||||
(E : Entity_Id;
|
||||
CL : Node_Id;
|
||||
Discrs : Elist_Id := New_Elmt_List) return List_Id
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (E);
|
||||
Result : constant List_Id := New_List;
|
||||
Variant : Node_Id;
|
||||
Alt_List : List_Id;
|
||||
|
||||
begin
|
||||
Append_To (Result, Make_VS_If (E, Component_Items (CL)));
|
||||
|
||||
if No (Variant_Part (CL)) then
|
||||
return Result;
|
||||
end if;
|
||||
|
||||
Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
|
||||
|
||||
if No (Variant) then
|
||||
return Result;
|
||||
end if;
|
||||
|
||||
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;
|
||||
|
||||
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));
|
||||
|
||||
return Result;
|
||||
end Make_VS_Case;
|
||||
|
||||
----------------
|
||||
-- Make_VS_If --
|
||||
----------------
|
||||
|
||||
-- Generates:
|
||||
|
||||
-- if
|
||||
-- not X.C1'Valid_Scalars
|
||||
-- or else
|
||||
-- not X.C2'Valid_Scalars
|
||||
-- ...
|
||||
-- then
|
||||
-- return False;
|
||||
-- end if;
|
||||
|
||||
-- or a null statement if the list L is empty
|
||||
|
||||
function Make_VS_If
|
||||
(E : Entity_Id;
|
||||
L : List_Id) return Node_Id
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (E);
|
||||
C : Node_Id;
|
||||
Def_Id : Entity_Id;
|
||||
Field_Name : Name_Id;
|
||||
Cond : Node_Id;
|
||||
|
||||
begin
|
||||
if No (L) then
|
||||
return Make_Null_Statement (Loc);
|
||||
|
||||
else
|
||||
Cond := Empty;
|
||||
|
||||
C := First_Non_Pragma (L);
|
||||
while Present (C) loop
|
||||
Def_Id := Defining_Identifier (C);
|
||||
Field_Name := Chars (Def_Id);
|
||||
|
||||
-- The tags need not be checked since they will always be valid
|
||||
|
||||
-- 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.
|
||||
|
||||
-- Don't bother with abstract parent in interface case
|
||||
|
||||
if Field_Name = Name_uParent
|
||||
and then Is_Interface (Etype (Def_Id))
|
||||
then
|
||||
null;
|
||||
|
||||
-- Don't bother with tag, always valid, and not scalar anyway
|
||||
|
||||
elsif Field_Name = Name_uTag then
|
||||
null;
|
||||
|
||||
-- Don't bother with component with no scalar components
|
||||
|
||||
elsif not Scalar_Part_Present (Etype (Def_Id)) then
|
||||
null;
|
||||
|
||||
-- Normal case, generate Valid_Scalars attribute reference
|
||||
|
||||
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 (C);
|
||||
end loop;
|
||||
|
||||
if No (Cond) then
|
||||
return Make_Null_Statement (Loc);
|
||||
|
||||
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;
|
||||
|
||||
-- Local Declarations
|
||||
|
||||
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;
|
||||
|
||||
begin
|
||||
Append_To (Pspecs,
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => X,
|
||||
Parameter_Type => New_Occurrence_Of (R_Type, Loc)));
|
||||
|
||||
Append_To (Stmts,
|
||||
Make_VS_If (R_Type, Discriminant_Specifications (Def)));
|
||||
Append_List_To (Stmts, Make_VS_Case (R_Type, Comps));
|
||||
|
||||
Append_To (Stmts,
|
||||
Make_Simple_Return_Statement (Loc,
|
||||
Expression => New_Occurrence_Of (Standard_True, Loc)));
|
||||
|
||||
Insert_Action (Nod,
|
||||
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)),
|
||||
Declarations => New_List,
|
||||
Handled_Statement_Sequence =>
|
||||
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;
|
||||
|
||||
----------------------------------
|
||||
-- Compile_Stream_Body_In_Scope --
|
||||
----------------------------------
|
||||
@ -6377,14 +6653,18 @@ package body Exp_Attr is
|
||||
Ftyp := Ptyp;
|
||||
end if;
|
||||
|
||||
-- Replace by True if no scalar parts
|
||||
|
||||
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
|
||||
|
||||
if Is_Scalar_Type (Ftyp) then
|
||||
elsif Is_Scalar_Type (Ftyp) then
|
||||
Rewrite (N,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Valid,
|
||||
Prefix => Pref));
|
||||
Analyze_And_Resolve (N, Standard_Boolean);
|
||||
|
||||
-- For array types, we construct a function that determines if there
|
||||
-- are any non-valid scalar subcomponents, and call the function.
|
||||
@ -6399,14 +6679,25 @@ package body Exp_Attr is
|
||||
New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
|
||||
Parameter_Associations => New_List (Pref)));
|
||||
|
||||
Analyze_And_Resolve (N, Standard_Boolean);
|
||||
-- For record types, we construct a function that determines if there
|
||||
-- are any non-valid scalar subcomponents, and call the function.
|
||||
|
||||
-- For record types, we build a big if expression, applying Valid or
|
||||
-- Valid_Scalars as appropriate to all relevant components.
|
||||
|
||||
elsif (Is_Record_Type (Ptyp) or else Has_Discriminants (Ptyp))
|
||||
and then Scalar_Part_Present (Ptyp)
|
||||
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)));
|
||||
|
||||
-- Other record types or types with discriminants
|
||||
|
||||
elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then
|
||||
|
||||
-- Build expression with list of equality tests
|
||||
|
||||
declare
|
||||
C : Entity_Id;
|
||||
X : Node_Id;
|
||||
@ -6441,16 +6732,18 @@ package body Exp_Attr is
|
||||
end loop;
|
||||
|
||||
Rewrite (N, X);
|
||||
Analyze_And_Resolve (N, Standard_Boolean);
|
||||
end;
|
||||
|
||||
-- For all other types, result is True (but not static)
|
||||
-- For all other types, result is True
|
||||
|
||||
else
|
||||
Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
|
||||
Analyze_And_Resolve (N, Standard_Boolean);
|
||||
Set_Is_Static_Expression (N, False);
|
||||
end if;
|
||||
|
||||
-- Result is always boolean, but never static
|
||||
|
||||
Analyze_And_Resolve (N, Standard_Boolean);
|
||||
Set_Is_Static_Expression (N, False);
|
||||
end Valid_Scalars;
|
||||
|
||||
-----------
|
||||
|
||||
@ -147,7 +147,7 @@ package body Exp_Ch3 is
|
||||
-- The resulting operation is a TSS subprogram.
|
||||
|
||||
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
|
||||
-- Create An Equality function for the non-tagged variant record 'Typ'
|
||||
-- Create An Equality function for the non-tagged variant record Typ
|
||||
-- and attach it to the TSS list
|
||||
|
||||
procedure Check_Stream_Attributes (Typ : Entity_Id);
|
||||
@ -442,9 +442,7 @@ package body Exp_Ch3 is
|
||||
|
||||
Ctyp := Etype (Comp);
|
||||
|
||||
if not Is_Array_Type (Ctyp)
|
||||
or else Number_Dimensions (Ctyp) > 1
|
||||
then
|
||||
if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then
|
||||
goto Continue;
|
||||
end if;
|
||||
|
||||
@ -4279,9 +4277,9 @@ package body Exp_Ch3 is
|
||||
end if;
|
||||
end Build_Untagged_Equality;
|
||||
|
||||
------------------------------------
|
||||
-----------------------------------
|
||||
-- Build_Variant_Record_Equality --
|
||||
------------------------------------
|
||||
-----------------------------------
|
||||
|
||||
-- Generates:
|
||||
|
||||
@ -4289,13 +4287,13 @@ package body Exp_Ch3 is
|
||||
-- begin
|
||||
-- -- Compare discriminants
|
||||
|
||||
-- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then
|
||||
-- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then
|
||||
-- return False;
|
||||
-- end if;
|
||||
|
||||
-- -- Compare components
|
||||
|
||||
-- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then
|
||||
-- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then
|
||||
-- return False;
|
||||
-- end if;
|
||||
|
||||
@ -4303,12 +4301,12 @@ package body Exp_Ch3 is
|
||||
|
||||
-- case X.D1 is
|
||||
-- when V1 =>
|
||||
-- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then
|
||||
-- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then
|
||||
-- return False;
|
||||
-- end if;
|
||||
-- ...
|
||||
-- when Vn =>
|
||||
-- if False or else X.Cn /= Y.Cn then
|
||||
-- if X.Cn /= Y.Cn or else ... then
|
||||
-- return False;
|
||||
-- end if;
|
||||
-- end case;
|
||||
@ -4323,13 +4321,8 @@ package body Exp_Ch3 is
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
|
||||
|
||||
X : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => Name_X);
|
||||
|
||||
Y : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => Name_Y);
|
||||
X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
|
||||
Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
|
||||
|
||||
Def : constant Node_Id := Parent (Typ);
|
||||
Comps : constant Node_Id := Component_List (Type_Definition (Def));
|
||||
@ -4357,7 +4350,6 @@ package body Exp_Ch3 is
|
||||
declare
|
||||
Parent_Eq : constant Entity_Id :=
|
||||
TSS (Root_Type (Typ), TSS_Composite_Equality);
|
||||
|
||||
begin
|
||||
if Present (Parent_Eq) then
|
||||
Copy_TSS (Parent_Eq, Typ);
|
||||
@ -8805,6 +8797,7 @@ package body Exp_Ch3 is
|
||||
------------------
|
||||
|
||||
-- <Make_Eq_If shared components>
|
||||
|
||||
-- case X.D1 is
|
||||
-- when V1 => <Make_Eq_Case> on subcomponents
|
||||
-- ...
|
||||
|
||||
@ -6164,11 +6164,15 @@ package body Exp_Ch4 is
|
||||
-- messing especially in the packed case, but more importantly bypasses
|
||||
-- some problems in handling this peculiar case, for example, the issue
|
||||
-- of dealing specially with object renamings.
|
||||
-- This optimization is disabled for CodePeer because it can transform
|
||||
-- an index-check constraint_error into a range-check constraint_error
|
||||
-- and CodePeer cares about that distinction.
|
||||
|
||||
if Nkind (P) = N_Slice and then not CodePeer_Mode then
|
||||
if Nkind (P) = N_Slice
|
||||
|
||||
-- This optimization is disabled for CodePeer because it can transform
|
||||
-- an index-check constraint_error into a range-check constraint_error
|
||||
-- and CodePeer cares about that distinction.
|
||||
|
||||
and then not CodePeer_Mode
|
||||
then
|
||||
Rewrite (N,
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix => Prefix (P),
|
||||
|
||||
@ -10163,6 +10163,16 @@ be determined at compile time that the prefix of the attribute has no
|
||||
scalar parts (e.g., if the prefix is of an access type, an interface type,
|
||||
an undiscriminated task type, or an undiscriminated protected type).
|
||||
|
||||
For scalar types, @code{Valid_Scalars} is equivalent to @code{Valid}. The use
|
||||
of this attribute is not permitted for @code{Unchecked_Union} types for which
|
||||
in general it is not possible to determine the values of the discriminants.
|
||||
|
||||
Note: @code{Valid_Scalars} can generate a lot of code, especially in the case
|
||||
of a large variant record. If the attribute is called in many places in the
|
||||
same program applied to objects of the same type, it can reduce program size
|
||||
to write a function with a single use of the attribute, and then call that
|
||||
function from multiple places.
|
||||
|
||||
@node Attribute VADS_Size
|
||||
@unnumberedsec Attribute VADS_Size
|
||||
@cindex @code{Size}, VADS compatibility
|
||||
|
||||
@ -19972,7 +19972,7 @@ by hand.
|
||||
|
||||
@item --omit-sloc
|
||||
@cindex @option{--omit-sloc} (@command{gnattest})
|
||||
Supresses comment line containing file name and line number of corresponding
|
||||
Suppresses comment line containing file name and line number of corresponding
|
||||
subprograms in test skeletons.
|
||||
|
||||
@end table
|
||||
|
||||
@ -2912,26 +2912,26 @@ package body Makeutl is
|
||||
is
|
||||
|
||||
procedure Do_Insert
|
||||
(Project : Project_Id;
|
||||
Tree : Project_Tree_Ref;
|
||||
Context : Project_Context);
|
||||
(Project : Project_Id;
|
||||
Tree : Project_Tree_Ref;
|
||||
Context : Project_Context);
|
||||
-- Local procedures must be commented ???
|
||||
|
||||
---------------
|
||||
-- Do_Insert --
|
||||
---------------
|
||||
|
||||
procedure Do_Insert
|
||||
(Project : Project_Id;
|
||||
Tree : Project_Tree_Ref;
|
||||
Context : Project_Context)
|
||||
(Project : Project_Id;
|
||||
Tree : Project_Tree_Ref;
|
||||
Context : Project_Context)
|
||||
is
|
||||
Unit_Based : constant Boolean :=
|
||||
Unique_Compile
|
||||
or else not Builder_Data (Tree).Closure_Needed;
|
||||
-- When Unit_Based is True, put in the queue all compilable
|
||||
-- sources including the unit based (Ada) one. When Unit_Based is
|
||||
-- False, put the Ada sources only when they are in a library
|
||||
-- project.
|
||||
-- When Unit_Based is True, we enqueue all compilable sources
|
||||
-- including the unit based (Ada) one. When Unit_Based is False,
|
||||
-- put the Ada sources only when they are in a library project.
|
||||
|
||||
Iter : Source_Iterator;
|
||||
Source : Prj.Source_Id;
|
||||
@ -2942,9 +2942,7 @@ package body Makeutl is
|
||||
-- Nothing to do when "-u" was specified and some files were
|
||||
-- specified on the command line
|
||||
|
||||
if Unique_Compile
|
||||
and then Mains.Number_Of_Mains (Tree) > 0
|
||||
then
|
||||
if Unique_Compile and then Mains.Number_Of_Mains (Tree) > 0 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
@ -2955,16 +2953,13 @@ package body Makeutl is
|
||||
|
||||
if Is_Allowed_Language (Source.Language.Name)
|
||||
and then Is_Compilable (Source)
|
||||
and then
|
||||
(All_Projects
|
||||
or else Is_Extending (Project, Source.Project))
|
||||
and then (All_Projects
|
||||
or else Is_Extending (Project, Source.Project))
|
||||
and then not Source.Locally_Removed
|
||||
and then Source.Replaced_By = No_Source
|
||||
and then
|
||||
(not Source.Project.Externally_Built
|
||||
or else
|
||||
(Is_Extending (Project, Source.Project)
|
||||
and then not Project.Externally_Built))
|
||||
and then (not Source.Project.Externally_Built
|
||||
or else (Is_Extending (Project, Source.Project)
|
||||
and then not Project.Externally_Built))
|
||||
and then Source.Kind /= Sep
|
||||
and then Source.Path /= No_Path_Information
|
||||
then
|
||||
@ -2988,19 +2983,20 @@ package body Makeutl is
|
||||
if Source.Unit /= No_Unit_Index
|
||||
and then
|
||||
(Source.Project.Library
|
||||
or else Project.Qualifier = Aggregate_Library
|
||||
or else Context.In_Aggregate_Lib)
|
||||
or else Project.Qualifier = Aggregate_Library
|
||||
or else Context.In_Aggregate_Lib)
|
||||
and then Source.Project.Standalone_Library /= No
|
||||
then
|
||||
-- Check if the unit is in the interface
|
||||
|
||||
OK := False;
|
||||
|
||||
declare
|
||||
List : String_List_Id :=
|
||||
Source.Project.Lib_Interface_ALIs;
|
||||
List : String_List_Id;
|
||||
Element : String_Element;
|
||||
|
||||
begin
|
||||
List := Source.Project.Lib_Interface_ALIs;
|
||||
while List /= Nil_String loop
|
||||
Element :=
|
||||
Project_Tree.Shared.String_Elements.Table
|
||||
|
||||
@ -6589,13 +6589,24 @@ package body Sem_Attr is
|
||||
when Attribute_Valid_Scalars =>
|
||||
Check_E0;
|
||||
Check_Object_Reference (P);
|
||||
|
||||
if not Scalar_Part_Present (P_Type) then
|
||||
Error_Attr_P ("??attribute % always True, no scalars to check");
|
||||
end if;
|
||||
|
||||
Set_Etype (N, Standard_Boolean);
|
||||
|
||||
-- Following checks are only for source types
|
||||
|
||||
if Comes_From_Source (N) then
|
||||
if not Scalar_Part_Present (P_Type) then
|
||||
Error_Attr_P
|
||||
("??attribute % always True, no scalars to check");
|
||||
end if;
|
||||
|
||||
-- Not allowed for unchecked union type
|
||||
|
||||
if Has_Unchecked_Union (P_Type) then
|
||||
Error_Attr_P
|
||||
("attribute % not allowed for Unchecked_Union type");
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-----------
|
||||
-- Value --
|
||||
-----------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user