+2014-07-31 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Build_Invariant_Procedure): If body of procedure
+ is already present, nothing to do.
+ * exp_ch3.adb (Build_Component_Invariant_Call): For an access
+ component, check whether the access type has an invariant before
+ checking the designated type.
+ (Build_Record_Invariant_Proc): Change suffix of generated
+ name to prevent ambiguity when record type has invariants
+ in addition to those of components, and two subprograms are
+ constructed. Consistent with handling of array types.
+ (Insert_Component_Invariant_Checks): Build invariant procedure
+ body when one has not been created yet, in the case of composite
+ types that are completions and whose full declarations carry
+ invariants.
+
2014-07-30 Thomas Quinot <quinot@adacore.com>
* gnat_rm.texi: Minor doc fixes.
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
Selector_Name => New_Occurrence_Of (Comp, Loc));
if Is_Access_Type (Typ) then
- Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp);
- Typ := Designated_Type (Typ);
+
+ -- If the access component designates a type with an invariant,
+ -- the check applies to the designated object. The access type
+ -- itself may have an invariant, in which case it applies to the
+ -- access value directly.
+
+ -- Note: we are assuming that invariants will not occur on both
+ -- the access type and the type that it designates. This is not
+ -- really justified but it is hard to imagine that this case will
+ -- ever cause trouble ???
+
+ if not (Has_Invariants (Typ)) then
+ Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp);
+ Typ := Designated_Type (Typ);
+ end if;
end if;
Call :=
return Empty;
end if;
+ -- The name of the invariant procedure reflects the fact that the
+ -- checks correspond to invariants on the component types. The
+ -- record type itself may have invariants that will create a separate
+ -- procedure whose name carries the Invariant suffix.
+
Proc_Id :=
Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (R_Type), "Invariant"));
+ Chars => New_External_Name (Chars (R_Type), "CInvariant"));
Proc_Body :=
Make_Subprogram_Body (Loc,
else
- -- Find already created invariant body, insert body of component
- -- invariant proc in it, and add call after other checks.
+ -- Find already created invariant subprogram, insert body of
+ -- component invariant proc in its body, and add call after
+ -- other checks.
declare
Bod : Node_Id;
Inv_Id : constant Entity_Id := Invariant_Procedure (Typ);
Call : constant Node_Id :=
- Make_Procedure_Call_Statement (Loc,
+ Make_Procedure_Call_Statement (Sloc (N),
Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations =>
New_List
Next (Bod);
end loop;
+ -- If the body is not found, it is the case of an invariant
+ -- appearing on a full declaration in a private part, in
+ -- which case the type has been frozen but the invariant
+ -- procedure for the composite type not created yet. Create
+ -- body now.
+
+ if No (Bod) then
+ Build_Invariant_Procedure (Typ, Parent (Current_Scope));
+ Bod := Unit_Declaration_Node
+ (Corresponding_Body (Unit_Declaration_Node (Inv_Id)));
+ end if;
+
Append_To (Declarations (Bod), Proc);
Append_To (Statements (Handled_Statement_Sequence (Bod)), Call);
+ Analyze (Proc);
+ Analyze (Call);
end;
end if;
end if;
SId := Invariant_Procedure (Typ);
end if;
+ -- If the body is already present, nothing to do. This will occur when
+ -- the type is already frozen, which is the case when the invariant
+ -- appears in a private part, and the freezing takes place before the
+ -- final pass over full declarations.
+ -- See exp_ch3.Insert_Component_Invariant_Checks for details.
+
if Present (SId) then
PDecl := Unit_Declaration_Node (SId);
+
+ if Present (PDecl)
+ and then Nkind (PDecl) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (PDecl))
+ then
+ return;
+ end if;
+
else
PDecl := Build_Invariant_Procedure_Declaration (Typ);
end if;
projects / gcc.git / commitdiff