+2014-02-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch6.adb (Add_Or_Save_Precondition): New routine.
+ (Collect_Body_Postconditions_In_Decls): New routine.
+ (Collect_Body_Postconditions_Of_Kind): Factor out code. Handle
+ postcondition aspects or pragmas that appear on a subprogram
+ body stub.
+ (Collect_Spec_Preconditions): Factor out code. Handle
+ precondition aspects or pragmas that appear on a subprogram
+ body stub.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): The analysis of
+ aspects that apply to a subprogram body stub is no longer delayed,
+ the aspects are analyzed on the spot.
+ (SPARK_Aspect_Error):
+ Aspects that apply to a subprogram declaration cannot appear in
+ a subunit.
+ * sem_ch10.adb Remove with and use clause for Sem_Ch13.
+ (Analyze_Proper_Body): Add local variable Comp_Unit. Unum
+ is now a local variable. Code cleanup. Analysis related to
+ the aspects of a subprogram body stub is now carried out by
+ Analyze_Subprogram_Body_Helper. Do not propagate the aspects
+ and/or pragmas of a subprogram body stub to the proper body
+ as this is no longer needed. Do not analyze the aspects of a
+ subprogram stub when the corresponding source unit is missing.
+ (Analyze_Protected_Body_Stub): Flag the illegal use of aspects
+ on a stub.
+ (Analyze_Task_Body_Stub): Flag the illegal use of
+ aspects on a stub.
+ (Optional_Subunit): Add local variable Unum.
+ * sem_ch13.adb (Insert_Delayed_Pragma): Do not analyze a generated
+ pragma when it applies to a subprogram body stub.
+ * sem_prag.adb (Analyze_Pragma): Pragmas Contract_Cases,
+ Depends and Global can now apply to a subprogram body stub as
+ long as it acts as its own spec.
+ (Analyze_Refined_Pragma):
+ Code reformatting. Refinement pragmas cannot apply to a subunit.
+
2014-02-25 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.ads Update the usage of flag
procedure Collect_Body_Postconditions (Stmts : in out List_Id) is
procedure Collect_Body_Postconditions_Of_Kind (Post_Nam : Name_Id);
- -- Process postconditions of a particular kind denoted by Post_Nam
+ -- Process all postconditions of a particular kind denoted by
+ -- Post_Nam.
-----------------------------------------
-- Collect_Body_Postconditions_Of_Kind --
-----------------------------------------
procedure Collect_Body_Postconditions_Of_Kind (Post_Nam : Name_Id) is
- Check_Prag : Node_Id;
- Decl : Node_Id;
+ procedure Collect_Body_Postconditions_In_Decls
+ (First_Decl : Node_Id);
+ -- Process all postconditions found in a declarative list starting
+ -- with declaration First_Decl.
- begin
- pragma Assert (Nam_In (Post_Nam, Name_Postcondition,
- Name_Refined_Post));
+ ------------------------------------------
+ -- Collect_Body_Postconditions_In_Decls --
+ ------------------------------------------
- -- Inspect the declarations of the subprogram body looking for a
- -- pragma that matches the desired name.
+ procedure Collect_Body_Postconditions_In_Decls
+ (First_Decl : Node_Id)
+ is
+ Check_Prag : Node_Id;
+ Decl : Node_Id;
- Decl := First (Declarations (N));
- while Present (Decl) loop
- if Nkind (Decl) = N_Pragma then
- if Pragma_Name (Decl) = Post_Nam then
- Analyze (Decl);
- Check_Prag := Build_Pragma_Check_Equivalent (Decl);
+ begin
+ -- Inspect the declarative list looking for a pragma that
+ -- matches the desired name.
- if Expander_Active then
- Append_Enabled_Item
- (Item => Check_Prag,
- List => Stmts);
+ Decl := First_Decl;
+ while Present (Decl) loop
- -- When analyzing a generic unit, save the pragma for
- -- later.
+ -- Note that non-matching pragmas are skipped
- else
- Prepend_To_Declarations (Check_Prag);
+ if Nkind (Decl) = N_Pragma then
+ if Pragma_Name (Decl) = Post_Nam then
+ if not Analyzed (Decl) then
+ Analyze (Decl);
+ end if;
+
+ Check_Prag := Build_Pragma_Check_Equivalent (Decl);
+
+ if Expander_Active then
+ Append_Enabled_Item
+ (Item => Check_Prag,
+ List => Stmts);
+
+ -- When analyzing a generic unit, save the pragma for
+ -- later.
+
+ else
+ Prepend_To_Declarations (Check_Prag);
+ end if;
end if;
+
+ -- Skip internally generated code
+
+ elsif not Comes_From_Source (Decl) then
+ null;
+
+ -- Postcondition pragmas are usually grouped together. There
+ -- is no need to inspect the whole declarative list.
+
+ else
+ exit;
end if;
- -- Skip internally generated code
+ Next (Decl);
+ end loop;
+ end Collect_Body_Postconditions_In_Decls;
- elsif not Comes_From_Source (Decl) then
- null;
+ -- Local variables
- -- Postconditions in bodies are usually grouped at the top of
- -- the declarations. There is no point in inspecting the whole
- -- source list.
+ Unit_Decl : constant Node_Id := Parent (N);
- else
- exit;
- end if;
+ -- Start of processing for Collect_Body_Postconditions_Of_Kind
- Next (Decl);
- end loop;
+ begin
+ pragma Assert (Nam_In (Post_Nam, Name_Postcondition,
+ Name_Refined_Post));
+
+ -- Inspect the declarations of the subprogram body looking for a
+ -- pragma that matches the desired name.
+
+ Collect_Body_Postconditions_In_Decls
+ (First_Decl => First (Declarations (N)));
+
+ -- The subprogram body being processed is actually the proper body
+ -- of a stub with a corresponding spec. The subprogram stub may
+ -- carry a postcondition pragma in which case it must be taken
+ -- into account. The pragma appears after the stub.
+
+ if Present (Spec_Id) and then Nkind (Unit_Decl) = N_Subunit then
+ Collect_Body_Postconditions_In_Decls
+ (First_Decl => Next (Corresponding_Stub (Unit_Decl)));
+ end if;
end Collect_Body_Postconditions_Of_Kind;
-- Start of processing for Collect_Body_Postconditions
--------------------------------
procedure Collect_Spec_Preconditions (Subp_Id : Entity_Id) is
+ Class_Pre : Node_Id := Empty;
+ -- The sole class-wide precondition pragma that applies to the
+ -- subprogram.
+
+ procedure Add_Or_Save_Precondition (Prag : Node_Id);
+ -- Save a class-wide precondition or add a regulat precondition to
+ -- the declarative list of the body.
+
procedure Merge_Preconditions (From : Node_Id; Into : Node_Id);
-- Merge two class-wide preconditions by "or else"-ing them. The
-- changes are accumulated in parameter Into. Update the error
-- message of Into.
+ ------------------------------
+ -- Add_Or_Save_Precondition --
+ ------------------------------
+
+ procedure Add_Or_Save_Precondition (Prag : Node_Id) is
+ Check_Prag : Node_Id;
+
+ begin
+ Check_Prag := Build_Pragma_Check_Equivalent (Prag);
+
+ -- Save the sole class-wide precondition (if any) for the next
+ -- step where it will be merged with inherited preconditions.
+
+ if Class_Present (Prag) then
+ pragma Assert (No (Class_Pre));
+ Class_Pre := Check_Prag;
+
+ -- Accumulate the corresponding Check pragmas to the top of the
+ -- declarations. Prepending the items ensures that they will be
+ -- evaluated in their original order.
+
+ else
+ Prepend_To_Declarations (Check_Prag);
+ end if;
+ end Add_Or_Save_Precondition;
+
-------------------------
-- Merge_Preconditions --
-------------------------
Inher_Subps : constant Subprogram_List :=
Inherited_Subprograms (Subp_Id);
+ Subp_Decl : constant Node_Id := Parent (Parent (Subp_Id));
Check_Prag : Node_Id;
- Class_Pre : Node_Id := Empty;
+ Decl : Node_Id;
Inher_Subp_Id : Entity_Id;
Prag : Node_Id;
Prag := Pre_Post_Conditions (Contract (Subp_Id));
while Present (Prag) loop
if Pragma_Name (Prag) = Name_Precondition then
- Check_Prag := Build_Pragma_Check_Equivalent (Prag);
+ Add_Or_Save_Precondition (Prag);
+ end if;
- -- Save the sole class-wide precondition (if any) for the next
- -- step where it will be merged with inherited preconditions.
+ Prag := Next_Pragma (Prag);
+ end loop;
- if Class_Present (Prag) then
- Class_Pre := Check_Prag;
+ -- The subprogram declaration being processed is actually a body
+ -- stub. The stub may carry a precondition pragma in which case it
+ -- must be taken into account. The pragma appears after the stub.
- -- Accumulate the corresponding Check pragmas to the top of the
- -- declarations. Prepending the items ensures that they will
- -- be evaluated in their original order.
+ if Nkind (Subp_Decl) = N_Subprogram_Body_Stub then
+
+ -- Inspect the declarations following the body stub
+
+ Decl := Next (Subp_Decl);
+ while Present (Decl) loop
+
+ -- Note that non-matching pragmas are skipped
+
+ if Nkind (Decl) = N_Pragma then
+ if Pragma_Name (Decl) = Name_Precondition then
+ if not Analyzed (Decl) then
+ Analyze (Decl);
+ end if;
+
+ Add_Or_Save_Precondition (Decl);
+ end if;
+
+ -- Skip internally generated code
+
+ elsif not Comes_From_Source (Decl) then
+ null;
+
+ -- Preconditions are usually grouped together. There is no need
+ -- to inspect the whole declarative list.
else
- Prepend_To_Declarations (Check_Prag);
+ exit;
end if;
- end if;
- Prag := Next_Pragma (Prag);
- end loop;
+ Next (Decl);
+ end loop;
+ end if;
-- Process the contracts of all inherited subprograms, looking for
-- class-wide preconditions.
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
with Sem_Dist; use Sem_Dist;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
- Unum : Unit_Number_Type;
procedure Optional_Subunit;
-- This procedure is called when the main unit is a stub, or when we
procedure Optional_Subunit is
Comp_Unit : Node_Id;
+ Unum : Unit_Number_Type;
begin
-- Try to load subunit, but ignore any errors that occur during the
-- Local variables
- Stub_Id : Entity_Id;
+ Comp_Unit : Node_Id;
+ Unum : Unit_Number_Type;
-- Start of processing for Analyze_Proper_Body
Write_Eol;
end if;
- declare
- Comp_Unit : constant Node_Id := Cunit (Unum);
- Prop_Body : Node_Id;
-
- begin
- -- Check for child unit instead of subunit
-
- if Nkind (Unit (Comp_Unit)) /= N_Subunit then
- Error_Msg_N
- ("expected SEPARATE subunit, found child unit",
- Cunit_Entity (Unum));
-
- -- OK, we have a subunit
-
- else
- Prop_Body := Proper_Body (Unit (Comp_Unit));
-
- -- Set corresponding stub (even if errors)
+ Comp_Unit := Cunit (Unum);
- Set_Corresponding_Stub (Unit (Comp_Unit), N);
+ -- Check for child unit instead of subunit
- -- Collect SCO information for loaded subunit if we are
- -- in the main unit.
+ if Nkind (Unit (Comp_Unit)) /= N_Subunit then
+ Error_Msg_N
+ ("expected SEPARATE subunit, found child unit",
+ Cunit_Entity (Unum));
- if Generate_SCO
- and then
- In_Extended_Main_Source_Unit
- (Cunit_Entity (Current_Sem_Unit))
- then
- SCO_Record (Unum);
- end if;
-
- -- Propagate all aspect specifications associated with
- -- the stub to the proper body.
-
- Move_Or_Merge_Aspects (From => N, To => Prop_Body);
-
- -- Move all source pragmas that follow the body stub and
- -- apply to it to the declarations of the proper body.
+ -- OK, we have a subunit
- if Nkind (N) = N_Subprogram_Body_Stub then
- Relocate_Pragmas_To_Body (N, Target_Body => Prop_Body);
- end if;
-
- -- Analyze the unit if semantics active
-
- if not Fatal_Error (Unum) or else Try_Semantics then
- Analyze_Subunit (Comp_Unit);
- end if;
+ else
+ Set_Corresponding_Stub (Unit (Comp_Unit), N);
+ Set_Library_Unit (N, Comp_Unit);
- -- Set the library unit pointer in any case
+ -- We update the version. Although we are not technically
+ -- semantically dependent on the subunit, given our approach
+ -- of macro substitution of subunits, it makes sense to
+ -- include it in the version identification.
- Set_Library_Unit (N, Comp_Unit);
+ Version_Update (Cunit (Main_Unit), Comp_Unit);
- -- We update the version. Although we are not technically
- -- semantically dependent on the subunit, given our
- -- approach of macro substitution of subunits, it makes
- -- sense to include it in the version identification.
+ -- Collect SCO information for loaded subunit if we are in
+ -- the main unit.
- Version_Update (Cunit (Main_Unit), Comp_Unit);
+ if Generate_SCO
+ and then
+ In_Extended_Main_Source_Unit
+ (Cunit_Entity (Current_Sem_Unit))
+ then
+ SCO_Record (Unum);
end if;
- end;
-
- -- The unit which should contain the proper subprogram body does
- -- not exist. Analyze the aspect specifications of the stub (if
- -- any).
-
- elsif Nkind (N) = N_Subprogram_Body_Stub
- and then Has_Aspects (N)
- then
- Stub_Id := Defining_Unit_Name (Specification (N));
-
- -- Restore the proper visibility of the stub and its formals
-
- Push_Scope (Stub_Id);
- Install_Formals (Stub_Id);
- Analyze_Aspect_Specifications (N, Stub_Id);
+ -- Analyze the unit if semantics active
- Pop_Scope;
+ if not Fatal_Error (Unum) or else Try_Semantics then
+ Analyze_Subunit (Comp_Unit);
+ end if;
+ end if;
end if;
end if;
Error_Msg_N ("missing specification for Protected body", N);
else
+ -- Currently there are no language-defined aspects that can apply to
+ -- a protected body stub. Issue an error and remove the aspects to
+ -- prevent cascaded errors.
+
+ if Has_Aspects (N) then
+ Error_Msg_N
+ ("aspects on protected bodies are not allowed",
+ First (Aspect_Specifications (N)));
+ Remove_Aspects (N);
+ end if;
+
Set_Scope (Defining_Entity (N), Current_Scope);
Set_Has_Completion (Etype (Nam));
Set_Corresponding_Spec_Of_Stub (N, Nam);
if No (Nam) or else not Is_Task_Type (Etype (Nam)) then
Error_Msg_N ("missing specification for task body", N);
+
else
+ -- Currently there are no language-defined aspects that can apply to
+ -- a task body stub. Issue an error and remove the aspects to prevent
+ -- cascaded errors.
+
+ if Has_Aspects (N) then
+ Error_Msg_N
+ ("aspects on task bodies are not allowed",
+ First (Aspect_Specifications (N)));
+ Remove_Aspects (N);
+ end if;
+
Set_Scope (Defining_Entity (N), Current_Scope);
Generate_Reference (Nam, Defining_Identifier (N), 'b');
Set_Corresponding_Spec_Of_Stub (N, Nam);
else
Insert_After (N, Prag);
-
- -- Analyze the pragma before analyzing the proper body of a stub.
- -- This ensures that the pragma will appear on the proper contract
- -- list (see N_Contract).
-
- if Nkind (N) = N_Subprogram_Body_Stub then
- Analyze (Prag);
- end if;
end if;
end Insert_Delayed_Pragma;
if Has_Aspect (Spec_Id, Asp_Id) then
Error_Msg_Name_1 := Asp_Nam;
- Error_Msg_Name_2 := Ref_Nam;
- Error_Msg_N ("aspect % should be %", Asp);
+
+ -- Subunits cannot carry aspects that apply to a subprogram
+ -- declaration.
+
+ if Nkind (Parent (N)) = N_Subunit then
+ Error_Msg_N ("aspect % cannot apply to a subunit", Asp);
+
+ else
+ Error_Msg_Name_2 := Ref_Nam;
+ Error_Msg_N ("aspect % should be %", Asp);
+ end if;
-- Otherwise the aspect must appear in the spec, not in the body:
end if;
end if;
- -- Language-defined aspects cannot appear in a subprogram body [stub] if
- -- the subprogram has a separate spec. Certainly implementation-defined
- -- aspects are allowed to appear (per Aspects_On_Body_Of_Stub_OK).
+ -- Language-defined aspects cannot appear on a subprogram body [stub] if
+ -- the subprogram has a spec. Certain implementation-defined aspects are
+ -- allowed to break this rule (see table Aspect_On_Body_Or_Stub_OK).
if Has_Aspects (N) then
if Present (Spec_Id)
and then not Aspects_On_Body_Or_Stub_OK (N)
-
- -- Do not emit an error on a subprogram body stub that act as
- -- its own spec.
-
- and then Nkind (Parent (Parent (Spec_Id))) /= N_Subprogram_Body_Stub
then
Diagnose_Misplaced_Aspect_Specifications;
- -- Delay the analysis of aspect specifications that apply to a body
- -- stub until the proper body is analyzed. If the corresponding body
- -- is missing, the aspects are still analyzed in Analyze_Proper_Body.
-
- elsif Nkind (N) in N_Body_Stub then
- null;
-
else
Analyze_Aspect_Specifications (N, Body_Id);
end if;
Body_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
- if not Nkind_In (Body_Decl, N_Subprogram_Body,
- N_Subprogram_Body_Stub)
- then
- Pragma_Misplaced;
- return;
- end if;
-
- Body_Id := Defining_Entity (Body_Decl);
-
- -- The body [stub] must not act as a spec, in other words it has to
- -- be paired with a corresponding spec.
+ -- Extract the entities of the spec and body
if Nkind (Body_Decl) = N_Subprogram_Body then
+ Body_Id := Defining_Entity (Body_Decl);
Spec_Id := Corresponding_Spec (Body_Decl);
- else
+
+ elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
+ Body_Id := Defining_Entity (Body_Decl);
Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl);
+
+ else
+ Pragma_Misplaced;
+ return;
end if;
+ -- The pragma must apply to the second declaration of a subprogram.
+ -- In other words, the body [stub] cannot acts as a spec.
+
if No (Spec_Id) then
Error_Pragma ("pragma % cannot apply to a stand alone body");
return;
+
+ -- Catch the case where the subprogram body is a subunit and acts as
+ -- the third declaration of the subprogram.
+
+ elsif Nkind (Parent (Body_Decl)) = N_Subunit then
+ Error_Pragma ("pragma % cannot apply to a subunit");
+ return;
end if;
- -- The pragma may only apply to the body [stub] of a subprogram
+ -- The pragma can only apply to the body [stub] of a subprogram
-- declared in the visible part of a package. Retrieve the context of
-- the subprogram declaration.
Spec_Decl := Parent (Parent (Spec_Id));
- pragma Assert
- (Nkind_In (Spec_Decl, N_Abstract_Subprogram_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Subprogram_Declaration));
-
if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
Error_Pragma
("pragma % must apply to the body of a subprogram declared in a "
Subp_Decl :=
Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
- if Nkind (Subp_Decl) /= N_Subprogram_Declaration
- and then (Nkind (Subp_Decl) /= N_Subprogram_Body
- or else not Acts_As_Spec (Subp_Decl))
+ if Nkind (Subp_Decl) = N_Subprogram_Declaration then
+ null;
+
+ -- Body acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body
+ and then No (Corresponding_Spec (Subp_Decl))
+ then
+ null;
+
+ -- Body stub acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
+ and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
then
+ null;
+
+ else
Pragma_Misplaced;
return;
end if;
Subp_Decl :=
Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
- if Nkind (Subp_Decl) /= N_Subprogram_Declaration
- and then (Nkind (Subp_Decl) /= N_Subprogram_Body
- or else not Acts_As_Spec (Subp_Decl))
+ if Nkind (Subp_Decl) = N_Subprogram_Declaration then
+ null;
+
+ -- Body acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body
+ and then No (Corresponding_Spec (Subp_Decl))
then
+ null;
+
+ -- Body stub acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
+ and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
+ then
+ null;
+
+ else
Pragma_Misplaced;
return;
end if;
Subp_Decl :=
Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
- if Nkind (Subp_Decl) /= N_Subprogram_Declaration
- and then (Nkind (Subp_Decl) /= N_Subprogram_Body
- or else not Acts_As_Spec (Subp_Decl))
+ if Nkind (Subp_Decl) = N_Subprogram_Declaration then
+ null;
+
+ -- Body acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body
+ and then No (Corresponding_Spec (Subp_Decl))
then
+ null;
+
+ -- Body stub acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
+ and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
+ then
+ null;
+
+ else
Pragma_Misplaced;
return;
end if;
projects / thirdparty / gcc.git / commitdiff
