projects / thirdparty / gcc.git / blame
| Commit | Line | Data |
|---|---|---|
| d23b8f57 RK |
1 | ------------------------------------------------------------------------------ |
| 2 | -- -- | |
| 3 | -- GNAT RUN-TIME COMPONENTS -- | |
| 4 | -- -- | |
| 5 | -- A D A . T E X T _ I O . F L O A T _ A U X -- | |
| 6 | -- -- | |
| 7 | -- B o d y -- | |
| 8 | -- -- | |
| fbf5a39b | 9 | -- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- |
| d23b8f57 RK |
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. -- | |
| 71ff80dc | 30 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| d23b8f57 RK |
31 | -- -- |
| 32 | ------------------------------------------------------------------------------ | |
| 33 | ||
| 34 | with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; | |
| 35 | ||
| 36 | with System.Img_Real; use System.Img_Real; | |
| 37 | with System.Val_Real; use System.Val_Real; | |
| 38 | ||
| 39 | package body Ada.Text_IO.Float_Aux is | |
| 40 | ||
| 41 | --------- | |
| 42 | -- Get -- | |
| 43 | --------- | |
| 44 | ||
| 45 | procedure Get | |
| 46 | (File : in File_Type; | |
| 47 | Item : out Long_Long_Float; | |
| 48 | Width : in Field) | |
| 49 | is | |
| 50 | Buf : String (1 .. Field'Last); | |
| 51 | Stop : Integer := 0; | |
| 52 | Ptr : aliased Integer := 1; | |
| 53 | ||
| 54 | begin | |
| 55 | if Width /= 0 then | |
| 56 | Load_Width (File, Width, Buf, Stop); | |
| 57 | String_Skip (Buf, Ptr); | |
| 58 | else | |
| 59 | Load_Real (File, Buf, Stop); | |
| 60 | end if; | |
| 61 | ||
| 62 | Item := Scan_Real (Buf, Ptr'Access, Stop); | |
| 63 | ||
| 07fc65c4 | 64 | Check_End_Of_Field (Buf, Stop, Ptr, Width); |
| d23b8f57 RK |
65 | end Get; |
| 66 | ||
| 67 | ---------- | |
| 68 | -- Gets -- | |
| 69 | ---------- | |
| 70 | ||
| 71 | procedure Gets | |
| 72 | (From : in String; | |
| 73 | Item : out Long_Long_Float; | |
| 74 | Last : out Positive) | |
| 75 | is | |
| 76 | Pos : aliased Integer; | |
| 77 | ||
| 78 | begin | |
| 79 | String_Skip (From, Pos); | |
| 80 | Item := Scan_Real (From, Pos'Access, From'Last); | |
| 81 | Last := Pos - 1; | |
| 82 | ||
| 83 | exception | |
| 84 | when Constraint_Error => | |
| d23b8f57 RK |
85 | raise Data_Error; |
| 86 | end Gets; | |
| 87 | ||
| 88 | --------------- | |
| 89 | -- Load_Real -- | |
| 90 | --------------- | |
| 91 | ||
| 92 | procedure Load_Real | |
| 93 | (File : in File_Type; | |
| 94 | Buf : out String; | |
| 95 | Ptr : in out Natural) | |
| 96 | is | |
| 97 | Loaded : Boolean; | |
| 98 | ||
| 99 | begin | |
| 100 | -- Skip initial blanks, and load possible sign | |
| 101 | ||
| 102 | Load_Skip (File); | |
| 103 | Load (File, Buf, Ptr, '+', '-'); | |
| 104 | ||
| 105 | -- Case of .nnnn | |
| 106 | ||
| 107 | Load (File, Buf, Ptr, '.', Loaded); | |
| 108 | ||
| 109 | if Loaded then | |
| 110 | Load_Digits (File, Buf, Ptr, Loaded); | |
| 111 | ||
| 112 | -- Hopeless junk if no digits loaded | |
| 113 | ||
| 114 | if not Loaded then | |
| 115 | return; | |
| 116 | end if; | |
| 117 | ||
| 118 | -- Otherwise must have digits to start | |
| 119 | ||
| 120 | else | |
| 121 | Load_Digits (File, Buf, Ptr, Loaded); | |
| 122 | ||
| 123 | -- Hopeless junk if no digits loaded | |
| 124 | ||
| 125 | if not Loaded then | |
| 126 | return; | |
| 127 | end if; | |
| 128 | ||
| 129 | -- Based cases | |
| 130 | ||
| 131 | Load (File, Buf, Ptr, '#', ':', Loaded); | |
| 132 | ||
| 133 | if Loaded then | |
| 134 | ||
| 135 | -- Case of nnn#.xxx# | |
| 136 | ||
| 137 | Load (File, Buf, Ptr, '.', Loaded); | |
| 138 | ||
| 139 | if Loaded then | |
| 140 | Load_Extended_Digits (File, Buf, Ptr); | |
| 141 | ||
| 142 | -- Case of nnn#xxx.[xxx]# or nnn#xxx# | |
| 143 | ||
| 144 | else | |
| 145 | Load_Extended_Digits (File, Buf, Ptr); | |
| 146 | Load (File, Buf, Ptr, '.', Loaded); | |
| 147 | ||
| 148 | if Loaded then | |
| 149 | Load_Extended_Digits (File, Buf, Ptr); | |
| 150 | end if; | |
| 151 | ||
| 152 | -- As usual, it seems strange to allow mixed base characters, | |
| 153 | -- but that is what ACVC tests expect, see CE3804M, case (3). | |
| 154 | ||
| 155 | Load (File, Buf, Ptr, '#', ':'); | |
| 156 | end if; | |
| 157 | ||
| 158 | -- Case of nnn.[nnn] or nnn | |
| 159 | ||
| 160 | else | |
| 161 | Load (File, Buf, Ptr, '.', Loaded); | |
| 162 | ||
| 163 | if Loaded then | |
| 164 | Load_Digits (File, Buf, Ptr); | |
| 165 | end if; | |
| 166 | end if; | |
| 167 | end if; | |
| 168 | ||
| 169 | -- Deal with exponent | |
| 170 | ||
| 171 | Load (File, Buf, Ptr, 'E', 'e', Loaded); | |
| 172 | ||
| 173 | if Loaded then | |
| 174 | Load (File, Buf, Ptr, '+', '-'); | |
| 175 | Load_Digits (File, Buf, Ptr); | |
| 176 | end if; | |
| 177 | end Load_Real; | |
| 178 | ||
| 179 | --------- | |
| 180 | -- Put -- | |
| 181 | --------- | |
| 182 | ||
| 183 | procedure Put | |
| 184 | (File : in File_Type; | |
| 185 | Item : in Long_Long_Float; | |
| 186 | Fore : in Field; | |
| 187 | Aft : in Field; | |
| 188 | Exp : in Field) | |
| 189 | is | |
| 190 | Buf : String (1 .. 3 * Field'Last + 2); | |
| 191 | Ptr : Natural := 0; | |
| 192 | ||
| 193 | begin | |
| 194 | Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); | |
| 195 | Put_Item (File, Buf (1 .. Ptr)); | |
| 196 | end Put; | |
| 197 | ||
| 198 | ---------- | |
| 199 | -- Puts -- | |
| 200 | ---------- | |
| 201 | ||
| 202 | procedure Puts | |
| 203 | (To : out String; | |
| 204 | Item : in Long_Long_Float; | |
| 205 | Aft : in Field; | |
| 206 | Exp : in Field) | |
| 207 | is | |
| 208 | Buf : String (1 .. 3 * Field'Last + 2); | |
| 209 | Ptr : Natural := 0; | |
| 210 | ||
| 211 | begin | |
| 212 | Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); | |
| 213 | ||
| 214 | if Ptr > To'Length then | |
| 215 | raise Layout_Error; | |
| 216 | ||
| 217 | else | |
| 218 | for J in 1 .. Ptr loop | |
| 219 | To (To'Last - Ptr + J) := Buf (J); | |
| 220 | end loop; | |
| 221 | ||
| 222 | for J in To'First .. To'Last - Ptr loop | |
| 223 | To (J) := ' '; | |
| 224 | end loop; | |
| 225 | end if; | |
| 226 | end Puts; | |
| 227 | ||
| 228 | end Ada.Text_IO.Float_Aux; |