1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . W I D E _ 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-2014, 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 3, 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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; 33 34with System.Img_Real; use System.Img_Real; 35with System.Val_Real; use System.Val_Real; 36 37package body Ada.Wide_Wide_Text_IO.Float_Aux is 38 39 --------- 40 -- Get -- 41 --------- 42 43 procedure Get 44 (File : File_Type; 45 Item : out Long_Long_Float; 46 Width : Field) 47 is 48 Buf : String (1 .. Field'Last); 49 Stop : Integer := 0; 50 Ptr : aliased Integer := 1; 51 52 begin 53 if Width /= 0 then 54 Load_Width (File, Width, Buf, Stop); 55 String_Skip (Buf, Ptr); 56 else 57 Load_Real (File, Buf, Stop); 58 end if; 59 60 Item := Scan_Real (Buf, Ptr'Access, Stop); 61 62 Check_End_Of_Field (Buf, Stop, Ptr, Width); 63 end Get; 64 65 ---------- 66 -- Gets -- 67 ---------- 68 69 procedure Gets 70 (From : String; 71 Item : out Long_Long_Float; 72 Last : out Positive) 73 is 74 Pos : aliased Integer; 75 76 begin 77 String_Skip (From, Pos); 78 Item := Scan_Real (From, Pos'Access, From'Last); 79 Last := Pos - 1; 80 81 exception 82 when Constraint_Error => 83 raise Data_Error; 84 end Gets; 85 86 --------------- 87 -- Load_Real -- 88 --------------- 89 90 procedure Load_Real 91 (File : File_Type; 92 Buf : out String; 93 Ptr : in out Natural) 94 is 95 Loaded : Boolean; 96 97 begin 98 -- Skip initial blanks and load possible sign 99 100 Load_Skip (File); 101 Load (File, Buf, Ptr, '+', '-'); 102 103 -- Case of .nnnn 104 105 Load (File, Buf, Ptr, '.', Loaded); 106 107 if Loaded then 108 Load_Digits (File, Buf, Ptr, Loaded); 109 110 -- Hopeless junk if no digits loaded 111 112 if not Loaded then 113 return; 114 end if; 115 116 -- Otherwise must have digits to start 117 118 else 119 Load_Digits (File, Buf, Ptr, Loaded); 120 121 -- Hopeless junk if no digits loaded 122 123 if not Loaded then 124 return; 125 end if; 126 127 -- Deal with based case. We recognize either the standard '#' or the 128 -- allowed alternative replacement ':' (see RM J.2(3)). 129 130 Load (File, Buf, Ptr, '#', ':', Loaded); 131 132 if Loaded then 133 134 -- Case of nnn#.xxx# 135 136 Load (File, Buf, Ptr, '.', Loaded); 137 138 if Loaded then 139 Load_Extended_Digits (File, Buf, Ptr); 140 Load (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 -- Prevent the potential processing of '.' in cases where the 162 -- initial digits have a trailing underscore. 163 164 if Buf (Ptr) = '_' then 165 return; 166 end if; 167 168 Load (File, Buf, Ptr, '.', Loaded); 169 170 if Loaded then 171 Load_Digits (File, Buf, Ptr); 172 end if; 173 end if; 174 end if; 175 176 -- Deal with exponent 177 178 Load (File, Buf, Ptr, 'E', 'e', Loaded); 179 180 if Loaded then 181 Load (File, Buf, Ptr, '+', '-'); 182 Load_Digits (File, Buf, Ptr); 183 end if; 184 end Load_Real; 185 186 --------- 187 -- Put -- 188 --------- 189 190 procedure Put 191 (File : File_Type; 192 Item : Long_Long_Float; 193 Fore : Field; 194 Aft : Field; 195 Exp : Field) 196 is 197 Buf : String (1 .. Field'Last); 198 Ptr : Natural := 0; 199 200 begin 201 Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); 202 Put_Item (File, Buf (1 .. Ptr)); 203 end Put; 204 205 ---------- 206 -- Puts -- 207 ---------- 208 209 procedure Puts 210 (To : out String; 211 Item : Long_Long_Float; 212 Aft : Field; 213 Exp : Field) 214 is 215 Buf : String (1 .. Field'Last); 216 Ptr : Natural := 0; 217 218 begin 219 Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); 220 221 if Ptr > To'Length then 222 raise Layout_Error; 223 224 else 225 for J in 1 .. Ptr loop 226 To (To'Last - Ptr + J) := Buf (J); 227 end loop; 228 229 for J in To'First .. To'Last - Ptr loop 230 To (J) := ' '; 231 end loop; 232 end if; 233 end Puts; 234 235end Ada.Wide_Wide_Text_IO.Float_Aux; 236