gcc/ada/s-direio.adb

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