+2010-10-26 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch13.adb (Build_Invariant_Procedure): New calling sequence.
+ (Build_Invariant_Procedure): Properly handle analysis of invariant
+ expression with proper end-of-visible-decls visibility.
+ * sem_ch13.ads (Build_Invariant_Procedure): Changed calling sequence.
+ * sem_ch3.adb (Process_Full_View): Don't build invariant procedure
+ (too late).
+ (Analyze_Private_Extension_Declaration): Propagate invariant flags.
+ * sem_ch7.adb (Analyze_Package_Specification): Build invariant
+ procedures.
+
2010-10-26 Vincent Celier <celier@adacore.com>
* opt.ads (Old_Checksums, Old_Old_Checksums): New Boolean flags,
-- ...
-- end typInvariant;
- procedure Build_Invariant_Procedure
- (Typ : Entity_Id;
- PDecl : out Node_Id;
- PBody : out Node_Id)
- is
+ procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Stmts : List_Id;
Spec : Node_Id;
SId : Entity_Id;
+ PDecl : Node_Id;
+ PBody : Node_Id;
+
+ Visible_Decls : constant List_Id := Visible_Declarations (N);
+ Private_Decls : constant List_Id := Private_Declarations (N);
procedure Add_Invariants (T : Entity_Id; Inherit : Boolean);
-- Appends statements to Stmts for any invariants in the rep item chain
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of invariant procedure
+ Object_Entity : constant Node_Id :=
+ Make_Defining_Identifier (Loc, Object_Name);
+ -- The procedure declaration entity for the argument
+
--------------------
-- Add_Invariants --
--------------------
new Replace_Type_References_Generic (Replace_Type_Reference);
-- Traverse an expression replacing all occurrences of the subtype
-- name with appropriate references to the object that is the formal
- -- parameter of the predicate function.
+ -- parameter of the predicate function. Note that we must ensure
+ -- that the type and entity information is properly set in the
+ -- replacement node, since we will do a Preanalyze call of this
+ -- expression without proper visibility of the procedure argument.
----------------------------
-- Replace_Type_Reference --
Make_Identifier (Loc,
Chars => Object_Name)));
+ Set_Entity (Expression (N), Object_Entity);
+ Set_Etype (Expression (N), Typ);
+
-- Invariant, replace with obj
else
- Rewrite (N,
- Make_Identifier (Loc,
- Chars => Object_Name));
+ Rewrite (N, Make_Identifier (Loc, Chars => Object_Name));
+ Set_Entity (N, Object_Entity);
+ Set_Etype (N, Typ);
end if;
end Replace_Type_Reference;
Replace_Type_References (Exp, Chars (T));
+ -- Now we need to preanalyze the expression to properly capture
+ -- the visibility in the visible part. The expression will not
+ -- be analyzed for real until the body is analyzed, but that is
+ -- at the end of the private part and has the wrong visibility.
+
+ Set_Parent (Exp, N);
+ Preanalyze_Spec_Expression (Exp, Standard_Boolean);
+
-- Build first two arguments for Check pragma
Assoc := New_List (
Make_Pragma_Argument_Association (Loc,
Expression =>
- Make_Identifier (Loc,
- Chars => Name_Invariant)),
+ Make_Identifier (Loc, Chars => Name_Invariant)),
Make_Pragma_Argument_Association (Loc,
Expression => Exp));
Append_To (Stmts,
Make_Pragma (Loc,
Pragma_Identifier =>
- Make_Identifier (Loc,
- Chars => Name_Check),
+ Make_Identifier (Loc, Chars => Name_Check),
Pragma_Argument_Associations => Assoc));
-- If Inherited case and option enabled, output info msg. Note
Stmts := No_List;
PDecl := Empty;
PBody := Empty;
+ Set_Etype (Object_Entity, Typ);
-- Add invariants for the current type
-- Build procedure declaration
- pragma Assert (Has_Invariants (Typ));
SId :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Invariant"));
Defining_Unit_Name => SId,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))));
+ Defining_Identifier => Object_Entity,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))));
- PDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
+ PDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
-- Build procedure body
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
+
+ -- Insert procedure declaration and spec at the appropriate points.
+ -- Skip this if there are no private declarations (that's an error
+ -- that will be diagnosed elsewhere, and there is no point in having
+ -- an invariant procedure set if the full declaration is missing).
+
+ if Present (Private_Decls) then
+
+ -- The spec goes at the end of visible declarations, but they have
+ -- already been analyzed, so we need to explicitly do the analyze.
+
+ Append_To (Visible_Decls, PDecl);
+ Analyze (PDecl);
+
+ -- The body goes at the end of the private declarations, which we
+ -- have not analyzed yet, so we do not need to perform an explicit
+ -- analyze call. We skip this if there are no private declarations
+ -- (this is an error that will be caught elsewhere);
+
+ Append_To (Private_Decls, PBody);
+ end if;
end if;
end Build_Invariant_Procedure;
-- order is specified and there is at least one component clause. Adjusts
-- component positions according to either Ada 95 or Ada 2005 (AI-133).
- procedure Build_Invariant_Procedure
- (Typ : Entity_Id;
- PDecl : out Node_Id;
- PBody : out Node_Id);
- -- If Typ has Invariants (indicated by Has_Invariants being set for Typ,
- -- indicating the presence of pragma Invariant entries on the rep chain,
- -- note that Invariant aspects are converted to pragma Invariant), then
- -- this procedure builds the spec and body for the corresponding Invariant
- -- procedure, returning themn in PDecl and PBody. Invariant_Procedure is
- -- set for Typ. In some error situations no procedure is built, in which
- -- case PDecl/PBody are empty on return.
+ procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id);
+ -- Typ is a private type with invariants (indicated by Has_Invariants being
+ -- set for Typ, indicating the presence of pragma Invariant entries on the
+ -- rep chain, note that Invariant aspects have already been converted to
+ -- pragma Invariant), then this procedure builds the spec and body for the
+ -- corresponding Invariant procedure, inserting them at appropriate points
+ -- in the package specification N. Invariant_Procedure is set for Typ. Note
+ -- that this procedure is called at the end of processing the declarations
+ -- in the visible part (i.e. the right point for visibility analysis of
+ -- the invariant expression).
procedure Check_Record_Representation_Clause (N : Node_Id);
-- This procedure completes the analysis of a record representation clause
Build_Derived_Record_Type (N, Parent_Type, T);
+ -- Propagate inherited invariant information. The new type has
+ -- invariants, if the parent type has inheritable invariants,
+ -- and these invariants can in turn be inherited.
+
+ if Has_Inheritable_Invariants (Parent_Type) then
+ Set_Has_Inheritable_Invariants (T);
+ Set_Has_Invariants (T);
+ end if;
+
-- Ada 2005 (AI-443): Synchronized private extension or a rewritten
-- synchronized formal derived type.
Set_Has_Specified_Stream_Output (Full_T);
end if;
- -- Deal with invariants
+ -- Propagate invariants to full type
- if Has_Invariants (Full_T)
- or else
- Has_Invariants (Priv_T)
- then
+ if Has_Invariants (Priv_T) then
Set_Has_Invariants (Full_T);
- Set_Has_Invariants (Priv_T);
+ Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T));
end if;
- if Has_Inheritable_Invariants (Full_T)
- or else
- Has_Inheritable_Invariants (Priv_T)
- then
+ if Has_Inheritable_Invariants (Priv_T) then
Set_Has_Inheritable_Invariants (Full_T);
- Set_Has_Inheritable_Invariants (Priv_T);
- end if;
-
- -- This is where we build the invariant procedure if needed
-
- if Has_Invariants (Priv_T) then
- declare
- PDecl : Entity_Id;
- PBody : Entity_Id;
- Packg : constant Node_Id := Declaration_Node (Scope (Priv_T));
-
- begin
- Build_Invariant_Procedure (Full_T, PDecl, PBody);
-
- -- Error defense, normally these should be set
-
- if Present (PDecl) and then Present (PBody) then
-
- -- Spec goes at the end of the public part of the package.
- -- That's behind us, so we have to manually analyze the
- -- inserted spec.
-
- Append_To (Visible_Declarations (Packg), PDecl);
- Analyze (PDecl);
-
- -- Body goes at the end of the private part of the package.
- -- That's ahead of us so it will get analyzed later on when
- -- we come to it.
-
- Append_To (Private_Declarations (Packg), PBody);
-
- -- Copy Invariant procedure to private declaration
-
- Set_Invariant_Procedure (Priv_T, Invariant_Procedure (Full_T));
- Set_Has_Invariants (Priv_T);
- end if;
- end;
end if;
-- Propagate predicates to full type
Analyze_Declarations (Vis_Decls);
end if;
- -- Verify that incomplete types have received full declarations
+ -- Verify that incomplete types have received full declarations and
+ -- also build invariant procedures for any types with invariants.
E := First_Entity (Id);
while Present (E) loop
+
+ -- Check on incomplete types
+
if Ekind (E) = E_Incomplete_Type
and then No (Full_View (E))
then
Error_Msg_N ("no declaration in visible part for incomplete}", E);
end if;
+ -- Build invariant procedures
+
+ if Is_Type (E) and then Has_Invariants (E) then
+ Build_Invariant_Procedure (E, N);
+ end if;
+
Next_Entity (E);
end loop;
projects / platform / upstream / gcc.git / commitdiff