diff --git a/src/tgen/templates/json_templates/composite_base_spec.tmplt b/src/tgen/templates/json_templates/composite_base_spec.tmplt
index 6c8436a5..dd5f38b6 100644
--- a/src/tgen/templates/json_templates/composite_base_spec.tmplt
+++ b/src/tgen/templates/json_templates/composite_base_spec.tmplt
@@ -5,7 +5,6 @@
@@-- @_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
@@ -15,4 +14,3 @@
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 84bd7ed2..75372573 100644
--- a/src/tgen/templates/json_templates/header_spec.tmplt
+++ b/src/tgen/templates/json_templates/header_spec.tmplt
@@ -9,7 +9,6 @@
@@-- @_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
@@ -19,4 +18,3 @@
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 cba31fa5..895a9240 100644
--- a/src/tgen/templates/json_templates/header_wrappers_spec.tmplt
+++ b/src/tgen/templates/json_templates/header_wrappers_spec.tmplt
@@ -4,7 +4,6 @@
@@-- @_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;
@@ -13,4 +12,3 @@
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 a141284c..699d77f7 100644
--- a/src/tgen/templates/json_templates/in_out_spec.tmplt
+++ b/src/tgen/templates/json_templates/in_out_spec.tmplt
@@ -4,7 +4,6 @@
@@-- @_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
@@ -13,4 +12,3 @@
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 18aa9f1e..796ffc9f 100644
--- a/src/tgen/templates/json_templates/scalar_base_spec.tmplt
+++ b/src/tgen/templates/json_templates/scalar_base_spec.tmplt
@@ -3,21 +3,15 @@
@@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type.
@@-- @_TY_NAME_@ Name of the current type or of its base type if we are
@@-- doing the generation for the base type.
-@@-- @_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()_@
(@_GLOBAL_PREFIX_@_JSON : in out TGen.JSON.JSON_Value;
- @_GLOBAL_PREFIX_@_V : @_TY_NAME_@;
- @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last);
+ @_GLOBAL_PREFIX_@_V : @_TY_NAME_@);
procedure @_TY_PREFIX_@_Read@_BASE_SUFFIX()_@
(@_GLOBAL_PREFIX_@_JSON : TGen.JSON.JSON_Value;
- @_GLOBAL_PREFIX_@_V : out @_TY_NAME_@;
- @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last);
-@@END_IF@@
+ @_GLOBAL_PREFIX_@_V : out @_TY_NAME_@);
diff --git a/src/tgen/templates/json_templates/scalar_read_write.tmplt b/src/tgen/templates/json_templates/scalar_read_write.tmplt
index 83575506..2bf57348 100644
--- a/src/tgen/templates/json_templates/scalar_read_write.tmplt
+++ b/src/tgen/templates/json_templates/scalar_read_write.tmplt
@@ -16,15 +16,11 @@
@_MARSHALLING_LIB_@.@_GENERIC_NAME_@_JSON (@_TY_NAME_@);
procedure @_TY_PREFIX_@_Write@_BASE_SUFFIX()_@
- (@_GLOBAL_PREFIX_@_JSON : in out TGen.JSON.JSON_Value;
- @_GLOBAL_PREFIX_@_V : @_TY_NAME_@;
- @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last)
+ (@_GLOBAL_PREFIX_@_JSON : in out TGen.JSON.JSON_Value;
+ @_GLOBAL_PREFIX_@_V : @_TY_NAME_@)
renames @_TY_PREFIX_@_Funs@_BASE_SUFFIX()_@_JSON.Write;
procedure @_TY_PREFIX_@_Read@_BASE_SUFFIX()_@
- (@_GLOBAL_PREFIX_@_JSON : TGen.JSON.JSON_Value;
- @_GLOBAL_PREFIX_@_V : out @_TY_NAME_@;
- @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last)
+ (@_GLOBAL_PREFIX_@_JSON : TGen.JSON.JSON_Value;
+ @_GLOBAL_PREFIX_@_V : out @_TY_NAME_@)
renames @_TY_PREFIX_@_Funs@_BASE_SUFFIX()_@_JSON.Read;
diff --git a/src/tgen/templates/marshalling_templates/composite_base_spec.tmplt b/src/tgen/templates/marshalling_templates/composite_base_spec.tmplt
index 7e2f34a7..e252c98a 100644
--- a/src/tgen/templates/marshalling_templates/composite_base_spec.tmplt
+++ b/src/tgen/templates/marshalling_templates/composite_base_spec.tmplt
@@ -14,7 +14,7 @@
@@-- 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
@@ -32,20 +32,3 @@
function @_TY_PREFIX_@_Size
(@_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(":", ":=")@@
- @_LPAR()_@@_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Min : @_DISCR_TYP_@ := @_DISCR_TYP_@'First;
- @_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Max : @_DISCR_TYP_@ := @_DISCR_TYP_@'Last@_RPAR()_@
-@@END_TABLE@@
-@@ELSIF@@ @_FIRST_NAME_@ /= ""
-@@TABLE'ALIGN_ON(":", ":=")@@
- @_LPAR()_@@_GLOBAL_PREFIX_@_@_FIRST_NAME_@ : @_BOUND_TYP_@'Base := @_BOUND_TYP_@'First;
- @_GLOBAL_PREFIX_@_@_LAST_NAME_@ : @_BOUND_TYP_@'Base := @_BOUND_TYP_@'Last@_RPAR()_@
-@@END_TABLE@@
-@@END_IF@@
- return Natural;
-@@END_IF@@
diff --git a/src/tgen/templates/marshalling_templates/composite_size_max.tmplt b/src/tgen/templates/marshalling_templates/composite_size_max.tmplt
new file mode 100644
index 00000000..50e3a9ff
--- /dev/null
+++ b/src/tgen/templates/marshalling_templates/composite_size_max.tmplt
@@ -0,0 +1,30 @@
+@@-- Template for the specification of the base subprograms for composite
+@@-- types.
+@@-- @_GLOBAL_PREFIX_@ Prefix used to prefix all entities local to the unit.
+@@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type.
+@@-- @_TY_NAME_@ Name of the current type.
+@@-- @_FIRST_NAME_@ Names of the components for the 'First attributes. Only
+@@-- set if the current type is an array.
+@@-- @_LAST_NAME_@ Same as above for the 'Last attributes.
+@@-- @_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
+
+ function @_TY_PREFIX_@_Size_Max
+@@IF@@ @_DISCR_NAME_@ /= ""
+@@TABLE'ALIGN_ON(":", ":=")@@
+ @_LPAR()_@@_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Min : @_DISCR_TYP_@ := @_DISCR_TYP_@'First;
+ @_GLOBAL_PREFIX_@_@_DISCR_NAME_@_D_Max : @_DISCR_TYP_@ := @_DISCR_TYP_@'Last@_RPAR()_@
+@@END_TABLE@@
+@@ELSIF@@ @_FIRST_NAME_@ /= ""
+@@TABLE'ALIGN_ON(":", ":=")@@
+ @_LPAR()_@@_GLOBAL_PREFIX_@_@_FIRST_NAME_@ : @_BOUND_TYP_@'Base := @_BOUND_TYP_@'First;
+ @_GLOBAL_PREFIX_@_@_LAST_NAME_@ : @_BOUND_TYP_@'Base := @_BOUND_TYP_@'Last@_RPAR()_@
+@@END_TABLE@@
+@@END_IF@@
+ return Natural;
diff --git a/src/tgen/templates/marshalling_templates/default_header_spec.tmplt b/src/tgen/templates/marshalling_templates/default_header_spec.tmplt
index 04a9e4b8..f1e23ef8 100644
--- a/src/tgen/templates/marshalling_templates/default_header_spec.tmplt
+++ b/src/tgen/templates/marshalling_templates/default_header_spec.tmplt
@@ -2,10 +2,8 @@
@@-- @_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_private.tmplt b/src/tgen/templates/marshalling_templates/header_private.tmplt
new file mode 100644
index 00000000..2306ca3b
--- /dev/null
+++ b/src/tgen/templates/marshalling_templates/header_private.tmplt
@@ -0,0 +1,25 @@
+@@-- Template for the private part of the header handling.
+@@-- @_GLOBAL_PREFIX_@ Prefix used to prefix all entities local to the unit.
+@@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type.
+@@-- @_TY_NAME_@ Name of the current type.
+@@-- @_FIRST_NAME_@ Names of the components for the 'First attributes. Only
+@@-- set if the current type is an array.
+@@-- @_LAST_NAME_@ Same as above for the 'Last attributes.
+@@-- @_DISCR_NAME_@ Same as above for the discriminants of records.
+@@-- @_COMP_TYP_@ Index types for arrays, and types of the discriminants for
+@@-- records.
+@@--
+ -- Definition of a header type and Input and Output functions for @_TY_NAME_@
+
+ type @_TY_PREFIX_@_Header_Type is record
+@@IF@@ @_FIRST_NAME_@ /= ""
+@@TABLE'ALIGN_ON(":")@@
+ @_FIRST_NAME_@ : @_COMP_TYP_@'Base;
+ @_LAST_NAME_@ : @_COMP_TYP_@'Base;
+@@END_TABLE@@
+@@ELSE@@
+@@TABLE'ALIGN_ON(":")@@
+ @_DISCR_NAME_@ : @_COMP_TYP_@;
+@@END_TABLE@@
+@@END_IF@@
+ end record;
diff --git a/src/tgen/templates/marshalling_templates/header_spec.tmplt b/src/tgen/templates/marshalling_templates/header_spec.tmplt
index 49c0ea09..3e3583ca 100644
--- a/src/tgen/templates/marshalling_templates/header_spec.tmplt
+++ b/src/tgen/templates/marshalling_templates/header_spec.tmplt
@@ -10,26 +10,8 @@
@@-- 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
-@@IF@@ @_FIRST_NAME_@ /= ""
-@@TABLE'ALIGN_ON(":")@@
- @_FIRST_NAME_@ : @_COMP_TYP_@'Base;
- @_LAST_NAME_@ : @_COMP_TYP_@'Base;
-@@END_TABLE@@
-@@ELSE@@
-@@TABLE'ALIGN_ON(":")@@
- @_DISCR_NAME_@ : @_COMP_TYP_@;
-@@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;
@@ -41,4 +23,3 @@
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 96af7473..64e9dbbb 100644
--- a/src/tgen/templates/marshalling_templates/header_wrappers_spec.tmplt
+++ b/src/tgen/templates/marshalling_templates/header_wrappers_spec.tmplt
@@ -4,7 +4,6 @@
@@-- @_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;
@@ -18,4 +17,3 @@
@_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 c8e98894..d8237f61 100644
--- a/src/tgen/templates/marshalling_templates/in_out_spec.tmplt
+++ b/src/tgen/templates/marshalling_templates/in_out_spec.tmplt
@@ -4,7 +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
@@ -24,4 +24,3 @@
(@_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_private.tmplt b/src/tgen/templates/marshalling_templates/scalar_base_private.tmplt
new file mode 100644
index 00000000..6bd54229
--- /dev/null
+++ b/src/tgen/templates/marshalling_templates/scalar_base_private.tmplt
@@ -0,0 +1,12 @@
+@@-- Template for the specification of the base subprograms for scalar types.
+@@-- @_GLOBAL_PREFIX_@ Prefix used to prefix all entities local to the unit.
+@@-- @_TY_PREFIX_@ Prefix used to prefix all entities for the current type.
+@@-- @_TY_NAME_@ Name of the current type or of its base type if we are
+@@-- doing the generation for the base type.
+@@-- @_FOR_BASE_@ True if we are doing the generation for the base type.
+@@--
+@@INCLUDE@@ util.tmplt
+ -- Private extensions of the functions encoding 'First and 'Last
+
+ function @_TY_PREFIX_@_First@_BASE_SUFFIX()_@ return @_TY_NAME_@ is (@_TY_NAME_@'First);
+ function @_TY_PREFIX_@_Last@_BASE_SUFFIX()_@ return @_TY_NAME_@ is (@_TY_NAME_@'Last);
diff --git a/src/tgen/templates/marshalling_templates/scalar_base_spec.tmplt b/src/tgen/templates/marshalling_templates/scalar_base_spec.tmplt
index 0e67ab1d..9901f1fe 100644
--- a/src/tgen/templates/marshalling_templates/scalar_base_spec.tmplt
+++ b/src/tgen/templates/marshalling_templates/scalar_base_spec.tmplt
@@ -6,27 +6,28 @@
@@-- @_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_@
+ function @_TY_PREFIX_@_First@_BASE_SUFFIX()_@ return @_TY_NAME_@;
+ function @_TY_PREFIX_@_Last@_BASE_SUFFIX()_@ return @_TY_NAME_@;
+
procedure @_TY_PREFIX_@_Write@_BASE_SUFFIX()_@
(@_GLOBAL_PREFIX_@_Stream : not null access Root_Stream_Type'Class;
@_GLOBAL_PREFIX_@_Buffer : in out Unsigned_8;
@_GLOBAL_PREFIX_@_Offset : in out Offset_Type;
@_GLOBAL_PREFIX_@_V : @_TY_NAME_@;
- @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last);
+ @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_PREFIX_@_First@_BASE_SUFFIX()_@;
+ @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_PREFIX_@_Last@_BASE_SUFFIX()_@);
procedure @_TY_PREFIX_@_Read@_BASE_SUFFIX()_@
(@_GLOBAL_PREFIX_@_Stream : not null access Root_Stream_Type'Class;
@_GLOBAL_PREFIX_@_Buffer : in out Unsigned_8;
@_GLOBAL_PREFIX_@_Offset : in out Offset_Type;
@_GLOBAL_PREFIX_@_V : out @_TY_NAME_@;
- @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last);
+ @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_PREFIX_@_First@_BASE_SUFFIX()_@;
+ @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_PREFIX_@_Last@_BASE_SUFFIX()_@);
function @_TY_PREFIX_@_Size@_BASE_SUFFIX()_@
- (@_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last)
+ (@_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_PREFIX_@_First@_BASE_SUFFIX()_@;
+ @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_PREFIX_@_Last@_BASE_SUFFIX()_@)
return Natural;
-@@END_IF@@
diff --git a/src/tgen/templates/marshalling_templates/scalar_read_write.tmplt b/src/tgen/templates/marshalling_templates/scalar_read_write.tmplt
index ad6dbc73..f818b4fe 100644
--- a/src/tgen/templates/marshalling_templates/scalar_read_write.tmplt
+++ b/src/tgen/templates/marshalling_templates/scalar_read_write.tmplt
@@ -16,8 +16,8 @@
@_MARSHALLING_LIB_@.@_GENERIC_NAME_@ (@_TY_NAME_@);
function @_TY_PREFIX_@_Size@_BASE_SUFFIX()_@
- (@_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last) return Natural
+ (@_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_PREFIX_@_First@_BASE_SUFFIX()_@;
+ @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_PREFIX_@_Last@_BASE_SUFFIX()_@) return Natural
renames @_TY_PREFIX_@_Funs@_BASE_SUFFIX()_@.Size;
procedure @_TY_PREFIX_@_Read@_BASE_SUFFIX()_@
@@ -25,8 +25,8 @@
@_GLOBAL_PREFIX_@_Buffer : in out Unsigned_8;
@_GLOBAL_PREFIX_@_Offset : in out Offset_Type;
@_GLOBAL_PREFIX_@_V : out @_TY_NAME_@;
- @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last)
+ @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_PREFIX_@_First@_BASE_SUFFIX()_@;
+ @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_PREFIX_@_Last@_BASE_SUFFIX()_@)
renames @_TY_PREFIX_@_Funs@_BASE_SUFFIX()_@.Read;
procedure @_TY_PREFIX_@_Write@_BASE_SUFFIX()_@
@@ -34,6 +34,6 @@
@_GLOBAL_PREFIX_@_Buffer : in out Unsigned_8;
@_GLOBAL_PREFIX_@_Offset : in out Offset_Type;
@_GLOBAL_PREFIX_@_V : @_TY_NAME_@;
- @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_NAME_@'First;
- @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_NAME_@'Last)
+ @_GLOBAL_PREFIX_@_First : @_TY_NAME_@ := @_TY_PREFIX_@_First@_BASE_SUFFIX()_@;
+ @_GLOBAL_PREFIX_@_Last : @_TY_NAME_@ := @_TY_PREFIX_@_Last@_BASE_SUFFIX()_@)
renames @_TY_PREFIX_@_Funs@_BASE_SUFFIX()_@.Write;
diff --git a/src/tgen/tgen-gen_strategies_utils.adb b/src/tgen/tgen-gen_strategies_utils.adb
index 04cf83e0..23f2e3fd 100644
--- a/src/tgen/tgen-gen_strategies_utils.adb
+++ b/src/tgen/tgen-gen_strategies_utils.adb
@@ -343,6 +343,7 @@ package body TGen.Gen_Strategies_Utils is
Name => R.Name,
Last_Comp_Unit_Idx => R.Last_Comp_Unit_Idx,
Fully_Private => R.Fully_Private,
+ Private_Extension => R.Private_Extension,
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 de6a2751..40b2b35e 100644
--- a/src/tgen/tgen-libgen.adb
+++ b/src/tgen/tgen-libgen.adb
@@ -299,35 +299,62 @@ package body TGen.Libgen is
-- the visibility of the type, and have the implementation details
-- generated in the correct order.
- for Part in Spec_Part loop
+ declare
+ Spec_Part, Private_Part, Body_Part : aliased Unbounded_String;
+
+ Spec_Part_Acc : US_Access;
+ -- This indicates where we should write the specification
+ -- declarations for the current type (private or public spec). It
+ -- points to Private_Part, if the type is fully private (i.e. the
+ -- parent package of its first part is a private package), or to
+ -- Spec_Part otherwise.
+
+ begin
for T of Sorted_Types loop
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.
+ -- 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
+ and then T.Get not in Instance_Typ'Class
then
+ Spec_Part_Acc :=
+ (if T.Get.Fully_Private
+ then Private_Part'Unrestricted_Access
+ else Spec_Part'Unrestricted_Access);
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);
+ .Generate_TC_Serializers_For_Subp
+ (Spec_Part_Acc,
+ Private_Part'Unrestricted_Access,
+ Body_Part'Unrestricted_Access,
+ T.Get,
+ TRD);
else
TGen.Marshalling.Binary_Marshallers
- .Generate_Marshalling_Functions_For_Typ
- (F_Spec, F_Body, T.Get, Part, TRD);
+ .Generate_Marshalling_Functions_For_Typ
+ (Spec_Part_Acc,
+ Private_Part'Unrestricted_Access,
+ Body_Part'Unrestricted_Access,
+ T.Get,
+ TRD);
TGen.Marshalling.JSON_Marshallers
- .Generate_Marshalling_Functions_For_Typ
- (F_Spec, F_Body, T.Get, Part, TRD);
+ .Generate_Marshalling_Functions_For_Typ
+ (Spec_Part_Acc,
+ Private_Part'Unrestricted_Access,
+ Body_Part'Unrestricted_Access,
+ T.Get,
+ TRD);
end if;
end if;
end loop;
- if Part = Pub then
- Put_Line (F_Spec, "private");
- end if;
- end loop;
+ Put_Line (F_Body, +Body_Part);
+ Put_Line (F_Spec, +Spec_Part);
+ Put_Line (F_Spec, "private");
+ Put_Line (F_Spec, +Private_Part);
+ end;
Put_Line (F_Body, "end " & Ada_Pack_Name & ";");
Close (F_Body);
diff --git a/src/tgen/tgen-marshalling-binary_marshallers.adb b/src/tgen/tgen-marshalling-binary_marshallers.adb
index e8c6b92f..c12e75ea 100644
--- a/src/tgen/tgen-marshalling-binary_marshallers.adb
+++ b/src/tgen/tgen-marshalling-binary_marshallers.adb
@@ -21,9 +21,13 @@
-- . --
------------------------------------------------------------------------------
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+
with GNAT.OS_Lib; use GNAT.OS_Lib;
with TGen.Templates;
+with TGen.Types.Array_Types; use TGen.Types.Array_Types;
+with TGen.Types.Record_Types; use TGen.Types.Record_Types;
package body TGen.Marshalling.Binary_Marshallers is
@@ -32,9 +36,10 @@ package body TGen.Marshalling.Binary_Marshallers is
--------------------------------------------
procedure Generate_Marshalling_Functions_For_Typ
- (F_Spec, F_Body : File_Type;
+ (Spec_Part : US_Access;
+ Private_Part : US_Access;
+ Body_Part : US_Access;
Typ : TGen.Types.Typ'Class;
- Part : Spec_Part;
Templates_Root_Dir : String)
is
TRD : constant String :=
@@ -57,9 +62,7 @@ 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),
- 8 => Assoc ("PUB_PART", Part = Pub),
- 9 => Assoc ("FULL_PRIV", Typ.Fully_Private)];
+ 7 => Assoc ("IS_SCALAR", Typ in Scalar_Typ'Class)];
function Component_Read
(Assocs : Translate_Table) return Unbounded_String;
@@ -77,7 +80,7 @@ package body TGen.Marshalling.Binary_Marshallers is
(Assocs : Translate_Table) return Unbounded_String;
procedure Print_Header (Assocs : Translate_Table);
procedure Print_Default_Header (Assocs : Translate_Table);
- procedure Print_Scalar (Assocs : Translate_Table);
+ procedure Print_Scalar (Assocs : Translate_Table; For_Base : Boolean);
procedure Print_Array (Assocs : Translate_Table);
procedure Print_Record (Assocs : Translate_Table);
procedure Print_Header_Wrappers (Assocs : Translate_Table);
@@ -169,12 +172,12 @@ package body TGen.Marshalling.Binary_Marshallers is
procedure Print_Header (Assocs : Translate_Table) is
begin
- Put_Line (F_Spec, Parse (Header_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
- Put_Line (F_Body, Parse (Header_Body_Template, Assocs));
- New_Line (F_Body);
- end if;
+ Put_Line (Spec_Part, Parse (Header_Spec_Template, Assocs));
+ New_Line (Spec_Part);
+ Put_Line (Private_Part, Parse (Header_Private_Template, Assocs));
+ New_Line (Private_Part);
+ Put_Line (Body_Part, Parse (Header_Body_Template, Assocs));
+ New_Line (Body_Part);
end Print_Header;
--------------------------
@@ -183,23 +186,28 @@ package body TGen.Marshalling.Binary_Marshallers is
procedure Print_Default_Header (Assocs : Translate_Table) is
begin
- Put_Line (F_Spec, Parse (Default_Header_Spec_Template, Assocs));
- New_Line (F_Spec);
+ Put_Line (Spec_Part, Parse (Default_Header_Spec_Template, Assocs));
+ New_Line (Spec_Part);
end Print_Default_Header;
------------------
-- Print_Scalar --
------------------
- procedure Print_Scalar (Assocs : Translate_Table) is
+ procedure Print_Scalar (Assocs : Translate_Table; For_Base : Boolean) is
begin
- Put_Line (F_Spec, Parse (Scalar_Base_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
+ if For_Base and then Typ.Private_Extension then
Put_Line
- (F_Body, Parse (Scalar_Read_Write_Template, Assocs));
- New_Line (F_Body);
+ (Private_Part, Parse (Scalar_Base_Spec_Template, Assocs));
+ New_Line (Private_Part);
+ else
+ Put_Line (Spec_Part, Parse (Scalar_Base_Spec_Template, Assocs));
+ New_Line (Spec_Part);
end if;
+ Put_Line (Private_Part, Parse (Scalar_Base_Private_Template, Assocs));
+ New_Line (Private_Part);
+ Put_Line (Body_Part, Parse (Scalar_Read_Write_Template, Assocs));
+ New_Line (Body_Part);
end Print_Scalar;
-----------------
@@ -207,19 +215,33 @@ package body TGen.Marshalling.Binary_Marshallers is
-----------------
procedure Print_Array (Assocs : Translate_Table) is
+
+ -- 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
- Put_Line (F_Spec, Parse (Composite_Base_Spec_Template, Assocs));
- New_Line (F_Spec);
- 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 (Spec_Part, Parse (Composite_Base_Spec_Template, Assocs));
+ New_Line (Spec_Part);
+
+ if Size_Max_Pub then
+ Put_Line (Spec_Part, Parse (Composite_Size_Max_Template, Assocs));
+ else
Put_Line
- (F_Body, Parse (Array_Size_Max_Template, Assocs));
- New_Line (F_Body);
+ (Private_Part, Parse (Composite_Size_Max_Template, Assocs));
end if;
+ Put_Line
+ (Body_Part, Parse (Array_Read_Write_Template, Assocs));
+ New_Line (Body_Part);
+ Put_Line (Body_Part, Parse (Array_Size_Template, Assocs));
+ New_Line (Body_Part);
+ Put_Line
+ (Body_Part, Parse (Array_Size_Max_Template, Assocs));
+ New_Line (Body_Part);
+
end Print_Array;
------------------
@@ -227,23 +249,35 @@ package body TGen.Marshalling.Binary_Marshallers is
------------------
procedure Print_Record (Assocs : Translate_Table) is
- Size_Max : constant String :=
- Parse (Record_Size_Max_Template, Assocs);
- pragma Unreferenced (Size_Max);
+
+ -- 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
- Put_Line (F_Spec, Parse (Composite_Base_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
- Put_Line
- (F_Body, Parse (Record_Read_Write_Template, Assocs));
- New_Line (F_Body);
+ Put_Line (Spec_Part, Parse (Composite_Base_Spec_Template, Assocs));
+ New_Line (Spec_Part);
+ if Size_Max_Pub then
+ Put_Line (Spec_Part, Parse (Composite_Size_Max_Template, Assocs));
+ else
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);
+ (Private_Part, Parse (Composite_Size_Max_Template, Assocs));
end if;
+ Put_Line
+ (Body_Part, Parse (Record_Read_Write_Template, Assocs));
+ New_Line (Body_Part);
+ Put_Line
+ (Body_Part, Parse (Record_Size_Template, Assocs));
+ New_Line (Body_Part);
+ Put_Line
+ (Body_Part, Parse (Record_Size_Max_Template, Assocs));
+ New_Line (Body_Part);
end Print_Record;
---------------------------
@@ -256,13 +290,11 @@ package body TGen.Marshalling.Binary_Marshallers is
pragma Unreferenced (Header_Wrapper);
begin
Put_Line
- (F_Spec, Parse (Header_Wrappers_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
- Put_Line
- (F_Body, Parse (Header_Wrappers_Body_Template, Assocs));
- New_Line (F_Body);
- end if;
+ (Spec_Part, Parse (Header_Wrappers_Spec_Template, Assocs));
+ New_Line (Spec_Part);
+ Put_Line
+ (Body_Part, Parse (Header_Wrappers_Body_Template, Assocs));
+ New_Line (Body_Part);
end Print_Header_Wrappers;
procedure Generate_Base_Functions_For_Typ_Instance is new
@@ -284,31 +316,26 @@ package body TGen.Marshalling.Binary_Marshallers is
begin
-- Generate the base functions for Typ
- Generate_Base_Functions_For_Typ_Instance (Typ, Part);
+ Generate_Base_Functions_For_Typ_Instance (Typ);
-- 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, Part, For_Base => True);
+ Generate_Base_Functions_For_Typ_Instance (Typ, For_Base => True);
end if;
-- Generate the Input and Output subprograms
Put_Line
- (F_Spec,
+ (Spec_Part,
Parse
(In_Out_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
- Put_Line
- (F_Body,
- Parse
- (In_Out_Body_Template, Assocs));
- New_Line (F_Body);
- end if;
+ New_Line (Spec_Part);
+ Put_Line (Body_Part, Parse (In_Out_Body_Template, Assocs));
+ New_Line (Body_Part);
+
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 793a2d79..99e74ba3 100644
--- a/src/tgen/tgen-marshalling-binary_marshallers.ads
+++ b/src/tgen/tgen-marshalling-binary_marshallers.ads
@@ -21,14 +21,13 @@
-- . --
------------------------------------------------------------------------------
-with Ada.Text_IO; use Ada.Text_IO;
-
package TGen.Marshalling.Binary_Marshallers is
procedure Generate_Marshalling_Functions_For_Typ
- (F_Spec, F_Body : File_Type;
+ (Spec_Part : US_Access;
+ Private_Part : US_Access;
+ Body_Part : US_Access;
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
diff --git a/src/tgen/tgen-marshalling-json_marshallers.adb b/src/tgen/tgen-marshalling-json_marshallers.adb
index 901dffa9..7633bd25 100644
--- a/src/tgen/tgen-marshalling-json_marshallers.adb
+++ b/src/tgen/tgen-marshalling-json_marshallers.adb
@@ -34,9 +34,10 @@ package body TGen.Marshalling.JSON_Marshallers is
--------------------------------------------
procedure Generate_Marshalling_Functions_For_Typ
- (F_Spec, F_Body : File_Type;
+ (Spec_Part : US_Access;
+ Private_Part : US_Access;
+ Body_Part : US_Access;
Typ : TGen.Types.Typ'Class;
- Part : Spec_Part;
Templates_Root_Dir : String)
is
TRD : constant String :=
@@ -59,9 +60,7 @@ 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),
- 8 => Assoc ("PUB_PART", Part = Pub),
- 9 => Assoc ("FULL_PRIV", Typ.Fully_Private)];
+ 7 => Assoc ("IS_SCALAR", Typ in Scalar_Typ'Class)];
function Component_Read
(Assocs : Translate_Table) return Unbounded_String;
@@ -79,7 +78,7 @@ package body TGen.Marshalling.JSON_Marshallers is
(Assocs : Translate_Table) return Unbounded_String;
procedure Print_Header (Assocs : Translate_Table);
procedure Print_Default_Header (Assocs : Translate_Table) is null;
- procedure Print_Scalar (Assocs : Translate_Table);
+ procedure Print_Scalar (Assocs : Translate_Table; For_Base : Boolean);
procedure Print_Array (Assocs : Translate_Table);
procedure Print_Record (Assocs : Translate_Table);
procedure Print_Header_Wrappers (Assocs : Translate_Table);
@@ -167,27 +166,30 @@ package body TGen.Marshalling.JSON_Marshallers is
procedure Print_Header (Assocs : Translate_Table) is
begin
- Put_Line (F_Spec, Parse (Header_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
- Put_Line (F_Body, Parse (Header_Body_Template, Assocs));
- New_Line (F_Body);
- end if;
+ Put_Line (Spec_Part, Parse (Header_Spec_Template, Assocs));
+ New_Line (Spec_Part);
+ Put_Line (Body_Part, Parse (Header_Body_Template, Assocs));
+ New_Line (Body_Part);
end Print_Header;
------------------
-- Print_Scalar --
------------------
- procedure Print_Scalar (Assocs : Translate_Table) is
+ procedure Print_Scalar
+ (Assocs : Translate_Table;
+ For_Base : Boolean with Unreferenced) is
begin
- Put_Line (F_Spec, Parse (Scalar_Base_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
+ if For_Base and then Typ.Private_Extension then
Put_Line
- (F_Body, Parse (Scalar_Read_Write_Template, Assocs));
- New_Line (F_Body);
+ (Private_Part, Parse (Scalar_Base_Spec_Template, Assocs));
+ New_Line (Private_Part);
+ else
+ Put_Line (Spec_Part, Parse (Scalar_Base_Spec_Template, Assocs));
+ New_Line (Spec_Part);
end if;
+ Put_Line (Body_Part, Parse (Scalar_Read_Write_Template, Assocs));
+ New_Line (Body_Part);
end Print_Scalar;
-----------------
@@ -196,13 +198,10 @@ package body TGen.Marshalling.JSON_Marshallers is
procedure Print_Array (Assocs : Translate_Table) is
begin
- Put_Line (F_Spec, Parse (Composite_Base_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
- Put_Line
- (F_Body, Parse (Array_Read_Write_Template, Assocs));
- New_Line (F_Body);
- end if;
+ Put_Line (Spec_Part, Parse (Composite_Base_Spec_Template, Assocs));
+ New_Line (Spec_Part);
+ Put_Line (Body_Part, Parse (Array_Read_Write_Template, Assocs));
+ New_Line (Body_Part);
end Print_Array;
------------------
@@ -211,13 +210,10 @@ package body TGen.Marshalling.JSON_Marshallers is
procedure Print_Record (Assocs : Translate_Table) is
begin
- Put_Line (F_Spec, Parse (Composite_Base_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
- Put_Line
- (F_Body, Parse (Record_Read_Write_Template, Assocs));
- New_Line (F_Body);
- end if;
+ Put_Line (Spec_Part, Parse (Composite_Base_Spec_Template, Assocs));
+ New_Line (Spec_Part);
+ Put_Line (Body_Part, Parse (Record_Read_Write_Template, Assocs));
+ New_Line (Body_Part);
end Print_Record;
---------------------------
@@ -227,13 +223,10 @@ package body TGen.Marshalling.JSON_Marshallers is
procedure Print_Header_Wrappers (Assocs : Translate_Table) is
begin
Put_Line
- (F_Spec, Parse (Header_Wrappers_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
- Put_Line
- (F_Body, Parse (Header_Wrappers_Body_Template, Assocs));
- New_Line (F_Body);
- end if;
+ (Spec_Part, Parse (Header_Wrappers_Spec_Template, Assocs));
+ New_Line (Spec_Part);
+ Put_Line (Body_Part, Parse (Header_Wrappers_Body_Template, Assocs));
+ New_Line (Body_Part);
end Print_Header_Wrappers;
procedure Generate_Base_Functions_For_Typ_Instance is new
@@ -255,31 +248,27 @@ package body TGen.Marshalling.JSON_Marshallers is
begin
-- Generate the base functions for Typ
- Generate_Base_Functions_For_Typ_Instance (Typ, Part);
+ Generate_Base_Functions_For_Typ_Instance (Typ);
-- 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, Part, For_Base => True);
+ Generate_Base_Functions_For_Typ_Instance (Typ, For_Base => True);
end if;
-- Generate the Input and Output subprograms
Put_Line
- (F_Spec,
+ (Spec_Part,
Parse
(In_Out_Spec_Template, Assocs));
- New_Line (F_Spec);
- if Part = Pub then
- Put_Line
- (F_Body,
- Parse
- (In_Out_Body_Template, Assocs));
- New_Line (F_Body);
- end if;
+ New_Line (Spec_Part);
+
+ Put_Line (Body_Part, Parse (In_Out_Body_Template, Assocs));
+ New_Line (Body_Part);
+
end Generate_Marshalling_Functions_For_Typ;
--------------------------------------
@@ -287,9 +276,10 @@ package body TGen.Marshalling.JSON_Marshallers is
--------------------------------------
procedure Generate_TC_Serializers_For_Subp
- (F_Spec, F_Body : File_Type;
+ (Spec_Part : US_Access;
+ Private_Part : US_Access;
+ Body_Part : US_Access;
FN_Typ : TGen.Types.Typ'Class;
- Part : Spec_Part;
Templates_Root_Dir : String)
is
use Component_Maps;
@@ -308,13 +298,6 @@ 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;
@@ -347,19 +330,21 @@ package body TGen.Marshalling.JSON_Marshallers is
-- First generate the spec, in the correct part of the spec
- if Part = Pub xor FN_Typ.Fully_Private then
+ if FN_Typ.Fully_Private then
+ Assocs.Insert (Assoc ("FOR_SPEC", True));
+ Put_Line (Private_Part, Parse (Function_TC_Dump_Template, Assocs));
+ New_Line (Private_Part);
+ else
Assocs.Insert (Assoc ("FOR_SPEC", True));
- Put_Line (F_Spec, Parse (Function_TC_Dump_Template, Assocs));
- New_Line (F_Spec);
+ Put_Line (Spec_Part, Parse (Function_TC_Dump_Template, Assocs));
+ New_Line (Spec_Part);
end if;
-- Then the 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;
+ Assocs.Insert (Assoc ("FOR_SPEC", False));
+ Put_Line (Body_Part, Parse (Function_TC_Dump_Template, Assocs));
+ New_Line (Body_Part);
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 4db9625d..16f92d54 100644
--- a/src/tgen/tgen-marshalling-json_marshallers.ads
+++ b/src/tgen/tgen-marshalling-json_marshallers.ads
@@ -21,14 +21,13 @@
-- . --
------------------------------------------------------------------------------
-with Ada.Text_IO; use Ada.Text_IO;
-
package TGen.Marshalling.JSON_Marshallers is
procedure Generate_Marshalling_Functions_For_Typ
- (F_Spec, F_Body : File_Type;
+ (Spec_Part : US_Access;
+ Private_Part : US_Access;
+ Body_Part : US_Access;
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
@@ -63,9 +62,10 @@ package TGen.Marshalling.JSON_Marshallers is
-- parameter passed to the marshallers as it makes the JSON bigger.
procedure Generate_TC_Serializers_For_Subp
- (F_Spec, F_Body : File_Type;
+ (Spec_Part : US_Access;
+ Private_Part : US_Access;
+ Body_Part : US_Access;
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:
@@ -79,12 +79,5 @@ 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 408bf3d4..20b8a164 100644
--- a/src/tgen/tgen-marshalling.adb
+++ b/src/tgen/tgen-marshalling.adb
@@ -21,6 +21,7 @@
-- . --
------------------------------------------------------------------------------
+with Ada.Characters.Latin_1;
with Ada.Numerics.Big_Numbers.Big_Integers;
use Ada.Numerics.Big_Numbers.Big_Integers;
with Ada.Strings; use Ada.Strings;
@@ -405,7 +406,6 @@ 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;
@@ -416,9 +416,7 @@ package body TGen.Marshalling is
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)];
+ 3 => Assoc ("TY_NAME", Ty_Name)];
type Component_Kind is (Array_Component, Record_Component);
@@ -795,7 +793,7 @@ package body TGen.Marshalling is
4 => Assoc ("FOR_BASE", For_Base)];
begin
- Print_Scalar (Assocs);
+ Print_Scalar (Assocs, For_Base);
end;
-- 3.2 For array types, we generate the calls for the components and we
@@ -813,14 +811,6 @@ 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
@@ -843,8 +833,7 @@ package body TGen.Marshalling is
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)];
+ 9 => Assoc ("BOUND_TYP", Comp_Typ_Tag)];
begin
Print_Array (Assocs);
@@ -869,18 +858,6 @@ package body TGen.Marshalling is
Variant_Write : Tag;
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
-- Construct the calls for the components
@@ -924,9 +901,7 @@ package body TGen.Marshalling is
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)];
-
+ 10 => Assoc ("DISCR_TYP", Comp_Typ_Tag)];
begin
Print_Record (Assocs);
end;
@@ -1111,4 +1086,22 @@ package body TGen.Marshalling is
return Prefix_For_Typ (To_Symbol (Typ_FQN, '_')) & "_Input";
end Input_Fname_For_Typ;
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (Str : US_Access; Added : String) is
+ begin
+ Append (Str.all, Added & Ada.Characters.Latin_1.LF);
+ end Put_Line;
+
+ --------------
+ -- New_Line --
+ --------------
+
+ procedure New_Line (Str : US_Access) is
+ begin
+ Append (Str.all, Ada.Characters.Latin_1.LF);
+ end New_Line;
+
end TGen.Marshalling;
diff --git a/src/tgen/tgen-marshalling.ads b/src/tgen/tgen-marshalling.ads
index 6ffa2e5a..5da0bd05 100644
--- a/src/tgen/tgen-marshalling.ads
+++ b/src/tgen/tgen-marshalling.ads
@@ -100,7 +100,8 @@ private
-- Output a default header type for constrained types that do not
-- normally require a header.
- with procedure Print_Scalar (Assocs : Translate_Table);
+ with procedure Print_Scalar
+ (Assocs : Translate_Table; For_Base : Boolean);
-- Output a scalar (un)marshallers
with procedure Print_Array (Assocs : Translate_Table);
@@ -114,9 +115,8 @@ private
-- the type's header and the type's component(s).
procedure Generate_Base_Functions_For_Typ
- (Typ : TGen.Types.Typ'Class;
- Part : Spec_Part := Pub;
- For_Base : Boolean := False)
+ (Typ : TGen.Types.Typ'Class;
+ For_Base : Boolean := False)
with Pre => (if For_Base then Typ in Scalar_Typ'Class)
and then Typ not in Anonymous_Typ'Class
and then Typ not in Instance_Typ'Class;
@@ -234,8 +234,9 @@ 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.
+
+ procedure Put_Line (Str : US_Access; Added : String);
+
+ procedure New_Line (Str : US_Access);
+
end TGen.Marshalling;
diff --git a/src/tgen/tgen-templates.ads b/src/tgen/tgen-templates.ads
index b24c6bc7..64cac809 100644
--- a/src/tgen/tgen-templates.ads
+++ b/src/tgen/tgen-templates.ads
@@ -38,8 +38,12 @@ package TGen.Templates is
Template_Folder & "component_size.tmplt";
Composite_Base_Spec_Template : constant String :=
Template_Folder & "composite_base_spec.tmplt";
+ Composite_Size_Max_Template : constant String :=
+ Template_Folder & "composite_size_max.tmplt";
Header_Body_Template : constant String :=
Template_Folder & "header_body.tmplt";
+ Header_Private_Template : constant String :=
+ Template_Folder & "header_private.tmplt";
Default_Header_Spec_Template : constant String :=
Template_Folder & "default_header_spec.tmplt";
Header_Spec_Template : constant String :=
@@ -60,6 +64,8 @@ package TGen.Templates is
Template_Folder & "record_size.tmplt";
Scalar_Base_Spec_Template : constant String :=
Template_Folder & "scalar_base_spec.tmplt";
+ Scalar_Base_Private_Template : constant String :=
+ Template_Folder & "scalar_base_private.tmplt";
Scalar_Read_Write_Template : constant String :=
Template_Folder & "scalar_read_write.tmplt";
Variant_Read_Write_Template : constant String :=
diff --git a/src/tgen/tgen-types-translation.adb b/src/tgen/tgen-types-translation.adb
index 4fc856d4..03bc1e83 100644
--- a/src/tgen/tgen-types-translation.adb
+++ b/src/tgen/tgen-types-translation.adb
@@ -2738,13 +2738,12 @@ package body TGen.Types.Translation is
function Translate
(N : LAL.Type_Expr; Verbose : Boolean := False) return Translation_Result
is
- Type_Decl_Node : Base_Type_Decl;
+ Type_Decl_Node : Base_Type_Decl;
Intermediate_Result : Translation_Result;
begin
if Kind (N) in Ada_Anonymous_Type_Range then
Type_Decl_Node := N.As_Anonymous_Type.F_Type_Decl.As_Base_Type_Decl;
else
-
-- For now, work on the full view of the type that we are trying to
-- translate. If this proves useless/problematic this can be
-- revisited.
@@ -2772,6 +2771,8 @@ package body TGen.Types.Translation is
Last_Comp_Unit_Idx => 1,
Fully_Private =>
Intermediate_Result.Res.Get.Fully_Private,
+ Private_Extension =>
+ Intermediate_Result.Res.Get.Private_Extension,
Named_Ancestor => Intermediate_Result.Res,
Subtype_Constraints => new Discrete_Range_Constraint'
(Translate_Discrete_Range_Constraint
@@ -2786,6 +2787,8 @@ package body TGen.Types.Translation is
Named_Ancestor => Intermediate_Result.Res,
Fully_Private =>
Intermediate_Result.Res.Get.Fully_Private,
+ Private_Extension =>
+ Intermediate_Result.Res.Get.Private_Extension,
Subtype_Constraints =>
new TGen.Types.Constraints.Constraint'Class'
(Translate_Real_Constraints
@@ -2799,6 +2802,8 @@ package body TGen.Types.Translation is
Named_Ancestor => Intermediate_Result.Res,
Fully_Private =>
Intermediate_Result.Res.Get.Fully_Private,
+ Private_Extension =>
+ Intermediate_Result.Res.Get.Private_Extension,
Subtype_Constraints => new Index_Constraints'
(Translate_Index_Constraints
(N.As_Subtype_Indication.F_Constraint,
@@ -2818,6 +2823,8 @@ package body TGen.Types.Translation is
Named_Ancestor => Intermediate_Result.Res,
Fully_Private =>
Intermediate_Result.Res.Get.Fully_Private,
+ Private_Extension =>
+ Intermediate_Result.Res.Get.Private_Extension,
Subtype_Constraints => new Discriminant_Constraints'
(Translate_Discriminant_Constraints
(N.As_Subtype_Indication.F_Constraint
@@ -3061,6 +3068,8 @@ package body TGen.Types.Translation is
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);
+ Specialized_Res.Res.Get.Private_Extension :=
+ Basic_Decl'(N.P_All_Parts (1)).As_Base_Type_Decl.P_Is_Private;
end if;
return Specialized_Res;
diff --git a/src/tgen/tgen-types-translation.ads b/src/tgen/tgen-types-translation.ads
index f23b7336..49e58e1d 100644
--- a/src/tgen/tgen-types-translation.ads
+++ b/src/tgen/tgen-types-translation.ads
@@ -28,6 +28,8 @@ with Ada.Containers.Hashed_Maps;
with Libadalang.Analysis;
+with TGen.Context; use TGen.Context;
+
package TGen.Types.Translation is
package LAL renames Libadalang.Analysis;
diff --git a/src/tgen/tgen_rts/tgen-marshalling_lib.adb b/src/tgen/tgen_rts/tgen-marshalling_lib.adb
index 97a22479..f33a1543 100644
--- a/src/tgen/tgen_rts/tgen-marshalling_lib.adb
+++ b/src/tgen/tgen_rts/tgen-marshalling_lib.adb
@@ -422,13 +422,7 @@ package body TGen.Marshalling_Lib is
-- Write --
-----------
- procedure Write
- (JSON : in out TGen.JSON.JSON_Value;
- V : T;
- First : T := T'First;
- Last : T := T'Last)
- is
- pragma Unreferenced (First, Last);
+ procedure Write (JSON : in out TGen.JSON.JSON_Value; V : T) is
begin
JSON := Create (T'Image (V));
end Write;
@@ -437,13 +431,7 @@ package body TGen.Marshalling_Lib is
-- Read --
----------
- procedure Read
- (JSON : TGen.JSON.JSON_Value;
- V : out T;
- First : T := T'First;
- Last : T := T'Last)
- is
- pragma Unreferenced (First, Last);
+ procedure Read (JSON : TGen.JSON.JSON_Value; V : out T) is
begin
V := T'Value (Get (JSON));
end Read;
@@ -536,13 +524,8 @@ package body TGen.Marshalling_Lib is
-----------
pragma Warnings (Off, "formal parameter * is read but never assigned");
- procedure Write
- (JSON : in out TGen.JSON.JSON_Value;
- V : T;
- First : T := T'First;
- Last : T := T'Last)
+ procedure Write (JSON : in out TGen.JSON.JSON_Value; V : T)
is
- pragma Unreferenced (First, Last);
V_Big_Real : constant TGen.Big_Reals.Big_Real :=
T_Conversions.To_Big_Real (V);
begin
@@ -555,13 +538,7 @@ package body TGen.Marshalling_Lib is
-- Read --
----------
- procedure Read
- (JSON : TGen.JSON.JSON_Value;
- V : out T;
- First : T := T'First;
- Last : T := T'Last)
- is
- pragma Unreferenced (First, Last);
+ procedure Read (JSON : TGen.JSON.JSON_Value; V : out T) is
begin
-- Decode the big real from the string encoded as a quotient string
@@ -658,13 +635,8 @@ package body TGen.Marshalling_Lib is
-----------
pragma Warnings (Off, "formal parameter * is read but never assigned");
- procedure Write
- (JSON : in out TGen.JSON.JSON_Value;
- V : T;
- First : T := T'First;
- Last : T := T'Last)
+ procedure Write (JSON : in out TGen.JSON.JSON_Value; V : T)
is
- pragma Unreferenced (First, Last);
V_Big_Real : constant TGen.Big_Reals.Big_Real :=
T_Conversions.To_Big_Real (V);
begin
@@ -677,13 +649,7 @@ package body TGen.Marshalling_Lib is
-- Read --
----------
- procedure Read
- (JSON : TGen.JSON.JSON_Value;
- V : out T;
- First : T := T'First;
- Last : T := T'Last)
- is
- pragma Unreferenced (First, Last);
+ procedure Read (JSON : TGen.JSON.JSON_Value; V : out T) is
begin
-- Decode the big real from the string encoded as a quotient string
@@ -1140,13 +1106,8 @@ package body TGen.Marshalling_Lib is
-----------
pragma Warnings (Off, "formal parameter * is read but never assigned");
- procedure Write
- (JSON : in out TGen.JSON.JSON_Value;
- V : T;
- First : T := T'First;
- Last : T := T'Last)
+ procedure Write (JSON : in out TGen.JSON.JSON_Value; V : T)
is
- pragma Unreferenced (First, Last);
V_Big_Real : constant TGen.Big_Reals.Big_Real :=
T_Conversions.To_Big_Real (V);
begin
@@ -1159,13 +1120,7 @@ package body TGen.Marshalling_Lib is
-- Read --
----------
- procedure Read
- (JSON : TGen.JSON.JSON_Value;
- V : out T;
- First : T := T'First;
- Last : T := T'Last)
- is
- pragma Unreferenced (First, Last);
+ procedure Read (JSON : TGen.JSON.JSON_Value; V : out T) is
begin
-- Decode the big real from the string encoded as a quotient string
diff --git a/src/tgen/tgen_rts/tgen-marshalling_lib.ads b/src/tgen/tgen_rts/tgen-marshalling_lib.ads
index c288031a..b852546f 100644
--- a/src/tgen/tgen_rts/tgen-marshalling_lib.ads
+++ b/src/tgen/tgen_rts/tgen-marshalling_lib.ads
@@ -129,17 +129,9 @@ package TGen.Marshalling_Lib is
type T is (<>);
package Read_Write_Discrete_JSON is
- procedure Write
- (JSON : in out TGen.JSON.JSON_Value;
- V : T;
- First : T := T'First;
- Last : T := T'Last);
+ procedure Write (JSON : in out TGen.JSON.JSON_Value; V : T);
- procedure Read
- (JSON : TGen.JSON.JSON_Value;
- V : out T;
- First : T := T'First;
- Last : T := T'Last);
+ procedure Read (JSON : TGen.JSON.JSON_Value; V : out T);
end Read_Write_Discrete_JSON;
@@ -174,17 +166,10 @@ package TGen.Marshalling_Lib is
type T is delta <> digits <>;
package Read_Write_Decimal_Fixed_JSON is
- procedure Write
- (JSON : in out TGen.JSON.JSON_Value;
- V : T;
- First : T := T'First;
- Last : T := T'Last);
+ procedure Write (JSON : in out TGen.JSON.JSON_Value; V : T);
procedure Read
- (JSON : TGen.JSON.JSON_Value;
- V : out T;
- First : T := T'First;
- Last : T := T'Last);
+ (JSON : TGen.JSON.JSON_Value; V : out T);
end Read_Write_Decimal_Fixed_JSON;
@@ -219,17 +204,9 @@ package TGen.Marshalling_Lib is
type T is delta <>;
package Read_Write_Ordinary_Fixed_JSON is
- procedure Write
- (JSON : in out TGen.JSON.JSON_Value;
- V : T;
- First : T := T'First;
- Last : T := T'Last);
+ procedure Write (JSON : in out TGen.JSON.JSON_Value; V : T);
- procedure Read
- (JSON : TGen.JSON.JSON_Value;
- V : out T;
- First : T := T'First;
- Last : T := T'Last);
+ procedure Read (JSON : TGen.JSON.JSON_Value; V : out T);
end Read_Write_Ordinary_Fixed_JSON;
@@ -274,17 +251,9 @@ package TGen.Marshalling_Lib is
type T is digits <>;
package Read_Write_Float_JSON is
- procedure Write
- (JSON : in out TGen.JSON.JSON_Value;
- V : T;
- First : T := T'First;
- Last : T := T'Last);
+ procedure Write (JSON : in out TGen.JSON.JSON_Value; V : T);
- procedure Read
- (JSON : TGen.JSON.JSON_Value;
- V : out T;
- First : T := T'First;
- Last : T := T'Last);
+ procedure Read (JSON : TGen.JSON.JSON_Value; V : out T);
end Read_Write_Float_JSON;
diff --git a/src/tgen/tgen_rts/tgen-strings.ads b/src/tgen/tgen_rts/tgen-strings.ads
index ca1975fd..fcd5f21a 100644
--- a/src/tgen/tgen_rts/tgen-strings.ads
+++ b/src/tgen/tgen_rts/tgen-strings.ads
@@ -190,4 +190,6 @@ package TGen.Strings is
(To_Filename (FQN) & ".json");
-- Convert FQN to a filename, and append the ".json" extension
+ type US_Access is access all Unbounded_String;
+
end TGen.Strings;
diff --git a/src/tgen/tgen_rts/tgen-types-record_types.adb b/src/tgen/tgen_rts/tgen-types-record_types.adb
index 1482495c..2def69f4 100644
--- a/src/tgen/tgen_rts/tgen-types-record_types.adb
+++ b/src/tgen/tgen_rts/tgen-types-record_types.adb
@@ -1086,7 +1086,8 @@ package body TGen.Types.Record_Types is
Last_Comp_Unit_Idx => Disc_Record.Last_Comp_Unit_Idx,
Component_Types => Components,
Static_Gen => Disc_Record.Static_Gen,
- Fully_Private => Disc_Record.Fully_Private);
+ Fully_Private => Disc_Record.Fully_Private,
+ Private_Extension => Disc_Record.Private_Extension);
R_Ref : SP.Ref;
begin
R_Ref.Set (R);
diff --git a/src/tgen/tgen_rts/tgen-types.ads b/src/tgen/tgen_rts/tgen-types.ads
index 459d99fa..d98b148e 100644
--- a/src/tgen/tgen_rts/tgen-types.ads
+++ b/src/tgen/tgen_rts/tgen-types.ads
@@ -56,6 +56,10 @@ package TGen.Types is
-- or outside of the private part of child packages of its declaration
-- package.
+ Private_Extension : Boolean;
+ -- Whether this type has a private extension. Note that if Fully_Private
+ -- is True, this field will be False.
+
end record;
type Typ_Kind is (Invalid_Kind,