1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . S E Q U E N T I A L _ I O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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 32-- This is the generic template for Sequential_IO, i.e. the code that gets 33-- duplicated. We absolutely minimize this code by either calling routines 34-- in System.File_IO (for common file functions), or in System.Sequential_IO 35-- (for specialized Sequential_IO functions) 36 37with Ada.Unchecked_Conversion; 38 39with System; 40with System.Byte_Swapping; 41with System.CRTL; 42with System.File_Control_Block; 43with System.File_IO; 44with System.Storage_Elements; 45 46with Interfaces.C_Streams; use Interfaces.C_Streams; 47 48package body Ada.Sequential_IO is 49 50 package FIO renames System.File_IO; 51 package FCB renames System.File_Control_Block; 52 package SIO renames System.Sequential_IO; 53 package SSE renames System.Storage_Elements; 54 55 SU : constant := System.Storage_Unit; 56 57 subtype AP is FCB.AFCB_Ptr; 58 subtype FP is SIO.File_Type; 59 60 function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); 61 function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); 62 63 use type System.Bit_Order; 64 use type System.CRTL.size_t; 65 66 procedure Byte_Swap (Siz : in out size_t); 67 -- Byte swap Siz 68 69 --------------- 70 -- Byte_Swap -- 71 --------------- 72 73 procedure Byte_Swap (Siz : in out size_t) is 74 use System.Byte_Swapping; 75 begin 76 case Siz'Size is 77 when 32 => Siz := size_t (Bswap_32 (U32 (Siz))); 78 when 64 => Siz := size_t (Bswap_64 (U64 (Siz))); 79 when others => raise Program_Error; 80 end case; 81 end Byte_Swap; 82 83 ----------- 84 -- Close -- 85 ----------- 86 87 procedure Close (File : in out File_Type) is 88 begin 89 FIO.Close (AP (File)'Unrestricted_Access); 90 end Close; 91 92 ------------ 93 -- Create -- 94 ------------ 95 96 procedure Create 97 (File : in out File_Type; 98 Mode : File_Mode := Out_File; 99 Name : String := ""; 100 Form : String := "") 101 is 102 begin 103 SIO.Create (FP (File), To_FCB (Mode), Name, Form); 104 end Create; 105 106 ------------ 107 -- Delete -- 108 ------------ 109 110 procedure Delete (File : in out File_Type) is 111 begin 112 FIO.Delete (AP (File)'Unrestricted_Access); 113 end Delete; 114 115 ----------------- 116 -- End_Of_File -- 117 ----------------- 118 119 function End_Of_File (File : File_Type) return Boolean is 120 begin 121 return FIO.End_Of_File (AP (File)); 122 end End_Of_File; 123 124 ---------- 125 -- Form -- 126 ---------- 127 128 function Form (File : File_Type) return String is 129 begin 130 return FIO.Form (AP (File)); 131 end Form; 132 133 ------------- 134 -- Is_Open -- 135 ------------- 136 137 function Is_Open (File : File_Type) return Boolean is 138 begin 139 return FIO.Is_Open (AP (File)); 140 end Is_Open; 141 142 ---------- 143 -- Mode -- 144 ---------- 145 146 function Mode (File : File_Type) return File_Mode is 147 begin 148 return To_SIO (FIO.Mode (AP (File))); 149 end Mode; 150 151 ---------- 152 -- Name -- 153 ---------- 154 155 function Name (File : File_Type) return String is 156 begin 157 return FIO.Name (AP (File)); 158 end Name; 159 160 ---------- 161 -- Open -- 162 ---------- 163 164 procedure Open 165 (File : in out File_Type; 166 Mode : File_Mode; 167 Name : String; 168 Form : String := "") 169 is 170 begin 171 SIO.Open (FP (File), To_FCB (Mode), Name, Form); 172 end Open; 173 174 ---------- 175 -- Read -- 176 ---------- 177 178 procedure Read (File : File_Type; Item : out Element_Type) is 179 Siz : constant size_t := (Item'Size + SU - 1) / SU; 180 Rsiz : size_t; 181 182 begin 183 FIO.Check_Read_Status (AP (File)); 184 185 -- For non-definite type or type with discriminants, read size and 186 -- raise Program_Error if it is larger than the size of the item. 187 188 if not Element_Type'Definite 189 or else Element_Type'Has_Discriminants 190 then 191 FIO.Read_Buf 192 (AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit); 193 194 -- If item read has non-default scalar storage order, then the size 195 -- will have been written with that same order, so byte swap it. 196 197 if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then 198 Byte_Swap (Rsiz); 199 end if; 200 201 -- For a type with discriminants, we have to read into a temporary 202 -- buffer if Item is constrained, to check that the discriminants 203 -- are correct. 204 205 if Element_Type'Has_Discriminants and then Item'Constrained then 206 declare 207 RsizS : constant SSE.Storage_Offset := 208 SSE.Storage_Offset (Rsiz - 1); 209 210 type SA is new SSE.Storage_Array (0 .. RsizS); 211 212 for SA'Alignment use Standard'Maximum_Alignment; 213 -- We will perform an unchecked conversion of a pointer-to-SA 214 -- into pointer-to-Element_Type. We need to ensure that the 215 -- source is always at least as strictly aligned as the target. 216 217 type SAP is access all SA; 218 type ItemP is access all Element_Type; 219 220 pragma Warnings (Off); 221 -- We have to turn warnings off for function To_ItemP, 222 -- because it gets analyzed for all types, including ones 223 -- which can't possibly come this way, and for which the 224 -- size of the access types differs. 225 226 function To_ItemP is new Ada.Unchecked_Conversion (SAP, ItemP); 227 228 pragma Warnings (On); 229 230 Buffer : aliased SA; 231 232 pragma Unsuppress (Discriminant_Check); 233 234 begin 235 FIO.Read_Buf (AP (File), Buffer'Address, Rsiz); 236 Item := To_ItemP (Buffer'Access).all; 237 return; 238 end; 239 end if; 240 241 -- In the case of a non-definite type, make sure the length is OK. 242 -- We can't do this in the variant record case, because the size is 243 -- based on the current discriminant, so may be apparently wrong. 244 245 if not Element_Type'Has_Discriminants and then Rsiz > Siz then 246 raise Program_Error; 247 end if; 248 249 FIO.Read_Buf (AP (File), Item'Address, Rsiz); 250 251 -- For definite type without discriminants, use actual size of item 252 253 else 254 FIO.Read_Buf (AP (File), Item'Address, Siz); 255 end if; 256 end Read; 257 258 ----------- 259 -- Reset -- 260 ----------- 261 262 procedure Reset (File : in out File_Type; Mode : File_Mode) is 263 begin 264 FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); 265 end Reset; 266 267 procedure Reset (File : in out File_Type) is 268 begin 269 FIO.Reset (AP (File)'Unrestricted_Access); 270 end Reset; 271 272 ----------- 273 -- Write -- 274 ----------- 275 276 procedure Write (File : File_Type; Item : Element_Type) is 277 Siz : constant size_t := (Item'Size + SU - 1) / SU; 278 -- Size to be written, in native representation 279 280 Swapped_Siz : size_t := Siz; 281 -- Same, possibly byte swapped to account for Element_Type endianness 282 283 begin 284 FIO.Check_Write_Status (AP (File)); 285 286 -- For non-definite types or types with discriminants, write the size 287 288 if not Element_Type'Definite 289 or else Element_Type'Has_Discriminants 290 then 291 -- If item written has non-default scalar storage order, then the 292 -- size is written with that same order, so byte swap it. 293 294 if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then 295 Byte_Swap (Swapped_Siz); 296 end if; 297 298 FIO.Write_Buf 299 (AP (File), Swapped_Siz'Address, size_t'Size / System.Storage_Unit); 300 end if; 301 302 FIO.Write_Buf (AP (File), Item'Address, Siz); 303 end Write; 304 305end Ada.Sequential_IO; 306