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