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 <schonb...@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.
Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 216367) +++ sem_ch13.adb (working copy) @@ -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;