From b6acf969931d71f950869689dd56d2f7f5e63818 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20Creuse?= Date: Mon, 31 Jul 2023 15:42:51 +0200 Subject: [PATCH 1/2] TGen: Factorize common translation initialization code --- src/tgen/tgen-types-translation.adb | 447 +++++++------------ src/tgen/tgen_rts/tgen-types-constraints.adb | 174 +++----- 2 files changed, 229 insertions(+), 392 deletions(-) diff --git a/src/tgen/tgen-types-translation.adb b/src/tgen/tgen-types-translation.adb index 65e73535..3321a81e 100644 --- a/src/tgen/tgen-types-translation.adb +++ b/src/tgen/tgen-types-translation.adb @@ -84,43 +84,30 @@ package body TGen.Types.Translation is -- flaged as non static. function Translate_Int_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result with + (Decl : Base_Type_Decl) return Translation_Result with Pre => Decl.P_Is_Int_Type; function Translate_Enum_Decl (Decl : Base_Type_Decl; - Root_Enum_Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) + Root_Enum_Decl : Base_Type_Decl) return Translation_Result with - Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Enum_Type; + Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Enum_Type; function Translate_Char_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) - return Translation_Result with + (Decl : Base_Type_Decl) return Translation_Result with Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Enum_Type; function Translate_Float_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result with - Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Float_Type; + (Decl : Base_Type_Decl) return Translation_Result with + Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Float_Type; function Translate_Ordinary_Fixed_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result with - Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Fixed_Point; + (Decl : Base_Type_Decl) return Translation_Result with + Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Fixed_Point; function Translate_Decimal_Fixed_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result with - Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Fixed_Point; + (Decl : Base_Type_Decl) return Translation_Result with + Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Fixed_Point; procedure Translate_Float_Range (Decl : Base_Type_Decl; @@ -140,10 +127,8 @@ package body TGen.Types.Translation is -- Long_Float'First .. Long_Float'Last function Translate_Array_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result with - Pre => Decl.P_Root_Type.P_Full_View.P_Is_Array_Type; + (Decl : Base_Type_Decl) return Translation_Result with + Pre => Decl.P_Root_Type.P_Full_View.P_Is_Array_Type; function Translate_Component_Decl_List (Decl_List : Ada_Node_List; @@ -177,10 +162,8 @@ package body TGen.Types.Translation is -- in Decl_Or_Constraint. function Translate_Record_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result with - Pre => Decl.P_Root_Type.P_Full_View.P_Is_Record_Type; + (Decl : Base_Type_Decl) return Translation_Result with + Pre => Decl.P_Root_Type.P_Full_View.P_Is_Record_Type; procedure Apply_Record_Subtype_Decl (Decl : Subtype_Indication; @@ -345,9 +328,7 @@ package body TGen.Types.Translation is ------------------------ function Translate_Int_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result + (Decl : Base_Type_Decl) return Translation_Result is Rang : constant Discrete_Range := Decl.P_Discrete_Range; @@ -360,9 +341,6 @@ package body TGen.Types.Translation is -- non static. To do so we have no choice but to try to evaluate the -- bounds, and see if we get an exception. - Ada_Type_Name : constant Ada_Qualified_Name := - Convert_Qualified_Name (Type_Name.P_Fully_Qualified_Name_Array); - Is_Mode_Typ : constant Boolean := Decl.P_Root_Type.P_Full_View.As_Concrete_Type_Decl.F_Type_Def.Kind in Ada_Mod_Int_Type_Def; @@ -389,18 +367,16 @@ package body TGen.Types.Translation is if Is_Actually_Static then return Res : Translation_Result (Success => True) do Res.Res.Set - (Mod_Int_Typ'(Is_Static => True, - Name => Ada_Type_Name, - Last_Comp_Unit_Idx => Cmp_Idx, - Mod_Value => Max)); + (Mod_Int_Typ'(Is_Static => True, + Mod_Value => Max, + others => <>)); end return; else return Res : Translation_Result (Success => True) do Res.Res.Set (Mod_Int_Typ' - (Is_Static => False, - Name => Ada_Type_Name, - Last_Comp_Unit_Idx => Cmp_Idx)); + (Is_Static => False, + others => <>)); end return; end if; end if; @@ -423,18 +399,16 @@ package body TGen.Types.Translation is return Res : Translation_Result (Success => True) do Res.Res.Set (Signed_Int_Typ'(Is_Static => True, - Name => Ada_Type_Name, - Last_Comp_Unit_Idx => Cmp_Idx, Range_Value => - (Min => Min, Max => Max))); + (Min => Min, Max => Max), + others => <>)); end return; else return Res : Translation_Result (Success => True) do Res.Res.Set (Signed_Int_Typ' - (Is_Static => False, - Name => Ada_Type_Name, - Last_Comp_Unit_Idx => Cmp_Idx)); + (Is_Static => False, + others => <>)); end return; end if; end Translate_Int_Decl; @@ -444,10 +418,7 @@ package body TGen.Types.Translation is ------------------------- function Translate_Char_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) - return Translation_Result + (Decl : Base_Type_Decl) return Translation_Result is Rang : constant Discrete_Range := Decl.P_Discrete_Range; begin @@ -455,12 +426,9 @@ package body TGen.Types.Translation is if Is_Null (Low_Bound (Rang)) then return Res : Translation_Result (Success => True) do Res.Res.Set (Char_Typ' - (Is_Static => True, - Has_Range => False, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx)); + (Is_Static => True, + Has_Range => False, + others => <>)); end return; else declare @@ -485,27 +453,21 @@ package body TGen.Types.Translation is if LB.Kind = Static and then HB.Kind = Static then return Res : Translation_Result (Success => True) do Res.Res.Set - (Char_Typ'(Is_Static => True, - Has_Range => True, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx, - Range_Value => - (Low_Bound => LB, High_Bound => HB))); + (Char_Typ'(Is_Static => True, + Has_Range => True, + Range_Value => + (Low_Bound => LB, High_Bound => HB), + others => <>)); end return; else return Res : Translation_Result (Success => True) do Res.Res.Set - (Char_Typ'(Is_Static => False, - Has_Range => True, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx, - Range_Value => - (Low_Bound => LB, High_Bound => HB))); + (Char_Typ'(Is_Static => False, + Has_Range => True, + Range_Value => + (Low_Bound => LB, High_Bound => HB), + others => <>)); end return; end if; @@ -519,10 +481,7 @@ package body TGen.Types.Translation is function Translate_Enum_Decl (Decl : Base_Type_Decl; - Root_Enum_Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) - return Translation_Result + Root_Enum_Decl : Base_Type_Decl) return Translation_Result is package Long_Long_Conversion is new Big_Int.Signed_Conversions (Int => Long_Long_Integer); @@ -564,12 +523,9 @@ package body TGen.Types.Translation is return Res : Translation_Result (Success => True) do Res.Res.Set - (Other_Enum_Typ'(Is_Static => True, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx, - Literals => Enum_Lits)); + (Other_Enum_Typ'(Is_Static => True, + Literals => Enum_Lits, + others => <>)); end return; end Translate_Enum_Decl; @@ -578,9 +534,7 @@ package body TGen.Types.Translation is -------------------------- function Translate_Float_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result + (Decl : Base_Type_Decl) return Translation_Result is procedure Find_Digits @@ -663,23 +617,17 @@ package body TGen.Types.Translation is Translate_Float_Range (Decl, Has_Range, Min, Max); if Has_Range then Res.Res.Set - (Float_Typ'(Is_Static => True, - Has_Range => True, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx, - Digits_Value => Digits_Value, - Range_Value => (Min => Min, Max => Max))); + (Float_Typ'(Is_Static => True, + Has_Range => True, + Digits_Value => Digits_Value, + Range_Value => (Min => Min, Max => Max), + others => <>)); else Res.Res.Set - (Float_Typ'(Is_Static => True, - Has_Range => False, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx, - Digits_Value => Digits_Value)); + (Float_Typ'(Is_Static => True, + Has_Range => False, + Digits_Value => Digits_Value, + others => <>)); end if; return Res; exception @@ -690,12 +638,9 @@ package body TGen.Types.Translation is Decl.Image & " : " & Ada.Exceptions.Exception_Message (Exc)); end if; Res.Res.Set - (Float_Typ'(Is_Static => False, - Has_Range => False, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx)); + (Float_Typ'(Is_Static => False, + Has_Range => False, + others => <>)); return Res; end Translate_Float_Decl; @@ -704,9 +649,7 @@ package body TGen.Types.Translation is ----------------------------------- function Translate_Ordinary_Fixed_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result + (Decl : Base_Type_Decl) return Translation_Result is Min, Max : Big_Real; Delta_Value : Big_Real; @@ -815,14 +758,10 @@ package body TGen.Types.Translation is Find_Delta (Decl, Delta_Value); return Res : Translation_Result (Success => True) do Res.Res.Set - (Ordinary_Fixed_Typ'(Is_Static => True, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx, - Delta_Value => Delta_Value, - Range_Value => - (Min => Min, Max => Max))); + (Ordinary_Fixed_Typ'(Is_Static => True, + Delta_Value => Delta_Value, + Range_Value => (Min => Min, Max => Max), + others => <>)); end return; exception when Exc : Translation_Error => @@ -837,11 +776,8 @@ package body TGen.Types.Translation is return Res : Translation_Result (Success => True) do Res.Res.Set (Ordinary_Fixed_Typ' - (Is_Static => False, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx)); + (Is_Static => False, + others => <>)); end return; end Translate_Ordinary_Fixed_Decl; @@ -850,9 +786,7 @@ package body TGen.Types.Translation is ---------------------------------- function Translate_Decimal_Fixed_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result + (Decl : Base_Type_Decl) return Translation_Result is Delta_Val : Big_Real; Digits_Val : Natural; @@ -948,28 +882,22 @@ package body TGen.Types.Translation is if Has_Range then return Res : Translation_Result (Success => True) do Res.Res.Set - (Decimal_Fixed_Typ'(Is_Static => True, - Has_Range => True, - Digits_Value => Digits_Val, - Delta_Value => Delta_Val, - Range_Value => + (Decimal_Fixed_Typ'(Is_Static => True, + Has_Range => True, + Digits_Value => Digits_Val, + Delta_Value => Delta_Val, + Range_Value => (Min => Range_Min, Max => Range_Max), - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx)); + others => <>)); end return; else return Res : Translation_Result (Success => True) do Res.Res.Set - (Decimal_Fixed_Typ'(Is_Static => True, - Has_Range => False, - Digits_Value => Digits_Val, - Delta_Value => Delta_Val, - Name => - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array), - Last_Comp_Unit_Idx => Cmp_Idx)); + (Decimal_Fixed_Typ'(Is_Static => True, + Has_Range => False, + Digits_Value => Digits_Val, + Delta_Value => Delta_Val, + others => <>)); end return; end if; end Translate_Decimal_Fixed_Decl; @@ -1249,9 +1177,7 @@ package body TGen.Types.Translation is -------------------------- function Translate_Array_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result + (Decl : Base_Type_Decl) return Translation_Result is function Translate_Constrained (Decl : Base_Type_Decl) return Translation_Result; @@ -1301,9 +1227,9 @@ package body TGen.Types.Translation is begin if not Component_Typ.Success then return (Success => False, - Diagnostics => "Failed to translate component type of" - & " array decl : " - & Component_Typ.Diagnostics); + Diagnostics => "Failed to translate component type of" + & " array decl : " + & Component_Typ.Diagnostics); end if; Res_Typ.Component_Type := Component_Typ.Res; @@ -1350,7 +1276,7 @@ package body TGen.Types.Translation is end; if Has_Constraints then - -- We should only encouter either a Bin Op (A .. B) or a + -- We should only encounter either a Bin Op (A .. B) or a -- range attribute reference according to RM 3.5 (2). begin if Kind (Range_Exp) in Ada_Bin_Op_Range then @@ -1439,10 +1365,6 @@ package body TGen.Types.Translation is Current_Index := Current_Index + 1; end loop; - Res_Typ.Name := - Convert_Qualified_Name (Type_Name.P_Fully_Qualified_Name_Array); - Res_Typ.Last_Comp_Unit_Idx := Cmp_Idx; - -- For constrained arrays, even if some index type is not -- statically known, as long as the matching index constraints -- are we should be able to generate values for this type. @@ -1466,7 +1388,7 @@ package body TGen.Types.Translation is ----------------------------- function Translate_Unconstrained - (Def : Array_Type_Def) return Translation_Result + (Def : Array_Type_Def) return Translation_Result is Indices_List : constant Unconstrained_Array_Index_List := Def.F_Indices.As_Unconstrained_Array_Indices.F_Types; @@ -1506,11 +1428,6 @@ package body TGen.Types.Translation is end if; end; end loop; - - Res_Typ.Name := - Convert_Qualified_Name (Type_Name.P_Fully_Qualified_Name_Array); - Res_Typ.Last_Comp_Unit_Idx := Cmp_Idx; - Res_Typ.Static_Gen := Res_Typ.Component_Type.Get.Supports_Static_Gen and then (for all Index_Ref of Res_Typ.Index_Types @@ -1535,8 +1452,7 @@ package body TGen.Types.Translation is when Ada_Subtype_Decl_Range => if Is_Null (Decl.As_Subtype_Decl.F_Subtype.F_Constraint) then return Translate_Array_Decl - (Decl.As_Subtype_Decl.F_Subtype.P_Designated_Type_Decl, - Type_Name, Cmp_Idx); + (Decl.As_Subtype_Decl.F_Subtype.P_Designated_Type_Decl); else return Translate_Constrained (Decl); end if; @@ -1551,9 +1467,7 @@ package body TGen.Types.Translation is then return Translate_Array_Decl (Decl.As_Type_Decl.F_Type_Def.As_Derived_Type_Def - .F_Subtype_Indication.P_Designated_Type_Decl, - Type_Name, - Cmp_Idx); + .F_Subtype_Indication.P_Designated_Type_Decl); else return Translate_Constrained (Decl); end if; @@ -2204,7 +2118,8 @@ package body TGen.Types.Translation is (Discriminants.Find (Res.Discr_Name)) then raise Translation_Error with - "Unknown discriminant name"; + "Unknown discriminant name " + & To_String (Res.Discr_Name); end if; -- This is not really accurate for enum types if the @@ -2249,9 +2164,7 @@ package body TGen.Types.Translation is --------------------------- function Translate_Record_Decl - (Decl : Base_Type_Decl; - Type_Name : Defining_Name; - Cmp_Idx : Positive) return Translation_Result + (Decl : Base_Type_Decl) return Translation_Result is procedure Apply_Constraints @@ -2342,11 +2255,6 @@ package body TGen.Types.Translation is (Comp_List, Trans_Res.Component_Types); if Failure_Reason = Null_Unbounded_String then - Trans_Res.Name := - Convert_Qualified_Name - (Type_Name.P_Fully_Qualified_Name_Array); - Trans_Res.Last_Comp_Unit_Idx := Cmp_Idx; - Trans_Res.Static_Gen := (for all Comp_Ref of Trans_Res.Component_Types => Comp_Ref.Get.Supports_Static_Gen); @@ -2432,10 +2340,6 @@ package body TGen.Types.Translation is (Decl, Actual_Decl.As_Base_Type_Decl, Trans_Res); end if; - Trans_Res.Name := - Convert_Qualified_Name (Type_Name.P_Fully_Qualified_Name_Array); - Trans_Res.Last_Comp_Unit_Idx := Cmp_Idx; - Trans_Res.Static_Gen := (for all Comp_Ref of Trans_Res.Component_Types => Comp_Ref.Get.Supports_Static_Gen) @@ -2469,10 +2373,9 @@ package body TGen.Types.Translation is return Res : Translation_Result (Success => True) do Res.Res.Set (Nondiscriminated_Record_Typ' - (Name => Trans_Res.Name, - Last_Comp_Unit_Idx => Trans_Res.Last_Comp_Unit_Idx, - Component_Types => Trans_Res.Component_Types, - Static_Gen => Trans_Res.Static_Gen)); + (Component_Types => Trans_Res.Component_Types, + Static_Gen => Trans_Res.Static_Gen, + others => <>)); end return; else @@ -2486,9 +2389,6 @@ package body TGen.Types.Translation is Rec_Typ.Discriminant_Types.Move (Trans_Res.Discriminant_Types); Rec_Typ.Variant := Trans_Res.Variant; - Rec_Typ.Name := Trans_Res.Name; - Rec_Typ.Last_Comp_Unit_Idx := - Trans_Res.Last_Comp_Unit_Idx; Rec_Typ.Mutable := Trans_Res.Mutable; Rec_Typ.Static_Gen := Trans_Res.Static_Gen; Res.Res.Set (Rec_Typ); @@ -2979,6 +2879,8 @@ package body TGen.Types.Translation is -- First part of the declaration. Used to determine whether the type we -- are translating is private or not. + Specialized_Res : Translation_Result (Success => True); + begin Verbose_Diag := Verbose; Is_Static := Is_Static @@ -2994,17 +2896,11 @@ package body TGen.Types.Translation is -- declarations or anonymous access types, both of which we don't -- intend to support. - return Res : Translation_Result (Success => True) do - Res.Res.Set - (Unsupported_Typ' - (Name => - TGen.Strings.Ada_Identifier_Vectors.To_Vector - (To_Unbounded_String (N.Image), 1), - Last_Comp_Unit_Idx => 1, - Reason => - To_Unbounded_String - ("Anonymous array or access type unsupported"))); - end return; + Specialized_Res.Res.Set + (Unsupported_Typ' + (Reason => To_Unbounded_String + ("Anonymous array or access type unsupported"), + others => <>)); elsif Text.Image (Type_Name.P_Fully_Qualified_Name) = "System.Address" then @@ -3012,60 +2908,39 @@ package body TGen.Types.Translation is -- modular integer but for which we do not want to generate any -- values. - return Res : Translation_Result (Success => True) do - Res.Res.Set (Unsupported_Typ' - (Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Reason => - To_Unbounded_String - ("System.Address unsupported"))); - end return; + Specialized_Res.Res.Set (Unsupported_Typ' + (Reason => To_Unbounded_String ("System.Address unsupported"), + others => <>)); elsif First_Part.As_Base_Type_Decl.P_Is_Private and then Positive (FQN.Length) - Comp_Unit_Idx > 1 then -- We are dealing with a private type declared in a nested package, -- consider this as unsupported. - return Res : Translation_Result (Success => True) do - Res.Res.Set (Unsupported_Typ' - (Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Reason => - To_Unbounded_String - ("Private types declared in nested package are not" - & " supported"))); - end return; + Specialized_Res.Res.Set (Unsupported_Typ' + (Reason => + To_Unbounded_String + ("Private types declared in nested package are not" + & " supported"), + others => <>)); elsif Root_Type.P_Is_Formal then - return Res : Translation_Result (Success => True) do - Res.Res.Set (Formal_Typ' - (Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Reason => - To_Unbounded_String - ("Generic formal types are unsupported"))); - end return; + Specialized_Res.Res.Set (Formal_Typ' + (Reason => + To_Unbounded_String ("Generic formal types are unsupported"), + others => <>)); elsif Root_Type.P_Is_Int_Type then - return Translate_Int_Decl (N, Type_Name, Comp_Unit_Idx); + Specialized_Res := Translate_Int_Decl (N); elsif P_Is_Derived_Type (Node => N, Other_Type => N.P_Bool_Type.As_Base_Type_Decl) then - return Res : Translation_Result (Success => True) do - Res.Res.Set (Bool_Typ' - (Is_Static => True, - Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); - end return; + Specialized_Res.Res.Set (Bool_Typ'(Is_Static => True, others => <>)); elsif Root_Type.P_Is_Enum_Type then if not Is_Static then - return Res : Translation_Result (Success => True) do - Res.Res.Set (Other_Enum_Typ' - (Is_Static => False, - Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); - end return; + Specialized_Res.Res.Set (Other_Enum_Typ' + (Is_Static => False, others => <>)); end if; declare Root_Type_Name : constant String := @@ -3075,25 +2950,21 @@ package body TGen.Types.Translation is or else Root_Type_Name = "standard.wide_character" or else Root_Type_Name = "standard.wide_wide_character" then - return Translate_Char_Decl (N, Type_Name, Comp_Unit_Idx); + Specialized_Res := Translate_Char_Decl (N); else - return Translate_Enum_Decl - (N, Root_Type, Type_Name, Comp_Unit_Idx); + Specialized_Res := Translate_Enum_Decl (N, Root_Type); end if; end; elsif Root_Type.P_Is_Float_Type then if Is_Static then - return Translate_Float_Decl (N, Type_Name, Comp_Unit_Idx); + Specialized_Res := Translate_Float_Decl (N); else - return Res : Translation_Result (Success => True) do - Res.Res.Set - (Float_Typ' - (Is_Static => False, - Has_Range => False, - Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); - end return; + Specialized_Res.Res.Set + (Float_Typ' + (Is_Static => False, + Has_Range => False, + others => <>)); end if; elsif Root_Type.P_Is_Fixed_Point then @@ -3101,67 +2972,59 @@ package body TGen.Types.Translation is Ada_Ordinary_Fixed_Point_Def_Range then if Is_Static then - return Translate_Ordinary_Fixed_Decl - (N, Type_Name, Comp_Unit_Idx); + Specialized_Res := Translate_Ordinary_Fixed_Decl (N); else - return Res : Translation_Result (Success => True) do - Res.Res.Set - (Ordinary_Fixed_Typ' - (Is_Static => False, - Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); - end return; + Specialized_Res.Res.Set + (Ordinary_Fixed_Typ' + (Is_Static => False, + others => <>)); end if; else if Is_Static then - return Translate_Decimal_Fixed_Decl - (N, Type_Name, Comp_Unit_Idx); + Specialized_Res := Translate_Decimal_Fixed_Decl (N); else - return Res : Translation_Result (Success => True) do - Res.Res.Set - (Decimal_Fixed_Typ' - (Is_Static => False, - Has_Range => False, - Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); - end return; + Specialized_Res.Res.Set + (Decimal_Fixed_Typ' + (Is_Static => False, + Has_Range => False, + others => <>)); end if; end if; elsif Root_Type.P_Is_Array_Type then - return Translate_Array_Decl (N, Type_Name, Comp_Unit_Idx); + Specialized_Res := Translate_Array_Decl (N); elsif Root_Type.P_Is_Record_Type then if Root_Type.P_Is_Tagged_Type then - return Res : Translation_Result (Success => True) do - Res.Res.Set - (Unsupported_Typ' - (Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Reason => - To_Unbounded_String ("tagged types not supported"))); - end return; + Specialized_Res.Res.Set + (Unsupported_Typ' + (Reason => To_Unbounded_String ("tagged types not supported"), + others => <>)); else - return Translate_Record_Decl (N, Type_Name, Comp_Unit_Idx); + Specialized_Res := Translate_Record_Decl (N); end if; elsif Root_Type.P_Is_Access_Type then - return Res : Translation_Result (Success => True) do - Res.Res.Set - (Access_Typ' - (Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Reason => - To_Unbounded_String ("Access types are not supported"))); - end return; + Specialized_Res.Res.Set + (Access_Typ' + (Reason => + To_Unbounded_String ("Access types are not supported"), + others => <>)); + else + Specialized_Res.Res.Set + (Unsupported_Typ' + (Reason => To_Unbounded_String ("Unknown type kind"), + others => <>)); end if; - return Res : Translation_Result (Success => True) do - Res.Res.Set (Unsupported_Typ' - (Name => FQN, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Reason => To_Unbounded_String ("Unknown type kind"))); - end return; + -- Fill the common bits if we got a successful translation + + if Specialized_Res.Success then + Specialized_Res.Res.Get.Name := FQN; + Specialized_Res.Res.Get.Last_Comp_Unit_Idx := Comp_Unit_Idx; + end if; + + return Specialized_Res; exception when Exc : Property_Error => diff --git a/src/tgen/tgen_rts/tgen-types-constraints.adb b/src/tgen/tgen_rts/tgen-types-constraints.adb index 9c6458fb..6ab92fdd 100644 --- a/src/tgen/tgen_rts/tgen-types-constraints.adb +++ b/src/tgen/tgen_rts/tgen-types-constraints.adb @@ -120,10 +120,6 @@ package body TGen.Types.Constraints is ------------------ function As_Named_Typ (Self : Anonymous_Typ) return SP.Ref is - Name : constant Ada_Qualified_Name := - Self.Named_Ancestor.Get.Name; - Comp_Unit_Idx : constant Positive := Self.Last_Comp_Unit_Idx; - Res : SP.Ref; Cst : Constraint'Class renames Self.Subtype_Constraints.all; begin @@ -131,52 +127,46 @@ package body TGen.Types.Constraints is when Signed_Int_Kind => if Cst.Static then Res.Set (Signed_Int_Typ' - (Is_Static => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Range_Value => + (Is_Static => True, + Range_Value => (Min => Discrete_Range_Constraint (Cst).Low_Bound.Int_Val, Max => Discrete_Range_Constraint - (Cst).High_Bound.Int_Val))); + (Cst).High_Bound.Int_Val), + others => <>)); else Res.Set (Signed_Int_Typ' - (Is_Static => False, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); + (Is_Static => False, + others => <>)); end if; when Mod_Int_Kind => if Cst.Static then Res.Set (Mod_Int_Typ' - (Is_Static => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Mod_Value => + (Is_Static => True, + Mod_Value => Discrete_Range_Constraint - (Cst).High_Bound.Int_Val)); + (Cst).High_Bound.Int_Val, + others => <>)); else Res.Set (Mod_Int_Typ' - (Is_Static => False, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); + (Is_Static => False, + others => <>)); end if; when Char_Kind => if Cst.Static then Res.Set - (Char_Typ'(Is_Static => True, - Has_Range => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Range_Value => - Discrete_Range_Constraint (Cst))); + (Char_Typ'(Is_Static => True, + Has_Range => True, + Range_Value => + Discrete_Range_Constraint (Cst), + others => <>)); else Res.Set - (Char_Typ'(Is_Static => False, - Has_Range => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Range_Value => - Discrete_Range_Constraint (Cst))); + (Char_Typ'(Is_Static => False, + Has_Range => True, + Range_Value => + Discrete_Range_Constraint (Cst), + others => <>)); end if; when Enum_Kind => if Cst.Static then @@ -199,68 +189,60 @@ package body TGen.Types.Constraints is (Key (Old_Enum_Cur), Element (Old_Enum_Cur)); end if; end loop; - Res.Set (Other_Enum_Typ'(Is_Static => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Literals => New_Lit_Set)); + Res.Set (Other_Enum_Typ'(Is_Static => True, + Literals => New_Lit_Set, + others => <>)); end; else - Res.Set (Other_Enum_Typ' - (Is_Static => False, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); + Res.Set (Other_Enum_Typ'(Is_Static => False, others => <>)); end if; when Float_Kind => if Cst.Static then if Cst in Real_Range_Constraint then Res.Set (Float_Typ' - (Is_Static => True, - Has_Range => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Digits_Value => + (Is_Static => True, + Has_Range => True, + Digits_Value => As_Float_Typ (Self.Named_Ancestor).Digits_Value, - Range_Value => + Range_Value => (Min => Real_Range_Constraint (Cst) .Low_Bound.Real_Val, Max => Real_Range_Constraint (Cst) - .High_Bound.Real_Val))); + .High_Bound.Real_Val), + others => <>)); else if Digits_Constraint (Cst).Has_Range then Res.Set (Float_Typ' - (Is_Static => True, - Has_Range => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Digits_Value => Big_Int.To_Integer + (Is_Static => True, + Has_Range => True, + Digits_Value => Big_Int.To_Integer (Digits_Constraint (Cst).Digits_Value.Int_Val), - Range_Value => + Range_Value => (Min => Digits_Constraint (Cst).Range_Value .Low_Bound.Real_Val, Max => Digits_Constraint (Cst).Range_Value - .High_Bound.Real_Val))); + .High_Bound.Real_Val), + others => <>)); else if As_Float_Typ (Self.Named_Ancestor).Is_Static and then As_Float_Typ (Self.Named_Ancestor).Has_Range then Res.Set (Float_Typ' - (Is_Static => True, - Has_Range => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Digits_Value => Big_Int.To_Integer + (Is_Static => True, + Has_Range => True, + Digits_Value => Big_Int.To_Integer (Digits_Constraint (Cst).Digits_Value.Int_Val), - Range_Value => - As_Float_Typ (Self.Named_Ancestor).Range_Value)); + Range_Value => + As_Float_Typ (Self.Named_Ancestor).Range_Value, + others => <>)); elsif As_Float_Typ (Self.Named_Ancestor).Is_Static then Res.Set (Float_Typ' - (Is_Static => True, - Has_Range => False, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Digits_Value => Big_Int.To_Integer - (Digits_Constraint (Cst).Digits_Value.Int_Val))); + (Is_Static => True, + Has_Range => False, + Digits_Value => Big_Int.To_Integer + (Digits_Constraint (Cst).Digits_Value.Int_Val), + others => <>)); else Res := Self.Named_Ancestor; end if; @@ -268,10 +250,7 @@ package body TGen.Types.Constraints is end if; else Res.Set (Float_Typ' - (Is_Static => False, - Has_Range => False, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); + (Is_Static => False, Has_Range => False, others => <>)); end if; when Fixed_Kind => if Cst.Static @@ -279,64 +258,59 @@ package body TGen.Types.Constraints is and then As_Ordinary_Fixed_Typ (Self.Named_Ancestor).Is_Static then Res.Set (Ordinary_Fixed_Typ' - (Is_Static => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Delta_Value => + (Is_Static => True, + Delta_Value => As_Ordinary_Fixed_Typ (Self.Named_Ancestor).Delta_Value, - Range_Value => + Range_Value => (Min => Real_Range_Constraint (Cst) .Low_Bound.Real_Val, Max => Real_Range_Constraint (Cst) - .High_Bound.Real_Val))); + .High_Bound.Real_Val), + others => <>)); else - Res.Set (Ordinary_Fixed_Typ' - (Is_Static => False, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx)); + Res.Set + (Ordinary_Fixed_Typ'(Is_Static => False, others => <>)); end if; when Array_Typ_Range => Res.Set (Constrained_Array_Typ' (Num_Dims => As_Unconstrained_Array_Typ (Self.Named_Ancestor).Num_Dims, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Static_Gen => + Static_Gen => (As_Unconstrained_Array_Typ (Self.Named_Ancestor).Static_Gen and then Self.Subtype_Constraints.Static), - Component_Type => + Component_Type => As_Unconstrained_Array_Typ (Self.Named_Ancestor).Component_Type, - Index_Types => + Index_Types => As_Unconstrained_Array_Typ (Self.Named_Ancestor).Index_Types, - Index_Constraints => - Index_Constraints (Cst).Constraint_Array)); + Index_Constraints => + Index_Constraints (Cst).Constraint_Array, + others => <>)); when Disc_Record_Kind => Res.Set (Discriminated_Record_Typ' - (Constrained => True, - Name => Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Component_Types => + (Constrained => True, + Component_Types => As_Discriminated_Record_Typ (Self.Named_Ancestor) .Component_Types.Copy, - Mutable => + Mutable => As_Discriminated_Record_Typ (Self.Named_Ancestor).Mutable, - Discriminant_Types => + Discriminant_Types => As_Discriminated_Record_Typ (Self.Named_Ancestor) .Discriminant_Types.Copy, - Variant => Clone + Variant => Clone (As_Discriminated_Record_Typ (Self.Named_Ancestor).Variant), Discriminant_Constraint => Discriminant_Constraints (Cst).Constraint_Map.Copy, - Static_Gen => + Static_Gen => As_Record_Typ (Self.Named_Ancestor).Static_Gen - and then Self.Subtype_Constraints.Static)); + and then Self.Subtype_Constraints.Static, + others => <>)); when others => Res.Set (Unsupported_Typ' - (Name => Self.Named_Ancestor.Get.Name, - Last_Comp_Unit_Idx => Comp_Unit_Idx, - Reason => +"Unknown named ancestor type kind")); + (Reason => +"Unknown named ancestor type kind", others => <>)); end case; + Res.Get.Name := Self.Named_Ancestor.Get.Name; + Res.Get.Last_Comp_Unit_Idx := Self.Last_Comp_Unit_Idx; return Res; end As_Named_Typ; From ab4eb27729d147ec25b570d46cd699fa1797ace8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20Creuse?= Date: Tue, 1 Aug 2023 12:08:16 +0200 Subject: [PATCH 2/2] TGen: Generated helpers for private types as private subprograms Types only declared in the private part of a package can only be referenced in that private part, or in the private part of its child packages. The helper subprograms generated in the support library were all generated in the public part, which violated visibility rules. This change moves to the body (which is part of the private part) as many implementation details as possible for the value library, and ensures marshallers are generated in the private part if needed. --- .../json_templates/composite_base_spec.tmplt | 2 + .../json_templates/header_spec.tmplt | 2 + .../json_templates/header_wrappers_spec.tmplt | 2 + .../json_templates/in_out_spec.tmplt | 2 + .../json_templates/scalar_base_spec.tmplt | 2 + .../composite_base_spec.tmplt | 7 + .../default_header_spec.tmplt | 2 + .../marshalling_templates/header_spec.tmplt | 7 + .../header_wrappers_spec.tmplt | 2 + .../marshalling_templates/in_out_spec.tmplt | 2 + .../scalar_base_spec.tmplt | 2 + ...yp_spec.tmplt => anonymous_typ_decl.tmplt} | 6 +- ...ay_typ_spec.tmplt => array_typ_decl.tmplt} | 5 +- ...raint_spec.tmplt => constraint_decl.tmplt} | 4 +- ...typ_spec.tmplt => instance_typ_decl.tmplt} | 7 +- ...d_typ_spec.tmplt => record_typ_decl.tmplt} | 7 +- .../scalar_spec.tmplt | 19 -- ...r_typ_spec.tmplt => scalar_typ_decl.tmplt} | 6 +- ...e_spec.tmplt => variant_choice_decl.tmplt} | 4 +- ...{variant_spec.tmplt => variant_decl.tmplt} | 4 + src/tgen/tgen-gen_strategies_utils.adb | 1 + src/tgen/tgen-libgen.adb | 59 +++-- .../tgen-marshalling-binary_marshallers.adb | 78 +++--- .../tgen-marshalling-binary_marshallers.ads | 8 + .../tgen-marshalling-json_marshallers.adb | 87 ++++--- .../tgen-marshalling-json_marshallers.ads | 16 ++ src/tgen/tgen-marshalling.adb | 150 ++++++------ src/tgen/tgen-marshalling.ads | 7 + src/tgen/tgen-templates.ads | 32 +-- src/tgen/tgen-type_representation.adb | 223 ++++++++++-------- src/tgen/tgen-types-translation.adb | 40 ++++ src/tgen/tgen_rts/tgen-types-constraints.adb | 1 + src/tgen/tgen_rts/tgen-types-record_types.adb | 3 +- src/tgen/tgen_rts/tgen-types.ads | 6 + .../test/marshalling_full_private/pkg.adb | 13 + .../test/marshalling_full_private/pkg.ads | 20 ++ .../test/marshalling_full_private/prj.gpr | 3 + .../test/marshalling_full_private/test.out | 13 + .../test/marshalling_full_private/test.sh | 3 + .../test/marshalling_full_private/test.yaml | 8 + .../test/marshalling_priv_nested/test/foo.ads | 1 + .../example_introspection.adb | 78 +++--- 42 files changed, 610 insertions(+), 334 deletions(-) rename src/tgen/templates/type_representation_templates/{anonymous_typ_spec.tmplt => anonymous_typ_decl.tmplt} (69%) rename src/tgen/templates/type_representation_templates/{array_typ_spec.tmplt => array_typ_decl.tmplt} (80%) rename src/tgen/templates/type_representation_templates/{constraint_spec.tmplt => constraint_decl.tmplt} (95%) rename src/tgen/templates/type_representation_templates/{instance_typ_spec.tmplt => instance_typ_decl.tmplt} (71%) rename src/tgen/templates/type_representation_templates/{record_typ_spec.tmplt => record_typ_decl.tmplt} (85%) delete mode 100644 src/tgen/templates/type_representation_templates/scalar_spec.tmplt rename src/tgen/templates/type_representation_templates/{scalar_typ_spec.tmplt => scalar_typ_decl.tmplt} (95%) rename src/tgen/templates/type_representation_templates/{variant_choice_spec.tmplt => variant_choice_decl.tmplt} (68%) rename src/tgen/templates/type_representation_templates/{variant_spec.tmplt => variant_decl.tmplt} (65%) create mode 100644 testsuite/tests/test/marshalling_full_private/pkg.adb create mode 100644 testsuite/tests/test/marshalling_full_private/pkg.ads create mode 100644 testsuite/tests/test/marshalling_full_private/prj.gpr create mode 100644 testsuite/tests/test/marshalling_full_private/test.out create mode 100644 testsuite/tests/test/marshalling_full_private/test.sh create mode 100644 testsuite/tests/test/marshalling_full_private/test.yaml diff --git a/src/tgen/templates/json_templates/composite_base_spec.tmplt b/src/tgen/templates/json_templates/composite_base_spec.tmplt index dd5f38b6..6c8436a5 100644 --- a/src/tgen/templates/json_templates/composite_base_spec.tmplt +++ b/src/tgen/templates/json_templates/composite_base_spec.tmplt @@ -5,6 +5,7 @@ @@-- @_TY_NAME_@ Name of the current type. @@-- @@INCLUDE@@ util.tmplt +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ -- Base operations for @_TY_NAME_@ procedure @_TY_PREFIX_@_Write @@ -14,3 +15,4 @@ procedure @_TY_PREFIX_@_Read (@_GLOBAL_PREFIX_@_JSON : TGen.JSON.JSON_Value; @_GLOBAL_PREFIX_@_V : out @_TY_NAME_@); +@@END_IF@@ diff --git a/src/tgen/templates/json_templates/header_spec.tmplt b/src/tgen/templates/json_templates/header_spec.tmplt index 75372573..84bd7ed2 100644 --- a/src/tgen/templates/json_templates/header_spec.tmplt +++ b/src/tgen/templates/json_templates/header_spec.tmplt @@ -9,6 +9,7 @@ @@-- @_COMP_TYP_@ Index types for arrays, and types of the discriminants for @@-- records. @@-- +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ -- Definition of a header type and Input and Output functions for @_TY_NAME_@ function @_TY_PREFIX_@_Input_Header @@ -18,3 +19,4 @@ procedure @_TY_PREFIX_@_Output_Header (@_GLOBAL_PREFIX_@_JSON : in out TGen.JSON.JSON_Value; @_GLOBAL_PREFIX_@_V : @_TY_NAME_@); +@@END_IF@@ diff --git a/src/tgen/templates/json_templates/header_wrappers_spec.tmplt b/src/tgen/templates/json_templates/header_wrappers_spec.tmplt index 895a9240..cba31fa5 100644 --- a/src/tgen/templates/json_templates/header_wrappers_spec.tmplt +++ b/src/tgen/templates/json_templates/header_wrappers_spec.tmplt @@ -4,6 +4,7 @@ @@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type. @@-- @_TY_NAME_@ Name of the current type. @@-- +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ procedure @_TY_PREFIX_@_Write_All (@_GLOBAL_PREFIX_@_JSON : in out TGen.JSON.JSON_Value; @@ -12,3 +13,4 @@ procedure @_TY_PREFIX_@_Read_All (@_GLOBAL_PREFIX_@_JSON : TGen.JSON.JSON_Value; @_GLOBAL_PREFIX_@_V : out @_TY_NAME_@); +@@END_IF@@ diff --git a/src/tgen/templates/json_templates/in_out_spec.tmplt b/src/tgen/templates/json_templates/in_out_spec.tmplt index 699d77f7..a141284c 100644 --- a/src/tgen/templates/json_templates/in_out_spec.tmplt +++ b/src/tgen/templates/json_templates/in_out_spec.tmplt @@ -4,6 +4,7 @@ @@-- @_TY_NAME_@ Name of the current type. @@-- @_NEEDS_HEADER_@ True if the current type needs a header. @@-- +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ -- Input and Output functions for @_TY_NAME_@ function @_TY_PREFIX_@_Output @@ -12,3 +13,4 @@ function @_TY_PREFIX_@_Input (@_GLOBAL_PREFIX_@_JSON : TGen.JSON.JSON_Value) return @_TY_NAME_@; +@@END_IF@@ \ No newline at end of file diff --git a/src/tgen/templates/json_templates/scalar_base_spec.tmplt b/src/tgen/templates/json_templates/scalar_base_spec.tmplt index a9585a48..18aa9f1e 100644 --- a/src/tgen/templates/json_templates/scalar_base_spec.tmplt +++ b/src/tgen/templates/json_templates/scalar_base_spec.tmplt @@ -6,6 +6,7 @@ @@-- @_FOR_BASE_@ True if we are doing the generation for the base type. @@-- @@INCLUDE@@ util.tmplt +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ -- Base operations for @_TY_NAME_@ procedure @_TY_PREFIX_@_Write@_BASE_SUFFIX()_@ @@ -19,3 +20,4 @@ @_GLOBAL_PREFIX_@_V : out @_TY_NAME_@; @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First; @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last); +@@END_IF@@ diff --git a/src/tgen/templates/marshalling_templates/composite_base_spec.tmplt b/src/tgen/templates/marshalling_templates/composite_base_spec.tmplt index e44fe930..7e2f34a7 100644 --- a/src/tgen/templates/marshalling_templates/composite_base_spec.tmplt +++ b/src/tgen/templates/marshalling_templates/composite_base_spec.tmplt @@ -9,8 +9,12 @@ @@-- @_DISCR_NAME_@ Same as above for the discriminants of records. @@-- @_COMP_TYP_@ Index types for arrays, and types of the discriminants for @@-- records. +@@-- @_SIZE_MAX_PUB_@ True if the Size_Max function can be declared in the +@@-- public part. This will be False if one of the discriminant types, or +@@-- index types is not visible outside of the private part. @@-- @@INCLUDE@@ util.tmplt +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ -- Base operations for @_TY_NAME_@ procedure @_TY_PREFIX_@_Write @@ -29,6 +33,8 @@ (@_GLOBAL_PREFIX_@_V : @_TY_NAME_@) return Natural; +@@END_IF@@ +@@IF@@ @_PUB_PART_@ xor (@_FULL_PRIV_@ or not @_SIZE_MAX_PUB_@) function @_TY_PREFIX_@_Size_Max @@IF@@ @_DISCR_NAME_@ /= "" @@TABLE'ALIGN_ON(":", ":=")@@ @@ -42,3 +48,4 @@ @@END_TABLE@@ @@END_IF@@ return Natural; +@@END_IF@@ diff --git a/src/tgen/templates/marshalling_templates/default_header_spec.tmplt b/src/tgen/templates/marshalling_templates/default_header_spec.tmplt index f1e23ef8..04a9e4b8 100644 --- a/src/tgen/templates/marshalling_templates/default_header_spec.tmplt +++ b/src/tgen/templates/marshalling_templates/default_header_spec.tmplt @@ -2,8 +2,10 @@ @@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type. @@-- @_TY_NAME_@ Name of the current type. @@-- +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ -- Definitions constants for the size of the header of @_TY_NAME_@ @_TY_PREFIX_@_Bit_Size_Header : constant Natural := 0; @_TY_PREFIX_@_Byte_Size_Header : constant Natural := 0; +@@END_IF@@ diff --git a/src/tgen/templates/marshalling_templates/header_spec.tmplt b/src/tgen/templates/marshalling_templates/header_spec.tmplt index ce8fab6b..49c0ea09 100644 --- a/src/tgen/templates/marshalling_templates/header_spec.tmplt +++ b/src/tgen/templates/marshalling_templates/header_spec.tmplt @@ -9,6 +9,10 @@ @@-- @_COMP_TYP_@ Index types for arrays, and types of the discriminants for @@-- records. @@-- + +@@IF@@ @_PUB_PART_@ + type @_TY_PREFIX_@_Header_Type is private; +@@ELSE@@ -- Definition of a header type and Input and Output functions for @_TY_NAME_@ type @_TY_PREFIX_@_Header_Type is record @@ -23,7 +27,9 @@ @@END_TABLE@@ @@END_IF@@ end record; +@@END_IF@@ +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ function @_TY_PREFIX_@_Input_Header (@_GLOBAL_PREFIX_@_Stream : not null access Root_Stream_Type'Class) return @_TY_PREFIX_@_Header_Type; @@ -35,3 +41,4 @@ function @_TY_PREFIX_@_Bit_Size_Header return Natural; function @_TY_PREFIX_@_Byte_Size_Header return Natural; +@@END_IF@@ diff --git a/src/tgen/templates/marshalling_templates/header_wrappers_spec.tmplt b/src/tgen/templates/marshalling_templates/header_wrappers_spec.tmplt index 64e9dbbb..96af7473 100644 --- a/src/tgen/templates/marshalling_templates/header_wrappers_spec.tmplt +++ b/src/tgen/templates/marshalling_templates/header_wrappers_spec.tmplt @@ -4,6 +4,7 @@ @@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type. @@-- @_TY_NAME_@ Name of the current type. @@-- +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ procedure @_TY_PREFIX_@_Write_All (@_GLOBAL_PREFIX_@_Stream : not null access Root_Stream_Type'Class; @_GLOBAL_PREFIX_@_Buffer : in out Unsigned_8; @@ -17,3 +18,4 @@ @_GLOBAL_PREFIX_@_V : out @_TY_NAME_@); function @_TY_PREFIX_@_Size_Max_All return Natural; +@@END_IF@@ diff --git a/src/tgen/templates/marshalling_templates/in_out_spec.tmplt b/src/tgen/templates/marshalling_templates/in_out_spec.tmplt index 90a4ce2a..c8e98894 100644 --- a/src/tgen/templates/marshalling_templates/in_out_spec.tmplt +++ b/src/tgen/templates/marshalling_templates/in_out_spec.tmplt @@ -4,6 +4,7 @@ @@-- @_TY_NAME_@ Name of the current type. @@-- @_NEEDS_HEADER_@ True if the current type needs a header. @@-- +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ -- Input and Output functions for @_TY_NAME_@ procedure @_TY_PREFIX_@_Output @@ -23,3 +24,4 @@ (@_GLOBAL_PREFIX_@_Header : not null access Root_Stream_Type'Class; @_GLOBAL_PREFIX_@_Stream : not null access Root_Stream_Type'Class) return @_TY_NAME_@; +@@END_IF@@ diff --git a/src/tgen/templates/marshalling_templates/scalar_base_spec.tmplt b/src/tgen/templates/marshalling_templates/scalar_base_spec.tmplt index d58d4a38..0e67ab1d 100644 --- a/src/tgen/templates/marshalling_templates/scalar_base_spec.tmplt +++ b/src/tgen/templates/marshalling_templates/scalar_base_spec.tmplt @@ -6,6 +6,7 @@ @@-- @_FOR_BASE_@ True if we are doing the generation for the base type. @@-- @@INCLUDE@@ util.tmplt +@@IF@@ @_PUB_PART_@ xor @_FULL_PRIV_@ -- Base operations for @_TY_NAME_@ procedure @_TY_PREFIX_@_Write@_BASE_SUFFIX()_@ @@ -28,3 +29,4 @@ (@_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First; @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last) return Natural; +@@END_IF@@ diff --git a/src/tgen/templates/type_representation_templates/anonymous_typ_spec.tmplt b/src/tgen/templates/type_representation_templates/anonymous_typ_decl.tmplt similarity index 69% rename from src/tgen/templates/type_representation_templates/anonymous_typ_spec.tmplt rename to src/tgen/templates/type_representation_templates/anonymous_typ_decl.tmplt index 473be1d5..1ef94cc5 100644 --- a/src/tgen/templates/type_representation_templates/anonymous_typ_spec.tmplt +++ b/src/tgen/templates/type_representation_templates/anonymous_typ_decl.tmplt @@ -1,4 +1,6 @@ -@@-- Template for the specification of an anonymous type representation. +@@-- Template for the declarations for an anonymous type representation. +@@-- These declarations go in the body of the value package, in order to +@@-- be part of the private part and avoid any visibility issues. @@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type. @@-- @_TY_NAME_@ Name of the current type. @@-- @_CONSTRAINT_KIND_@ Type of the constraint @@ -11,5 +13,3 @@ @_TY_PREFIX_@_Typ : TGen.Types.Constraints.Anonymous_Typ := (Name => TGen.Strings.To_Qualified_Name ("@_TY_NAME_@"), others => <>); - - @_TY_PREFIX_@_Typ_Ref : TGen.Types.SP.Ref; diff --git a/src/tgen/templates/type_representation_templates/array_typ_spec.tmplt b/src/tgen/templates/type_representation_templates/array_typ_decl.tmplt similarity index 80% rename from src/tgen/templates/type_representation_templates/array_typ_spec.tmplt rename to src/tgen/templates/type_representation_templates/array_typ_decl.tmplt index 0f6364f5..40926d43 100644 --- a/src/tgen/templates/type_representation_templates/array_typ_spec.tmplt +++ b/src/tgen/templates/type_representation_templates/array_typ_decl.tmplt @@ -1,4 +1,6 @@ -@@-- Template for the specification of an array type. +@@-- Template for the declarations for an array type representation. +@@-- These declarations go in the body of the value package, in order to +@@-- be part of the private part and avoid any visibility issues. @@-- @_TY_PREFIX_@ Common prefix for all entities of the type. @@-- @_ARRAY_TYP_@ Type of the array (either Constrained_Array_Typ or @@-- Unconstrained_Array_Typ. @@ -20,4 +22,3 @@ (Num_Dims => @_NUM_DIMS_@, Name => TGen.Strings.To_Qualified_Name ("@_TY_NAME_@"), others => <>); - @_TY_PREFIX_@_Typ_Ref : TGen.Types.SP.Ref; diff --git a/src/tgen/templates/type_representation_templates/constraint_spec.tmplt b/src/tgen/templates/type_representation_templates/constraint_decl.tmplt similarity index 95% rename from src/tgen/templates/type_representation_templates/constraint_spec.tmplt rename to src/tgen/templates/type_representation_templates/constraint_decl.tmplt index a52f4733..4d828be9 100644 --- a/src/tgen/templates/type_representation_templates/constraint_spec.tmplt +++ b/src/tgen/templates/type_representation_templates/constraint_decl.tmplt @@ -1,4 +1,6 @@ -@@-- Template for the specification of any kind of constraint +@@-- Template for the declarations for any kind of constraint representation. +@@-- These declarations go in the body of the value package, in order to +@@-- be part of the private part and avoid any visibility issues. @@-- @@-- Macro to instantiate a discrete constraint. @@-- @_$1_@: Kind of the constraint (STATIC, NON_STATIC, DISCRIMINANT) diff --git a/src/tgen/templates/type_representation_templates/instance_typ_spec.tmplt b/src/tgen/templates/type_representation_templates/instance_typ_decl.tmplt similarity index 71% rename from src/tgen/templates/type_representation_templates/instance_typ_spec.tmplt rename to src/tgen/templates/type_representation_templates/instance_typ_decl.tmplt index d7ddf26b..4e4011a6 100644 --- a/src/tgen/templates/type_representation_templates/instance_typ_spec.tmplt +++ b/src/tgen/templates/type_representation_templates/instance_typ_decl.tmplt @@ -1,4 +1,7 @@ -@@-- Template for the specification of an instane type representation. +@@-- Template for the declarations for an instance type representation. +@@-- These declarations go in the body of the value package, in order to +@@-- be part of the private part and avoid any visibility issues. +@@-- @@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type. @@-- @_TY_NAME_@ Name of the current type. @@ -13,5 +16,3 @@ @_TY_PREFIX_@_Typ : @_TY_PREFIX_@_Instance_Typ := (Name => TGen.Strings.To_Qualified_Name ("@_TY_NAME_@"), others => <>); - - @_TY_PREFIX_@_Typ_Ref : TGen.Types.SP.Ref; diff --git a/src/tgen/templates/type_representation_templates/record_typ_spec.tmplt b/src/tgen/templates/type_representation_templates/record_typ_decl.tmplt similarity index 85% rename from src/tgen/templates/type_representation_templates/record_typ_spec.tmplt rename to src/tgen/templates/type_representation_templates/record_typ_decl.tmplt index 9658be76..f7c73842 100644 --- a/src/tgen/templates/type_representation_templates/record_typ_spec.tmplt +++ b/src/tgen/templates/type_representation_templates/record_typ_decl.tmplt @@ -1,4 +1,7 @@ -@@-- Template for the specification of a record type representation. +@@-- Template for the declarations for a record type representation. +@@-- These declarations go in the body of the value package, in order to +@@-- be part of the private part and avoid any visibility issues. +@@-- @@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type. @@-- @_TY_NAME_@ Name of the current type. @@-- @_RECORD_TYP_@ Kind of the record type. Can be either Function_Typ, @@ -25,5 +28,3 @@ @@END_IF@@ Static_Gen => True, others => <>); - - @_TY_PREFIX_@_Typ_Ref : TGen.Types.SP.Ref; diff --git a/src/tgen/templates/type_representation_templates/scalar_spec.tmplt b/src/tgen/templates/type_representation_templates/scalar_spec.tmplt deleted file mode 100644 index a092e2c4..00000000 --- a/src/tgen/templates/type_representation_templates/scalar_spec.tmplt +++ /dev/null @@ -1,19 +0,0 @@ -@@-- Template for the specification of a scalar type representation. -@@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type. -@@-- @_TY_NAME_@ Name of the current type. - - package @_TY_PREFIX_@_Typ_Conversions is - new TGen.Big_Int.Signed_Conversions (@_TY_NAME_@); - - @_TY_PREFIX_@_Typ : constant TGen.Types.Int_Types.Signed_Int_Typ := - (Name => To_Qualified_Name ("@_TY_NAME_@"), - Is_Static => True, - Range_Value => - TGen.Types.Discrete_Types.Int_Range' - (Min => - @_TY_PREFIX_@_Typ_Conversions.To_Big_Integer - (@_TY_NAME_@'First), - Max => - @_TY_PREFIX_@_Typ_Conversions.To_Big_Integer - (@_TY_NAME_@'Last)), - others => <>); diff --git a/src/tgen/templates/type_representation_templates/scalar_typ_spec.tmplt b/src/tgen/templates/type_representation_templates/scalar_typ_decl.tmplt similarity index 95% rename from src/tgen/templates/type_representation_templates/scalar_typ_spec.tmplt rename to src/tgen/templates/type_representation_templates/scalar_typ_decl.tmplt index 40c7c2c8..3b34c935 100644 --- a/src/tgen/templates/type_representation_templates/scalar_typ_spec.tmplt +++ b/src/tgen/templates/type_representation_templates/scalar_typ_decl.tmplt @@ -1,4 +1,7 @@ -@@-- Template for the specification of a scalar type representation. +@@-- Template for the declarations for a scalar type representation. +@@-- These declarations go in the body of the value package, in order to +@@-- be part of the private part and avoid any visibility issues. +@@-- @@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type. @@-- @_TY_NAME_@ Name of the current type. @@-- @_SCALAR_TYP_@ Kind of the discrete typ @@ -104,4 +107,3 @@ others => <>); @@END_IF@@ - @_TY_PREFIX_@_Typ_Ref : TGen.Types.SP.Ref; diff --git a/src/tgen/templates/type_representation_templates/variant_choice_spec.tmplt b/src/tgen/templates/type_representation_templates/variant_choice_decl.tmplt similarity index 68% rename from src/tgen/templates/type_representation_templates/variant_choice_spec.tmplt rename to src/tgen/templates/type_representation_templates/variant_choice_decl.tmplt index c31caa3d..b09b5f3f 100644 --- a/src/tgen/templates/type_representation_templates/variant_choice_spec.tmplt +++ b/src/tgen/templates/type_representation_templates/variant_choice_decl.tmplt @@ -1,4 +1,6 @@ -@@-- Template for a variant choice specification +@@-- Template for the declarations for a variant choice specification. +@@-- These declarations go in the body of the value package, in order to +@@-- be part of the private part and avoid any visibility issues. @@-- @_TY_PREFIX_@ Prefix for all of the type declarations @@-- @_VARIANT_NUMBER_@ Index of the variant in the record @@-- @_VARIANT_CHOICE_NUMBER_@ Index of the variant choice number diff --git a/src/tgen/templates/type_representation_templates/variant_spec.tmplt b/src/tgen/templates/type_representation_templates/variant_decl.tmplt similarity index 65% rename from src/tgen/templates/type_representation_templates/variant_spec.tmplt rename to src/tgen/templates/type_representation_templates/variant_decl.tmplt index b51cd433..f42bc3e4 100644 --- a/src/tgen/templates/type_representation_templates/variant_spec.tmplt +++ b/src/tgen/templates/type_representation_templates/variant_decl.tmplt @@ -1,3 +1,7 @@ +@@-- Template for the declarations for a variant part representation. +@@-- These declarations go in the body of the value package, in order to +@@-- be part of the private part and avoid any visibility issues. +@@-- @@-- @_TY_PREFIX_@ Prefix for all of the type declarations @@-- @_VARIANT_NUMBER_@ Index of the variant in the record @@-- @_DISCR_NAME_@ Controlling discriminant for the variant expression diff --git a/src/tgen/tgen-gen_strategies_utils.adb b/src/tgen/tgen-gen_strategies_utils.adb index d2632d16..04cf83e0 100644 --- a/src/tgen/tgen-gen_strategies_utils.adb +++ b/src/tgen/tgen-gen_strategies_utils.adb @@ -342,6 +342,7 @@ package body TGen.Gen_Strategies_Utils is (Constrained => False, Name => R.Name, Last_Comp_Unit_Idx => R.Last_Comp_Unit_Idx, + Fully_Private => R.Fully_Private, Static_Gen => R.Static_Gen, Component_Types => V.Components, Mutable => False, diff --git a/src/tgen/tgen-libgen.adb b/src/tgen/tgen-libgen.adb index 8aa3b218..9adc2ff8 100644 --- a/src/tgen/tgen-libgen.adb +++ b/src/tgen/tgen-libgen.adb @@ -174,6 +174,8 @@ package body TGen.Libgen is TRD : constant String := To_String (Ctx.Root_Templates_Dir); + Sorted_Types : Typ_List; + begin Create (F_Spec, Out_File, File_Name & ".ads"); Put (F_Spec, "with TGen.Marshalling_Lib; "); @@ -279,30 +281,49 @@ package body TGen.Libgen is -- Generate the marshalling support lib. Make sure to sort the types -- in dependency order otherwise we will get access before elaboration - -- issues. + -- issues when computing the Size_Max constants for each type: + -- we need the Size_Max of all the dependencies of the components to be + -- available before being able to compute the Size_Max for a composite + -- type. - for T of Sort (Types) loop + Sorted_Types := Sort (Types); - if Is_Supported_Type (T.Get) + -- Output the marshalling subprograms for the types with a public part + -- first, then create the private part for the package and output the + -- marshalling subprograms for the fully private types. Hopefully this + -- won't break too much the topological order on the types, otherwise + -- we'll need to make marshaller generation much finer grain in order to + -- both be able to have the marshaller subprograms declarations respect + -- the visibility of the type, and have the implementation details + -- generated in the correct order. - -- We ignore instance types when generating marshallers as they - -- are not types per-se, but a convenient way of binding a type - -- to its strategy context. + for Part in Spec_Part loop + for T of Sorted_Types loop - and then T.Get not in Instance_Typ'Class - then - if T.Get.Kind in Function_Kind then - TGen.Marshalling.JSON_Marshallers - .Generate_TC_Serializers_For_Subp - (F_Spec, F_Body, T.Get, TRD); - else - TGen.Marshalling.Binary_Marshallers - .Generate_Marshalling_Functions_For_Typ - (F_Spec, F_Body, T.Get, TRD); - TGen.Marshalling.JSON_Marshallers - .Generate_Marshalling_Functions_For_Typ - (F_Spec, F_Body, T.Get, TRD); + if Is_Supported_Type (T.Get) + + -- We ignore instance types when generating marshallers as they + -- are not types per-se, but a convenient way of binding a type + -- to its strategy context. + + and then T.Get not in Instance_Typ'Class + then + if T.Get.Kind in Function_Kind then + TGen.Marshalling.JSON_Marshallers + .Generate_TC_Serializers_For_Subp + (F_Spec, F_Body, T.Get, Part, TRD); + else + TGen.Marshalling.Binary_Marshallers + .Generate_Marshalling_Functions_For_Typ + (F_Spec, F_Body, T.Get, Part, TRD); + TGen.Marshalling.JSON_Marshallers + .Generate_Marshalling_Functions_For_Typ + (F_Spec, F_Body, T.Get, Part, TRD); + end if; end if; + end loop; + if Part = Pub then + Put_Line (F_Spec, "private"); end if; end loop; diff --git a/src/tgen/tgen-marshalling-binary_marshallers.adb b/src/tgen/tgen-marshalling-binary_marshallers.adb index 4d8faa83..e8c6b92f 100644 --- a/src/tgen/tgen-marshalling-binary_marshallers.adb +++ b/src/tgen/tgen-marshalling-binary_marshallers.adb @@ -34,6 +34,7 @@ package body TGen.Marshalling.Binary_Marshallers is procedure Generate_Marshalling_Functions_For_Typ (F_Spec, F_Body : File_Type; Typ : TGen.Types.Typ'Class; + Part : Spec_Part; Templates_Root_Dir : String) is TRD : constant String := @@ -56,7 +57,9 @@ package body TGen.Marshalling.Binary_Marshallers is 4 => Assoc ("GENERIC_NAME", Generic_Name), 5 => Assoc ("GLOBAL_PREFIX", Global_Prefix), 6 => Assoc ("NEEDS_HEADER", Needs_Header (Typ)), - 7 => Assoc ("IS_SCALAR", Typ in Scalar_Typ'Class)]; + 7 => Assoc ("IS_SCALAR", Typ in Scalar_Typ'Class), + 8 => Assoc ("PUB_PART", Part = Pub), + 9 => Assoc ("FULL_PRIV", Typ.Fully_Private)]; function Component_Read (Assocs : Translate_Table) return Unbounded_String; @@ -168,8 +171,10 @@ package body TGen.Marshalling.Binary_Marshallers is begin Put_Line (F_Spec, Parse (Header_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line (F_Body, Parse (Header_Body_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line (F_Body, Parse (Header_Body_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Header; -------------------------- @@ -190,9 +195,11 @@ package body TGen.Marshalling.Binary_Marshallers is begin Put_Line (F_Spec, Parse (Scalar_Base_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line - (F_Body, Parse (Scalar_Read_Write_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line + (F_Body, Parse (Scalar_Read_Write_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Scalar; ----------------- @@ -203,14 +210,16 @@ package body TGen.Marshalling.Binary_Marshallers is begin Put_Line (F_Spec, Parse (Composite_Base_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line - (F_Body, Parse (Array_Read_Write_Template, Assocs)); - New_Line (F_Body); - Put_Line (F_Body, Parse (Array_Size_Template, Assocs)); - New_Line (F_Body); - Put_Line - (F_Body, Parse (Array_Size_Max_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line + (F_Body, Parse (Array_Read_Write_Template, Assocs)); + New_Line (F_Body); + Put_Line (F_Body, Parse (Array_Size_Template, Assocs)); + New_Line (F_Body); + Put_Line + (F_Body, Parse (Array_Size_Max_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Array; ------------------ @@ -224,15 +233,17 @@ package body TGen.Marshalling.Binary_Marshallers is begin Put_Line (F_Spec, Parse (Composite_Base_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line - (F_Body, Parse (Record_Read_Write_Template, Assocs)); - New_Line (F_Body); - Put_Line - (F_Body, Parse (Record_Size_Template, Assocs)); - New_Line (F_Body); - Put_Line - (F_Body, Parse (Record_Size_Max_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line + (F_Body, Parse (Record_Read_Write_Template, Assocs)); + New_Line (F_Body); + Put_Line + (F_Body, Parse (Record_Size_Template, Assocs)); + New_Line (F_Body); + Put_Line + (F_Body, Parse (Record_Size_Max_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Record; --------------------------- @@ -247,9 +258,11 @@ package body TGen.Marshalling.Binary_Marshallers is Put_Line (F_Spec, Parse (Header_Wrappers_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line - (F_Body, Parse (Header_Wrappers_Body_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line + (F_Body, Parse (Header_Wrappers_Body_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Header_Wrappers; procedure Generate_Base_Functions_For_Typ_Instance is new @@ -271,7 +284,7 @@ package body TGen.Marshalling.Binary_Marshallers is begin -- Generate the base functions for Typ - Generate_Base_Functions_For_Typ_Instance (Typ); + Generate_Base_Functions_For_Typ_Instance (Typ, Part); -- If the type can be used as an array index constraint, also generate -- the functions for Typ'Base. TODO: we probably should do that iff @@ -279,7 +292,7 @@ package body TGen.Marshalling.Binary_Marshallers is if Typ in Scalar_Typ'Class then Generate_Base_Functions_For_Typ_Instance - (Typ, For_Base => True); + (Typ, Part, For_Base => True); end if; -- Generate the Input and Output subprograms @@ -289,12 +302,13 @@ package body TGen.Marshalling.Binary_Marshallers is Parse (In_Out_Spec_Template, Assocs)); New_Line (F_Spec); - - Put_Line - (F_Body, + if Part = Pub then + Put_Line + (F_Body, Parse (In_Out_Body_Template, Assocs)); - New_Line (F_Body); + New_Line (F_Body); + end if; end Generate_Marshalling_Functions_For_Typ; end TGen.Marshalling.Binary_Marshallers; diff --git a/src/tgen/tgen-marshalling-binary_marshallers.ads b/src/tgen/tgen-marshalling-binary_marshallers.ads index c217843c..793a2d79 100644 --- a/src/tgen/tgen-marshalling-binary_marshallers.ads +++ b/src/tgen/tgen-marshalling-binary_marshallers.ads @@ -28,11 +28,19 @@ package TGen.Marshalling.Binary_Marshallers is procedure Generate_Marshalling_Functions_For_Typ (F_Spec, F_Body : File_Type; Typ : TGen.Types.Typ'Class; + Part : Spec_Part; Templates_Root_Dir : String); -- Generate binary marshalling and unmarshalling functions for Typ. Note -- that this function will not operate recursively. It will thus have to -- be called for each of the component type of a record for instance. -- + -- Part determines which part (public or private) of the spec will be + -- generated. It is thus necessary to call this subprogram twice in order + -- to generate a full spec, taking care to insert a "private" line in + -- F_Spec in between the two calls. The body is generated at the same time + -- the public part is generated, nothing will be written to F_Body if Part + -- is Priv. + -- -- If the type does not need a header, we generate: -- -- procedure TAGAda_Marshalling_Typ_Output diff --git a/src/tgen/tgen-marshalling-json_marshallers.adb b/src/tgen/tgen-marshalling-json_marshallers.adb index 52971798..901dffa9 100644 --- a/src/tgen/tgen-marshalling-json_marshallers.adb +++ b/src/tgen/tgen-marshalling-json_marshallers.adb @@ -36,6 +36,7 @@ package body TGen.Marshalling.JSON_Marshallers is procedure Generate_Marshalling_Functions_For_Typ (F_Spec, F_Body : File_Type; Typ : TGen.Types.Typ'Class; + Part : Spec_Part; Templates_Root_Dir : String) is TRD : constant String := @@ -58,7 +59,9 @@ package body TGen.Marshalling.JSON_Marshallers is 4 => Assoc ("GENERIC_NAME", Generic_Name), 5 => Assoc ("GLOBAL_PREFIX", Global_Prefix), 6 => Assoc ("NEEDS_HEADER", Needs_Header (Typ)), - 7 => Assoc ("IS_SCALAR", Typ in Scalar_Typ'Class)]; + 7 => Assoc ("IS_SCALAR", Typ in Scalar_Typ'Class), + 8 => Assoc ("PUB_PART", Part = Pub), + 9 => Assoc ("FULL_PRIV", Typ.Fully_Private)]; function Component_Read (Assocs : Translate_Table) return Unbounded_String; @@ -166,8 +169,10 @@ package body TGen.Marshalling.JSON_Marshallers is begin Put_Line (F_Spec, Parse (Header_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line (F_Body, Parse (Header_Body_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line (F_Body, Parse (Header_Body_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Header; ------------------ @@ -178,9 +183,11 @@ package body TGen.Marshalling.JSON_Marshallers is begin Put_Line (F_Spec, Parse (Scalar_Base_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line - (F_Body, Parse (Scalar_Read_Write_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line + (F_Body, Parse (Scalar_Read_Write_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Scalar; ----------------- @@ -191,9 +198,11 @@ package body TGen.Marshalling.JSON_Marshallers is begin Put_Line (F_Spec, Parse (Composite_Base_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line - (F_Body, Parse (Array_Read_Write_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line + (F_Body, Parse (Array_Read_Write_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Array; ------------------ @@ -204,9 +213,11 @@ package body TGen.Marshalling.JSON_Marshallers is begin Put_Line (F_Spec, Parse (Composite_Base_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line - (F_Body, Parse (Record_Read_Write_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line + (F_Body, Parse (Record_Read_Write_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Record; --------------------------- @@ -218,9 +229,11 @@ package body TGen.Marshalling.JSON_Marshallers is Put_Line (F_Spec, Parse (Header_Wrappers_Spec_Template, Assocs)); New_Line (F_Spec); - Put_Line - (F_Body, Parse (Header_Wrappers_Body_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line + (F_Body, Parse (Header_Wrappers_Body_Template, Assocs)); + New_Line (F_Body); + end if; end Print_Header_Wrappers; procedure Generate_Base_Functions_For_Typ_Instance is new @@ -242,14 +255,15 @@ package body TGen.Marshalling.JSON_Marshallers is begin -- Generate the base functions for Typ - Generate_Base_Functions_For_Typ_Instance (Typ); + Generate_Base_Functions_For_Typ_Instance (Typ, Part); -- If the type can be used as an array index constraint, also generate -- the functions for Typ'Base. TODO: we probably should do that iff -- the type actually constrains an array. if Typ in Scalar_Typ'Class then - Generate_Base_Functions_For_Typ_Instance (Typ, For_Base => True); + Generate_Base_Functions_For_Typ_Instance + (Typ, Part, For_Base => True); end if; -- Generate the Input and Output subprograms @@ -259,12 +273,13 @@ package body TGen.Marshalling.JSON_Marshallers is Parse (In_Out_Spec_Template, Assocs)); New_Line (F_Spec); - - Put_Line - (F_Body, - Parse - (In_Out_Body_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Put_Line + (F_Body, + Parse + (In_Out_Body_Template, Assocs)); + New_Line (F_Body); + end if; end Generate_Marshalling_Functions_For_Typ; -------------------------------------- @@ -274,6 +289,7 @@ package body TGen.Marshalling.JSON_Marshallers is procedure Generate_TC_Serializers_For_Subp (F_Spec, F_Body : File_Type; FN_Typ : TGen.Types.Typ'Class; + Part : Spec_Part; Templates_Root_Dir : String) is use Component_Maps; @@ -292,6 +308,13 @@ package body TGen.Marshalling.JSON_Marshallers is Param_Types : Vector_Tag; Param_Slugs : Vector_Tag; begin + -- Nothing to be done when the subprogram is public and we are + -- processing the private part. + + if Part = Priv and then not FN_Typ.Fully_Private then + return; + end if; + if Function_Typ (FN_Typ).Component_Types.Is_Empty then return; end if; @@ -322,17 +345,21 @@ package body TGen.Marshalling.JSON_Marshallers is Assocs.Insert (Assoc ("PARAM_TY", Param_Types)); Assocs.Insert (Assoc ("PARAM_SLUG", Param_Slugs)); - -- First generate the spec + -- First generate the spec, in the correct part of the spec - Assocs.Insert (Assoc ("FOR_SPEC", True)); - Put_Line (F_Spec, Parse (Function_TC_Dump_Template, Assocs)); - New_Line (F_Spec); + if Part = Pub xor FN_Typ.Fully_Private then + Assocs.Insert (Assoc ("FOR_SPEC", True)); + Put_Line (F_Spec, Parse (Function_TC_Dump_Template, Assocs)); + New_Line (F_Spec); + end if; -- Then the body - Assocs.Insert (Assoc ("FOR_SPEC", False)); - Put_Line (F_Body, Parse (Function_TC_Dump_Template, Assocs)); - New_Line (F_Body); + if Part = Pub then + Assocs.Insert (Assoc ("FOR_SPEC", False)); + Put_Line (F_Body, Parse (Function_TC_Dump_Template, Assocs)); + New_Line (F_Body); + end if; end Generate_TC_Serializers_For_Subp; diff --git a/src/tgen/tgen-marshalling-json_marshallers.ads b/src/tgen/tgen-marshalling-json_marshallers.ads index b1229fb5..4db9625d 100644 --- a/src/tgen/tgen-marshalling-json_marshallers.ads +++ b/src/tgen/tgen-marshalling-json_marshallers.ads @@ -28,11 +28,19 @@ package TGen.Marshalling.JSON_Marshallers is procedure Generate_Marshalling_Functions_For_Typ (F_Spec, F_Body : File_Type; Typ : TGen.Types.Typ'Class; + Part : Spec_Part; Templates_Root_Dir : String); -- Generate JSON marshalling and unmarshalling functions for Typ. Note that -- this function will not operate recursively. It will thus have to be -- called for each of the component type of a record for instance. -- + -- Part determines which part (public or private) of the spec will be + -- generated. It is thus necessary to call this subprogram twice in order + -- to generate a full spec, taking care to insert a "private" line in + -- F_Spec in between the two calls. The body is generated at the same time + -- the public part is generated, nothing will be written to F_Body if Part + -- is Priv. + -- -- We generate the following functions: -- -- function TAGAda_Marshalling_Typ_Output @@ -57,6 +65,7 @@ package TGen.Marshalling.JSON_Marshallers is procedure Generate_TC_Serializers_For_Subp (F_Spec, F_Body : File_Type; FN_Typ : TGen.Types.Typ'Class; + Part : Spec_Part; Templates_Root_Dir : String) with Pre => FN_Typ.Kind = Function_Kind; -- Generate a test-case serializer for FN_Typ: @@ -70,5 +79,12 @@ package TGen.Marshalling.JSON_Marshallers is -- -- The generated procedure also has a Origin parameter which can be used -- to specify which tool produced the test case. + -- + -- Part determines which part (public or private) of the spec will be + -- generated. It is thus necessary to call this subprogram twice in order + -- to generate a full spec, taking care to insert a "private" line in + -- F_Spec in between the two calls. The body is generated at the same time + -- the public part is generated, nothing will be written to F_Body if Part + -- is Priv. end TGen.Marshalling.JSON_Marshallers; diff --git a/src/tgen/tgen-marshalling.adb b/src/tgen/tgen-marshalling.adb index 46a34bd5..408bf3d4 100644 --- a/src/tgen/tgen-marshalling.adb +++ b/src/tgen/tgen-marshalling.adb @@ -405,6 +405,7 @@ package body TGen.Marshalling is procedure Generate_Base_Functions_For_Typ (Typ : TGen.Types.Typ'Class; + Part : Spec_Part := Pub; For_Base : Boolean := False) is B_Name : constant String := Typ.Fully_Qualified_Name; @@ -412,6 +413,13 @@ package body TGen.Marshalling is Ty_Name : constant String := (if For_Base then B_Name & "'Base" else B_Name); + Common_Assocs : constant Translate_Table := + [1 => Assoc ("GLOBAL_PREFIX", Global_Prefix), + 2 => Assoc ("TY_PREFIX", Ty_Prefix), + 3 => Assoc ("TY_NAME", Ty_Name), + 4 => Assoc ("PUB_PART", (if Part = Pub then True else False)), + 5 => Assoc ("FULL_PRIV", Typ.Fully_Private)]; + type Component_Kind is (Array_Component, Record_Component); -- Function computing the indentation for component handling @@ -511,14 +519,14 @@ package body TGen.Marshalling is Comp_Constraints : constant Tag := Create_Tag_For_Constraints (Comp_Ty); Assocs : constant Translate_Table := - [1 => Assoc ("GLOBAL_PREFIX", Global_Prefix), - 2 => Assoc ("COMP_PREFIX", Comp_Prefix), - 3 => Assoc ("COMPONENT", Comp), - 4 => Assoc ("CONSTRAINTS", Comp_Constraints), - 5 => Assoc ("COMP_SCALAR", Comp_Scalar), - 6 => Assoc ("NEEDS_HEADER", Needs_Header (Named_Comp_Ty)), - 7 => Assoc ("COMPONENT_KIND", Component_Kind'Image (Comp_Kind)), - 8 => Assoc ("COMPONENT_NAME", Comp_Name)]; + Common_Assocs + & [1 => Assoc ("COMP_PREFIX", Comp_Prefix), + 2 => Assoc ("COMPONENT", Comp), + 3 => Assoc ("CONSTRAINTS", Comp_Constraints), + 4 => Assoc ("COMP_SCALAR", Comp_Scalar), + 5 => Assoc ("NEEDS_HEADER", Needs_Header (Named_Comp_Ty)), + 6 => Assoc ("COMPONENT_KIND", Component_Kind'Image (Comp_Kind)), + 7 => Assoc ("COMPONENT_NAME", Comp_Name)]; Comp_Kind_Str : constant String := Component_Kind'Image (Comp_Kind); pragma Unreferenced (Comp_Kind_Str); @@ -659,10 +667,10 @@ package body TGen.Marshalling is declare Assocs : constant Translate_Table := - [1 => Assoc ("OBJECT_NAME", Object_Name), - 2 => Assoc ("DISCR_NAME", Discr_Name), - 3 => Assoc ("GLOBAL_PREFIX", Global_Prefix), - 4 => Assoc ("CHOICES", Choices_Tag)]; + Common_Assocs + & [1 => Assoc ("OBJECT_NAME", Object_Name), + 2 => Assoc ("DISCR_NAME", Discr_Name), + 3 => Assoc ("CHOICES", Choices_Tag)]; begin Read_Tag := +Variant_Read_Write @@ -743,15 +751,13 @@ package body TGen.Marshalling is declare Assocs : constant Translate_Table := - [1 => Assoc ("TY_NAME", Ty_Name), - 2 => Assoc ("TY_PREFIX", Ty_Prefix), - 3 => Assoc ("GLOBAL_PREFIX", Global_Prefix), - 4 => Assoc ("DISCR_NAME", Discr_Name_Tag), - 5 => Assoc ("FIRST_NAME", First_Name_Tag), - 6 => Assoc ("LAST_NAME", Last_Name_Tag), - 7 => Assoc ("COMP_TYP", Comp_Typ_Tag), - 8 => Assoc ("COMP_PREFIX", Comp_Pref_Tag), - 9 => Assoc ("ADA_DIM", Ada_Dim_Tag)]; + Common_Assocs + & [1 => Assoc ("DISCR_NAME", Discr_Name_Tag), + 2 => Assoc ("FIRST_NAME", First_Name_Tag), + 3 => Assoc ("LAST_NAME", Last_Name_Tag), + 4 => Assoc ("COMP_TYP", Comp_Typ_Tag), + 5 => Assoc ("COMP_PREFIX", Comp_Pref_Tag), + 6 => Assoc ("ADA_DIM", Ada_Dim_Tag)]; begin Print_Header (Assocs); @@ -761,14 +767,7 @@ package body TGen.Marshalling is -- the size of the header. elsif not For_Base then - declare - Assocs : constant Translate_Table := - [1 => Assoc ("TY_NAME", Ty_Name), - 2 => Assoc ("TY_PREFIX", Ty_Prefix)]; - - begin - Print_Default_Header (Assocs); - end; + Print_Default_Header (Common_Assocs); end if; -- 3. Generate the body and spec of the base operations @@ -789,13 +788,11 @@ package body TGen.Marshalling is then "Read_Write_Ordinary_Fixed" else "Read_Write_Decimal_Fixed"); Assocs : constant Translate_Table := - [1 => Assoc ("TY_NAME", Ty_Name), - 2 => Assoc ("TY_PREFIX", Ty_Prefix), - 3 => Assoc ("GLOBAL_PREFIX", Global_Prefix), - 4 => Assoc ("MARSHALLING_LIB", Marshalling_Lib), - 5 => Assoc ("GENERIC_NAME", Generic_Name), - 6 => Assoc ("IS_DISCRETE", Typ in Discrete_Typ'Class), - 7 => Assoc ("FOR_BASE", For_Base)]; + Common_Assocs + & [1 => Assoc ("MARSHALLING_LIB", Marshalling_Lib), + 2 => Assoc ("GENERIC_NAME", Generic_Name), + 3 => Assoc ("IS_DISCRETE", Typ in Discrete_Typ'Class), + 4 => Assoc ("FOR_BASE", For_Base)]; begin Print_Scalar (Assocs); @@ -816,6 +813,14 @@ package body TGen.Marshalling is Component_Write : Unbounded_String; Component_Size : Unbounded_String; Component_Size_Max : Unbounded_String; + + -- Check that the Size_Max function can be declared in the public + -- part of the support package: this is not the case as soon as + -- one of the index types of the array is fully private. + + Size_Max_Pub : constant Boolean := + not (for some Idx_Typ of Array_Typ'Class (Typ).Index_Types + => Idx_Typ.Get.Fully_Private); begin -- Contruct the calls for the components @@ -829,18 +834,17 @@ package body TGen.Marshalling is declare Assocs : constant Translate_Table := - [1 => Assoc ("TY_NAME", Ty_Name), - 2 => Assoc ("TY_PREFIX", Ty_Prefix), - 3 => Assoc ("GLOBAL_PREFIX", Global_Prefix), - 4 => Assoc ("COMPONENT_READ", Component_Read), - 5 => Assoc ("COMPONENT_WRITE", Component_Write), - 6 => Assoc ("COMPONENT_SIZE", Component_Size), - 7 => Assoc ("COMPONENT_SIZE_MAX", Component_Size_Max), - 8 => Assoc ("COMP_TYP", Named_Comp_Ty.Type_Name), - 9 => Assoc ("ADA_DIM", Ada_Dim_Tag), - 10 => Assoc ("FIRST_NAME", First_Name_Tag), - 11 => Assoc ("LAST_NAME", Last_Name_Tag), - 12 => Assoc ("BOUND_TYP", Comp_Typ_Tag)]; + Common_Assocs + & [1 => Assoc ("COMPONENT_READ", Component_Read), + 2 => Assoc ("COMPONENT_WRITE", Component_Write), + 3 => Assoc ("COMPONENT_SIZE", Component_Size), + 4 => Assoc ("COMPONENT_SIZE_MAX", Component_Size_Max), + 5 => Assoc ("COMP_TYP", Named_Comp_Ty.Type_Name), + 6 => Assoc ("ADA_DIM", Ada_Dim_Tag), + 7 => Assoc ("FIRST_NAME", First_Name_Tag), + 8 => Assoc ("LAST_NAME", Last_Name_Tag), + 9 => Assoc ("BOUND_TYP", Comp_Typ_Tag), + 10 => Assoc ("SIZE_MAX_PUB", Size_Max_Pub)]; begin Print_Array (Assocs); @@ -866,8 +870,19 @@ package body TGen.Marshalling is Variant_Size : Tag; Variant_Size_Max : Tag; + -- Check wether the Size_Max function can be placed in the public + -- part: This is not the case as soon as one of the discriminants + -- is fully private. + + Size_Max_Pub : constant Boolean := + not (Typ in Discriminated_Record_Typ'Class) + or else + not (for some Disc_Typ of + Discriminated_Record_Typ'Class (Typ).Discriminant_Types + => Disc_Typ.Get.Fully_Private); + begin - -- Contruct the calls for the components + -- Construct the calls for the components Collect_Info_For_Components (Record_Typ'Class (Typ).Component_Types, @@ -876,7 +891,7 @@ package body TGen.Marshalling is Object_Name => Object_Name, Spacing => 0); - -- Contruct the calls for the variant part if any + -- Construct the calls for the variant part if any if Typ in Discriminated_Record_Typ'Class then declare @@ -899,19 +914,18 @@ package body TGen.Marshalling is declare Assocs : constant Translate_Table := - [1 => Assoc ("TY_NAME", Ty_Name), - 2 => Assoc ("TY_PREFIX", Ty_Prefix), - 3 => Assoc ("GLOBAL_PREFIX", Global_Prefix), - 4 => Assoc ("COMPONENT_READ", Component_Read), - 5 => Assoc ("COMPONENT_WRITE", Component_Write), - 6 => Assoc ("COMPONENT_SIZE", Component_Size), - 7 => Assoc ("COMPONENT_SIZE_MAX", Component_Size_Max), - 8 => Assoc ("VARIANT_READ", Variant_Read), - 9 => Assoc ("VARIANT_WRITE", Variant_Write), - 10 => Assoc ("VARIANT_SIZE", Variant_Size), - 11 => Assoc ("VARIANT_SIZE_MAX", Variant_Size_Max), - 12 => Assoc ("DISCR_NAME", Discr_Name_Tag), - 13 => Assoc ("DISCR_TYP", Comp_Typ_Tag)]; + Common_Assocs + & [1 => Assoc ("COMPONENT_READ", Component_Read), + 2 => Assoc ("COMPONENT_WRITE", Component_Write), + 3 => Assoc ("COMPONENT_SIZE", Component_Size), + 4 => Assoc ("COMPONENT_SIZE_MAX", Component_Size_Max), + 5 => Assoc ("VARIANT_READ", Variant_Read), + 6 => Assoc ("VARIANT_WRITE", Variant_Write), + 7 => Assoc ("VARIANT_SIZE", Variant_Size), + 8 => Assoc ("VARIANT_SIZE_MAX", Variant_Size_Max), + 9 => Assoc ("DISCR_NAME", Discr_Name_Tag), + 10 => Assoc ("DISCR_TYP", Comp_Typ_Tag), + 11 => Assoc ("SIZE_MAX_PUB", Size_Max_Pub)]; begin Print_Record (Assocs); @@ -925,12 +939,10 @@ package body TGen.Marshalling is if Needs_Wrappers (Typ) then declare Assocs : constant Translate_Table := - [1 => Assoc ("TY_NAME", Ty_Name), - 2 => Assoc ("TY_PREFIX", Ty_Prefix), - 3 => Assoc ("GLOBAL_PREFIX", Global_Prefix), - 4 => Assoc ("DISCR_NAME", Discr_Name_Tag), - 5 => Assoc ("DISCR_TYP", Comp_Typ_Tag), - 6 => Assoc ("DISCR_PREFIX", Comp_Pref_Tag)]; + Common_Assocs + & [1 => Assoc ("DISCR_NAME", Discr_Name_Tag), + 2 => Assoc ("DISCR_TYP", Comp_Typ_Tag), + 3 => Assoc ("DISCR_PREFIX", Comp_Pref_Tag)]; begin Print_Header_Wrappers (Assocs); diff --git a/src/tgen/tgen-marshalling.ads b/src/tgen/tgen-marshalling.ads index d3c1132d..6ffa2e5a 100644 --- a/src/tgen/tgen-marshalling.ads +++ b/src/tgen/tgen-marshalling.ads @@ -49,6 +49,8 @@ package TGen.Marshalling is Global_Prefix : constant String := "TGen_Marshalling"; + type Spec_Part is (Pub, Priv); + private Marshalling_Lib : constant String := "TGen.Marshalling_Lib"; @@ -113,6 +115,7 @@ private procedure Generate_Base_Functions_For_Typ (Typ : TGen.Types.Typ'Class; + Part : Spec_Part := Pub; For_Base : Boolean := False) with Pre => (if For_Base then Typ in Scalar_Typ'Class) and then Typ not in Anonymous_Typ'Class @@ -231,4 +234,8 @@ private -- -- They also marshall the header and add some padding so that there is -- enough room to read a correct value if the header is mutated. + -- + -- Part may be used to control which part of the spec (public or private) + -- is generated, if the templates support the tag, otherwise, it has no + -- effect. end TGen.Marshalling; diff --git a/src/tgen/tgen-templates.ads b/src/tgen/tgen-templates.ads index 1a5fa9f4..33cfb12a 100644 --- a/src/tgen/tgen-templates.ads +++ b/src/tgen/tgen-templates.ads @@ -108,40 +108,40 @@ package TGen.Templates is end JSON_Marshalling; package Type_Representation is - Scalar_Typ_Spec_Template : constant String := - Template_Folder & "scalar_typ_spec.tmplt"; + Scalar_Typ_Decl_Template : constant String := + Template_Folder & "scalar_typ_decl.tmplt"; Scalar_Typ_Init_Template : constant String := Template_Folder & "scalar_typ_init.tmplt"; - Record_Typ_Spec_Template : constant String := - Template_Folder & "record_typ_spec.tmplt"; + Record_Typ_Decl_Template : constant String := + Template_Folder & "record_typ_decl.tmplt"; Record_Typ_Init_Template : constant String := Template_Folder & "record_typ_init.tmplt"; - Anonymous_Typ_Spec_Template : constant String := - Template_Folder & "anonymous_typ_spec.tmplt"; + Anonymous_Typ_Decl_Template : constant String := + Template_Folder & "anonymous_typ_decl.tmplt"; Anonymous_Typ_Init_Template : constant String := Template_Folder & "anonymous_typ_init.tmplt"; Custom_Strat_Spec_Template : constant String := Template_Folder & "custom_strat_spec.tmplt"; Custom_Strat_Body_Template : constant String := Template_Folder & "custom_strat_body.tmplt"; - Variant_Choice_Spec_Template : constant String := - Template_Folder & "variant_choice_spec.tmplt"; + Variant_Choice_Decl_Template : constant String := + Template_Folder & "variant_choice_decl.tmplt"; Variant_Choice_Init_Template : constant String := Template_Folder & "variant_choice_init.tmplt"; - Variant_Spec_Template : constant String := - Template_Folder & "variant_spec.tmplt"; + Variant_Decl_Template : constant String := + Template_Folder & "variant_decl.tmplt"; Variant_Init_Template : constant String := Template_Folder & "variant_init.tmplt"; - Constraint_Spec_Template : constant String := - Template_Folder & "constraint_spec.tmplt"; + Constraint_Decl_Template : constant String := + Template_Folder & "constraint_decl.tmplt"; Constraint_Init_Template : constant String := Template_Folder & "constraint_init.tmplt"; - Instance_Spec_Template : constant String := - Template_Folder & "instance_typ_spec.tmplt"; + Instance_Decl_Template : constant String := + Template_Folder & "instance_typ_decl.tmplt"; Instance_Init_Template : constant String := Template_Folder & "instance_typ_init.tmplt"; - Array_Typ_Spec_Template : constant String := - Template_Folder & "array_typ_spec.tmplt"; + Array_Typ_Decl_Template : constant String := + Template_Folder & "array_typ_decl.tmplt"; Array_Typ_Init_Template : constant String := Template_Folder & "array_typ_init.tmplt"; end Type_Representation; diff --git a/src/tgen/tgen-type_representation.adb b/src/tgen/tgen-type_representation.adb index eaadc030..8b741ae2 100644 --- a/src/tgen/tgen-type_representation.adb +++ b/src/tgen/tgen-type_representation.adb @@ -43,9 +43,9 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Constraint (Ty_Prefix : String; Constraint : TGen.Types.Constraints.Constraint'Class; - Constraint_Spec_Template : String; + Constraint_Decl_Template : String; Constraint_Init_Template : String; - Constraint_Spec : out Unbounded_String; + Constraint_Decl : out Unbounded_String; Constraint_Init : out Unbounded_String); -- Return the specification and initialization for a constraint @@ -56,9 +56,9 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Constraint (Ty_Prefix : String; Constraint : TGen.Types.Constraints.Constraint'Class; - Constraint_Spec_Template : String; + Constraint_Decl_Template : String; Constraint_Init_Template : String; - Constraint_Spec : out Unbounded_String; + Constraint_Decl : out Unbounded_String; Constraint_Init : out Unbounded_String) is Assocs : Translate_Set; @@ -327,16 +327,16 @@ package body TGen.Type_Representation is -- Now we can generate the constraint template - Constraint_Spec := Parse (Constraint_Spec_Template, Assocs); + Constraint_Decl := Parse (Constraint_Decl_Template, Assocs); Constraint_Init := Parse (Constraint_Init_Template, Assocs); end Collect_Info_For_Constraint; procedure Collect_Info_For_Anonymous_Typ (T : Anonymous_Typ'Class; - Anonymous_Typ_Spec_Template, Anonymous_Typ_Init_Template : String; - Constraint_Spec_Template, Constraint_Init_Template : String; - T_Spec, T_Init : out Unbounded_String); - -- Return the specification and initialization for an anonymous type + Anonymous_Typ_Decl_Template, Anonymous_Typ_Init_Template : String; + Constraint_Decl_Template, Constraint_Init_Template : String; + T_Decl, T_Init : out Unbounded_String); + -- Return the declarations and initialization for an anonymous type ------------------------------------ -- Collect_Info_For_Anonymous_Typ -- @@ -344,9 +344,9 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Anonymous_Typ (T : Anonymous_Typ'Class; - Anonymous_Typ_Spec_Template, Anonymous_Typ_Init_Template : String; - Constraint_Spec_Template, Constraint_Init_Template : String; - T_Spec, T_Init : out Unbounded_String) + Anonymous_Typ_Decl_Template, Anonymous_Typ_Init_Template : String; + Constraint_Decl_Template, Constraint_Init_Template : String; + T_Decl, T_Init : out Unbounded_String) is Ty_Prefix : constant String := T.Slug; Ty_Name : constant String := T.Fully_Qualified_Name; @@ -363,35 +363,35 @@ package body TGen.Type_Representation is if T.Subtype_Constraints /= null then declare - Constraint_Spec, Constraint_Init : Unbounded_String; + Constraint_Decl, Constraint_Init : Unbounded_String; begin Collect_Info_For_Constraint (Ty_Prefix, T.Subtype_Constraints.all, - Constraint_Spec_Template, + Constraint_Decl_Template, Constraint_Init_Template, - Constraint_Spec, + Constraint_Decl, Constraint_Init); Insert (Assocs, Assoc ("HAS_CONSTRAINT", True)); - Insert (Assocs, Assoc ("CONSTRAINT_SPEC", Constraint_Spec)); + Insert (Assocs, Assoc ("CONSTRAINT_SPEC", Constraint_Decl)); Insert (Assocs, Assoc ("CONSTRAINT_INIT", Constraint_Init)); end; end if; - T_Spec := Parse (Anonymous_Typ_Spec_Template, Assocs); + T_Decl := Parse (Anonymous_Typ_Decl_Template, Assocs); T_Init := Parse (Anonymous_Typ_Init_Template, Assocs); end Collect_Info_For_Anonymous_Typ; procedure Collect_Info_For_Instance_Typ (T : Instance_Typ'Class; - Instance_Typ_Spec_Template, Instance_Typ_Init_Template : String; - T_Spec, T_Init : out Unbounded_String); + Instance_Typ_Decl_Template, Instance_Typ_Init_Template : String; + T_Decl, T_Init : out Unbounded_String); procedure Collect_Info_For_Instance_Typ (T : Instance_Typ'Class; - Instance_Typ_Spec_Template, Instance_Typ_Init_Template : String; - T_Spec, T_Init : out Unbounded_String) + Instance_Typ_Decl_Template, Instance_Typ_Init_Template : String; + T_Decl, T_Init : out Unbounded_String) is Ty_Prefix : constant String := T.Slug; Ty_Name : constant String := T.Fully_Qualified_Name; @@ -404,20 +404,20 @@ package body TGen.Type_Representation is Insert (Assocs, Assoc ("ORIG_TY_PREFIX", T.Orig_Typ.Get.Slug)); - T_Spec := Parse (Instance_Typ_Spec_Template, Assocs); + T_Decl := Parse (Instance_Typ_Decl_Template, Assocs); T_Init := Parse (Instance_Typ_Init_Template, Assocs); end Collect_Info_For_Instance_Typ; procedure Collect_Info_For_Scalar_Typ (T : Scalar_Typ'Class; - Scalar_Typ_Spec_Template, Scalar_Typ_Init_Template : String; - Scalar_Typ_Spec : out Unbounded_String; + Scalar_Typ_Decl_Template, Scalar_Typ_Init_Template : String; + Scalar_Typ_Decl : out Unbounded_String; Scalar_Typ_Init : out Unbounded_String); procedure Collect_Info_For_Scalar_Typ (T : Scalar_Typ'Class; - Scalar_Typ_Spec_Template, Scalar_Typ_Init_Template : String; - Scalar_Typ_Spec : out Unbounded_String; + Scalar_Typ_Decl_Template, Scalar_Typ_Init_Template : String; + Scalar_Typ_Decl : out Unbounded_String; Scalar_Typ_Init : out Unbounded_String) is Ty_Prefix : constant String := T.Slug; @@ -446,7 +446,7 @@ package body TGen.Type_Representation is raise Program_Error; end if; - Scalar_Typ_Spec := Parse (Scalar_Typ_Spec_Template, Assocs); + Scalar_Typ_Decl := Parse (Scalar_Typ_Decl_Template, Assocs); Scalar_Typ_Init := Parse (Scalar_Typ_Init_Template, Assocs); end Collect_Info_For_Scalar_Typ; @@ -479,7 +479,7 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Component (T : TGen.Types.Typ'Class; - Anonymous_Spec : out Unbounded_String; + Anonymous_Decl : out Unbounded_String; Anonymous_Init : out Unbounded_String; Component_Ty_Prefix : out Unbounded_String); -- Return the specification and initialization for the instantiation of @@ -488,20 +488,20 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Variant (Variant : Variant_Part_Acc; Ty_Prefix : String; - Variant_Spec : in out Unbounded_String; + Variant_Decl : in out Unbounded_String; Variant_Init : in out Unbounded_String); -- Return the specification and initialization for a variant. Note that -- Variant_Index is incremented every time this procedure is called. procedure Collect_Info_For_Record (T : Record_Typ'Class; - Record_Typ_Spec : out Unbounded_String; + Record_Typ_Decl : out Unbounded_String; Record_Typ_Init : out Unbounded_String); -- Return the specification and initialization for a record type procedure Collect_Info_For_Array (T : Array_Typ'Class; - Array_Typ_Spec : out Unbounded_String; + Array_Typ_Decl : out Unbounded_String; Array_Typ_Init : out Unbounded_String); -- Return the specification and initialization for an array type @@ -511,7 +511,7 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Component (T : TGen.Types.Typ'Class; - Anonymous_Spec : out Unbounded_String; + Anonymous_Decl : out Unbounded_String; Anonymous_Init : out Unbounded_String; Component_Ty_Prefix : out Unbounded_String) is begin @@ -532,14 +532,22 @@ package body TGen.Type_Representation is (Trim (Anonymous_Ty_Index'Image)))); Collect_Info_For_Anonymous_Typ (Ano_Typ, - Anonymous_Typ_Spec_Template, + Anonymous_Typ_Decl_Template, Anonymous_Typ_Init_Template, - Constraint_Spec_Template, + Constraint_Decl_Template, Constraint_Init_Template, - Anonymous_Spec, + Anonymous_Decl, Anonymous_Init); Component_Ty_Prefix := +Ano_Typ.Slug; Anonymous_Ty_Index := Anonymous_Ty_Index + 1; + + -- Add the type reference declaration in the body declarative + -- part, as the only uses of this type reference will be + -- accessed through the parent record type ref. + + Anonymous_Decl := + Anonymous_Decl + & (+(Ano_Typ.Slug & "_Typ_Ref : TGen.Types.SP.Ref;")); end; else Component_Ty_Prefix := +T.Slug; @@ -553,7 +561,7 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Variant (Variant : Variant_Part_Acc; Ty_Prefix : String; - Variant_Spec : in out Unbounded_String; + Variant_Decl : in out Unbounded_String; Variant_Init : in out Unbounded_String) is Assocs : Translate_Set; @@ -572,7 +580,7 @@ package body TGen.Type_Representation is declare Low_Bounds, High_Bounds : Vector_Tag; Comp_Names, Comp_Types_Prefix : Vector_Tag; - Anonymous_Typ_Inits, Anonymous_Typ_Specs : Unbounded_String; + Anonymous_Typ_Inits, Anonymous_Typ_Decls : Unbounded_String; begin -- Fill in the component for this variant @@ -581,18 +589,18 @@ package body TGen.Type_Representation is use Component_Maps; Component_Name : constant Unbounded_String := Key (Comp); - Anonymous_Typ_Init, Anonymous_Typ_Spec : Unbounded_String; + Anonymous_Typ_Init, Anonymous_Typ_Decl : Unbounded_String; Component_Ty_Prefix : Unbounded_String; begin Collect_Info_For_Component (Element (Comp).Get, - Anonymous_Typ_Spec, + Anonymous_Typ_Decl, Anonymous_Typ_Init, Component_Ty_Prefix); Anonymous_Typ_Inits := Anonymous_Typ_Inits & Anonymous_Typ_Init; - Anonymous_Typ_Specs := - Anonymous_Typ_Specs & Anonymous_Typ_Spec; + Anonymous_Typ_Decls := + Anonymous_Typ_Decls & Anonymous_Typ_Decl; Comp_Names := Comp_Names & Component_Name; Comp_Types_Prefix := Comp_Types_Prefix & Component_Ty_Prefix; @@ -602,7 +610,7 @@ package body TGen.Type_Representation is -- Insert the anonymous type declarations Insert - (Assocs, Assoc ("ANONYMOUS_TYP_SPEC", Anonymous_Typ_Specs)); + (Assocs, Assoc ("ANONYMOUS_TYP_SPEC", Anonymous_Typ_Decls)); Insert (Assocs, Assoc ("ANONYMOUS_TYP_INIT", Anonymous_Typ_Inits)); Insert (Assocs, Assoc ("COMP_NAME", Comp_Names)); @@ -634,7 +642,7 @@ package body TGen.Type_Representation is Collect_Info_For_Variant (Choice.Variant, Ty_Prefix, - Variant_Spec, + Variant_Decl, Variant_Init); else Insert (Assocs, Assoc ("HAS_VARIANT", False)); @@ -642,9 +650,9 @@ package body TGen.Type_Representation is Insert (Assocs, Assoc ("VARIANT_CHOICE_NUMBER", I)); - Variant_Spec := - Variant_Spec - & String'(Parse (Variant_Choice_Spec_Template, Assocs)); + Variant_Decl := + Variant_Decl + & String'(Parse (Variant_Choice_Decl_Template, Assocs)); Variant_Init := Variant_Init & String'(Parse (Variant_Choice_Init_Template, Assocs)); @@ -666,8 +674,8 @@ package body TGen.Type_Representation is Insert (Assocs, Assoc ("VARIANT_CHOICE_NUMBER", Variant_Choice_Number)); Insert (Assocs, Assoc ("DISCR_NAME", Variant.Discr_Name)); - Variant_Spec := - Variant_Spec & String'(Parse (Variant_Spec_Template, Assocs)); + Variant_Decl := + Variant_Decl & String'(Parse (Variant_Decl_Template, Assocs)); Variant_Init := Variant_Init & String'(Parse (Variant_Init_Template, Assocs)); end; @@ -679,20 +687,20 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Record (T : Record_Typ'Class; - Record_Typ_Spec : out Unbounded_String; + Record_Typ_Decl : out Unbounded_String; Record_Typ_Init : out Unbounded_String) is Discr_Names : Vector_Tag; Discr_Types : Vector_Tag; Comp_Names : Vector_Tag; Comp_Types : Vector_Tag; - Anonymous_Typ_Inits, Anonymous_Typ_Specs : Unbounded_String; + Anonymous_Typ_Inits, Anonymous_Typ_Decls : Unbounded_String; begin if T in Discriminated_Record_Typ'Class then declare Disc_T : constant Discriminated_Record_Typ'Class := Discriminated_Record_Typ'Class (T); - Variant_Spec, Variant_Init : Unbounded_String; + Variant_Decl, Variant_Init : Unbounded_String; begin Insert (Assocs, Assoc ("RECORD_TYP", "Discriminated_Record_Typ")); @@ -704,18 +712,18 @@ package body TGen.Type_Representation is if Disc_T.Constrained then declare - Constraint_Spec, Constraint_Init : Unbounded_String; + Constraint_Decl, Constraint_Init : Unbounded_String; begin Collect_Info_For_Constraint (Ty_Prefix, Discriminant_Constraints' (Constraint_Map => Disc_T.Discriminant_Constraint), - Constraint_Spec_Template, + Constraint_Decl_Template, Constraint_Init_Template, - Constraint_Spec, + Constraint_Decl, Constraint_Init); Insert - (Assocs, Assoc ("CONSTRAINT_SPEC", Constraint_Spec)); + (Assocs, Assoc ("CONSTRAINT_SPEC", Constraint_Decl)); Insert (Assocs, Assoc ("CONSTRAINT_INIT", Constraint_Init)); end; @@ -727,13 +735,13 @@ package body TGen.Type_Representation is Collect_Info_For_Variant (Variant => Disc_T.Variant, Ty_Prefix => Ty_Prefix, - Variant_Spec => Variant_Spec, + Variant_Decl => Variant_Decl, Variant_Init => Variant_Init); Insert (Assocs, Assoc ("HAS_VARIANT_PART", True)); Insert - (Assocs, Assoc ("VARIANT_SPEC", Variant_Spec)); + (Assocs, Assoc ("VARIANT_SPEC", Variant_Decl)); Insert (Assocs, Assoc ("VARIANT_INIT", Variant_Init)); Insert @@ -745,17 +753,17 @@ package body TGen.Type_Representation is use Component_Maps; Discr_Name : constant Unbounded_String := Key (Cur); Discr_Ty_Prefix : Unbounded_String; - Anonymous_Typ_Init, Anonymous_Typ_Spec : Unbounded_String; + Anonymous_Typ_Init, Anonymous_Typ_Decl : Unbounded_String; begin Collect_Info_For_Component (Element (Cur).Get, - Anonymous_Typ_Spec, + Anonymous_Typ_Decl, Anonymous_Typ_Init, Discr_Ty_Prefix); Anonymous_Typ_Inits := Anonymous_Typ_Inits & Anonymous_Typ_Init; - Anonymous_Typ_Specs := - Anonymous_Typ_Specs & Anonymous_Typ_Spec; + Anonymous_Typ_Decls := + Anonymous_Typ_Decls & Anonymous_Typ_Decl; Discr_Names := Discr_Names & Discr_Name; Discr_Types := Discr_Types & Discr_Ty_Prefix; end; @@ -776,17 +784,17 @@ package body TGen.Type_Representation is use Component_Maps; Comp_Name : constant Unbounded_String := Key (Cur); Comp_Ty_Prefix : Unbounded_String; - Anonymous_Typ_Init, Anonymous_Typ_Spec : Unbounded_String; + Anonymous_Typ_Init, Anonymous_Typ_Decl : Unbounded_String; begin Collect_Info_For_Component (Element (Cur).Get, - Anonymous_Typ_Spec, + Anonymous_Typ_Decl, Anonymous_Typ_Init, Comp_Ty_Prefix); Anonymous_Typ_Inits := Anonymous_Typ_Inits & Anonymous_Typ_Init; - Anonymous_Typ_Specs := - Anonymous_Typ_Specs & Anonymous_Typ_Spec; + Anonymous_Typ_Decls := + Anonymous_Typ_Decls & Anonymous_Typ_Decl; Comp_Names := Comp_Names & Comp_Name; Comp_Types := Comp_Types & Comp_Ty_Prefix; end; @@ -794,13 +802,13 @@ package body TGen.Type_Representation is -- Print the templates - Insert (Assocs, Assoc ("ANONYMOUS_TYP_SPEC", Anonymous_Typ_Specs)); + Insert (Assocs, Assoc ("ANONYMOUS_TYP_SPEC", Anonymous_Typ_Decls)); Insert (Assocs, Assoc ("ANONYMOUS_TYP_INIT", Anonymous_Typ_Inits)); Insert (Assocs, Assoc ("COMP_NAME", Comp_Names)); Insert (Assocs, Assoc ("COMP_TYPE", Comp_Types)); Insert (Assocs, Assoc ("DISCR_NAME", Discr_Names)); Insert (Assocs, Assoc ("DISCR_TYPE", Discr_Types)); - Record_Typ_Spec := Parse (Record_Typ_Spec_Template, Assocs); + Record_Typ_Decl := Parse (Record_Typ_Decl_Template, Assocs); Record_Typ_Init := Parse (Record_Typ_Init_Template, Assocs); end Collect_Info_For_Record; @@ -811,11 +819,11 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Array (T : Array_Typ'Class; - Array_Typ_Spec : out Unbounded_String; + Array_Typ_Decl : out Unbounded_String; Array_Typ_Init : out Unbounded_String) is Index_Ty_Prefixes : Vector_Tag; - Anonymous_Typ_Inits, Anonymous_Typ_Specs : Unbounded_String; + Anonymous_Typ_Inits, Anonymous_Typ_Decls : Unbounded_String; begin -- Fill the number of dimension @@ -825,17 +833,17 @@ package body TGen.Type_Representation is declare Component_Ty_Prefix : Unbounded_String; - Anonymous_Typ_Init, Anonymous_Typ_Spec : Unbounded_String; + Anonymous_Typ_Init, Anonymous_Typ_Decl : Unbounded_String; begin Collect_Info_For_Component (T.Component_Type.Get, - Anonymous_Typ_Spec, + Anonymous_Typ_Decl, Anonymous_Typ_Init, Component_Ty_Prefix); Anonymous_Typ_Inits := Anonymous_Typ_Inits & Anonymous_Typ_Init; - Anonymous_Typ_Specs := - Anonymous_Typ_Specs & Anonymous_Typ_Spec; + Anonymous_Typ_Decls := + Anonymous_Typ_Decls & Anonymous_Typ_Decl; Insert (Assocs, Assoc ("COMPONENT_TY_PREFIX", Component_Ty_Prefix)); end; @@ -845,17 +853,17 @@ package body TGen.Type_Representation is for Index_T of T.Index_Types loop declare Index_Ty_Prefix : Unbounded_String; - Anonymous_Typ_Init, Anonymous_Typ_Spec : Unbounded_String; + Anonymous_Typ_Init, Anonymous_Typ_Decl : Unbounded_String; begin Collect_Info_For_Component (Index_T.Get, Anonymous_Typ_Init, - Anonymous_Typ_Spec, + Anonymous_Typ_Decl, Index_Ty_Prefix); Anonymous_Typ_Inits := Anonymous_Typ_Inits & Anonymous_Typ_Init; - Anonymous_Typ_Specs := - Anonymous_Typ_Specs & Anonymous_Typ_Spec; + Anonymous_Typ_Decls := + Anonymous_Typ_Decls & Anonymous_Typ_Decl; Index_Ty_Prefixes := Index_Ty_Prefixes & Index_Ty_Prefix; end; end loop; @@ -863,7 +871,7 @@ package body TGen.Type_Representation is -- Done with anonymous types - Insert (Assocs, Assoc ("ANONYMOUS_TYP_SPEC", Anonymous_Typ_Specs)); + Insert (Assocs, Assoc ("ANONYMOUS_TYP_SPEC", Anonymous_Typ_Decls)); Insert (Assocs, Assoc ("ANONYMOUS_TYP_INIT", Anonymous_Typ_Inits)); -- Deal with index constraints for constrained arrays @@ -872,25 +880,25 @@ package body TGen.Type_Representation is declare T_Const : constant Constrained_Array_Typ'Class := Constrained_Array_Typ'Class (T); - Constraint_Spec, Constraint_Init : Unbounded_String; + Constraint_Decl, Constraint_Init : Unbounded_String; begin Collect_Info_For_Constraint (Ty_Prefix, Index_Constraints' (T_Const.Num_Dims, T_Const.Index_Constraints), - Constraint_Spec_Template, + Constraint_Decl_Template, Constraint_Init_Template, - Constraint_Spec, + Constraint_Decl, Constraint_Init); Insert (Assocs, Assoc ("ARRAY_TYP", "Constrained_Array_Typ")); - Insert (Assocs, Assoc ("CONSTRAINT_SPEC", Constraint_Spec)); + Insert (Assocs, Assoc ("CONSTRAINT_SPEC", Constraint_Decl)); Insert (Assocs, Assoc ("CONSTRAINT_INIT", Constraint_Init)); end; else pragma Assert (T in Unconstrained_Array_Typ'Class); Insert (Assocs, Assoc ("ARRAY_TYP", "Unconstrained_Array_Typ")); end if; - Array_Typ_Spec := Parse (Array_Typ_Spec_Template, Assocs); + Array_Typ_Decl := Parse (Array_Typ_Decl_Template, Assocs); Array_Typ_Init := Parse (Array_Typ_Init_Template, Assocs); end Collect_Info_For_Array; @@ -941,56 +949,63 @@ package body TGen.Type_Representation is if Typ in Record_Typ'Class then declare - Record_Typ_Init, Record_Typ_Spec : Unbounded_String; + Record_Typ_Init, Record_Typ_Decl : Unbounded_String; begin Collect_Info_For_Record (Record_Typ'Class (Typ), - Record_Typ_Spec, + Record_Typ_Decl, Record_Typ_Init); - Put_Line (F_Spec, +Record_Typ_Spec); + Put_Line + (F_Spec, " " & Ty_Prefix & "_Typ_Ref : TGen.Types.SP.Ref;"); + Put_Line (F_Body, +Record_Typ_Decl); Init_Package_Code := Init_Package_Code & Record_Typ_Init; end; elsif Typ in Anonymous_Typ'Class then declare - Anonymous_Typ_Init, Anonymous_Typ_Spec : Unbounded_String; + Anonymous_Typ_Init, Anonymous_Typ_Decl : Unbounded_String; begin Collect_Info_For_Anonymous_Typ (Anonymous_Typ'Class (Typ), - Anonymous_Typ_Spec_Template, + Anonymous_Typ_Decl_Template, Anonymous_Typ_Init_Template, - Constraint_Spec_Template, + Constraint_Decl_Template, Constraint_Init_Template, - Anonymous_Typ_Spec, + Anonymous_Typ_Decl, Anonymous_Typ_Init); - - Put_Line (F_Spec, +Anonymous_Typ_Spec); + Put_Line (F_Spec, " " & Anonymous_Typ'Class (Typ).Slug + & "_Typ_Ref : SP.Ref;"); + Put_Line (F_Body, +Anonymous_Typ_Decl); Init_Package_Code := Init_Package_Code & Anonymous_Typ_Init; end; elsif Typ in Instance_Typ'Class then declare - Instance_Typ_Init, Instance_Typ_Spec : Unbounded_String; + Instance_Typ_Init, Instance_Typ_Decl : Unbounded_String; begin Collect_Info_For_Instance_Typ (Instance_Typ'Class (Typ), - Instance_Spec_Template, + Instance_Decl_Template, Instance_Init_Template, - Instance_Typ_Spec, + Instance_Typ_Decl, Instance_Typ_Init); - Put_Line (F_Spec, +Instance_Typ_Spec); + Put_Line + (F_Spec, " " & Ty_Prefix & "_Typ_Ref : TGen.Types.SP.Ref;"); + Put_Line (F_Body, +Instance_Typ_Decl); Init_Package_Code := Init_Package_Code & Instance_Typ_Init; end; elsif Typ in Array_Typ'Class then declare - Array_Typ_Init, Array_Typ_Spec : Unbounded_String; + Array_Typ_Init, Array_Typ_Decl : Unbounded_String; begin Collect_Info_For_Array (Array_Typ'Class (Typ), - Array_Typ_Spec, + Array_Typ_Decl, Array_Typ_Init); - Put_Line (F_Spec, +Array_Typ_Spec); + Put_Line + (F_Spec, " " & Ty_Prefix & "_Typ_Ref : TGen.Types.SP.Ref;"); + Put_Line (F_Body, +Array_Typ_Decl); Init_Package_Code := Init_Package_Code & Array_Typ_Init; end; @@ -1012,15 +1027,17 @@ package body TGen.Type_Representation is end if; declare - Scalar_Typ_Spec, Scalar_Typ_Init : Unbounded_String; + Scalar_Typ_Decl, Scalar_Typ_Init : Unbounded_String; begin Collect_Info_For_Scalar_Typ (Scalar_Typ'Class (Typ), - Scalar_Typ_Spec_Template, + Scalar_Typ_Decl_Template, Scalar_Typ_Init_Template, - Scalar_Typ_Spec, + Scalar_Typ_Decl, Scalar_Typ_Init); - Put_Line (F_Spec, +Scalar_Typ_Spec); + Put_Line + (F_Spec, " " & Ty_Prefix & "_Typ_Ref : TGen.Types.SP.Ref;"); + Put_Line (F_Body, +Scalar_Typ_Decl); Init_Package_Code := Init_Package_Code & Scalar_Typ_Init; end; diff --git a/src/tgen/tgen-types-translation.adb b/src/tgen/tgen-types-translation.adb index 3321a81e..0c07c482 100644 --- a/src/tgen/tgen-types-translation.adb +++ b/src/tgen/tgen-types-translation.adb @@ -233,6 +233,11 @@ package body TGen.Types.Translation is function "+" (Text : Unbounded_Text_Type) return Unbounded_String is (TGen.Types.Translation."+" (+Text)); + function Decl_Is_Fully_Private (N : Basic_Decl'Class) return Boolean; + -- Return whether N is fully private, i.e. whether the first declaration of + -- N is in a private part, and can't thus be used outside the private parts + -- of its declaration unit or child units. + -------------- -- PP_Cache -- -------------- @@ -323,6 +328,26 @@ package body TGen.Types.Translation is end; end New_Eval_As_Int; + --------------------------- + -- Decl_Is_Fully_Private -- + --------------------------- + + function Decl_Is_Fully_Private (N : Basic_Decl'Class) return Boolean is + First_Part : constant Basic_Decl := N.P_All_Parts (1); + Sem_Parent : Ada_Node := First_Part.P_Semantic_Parent; + begin + -- Consider that N is fully private if there is a private part node + -- among the chain of semantic parents of the first part of N. + + while not Sem_Parent.Is_Null loop + if Sem_Parent.Kind in Ada_Private_Part_Range then + return True; + end if; + Sem_Parent := Sem_Parent.P_Semantic_Parent; + end loop; + return False; + end Decl_Is_Fully_Private; + ------------------------ -- Translate_Int_Decl -- ------------------------ @@ -2740,6 +2765,8 @@ package body TGen.Types.Translation is Res.Res.Set (Anonymous_Typ' (Name => Ada_Identifier_Vectors.Empty_Vector, Last_Comp_Unit_Idx => 1, + Fully_Private => + Intermediate_Result.Res.Get.Fully_Private, Named_Ancestor => Intermediate_Result.Res, Subtype_Constraints => new Discrete_Range_Constraint' (Translate_Discrete_Range_Constraint @@ -2752,6 +2779,8 @@ package body TGen.Types.Translation is (Name => Ada_Identifier_Vectors.Empty_Vector, Last_Comp_Unit_Idx => 1, Named_Ancestor => Intermediate_Result.Res, + Fully_Private => + Intermediate_Result.Res.Get.Fully_Private, Subtype_Constraints => new TGen.Types.Constraints.Constraint'Class' (Translate_Real_Constraints @@ -2763,6 +2792,8 @@ package body TGen.Types.Translation is (Name => Ada_Identifier_Vectors.Empty_Vector, Last_Comp_Unit_Idx => 1, Named_Ancestor => Intermediate_Result.Res, + Fully_Private => + Intermediate_Result.Res.Get.Fully_Private, Subtype_Constraints => new Index_Constraints' (Translate_Index_Constraints (N.As_Subtype_Indication.F_Constraint, @@ -2780,6 +2811,8 @@ package body TGen.Types.Translation is (Name => Ada_Identifier_Vectors.Empty_Vector, Last_Comp_Unit_Idx => 1, Named_Ancestor => Intermediate_Result.Res, + Fully_Private => + Intermediate_Result.Res.Get.Fully_Private, Subtype_Constraints => new Discriminant_Constraints' (Translate_Discriminant_Constraints (N.As_Subtype_Indication.F_Constraint @@ -3022,6 +3055,7 @@ package body TGen.Types.Translation is if Specialized_Res.Success then Specialized_Res.Res.Get.Name := FQN; Specialized_Res.Res.Get.Last_Comp_Unit_Idx := Comp_Unit_Idx; + Specialized_Res.Res.Get.Fully_Private := Decl_Is_Fully_Private (N); end if; return Specialized_Res; @@ -3120,6 +3154,12 @@ package body TGen.Types.Translation is F_Typ.Subp_UID := +UID; + -- This function can only be used outside of the private part if none of + -- its parameter types are fully private. + + F_Typ.Fully_Private := + (for some Param of F_Typ.Component_Types => Param.Get.Fully_Private); + F_Typ_Ref.Set (F_Typ); Translation_Cache.Insert (F_Typ.Name, F_Typ_Ref); Result.Res := F_Typ_Ref; diff --git a/src/tgen/tgen_rts/tgen-types-constraints.adb b/src/tgen/tgen_rts/tgen-types-constraints.adb index 6ab92fdd..6a9a700f 100644 --- a/src/tgen/tgen_rts/tgen-types-constraints.adb +++ b/src/tgen/tgen_rts/tgen-types-constraints.adb @@ -311,6 +311,7 @@ package body TGen.Types.Constraints is end case; Res.Get.Name := Self.Named_Ancestor.Get.Name; Res.Get.Last_Comp_Unit_Idx := Self.Last_Comp_Unit_Idx; + Res.Get.Fully_Private := Self.Named_Ancestor.Get.Fully_Private; return Res; end As_Named_Typ; diff --git a/src/tgen/tgen_rts/tgen-types-record_types.adb b/src/tgen/tgen_rts/tgen-types-record_types.adb index baef8384..db159709 100644 --- a/src/tgen/tgen_rts/tgen-types-record_types.adb +++ b/src/tgen/tgen_rts/tgen-types-record_types.adb @@ -951,7 +951,8 @@ package body TGen.Types.Record_Types is (Name => Disc_Record.Name, Last_Comp_Unit_Idx => Disc_Record.Last_Comp_Unit_Idx, Component_Types => Components, - Static_Gen => Disc_Record.Static_Gen); + Static_Gen => Disc_Record.Static_Gen, + Fully_Private => Disc_Record.Fully_Private); begin Set_Field (Result, "components", diff --git a/src/tgen/tgen_rts/tgen-types.ads b/src/tgen/tgen_rts/tgen-types.ads index 300d81ba..decc8da3 100644 --- a/src/tgen/tgen_rts/tgen-types.ads +++ b/src/tgen/tgen_rts/tgen-types.ads @@ -50,6 +50,12 @@ package TGen.Types is -- Index, in Name, of the last identifier of the compilation unit in -- which this type is declared. + Fully_Private : Boolean; + -- Wether this type has no public declaration whatsoever, i.e. it cannot + -- be referenced outside of the private part of its declaration package, + -- or outside of the private part of child packages of its declaration + -- package. + end record; type Typ_Kind is (Invalid_Kind, diff --git a/testsuite/tests/test/marshalling_full_private/pkg.adb b/testsuite/tests/test/marshalling_full_private/pkg.adb new file mode 100644 index 00000000..693a698e --- /dev/null +++ b/testsuite/tests/test/marshalling_full_private/pkg.adb @@ -0,0 +1,13 @@ +package body Pkg is + + procedure Foo (P : P_Type) is + begin + null; + end Foo; + + procedure Bar (X : A) is + begin + null; + end Bar; + +end Pkg; diff --git a/testsuite/tests/test/marshalling_full_private/pkg.ads b/testsuite/tests/test/marshalling_full_private/pkg.ads new file mode 100644 index 00000000..85304609 --- /dev/null +++ b/testsuite/tests/test/marshalling_full_private/pkg.ads @@ -0,0 +1,20 @@ +package Pkg is + type P_Type is private; + procedure Foo (P : P_Type); + type A (<>) is private; + procedure Bar (X : A); +private + type I_Type is range 0 .. 1; + type P_Type is array (I_Type) of Boolean; + + type A (Discr : I_Type) is record + case Discr is + when 1 => + F1 : Integer; + F2 : Integer; + when others => + F3 : Integer; + end case; + end record; + +end Pkg; diff --git a/testsuite/tests/test/marshalling_full_private/prj.gpr b/testsuite/tests/test/marshalling_full_private/prj.gpr new file mode 100644 index 00000000..eb17a686 --- /dev/null +++ b/testsuite/tests/test/marshalling_full_private/prj.gpr @@ -0,0 +1,3 @@ +project Prj is + for Object_Dir use "obj"; +end Prj; diff --git a/testsuite/tests/test/marshalling_full_private/test.out b/testsuite/tests/test/marshalling_full_private/test.out new file mode 100644 index 00000000..8969a411 --- /dev/null +++ b/testsuite/tests/test/marshalling_full_private/test.out @@ -0,0 +1,13 @@ +pkg.ads:5:4: info: corresponding test PASSED +pkg.ads:5:4: info: corresponding test PASSED +pkg.ads:5:4: info: corresponding test PASSED +pkg.ads:5:4: info: corresponding test PASSED +pkg.ads:5:4: info: corresponding test PASSED +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:3:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:45) +pkg.ads:5:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:66) +12 tests run: 10 passed; 2 failed; 0 crashed. diff --git a/testsuite/tests/test/marshalling_full_private/test.sh b/testsuite/tests/test/marshalling_full_private/test.sh new file mode 100644 index 00000000..859ec834 --- /dev/null +++ b/testsuite/tests/test/marshalling_full_private/test.sh @@ -0,0 +1,3 @@ +gnattest -q -P prj.gpr --gen-test-vectors +gprbuild -q -P obj/gnattest/harness/test_driver.gpr +./obj/gnattest/harness/test_runner diff --git a/testsuite/tests/test/marshalling_full_private/test.yaml b/testsuite/tests/test/marshalling_full_private/test.yaml new file mode 100644 index 00000000..e0698230 --- /dev/null +++ b/testsuite/tests/test/marshalling_full_private/test.yaml @@ -0,0 +1,8 @@ +description: + Test that the support library does not violate visibility rules for types + with no visible part (i.e. only declared in the private part of the + package). + +driver: shell_script +control: + - [XFAIL, 'x86', 'Marshalling not working for 32bits (UB03-008)'] diff --git a/testsuite/tests/test/marshalling_priv_nested/test/foo.ads b/testsuite/tests/test/marshalling_priv_nested/test/foo.ads index 23b4aaf1..a6de65a7 100644 --- a/testsuite/tests/test/marshalling_priv_nested/test/foo.ads +++ b/testsuite/tests/test/marshalling_priv_nested/test/foo.ads @@ -5,5 +5,6 @@ package Foo is private type T is new Integer; end Bar; + use Bar; function Ident (X : T) return T is (Ident_Nested (X)); end Foo; diff --git a/testsuite/tests/test/tagada_marshalling/example_introspection.adb b/testsuite/tests/test/tagada_marshalling/example_introspection.adb index 5b67ae62..606b628e 100644 --- a/testsuite/tests/test/tagada_marshalling/example_introspection.adb +++ b/testsuite/tests/test/tagada_marshalling/example_introspection.adb @@ -13,6 +13,7 @@ with TGen.Types.Constraints; use TGen.Types.Constraints; with TGen.Types.Enum_Types; use TGen.Types.Enum_Types; with TGen.Types.Discrete_Types; use TGen.Types.Discrete_Types; with TGen.Types.Int_Types; use TGen.Types.Int_Types; +with TGen.Types.Real_Types; use TGen.Types.Real_Types; with TGen.Types.Record_Types; use TGen.Types.Record_Types; procedure Example_Introspection is @@ -34,13 +35,13 @@ procedure Example_Introspection is ------------- procedure Test_T1 is + T1_Typ : Signed_Int_Typ renames + Signed_Int_Typ (my_file_t1_Typ_Ref.Unchecked_Get.all); begin Assert - (my_file_t1_Typ.Range_Value.Min = - my_file_t1_Typ_Conversions.To_Big_Integer (1 - 2 ** 31)); + (T1_Typ.Range_Value.Min = To_Big_Integer (1 - 2 ** 31)); Assert - (my_file_t1_Typ.Range_Value.Max = - my_file_t1_Typ_Conversions.To_Big_Integer (2 ** 31 - 1)); + (T1_Typ.Range_Value.Max = To_Big_Integer (2 ** 31 - 1)); end Test_T1; -- Testing introspection over the following type: @@ -51,13 +52,13 @@ procedure Example_Introspection is ------------- procedure Test_T2 is + T2_Typ : Signed_Int_Typ renames + Signed_Int_Typ (my_file_t2_Typ_Ref.Unchecked_Get.all); begin Assert - (my_file_t2_Typ.Range_Value.Min = - my_file_t2_Typ_Conversions.To_Big_Integer (0)); + (T2_Typ.Range_Value.Min = To_Big_Integer (0)); Assert - (my_file_t2_Typ.Range_Value.Max = - my_file_t2_Typ_Conversions.To_Big_Integer (100)); + (T2_Typ.Range_Value.Max = To_Big_Integer (100)); end Test_T2; @@ -70,7 +71,8 @@ procedure Example_Introspection is procedure Test_T3 is begin - Assert (To_Integer (my_file_t3_Typ.Mod_Value) = 2**16); + Assert (To_Integer + (As_Mod_Int_Typ (my_file_t3_Typ_Ref).Mod_Value) = 2**16); end Test_T3; -- Testing introspection over the following type: @@ -83,31 +85,31 @@ procedure Example_Introspection is procedure Test_Constr_Array is + my_file_constr_array_Typ : Constrained_Array_Typ renames + Constrained_Array_Typ (my_file_constr_array_Typ_Ref.Unchecked_Get.all); Idx_Constraint : constant Index_Constraint := my_file_constr_array_Typ.Index_Constraints (1); Comp_Type : constant Signed_Int_Typ'Class := - As_Signed_Int_Typ - (As_Named_Typ - (As_Anonymous_Typ (my_file_constr_array_Typ.Component_Type))); + Signed_Int_Typ + (As_Named_Typ + (As_Anonymous_Typ (my_file_constr_array_Typ.Component_Type)) + .Unchecked_Get.all); begin Assert (my_file_constr_array_Typ.Num_Dims = 1); Assert - (Comp_Type.Range_Value.Min = - standard_integer_Typ_Conversions.To_Big_Integer (0)); + (Comp_Type.Range_Value.Min = To_Big_Integer (0)); Assert - (Comp_Type.Range_Value.Max = - standard_integer_Typ_Conversions.To_Big_Integer (Integer'Last)); + (Comp_Type.Range_Value.Max = To_Big_Integer (Integer'Last)); -- The bounds are contained in the index constraint and not in the -- index type, which is the base type. Assert - (Idx_Constraint.Discrete_Range.Low_Bound.Int_Val = - standard_positive_Typ_Conversions.To_Big_Integer (1)); + (Idx_Constraint.Discrete_Range.Low_Bound.Int_Val = To_Big_Integer (1)); Assert (Idx_Constraint.Discrete_Range.High_Bound.Int_Val = - standard_positive_Typ_Conversions.To_Big_Integer (10)); + To_Big_Integer (10)); end Test_Constr_Array; -- Testing introspection over the following type: @@ -119,6 +121,8 @@ procedure Example_Introspection is procedure Test_Matrix is + my_file_matrix_Typ : Unconstrained_Array_Typ renames + Unconstrained_Array_Typ (my_file_matrix_Typ_Ref.Unchecked_Get.all); First_Index_Type : constant Signed_Int_Typ'Class := As_Signed_Int_Typ (my_file_matrix_Typ.Index_Types (1)); Second_Index_Type : constant Char_Typ'Class := @@ -128,11 +132,9 @@ procedure Example_Introspection is begin Assert (my_file_matrix_Typ.Num_Dims = 2); Assert - (First_Index_Type.Range_Value.Min = - standard_natural_Typ_Conversions.To_Big_Integer (Natural'First)); + (First_Index_Type.Range_Value.Min = To_Big_Integer (Natural'First)); Assert - (First_Index_Type.Range_Value.Max = - standard_natural_Typ_Conversions.To_Big_Integer (Natural'Last)); + (First_Index_Type.Range_Value.Max = To_Big_Integer (Natural'Last)); -- TODO: add test for character type second index @@ -146,6 +148,8 @@ procedure Example_Introspection is ------------------ procedure Test_Fixed_1 is + my_file_fixed_1_Typ : Ordinary_Fixed_Typ renames + Ordinary_Fixed_Typ (my_file_fixed_1_Typ_Ref.Unchecked_Get.all); begin Assert (my_file_fixed_1_Typ.Delta_Value = From_Universal_Image ("0.0001")); @@ -164,6 +168,8 @@ procedure Example_Introspection is ------------------ procedure Test_Fixed_2 is + my_file_fixed_2_Typ : Decimal_Fixed_Typ renames + Decimal_Fixed_Typ (my_file_fixed_2_Typ_Ref.Unchecked_Get.all); begin Assert (my_file_fixed_2_Typ.Delta_Value = @@ -186,6 +192,8 @@ procedure Example_Introspection is procedure Test_Shape_Kind is use Enum_Literal_Maps; + my_file_shape_kind_Typ : Other_Enum_Typ renames + Other_Enum_Typ (my_file_shape_kind_Typ_Ref.Unchecked_Get.all); begin for Cur in my_file_shape_kind_Typ.Literals.Iterate loop Assert @@ -202,13 +210,13 @@ procedure Example_Introspection is ----------------------- procedure Test_Name_Size_Ty is + my_file_name_Size_ty_typ : Signed_Int_Typ renames + Signed_Int_Typ (my_file_name_size_ty_Typ_Ref.Unchecked_Get.all); begin Assert - (my_file_name_size_ty_Typ.Range_Value.Min = - my_file_name_size_ty_Typ_Conversions.To_Big_Integer (0)); + (my_file_name_size_ty_Typ.Range_Value.Min = To_Big_Integer (0)); Assert - (my_file_name_size_ty_Typ.Range_Value.Max = - my_file_name_size_ty_Typ_Conversions.To_Big_Integer (30)); + (my_file_name_size_ty_Typ.Range_Value.Max = To_Big_Integer (30)); end Test_Name_Size_Ty; -- Testing type introspection for the following type: @@ -242,7 +250,8 @@ procedure Example_Introspection is procedure Test_Shape is use Component_Maps; - Rec_Typ : constant Discriminated_Record_Typ'Class := my_file_shape_typ; + Rec_Typ : Discriminated_Record_Typ renames + Discriminated_Record_Typ (my_file_shape_typ_ref.Unchecked_Get.all); begin Assert (Rec_Typ.Mutable); @@ -573,7 +582,9 @@ procedure Example_Introspection is -- type Shape_Array is array (T2'Base range <>) of Shape; procedure Test_Shape_Array is - Arr_Typ : Unconstrained_Array_Typ renames my_file_shape_array_Typ; + Arr_Typ : Unconstrained_Array_Typ renames + Unconstrained_Array_Typ + (my_file_shape_array_Typ_Ref.Unchecked_Get.all); Index_Typ : Signed_Int_Typ renames Signed_Int_Typ (Arr_Typ.Index_Types (1).Unchecked_Get.all); begin @@ -591,7 +602,9 @@ procedure Example_Introspection is procedure Test_Small_Shape_Array is use Component_Maps; - Rec_Typ : Discriminated_Record_Typ renames my_file_small_shape_array_Typ; + Rec_Typ : Discriminated_Record_Typ renames + Discriminated_Record_Typ + (my_file_small_shape_array_Typ_Ref.Unchecked_Get.all); begin Assert (Rec_Typ.Discriminant_Types.Length = 1); Assert (+Key (Rec_Typ.Discriminant_Types.First) = "L"); @@ -643,6 +656,9 @@ procedure Example_Introspection is procedure Test_R is use Component_Maps; Index : Positive := 1; + my_file_r_Typ : Nondiscriminated_Record_Typ renames + Nondiscriminated_Record_Typ + (my_file_r_Typ_Ref.Unchecked_Get.all); begin for Comp_Cur in my_file_r_Typ.Component_Types.Iterate loop declare @@ -755,6 +771,8 @@ procedure Example_Introspection is procedure Test_R2 is use Component_Maps; + my_file_r2_typ : Nondiscriminated_Record_Typ renames + Nondiscriminated_Record_Typ (my_file_r2_Typ_Ref.Unchecked_Get.all); begin Assert (my_file_r2_Typ.Component_Types.Length = 2); for Comp_Cur in my_file_r2_Typ.Component_Types.iterate loop