1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . S T R E A M S . S T R E A M _ I O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 Interfaces.C_Streams; use Interfaces.C_Streams; 33 34with System; use System; 35with System.Communication; use System.Communication; 36with System.File_IO; 37with System.Soft_Links; 38with System.CRTL; 39 40with Ada.Unchecked_Conversion; 41with Ada.Unchecked_Deallocation; 42 43package body Ada.Streams.Stream_IO is 44 45 package FIO renames System.File_IO; 46 package SSL renames System.Soft_Links; 47 48 subtype AP is FCB.AFCB_Ptr; 49 50 function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); 51 function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); 52 use type FCB.File_Mode; 53 use type FCB.Shared_Status_Type; 54 55 ----------------------- 56 -- Local Subprograms -- 57 ----------------------- 58 59 procedure Set_Position (File : File_Type); 60 -- Sets file position pointer according to value of current index 61 62 ------------------- 63 -- AFCB_Allocate -- 64 ------------------- 65 66 function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr is 67 pragma Warnings (Off, Control_Block); 68 begin 69 return new Stream_AFCB; 70 end AFCB_Allocate; 71 72 ---------------- 73 -- AFCB_Close -- 74 ---------------- 75 76 -- No special processing required for closing Stream_IO file 77 78 procedure AFCB_Close (File : not null access Stream_AFCB) is 79 pragma Warnings (Off, File); 80 begin 81 null; 82 end AFCB_Close; 83 84 --------------- 85 -- AFCB_Free -- 86 --------------- 87 88 procedure AFCB_Free (File : not null access Stream_AFCB) is 89 type FCB_Ptr is access all Stream_AFCB; 90 FT : FCB_Ptr := FCB_Ptr (File); 91 92 procedure Free is new Ada.Unchecked_Deallocation (Stream_AFCB, FCB_Ptr); 93 94 begin 95 Free (FT); 96 end AFCB_Free; 97 98 ----------- 99 -- Close -- 100 ----------- 101 102 procedure Close (File : in out File_Type) is 103 begin 104 FIO.Close (AP (File)'Unrestricted_Access); 105 end Close; 106 107 ------------ 108 -- Create -- 109 ------------ 110 111 procedure Create 112 (File : in out File_Type; 113 Mode : File_Mode := Out_File; 114 Name : String := ""; 115 Form : String := "") 116 is 117 Dummy_File_Control_Block : Stream_AFCB; 118 pragma Warnings (Off, Dummy_File_Control_Block); 119 -- Yes, we know this is never assigned a value, only the tag 120 -- is used for dispatching purposes, so that's expected. 121 122 begin 123 FIO.Open (File_Ptr => AP (File), 124 Dummy_FCB => Dummy_File_Control_Block, 125 Mode => To_FCB (Mode), 126 Name => Name, 127 Form => Form, 128 Amethod => 'S', 129 Creat => True, 130 Text => False); 131 File.Last_Op := Op_Write; 132 end Create; 133 134 ------------ 135 -- Delete -- 136 ------------ 137 138 procedure Delete (File : in out File_Type) is 139 begin 140 FIO.Delete (AP (File)'Unrestricted_Access); 141 end Delete; 142 143 ----------------- 144 -- End_Of_File -- 145 ----------------- 146 147 function End_Of_File (File : File_Type) return Boolean is 148 begin 149 FIO.Check_Read_Status (AP (File)); 150 return File.Index > Size (File); 151 end End_Of_File; 152 153 ----------- 154 -- Flush -- 155 ----------- 156 157 procedure Flush (File : File_Type) is 158 begin 159 FIO.Flush (AP (File)); 160 end Flush; 161 162 ---------- 163 -- Form -- 164 ---------- 165 166 function Form (File : File_Type) return String is 167 begin 168 return FIO.Form (AP (File)); 169 end Form; 170 171 ----------- 172 -- Index -- 173 ----------- 174 175 function Index (File : File_Type) return Positive_Count is 176 begin 177 FIO.Check_File_Open (AP (File)); 178 return File.Index; 179 end Index; 180 181 ------------- 182 -- Is_Open -- 183 ------------- 184 185 function Is_Open (File : File_Type) return Boolean is 186 begin 187 return FIO.Is_Open (AP (File)); 188 end Is_Open; 189 190 ---------- 191 -- Mode -- 192 ---------- 193 194 function Mode (File : File_Type) return File_Mode is 195 begin 196 return To_SIO (FIO.Mode (AP (File))); 197 end Mode; 198 199 ---------- 200 -- Name -- 201 ---------- 202 203 function Name (File : File_Type) return String is 204 begin 205 return FIO.Name (AP (File)); 206 end Name; 207 208 ---------- 209 -- Open -- 210 ---------- 211 212 procedure Open 213 (File : in out File_Type; 214 Mode : File_Mode; 215 Name : String; 216 Form : String := "") 217 is 218 Dummy_File_Control_Block : Stream_AFCB; 219 pragma Warnings (Off, Dummy_File_Control_Block); 220 -- Yes, we know this is never assigned a value, only the tag 221 -- is used for dispatching purposes, so that's expected. 222 223 begin 224 FIO.Open (File_Ptr => AP (File), 225 Dummy_FCB => Dummy_File_Control_Block, 226 Mode => To_FCB (Mode), 227 Name => Name, 228 Form => Form, 229 Amethod => 'S', 230 Creat => False, 231 Text => False); 232 233 -- Ensure that the stream index is set properly (e.g., for Append_File) 234 235 Reset (File, Mode); 236 237 -- Set last operation. The purpose here is to ensure proper handling 238 -- of the initial operation. In general, a write after a read requires 239 -- resetting and doing a seek, so we set the last operation as Read 240 -- for an In_Out file, but for an Out file we set the last operation 241 -- to Op_Write, since in this case it is not necessary to do a seek 242 -- (and furthermore there are situations (such as the case of writing 243 -- a sequential Posix FIFO file) where the lseek would cause problems. 244 245 File.Last_Op := (if Mode = Out_File then Op_Write else Op_Read); 246 end Open; 247 248 ---------- 249 -- Read -- 250 ---------- 251 252 procedure Read 253 (File : File_Type; 254 Item : out Stream_Element_Array; 255 Last : out Stream_Element_Offset; 256 From : Positive_Count) 257 is 258 begin 259 Set_Index (File, From); 260 Read (File, Item, Last); 261 end Read; 262 263 procedure Read 264 (File : File_Type; 265 Item : out Stream_Element_Array; 266 Last : out Stream_Element_Offset) 267 is 268 Nread : size_t; 269 270 begin 271 FIO.Check_Read_Status (AP (File)); 272 273 -- If last operation was not a read, or if in file sharing mode, 274 -- then reset the physical pointer of the file to match the index 275 -- We lock out task access over the two operations in this case. 276 277 if File.Last_Op /= Op_Read 278 or else File.Shared_Status = FCB.Yes 279 then 280 Locked_Processing : begin 281 SSL.Lock_Task.all; 282 Set_Position (File); 283 FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread); 284 SSL.Unlock_Task.all; 285 286 exception 287 when others => 288 SSL.Unlock_Task.all; 289 raise; 290 end Locked_Processing; 291 292 else 293 FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread); 294 end if; 295 296 File.Index := File.Index + Count (Nread); 297 File.Last_Op := Op_Read; 298 Last := Last_Index (Item'First, Nread); 299 end Read; 300 301 -- This version of Read is the primitive operation on the underlying 302 -- Stream type, used when a Stream_IO file is treated as a Stream 303 304 procedure Read 305 (File : in out Stream_AFCB; 306 Item : out Ada.Streams.Stream_Element_Array; 307 Last : out Ada.Streams.Stream_Element_Offset) 308 is 309 begin 310 Read (File'Unchecked_Access, Item, Last); 311 end Read; 312 313 ----------- 314 -- Reset -- 315 ----------- 316 317 procedure Reset (File : in out File_Type; Mode : File_Mode) is 318 begin 319 FIO.Check_File_Open (AP (File)); 320 321 -- Reset file index to start of file for read/write cases. For 322 -- the append case, the Set_Mode call repositions the index. 323 324 File.Index := 1; 325 Set_Mode (File, Mode); 326 end Reset; 327 328 procedure Reset (File : in out File_Type) is 329 begin 330 Reset (File, To_SIO (File.Mode)); 331 end Reset; 332 333 --------------- 334 -- Set_Index -- 335 --------------- 336 337 procedure Set_Index (File : File_Type; To : Positive_Count) is 338 begin 339 FIO.Check_File_Open (AP (File)); 340 File.Index := Count (To); 341 File.Last_Op := Op_Other; 342 end Set_Index; 343 344 -------------- 345 -- Set_Mode -- 346 -------------- 347 348 procedure Set_Mode (File : in out File_Type; Mode : File_Mode) is 349 begin 350 FIO.Check_File_Open (AP (File)); 351 352 -- If we are switching from read to write, or vice versa, and 353 -- we are not already open in update mode, then reopen in update 354 -- mode now. Note that we can use Inout_File as the mode for the 355 -- call since File_IO handles all modes for all file types. 356 357 if ((File.Mode = FCB.In_File) /= (Mode = In_File)) 358 and then not File.Update_Mode 359 then 360 FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File); 361 File.Update_Mode := True; 362 end if; 363 364 -- Set required mode and position to end of file if append mode 365 366 File.Mode := To_FCB (Mode); 367 FIO.Append_Set (AP (File)); 368 369 if File.Mode = FCB.Append_File then 370 if Standard'Address_Size = 64 then 371 File.Index := Count (ftell64 (File.Stream)) + 1; 372 else 373 File.Index := Count (ftell (File.Stream)) + 1; 374 end if; 375 end if; 376 377 File.Last_Op := Op_Other; 378 end Set_Mode; 379 380 ------------------ 381 -- Set_Position -- 382 ------------------ 383 384 procedure Set_Position (File : File_Type) is 385 use type System.CRTL.int64; 386 R : int; 387 begin 388 R := fseek64 (File.Stream, System.CRTL.int64 (File.Index) - 1, SEEK_SET); 389 390 if R /= 0 then 391 raise Use_Error; 392 end if; 393 end Set_Position; 394 395 ---------- 396 -- Size -- 397 ---------- 398 399 function Size (File : File_Type) return Count is 400 begin 401 FIO.Check_File_Open (AP (File)); 402 403 if File.File_Size = -1 then 404 File.Last_Op := Op_Other; 405 406 if fseek64 (File.Stream, 0, SEEK_END) /= 0 then 407 raise Device_Error; 408 end if; 409 410 File.File_Size := Stream_Element_Offset (ftell64 (File.Stream)); 411 412 if File.File_Size = -1 then 413 raise Use_Error; 414 end if; 415 end if; 416 417 return Count (File.File_Size); 418 end Size; 419 420 ------------ 421 -- Stream -- 422 ------------ 423 424 function Stream (File : File_Type) return Stream_Access is 425 begin 426 FIO.Check_File_Open (AP (File)); 427 return Stream_Access (File); 428 end Stream; 429 430 ----------- 431 -- Write -- 432 ----------- 433 434 procedure Write 435 (File : File_Type; 436 Item : Stream_Element_Array; 437 To : Positive_Count) 438 is 439 begin 440 Set_Index (File, To); 441 Write (File, Item); 442 end Write; 443 444 procedure Write 445 (File : File_Type; 446 Item : Stream_Element_Array) 447 is 448 begin 449 FIO.Check_Write_Status (AP (File)); 450 451 -- If last operation was not a write, or if in file sharing mode, 452 -- then reset the physical pointer of the file to match the index 453 -- We lock out task access over the two operations in this case. 454 455 if File.Last_Op /= Op_Write 456 or else File.Shared_Status = FCB.Yes 457 then 458 Locked_Processing : begin 459 SSL.Lock_Task.all; 460 Set_Position (File); 461 FIO.Write_Buf (AP (File), Item'Address, Item'Length); 462 SSL.Unlock_Task.all; 463 464 exception 465 when others => 466 SSL.Unlock_Task.all; 467 raise; 468 end Locked_Processing; 469 470 else 471 FIO.Write_Buf (AP (File), Item'Address, Item'Length); 472 end if; 473 474 File.Index := File.Index + Item'Length; 475 File.Last_Op := Op_Write; 476 File.File_Size := -1; 477 end Write; 478 479 -- This version of Write is the primitive operation on the underlying 480 -- Stream type, used when a Stream_IO file is treated as a Stream 481 482 procedure Write 483 (File : in out Stream_AFCB; 484 Item : Ada.Streams.Stream_Element_Array) 485 is 486 begin 487 Write (File'Unchecked_Access, Item); 488 end Write; 489 490end Ada.Streams.Stream_IO; 491