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