[multiple changes]
2012-12-05 Yannick Moy <moy@adacore.com> * urealp.ads: Minor rewording. 2012-12-05 Yannick Moy <moy@adacore.com> * aspects.ads (No_Duplicates_Allowed): Forbid use of duplicate Contract_Cases aspects. * sem_prag.adb (Analyze_Pragma/Pragma_Contract_Case): Rename POST_CASE into CONTRACT_CASE in both grammar and code, to be consistent with current language definition. Issue a more precise error message when the pragma duplicates another pragma or aspect. 2012-12-05 Hristian Kirtchev <kirtchev@adacore.com> * exp_attr.adb (Expand_N_Attribute_Reference): Add processing for attribute Update. (Expand_Update_Attribute): New routine. * par-ch4.adb (P_Name): The sole expression of attribute Update is an aggregate, parse it accordingly. * sem_attr.adb (Analyze_Attribute): Verify the legality of attribute Update. (Eval_Attribute): Attribute Update does not need evaluation because it is never static. * snames.ads-tmpl: Add Name_Update to the list of special names recognized by the compiler. Add an Attribute_Id for Update. 2012-12-05 Ed Schonberg <schonberg@adacore.com> * exp_util.adb (Remove_Side_Effects): For purposes of removing side effects, qualified expressions do not receive a special treatment, even though in Ada 2012 they are defined as object references. 2012-12-05 Thomas Quinot <quinot@adacore.com> * par-ch3.adb: Minor reformatting. From-SVN: r194207
This commit is contained in:
Arnaud Charlet
parent
baad98300a
commit
18a2ad5d46
|
|
@ -1,3 +1,41 @@
|
|||
2012-12-05 Yannick Moy <moy@adacore.com>
|
||||
|
||||
* urealp.ads: Minor rewording.
|
||||
|
||||
2012-12-05 Yannick Moy <moy@adacore.com>
|
||||
|
||||
* aspects.ads (No_Duplicates_Allowed): Forbid use of duplicate
|
||||
Contract_Cases aspects.
|
||||
* sem_prag.adb (Analyze_Pragma/Pragma_Contract_Case): Rename
|
||||
POST_CASE into CONTRACT_CASE in both grammar and code, to be
|
||||
consistent with current language definition. Issue a more precise
|
||||
error message when the pragma duplicates another pragma or aspect.
|
||||
|
||||
2012-12-05 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* exp_attr.adb (Expand_N_Attribute_Reference): Add processing
|
||||
for attribute Update.
|
||||
(Expand_Update_Attribute): New routine.
|
||||
* par-ch4.adb (P_Name): The sole expression of attribute Update
|
||||
is an aggregate, parse it accordingly.
|
||||
* sem_attr.adb (Analyze_Attribute): Verify the legality of
|
||||
attribute Update.
|
||||
(Eval_Attribute): Attribute Update does not
|
||||
need evaluation because it is never static.
|
||||
* snames.ads-tmpl: Add Name_Update to the list of special names
|
||||
recognized by the compiler. Add an Attribute_Id for Update.
|
||||
|
||||
2012-12-05 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* exp_util.adb (Remove_Side_Effects): For purposes of removing
|
||||
side effects, qualified expressions do not receive a special
|
||||
treatment, even though in Ada 2012 they are defined as object
|
||||
references.
|
||||
|
||||
2012-12-05 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* par-ch3.adb: Minor reformatting.
|
||||
|
||||
2012-12-05 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* exp_dist.adb (Build_From_Any_Call, Build_To_Any_Call,
|
||||
|
|
|
|||
|
|
@ -257,7 +257,6 @@ package Aspects is
|
|||
|
||||
No_Duplicates_Allowed : constant array (Aspect_Id) of Boolean :=
|
||||
(Aspect_Contract_Case => False,
|
||||
Aspect_Contract_Cases => False,
|
||||
Aspect_Test_Case => False,
|
||||
others => True);
|
||||
|
||||
|
|
|
|||
|
|
@ -140,6 +140,9 @@ package body Exp_Attr is
|
|||
-- Handles expansion of Pred or Succ attributes for case of non-real
|
||||
-- operand with overflow checking required.
|
||||
|
||||
procedure Expand_Update_Attribute (N : Node_Id);
|
||||
-- Handle the expansion of attribute Update
|
||||
|
||||
function Get_Index_Subtype (N : Node_Id) return Entity_Id;
|
||||
-- Used for Last, Last, and Length, when the prefix is an array type.
|
||||
-- Obtains the corresponding index subtype.
|
||||
|
|
@ -5237,6 +5240,13 @@ package body Exp_Attr is
|
|||
Analyze_And_Resolve (N, Typ);
|
||||
end UET_Address;
|
||||
|
||||
------------
|
||||
-- Update --
|
||||
------------
|
||||
|
||||
when Attribute_Update =>
|
||||
Expand_Update_Attribute (N);
|
||||
|
||||
---------------
|
||||
-- VADS_Size --
|
||||
---------------
|
||||
|
|
@ -6160,6 +6170,197 @@ package body Exp_Attr is
|
|||
end if;
|
||||
end Expand_Pred_Succ;
|
||||
|
||||
-----------------------------
|
||||
-- Expand_Update_Attribute --
|
||||
-----------------------------
|
||||
|
||||
procedure Expand_Update_Attribute (N : Node_Id) is
|
||||
procedure Process_Component_Or_Element_Update
|
||||
(Temp : Entity_Id;
|
||||
Comp : Node_Id;
|
||||
Expr : Node_Id;
|
||||
Typ : Entity_Id);
|
||||
-- Generate the statements necessary to update a single component or an
|
||||
-- element of the prefix. The code is inserted before the attribute N.
|
||||
-- Temp denotes the entity of the anonymous object created to reflect
|
||||
-- the changes in values. Comp is the component/index expression to be
|
||||
-- updated. Expr is an expression yielding the new value of Comp. Typ
|
||||
-- is the type of the prefix of attribute Update.
|
||||
|
||||
procedure Process_Range_Update
|
||||
(Temp : Entity_Id;
|
||||
Comp : Node_Id;
|
||||
Expr : Node_Id);
|
||||
-- Generate the statements necessary to update a slice of the prefix.
|
||||
-- The code is inserted before the attribute N. Temp denotes the entity
|
||||
-- of the anonymous object created to reflect the changes in values.
|
||||
-- Comp is range of the slice to be updated. Expr is an expression
|
||||
-- yielding the new value of Comp.
|
||||
|
||||
-----------------------------------------
|
||||
-- Process_Component_Or_Element_Update --
|
||||
-----------------------------------------
|
||||
|
||||
procedure Process_Component_Or_Element_Update
|
||||
(Temp : Entity_Id;
|
||||
Comp : Node_Id;
|
||||
Expr : Node_Id;
|
||||
Typ : Entity_Id)
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (Comp);
|
||||
Exprs : List_Id;
|
||||
LHS : Node_Id;
|
||||
|
||||
begin
|
||||
-- An array element may be modified by the following relations
|
||||
-- depending on the number of dimensions:
|
||||
|
||||
-- 1 => Expr -- one dimensional update
|
||||
-- (1, ..., N) => Expr -- multi dimensional update
|
||||
|
||||
-- The above forms are converted in assignment statements where the
|
||||
-- left hand side is an indexed component:
|
||||
|
||||
-- Temp (1) := Expr; -- one dimensional update
|
||||
-- Temp (1, ..., N) := Expr; -- multi dimensional update
|
||||
|
||||
if Is_Array_Type (Typ) then
|
||||
|
||||
-- The index expressions of a multi dimensional array update
|
||||
-- appear as an aggregate.
|
||||
|
||||
if Nkind (Comp) = N_Aggregate then
|
||||
Exprs := New_Copy_List_Tree (Expressions (Comp));
|
||||
else
|
||||
Exprs := New_List (Relocate_Node (Comp));
|
||||
end if;
|
||||
|
||||
LHS :=
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix => New_Reference_To (Temp, Loc),
|
||||
Expressions => Exprs);
|
||||
|
||||
-- A record component update appears in the following form:
|
||||
|
||||
-- Comp => Expr
|
||||
|
||||
-- The above relation is transformed into an assignment statement
|
||||
-- where the left hand side is a selected component:
|
||||
|
||||
-- Temp.Comp := Expr;
|
||||
|
||||
else pragma Assert (Is_Record_Type (Typ));
|
||||
LHS :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => New_Reference_To (Temp, Loc),
|
||||
Selector_Name => Relocate_Node (Comp));
|
||||
end if;
|
||||
|
||||
Insert_Action (N,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => LHS,
|
||||
Expression => Relocate_Node (Expr)));
|
||||
end Process_Component_Or_Element_Update;
|
||||
|
||||
--------------------------
|
||||
-- Process_Range_Update --
|
||||
--------------------------
|
||||
|
||||
procedure Process_Range_Update
|
||||
(Temp : Entity_Id;
|
||||
Comp : Node_Id;
|
||||
Expr : Node_Id)
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (Comp);
|
||||
Index : Entity_Id;
|
||||
|
||||
begin
|
||||
-- A range update appears as
|
||||
|
||||
-- (Low .. High => Expr)
|
||||
|
||||
-- The above construct is transformed into a loop that iterates over
|
||||
-- the given range and modifies the corresponding array values to the
|
||||
-- value of Expr:
|
||||
|
||||
-- for Index in Low .. High loop
|
||||
-- Temp (Index) := Expr;
|
||||
-- end loop;
|
||||
|
||||
Index := Make_Temporary (Loc, 'I');
|
||||
|
||||
Insert_Action (N,
|
||||
Make_Loop_Statement (Loc,
|
||||
Iteration_Scheme =>
|
||||
Make_Iteration_Scheme (Loc,
|
||||
Loop_Parameter_Specification =>
|
||||
Make_Loop_Parameter_Specification (Loc,
|
||||
Defining_Identifier => Index,
|
||||
Discrete_Subtype_Definition => Relocate_Node (Comp))),
|
||||
|
||||
Statements => New_List (
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix => New_Reference_To (Temp, Loc),
|
||||
Expressions => New_List (New_Reference_To (Index, Loc))),
|
||||
Expression => Relocate_Node (Expr))),
|
||||
|
||||
End_Label => Empty));
|
||||
end Process_Range_Update;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Aggr : constant Node_Id := First (Expressions (N));
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Pref : constant Node_Id := Prefix (N);
|
||||
Typ : constant Entity_Id := Etype (Pref);
|
||||
Assoc : Node_Id;
|
||||
Comp : Node_Id;
|
||||
Expr : Node_Id;
|
||||
Temp : Entity_Id;
|
||||
|
||||
-- Start of processing for Expand_Update_Attribute
|
||||
|
||||
begin
|
||||
-- Create the anonymous object that stores the value of the prefix and
|
||||
-- reflects subsequent changes in value. Generate:
|
||||
|
||||
-- Temp : <type of Pref> := Pref;
|
||||
|
||||
Temp := Make_Temporary (Loc, 'T');
|
||||
|
||||
Insert_Action (N,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Temp,
|
||||
Object_Definition => New_Reference_To (Typ, Loc),
|
||||
Expression => Relocate_Node (Pref)));
|
||||
|
||||
-- Process the update aggregate
|
||||
|
||||
Assoc := First (Component_Associations (Aggr));
|
||||
while Present (Assoc) loop
|
||||
Comp := First (Choices (Assoc));
|
||||
Expr := Expression (Assoc);
|
||||
while Present (Comp) loop
|
||||
if Nkind (Comp) = N_Range then
|
||||
Process_Range_Update (Temp, Comp, Expr);
|
||||
else
|
||||
Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
|
||||
end if;
|
||||
|
||||
Next (Comp);
|
||||
end loop;
|
||||
|
||||
Next (Assoc);
|
||||
end loop;
|
||||
|
||||
-- The attribute is replaced by a reference to the anonymous object
|
||||
|
||||
Rewrite (N, New_Reference_To (Temp, Loc));
|
||||
Analyze (N);
|
||||
end Expand_Update_Attribute;
|
||||
|
||||
-------------------
|
||||
-- Find_Fat_Info --
|
||||
-------------------
|
||||
|
|
|
|||
|
|
@ -1107,14 +1107,14 @@ package body Exp_Util is
|
|||
Temps (J) := T;
|
||||
|
||||
Append_To (Decls,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => T,
|
||||
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
||||
Expression =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Image,
|
||||
Prefix => New_Occurrence_Of (Etype (Indx), Loc),
|
||||
Expressions => New_List (New_Copy_Tree (Val)))));
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => T,
|
||||
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
||||
Expression =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Image,
|
||||
Prefix => New_Occurrence_Of (Etype (Indx), Loc),
|
||||
Expressions => New_List (New_Copy_Tree (Val)))));
|
||||
|
||||
Next_Index (Indx);
|
||||
Next (Val);
|
||||
|
|
@ -1126,22 +1126,21 @@ package body Exp_Util is
|
|||
Make_Op_Add (Loc,
|
||||
Left_Opnd => Sum,
|
||||
Right_Opnd =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Length,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Pref, Loc),
|
||||
Expressions => New_List (Make_Integer_Literal (Loc, 1))));
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Length,
|
||||
Prefix => New_Occurrence_Of (Pref, Loc),
|
||||
Expressions => New_List (Make_Integer_Literal (Loc, 1))));
|
||||
|
||||
for J in 1 .. Dims loop
|
||||
Sum :=
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd => Sum,
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd => Sum,
|
||||
Right_Opnd =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Length,
|
||||
Prefix =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Length,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Temps (J), Loc),
|
||||
Expressions => New_List (Make_Integer_Literal (Loc, 1))));
|
||||
Expressions => New_List (Make_Integer_Literal (Loc, 1))));
|
||||
end loop;
|
||||
|
||||
Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
|
||||
|
|
@ -1149,44 +1148,46 @@ package body Exp_Util is
|
|||
Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
|
||||
|
||||
Append_To (Stats,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => Make_Indexed_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Res, Loc),
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Res, Loc),
|
||||
Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
|
||||
Expression =>
|
||||
Make_Character_Literal (Loc,
|
||||
Chars => Name_Find,
|
||||
Char_Literal_Value =>
|
||||
UI_From_Int (Character'Pos ('(')))));
|
||||
Expression =>
|
||||
Make_Character_Literal (Loc,
|
||||
Chars => Name_Find,
|
||||
Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
|
||||
|
||||
Append_To (Stats,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Pos, Loc),
|
||||
Expression =>
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
||||
Right_Opnd => Make_Integer_Literal (Loc, 1))));
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Pos, Loc),
|
||||
Expression =>
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
||||
Right_Opnd => Make_Integer_Literal (Loc, 1))));
|
||||
|
||||
for J in 1 .. Dims loop
|
||||
|
||||
Append_To (Stats,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => Make_Slice (Loc,
|
||||
Prefix => New_Occurrence_Of (Res, Loc),
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Slice (Loc,
|
||||
Prefix => New_Occurrence_Of (Res, Loc),
|
||||
Discrete_Range =>
|
||||
Make_Range (Loc,
|
||||
Low_Bound => New_Occurrence_Of (Pos, Loc),
|
||||
High_Bound => Make_Op_Subtract (Loc,
|
||||
Left_Opnd =>
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
||||
Right_Opnd =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Length,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Temps (J), Loc),
|
||||
Expressions =>
|
||||
New_List (Make_Integer_Literal (Loc, 1)))),
|
||||
Low_Bound => New_Occurrence_Of (Pos, Loc),
|
||||
High_Bound =>
|
||||
Make_Op_Subtract (Loc,
|
||||
Left_Opnd =>
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
||||
Right_Opnd =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Length,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Temps (J), Loc),
|
||||
Expressions =>
|
||||
New_List (Make_Integer_Literal (Loc, 1)))),
|
||||
Right_Opnd => Make_Integer_Literal (Loc, 1)))),
|
||||
|
||||
Expression => New_Occurrence_Of (Temps (J), Loc)));
|
||||
|
|
@ -1194,36 +1195,35 @@ package body Exp_Util is
|
|||
if J < Dims then
|
||||
Append_To (Stats,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Pos, Loc),
|
||||
Name => New_Occurrence_Of (Pos, Loc),
|
||||
Expression =>
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
||||
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
||||
Right_Opnd =>
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Length,
|
||||
Prefix => New_Occurrence_Of (Temps (J), Loc),
|
||||
Expressions =>
|
||||
New_List (Make_Integer_Literal (Loc, 1))))));
|
||||
Prefix => New_Occurrence_Of (Temps (J), Loc),
|
||||
Expressions =>
|
||||
New_List (Make_Integer_Literal (Loc, 1))))));
|
||||
|
||||
Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
|
||||
|
||||
Append_To (Stats,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => Make_Indexed_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Res, Loc),
|
||||
Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
|
||||
Expression =>
|
||||
Make_Character_Literal (Loc,
|
||||
Chars => Name_Find,
|
||||
Char_Literal_Value =>
|
||||
UI_From_Int (Character'Pos (',')))));
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => Make_Indexed_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Res, Loc),
|
||||
Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
|
||||
Expression =>
|
||||
Make_Character_Literal (Loc,
|
||||
Chars => Name_Find,
|
||||
Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
|
||||
|
||||
Append_To (Stats,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Pos, Loc),
|
||||
Name => New_Occurrence_Of (Pos, Loc),
|
||||
Expression =>
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
||||
Left_Opnd => New_Occurrence_Of (Pos, Loc),
|
||||
Right_Opnd => Make_Integer_Literal (Loc, 1))));
|
||||
end if;
|
||||
end loop;
|
||||
|
|
@ -1231,15 +1231,15 @@ package body Exp_Util is
|
|||
Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
|
||||
|
||||
Append_To (Stats,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => Make_Indexed_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Res, Loc),
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Res, Loc),
|
||||
Expressions => New_List (New_Occurrence_Of (Len, Loc))),
|
||||
Expression =>
|
||||
Make_Character_Literal (Loc,
|
||||
Chars => Name_Find,
|
||||
Char_Literal_Value =>
|
||||
UI_From_Int (Character'Pos (')')))));
|
||||
Chars => Name_Find,
|
||||
Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
|
||||
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
|
||||
end Build_Task_Array_Image;
|
||||
|
||||
|
|
@ -6842,15 +6842,20 @@ package body Exp_Util is
|
|||
end if;
|
||||
|
||||
-- For expressions that denote objects, we can use a renaming scheme.
|
||||
-- This is needed for correctness in the case of a volatile object of a
|
||||
-- non-volatile type because the Make_Reference call of the "default"
|
||||
-- This is needed for correctness in the case of a volatile object of
|
||||
-- a non-volatile type because the Make_Reference call of the "default"
|
||||
-- approach would generate an illegal access value (an access value
|
||||
-- cannot designate such an object - see Analyze_Reference). We skip
|
||||
-- using this scheme if we have an object of a volatile type and we do
|
||||
-- not have Name_Req set true (see comments above for Side_Effect_Free).
|
||||
|
||||
-- In Ada 2012 a qualified expression is an object, but for purposes of
|
||||
-- removing side effects it still need to be transformed into a separate
|
||||
-- declaration, particularly if the expression is an aggregate.
|
||||
|
||||
elsif Is_Object_Reference (Exp)
|
||||
and then Nkind (Exp) /= N_Function_Call
|
||||
and then Nkind (Exp) /= N_Qualified_Expression
|
||||
and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
|
||||
then
|
||||
Def_Id := Make_Temporary (Loc, 'R', Exp);
|
||||
|
|
|
|||
|
|
@ -935,7 +935,7 @@ package body Ch3 is
|
|||
|
||||
-- SUBTYPE_DECLARATION ::=
|
||||
-- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION
|
||||
-- {ASPECT_SPECIFICATIONS];
|
||||
-- [ASPECT_SPECIFICATIONS];
|
||||
|
||||
-- The caller has checked that the initial token is SUBTYPE
|
||||
|
||||
|
|
|
|||
|
|
@ -510,26 +510,36 @@ package body Ch4 is
|
|||
Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
|
||||
then
|
||||
Set_Expressions (Name_Node, New_List);
|
||||
Scan; -- past left paren
|
||||
|
||||
loop
|
||||
declare
|
||||
Expr : constant Node_Id := P_Expression_If_OK;
|
||||
-- Attribute Update contains an array or record association
|
||||
-- list which provides new values for various components or
|
||||
-- elements. The list is parsed as an aggregate.
|
||||
|
||||
begin
|
||||
if Token = Tok_Arrow then
|
||||
Error_Msg_SC
|
||||
("named parameters not permitted for attributes");
|
||||
Scan; -- past junk arrow
|
||||
if Attr_Name = Name_Update then
|
||||
Append (P_Aggregate, Expressions (Name_Node));
|
||||
|
||||
else
|
||||
Append (Expr, Expressions (Name_Node));
|
||||
exit when not Comma_Present;
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
else
|
||||
Scan; -- past left paren
|
||||
|
||||
T_Right_Paren;
|
||||
loop
|
||||
declare
|
||||
Expr : constant Node_Id := P_Expression_If_OK;
|
||||
|
||||
begin
|
||||
if Token = Tok_Arrow then
|
||||
Error_Msg_SC
|
||||
("named parameters not permitted for attributes");
|
||||
Scan; -- past junk arrow
|
||||
|
||||
else
|
||||
Append (Expr, Expressions (Name_Node));
|
||||
exit when not Comma_Present;
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
T_Right_Paren;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
goto Scan_Name_Extension;
|
||||
|
|
|
|||
|
|
@ -5516,6 +5516,164 @@ package body Sem_Attr is
|
|||
|
||||
Analyze_Access_Attribute;
|
||||
|
||||
------------
|
||||
-- Update --
|
||||
------------
|
||||
|
||||
when Attribute_Update => Update : declare
|
||||
Comps : Elist_Id := No_Elist;
|
||||
|
||||
procedure Check_Component_Reference
|
||||
(Comp : Entity_Id;
|
||||
Typ : Entity_Id);
|
||||
-- Comp is a record component (possibly a discriminant) and Typ is a
|
||||
-- record type. Determine whether Comp is a legal component of Typ.
|
||||
-- Emit an error if Comp mentions a discriminant or is not a unique
|
||||
-- component reference in the update aggregate.
|
||||
|
||||
-------------------------------
|
||||
-- Check_Component_Reference --
|
||||
-------------------------------
|
||||
|
||||
procedure Check_Component_Reference
|
||||
(Comp : Entity_Id;
|
||||
Typ : Entity_Id)
|
||||
is
|
||||
Comp_Name : constant Name_Id := Chars (Comp);
|
||||
|
||||
function Is_Duplicate_Component return Boolean;
|
||||
-- Determine whether component Comp already appears in list Comps
|
||||
|
||||
----------------------------
|
||||
-- Is_Duplicate_Component --
|
||||
----------------------------
|
||||
|
||||
function Is_Duplicate_Component return Boolean is
|
||||
Comp_Elmt : Elmt_Id;
|
||||
|
||||
begin
|
||||
if Present (Comps) then
|
||||
Comp_Elmt := First_Elmt (Comps);
|
||||
while Present (Comp_Elmt) loop
|
||||
if Chars (Node (Comp_Elmt)) = Comp_Name then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
Next_Elmt (Comp_Elmt);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
return False;
|
||||
end Is_Duplicate_Component;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Comp_Or_Discr : Entity_Id;
|
||||
|
||||
-- Start of processing for Check_Component_Reference
|
||||
|
||||
begin
|
||||
-- Find the discriminant or component whose name corresponds to
|
||||
-- Comp. A simple character comparison is sufficient because all
|
||||
-- visible names within a record type are unique.
|
||||
|
||||
Comp_Or_Discr := First_Entity (Typ);
|
||||
while Present (Comp_Or_Discr) loop
|
||||
if Chars (Comp_Or_Discr) = Comp_Name then
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Comp_Or_Discr := Next_Entity (Comp_Or_Discr);
|
||||
end loop;
|
||||
|
||||
-- Diagnose possible erroneous references
|
||||
|
||||
if Present (Comp_Or_Discr) then
|
||||
if Ekind (Comp_Or_Discr) = E_Discriminant then
|
||||
Error_Attr
|
||||
("attribute % may not modify record discriminants", Comp);
|
||||
|
||||
else pragma Assert (Ekind (Comp_Or_Discr) = E_Component);
|
||||
if Is_Duplicate_Component then
|
||||
Error_Msg_NE ("component & already updated", Comp, Comp);
|
||||
|
||||
-- Mark this component as processed
|
||||
|
||||
else
|
||||
if No (Comps) then
|
||||
Comps := New_Elmt_List;
|
||||
end if;
|
||||
|
||||
Append_Elmt (Comp, Comps);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- The update aggregate mentions an entity that does not belong to
|
||||
-- the record type.
|
||||
|
||||
else
|
||||
Error_Msg_NE
|
||||
("& is not a component of aggregate subtype", Comp, Comp);
|
||||
end if;
|
||||
end Check_Component_Reference;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Assoc : Node_Id;
|
||||
Comp : Node_Id;
|
||||
|
||||
-- Start of processing for Update
|
||||
|
||||
begin
|
||||
S14_Attribute;
|
||||
Check_E1;
|
||||
|
||||
if not Is_Object_Reference (P) then
|
||||
Error_Attr_P ("prefix of attribute % must denote an object");
|
||||
|
||||
elsif not Is_Array_Type (P_Type)
|
||||
and then not Is_Record_Type (P_Type)
|
||||
then
|
||||
Error_Attr_P ("prefix of attribute % must be a record or array");
|
||||
|
||||
elsif Is_Immutably_Limited_Type (P_Type) then
|
||||
Error_Attr ("prefix of attribute % cannot be limited", N);
|
||||
|
||||
elsif Nkind (E1) /= N_Aggregate then
|
||||
Error_Attr ("attribute % requires component association list", N);
|
||||
end if;
|
||||
|
||||
-- Inspect the update aggregate, looking at all the associations and
|
||||
-- choices. Perform the following checks:
|
||||
|
||||
-- 1) Legality of "others" in all cases
|
||||
-- 2) Component legality for records
|
||||
|
||||
-- The remaining checks are performed on the expanded attribute
|
||||
|
||||
Assoc := First (Component_Associations (E1));
|
||||
while Present (Assoc) loop
|
||||
Comp := First (Choices (Assoc));
|
||||
while Present (Comp) loop
|
||||
if Nkind (Comp) = N_Others_Choice then
|
||||
Error_Attr
|
||||
("others choice not allowed in attribute %", Comp);
|
||||
|
||||
elsif Is_Record_Type (P_Type) then
|
||||
Check_Component_Reference (Comp, P_Type);
|
||||
end if;
|
||||
|
||||
Next (Comp);
|
||||
end loop;
|
||||
|
||||
Next (Assoc);
|
||||
end loop;
|
||||
|
||||
-- The type of attribute Update is that of the prefix
|
||||
|
||||
Set_Etype (N, P_Type);
|
||||
end Update;
|
||||
|
||||
---------
|
||||
-- Val --
|
||||
---------
|
||||
|
|
@ -8210,6 +8368,15 @@ package body Sem_Attr is
|
|||
Static := True;
|
||||
end Unconstrained_Array;
|
||||
|
||||
-- Attribute Update is never static
|
||||
|
||||
------------
|
||||
-- Update --
|
||||
------------
|
||||
|
||||
when Attribute_Update =>
|
||||
null;
|
||||
|
||||
---------------
|
||||
-- VADS_Size --
|
||||
---------------
|
||||
|
|
|
|||
|
|
@ -7761,11 +7761,11 @@ package body Sem_Prag is
|
|||
-- Contract_Cases --
|
||||
--------------------
|
||||
|
||||
-- pragma Contract_Cases (POST_CASE_LIST);
|
||||
-- pragma Contract_Cases (CONTRACT_CASE_LIST);
|
||||
|
||||
-- POST_CASE_LIST ::= POST_CASE {, POST_CASE}
|
||||
-- CONTRACT_CASE_LIST ::= CONTRACT_CASE {, CONTRACT_CASE}
|
||||
|
||||
-- POST_CASE ::= CASE_GUARD => CONSEQUENCE
|
||||
-- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
|
||||
|
||||
-- CASE_GUARD ::= boolean_EXPRESSION | others
|
||||
|
||||
|
|
@ -7786,11 +7786,22 @@ package body Sem_Prag is
|
|||
CTC : Node_Id;
|
||||
|
||||
begin
|
||||
Check_Duplicate_Pragma (Subp);
|
||||
CTC := Spec_CTC_List (Contract (Subp));
|
||||
while Present (CTC) loop
|
||||
if Chars (Pragma_Identifier (CTC)) = Pname then
|
||||
Error_Pragma ("pragma % already in use");
|
||||
return;
|
||||
Error_Msg_Name_1 := Pname;
|
||||
Error_Msg_Sloc := Sloc (CTC);
|
||||
|
||||
if From_Aspect_Specification (CTC) then
|
||||
Error_Msg_NE
|
||||
("aspect% for & previously given#", N, Subp);
|
||||
else
|
||||
Error_Msg_NE
|
||||
("pragma% for & duplicates pragma#", N, Subp);
|
||||
end if;
|
||||
|
||||
raise Pragma_Exit;
|
||||
end if;
|
||||
|
||||
CTC := Next_Pragma (CTC);
|
||||
|
|
@ -7804,12 +7815,12 @@ package body Sem_Prag is
|
|||
|
||||
-- Local variables
|
||||
|
||||
Case_Guard : Node_Id;
|
||||
Decl : Node_Id;
|
||||
Extra : Node_Id;
|
||||
Others_Seen : Boolean := False;
|
||||
Post_Case : Node_Id;
|
||||
Subp_Decl : Node_Id;
|
||||
Case_Guard : Node_Id;
|
||||
Decl : Node_Id;
|
||||
Extra : Node_Id;
|
||||
Others_Seen : Boolean := False;
|
||||
Contract_Case : Node_Id;
|
||||
Subp_Decl : Node_Id;
|
||||
|
||||
-- Start of processing for Contract_Cases
|
||||
|
||||
|
|
@ -7866,30 +7877,32 @@ package body Sem_Prag is
|
|||
end if;
|
||||
end loop;
|
||||
|
||||
-- All post cases must appear as an aggregate
|
||||
-- All contract cases must appear as an aggregate
|
||||
|
||||
if Nkind (Expression (Arg1)) /= N_Aggregate then
|
||||
Error_Pragma ("wrong syntax for pragma %");
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Verify the legality of individual post cases
|
||||
-- Verify the legality of individual contract cases
|
||||
|
||||
Post_Case := First (Component_Associations (Expression (Arg1)));
|
||||
while Present (Post_Case) loop
|
||||
if Nkind (Post_Case) /= N_Component_Association then
|
||||
Error_Pragma_Arg ("wrong syntax in post case", Post_Case);
|
||||
Contract_Case :=
|
||||
First (Component_Associations (Expression (Arg1)));
|
||||
while Present (Contract_Case) loop
|
||||
if Nkind (Contract_Case) /= N_Component_Association then
|
||||
Error_Pragma_Arg
|
||||
("wrong syntax in contract case", Contract_Case);
|
||||
return;
|
||||
end if;
|
||||
|
||||
Case_Guard := First (Choices (Post_Case));
|
||||
Case_Guard := First (Choices (Contract_Case));
|
||||
|
||||
-- Each post case must have exactly on case guard
|
||||
-- Each contract case must have exactly on case guard
|
||||
|
||||
Extra := Next (Case_Guard);
|
||||
if Present (Extra) then
|
||||
Error_Pragma_Arg
|
||||
("post case may have only one case guard", Extra);
|
||||
("contract case may have only one case guard", Extra);
|
||||
return;
|
||||
end if;
|
||||
|
||||
|
|
@ -7911,7 +7924,7 @@ package body Sem_Prag is
|
|||
return;
|
||||
end if;
|
||||
|
||||
Next (Post_Case);
|
||||
Next (Contract_Case);
|
||||
end loop;
|
||||
|
||||
Chain_Contract_Cases (Subp_Decl);
|
||||
|
|
@ -11517,10 +11530,12 @@ package body Sem_Prag is
|
|||
|
||||
Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean);
|
||||
|
||||
-- Transform pagma Loop_Invariant into an equivalent pragma Check.
|
||||
-- Transform pragma Loop_Invariant into equivalent pragma Check
|
||||
-- Generate:
|
||||
-- pragma Check (Loop_Invaraint, Arg1);
|
||||
|
||||
-- Seems completely wrong to hijack pragma Check this way ???
|
||||
|
||||
Rewrite (N,
|
||||
Make_Pragma (Loc,
|
||||
Chars => Name_Check,
|
||||
|
|
|
|||
|
|
@ -901,6 +901,7 @@ package Snames is
|
|||
Name_Unconstrained_Array : constant Name_Id := N + $;
|
||||
Name_Universal_Literal_String : constant Name_Id := N + $; -- GNAT
|
||||
Name_Unrestricted_Access : constant Name_Id := N + $; -- GNAT
|
||||
Name_Update : constant Name_Id := N + $; -- GNAT
|
||||
Name_VADS_Size : constant Name_Id := N + $; -- GNAT
|
||||
Name_Val : constant Name_Id := N + $;
|
||||
Name_Valid : constant Name_Id := N + $;
|
||||
|
|
@ -1512,6 +1513,7 @@ package Snames is
|
|||
Attribute_Unconstrained_Array,
|
||||
Attribute_Universal_Literal_String,
|
||||
Attribute_Unrestricted_Access,
|
||||
Attribute_Update,
|
||||
Attribute_VADS_Size,
|
||||
Attribute_Val,
|
||||
Attribute_Valid,
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2012, 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- --
|
||||
|
|
@ -53,12 +53,13 @@ package Urealp is
|
|||
-- a real base (Nat, either zero, or in the range 2 .. 16)
|
||||
-- a sign flag (Boolean), set if negative
|
||||
|
||||
-- If the base is zero, then the absolute value of the Ureal is simply
|
||||
-- numerator/denominator. If the base is non-zero, then the absolute
|
||||
-- value is num / (rbase ** den).
|
||||
-- Negative numbers are represented by the sign flag being True.
|
||||
|
||||
-- Negative numbers are represented by the sign of the numerator being
|
||||
-- negative. The denominator is always positive.
|
||||
-- If the base is zero, then the absolute value of the Ureal is simply
|
||||
-- numerator/denominator, where denominator is positive. If the base is
|
||||
-- non-zero, then the absolute value is numerator / (base ** denominator).
|
||||
-- In that case, since base is positive, (base ** denominator) is also
|
||||
-- positive, even when denominator is negative or null.
|
||||
|
||||
-- A normalized Ureal value has base = 0, and numerator/denominator
|
||||
-- reduced to lowest terms, with zero itself being represented as 0/1.
|
||||
|
|
|
|||
Loading…
Reference in New Issue