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 Scanf;
  93       --  Scans integer literal value starting at current character position.
  94       --  For each digit encountered, Uval is multiplied by 10.0, and the new
  95       --  digit value is incremented. In addition Scale is decremented for each
  96       --  digit encountered if we are after the point (After_Point = 1). The
  97       --  longest possible syntactically valid numeral is scanned out, and on
  98       --  return P points past the last character. On entry, the current
  99       --  character is known to be a digit, so a numeral is definitely present.
 100
 101       -----------
 102       -- Scanf --
 103       -----------
 104
 105       procedure Scanf is
 106          Digit : Natural;
 107
 108       begin
 109          loop
 110             Digit := Character'Pos (Str (P)) - Character'Pos ('0');
 111             P := P + 1;
 112
 113             --  Save up trailing zeroes after the decimal point
 114
 115             if Digit = 0 and After_Point = 1 then
 116                Num_Saved_Zeroes := Num_Saved_Zeroes + 1;
 117
 118             --  Here for a non-zero digit
 119
 120             else
 121                --  First deal with any previously saved zeroes
 122
 123                if Num_Saved_Zeroes /= 0 then
 124                   while Num_Saved_Zeroes > Maxpow loop
 125                      Uval := Uval * Powten (Maxpow);
 126                      Num_Saved_Zeroes := Num_Saved_Zeroes - Maxpow;
 127                      Scale := Scale - Maxpow;
 128                   end loop;
 129
 130                   Uval := Uval * Powten (Num_Saved_Zeroes);
 131                   Scale := Scale - Num_Saved_Zeroes;
 132
 133                   Num_Saved_Zeroes := 0;
 134                end if;
 135
 136                --  Accumulate new digit
 137
 138                Uval := Uval * 10.0 + Long_Long_Float (Digit);
 139                Scale := Scale - After_Point;
 140             end if;
 141
 142             --  Done if end of input field
 143
 144             if P > Max then
 145                return;
 146
 147             --  Check next character
 148
 149             elsif Str (P) not in Digs then
 150                if Str (P) = '_' then
 151                   Scan_Underscore (Str, P, Ptr, Max, False);
 152                else
 153                   return;
 154                end if;
 155             end if;
 156          end loop;
 157       end Scanf;
 158
 159    --  Start of processing for System.Scan_Real
 160
 161    begin
 162       Reset;
 163       Scan_Sign (Str, Ptr, Max, Minus, Start);
 164       P := Ptr.all;
 165       Ptr.all := Start;
 166
 167       --  If digit, scan numeral before point
 168
 169       if Str (P) in Digs then
 170          Uval := 0.0;
 171          Scanf;
 172
 173       --  Initial point, allowed only if followed by digit (RM 3.5(47))
 174
 175       elsif Str (P) = '.'
 176         and then P < Max
 177         and then Str (P + 1) in Digs
 178       then
 179          Uval := 0.0;
 180
 181       --  Any other initial character is an error
 182
 183       else
 184          raise Constraint_Error;
 185       end if;
 186
 187       --  Deal with based case
 188
 189       if P < Max and then (Str (P) = ':' or else Str (P) = '#') then
 190          declare
 191             Base_Char : constant Character := Str (P);
 192             Digit     : Natural;
 193             Fdigit    : Long_Long_Float;
 194
 195          begin
 196             --  Set bad base if out of range, and use safe base of 16.0,
 197             --  to guard against division by zero in the loop below.
 198
 199             if Uval < 2.0 or else Uval > 16.0 then
 200                Bad_Base := True;
 201                Uval := 16.0;
 202             end if;
 203
 204             Base := Uval;
 205             Uval := 0.0;
 206             P := P + 1;
 207
 208             --  Special check to allow initial point (RM 3.5(49))
 209
 210             if Str (P) = '.' then
 211                After_Point := 1;
 212                P := P + 1;
 213             end if;
 214
 215             --  Loop to scan digits of based number. On entry to the loop we
 216             --  must have a valid digit. If we don't, then we have an illegal
 217             --  floating-point value, and we raise Constraint_Error, note that
 218             --  Ptr at this stage was reset to the proper (Start) value.
 219
 220             loop
 221                if P > Max then
 222                   raise Constraint_Error;
 223
 224                elsif Str (P) in Digs then
 225                   Digit := Character'Pos (Str (P)) - Character'Pos ('0');
 226
 227                elsif Str (P) in 'A' .. 'F' then
 228                   Digit :=
 229                     Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
 230
 231                elsif Str (P) in 'a' .. 'f' then
 232                   Digit :=
 233                     Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
 234
 235                else
 236                   raise Constraint_Error;
 237                end if;
 238
 239                --  Save up trailing zeroes after the decimal point
 240
 241                if Digit = 0 and After_Point = 1 then
 242                   Num_Saved_Zeroes := Num_Saved_Zeroes + 1;
 243
 244                --  Here for a non-zero digit
 245
 246                else
 247                   --  First deal with any previously saved zeroes
 248
 249                   if Num_Saved_Zeroes /= 0 then
 250                      Uval := Uval * Base ** Num_Saved_Zeroes;
 251                      Scale := Scale - Num_Saved_Zeroes;
 252                      Num_Saved_Zeroes := 0;
 253                   end if;
 254
 255                   --  Now accumulate the new digit
 256
 257                   Fdigit := Long_Long_Float (Digit);
 258
 259                   if Fdigit >= Base then
 260                      Bad_Base := True;
 261                   else
 262                      Scale := Scale - After_Point;
 263                      Uval := Uval * Base + Fdigit;
 264                   end if;
 265                end if;
 266
 267                P := P + 1;
 268
 269                if P > Max then
 270                   raise Constraint_Error;
 271
 272                elsif Str (P) = '_' then
 273                   Scan_Underscore (Str, P, Ptr, Max, True);
 274
 275                else
 276                   --  Skip past period after digit. Note that the processing
 277                   --  here will permit either a digit after the period, or the
 278                   --  terminating base character, as allowed in (RM 3.5(48))
 279
 280                   if Str (P) = '.' and then After_Point = 0 then
 281                      P := P + 1;
 282                      After_Point := 1;
 283
 284                      if P > Max then
 285                         raise Constraint_Error;
 286                      end if;
 287                   end if;
 288
 289                   exit when Str (P) = Base_Char;
 290                end if;
 291             end loop;
 292
 293             --  Based number successfully scanned out (point was found)
 294
 295             Ptr.all := P + 1;
 296          end;
 297
 298       --  Non-based case, check for being at decimal point now. Note that
 299       --  in Ada 95, we do not insist on a decimal point being present
 300
 301       else
 302          Base := 10.0;
 303          After_Point := 1;
 304
 305          if P <= Max and then Str (P) = '.' then
 306             P := P + 1;
 307
 308             --  Scan digits after point if any are present (RM 3.5(46))
 309
 310             if P <= Max and then Str (P) in Digs then
 311                Scanf;
 312             end if;
 313          end if;
 314
 315          Ptr.all := P;
 316       end if;
 317
 318       --  At this point, we have Uval containing the digits of the value as
 319       --  an integer, and Scale indicates the negative of the number of digits
 320       --  after the point. Base contains the base value (an integral value in
 321       --  the range 2.0 .. 16.0). Test for exponent, must be at least one
 322       --  character after the E for the exponent to be valid.
 323
 324       Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True);
 325
 326       --  At this point the exponent has been scanned if one is present and
 327       --  Scale is adjusted to include the exponent value. Uval contains the
 328       --  the integral value which is to be multiplied by Base ** Scale.
 329
 330       --  If base is not 10, use exponentiation for scaling
 331
 332       if Base /= 10.0 then
 333          Uval := Uval * Base ** Scale;
 334
 335       --  For base 10, use power of ten table, repeatedly if necessary
 336
 337       elsif Scale > 0 then
 338          while Scale > Maxpow loop
 339             Uval := Uval * Powten (Maxpow);
 340             Scale := Scale - Maxpow;
 341          end loop;
 342
 343          if Scale > 0 then
 344             Uval := Uval * Powten (Scale);
 345          end if;
 346
 347       elsif Scale < 0 then
 348          while (-Scale) > Maxpow loop
 349             Uval := Uval / Powten (Maxpow);
 350             Scale := Scale + Maxpow;
 351          end loop;
 352
 353          if Scale < 0 then
 354             Uval := Uval / Powten (-Scale);
 355          end if;
 356       end if;
 357
 358       --  Here is where we check for a bad based number
 359
 360       if Bad_Base then
 361          raise Constraint_Error;
 362
 363       --  If OK, then deal with initial minus sign, note that this processing
 364       --  is done even if Uval is zero, so that -0.0 is correctly interpreted.
 365
 366       else
 367          if Minus then
 368             return -Uval;
 369          else
 370             return Uval;
 371          end if;
 372       end if;
 373    end Scan_Real;
 374
 375    ----------------
 376    -- Value_Real --
 377    ----------------
 378
 379    function Value_Real (Str : String) return Long_Long_Float is
 380       V : Long_Long_Float;
 381       P : aliased Integer := Str'First;
 382    begin
 383       V := Scan_Real (Str, P'Access, Str'Last);
 384       Scan_Trailing_Blanks (Str, P);
 385       return V;
 386    end Value_Real;
 387
 388 end System.Val_Real;