gcc/ada/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-2009, 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          Load (File, Buf, Ptr, '#', ':', Loaded);
 177
 178          if Loaded then
 179             Hash_Loc := Ptr;
 180             Load_Extended_Digits (File, Buf, Ptr);
 181             Load (File, Buf, Ptr, Buf (Hash_Loc));
 182          end if;
 183
 184          Load (File, Buf, Ptr, 'E', 'e', Loaded);
 185
 186          if Loaded then
 187
 188             --  Note: it is strange to allow a minus sign, since the syntax
 189             --  does not, but that is what ACVC test CE3704F, case (6) wants
 190             --  for the signed case, and there seems no good reason to treat
 191             --  exponents differently for the signed and unsigned cases.
 192
 193             Load (File, Buf, Ptr, '+', '-');
 194             Load_Digits (File, Buf, Ptr);
 195          end if;
 196       end if;
 197    end Load_Modular;
 198
 199    -------------
 200    -- Put_LLU --
 201    -------------
 202
 203    procedure Put_LLU
 204      (File  : File_Type;
 205       Item  : Long_Long_Unsigned;
 206       Width : Field;
 207       Base  : Number_Base)
 208    is
 209       Buf : String (1 .. Field'Last);
 210       Ptr : Natural := 0;
 211
 212    begin
 213       if Base = 10 and then Width = 0 then
 214          Set_Image_Long_Long_Unsigned (Item, Buf, Ptr);
 215       elsif Base = 10 then
 216          Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr);
 217       else
 218          Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr);
 219       end if;
 220
 221       Put_Item (File, Buf (1 .. Ptr));
 222    end Put_LLU;
 223
 224    -------------
 225    -- Put_Uns --
 226    -------------
 227
 228    procedure Put_Uns
 229      (File  : File_Type;
 230       Item  : Unsigned;
 231       Width : Field;
 232       Base  : Number_Base)
 233    is
 234       Buf : String (1 .. Field'Last);
 235       Ptr : Natural := 0;
 236
 237    begin
 238       if Base = 10 and then Width = 0 then
 239          Set_Image_Unsigned (Item, Buf, Ptr);
 240       elsif Base = 10 then
 241          Set_Image_Width_Unsigned (Item, Width, Buf, Ptr);
 242       else
 243          Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr);
 244       end if;
 245
 246       Put_Item (File, Buf (1 .. Ptr));
 247    end Put_Uns;
 248
 249    --------------
 250    -- Puts_LLU --
 251    --------------
 252
 253    procedure Puts_LLU
 254      (To   : out String;
 255       Item : Long_Long_Unsigned;
 256       Base : Number_Base)
 257    is
 258       Buf : String (1 .. Field'Last);
 259       Ptr : Natural := 0;
 260
 261    begin
 262       if Base = 10 then
 263          Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr);
 264       else
 265          Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr);
 266       end if;
 267
 268       if Ptr > To'Length then
 269          raise Layout_Error;
 270       else
 271          To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
 272       end if;
 273    end Puts_LLU;
 274
 275    --------------
 276    -- Puts_Uns --
 277    --------------
 278
 279    procedure Puts_Uns
 280      (To   : out String;
 281       Item : Unsigned;
 282       Base : Number_Base)
 283    is
 284       Buf : String (1 .. Field'Last);
 285       Ptr : Natural := 0;
 286
 287    begin
 288       if Base = 10 then
 289          Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr);
 290       else
 291          Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr);
 292       end if;
 293
 294       if Ptr > To'Length then
 295          raise Layout_Error;
 296       else
 297          To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
 298       end if;
 299    end Puts_Uns;
 300
 301 end Ada.Text_IO.Modular_Aux;