1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . W I D E _ T E X T _ I O . F L O A T _ A U X -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2003 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 34with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; 35 36with System.Img_Real; use System.Img_Real; 37with System.Val_Real; use System.Val_Real; 38 39package body Ada.Wide_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 64 Check_End_Of_Field (Buf, Stop, Ptr, Width); 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 => 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 .. Field'Last); 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 .. Field'Last); 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 228end Ada.Wide_Text_IO.Float_Aux; 229