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