gcc/ada/libgnat/a-tifiio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                 A D A . T E X T _ I O . F I X E D _ 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 --  -------------------
  33 --  - Fixed point I/O -
  34 --  -------------------
  35
  36 --  The following text documents implementation details of the fixed point
  37 --  input/output routines in the GNAT runtime. The first part describes the
  38 --  general properties of fixed point types as defined by the Ada standard,
  39 --  including the Information Systems Annex.
  40
  41 --  Subsequently these are reduced to implementation constraints and the impact
  42 --  of these constraints on a few possible approaches to input/output is given.
  43 --  Based on this analysis, a specific implementation is selected for use in
  44 --  the GNAT runtime. Finally the chosen algorithms are analyzed numerically in
  45 --  order to provide user-level documentation on limits for range and precision
  46 --  of fixed point types as well as accuracy of input/output conversions.
  47
  48 --  -------------------------------------------
  49 --  - General Properties of Fixed Point Types -
  50 --  -------------------------------------------
  51
  52 --  Operations on fixed point types, other than input/output, are not important
  53 --  for the purpose of this document. Only the set of values that a fixed point
  54 --  type can represent and the input/output operations are significant.
  55
  56 --  Values
  57 --  ------
  58
  59 --  The set of values of a fixed point type comprise the integral multiples of
  60 --  a number called the small of the type. The small can be either a power of
  61 --  two, a power of ten or (if the implementation allows) an arbitrary strictly
  62 --  positive real value.
  63
  64 --  Implementations need to support ordinary fixed point types with a precision
  65 --  of at least 24 bits, and (in order to comply with the Information Systems
  66 --  Annex) decimal fixed point types with at least 18 digits. For the rest, no
  67 --  requirements exist for the minimal small and range that must be supported.
  68
  69 --  Operations
  70 --  ----------
  71
  72 --  [Wide_[Wide_]]Image attribute (see RM 3.5(27.1/2))
  73
  74 --          These attributes return a decimal real literal best approximating
  75 --          the value (rounded away from zero if halfway between) with a
  76 --          single leading character that is either a minus sign or a space,
  77 --          one or more digits before the decimal point (with no redundant
  78 --          leading zeros), a decimal point, and N digits after the decimal
  79 --          point. For a subtype S, the value of N is S'Aft, the smallest
  80 --          positive integer such that (10**N)*S'Delta is greater or equal to
  81 --          one, see RM 3.5.10(5).
  82
  83 --          For an arbitrary small, this means large number arithmetic needs
  84 --          to be performed.
  85
  86 --  Put (see RM A.10.9(22-26))
  87
  88 --          The requirements for Put add no extra constraints over the image
  89 --          attributes, although it would be nice to be able to output more
  90 --          than S'Aft digits after the decimal point for values of subtype S.
  91
  92 --  [Wide_[Wide_]]Value attribute (RM 3.5(39.1/2))
  93
  94 --          Since the input can be given in any base in the range 2..16,
  95 --          accurate conversion to a fixed point number may require
  96 --          arbitrary precision arithmetic if there is no limit on the
  97 --          magnitude of the small of the fixed point type.
  98
  99 --  Get (see RM A.10.9(12-21))
 100
 101 --          The requirements for Get are identical to those of the Value
 102 --          attribute.
 103
 104 --  ------------------------------
 105 --  - Implementation Constraints -
 106 --  ------------------------------
 107
 108 --  The requirements listed above for the input/output operations lead to
 109 --  significant complexity, if no constraints are put on supported smalls.
 110
 111 --  Implementation Strategies
 112 --  -------------------------
 113
 114 --  * Floating point arithmetic
 115 --  * Arbitrary-precision integer arithmetic
 116 --  * Fixed-precision integer arithmetic
 117
 118 --  Although it seems convenient to convert fixed point numbers to floating
 119 --  point and then print them, this leads to a number of restrictions.
 120 --  The first one is precision. The widest floating-point type generally
 121 --  available has 53 bits of mantissa. This means that Fine_Delta cannot
 122 --  be less than 2.0**(-53).
 123
 124 --  In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a 64-bit
 125 --  type. This means that a floating-point type with 64 bits of mantissa needs
 126 --  to be used, which is only generally available on the x86 architecture. It
 127 --  would still be possible to use multi-precision floating point to perform
 128 --  calculations using longer mantissas, but this is a much harder approach.
 129
 130 --  The base conversions needed for input/output of (non-decimal) fixed point
 131 --  types can be seen as pairs of integer multiplications and divisions.
 132
 133 --  Arbitrary-precision integer arithmetic would be suitable for the job at
 134 --  hand, but has the drawback that it is very heavy implementation-wise.
 135 --  Especially in embedded systems, where fixed point types are often used,
 136 --  it may not be desirable to require large amounts of storage and time
 137 --  for fixed I/O operations.
 138
 139 --  Fixed-precision integer arithmetic has the advantage of simplicity and
 140 --  speed. For the most common fixed point types this would be a perfect
 141 --  solution. The downside however may be a restricted set of acceptable
 142 --  fixed point types.
 143
 144 --  Implementation Choices
 145 --  ----------------------
 146
 147 --  The current implementation in the GNAT runtime uses fixed-precision integer
 148 --  arithmetic for fixed point types whose Small is the ratio of two integers
 149 --  whose magnitude is bounded relatively to the size of the mantissa, with a
 150 --  two-tiered approach for 32-bit and 64-bit fixed point types. For the other
 151 --  fixed point types, the implementation uses floating-point arithmetic.
 152
 153 --  The exact requirements of the algorithms are analyzed and documented along
 154 --  with the implementation in their respective units.
 155
 156 with Interfaces;
 157 with Ada.Text_IO.Fixed_Aux;
 158 with Ada.Text_IO.Float_Aux;
 159 with System.Img_Fixed_32; use System.Img_Fixed_32;
 160 with System.Img_Fixed_64; use System.Img_Fixed_64;
 161 with System.Img_LFlt;     use System.Img_LFlt;
 162 with System.Val_Fixed_32; use System.Val_Fixed_32;
 163 with System.Val_Fixed_64; use System.Val_Fixed_64;
 164 with System.Val_LFlt;     use System.Val_LFlt;
 165
 166 package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
 167
 168    --  Note: we still use the floating-point I/O routines for types whose small
 169    --  is not the ratio of two sufficiently small integers. This will result in
 170    --  inaccuracies for fixed point types that require more precision than is
 171    --  available in Long_Float.
 172
 173    subtype Int32 is Interfaces.Integer_32; use type Int32;
 174    subtype Int64 is Interfaces.Integer_64; use type Int64;
 175
 176    package Aux32 is new
 177      Ada.Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32);
 178
 179    package Aux64 is new
 180      Ada.Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
 181
 182    package Aux_Long_Float is new
 183      Ada.Text_IO.Float_Aux (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
 184
 185    --  Throughout this generic body, we distinguish between the case where type
 186    --  Int32 is OK and where type Int64 is OK. These boolean constants are used
 187    --  to test for this, such that only code for the relevant case is included
 188    --  in the instance; that's why the computation of their value must be fully
 189    --  static (although it is not a static expressions in the RM sense).
 190
 191    OK_Get_32 : constant Boolean :=
 192      Num'Base'Object_Size <= 32
 193        and then
 194          ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
 195            or else
 196           (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
 197            or else
 198           (Num'Small_Numerator <= 2**27
 199             and then Num'Small_Denominator <= 2**27));
 200    --  These conditions are derived from the prerequisites of System.Value_F
 201
 202    OK_Put_32 : constant Boolean :=
 203      Num'Base'Object_Size <= 32
 204        and then
 205          ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
 206            or else
 207           (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
 208            or else
 209           (Num'Small_Numerator < Num'Small_Denominator
 210             and then Num'Small_Denominator <= 2**27)
 211            or else
 212           (Num'Small_Denominator < Num'Small_Numerator
 213             and then Num'Small_Numerator <= 2**25));
 214    --  These conditions are derived from the prerequisites of System.Image_F
 215
 216    OK_Get_64 : constant Boolean :=
 217      Num'Base'Object_Size <= 64
 218        and then
 219          ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
 220            or else
 221           (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
 222            or else
 223           (Num'Small_Numerator <= 2**59
 224             and then Num'Small_Denominator <= 2**59));
 225    --  These conditions are derived from the prerequisites of System.Value_F
 226
 227    OK_Put_64 : constant Boolean :=
 228      Num'Base'Object_Size <= 64
 229        and then
 230          ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
 231            or else
 232           (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
 233            or else
 234           (Num'Small_Numerator < Num'Small_Denominator
 235             and then Num'Small_Denominator <= 2**59)
 236            or else
 237           (Num'Small_Denominator < Num'Small_Numerator
 238             and then Num'Small_Numerator <= 2**53));
 239    --  These conditions are derived from the prerequisites of System.Image_F
 240
 241    E : constant Natural := 63 - 32 * Boolean'Pos (OK_Put_32);
 242    --  T'Size - 1 for the selected Int{32,64}
 243
 244    F0 : constant Natural := 0;
 245    F1 : constant Natural :=
 246           F0 + 18 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+18);
 247    F2 : constant Natural :=
 248           F1 +  9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+9);
 249    F3 : constant Natural :=
 250           F2 +  5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+5);
 251    F4 : constant Natural :=
 252           F3 +  3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+3);
 253    F5 : constant Natural :=
 254           F4 +  2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+2);
 255    F6 : constant Natural :=
 256           F5 +  1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+1);
 257    --  Binary search for the number of digits - 1 before the decimal point of
 258    --  the product 2.0**E * Num'Small.
 259
 260    For0 : constant Natural := 2 + F6;
 261    --  Fore value for the fixed point type whose mantissa is Int{32,64} and
 262    --  whose small is Num'Small.
 263
 264    ---------
 265    -- Get --
 266    ---------
 267
 268    procedure Get
 269      (File  : File_Type;
 270       Item  : out Num;
 271       Width : Field := 0)
 272    is
 273       pragma Unsuppress (Range_Check);
 274
 275    begin
 276       if OK_Get_32 then
 277          Item := Num'Fixed_Value
 278                    (Aux32.Get (File, Width,
 279                                -Num'Small_Numerator,
 280                                -Num'Small_Denominator));
 281       elsif OK_Get_64 then
 282          Item := Num'Fixed_Value
 283                    (Aux64.Get (File, Width,
 284                                -Num'Small_Numerator,
 285                                -Num'Small_Denominator));
 286       else
 287          Aux_Long_Float.Get (File, Long_Float (Item), Width);
 288       end if;
 289
 290    exception
 291       when Constraint_Error => raise Data_Error;
 292    end Get;
 293
 294    procedure Get
 295      (Item  : out Num;
 296       Width : Field := 0)
 297    is
 298    begin
 299       Get (Current_In, Item, Width);
 300    end Get;
 301
 302    procedure Get
 303      (From : String;
 304       Item : out Num;
 305       Last : out Positive)
 306    is
 307       pragma Unsuppress (Range_Check);
 308
 309    begin
 310       if OK_Get_32 then
 311          Item := Num'Fixed_Value
 312                    (Aux32.Gets (From, Last,
 313                                 -Num'Small_Numerator,
 314                                 -Num'Small_Denominator));
 315       elsif OK_Get_64 then
 316          Item := Num'Fixed_Value
 317                    (Aux64.Gets (From, Last,
 318                                 -Num'Small_Numerator,
 319                                 -Num'Small_Denominator));
 320       else
 321          Aux_Long_Float.Gets (From, Long_Float (Item), Last);
 322       end if;
 323
 324    exception
 325       when Constraint_Error => raise Data_Error;
 326    end Get;
 327
 328    ---------
 329    -- Put --
 330    ---------
 331
 332    procedure Put
 333      (File : File_Type;
 334       Item : Num;
 335       Fore : Field := Default_Fore;
 336       Aft  : Field := Default_Aft;
 337       Exp  : Field := Default_Exp)
 338    is
 339    begin
 340       if OK_Put_32 then
 341          Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp,
 342                     -Num'Small_Numerator, -Num'Small_Denominator,
 343                     For0, Num'Aft);
 344       elsif OK_Put_64 then
 345          Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp,
 346                     -Num'Small_Numerator, -Num'Small_Denominator,
 347                     For0, Num'Aft);
 348       else
 349          Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
 350       end if;
 351    end Put;
 352
 353    procedure Put
 354      (Item : Num;
 355       Fore : Field := Default_Fore;
 356       Aft  : Field := Default_Aft;
 357       Exp  : Field := Default_Exp)
 358    is
 359    begin
 360       Put (Current_Out, Item, Fore, Aft, Exp);
 361    end Put;
 362
 363    procedure Put
 364      (To   : out String;
 365       Item : Num;
 366       Aft  : Field := Default_Aft;
 367       Exp  : Field := Default_Exp)
 368    is
 369    begin
 370       if OK_Put_32 then
 371          Aux32.Puts (To, Int32'Integer_Value (Item), Aft, Exp,
 372                      -Num'Small_Numerator, -Num'Small_Denominator,
 373                      For0, Num'Aft);
 374       elsif OK_Put_64 then
 375          Aux64.Puts (To, Int64'Integer_Value (Item), Aft, Exp,
 376                      -Num'Small_Numerator, -Num'Small_Denominator,
 377                      For0, Num'Aft);
 378       else
 379          Aux_Long_Float.Puts (To, Long_Float (Item), Aft, Exp);
 380       end if;
 381    end Put;
 382
 383 end Ada.Text_IO.Fixed_IO;