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