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 --                            $Revision: 1.17 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-1999 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.IO_Exceptions;         use Ada.IO_Exceptions;
  37 with Interfaces.C_Streams;      use Interfaces.C_Streams;
  38 with System;                    use System;
  39 with System.File_IO;
  40 with System.Soft_Links;
  41 with Unchecked_Deallocation;
  42
  43 package body System.Direct_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    use type FCB.Shared_Status_Type;
  50
  51    -----------------------
  52    -- Local Subprograms --
  53    -----------------------
  54
  55    procedure Set_Position (File : in 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    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    begin
  75       null;
  76    end AFCB_Close;
  77
  78    ---------------
  79    -- AFCB_Free --
  80    ---------------
  81
  82    procedure AFCB_Free (File : access Direct_AFCB) is
  83
  84       type FCB_Ptr is access all Direct_AFCB;
  85
  86       FT : FCB_Ptr := FCB_Ptr (File);
  87
  88       procedure Free is new
  89         Unchecked_Deallocation (Direct_AFCB, FCB_Ptr);
  90
  91    begin
  92       Free (FT);
  93    end AFCB_Free;
  94
  95    ------------
  96    -- Create --
  97    ------------
  98
  99    procedure Create
 100      (File : in out File_Type;
 101       Mode : in FCB.File_Mode := FCB.Inout_File;
 102       Name : in String := "";
 103       Form : in String := "")
 104    is
 105       File_Control_Block : Direct_AFCB;
 106
 107    begin
 108       FIO.Open (File_Ptr  => AP (File),
 109                 Dummy_FCB => File_Control_Block,
 110                 Mode      => Mode,
 111                 Name      => Name,
 112                 Form      => Form,
 113                 Amethod   => 'D',
 114                 Creat     => True,
 115                 Text      => False);
 116    end Create;
 117
 118    -----------------
 119    -- End_Of_File --
 120    -----------------
 121
 122    function End_Of_File (File : in File_Type) return Boolean is
 123    begin
 124       FIO.Check_Read_Status (AP (File));
 125       return Count (File.Index) > Size (File);
 126    end End_Of_File;
 127
 128    -----------
 129    -- Index --
 130    -----------
 131
 132    function Index (File : in File_Type) return Positive_Count is
 133    begin
 134       FIO.Check_File_Open (AP (File));
 135       return Count (File.Index);
 136    end Index;
 137
 138    ----------
 139    -- Open --
 140    ----------
 141
 142    procedure Open
 143      (File : in out File_Type;
 144       Mode : in FCB.File_Mode;
 145       Name : in String;
 146       Form : in String := "")
 147    is
 148       File_Control_Block : Direct_AFCB;
 149
 150    begin
 151       FIO.Open (File_Ptr  => AP (File),
 152                 Dummy_FCB => File_Control_Block,
 153                 Mode      => Mode,
 154                 Name      => Name,
 155                 Form      => Form,
 156                 Amethod   => 'D',
 157                 Creat     => False,
 158                 Text      => False);
 159    end Open;
 160
 161    ----------
 162    -- Read --
 163    ----------
 164
 165    procedure Read
 166      (File : in File_Type;
 167       Item : Address;
 168       Size : in Interfaces.C_Streams.size_t;
 169       From : in Positive_Count)
 170    is
 171    begin
 172       Set_Index (File, From);
 173       Read (File, Item, Size);
 174    end Read;
 175
 176    procedure Read
 177      (File : in File_Type;
 178       Item : Address;
 179       Size : in Interfaces.C_Streams.size_t)
 180    is
 181    begin
 182       FIO.Check_Read_Status (AP (File));
 183
 184       --  If last operation was not a read, or if in file sharing mode,
 185       --  then reset the physical pointer of the file to match the index
 186       --  We lock out task access over the two operations in this case.
 187
 188       if File.Last_Op /= Op_Read
 189         or else File.Shared_Status = FCB.Yes
 190       then
 191          if End_Of_File (File) then
 192             raise End_Error;
 193          end if;
 194
 195          Locked_Processing : begin
 196             SSL.Lock_Task.all;
 197             Set_Position (File);
 198             FIO.Read_Buf (AP (File), Item, Size);
 199             SSL.Unlock_Task.all;
 200
 201          exception
 202             when others =>
 203                SSL.Unlock_Task.all;
 204                raise;
 205          end Locked_Processing;
 206
 207       else
 208          FIO.Read_Buf (AP (File), Item, Size);
 209       end if;
 210
 211       File.Index := File.Index + 1;
 212
 213       --  Set last operation to read, unless we did not read a full record
 214       --  (happens with the variant record case) in which case we set the
 215       --  last operation as other, to force the file position to be reset
 216       --  on the next read.
 217
 218       if File.Bytes = Size then
 219          File.Last_Op := Op_Read;
 220       else
 221          File.Last_Op := Op_Other;
 222       end if;
 223    end Read;
 224
 225    --  The following is the required overriding for Stream.Read, which is
 226    --  not used, since we do not do Stream operations on Direct_IO files.
 227
 228    procedure Read
 229      (File : in out Direct_AFCB;
 230       Item : out Ada.Streams.Stream_Element_Array;
 231       Last : out Ada.Streams.Stream_Element_Offset)
 232    is
 233    begin
 234       raise Program_Error;
 235    end Read;
 236
 237    -----------
 238    -- Reset --
 239    -----------
 240
 241    procedure Reset (File : in out File_Type; Mode : in FCB.File_Mode) is
 242    begin
 243       FIO.Reset (AP (File), Mode);
 244       File.Index := 1;
 245       File.Last_Op := Op_Read;
 246    end Reset;
 247
 248    procedure Reset (File : in out File_Type) is
 249    begin
 250       FIO.Reset (AP (File));
 251       File.Index := 1;
 252       File.Last_Op := Op_Read;
 253    end Reset;
 254
 255    ---------------
 256    -- Set_Index --
 257    ---------------
 258
 259    procedure Set_Index (File : in File_Type; To : in Positive_Count) is
 260    begin
 261       FIO.Check_File_Open (AP (File));
 262       File.Index := Count (To);
 263       File.Last_Op := Op_Other;
 264    end Set_Index;
 265
 266    ------------------
 267    -- Set_Position --
 268    ------------------
 269
 270    procedure Set_Position (File : in File_Type) is
 271    begin
 272       if fseek
 273            (File.Stream, long (File.Bytes) *
 274               long (File.Index - 1), SEEK_SET) /= 0
 275       then
 276          raise Use_Error;
 277       end if;
 278    end Set_Position;
 279
 280    ----------
 281    -- Size --
 282    ----------
 283
 284    function Size (File : in File_Type) return Count is
 285    begin
 286       FIO.Check_File_Open (AP (File));
 287       File.Last_Op := Op_Other;
 288
 289       if fseek (File.Stream, 0, SEEK_END) /= 0 then
 290          raise Device_Error;
 291       end if;
 292
 293       return Count (ftell (File.Stream) / long (File.Bytes));
 294    end Size;
 295
 296    -----------
 297    -- Write --
 298    -----------
 299
 300    procedure Write
 301      (File   : File_Type;
 302       Item   : Address;
 303       Size   : in Interfaces.C_Streams.size_t;
 304       Zeroes : System.Storage_Elements.Storage_Array)
 305
 306    is
 307       procedure Do_Write;
 308       --  Do the actual write
 309
 310       procedure Do_Write is
 311       begin
 312          FIO.Write_Buf (AP (File), Item, Size);
 313
 314          --  If we did not write the whole record (happens with the variant
 315          --  record case), then fill out the rest of the record with zeroes.
 316          --  This is cleaner in any case, and is required for the last
 317          --  record, since otherwise the length of the file is wrong.
 318
 319          if File.Bytes > Size then
 320             FIO.Write_Buf (AP (File), Zeroes'Address, File.Bytes - Size);
 321          end if;
 322       end Do_Write;
 323
 324    --  Start of processing for Write
 325
 326    begin
 327       FIO.Check_Write_Status (AP (File));
 328
 329       --  If last operation was not a write, or if in file sharing mode,
 330       --  then reset the physical pointer of the file to match the index
 331       --  We lock out task access over the two operations in this case.
 332
 333       if File.Last_Op /= Op_Write
 334         or else File.Shared_Status = FCB.Yes
 335       then
 336          Locked_Processing : begin
 337             SSL.Lock_Task.all;
 338             Set_Position (File);
 339             Do_Write;
 340             SSL.Unlock_Task.all;
 341
 342          exception
 343             when others =>
 344                SSL.Unlock_Task.all;
 345                raise;
 346          end Locked_Processing;
 347
 348       else
 349          Do_Write;
 350       end if;
 351
 352       File.Index := File.Index + 1;
 353
 354       --  Set last operation to write, unless we did not read a full record
 355       --  (happens with the variant record case) in which case we set the
 356       --  last operation as other, to force the file position to be reset
 357       --  on the next write.
 358
 359       if File.Bytes = Size then
 360          File.Last_Op := Op_Write;
 361       else
 362          File.Last_Op := Op_Other;
 363       end if;
 364    end Write;
 365
 366    --  The following is the required overriding for Stream.Write, which is
 367    --  not used, since we do not do Stream operations on Direct_IO files.
 368
 369    procedure Write
 370      (File : in out Direct_AFCB;
 371       Item : in Ada.Streams.Stream_Element_Array)
 372    is
 373    begin
 374       raise Program_Error;
 375    end Write;
 376
 377 end System.Direct_IO;