gcc/ada/libgnat/a-ztinio__128.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --      A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2024, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Wide_Wide_Text_IO.Integer_Aux;
  33 with System.Img_BIU;  use System.Img_BIU;
  34 with System.Img_Int;  use System.Img_Int;
  35 with System.Img_LLB;  use System.Img_LLB;
  36 with System.Img_LLI;  use System.Img_LLI;
  37 with System.Img_LLW;  use System.Img_LLW;
  38 with System.Img_LLLB; use System.Img_LLLB;
  39 with System.Img_LLLI; use System.Img_LLLI;
  40 with System.Img_LLLW; use System.Img_LLLW;
  41 with System.Img_WIU;  use System.Img_WIU;
  42 with System.Val_Int;  use System.Val_Int;
  43 with System.Val_LLI;  use System.Val_LLI;
  44 with System.Val_LLLI; use System.Val_LLLI;
  45 with System.WCh_Con;  use System.WCh_Con;
  46 with System.WCh_WtS;  use System.WCh_WtS;
  47
  48 package body Ada.Wide_Wide_Text_IO.Integer_IO is
  49
  50    package Aux_Int is new
  51      Ada.Wide_Wide_Text_IO.Integer_Aux
  52        (Integer,
  53         Scan_Integer,
  54         Set_Image_Integer,
  55         Set_Image_Width_Integer,
  56         Set_Image_Based_Integer);
  57
  58    package Aux_LLI is new
  59      Ada.Wide_Wide_Text_IO.Integer_Aux
  60        (Long_Long_Integer,
  61         Scan_Long_Long_Integer,
  62         Set_Image_Long_Long_Integer,
  63         Set_Image_Width_Long_Long_Integer,
  64         Set_Image_Based_Long_Long_Integer);
  65
  66    package Aux_LLLI is new
  67      Ada.Wide_Wide_Text_IO.Integer_Aux
  68        (Long_Long_Long_Integer,
  69         Scan_Long_Long_Long_Integer,
  70         Set_Image_Long_Long_Long_Integer,
  71         Set_Image_Width_Long_Long_Long_Integer,
  72         Set_Image_Based_Long_Long_Long_Integer);
  73
  74    Need_LLI  : constant Boolean := Num'Base'Size > Integer'Size;
  75    Need_LLLI : constant Boolean := Num'Base'Size > Long_Long_Integer'Size;
  76    --  Throughout this generic body, we distinguish between cases where type
  77    --  Integer is acceptable, where type Long_Long_Integer is acceptable and
  78    --  where type Long_Long_Long_Integer is needed. These boolean constants
  79    --  are used to test for these cases and since they are constant, only code
  80    --  for the relevant case will be included in the instance.
  81
  82    ---------
  83    -- Get --
  84    ---------
  85
  86    procedure Get
  87      (File  : File_Type;
  88       Item  : out Num;
  89       Width : Field := 0)
  90    is
  91       --  We depend on a range check to get Data_Error
  92
  93       pragma Unsuppress (Range_Check);
  94       pragma Unsuppress (Overflow_Check);
  95
  96    begin
  97       if Need_LLLI then
  98          Aux_LLLI.Get (File, Long_Long_Long_Integer (Item), Width);
  99       elsif Need_LLI then
 100          Aux_LLI.Get (File, Long_Long_Integer (Item), Width);
 101       else
 102          Aux_Int.Get (File, Integer (Item), Width);
 103       end if;
 104
 105    exception
 106       when Constraint_Error => raise Data_Error;
 107    end Get;
 108
 109    procedure Get
 110      (Item  : out Num;
 111       Width : Field := 0)
 112    is
 113    begin
 114       Get (Current_In, Item, Width);
 115    end Get;
 116
 117    procedure Get
 118      (From : Wide_Wide_String;
 119       Item : out Num;
 120       Last : out Positive)
 121    is
 122       --  We depend on a range check to get Data_Error
 123
 124       pragma Unsuppress (Range_Check);
 125       pragma Unsuppress (Overflow_Check);
 126
 127       S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
 128       --  String on which we do the actual conversion. Note that the method
 129       --  used for wide character encoding is irrelevant, since if there is
 130       --  a character outside the Standard.Character range then the call to
 131       --  Aux.Gets will raise Data_Error in any case.
 132
 133    begin
 134       if Need_LLLI then
 135          Aux_LLLI.Gets (S, Long_Long_Long_Integer (Item), Last);
 136       elsif Need_LLI then
 137          Aux_LLI.Gets (S, Long_Long_Integer (Item), Last);
 138       else
 139          Aux_Int.Gets (S, Integer (Item), Last);
 140       end if;
 141
 142    exception
 143       when Constraint_Error => raise Data_Error;
 144    end Get;
 145
 146    ---------
 147    -- Put --
 148    ---------
 149
 150    procedure Put
 151      (File  : File_Type;
 152       Item  : Num;
 153       Width : Field := Default_Width;
 154       Base  : Number_Base := Default_Base)
 155    is
 156    begin
 157       if Need_LLLI then
 158          Aux_LLLI.Put (File, Long_Long_Long_Integer (Item), Width, Base);
 159       elsif Need_LLI then
 160          Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base);
 161       else
 162          Aux_Int.Put (File, Integer (Item), Width, Base);
 163       end if;
 164    end Put;
 165
 166    procedure Put
 167      (Item  : Num;
 168       Width : Field := Default_Width;
 169       Base  : Number_Base := Default_Base)
 170    is
 171    begin
 172       Put (Current_Out, Item, Width, Base);
 173    end Put;
 174
 175    procedure Put
 176      (To   : out Wide_Wide_String;
 177       Item : Num;
 178       Base : Number_Base := Default_Base)
 179    is
 180       S : String (To'First .. To'Last);
 181
 182    begin
 183       if Need_LLLI then
 184          Aux_LLLI.Puts (S, Long_Long_Long_Integer (Item), Base);
 185       elsif Need_LLI then
 186          Aux_LLI.Puts (S, Long_Long_Integer (Item), Base);
 187       else
 188          Aux_Int.Puts (S, Integer (Item), Base);
 189       end if;
 190
 191       for J in S'Range loop
 192          To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
 193       end loop;
 194    end Put;
 195
 196 end Ada.Wide_Wide_Text_IO.Integer_IO;