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 --                                 S p e c                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.18 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with System.Powten_Table; use System.Powten_Table;
  37 with System.Val_Util;     use System.Val_Util;
  38
  39 package body System.Val_Real is
  40
  41    ---------------
  42    -- Scan_Real --
  43    ---------------
  44
  45    function Scan_Real
  46      (Str  : String;
  47       Ptr  : access Integer;
  48       Max  : Integer)
  49       return Long_Long_Float
  50    is
  51       procedure Reset;
  52       pragma Import (C, Reset, "__gnat_init_float");
  53       --  We import the floating-point processor reset routine so that we can
  54       --  be sure the floating-point processor is properly set for conversion
  55       --  calls (see description of Reset in GNAT.Float_Control (g-flocon.ads).
  56       --  This is notably need on Windows, where calls to the operating system
  57       --  randomly reset the processor into 64-bit mode.
  58
  59       P : Integer;
  60       --  Local copy of string pointer
  61
  62       Base   : Long_Long_Float;
  63       --  Base value
  64
  65       Uval : Long_Long_Float;
  66       --  Accumulated float result
  67
  68       subtype Digs is Character range '0' .. '9';
  69       --  Used to check for decimal digit
  70
  71       Scale : Integer := 0;
  72       --  Power of Base to multiply result by
  73
  74       Start : Positive;
  75       --  Position of starting non-blank character
  76
  77       Minus : Boolean;
  78       --  Set to True if minus sign is present, otherwise to False
  79
  80       Bad_Base : Boolean := False;
  81       --  Set True if Base out of range or if out of range digit
  82
  83       After_Point : Natural := 0;
  84       --  Set to 1 after the point
  85
  86       procedure Scanf;
  87       --  Scans integer literal value starting at current character position.
  88       --  For each digit encountered, Uval is multiplied by 10.0, and the new
  89       --  digit value is incremented. In addition Scale is decremented for each
  90       --  digit encountered if we are after the point (After_Point = 1). The
  91       --  longest possible syntactically valid numeral is scanned out, and on
  92       --  return P points past the last character. On entry, the current
  93       --  character is known to be a digit, so a numeral is definitely present.
  94
  95       procedure Scanf is
  96          Digit : Natural;
  97
  98       begin
  99          loop
 100             Digit := Character'Pos (Str (P)) - Character'Pos ('0');
 101             Uval := Uval * 10.0 + Long_Long_Float (Digit);
 102             P := P + 1;
 103             Scale := Scale - After_Point;
 104
 105             --  Done if end of input field
 106
 107             if P > Max then
 108                return;
 109
 110             --  Check next character
 111
 112             elsif Str (P) not in Digs then
 113                if Str (P) = '_' then
 114                   Scan_Underscore (Str, P, Ptr, Max, False);
 115                else
 116                   return;
 117                end if;
 118             end if;
 119          end loop;
 120       end Scanf;
 121
 122    --  Start of processing for System.Scan_Real
 123
 124    begin
 125       Reset;
 126       Scan_Sign (Str, Ptr, Max, Minus, Start);
 127       P := Ptr.all;
 128       Ptr.all := Start;
 129
 130       --  If digit, scan numeral before point
 131
 132       if Str (P) in Digs then
 133          Uval := 0.0;
 134          Scanf;
 135
 136       --  Initial point, allowed only if followed by digit (RM 3.5(47))
 137
 138       elsif Str (P) = '.'
 139         and then P < Max
 140         and then Str (P + 1) in Digs
 141       then
 142          Uval := 0.0;
 143
 144       --  Any other initial character is an error
 145
 146       else
 147          raise Constraint_Error;
 148       end if;
 149
 150       --  Deal with based case
 151
 152       if P < Max and then (Str (P) = ':' or else Str (P) = '#') then
 153          declare
 154             Base_Char : constant Character := Str (P);
 155             Digit     : Natural;
 156             Fdigit    : Long_Long_Float;
 157
 158          begin
 159             --  Set bad base if out of range, and use safe base of 16.0,
 160             --  to guard against division by zero in the loop below.
 161
 162             if Uval < 2.0 or else Uval > 16.0 then
 163                Bad_Base := True;
 164                Uval := 16.0;
 165             end if;
 166
 167             Base := Uval;
 168             Uval := 0.0;
 169             P := P + 1;
 170
 171             --  Special check to allow initial point (RM 3.5(49))
 172
 173             if Str (P) = '.' then
 174                After_Point := 1;
 175                P := P + 1;
 176             end if;
 177
 178             --  Loop to scan digits of based number. On entry to the loop we
 179             --  must have a valid digit. If we don't, then we have an illegal
 180             --  floating-point value, and we raise Constraint_Error, note that
 181             --  Ptr at this stage was reset to the proper (Start) value.
 182
 183             loop
 184                if P > Max then
 185                   raise Constraint_Error;
 186
 187                elsif Str (P) in Digs then
 188                   Digit := Character'Pos (Str (P)) - Character'Pos ('0');
 189
 190                elsif Str (P) in 'A' .. 'F' then
 191                   Digit :=
 192                     Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
 193
 194                elsif Str (P) in 'a' .. 'f' then
 195                   Digit :=
 196                     Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
 197
 198                else
 199                   raise Constraint_Error;
 200                end if;
 201
 202                P := P + 1;
 203                Fdigit := Long_Long_Float (Digit);
 204
 205                if Fdigit >= Base then
 206                   Bad_Base := True;
 207                else
 208                   Scale := Scale - After_Point;
 209                   Uval := Uval * Base + Fdigit;
 210                end if;
 211
 212                if P > Max then
 213                   raise Constraint_Error;
 214
 215                elsif Str (P) = '_' then
 216                   Scan_Underscore (Str, P, Ptr, Max, True);
 217
 218                else
 219                   --  Skip past period after digit. Note that the processing
 220                   --  here will permit either a digit after the period, or the
 221                   --  terminating base character, as allowed in (RM 3.5(48))
 222
 223                   if Str (P) = '.' and then After_Point = 0 then
 224                      P := P + 1;
 225                      After_Point := 1;
 226
 227                      if P > Max then
 228                         raise Constraint_Error;
 229                      end if;
 230                   end if;
 231
 232                   exit when Str (P) = Base_Char;
 233                end if;
 234             end loop;
 235
 236             --  Based number successfully scanned out (point was found)
 237
 238             Ptr.all := P + 1;
 239          end;
 240
 241       --  Non-based case, check for being at decimal point now. Note that
 242       --  in Ada 95, we do not insist on a decimal point being present
 243
 244       else
 245          Base := 10.0;
 246          After_Point := 1;
 247
 248          if P <= Max and then Str (P) = '.' then
 249             P := P + 1;
 250
 251             --  Scan digits after point if any are present (RM 3.5(46))
 252
 253             if P <= Max and then Str (P) in Digs then
 254                Scanf;
 255             end if;
 256          end if;
 257
 258          Ptr.all := P;
 259       end if;
 260
 261       --  At this point, we have Uval containing the digits of the value as
 262       --  an integer, and Scale indicates the negative of the number of digits
 263       --  after the point. Base contains the base value (an integral value in
 264       --  the range 2.0 .. 16.0). Test for exponent, must be at least one
 265       --  character after the E for the exponent to be valid.
 266
 267       Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True);
 268
 269       --  At this point the exponent has been scanned if one is present and
 270       --  Scale is adjusted to include the exponent value. Uval contains the
 271       --  the integral value which is to be multiplied by Base ** Scale.
 272
 273       --  If base is not 10, use exponentiation for scaling
 274
 275       if Base /= 10.0 then
 276          Uval := Uval * Base ** Scale;
 277
 278       --  For base 10, use power of ten table, repeatedly if necessary.
 279
 280       elsif Scale > 0 then
 281
 282          while Scale > Maxpow loop
 283             Uval := Uval * Powten (Maxpow);
 284             Scale := Scale - Maxpow;
 285          end loop;
 286
 287          if Scale > 0 then
 288             Uval := Uval * Powten (Scale);
 289          end if;
 290
 291       elsif Scale < 0 then
 292
 293          while (-Scale) > Maxpow loop
 294             Uval := Uval / Powten (Maxpow);
 295             Scale := Scale + Maxpow;
 296          end loop;
 297
 298          if Scale < 0 then
 299             Uval := Uval / Powten (-Scale);
 300          end if;
 301       end if;
 302
 303       --  Here is where we check for a bad based number
 304
 305       if Bad_Base then
 306          raise Constraint_Error;
 307
 308       --  If OK, then deal with initial minus sign, note that this processing
 309       --  is done even if Uval is zero, so that -0.0 is correctly interpreted.
 310
 311       else
 312          if Minus then
 313             return -Uval;
 314          else
 315             return Uval;
 316          end if;
 317       end if;
 318
 319    end Scan_Real;
 320
 321    ----------------
 322    -- Value_Real --
 323    ----------------
 324
 325    function Value_Real (Str : String) return Long_Long_Float is
 326       V : Long_Long_Float;
 327       P : aliased Integer := Str'First;
 328
 329    begin
 330       V := Scan_Real (Str, P'Access, Str'Last);
 331       Scan_Trailing_Blanks (Str, P);
 332       return V;
 333
 334    end Value_Real;
 335
 336 end System.Val_Real;