gcc/ada/s-direio.adb

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