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 65e73535..0c07c482 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; @@ -250,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 -- -------------- @@ -340,14 +328,32 @@ 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 -- ------------------------ 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 +366,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 +392,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 +424,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 +443,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 +451,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 +478,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 +506,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 +548,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 +559,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 +642,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 +663,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 +674,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 +783,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 +801,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 +811,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 +907,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 +1202,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 +1252,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 +1301,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 +1390,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 +1413,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 +1453,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 +1477,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 +1492,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 +2143,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 +2189,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 +2280,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 +2365,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 +2398,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 +2414,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); @@ -2840,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 @@ -2852,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 @@ -2863,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, @@ -2880,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 @@ -2979,6 +2912,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 +2929,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 +2941,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 +2983,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 +3005,60 @@ 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; + Specialized_Res.Res.Get.Fully_Private := Decl_Is_Fully_Private (N); + end if; + + return Specialized_Res; exception when Exc : Property_Error => @@ -3257,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 9c6458fb..6a9a700f 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,60 @@ 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; + 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