1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUNTIME COMPONENTS -- 4-- -- 5-- S Y S T E M . D I R E C T _ I O -- 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.IO_Exceptions; use Ada.IO_Exceptions; 35with Interfaces.C_Streams; use Interfaces.C_Streams; 36with System; use System; 37with System.CRTL; 38with System.File_IO; 39with System.Soft_Links; 40with Unchecked_Deallocation; 41 42package body System.Direct_IO is 43 44 package FIO renames System.File_IO; 45 package SSL renames System.Soft_Links; 46 47 subtype AP is FCB.AFCB_Ptr; 48 use type FCB.Shared_Status_Type; 49 50 use type System.CRTL.long; 51 use type System.CRTL.size_t; 52 53 ----------------------- 54 -- Local Subprograms -- 55 ----------------------- 56 57 procedure Set_Position (File : in File_Type); 58 -- Sets file position pointer according to value of current index 59 60 ------------------- 61 -- AFCB_Allocate -- 62 ------------------- 63 64 function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr is 65 pragma Unreferenced (Control_Block); 66 67 begin 68 return new Direct_AFCB; 69 end AFCB_Allocate; 70 71 ---------------- 72 -- AFCB_Close -- 73 ---------------- 74 75 -- No special processing required for Direct_IO close 76 77 procedure AFCB_Close (File : access Direct_AFCB) is 78 pragma Unreferenced (File); 79 80 begin 81 null; 82 end AFCB_Close; 83 84 --------------- 85 -- AFCB_Free -- 86 --------------- 87 88 procedure AFCB_Free (File : access Direct_AFCB) is 89 90 type FCB_Ptr is access all Direct_AFCB; 91 92 FT : FCB_Ptr := FCB_Ptr (File); 93 94 procedure Free is new 95 Unchecked_Deallocation (Direct_AFCB, FCB_Ptr); 96 97 begin 98 Free (FT); 99 end AFCB_Free; 100 101 ------------ 102 -- Create -- 103 ------------ 104 105 procedure Create 106 (File : in out File_Type; 107 Mode : in FCB.File_Mode := FCB.Inout_File; 108 Name : in String := ""; 109 Form : in String := "") 110 is 111 Dummy_File_Control_Block : Direct_AFCB; 112 pragma Warnings (Off, Dummy_File_Control_Block); 113 -- Yes, we know this is never assigned a value, only the tag 114 -- is used for dispatching purposes, so that's expected. 115 116 begin 117 FIO.Open (File_Ptr => AP (File), 118 Dummy_FCB => Dummy_File_Control_Block, 119 Mode => Mode, 120 Name => Name, 121 Form => Form, 122 Amethod => 'D', 123 Creat => True, 124 Text => False); 125 end Create; 126 127 ----------------- 128 -- End_Of_File -- 129 ----------------- 130 131 function End_Of_File (File : in File_Type) return Boolean is 132 begin 133 FIO.Check_Read_Status (AP (File)); 134 return Count (File.Index) > Size (File); 135 end End_Of_File; 136 137 ----------- 138 -- Index -- 139 ----------- 140 141 function Index (File : in File_Type) return Positive_Count is 142 begin 143 FIO.Check_File_Open (AP (File)); 144 return Count (File.Index); 145 end Index; 146 147 ---------- 148 -- Open -- 149 ---------- 150 151 procedure Open 152 (File : in out File_Type; 153 Mode : in FCB.File_Mode; 154 Name : in String; 155 Form : in String := "") 156 is 157 Dummy_File_Control_Block : Direct_AFCB; 158 pragma Warnings (Off, Dummy_File_Control_Block); 159 -- Yes, we know this is never assigned a value, only the tag 160 -- is used for dispatching purposes, so that's expected. 161 162 begin 163 FIO.Open (File_Ptr => AP (File), 164 Dummy_FCB => Dummy_File_Control_Block, 165 Mode => Mode, 166 Name => Name, 167 Form => Form, 168 Amethod => 'D', 169 Creat => False, 170 Text => False); 171 end Open; 172 173 ---------- 174 -- Read -- 175 ---------- 176 177 procedure Read 178 (File : in File_Type; 179 Item : Address; 180 Size : in Interfaces.C_Streams.size_t; 181 From : in Positive_Count) 182 is 183 begin 184 Set_Index (File, From); 185 Read (File, Item, Size); 186 end Read; 187 188 procedure Read 189 (File : in File_Type; 190 Item : Address; 191 Size : in Interfaces.C_Streams.size_t) 192 is 193 begin 194 FIO.Check_Read_Status (AP (File)); 195 196 -- If last operation was not a read, or if in file sharing mode, 197 -- then reset the physical pointer of the file to match the index 198 -- We lock out task access over the two operations in this case. 199 200 if File.Last_Op /= Op_Read 201 or else File.Shared_Status = FCB.Yes 202 then 203 if End_Of_File (File) then 204 raise End_Error; 205 end if; 206 207 Locked_Processing : begin 208 SSL.Lock_Task.all; 209 Set_Position (File); 210 FIO.Read_Buf (AP (File), Item, Size); 211 SSL.Unlock_Task.all; 212 213 exception 214 when others => 215 SSL.Unlock_Task.all; 216 raise; 217 end Locked_Processing; 218 219 else 220 FIO.Read_Buf (AP (File), Item, Size); 221 end if; 222 223 File.Index := File.Index + 1; 224 225 -- Set last operation to read, unless we did not read a full record 226 -- (happens with the variant record case) in which case we set the 227 -- last operation as other, to force the file position to be reset 228 -- on the next read. 229 230 if File.Bytes = Size then 231 File.Last_Op := Op_Read; 232 else 233 File.Last_Op := Op_Other; 234 end if; 235 end Read; 236 237 -- The following is the required overriding for Stream.Read, which is 238 -- not used, since we do not do Stream operations on Direct_IO files. 239 240 procedure Read 241 (File : in out Direct_AFCB; 242 Item : out Ada.Streams.Stream_Element_Array; 243 Last : out Ada.Streams.Stream_Element_Offset) 244 is 245 begin 246 raise Program_Error; 247 end Read; 248 249 ----------- 250 -- Reset -- 251 ----------- 252 253 procedure Reset (File : in out File_Type; Mode : in FCB.File_Mode) is 254 begin 255 FIO.Reset (AP (File), Mode); 256 File.Index := 1; 257 File.Last_Op := Op_Read; 258 end Reset; 259 260 procedure Reset (File : in out File_Type) is 261 begin 262 FIO.Reset (AP (File)); 263 File.Index := 1; 264 File.Last_Op := Op_Read; 265 end Reset; 266 267 --------------- 268 -- Set_Index -- 269 --------------- 270 271 procedure Set_Index (File : in File_Type; To : in Positive_Count) is 272 begin 273 FIO.Check_File_Open (AP (File)); 274 File.Index := Count (To); 275 File.Last_Op := Op_Other; 276 end Set_Index; 277 278 ------------------ 279 -- Set_Position -- 280 ------------------ 281 282 procedure Set_Position (File : in File_Type) is 283 begin 284 if fseek 285 (File.Stream, long (File.Bytes) * 286 long (File.Index - 1), SEEK_SET) /= 0 287 then 288 raise Use_Error; 289 end if; 290 end Set_Position; 291 292 ---------- 293 -- Size -- 294 ---------- 295 296 function Size (File : in File_Type) return Count is 297 begin 298 FIO.Check_File_Open (AP (File)); 299 File.Last_Op := Op_Other; 300 301 if fseek (File.Stream, 0, SEEK_END) /= 0 then 302 raise Device_Error; 303 end if; 304 305 return Count (ftell (File.Stream) / long (File.Bytes)); 306 end Size; 307 308 ----------- 309 -- Write -- 310 ----------- 311 312 procedure Write 313 (File : File_Type; 314 Item : Address; 315 Size : in Interfaces.C_Streams.size_t; 316 Zeroes : System.Storage_Elements.Storage_Array) 317 318 is 319 procedure Do_Write; 320 -- Do the actual write 321 322 procedure Do_Write is 323 begin 324 FIO.Write_Buf (AP (File), Item, Size); 325 326 -- If we did not write the whole record (happens with the variant 327 -- record case), then fill out the rest of the record with zeroes. 328 -- This is cleaner in any case, and is required for the last 329 -- record, since otherwise the length of the file is wrong. 330 331 if File.Bytes > Size then 332 FIO.Write_Buf (AP (File), Zeroes'Address, File.Bytes - Size); 333 end if; 334 end Do_Write; 335 336 -- Start of processing for Write 337 338 begin 339 FIO.Check_Write_Status (AP (File)); 340 341 -- If last operation was not a write, or if in file sharing mode, 342 -- then reset the physical pointer of the file to match the index 343 -- We lock out task access over the two operations in this case. 344 345 if File.Last_Op /= Op_Write 346 or else File.Shared_Status = FCB.Yes 347 then 348 Locked_Processing : begin 349 SSL.Lock_Task.all; 350 Set_Position (File); 351 Do_Write; 352 SSL.Unlock_Task.all; 353 354 exception 355 when others => 356 SSL.Unlock_Task.all; 357 raise; 358 end Locked_Processing; 359 360 else 361 Do_Write; 362 end if; 363 364 File.Index := File.Index + 1; 365 366 -- Set last operation to write, unless we did not read a full record 367 -- (happens with the variant record case) in which case we set the 368 -- last operation as other, to force the file position to be reset 369 -- on the next write. 370 371 if File.Bytes = Size then 372 File.Last_Op := Op_Write; 373 else 374 File.Last_Op := Op_Other; 375 end if; 376 end Write; 377 378 -- The following is the required overriding for Stream.Write, which is 379 -- not used, since we do not do Stream operations on Direct_IO files. 380 381 procedure Write 382 (File : in out Direct_AFCB; 383 Item : in Ada.Streams.Stream_Element_Array) 384 is 385 begin 386 raise Program_Error; 387 end Write; 388 389end System.Direct_IO; 390