===================================================================
@@ -2947,8 +2947,7 @@
-- evaluation of this aspect should be delayed to the
-- freeze point (why???)
- if No (Expr)
- or else Is_True (Static_Boolean (Expr))
+ if No (Expr) or else Is_True (Static_Boolean (Expr))
then
Set_Uses_Lock_Free (E);
end if;
@@ -3621,10 +3620,10 @@
if (Attr = Name_Constant_Indexing
and then Present
(Find_Aspect (Etype (Ent), Aspect_Constant_Indexing)))
-
- or else (Attr = Name_Variable_Indexing
- and then Present
- (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing)))
+ or else
+ (Attr = Name_Variable_Indexing
+ and then Present
+ (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing)))
then
if Debug_Flag_Dot_XX then
null;
@@ -4269,11 +4268,7 @@
-- Case of address clause for a (non-controlled) object
- elsif
- Ekind (U_Ent) = E_Variable
- or else
- Ekind (U_Ent) = E_Constant
- then
+ elsif Ekind_In (U_Ent, E_Variable, E_Constant) then
declare
Expr : constant Node_Id := Expression (N);
O_Ent : Entity_Id;
@@ -4295,7 +4290,7 @@
if Present (O_Ent)
and then (Has_Controlled_Component (Etype (O_Ent))
- or else Is_Controlled (Etype (O_Ent)))
+ or else Is_Controlled (Etype (O_Ent)))
then
Error_Msg_N
("??cannot overlay with controlled object", Expr);
@@ -4826,13 +4821,10 @@
-- except from aspect specification.
if From_Aspect_Specification (N) then
- if not (Is_Protected_Type (U_Ent)
- or else Is_Task_Type (U_Ent))
- then
+ if not Is_Concurrent_Type (U_Ent) then
Error_Msg_N
- ("Interrupt_Priority can only be defined for task" &
- "and protected object",
- Nam);
+ ("Interrupt_Priority can only be defined for task "
+ & "and protected object", Nam);
elsif Duplicate_Clause then
null;
@@ -4985,14 +4977,12 @@
-- aspect specification.
if From_Aspect_Specification (N) then
- if not (Is_Protected_Type (U_Ent)
- or else Is_Task_Type (U_Ent)
+ if not (Is_Concurrent_Type (U_Ent)
or else Ekind (U_Ent) = E_Procedure)
then
Error_Msg_N
- ("Priority can only be defined for task and protected " &
- "object",
- Nam);
+ ("Priority can only be defined for task and protected "
+ & "object", Nam);
elsif Duplicate_Clause then
null;
@@ -5828,6 +5818,7 @@
if Val = No_Uint then
Err := True;
+
elsif Val < Lo or else Hi < Val then
Error_Msg_N ("value outside permitted range", Expr);
Err := True;
@@ -7625,6 +7616,29 @@
Set_Parent (Exp, N);
Preanalyze_Assert_Expression (Exp, Standard_Boolean);
+ -- A class-wide invariant may be inherited in a separate unit,
+ -- where the corresponding expression cannot be resolved by
+ -- visibility, because it refers to a local function. Propagate
+ -- semantic information to the original representation item, to
+ -- be used when an invariant procedure for a derived type is
+ -- constructed.
+
+ -- Unclear how to handle class-wide invariants that are not
+ -- function calls ???
+
+ if not Inherit
+ and then Class_Present (Ritem)
+ and then Nkind (Exp) = N_Function_Call
+ and then Nkind (Arg2) = N_Indexed_Component
+ then
+ Rewrite (Arg2,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Entity (Name (Exp)), Loc),
+ Parameter_Associations =>
+ New_Copy_List (Expressions (Arg2))));
+ end if;
+
-- In ASIS mode, even if assertions are not enabled, we must
-- analyze the original expression in the aspect specification
-- because it is part of the original tree.
@@ -8501,9 +8515,9 @@
-- at the freeze point.
elsif A_Id = Aspect_Input or else
- A_Id = Aspect_Output or else
- A_Id = Aspect_Read or else
- A_Id = Aspect_Write
+ A_Id = Aspect_Output or else
+ A_Id = Aspect_Read or else
+ A_Id = Aspect_Write
then
Analyze (End_Decl_Expr);
Check_Overloaded_Name;
@@ -8862,8 +8876,8 @@
and then Has_Discriminants (T))
or else
(Is_Access_Type (T)
- and then Is_Record_Type (Designated_Type (T))
- and then Has_Discriminants (Designated_Type (T)))
+ and then Is_Record_Type (Designated_Type (T))
+ and then Has_Discriminants (Designated_Type (T)))
then
Error_Msg_NE
("invalid address clause for initialized object &!",
@@ -8954,11 +8968,8 @@
then
return;
- elsif
- Ekind (Ent) = E_Constant
- or else
- Ekind (Ent) = E_In_Parameter
- then
+ elsif Ekind_In (Ent, E_Constant, E_In_Parameter) then
+
-- This is the case where we must have Ent defined before
-- U_Ent. Clearly if they are in different units this
-- requirement is met since the unit containing Ent is
@@ -11132,9 +11143,7 @@
-- need to know such a size, but this routine may be called with a
-- generic type as part of normal processing.
- elsif Is_Generic_Type (R_Typ)
- or else R_Typ = Any_Type
- then
+ elsif Is_Generic_Type (R_Typ) or else R_Typ = Any_Type then
return 0;
-- Access types (cannot have size smaller than System.Address)
@@ -11849,8 +11858,7 @@
(Is_Record_Type (T2) or else Is_Array_Type (T2))
and then
(Component_Alignment (T1) /= Component_Alignment (T2)
- or else
- Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
+ or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
then
return False;
end if;
@@ -12739,9 +12747,7 @@
Prim := First (Choices (Assoc));
- if Nkind (Prim) /= N_Identifier
- or else Present (Next (Prim))
- then
+ if Nkind (Prim) /= N_Identifier or else Present (Next (Prim)) then
Error_Msg_N ("illegal name in association", Prim);
elsif Chars (Prim) = Name_First then
@@ -12858,24 +12864,22 @@
if Warn_On_Unchecked_Conversion
and then not In_Predefined_Unit (N)
and then RTU_Loaded (Ada_Calendar)
- and then
- (Chars (Source) = Name_Time
- or else
- Chars (Target) = Name_Time)
+ and then (Chars (Source) = Name_Time
+ or else
+ Chars (Target) = Name_Time)
then
-- If Ada.Calendar is loaded and the name of one of the operands is
-- Time, there is a good chance that this is Ada.Calendar.Time.
declare
- Calendar_Time : constant Entity_Id :=
- Full_View (RTE (RO_CA_Time));
+ Calendar_Time : constant Entity_Id := Full_View (RTE (RO_CA_Time));
begin
pragma Assert (Present (Calendar_Time));
if Source = Calendar_Time or else Target = Calendar_Time then
Error_Msg_N
- ("?z?representation of 'Time values may change between " &
- "'G'N'A'T versions", N);
+ ("?z?representation of 'Time values may change between "
+ & "'G'N'A'T versions", N);
end if;
end;
end if;
A class-wide type invariant is inherited by a type extension, and incorporated into the invariant procedure for that type. When the expression for such an invariant (typically a function call) is first analyzed, we must preserve some semantic information in it, because the type extension may be declared in a different unit, where it cannot be resolved by visibility if it refers to local entities. The following must compile quietly: gcc -c -gnata inv2.ads --- package Inv1 is type T_Inv1 is tagged private with Type_Invariant'Class => Invariant (T_Inv1); function Invariant (This : in T_Inv1'Class) return Boolean; type T_Inv2 is new Inv1.T_Inv1 with private; private type T_Inv1 is tagged record Value : Integer := 1234; end record; function Invariant (This : in T_Inv1'Class) return Boolean is (This.Value > 1000); type T_Inv2 is new Inv1.T_Inv1 with null record; end Inv1; --- with Inv1; package Inv2 is type T_Inv2 is new Inv1.T_Inv1 with private; private type T_Inv2 is new Inv1.T_Inv1 with null record; end Inv2; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-17 Ed Schonberg <schonberg@adacore.com> * sem_ch13.adb (Add_Invariants): For a class-wide type invariant, preserve semantic information on the invariant expression (typically a function call) because it may be inherited by a type extension in a different unit, and it cannot be resolved by visibility elsewhere because it may refer to local entities.