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