In Ada 2012, the formals of a subprogram can be incomplete types, and the subprogram is a primitive operation of the type. If the type is subsequently derived, it inherits the operation, and it can be explicitly overridden.
Executing main.adb must yield: 1 2 --- with Prim_Test; use Prim_Test; procedure Main is One : T := (Val => 1); Two : T := (Val => 2); begin Q (One); Q (Two); end; --: package Prim_Test is type T; procedure P (V : T); procedure Q (It : T); type T is record Val : Integer; end record; type T2 is new T; overriding procedure P (V : T2); end Prim_Test; --- with Text_IO; use Text_IO; package body Prim_Test is procedure P (V : T) is begin null; end P; procedure Q (It : T) is begin Put_Line (Integer'Image (It.Val)); end; overriding procedure P (V : T2) is begin null; end P; end Prim_Test; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-18 Ed Schonberg <schonb...@adacore.com> * sinfo.ads, sinfo.adb (Incomplete_View): New semantic attribute of full type declaration, denotes previous declaration for incomplete view of the type. * sem_ch3.adb (Analyze_Full_Type_Declaration): Set Incomplete_View of declaration if one is present. (Replace_Type): When constructing the signature of an inherited operation, handle properly the case where the operation has a formal whose type is an incomplete view. * sem_util.adb (Collect_Primitive_Operations): Handle properly the case of an operation declared after an incomplete declaration for a type T and before the full declaration of T.
Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 212797) +++ sem_ch3.adb (working copy) @@ -2464,6 +2464,8 @@ Prev := Find_Type_Name (N); -- The full view, if present, now points to the current type + -- If there is an incomplete partial view, set a link to it, to + -- simplify the retrieval of primitive operations of the type. -- Ada 2005 (AI-50217): If the type was previously decorated when -- imported through a LIMITED WITH clause, it appears as incomplete @@ -2472,6 +2474,7 @@ if Ekind (Prev) = E_Incomplete_Type and then Present (Full_View (Prev)) then T := Full_View (Prev); + Set_Incomplete_View (N, Parent (Prev)); else T := Prev; end if; @@ -13537,6 +13540,7 @@ ------------------ procedure Replace_Type (Id, New_Id : Entity_Id) is + Id_Type : constant Entity_Id := Etype (Id); Acc_Type : Entity_Id; Par : constant Node_Id := Parent (Derived_Type); @@ -13547,9 +13551,9 @@ -- be out of the proper scope for Gigi, so we insert a reference to -- it after the derivation. - if Ekind (Etype (Id)) = E_Anonymous_Access_Type then + if Ekind (Id_Type) = E_Anonymous_Access_Type then declare - Desig_Typ : Entity_Id := Designated_Type (Etype (Id)); + Desig_Typ : Entity_Id := Designated_Type (Id_Type); begin if Ekind (Desig_Typ) = E_Record_Type_With_Private @@ -13567,7 +13571,7 @@ or else (Is_Interface (Desig_Typ) and then not Is_Class_Wide_Type (Desig_Typ)) then - Acc_Type := New_Copy (Etype (Id)); + Acc_Type := New_Copy (Id_Type); Set_Etype (Acc_Type, Acc_Type); Set_Scope (Acc_Type, New_Subp); @@ -13599,16 +13603,23 @@ Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); else - Set_Etype (New_Id, Etype (Id)); + Set_Etype (New_Id, Id_Type); end if; end; - elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type) + -- In Ada2012, a formal may have an incomplete type but the type + -- derivation that inherits the primitive follows the full view. + + elsif Base_Type (Id_Type) = Base_Type (Parent_Type) or else - (Ekind (Etype (Id)) = E_Record_Type_With_Private - and then Present (Full_View (Etype (Id))) + (Ekind (Id_Type) = E_Record_Type_With_Private + and then Present (Full_View (Id_Type)) and then - Base_Type (Full_View (Etype (Id))) = Base_Type (Parent_Type)) + Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type)) + or else + (Ada_Version >= Ada_2012 + and then Ekind (Id_Type) = E_Incomplete_Type + and then Full_View (Id_Type) = Parent_Type) then -- Constraint checks on formals are generated during expansion, -- based on the signature of the original subprogram. The bounds Index: sinfo.adb =================================================================== --- sinfo.adb (revision 212719) +++ sinfo.adb (working copy) @@ -1713,6 +1713,14 @@ return Flag11 (N); end Includes_Infinities; + function Incomplete_View + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Full_Type_Declaration); + return Node2 (N); + end Incomplete_View; + function Inherited_Discriminant (N : Node_Id) return Boolean is begin @@ -4879,6 +4887,14 @@ Set_Flag11 (N, Val); end Set_Includes_Infinities; + procedure Set_Incomplete_View + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Full_Type_Declaration); + Set_Node2 (N, Val); -- semantic field, no Parent set + end Set_Incomplete_View; + procedure Set_Inherited_Discriminant (N : Node_Id; Val : Boolean := True) is begin Index: sinfo.ads =================================================================== --- sinfo.ads (revision 212732) +++ sinfo.ads (working copy) @@ -1450,6 +1450,13 @@ -- range is given by the programmer, even if that range is identical to -- the range for Float. + -- Incomplete_View (Node2-Sem) + -- Present in full type declarations that are completions of incomplete + -- type declarations. Denotes the corresponding incomplete type + -- declaration. Used to simplify the retrieval of primitive operations + -- that may be declared between the partial and the full view of an + -- untagged type. + -- Inherited_Discriminant (Flag13-Sem) -- This flag is present in N_Component_Association nodes. It indicates -- that a given component association in an extension aggregate is the @@ -2488,6 +2495,7 @@ -- N_Full_Type_Declaration -- Sloc points to TYPE -- Defining_Identifier (Node1) + -- Incomplete_View (Node2-Sem) -- Discriminant_Specifications (List4) (set to No_List if none) -- Type_Definition (Node3) -- Discr_Check_Funcs_Built (Flag11-Sem) @@ -9120,6 +9128,9 @@ function Includes_Infinities (N : Node_Id) return Boolean; -- Flag11 + function Incomplete_View + (N : Node_Id) return Node_Id; -- Node2 + function Inherited_Discriminant (N : Node_Id) return Boolean; -- Flag13 @@ -10128,6 +10139,9 @@ procedure Set_Includes_Infinities (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Incomplete_View + (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Inherited_Discriminant (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -10801,7 +10815,7 @@ N_Full_Type_Declaration => (1 => True, -- Defining_Identifier (Node1) - 2 => False, -- unused + 2 => False, -- Incomplete_View (Node2-Sem) 3 => True, -- Type_Definition (Node3) 4 => True, -- Discriminant_Specifications (List4) 5 => False), -- unused @@ -12543,6 +12557,7 @@ pragma Inline (Includes_Infinities); pragma Inline (Import_Interface_Present); pragma Inline (In_Present); + pragma Inline (Incomplete_View); pragma Inline (Inherited_Discriminant); pragma Inline (Instance_Spec); pragma Inline (Intval); @@ -12873,6 +12888,7 @@ pragma Inline (Set_Import_Interface_Present); pragma Inline (Set_In_Present); pragma Inline (Set_Includes_Infinities); + pragma Inline (Set_Incomplete_View); pragma Inline (Set_Inherited_Discriminant); pragma Inline (Set_Instance_Spec); pragma Inline (Set_Interface_List); Index: sem_util.adb =================================================================== --- sem_util.adb (revision 212797) +++ sem_util.adb (working copy) @@ -3400,7 +3400,14 @@ Etyp := Designated_Type (Etyp); end if; - return Base_Type (Etyp) = B_Type; + -- In Ada 2012 a primitive operation may have a formal of an + -- incomplete view of the parent type. + + return Base_Type (Etyp) = B_Type + or else + (Ada_Version >= Ada_2012 + and then Ekind (Etyp) = E_Incomplete_Type + and then Full_View (Etyp) = B_Type); end Match; -- Start of processing for Collect_Primitive_Operations @@ -3454,6 +3461,16 @@ and then In_Private_Part (B_Scope) then Id := Next_Entity (T); + + -- In Ada 2012, If the type has an incomplete partial view, there + -- may be primitive operations declared before the full view, so + -- we need to start scanning from the incomplete view. + + elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration + and then Present (Incomplete_View (Parent (B_Type))) + then + Id := Defining_Entity (Next (Incomplete_View (Parent (B_Type)))); + else Id := Next_Entity (B_Type); end if;