Merge branch 'eyraud/118' into 'master'

TGen: fix generation of marshallers for scalar type with private ext

See merge request eng/ide/libadalang-tools!152

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@@

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@@

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@@

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@@

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_@);

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;

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@@

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;

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@@

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;

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@@

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@@

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@@

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);

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@@

src/tgen/templates/marshalling_templates/scalar_read_write.tmplt

@@ -16,24 +16,24 @@
      @_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()_@
      (@_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()_@)
      renames @_TY_PREFIX_@_Funs@_BASE_SUFFIX()_@.Read;
 
    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()_@)
      renames @_TY_PREFIX_@_Funs@_BASE_SUFFIX()_@.Write;

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,