gcc/ada/libgnat/a-timoau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --              A D A . T E X T _ I O . M O D U L A R  _ A U X              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2019, 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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
  33
  34 with System.Img_BIU; use System.Img_BIU;
  35 with System.Img_Uns; use System.Img_Uns;
  36 with System.Img_LLB; use System.Img_LLB;
  37 with System.Img_LLU; use System.Img_LLU;
  38 with System.Img_LLW; use System.Img_LLW;
  39 with System.Img_WIU; use System.Img_WIU;
  40 with System.Val_Uns; use System.Val_Uns;
  41 with System.Val_LLU; use System.Val_LLU;
  42
  43 package body Ada.Text_IO.Modular_Aux is
  44
  45    use System.Unsigned_Types;
  46
  47    -----------------------
  48    -- Local Subprograms --
  49    -----------------------
  50
  51    procedure Load_Modular
  52      (File : File_Type;
  53       Buf  : out String;
  54       Ptr  : in out Natural);
  55    --  This is an auxiliary routine that is used to load an possibly signed
  56    --  modular literal value from the input file into Buf, starting at Ptr + 1.
  57    --  Ptr is left set to the last character stored.
  58
  59    -------------
  60    -- Get_LLU --
  61    -------------
  62
  63    procedure Get_LLU
  64      (File  : File_Type;
  65       Item  : out Long_Long_Unsigned;
  66       Width : Field)
  67    is
  68       Buf  : String (1 .. Field'Last);
  69       Stop : Integer := 0;
  70       Ptr  : aliased Integer := 1;
  71
  72    begin
  73       if Width /= 0 then
  74          Load_Width (File, Width, Buf, Stop);
  75          String_Skip (Buf, Ptr);
  76       else
  77          Load_Modular (File, Buf, Stop);
  78       end if;
  79
  80       Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop);
  81       Check_End_Of_Field (Buf, Stop, Ptr, Width);
  82    end Get_LLU;
  83
  84    -------------
  85    -- Get_Uns --
  86    -------------
  87
  88    procedure Get_Uns
  89      (File  : File_Type;
  90       Item  : out Unsigned;
  91       Width : Field)
  92    is
  93       Buf  : String (1 .. Field'Last);
  94       Stop : Integer := 0;
  95       Ptr  : aliased Integer := 1;
  96
  97    begin
  98       if Width /= 0 then
  99          Load_Width (File, Width, Buf, Stop);
 100          String_Skip (Buf, Ptr);
 101       else
 102          Load_Modular (File, Buf, Stop);
 103       end if;
 104
 105       Item := Scan_Unsigned (Buf, Ptr'Access, Stop);
 106       Check_End_Of_Field (Buf, Stop, Ptr, Width);
 107    end Get_Uns;
 108
 109    --------------
 110    -- Gets_LLU --
 111    --------------
 112
 113    procedure Gets_LLU
 114      (From : String;
 115       Item : out Long_Long_Unsigned;
 116       Last : out Positive)
 117    is
 118       Pos : aliased Integer;
 119
 120    begin
 121       String_Skip (From, Pos);
 122       Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last);
 123       Last := Pos - 1;
 124
 125    exception
 126       when Constraint_Error =>
 127          raise Data_Error;
 128    end Gets_LLU;
 129
 130    --------------
 131    -- Gets_Uns --
 132    --------------
 133
 134    procedure Gets_Uns
 135      (From : String;
 136       Item : out Unsigned;
 137       Last : out Positive)
 138    is
 139       Pos : aliased Integer;
 140
 141    begin
 142       String_Skip (From, Pos);
 143       Item := Scan_Unsigned (From, Pos'Access, From'Last);
 144       Last := Pos - 1;
 145
 146    exception
 147       when Constraint_Error =>
 148          raise Data_Error;
 149    end Gets_Uns;
 150
 151    ------------------
 152    -- Load_Modular --
 153    ------------------
 154
 155    procedure Load_Modular
 156      (File : File_Type;
 157       Buf  : out String;
 158       Ptr  : in out Natural)
 159    is
 160       Hash_Loc : Natural;
 161       Loaded   : Boolean;
 162
 163    begin
 164       Load_Skip (File);
 165
 166       --  Note: it is a bit strange to allow a minus sign here, but it seems
 167       --  consistent with the general behavior expected by the ACVC tests
 168       --  which is to scan past junk and then signal data error, see ACVC
 169       --  test CE3704F, case (6), which is for signed integer exponents,
 170       --  which seems a similar case.
 171
 172       Load (File, Buf, Ptr, '+', '-');
 173       Load_Digits (File, Buf, Ptr, Loaded);
 174
 175       if Loaded then
 176
 177          --  Deal with based case. We recognize either the standard '#' or the
 178          --  allowed alternative replacement ':' (see RM J.2(3)).
 179
 180          Load (File, Buf, Ptr, '#', ':', Loaded);
 181
 182          if Loaded then
 183             Hash_Loc := Ptr;
 184             Load_Extended_Digits (File, Buf, Ptr);
 185             Load (File, Buf, Ptr, Buf (Hash_Loc));
 186          end if;
 187
 188          Load (File, Buf, Ptr, 'E', 'e', Loaded);
 189
 190          if Loaded then
 191
 192             --  Note: it is strange to allow a minus sign, since the syntax
 193             --  does not, but that is what ACVC test CE3704F, case (6) wants
 194             --  for the signed case, and there seems no good reason to treat
 195             --  exponents differently for the signed and unsigned cases.
 196
 197             Load (File, Buf, Ptr, '+', '-');
 198             Load_Digits (File, Buf, Ptr);
 199          end if;
 200       end if;
 201    end Load_Modular;
 202
 203    -------------
 204    -- Put_LLU --
 205    -------------
 206
 207    procedure Put_LLU
 208      (File  : File_Type;
 209       Item  : Long_Long_Unsigned;
 210       Width : Field;
 211       Base  : Number_Base)
 212    is
 213       Buf : String (1 .. Field'Last);
 214       Ptr : Natural := 0;
 215
 216    begin
 217       if Base = 10 and then Width = 0 then
 218          Set_Image_Long_Long_Unsigned (Item, Buf, Ptr);
 219       elsif Base = 10 then
 220          Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr);
 221       else
 222          Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr);
 223       end if;
 224
 225       Put_Item (File, Buf (1 .. Ptr));
 226    end Put_LLU;
 227
 228    -------------
 229    -- Put_Uns --
 230    -------------
 231
 232    procedure Put_Uns
 233      (File  : File_Type;
 234       Item  : Unsigned;
 235       Width : Field;
 236       Base  : Number_Base)
 237    is
 238       Buf : String (1 .. Field'Last);
 239       Ptr : Natural := 0;
 240
 241    begin
 242       if Base = 10 and then Width = 0 then
 243          Set_Image_Unsigned (Item, Buf, Ptr);
 244       elsif Base = 10 then
 245          Set_Image_Width_Unsigned (Item, Width, Buf, Ptr);
 246       else
 247          Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr);
 248       end if;
 249
 250       Put_Item (File, Buf (1 .. Ptr));
 251    end Put_Uns;
 252
 253    --------------
 254    -- Puts_LLU --
 255    --------------
 256
 257    procedure Puts_LLU
 258      (To   : out String;
 259       Item : Long_Long_Unsigned;
 260       Base : Number_Base)
 261    is
 262       Buf : String (1 .. Field'Last);
 263       Ptr : Natural := 0;
 264
 265    begin
 266       if Base = 10 then
 267          Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr);
 268       else
 269          Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr);
 270       end if;
 271
 272       if Ptr > To'Length then
 273          raise Layout_Error;
 274       else
 275          To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
 276       end if;
 277    end Puts_LLU;
 278
 279    --------------
 280    -- Puts_Uns --
 281    --------------
 282
 283    procedure Puts_Uns
 284      (To   : out String;
 285       Item : Unsigned;
 286       Base : Number_Base)
 287    is
 288       Buf : String (1 .. Field'Last);
 289       Ptr : Natural := 0;
 290
 291    begin
 292       if Base = 10 then
 293          Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr);
 294       else
 295          Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr);
 296       end if;
 297
 298       if Ptr > To'Length then
 299          raise Layout_Error;
 300       else
 301          To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
 302       end if;
 303    end Puts_Uns;
 304
 305 end Ada.Text_IO.Modular_Aux;