===================================================================
@@ -62,6 +62,7 @@ with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
+with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Smem; use Sem_Smem;
with Sem_Type; use Sem_Type;
@@ -2069,6 +2070,35 @@ package body Sem_Ch3 is
D := Next_Node;
end loop;
+
+ -- One more thing to do, we need to scan the declarations to check
+ -- for any precondition/postcondition pragmas (Pre/Post aspects have
+ -- by this stage been converted into corresponding pragmas). It is
+ -- at this point that we analyze the expressions in such pragmas,
+ -- to implement the delayed visibility requirement.
+
+ declare
+ Decl : Node_Id;
+ Spec : Node_Id;
+ Sent : Entity_Id;
+ Prag : Node_Id;
+
+ begin
+ Decl := First (L);
+ while Present (Decl) loop
+ if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then
+ Spec := Specification (Original_Node (Decl));
+ Sent := Defining_Unit_Name (Spec);
+ Prag := Spec_PPC_List (Sent);
+ while Present (Prag) loop
+ Analyze_PPC_In_Decl_Part (Prag, Sent);
+ Prag := Next_Pragma (Prag);
+ end loop;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end;
end Analyze_Declarations;
-----------------------------------
===================================================================
@@ -55,7 +55,6 @@ with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Snames; use Snames;
@@ -872,12 +871,6 @@ package body Sem_Ch7 is
-- private_with_clauses, and remove them at the end of the nested
-- package.
- procedure Analyze_PPCs (Decls : List_Id);
- -- Given a list of declarations, go through looking for subprogram
- -- specs, and for each one found, analyze any pre/postconditions that
- -- are chained to the spec. This is the implementation of the late
- -- visibility analysis for preconditions and postconditions in specs.
-
procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
-- Clears constant indications (Never_Set_In_Source, Constant_Value, and
-- Is_True_Constant) on all variables that are entities of Id, and on
@@ -906,33 +899,6 @@ package body Sem_Ch7 is
-- private part rather than being done in Sem_Ch12.Install_Parent
-- (which is where the parents' visible declarations are installed).
- ------------------
- -- Analyze_PPCs --
- ------------------
-
- procedure Analyze_PPCs (Decls : List_Id) is
- Decl : Node_Id;
- Spec : Node_Id;
- Sent : Entity_Id;
- Prag : Node_Id;
-
- begin
- Decl := First (Decls);
- while Present (Decl) loop
- if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then
- Spec := Specification (Original_Node (Decl));
- Sent := Defining_Unit_Name (Spec);
- Prag := Spec_PPC_List (Sent);
- while Present (Prag) loop
- Analyze_PPC_In_Decl_Part (Prag, Sent);
- Prag := Next_Pragma (Prag);
- end loop;
- end if;
-
- Next (Decl);
- end loop;
- end Analyze_PPCs;
-
---------------------
-- Clear_Constants --
---------------------
@@ -1161,7 +1127,6 @@ package body Sem_Ch7 is
begin
if Present (Vis_Decls) then
Analyze_Declarations (Vis_Decls);
- Analyze_PPCs (Vis_Decls);
end if;
-- Verify that incomplete types have received full declarations
@@ -1296,7 +1261,6 @@ package body Sem_Ch7 is
end if;
Analyze_Declarations (Priv_Decls);
- Analyze_PPCs (Priv_Decls);
-- Check the private declarations for incomplete deferred constants
===================================================================
@@ -2581,7 +2581,10 @@ package body Einfo is
function Spec_PPC_List (Id : E) return N is
begin
- pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
+ pragma Assert
+ (Ekind (Id) = E_Entry
+ or else Is_Subprogram (Id)
+ or else Is_Generic_Subprogram (Id));
return Node24 (Id);
end Spec_PPC_List;
@@ -5046,7 +5049,10 @@ package body Einfo is
procedure Set_Spec_PPC_List (Id : E; V : N) is
begin
- pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
+ pragma Assert
+ (Ekind_In (Id, E_Entry, E_Void)
+ or else Is_Subprogram (Id)
+ or else Is_Generic_Subprogram (Id));
Set_Node24 (Id, V);
end Set_Spec_PPC_List;
===================================================================
@@ -3532,11 +3532,12 @@ package Einfo is
-- the corresponding parameter entities in the spec.
-- Spec_PPC_List (Node24)
+-- Present in entries, and in subprogram and generic subprogram entities.
+-- Points to a list of Precondition and Postcondition pragma nodes for
+-- preconditions and postconditions declared in the spec. The last pragma
+-- encountered is at the head of this list, so it is in reverse order of
+-- textual appearance. Note that this includes precondition/postcondition
+-- pragmas generated to correspond to Pre/Post aspects.
-- Storage_Size_Variable (Node15) [implementation base type only]
-- Present in access types and task type entities. This flag is set
@@ -4951,6 +4952,7 @@ package Einfo is
-- Accept_Address (Elist21)
-- Scope_Depth_Value (Uint22)
-- Protection_Object (Node23) (protected kind)
+ -- Spec_PPC_List (Node24) (for entry only)
-- Default_Expressions_Processed (Flag108)
-- Entry_Accepted (Flag152)
-- Is_AST_Entry (Flag132) (for entry only)
===================================================================
@@ -240,9 +240,7 @@ package body Sem_Prag is
------------------------------
procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
- Arg1 : constant Node_Id :=
- First (Pragma_Argument_Associations (N));
- Arg2 : constant Node_Id := Next (Arg1);
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
begin
-- Install formals and push subprogram spec onto scope stack so that we
@@ -257,13 +255,6 @@ package body Sem_Prag is
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg1), Standard_Boolean);
- -- If there is a message argument, analyze it the same way
-
- if Present (Arg2) then
- Preanalyze_Spec_Expression
- (Get_Pragma_Arg (Arg2), Standard_String);
- end if;
-
-- Remove the subprogram from the scope stack now that the pre-analysis
-- of the precondition/postcondition is done.
@@ -1511,8 +1502,7 @@ package body Sem_Prag is
("pragma% cannot be applied to abstract subprogram");
elsif Class_Present (N) then
- Error_Pragma
- ("aspect `%''Class` not implemented yet");
+ null;
else
Error_Pragma
@@ -1520,14 +1510,19 @@ package body Sem_Prag is
end if;
elsif not Nkind_In (PO, N_Subprogram_Declaration,
- N_Generic_Subprogram_Declaration)
+ N_Generic_Subprogram_Declaration,
+ N_Entry_Declaration)
then
Pragma_Misplaced;
end if;
- -- Here if we have subprogram or generic subprogram declaration
+ -- Here if we have [generic] subprogram or entry declaration
- S := Defining_Unit_Name (Specification (PO));
+ if Nkind (PO) = N_Entry_Declaration then
+ S := Defining_Entity (PO);
+ else
+ S := Defining_Unit_Name (Specification (PO));
+ end if;
-- Make sure we do not have the case of a precondition pragma when
-- the Pre'Class aspect is present.
@@ -1583,14 +1578,11 @@ package body Sem_Prag is
end;
end if;
- -- Analyze the pragma unless it appears within a package spec,
- -- which is the case where we delay the analysis of the PPC until
- -- the end of the package declarations (for details, see
- -- Analyze_Package_Specification.Analyze_PPCs).
-
- if not Is_Package_Or_Generic_Package (Scope (S)) then
- Analyze_PPC_In_Decl_Part (N, S);
- end if;
+ -- Note: we do not analye the pragma at this point. Instead we
+ -- delay this analysis until the end of the declarative part in
+ -- which the pragma appears. This implements the required delay
+ -- in this analysis, allowing forward references. The analysis
+ -- happens at the end of Analyze_Declarations.
-- Chain spec PPC pragma to list for subprogram
@@ -1610,6 +1602,15 @@ package body Sem_Prag is
Pragma_Misplaced;
end if;
+ -- Preanalyze message argument if present. Visibility in this
+ -- argument is established at the point of pragma occurrence.
+
+ if Arg_Count = 2 then
+ Check_Optional_Identifier (Arg2, Name_Message);
+ Preanalyze_Spec_Expression
+ (Get_Pragma_Arg (Arg2), Standard_String);
+ end if;
+
-- Record if pragma is enabled
if Check_Enabled (Pname) then
@@ -10823,7 +10824,6 @@ package body Sem_Prag is
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
Check_Optional_Identifier (Arg1, Name_Check);
-
Check_Precondition_Postcondition (In_Body);
-- If in spec, nothing more to do. If in body, then we convert the
@@ -10833,11 +10833,6 @@ package body Sem_Prag is
-- analyze the condition itself in the proper context.
if In_Body then
- if Arg_Count = 2 then
- Check_Optional_Identifier (Arg3, Name_Message);
- Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
- end if;
-
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check,
===================================================================
@@ -8699,18 +8699,22 @@ package body Sem_Ch6 is
-- do this fiddling, for the spec cases, the already preanalyzed
-- parameters are not affected.
+ Set_Analyzed (CP, False);
+
+ -- We also make sure Comes_From_Source is False for the copy
+
+ Set_Comes_From_Source (CP, False);
+
-- For a postcondition pragma within a generic, preserve the pragma
-- for later expansion.
- Set_Analyzed (CP, False);
-
if Nam = Name_Postcondition
and then not Expander_Active
then
return CP;
end if;
- -- Change pragma into corresponding pragma Check
+ -- Change copy of pragma into corresponding pragma Check
Prepend_To (Pragma_Argument_Associations (CP),
Make_Pragma_Argument_Association (Sloc (Prag),
@@ -8761,9 +8765,8 @@ package body Sem_Ch6 is
Prag := Spec_PPC_List (Spec_Id);
while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Precondition
- and then Pragma_Enabled (Prag)
- then
+ if Pragma_Name (Prag) = Name_Precondition then
+
-- For Pre (or Precondition pragma), we simply prepend the
-- pragma to the list of declarations right away so that it
-- will be executed at the start of the procedure. Note that
@@ -8969,7 +8972,6 @@ package body Sem_Ch6 is
Prag := Spec_PPC_List (Spec);
loop
if Pragma_Name (Prag) = Name_Postcondition
- and then Pragma_Enabled (Prag)
and then (not Class or else Class_Present (Prag))
then
if Plist = No_List then
===================================================================
@@ -1742,8 +1742,29 @@ package body Sem_Disp is
Parent_Op : Entity_Id;
-- Traverses the Overridden_Operation chain
+ procedure Store_IS (E : Entity_Id);
+ -- Stores E in Result if not already stored
+
+ --------------
+ -- Store_IS --
+ --------------
+
+ procedure Store_IS (E : Entity_Id) is
+ begin
+ for J in 1 .. N loop
+ if E = Result (J) then
+ return;
+ end if;
+ end loop;
+
+ N := N + 1;
+ Result (N) := E;
+ end Store_IS;
+
+ -- Start of processing for Inherited_Subprograms
+
begin
- if Present (S) then
+ if Present (S) and then Is_Dispatching_Operation (S) then
-- Deal with direct inheritance
@@ -1755,13 +1776,56 @@ package body Sem_Disp is
if Is_Subprogram (Parent_Op)
or else Is_Generic_Subprogram (Parent_Op)
then
- N := N + 1;
- Result (N) := Parent_Op;
+ Store_IS (Parent_Op);
end if;
end loop;
- -- For now don't bother with interfaces, TBD ???
+ -- Now deal with interfaces
+
+ declare
+ Tag_Typ : Entity_Id;
+ Prim : Entity_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ Tag_Typ := Find_Dispatching_Type (S);
+
+ if Is_Concurrent_Type (Tag_Typ) then
+ Tag_Typ := Corresponding_Record_Type (Tag_Typ);
+ end if;
+ -- Search primitive operations of dispatching type
+
+ if Present (Tag_Typ)
+ and then Present (Primitive_Operations (Tag_Typ))
+ then
+ Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+
+ -- The following test eliminates some odd cases in which
+ -- Ekind (Prim) is Void, to be investigated further ???
+
+ if not (Is_Subprogram (Prim)
+ or else
+ Is_Generic_Subprogram (Prim))
+ then
+ null;
+
+ -- For [generic] subprogram, look at interface alias
+
+ elsif Present (Interface_Alias (Prim))
+ and then Alias (Prim) = S
+ then
+ -- We have found a primitive covered by S
+
+ Store_IS (Interface_Alias (Prim));
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+ end;
end if;
return Result (1 .. N);