gcc/ada/s-valrea.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                      S Y S T E M . V A L _ R E A L                       --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, 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 System.Powten_Table; use System.Powten_Table;
  33 with System.Val_Util;     use System.Val_Util;
  34 with System.Float_Control;
  35
  36 package body System.Val_Real is
  37
  38    ---------------
  39    -- Scan_Real --
  40    ---------------
  41
  42    function Scan_Real
  43      (Str : String;
  44       Ptr : not null access Integer;
  45       Max : Integer) return Long_Long_Float
  46    is
  47       P : Integer;
  48       --  Local copy of string pointer
  49
  50       Base : Long_Long_Float;
  51       --  Base value
  52
  53       Uval : Long_Long_Float;
  54       --  Accumulated float result
  55
  56       subtype Digs is Character range '0' .. '9';
  57       --  Used to check for decimal digit
  58
  59       Scale : Integer := 0;
  60       --  Power of Base to multiply result by
  61
  62       Start : Positive;
  63       --  Position of starting non-blank character
  64
  65       Minus : Boolean;
  66       --  Set to True if minus sign is present, otherwise to False
  67
  68       Bad_Base : Boolean := False;
  69       --  Set True if Base out of range or if out of range digit
  70
  71       After_Point : Natural := 0;
  72       --  Set to 1 after the point
  73
  74       Num_Saved_Zeroes : Natural := 0;
  75       --  This counts zeroes after the decimal point. A non-zero value means
  76       --  that this number of previously scanned digits are zero. If the end
  77       --  of the number is reached, these zeroes are simply discarded, which
  78       --  ensures that trailing zeroes after the point never affect the value
  79       --  (which might otherwise happen as a result of rounding). With this
  80       --  processing in place, we can ensure that, for example, we get the
  81       --  same exact result from 1.0E+49 and 1.0000000E+49. This is not
  82       --  necessarily required in a case like this where the result is not
  83       --  a machine number, but it is certainly a desirable behavior.
  84
  85       procedure Bad_Based_Value;
  86       pragma No_Return (Bad_Based_Value);
  87       --  Raise exception for bad based value
  88
  89       procedure Scanf;
  90       --  Scans integer literal value starting at current character position.
  91       --  For each digit encountered, Uval is multiplied by 10.0, and the new
  92       --  digit value is incremented. In addition Scale is decremented for each
  93       --  digit encountered if we are after the point (After_Point = 1). The
  94       --  longest possible syntactically valid numeral is scanned out, and on
  95       --  return P points past the last character. On entry, the current
  96       --  character is known to be a digit, so a numeral is definitely present.
  97
  98       ---------------------
  99       -- Bad_Based_Value --
 100       ---------------------
 101
 102       procedure Bad_Based_Value is
 103       begin
 104          raise Constraint_Error with
 105            "invalid based literal for 'Value";
 106       end Bad_Based_Value;
 107
 108       -----------
 109       -- Scanf --
 110       -----------
 111
 112       procedure Scanf is
 113          Digit : Natural;
 114
 115       begin
 116          loop
 117             Digit := Character'Pos (Str (P)) - Character'Pos ('0');
 118             P := P + 1;
 119
 120             --  Save up trailing zeroes after the decimal point
 121
 122             if Digit = 0 and then After_Point = 1 then
 123                Num_Saved_Zeroes := Num_Saved_Zeroes + 1;
 124
 125             --  Here for a non-zero digit
 126
 127             else
 128                --  First deal with any previously saved zeroes
 129
 130                if Num_Saved_Zeroes /= 0 then
 131                   while Num_Saved_Zeroes > Maxpow loop
 132                      Uval := Uval * Powten (Maxpow);
 133                      Num_Saved_Zeroes := Num_Saved_Zeroes - Maxpow;
 134                      Scale := Scale - Maxpow;
 135                   end loop;
 136
 137                   Uval := Uval * Powten (Num_Saved_Zeroes);
 138                   Scale := Scale - Num_Saved_Zeroes;
 139
 140                   Num_Saved_Zeroes := 0;
 141                end if;
 142
 143                --  Accumulate new digit
 144
 145                Uval := Uval * 10.0 + Long_Long_Float (Digit);
 146                Scale := Scale - After_Point;
 147             end if;
 148
 149             --  Done if end of input field
 150
 151             if P > Max then
 152                return;
 153
 154             --  Check next character
 155
 156             elsif Str (P) not in Digs then
 157                if Str (P) = '_' then
 158                   Scan_Underscore (Str, P, Ptr, Max, False);
 159                else
 160                   return;
 161                end if;
 162             end if;
 163          end loop;
 164       end Scanf;
 165
 166    --  Start of processing for System.Scan_Real
 167
 168    begin
 169       --  We call the floating-point processor reset routine so that we can
 170       --  be sure the floating-point processor is properly set for conversion
 171       --  calls. This is notably need on Windows, where calls to the operating
 172       --  system randomly reset the processor into 64-bit mode.
 173
 174       System.Float_Control.Reset;
 175
 176       Scan_Sign (Str, Ptr, Max, Minus, Start);
 177       P := Ptr.all;
 178       Ptr.all := Start;
 179
 180       --  If digit, scan numeral before point
 181
 182       if Str (P) in Digs then
 183          Uval := 0.0;
 184          Scanf;
 185
 186       --  Initial point, allowed only if followed by digit (RM 3.5(47))
 187
 188       elsif Str (P) = '.'
 189         and then P < Max
 190         and then Str (P + 1) in Digs
 191       then
 192          Uval := 0.0;
 193
 194       --  Any other initial character is an error
 195
 196       else
 197          raise Constraint_Error with
 198            "invalid character in 'Value string";
 199       end if;
 200
 201       --  Deal with based case
 202
 203       if P < Max and then (Str (P) = ':' or else Str (P) = '#') then
 204          declare
 205             Base_Char : constant Character := Str (P);
 206             Digit     : Natural;
 207             Fdigit    : Long_Long_Float;
 208
 209          begin
 210             --  Set bad base if out of range, and use safe base of 16.0,
 211             --  to guard against division by zero in the loop below.
 212
 213             if Uval < 2.0 or else Uval > 16.0 then
 214                Bad_Base := True;
 215                Uval := 16.0;
 216             end if;
 217
 218             Base := Uval;
 219             Uval := 0.0;
 220             P := P + 1;
 221
 222             --  Special check to allow initial point (RM 3.5(49))
 223
 224             if Str (P) = '.' then
 225                After_Point := 1;
 226                P := P + 1;
 227             end if;
 228
 229             --  Loop to scan digits of based number. On entry to the loop we
 230             --  must have a valid digit. If we don't, then we have an illegal
 231             --  floating-point value, and we raise Constraint_Error, note that
 232             --  Ptr at this stage was reset to the proper (Start) value.
 233
 234             loop
 235                if P > Max then
 236                   Bad_Based_Value;
 237
 238                elsif Str (P) in Digs then
 239                   Digit := Character'Pos (Str (P)) - Character'Pos ('0');
 240
 241                elsif Str (P) in 'A' .. 'F' then
 242                   Digit :=
 243                     Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
 244
 245                elsif Str (P) in 'a' .. 'f' then
 246                   Digit :=
 247                     Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
 248
 249                else
 250                   Bad_Based_Value;
 251                end if;
 252
 253                --  Save up trailing zeroes after the decimal point
 254
 255                if Digit = 0 and then After_Point = 1 then
 256                   Num_Saved_Zeroes := Num_Saved_Zeroes + 1;
 257
 258                --  Here for a non-zero digit
 259
 260                else
 261                   --  First deal with any previously saved zeroes
 262
 263                   if Num_Saved_Zeroes /= 0 then
 264                      Uval := Uval * Base ** Num_Saved_Zeroes;
 265                      Scale := Scale - Num_Saved_Zeroes;
 266                      Num_Saved_Zeroes := 0;
 267                   end if;
 268
 269                   --  Now accumulate the new digit
 270
 271                   Fdigit := Long_Long_Float (Digit);
 272
 273                   if Fdigit >= Base then
 274                      Bad_Base := True;
 275                   else
 276                      Scale := Scale - After_Point;
 277                      Uval := Uval * Base + Fdigit;
 278                   end if;
 279                end if;
 280
 281                P := P + 1;
 282
 283                if P > Max then
 284                   Bad_Based_Value;
 285
 286                elsif Str (P) = '_' then
 287                   Scan_Underscore (Str, P, Ptr, Max, True);
 288
 289                else
 290                   --  Skip past period after digit. Note that the processing
 291                   --  here will permit either a digit after the period, or the
 292                   --  terminating base character, as allowed in (RM 3.5(48))
 293
 294                   if Str (P) = '.' and then After_Point = 0 then
 295                      P := P + 1;
 296                      After_Point := 1;
 297
 298                      if P > Max then
 299                         Bad_Based_Value;
 300                      end if;
 301                   end if;
 302
 303                   exit when Str (P) = Base_Char;
 304                end if;
 305             end loop;
 306
 307             --  Based number successfully scanned out (point was found)
 308
 309             Ptr.all := P + 1;
 310          end;
 311
 312       --  Non-based case, check for being at decimal point now. Note that
 313       --  in Ada 95, we do not insist on a decimal point being present
 314
 315       else
 316          Base := 10.0;
 317          After_Point := 1;
 318
 319          if P <= Max and then Str (P) = '.' then
 320             P := P + 1;
 321
 322             --  Scan digits after point if any are present (RM 3.5(46))
 323
 324             if P <= Max and then Str (P) in Digs then
 325                Scanf;
 326             end if;
 327          end if;
 328
 329          Ptr.all := P;
 330       end if;
 331
 332       --  At this point, we have Uval containing the digits of the value as
 333       --  an integer, and Scale indicates the negative of the number of digits
 334       --  after the point. Base contains the base value (an integral value in
 335       --  the range 2.0 .. 16.0). Test for exponent, must be at least one
 336       --  character after the E for the exponent to be valid.
 337
 338       Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True);
 339
 340       --  At this point the exponent has been scanned if one is present and
 341       --  Scale is adjusted to include the exponent value. Uval contains the
 342       --  the integral value which is to be multiplied by Base ** Scale.
 343
 344       --  If base is not 10, use exponentiation for scaling
 345
 346       if Base /= 10.0 then
 347          Uval := Uval * Base ** Scale;
 348
 349       --  For base 10, use power of ten table, repeatedly if necessary
 350
 351       elsif Scale > 0 then
 352          while Scale > Maxpow loop
 353             Uval := Uval * Powten (Maxpow);
 354             Scale := Scale - Maxpow;
 355          end loop;
 356
 357          if Scale > 0 then
 358             Uval := Uval * Powten (Scale);
 359          end if;
 360
 361       elsif Scale < 0 then
 362          while (-Scale) > Maxpow loop
 363             Uval := Uval / Powten (Maxpow);
 364             Scale := Scale + Maxpow;
 365          end loop;
 366
 367          if Scale < 0 then
 368             Uval := Uval / Powten (-Scale);
 369          end if;
 370       end if;
 371
 372       --  Here is where we check for a bad based number
 373
 374       if Bad_Base then
 375          Bad_Based_Value;
 376
 377       --  If OK, then deal with initial minus sign, note that this processing
 378       --  is done even if Uval is zero, so that -0.0 is correctly interpreted.
 379
 380       else
 381          if Minus then
 382             return -Uval;
 383          else
 384             return Uval;
 385          end if;
 386       end if;
 387    end Scan_Real;
 388
 389    ----------------
 390    -- Value_Real --
 391    ----------------
 392
 393    function Value_Real (Str : String) return Long_Long_Float is
 394       V : Long_Long_Float;
 395       P : aliased Integer := Str'First;
 396    begin
 397       V := Scan_Real (Str, P'Access, Str'Last);
 398       Scan_Trailing_Blanks (Str, P);
 399       return V;
 400    end Value_Real;
 401
 402 end System.Val_Real;