[Ada] Ada2020: AI12-0304 Put_Image attrs of lang-def types

Message ID 20200727080551.GA36262@adacore.com
State New
Headers show
Series
  • [Ada] Ada2020: AI12-0304 Put_Image attrs of lang-def types
Related show

Commit Message

Pierre-Marie de Rodat July 27, 2020, 8:05 a.m.
Implement Put_Image for the random number packages and for
Ada.Containers.Vectors. More to come.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

	* libgnat/s-rannum.ads, libgnat/s-rannum.adb: Add Put_Image.
	This will be inherited by the language-defined packages
	Ada.Numerics.Discrete_Random and Ada.Numerics.Float_Random.
	* libgnat/a-convec.ads, libgnat/a-convec.adb: Add Put_Image.
	* libgnat/s-putima.ads: Add pragma Preelaborate, so this can be
	imported into containers packages.
	* libgnat/s-putima.adb: Move Digit to private part; otherwise
	reference to Base is illegal in Preelaborate generic.
	* exp_put_image.adb (Build_Record_Put_Image_Procedure): Use the
	base type.

Patch

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -520,8 +520,8 @@  package body Exp_Put_Image is
       Decl : out Node_Id;
       Pnam : out Entity_Id)
    is
-      pragma Assert (Typ = Base_Type (Typ));
-      pragma Assert (not Is_Unchecked_Union (Typ));
+      Btyp : constant Entity_Id := Base_Type (Typ);
+      pragma Assert (not Is_Unchecked_Union (Btyp));
 
       First_Time : Boolean := True;
 
@@ -694,7 +694,7 @@  package body Exp_Put_Image is
       Stms : constant List_Id := New_List;
       Rdef : Node_Id;
       Type_Decl : constant Node_Id :=
-        Declaration_Node (Base_Type (Underlying_Type (Typ)));
+        Declaration_Node (Base_Type (Underlying_Type (Btyp)));
 
    --  Start of processing for Build_Record_Put_Image_Procedure
 
@@ -732,8 +732,8 @@  package body Exp_Put_Image is
           Parameter_Associations => New_List
             (Make_Identifier (Loc, Name_S))));
 
-      Pnam := Make_Put_Image_Name (Loc, Typ);
-      Build_Put_Image_Proc (Loc, Typ, Decl, Pnam, Stms);
+      Pnam := Make_Put_Image_Name (Loc, Btyp);
+      Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms);
    end Build_Record_Put_Image_Procedure;
 
    -------------------------------


diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb
--- a/gcc/ada/libgnat/a-convec.adb
+++ b/gcc/ada/libgnat/a-convec.adb
@@ -31,6 +31,7 @@  with Ada.Containers.Generic_Array_Sort;
 with Ada.Unchecked_Deallocation;
 
 with System; use type System.Address;
+with System.Put_Images;
 
 package body Ada.Containers.Vectors with
   SPARK_Mode => Off
@@ -2299,6 +2300,31 @@  is
       end return;
    end Pseudo_Reference;
 
+   ---------------
+   -- Put_Image --
+   ---------------
+
+   procedure Put_Image
+     (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector)
+   is
+      First_Time : Boolean := True;
+      use System.Put_Images;
+   begin
+      Array_Before (S);
+
+      for X of V loop
+         if First_Time then
+            First_Time := False;
+         else
+            Simple_Array_Between (S);
+         end if;
+
+         Element_Type'Put_Image (S, X);
+      end loop;
+
+      Array_After (S);
+   end Put_Image;
+
    -------------------
    -- Query_Element --
    -------------------


diff --git a/gcc/ada/libgnat/a-convec.ads b/gcc/ada/libgnat/a-convec.ads
--- a/gcc/ada/libgnat/a-convec.ads
+++ b/gcc/ada/libgnat/a-convec.ads
@@ -36,6 +36,7 @@  with Ada.Iterator_Interfaces;
 with Ada.Containers.Helpers;
 private with Ada.Finalization;
 private with Ada.Streams;
+private with Ada.Strings.Text_Output;
 
 --  The language-defined generic package Containers.Vectors provides private
 --  types Vector and Cursor, and a set of operations for each type. A vector
@@ -696,7 +697,10 @@  private
       Elements : Elements_Access := null;
       Last     : Extended_Index := No_Index;
       TC       : aliased Tamper_Counts;
-   end record;
+   end record with Put_Image => Put_Image;
+
+   procedure Put_Image
+     (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector);
 
    overriding procedure Adjust (Container : in out Vector);
    overriding procedure Finalize (Container : in out Vector);


diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb
--- a/gcc/ada/libgnat/s-putima.adb
+++ b/gcc/ada/libgnat/s-putima.adb
@@ -46,13 +46,14 @@  package body System.Put_Images is
       pragma Assert (Base in 2 .. 36);
       procedure Put_Image (S : in out Sink'Class; X : Integer_Type);
       procedure Put_Image (S : in out Sink'Class; X : Unsigned_Type);
+   private
+      subtype Digit is Unsigned_Type range 0 .. Base - 1;
    end Generic_Integer_Images;
 
    package body Generic_Integer_Images is
 
       A : constant := Character'Pos ('a');
       Z : constant := Character'Pos ('0');
-      subtype Digit is Unsigned_Type range 0 .. Base - 1;
       function Digit_To_Character (X : Digit) return Character is
         (Character'Val (if X < 10 then X + Z else X + A - 10));
 


diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads
--- a/gcc/ada/libgnat/s-putima.ads
+++ b/gcc/ada/libgnat/s-putima.ads
@@ -47,6 +47,8 @@  package System.Put_Images is
    --  after them. See Exp_Put_Image in the compiler for details of these
    --  calls.
 
+   pragma Preelaborate;
+
    subtype Sink is Ada.Strings.Text_Output.Sink;
 
    procedure Put_Image_Integer (S : in out Sink'Class; X : Integer);


diff --git a/gcc/ada/libgnat/s-rannum.adb b/gcc/ada/libgnat/s-rannum.adb
--- a/gcc/ada/libgnat/s-rannum.adb
+++ b/gcc/ada/libgnat/s-rannum.adb
@@ -86,6 +86,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Ada.Strings.Text_Output.Utils;
 with Ada.Unchecked_Conversion;
 
 with System.Random_Seed;
@@ -639,6 +640,16 @@  is
       return Result;
    end Image;
 
+   ---------------
+   -- Put_Image --
+   ---------------
+
+   procedure Put_Image
+     (S : in out Strings.Text_Output.Sink'Class; V : State) is
+   begin
+      Strings.Text_Output.Utils.Put_String (S, Image (V));
+   end Put_Image;
+
    -----------
    -- Value --
    -----------


diff --git a/gcc/ada/libgnat/s-rannum.ads b/gcc/ada/libgnat/s-rannum.ads
--- a/gcc/ada/libgnat/s-rannum.ads
+++ b/gcc/ada/libgnat/s-rannum.ads
@@ -57,6 +57,8 @@ 
 
 with Interfaces;
 
+private with Ada.Strings.Text_Output;
+
 package System.Random_Numbers with
   SPARK_Mode => Off
 is
@@ -142,7 +144,10 @@  private
    --  Feedback distance from the current position
 
    subtype State_Val is Interfaces.Unsigned_32;
-   type State is array (0 .. N - 1) of State_Val;
+   type State is array (0 .. N - 1) of State_Val with Put_Image => Put_Image;
+
+   procedure Put_Image
+     (S : in out Ada.Strings.Text_Output.Sink'Class; V : State);
 
    type Writable_Access (Self : access Generator) is limited null record;
    --  Auxiliary type to make Generator a self-referential type