+2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb (Insert_Valid_Check): Partially reimplement validity
+ checks.
+ * einfo.adb Node36 is now used as Validated_Object.
+ (Validated_Object): New routine.
+ (Set_Validated_Object): New routine.
+ (Write_Field36_Name): Add an entry for Validated_Object.
+ * einfo.ads Add new attribute Validated_Object along with
+ usage in entities.
+ (Validated_Object): New routine along with pragma Inline.
+ (Set_Validated_Object): New routine along with pragma Inline.
+ * exp_attr.adb (Make_Range_Test): Add processing for validation
+ variables to avoid extra reads and copies of the prefix.
+ * exp_ch6.adb (Expand_Actuals): Add copy-back for validation
+ variables in order to reflect any changes done in the variable
+ back into the original object.
+ * sem_util.adb (Is_Validation_Variable_Reference): New routine.
+ * sem_util.ads (Is_Validation_Variable_Reference): New routine.
+
+2017-04-25 Steve Baird <baird@adacore.com>
+
+ * exp_ch7.adb (Build_Array_Deep_Procs,
+ Build_Record_Deep_Procs, Make_Finalize_Address_Body): Don't
+ generate Finalize_Address routines for CodePeer.
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Inherits_Class_Wide_Pre): subsidiary of
+ Analyze_Pre_Post_Condition, to implement the legality checks
+ mandated by AI12-0131: Pre'Class shall not be specified for an
+ overriding primitive subprogram of a tagged type T unless the
+ Pre'Class aspect is specified for the corresponding primitive
+ subprogram of some ancestor of T.
+
2017-04-25 Bob Duff <duff@adacore.com>
* sem_ch8.adb (Use_One_Type): If a use_type_clause
Exp := Expression (Exp);
end loop;
+ -- Do not generate a check for a variable which already validates the
+ -- value of an assignable object.
+
+ if Is_Validation_Variable_Reference (Exp) then
+ return;
+ end if;
+
-- We are about to insert the validity check for Exp. We save and
-- reset the Do_Range_Check flag over this validity check, and then
-- put it back for the final original reference (Exp may be rewritten).
declare
DRC : constant Boolean := Do_Range_Check (Exp);
- PV : Node_Id;
CE : Node_Id;
+ Obj : Node_Id;
+ PV : Node_Id;
+ Var : Entity_Id;
begin
Set_Do_Range_Check (Exp, False);
- -- Force evaluation to avoid multiple reads for atomic/volatile
+ -- If the expression denotes an assignable object, capture its value
+ -- in a variable and replace the original expression by the variable.
+ -- This approach has several effects:
- -- Note: we set Name_Req to False. We used to set it to True, with
- -- the thinking that a name is required as the prefix of the 'Valid
- -- call, but in fact the check that the prefix of an attribute is
- -- a name is in the parser, and we just don't require it here.
- -- Moreover, when we set Name_Req to True, that interfered with the
- -- checking for Volatile, since we couldn't just capture the value.
+ -- 1) The evaluation of the object results in only one read in the
+ -- case where the object is atomic or volatile.
- if Is_Entity_Name (Exp)
- and then Is_Volatile (Entity (Exp))
- then
- -- Same reasoning as above for setting Name_Req to False
+ -- Temp ... := Object; -- read
- Force_Evaluation (Exp, Name_Req => False);
- end if;
+ -- 2) The captured value is the one verified by attribute 'Valid.
+ -- As a result the object is not evaluated again, which would
+ -- result in an unwanted read in the case where the object is
+ -- atomic or volatile.
+
+ -- if not Temp'Valid then -- OK, no read of Object
+
+ -- if not Object'Valid then -- Wrong, extra read of Object
+
+ -- 3) The captured value replaces the original object reference.
+ -- As a result the object is not evaluated again, in the same
+ -- vein as 2).
+
+ -- ... Temp ... -- OK, no read of Object
+
+ -- ... Object ... -- Wrong, extra read of Object
- -- Build the prefix for the 'Valid call. If the expression denotes
- -- a non-volatile name, use a renaming to alias it, otherwise use a
- -- constant to capture the value of the expression.
-
- -- Temp : ... renames Expr; -- non-volatile name
- -- Temp : constant ... := Expr; -- all other cases
-
- PV :=
- Duplicate_Subexpr_No_Checks
- (Exp => Exp,
- Name_Req => False,
- Renaming_Req =>
- Is_Name_Reference (Exp) and then not Is_Volatile (Typ),
- Related_Id => Related_Id,
- Is_Low_Bound => Is_Low_Bound,
- Is_High_Bound => Is_High_Bound);
+ -- 4) The use of a variable to capture the value of the object
+ -- allows the propagation of any changes back to the original
+ -- object.
+
+ -- procedure Call (Val : in out ...);
+
+ -- Temp : ... := Object; -- read Object
+ -- if not Temp'Valid then -- validity check
+ -- Call (Temp); -- modify Temp
+ -- Object := Temp; -- update Object
+
+ if Is_Variable (Exp) then
+ Obj := New_Copy_Tree (Exp);
+ Var := Make_Temporary (Loc, 'T', Exp);
+
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Var,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (Exp)));
+ Set_Validated_Object (Var, Obj);
+
+ Rewrite (Exp, New_Occurrence_Of (Var, Loc));
+ PV := New_Occurrence_Of (Var, Loc);
+
+ -- Otherwise the expression does not denote a variable. Force its
+ -- evaluation by capturing its value in a constant. Generate:
+
+ -- Temp : constant ... := Exp;
+
+ else
+ Force_Evaluation
+ (Exp => Exp,
+ Related_Id => Related_Id,
+ Is_Low_Bound => Is_Low_Bound,
+ Is_High_Bound => Is_High_Bound);
+
+ PV := New_Copy_Tree (Exp);
+ end if;
-- A rather specialized test. If PV is an analyzed expression which
-- is an indexed component of a packed array that has not been
-- Entry_Max_Queue_Lengths_Array Node35
-- Import_Pragma Node35
+ -- Validated_Object Node36
+
-- Class_Wide_Preconds List38
-- Class_Wide_Postconds List39
return Flag95 (Id);
end Uses_Sec_Stack;
+ function Validated_Object (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Variable);
+ return Node36 (Id);
+ end Validated_Object;
+
function Warnings_Off (Id : E) return B is
begin
return Flag96 (Id);
Set_Flag95 (Id, V);
end Set_Uses_Sec_Stack;
+ procedure Set_Validated_Object (Id : E; V : N) is
+ begin
+ pragma Assert (Ekind (Id) = E_Variable);
+ Set_Node36 (Id, V);
+ end Set_Validated_Object;
+
procedure Set_Warnings_Off (Id : E; V : B := True) is
begin
Set_Flag96 (Id, V);
------------------------
procedure Write_Field36_Name (Id : Entity_Id) is
- pragma Unreferenced (Id);
begin
- Write_Str ("Field36??");
+ case Ekind (Id) is
+ when E_Variable =>
+ Write_Str ("Validated_Object");
+
+ when others =>
+ Write_Str ("Field36??");
+ end case;
end Write_Field36_Name;
------------------------
-- task). Set to True when secondary stack is used in this scope and must
-- be released on exit unless Sec_Stack_Needed_For_Return is set.
+-- Validated_Object (Node36)
+-- Defined in variables. Contains the object whose value is captured by
+-- the variable for validity check purposes.
+
-- Warnings_Off (Flag96)
-- Defined in all entities. Set if a pragma Warnings (Off, entity-name)
-- is used to suppress warnings for a given entity. It is also used by
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Anonymous_Designated_Type (Node35)
+ -- Validated_Object (Node36)
-- SPARK_Pragma (Node40)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
function Used_As_Generic_Actual (Id : E) return B;
function Uses_Lock_Free (Id : E) return B;
function Uses_Sec_Stack (Id : E) return B;
+ function Validated_Object (Id : E) return N;
function Warnings_Off (Id : E) return B;
function Warnings_Off_Used (Id : E) return B;
function Warnings_Off_Used_Unmodified (Id : E) return B;
procedure Set_Used_As_Generic_Actual (Id : E; V : B := True);
procedure Set_Uses_Lock_Free (Id : E; V : B := True);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
+ procedure Set_Validated_Object (Id : E; V : N);
procedure Set_Warnings_Off (Id : E; V : B := True);
procedure Set_Warnings_Off_Used (Id : E; V : B := True);
procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True);
pragma Inline (Used_As_Generic_Actual);
pragma Inline (Uses_Lock_Free);
pragma Inline (Uses_Sec_Stack);
+ pragma Inline (Validated_Object);
pragma Inline (Warnings_Off);
pragma Inline (Warnings_Off_Used);
pragma Inline (Warnings_Off_Used_Unmodified);
pragma Inline (Set_Used_As_Generic_Actual);
pragma Inline (Set_Uses_Lock_Free);
pragma Inline (Set_Uses_Sec_Stack);
+ pragma Inline (Set_Validated_Object);
pragma Inline (Set_Warnings_Off);
pragma Inline (Set_Warnings_Off_Used);
pragma Inline (Set_Warnings_Off_Used_Unmodified);
---------------------
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.
- if Is_Entity_Name (Temp) then
- Set_Is_Known_Valid (Entity (Temp), False);
+ -- 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:
+
+ -- Temp : ... := Object;
+ -- if not Temp in ... then
+
+ if Is_Validation_Variable_Reference (Pref) then
+ Temp := New_Occurrence_Of (Entity (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 (Btyp, Temp),
Right_Opnd =>
Make_Range (Loc,
- Low_Bound =>
+ Low_Bound =>
Unchecked_Convert_To (Btyp,
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,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Last))));
end Make_Range_Test;
then
Add_Call_By_Copy_Code;
+ -- The actual denotes a variable which captures the value of an
+ -- object for validation purposes. Add a copy-back to reflect any
+ -- potential changes in value back into the original object.
+
+ -- Temp : ... := Object;
+ -- if not Temp'Valid then ...
+ -- Call (Temp);
+ -- Object := Temp;
+
+ elsif Is_Validation_Variable_Reference (Actual) then
+ Append_To (Post_Call,
+ Make_Assignment_Statement (Loc,
+ Name => Validated_Object (Entity (Actual)),
+ Expression => New_Occurrence_Of (Entity (Actual), Loc)));
+
elsif Nkind (Actual) = N_Indexed_Component
and then Is_Entity_Name (Prefix (Actual))
and then Has_Volatile_Components (Entity (Prefix (Actual)))
Typ => Typ,
Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
- -- Create TSS primitive Finalize_Address.
+ -- Create TSS primitive Finalize_Address (unless CodePeer_Mode).
- Set_TSS (Typ,
- Make_Deep_Proc
- (Prim => Address_Case,
- Typ => Typ,
- Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
+ if not CodePeer_Mode then
+ Set_TSS (Typ,
+ Make_Deep_Proc
+ (Prim => Address_Case,
+ Typ => Typ,
+ Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
+ end if;
end if;
end Build_Array_Deep_Procs;
Typ => Typ,
Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
- -- Create TSS primitive Finalize_Address
+ -- Create TSS primitive Finalize_Address (unless CodePeer_Mode).
- Set_TSS (Typ,
- Make_Deep_Proc
- (Prim => Address_Case,
- Typ => Typ,
- Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
+ if not CodePeer_Mode then
+ Set_TSS (Typ,
+ Make_Deep_Proc
+ (Prim => Address_Case,
+ Typ => Typ,
+ Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
+ end if;
end if;
end Build_Record_Deep_Procs;
return;
end if;
+ -- Don't generate Finalize_Address routine for CodePeer
+ if CodePeer_Mode then
+ return;
+ end if;
+
Proc_Id :=
Make_Defining_Identifier (Loc,
Make_TSS_Name (Typ, TSS_Finalize_Address));
-- Flag set when the pragma is one of Pre, Pre_Class, Post or
-- Post_Class.
+ function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
+ -- Implement rules in AI12-0131: an overriding operation can have
+ -- a class-wide precondition only if one of its ancestors has an
+ -- explicit class-wide precondition.
+
+ -----------------------------
+ -- Inherits_Class_Wide_Pre --
+ -----------------------------
+
+ function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
+ Prev : Entity_Id := Overridden_Operation (E);
+ Cont : Node_Id;
+ Prag : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ -- Check ancestors on the overriding operation to examine the
+ -- preconditions that may apply to them.
+
+ while Present (Prev) loop
+ Cont := Contract (Prev);
+ if Present (Cont) then
+ Prag := Pre_Post_Conditions (Cont);
+ while Present (Prag) loop
+ if Class_Present (Prag) then
+ return True;
+ end if;
+
+ Prag := Next_Pragma (Prag);
+ end loop;
+ end if;
+
+ Prev := Overridden_Operation (Prev);
+ end loop;
+
+ -- If the controlling type of the subprogram has progenitors,
+ -- an interface operation implemented by the current operation
+ -- may have a class-wide precondition.
+
+ Typ := Find_Dispatching_Type (E);
+ if Has_Interfaces (Typ) then
+ declare
+ Ints : Elist_Id;
+ Elmt : Elmt_Id;
+ Prim_List : Elist_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim : Entity_Id;
+ begin
+ Collect_Interfaces (Typ, Ints);
+ Elmt := First_Elmt (Ints);
+
+ -- Iterate over the primitive operations of each
+ -- interface.
+
+ while Present (Elmt) loop
+ Prim_List :=
+ (Direct_Primitive_Operations (Node (Elmt)));
+ Prim_Elmt := First_Elmt (Prim_List);
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+ if Chars (Prim) = Chars (E)
+ and then Present (Contract (Prim))
+ and then Class_Present
+ (Pre_Post_Conditions (Contract (Prim)))
+ then
+ return True;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Inherits_Class_Wide_Pre;
+
begin
-- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
-- offer uniformity among the various kinds of pre/postconditions by
Error_Pragma ("aspect % requires ''Class for null procedure");
end if;
+ -- Implement the legality checks mandated by AI12-0131:
+ -- Pre'Class shall not be specified for an overriding primitive
+ -- subprogram of a tagged type T unless the Pre'Class aspect is
+ -- specified for the corresponding primitive subprogram of some
+ -- ancestor of T.
+
+ declare
+ E : constant Entity_Id := Defining_Entity (Subp_Decl);
+ H : constant Entity_Id := Homonym (E);
+
+ begin
+ if Class_Present (N)
+ and then Present (Overridden_Operation (E))
+ and then not Inherits_Class_Wide_Pre (E)
+ then
+ Error_Msg_N
+ ("illegal class-wide precondition on overriding "
+ & "operation", Corresponding_Aspect (N));
+
+ -- If the operation is declared in the private part of an
+ -- instance it may not override any visible operations, but
+ -- still have a parent operation that carries a precondition.
+
+ elsif In_Instance
+ and then In_Private_Part (Current_Scope)
+ and then Present (H)
+ and then Scope (E) = Scope (H)
+ and then Is_Inherited_Operation (H)
+ and then Present (Overridden_Operation (H))
+ and then not Inherits_Class_Wide_Pre (H)
+ then
+ Error_Msg_N
+ ("illegal class-wide precondition on overriding "
+ & "operation in instance", Corresponding_Aspect (N));
+ end if;
+ end;
+
-- Otherwise the placement is illegal
else
return T = Universal_Integer or else T = Universal_Real;
end Is_Universal_Numeric_Type;
+ --------------------------------------
+ -- Is_Validation_Variable_Reference --
+ --------------------------------------
+
+ function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is
+ begin
+ return
+ Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Ekind (Entity (N)) = E_Variable
+ and then Present (Validated_Object (Entity (N)));
+ end Is_Validation_Variable_Reference;
+
----------------------------
-- Is_Variable_Size_Array --
----------------------------
------------------------
function Is_Volatile_Object (N : Node_Id) return Boolean is
-
function Is_Volatile_Prefix (N : Node_Id) return Boolean;
-- If prefix is an implicit dereference, examine designated type
pragma Inline (Is_Universal_Numeric_Type);
-- True if T is Universal_Integer or Universal_Real
+ function Is_Validation_Variable_Reference (N : Node_Id) return Boolean;
+ -- Determine whether N denotes a reference to a variable which captures the
+ -- value of an object for validation purposes.
+
function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
-- Returns true if E has variable size components
projects / gcc.git / commitdiff