gcc/ada/a-ststio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                A D A . S T R E A M S . S T R E A M _ 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 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_Conversion;
  40 with Unchecked_Deallocation;
  41
  42 package body Ada.Streams.Stream_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
  49    function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
  50    function To_SIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
  51    use type FCB.File_Mode;
  52    use type FCB.Shared_Status_Type;
  53
  54    -----------------------
  55    -- Local Subprograms --
  56    -----------------------
  57
  58    procedure Set_Position (File : in File_Type);
  59    --  Sets file position pointer according to value of current index
  60
  61    -------------------
  62    -- AFCB_Allocate --
  63    -------------------
  64
  65    function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr is
  66       pragma Warnings (Off, Control_Block);
  67
  68    begin
  69       return new Stream_AFCB;
  70    end AFCB_Allocate;
  71
  72    ----------------
  73    -- AFCB_Close --
  74    ----------------
  75
  76    --  No special processing required for closing Stream_IO file
  77
  78    procedure AFCB_Close (File : access Stream_AFCB) is
  79       pragma Warnings (Off, File);
  80
  81    begin
  82       null;
  83    end AFCB_Close;
  84
  85    ---------------
  86    -- AFCB_Free --
  87    ---------------
  88
  89    procedure AFCB_Free (File : access Stream_AFCB) is
  90       type FCB_Ptr is access all Stream_AFCB;
  91       FT : FCB_Ptr := FCB_Ptr (File);
  92
  93       procedure Free is new Unchecked_Deallocation (Stream_AFCB, FCB_Ptr);
  94
  95    begin
  96       Free (FT);
  97    end AFCB_Free;
  98
  99    -----------
 100    -- Close --
 101    -----------
 102
 103    procedure Close (File : in out File_Type) is
 104    begin
 105       FIO.Close (AP (File));
 106    end Close;
 107
 108    ------------
 109    -- Create --
 110    ------------
 111
 112    procedure Create
 113      (File : in out File_Type;
 114       Mode : in File_Mode := Out_File;
 115       Name : in String := "";
 116       Form : in String := "")
 117    is
 118       File_Control_Block : Stream_AFCB;
 119
 120    begin
 121       FIO.Open (File_Ptr  => AP (File),
 122                 Dummy_FCB => File_Control_Block,
 123                 Mode      => To_FCB (Mode),
 124                 Name      => Name,
 125                 Form      => Form,
 126                 Amethod   => 'S',
 127                 Creat     => True,
 128                 Text      => False);
 129       File.Last_Op := Op_Write;
 130    end Create;
 131
 132    ------------
 133    -- Delete --
 134    ------------
 135
 136    procedure Delete (File : in out File_Type) is
 137    begin
 138       FIO.Delete (AP (File));
 139    end Delete;
 140
 141    -----------------
 142    -- End_Of_File --
 143    -----------------
 144
 145    function End_Of_File (File : in File_Type) return Boolean is
 146    begin
 147       FIO.Check_Read_Status (AP (File));
 148       return Count (File.Index) > Size (File);
 149    end End_Of_File;
 150
 151    -----------
 152    -- Flush --
 153    -----------
 154
 155    procedure Flush (File : File_Type) is
 156    begin
 157       FIO.Flush (AP (File));
 158    end Flush;
 159
 160    ----------
 161    -- Form --
 162    ----------
 163
 164    function Form (File : in File_Type) return String is
 165    begin
 166       return FIO.Form (AP (File));
 167    end Form;
 168
 169    -----------
 170    -- Index --
 171    -----------
 172
 173    function Index (File : in File_Type) return Positive_Count is
 174    begin
 175       FIO.Check_File_Open (AP (File));
 176       return Count (File.Index);
 177    end Index;
 178
 179    -------------
 180    -- Is_Open --
 181    -------------
 182
 183    function Is_Open (File : in File_Type) return Boolean is
 184    begin
 185       return FIO.Is_Open (AP (File));
 186    end Is_Open;
 187
 188    ----------
 189    -- Mode --
 190    ----------
 191
 192    function Mode (File : in File_Type) return File_Mode is
 193    begin
 194       return To_SIO (FIO.Mode (AP (File)));
 195    end Mode;
 196
 197    ----------
 198    -- Name --
 199    ----------
 200
 201    function Name (File : in File_Type) return String is
 202    begin
 203       return FIO.Name (AP (File));
 204    end Name;
 205
 206    ----------
 207    -- Open --
 208    ----------
 209
 210    procedure Open
 211      (File : in out File_Type;
 212       Mode : in File_Mode;
 213       Name : in String;
 214       Form : in String := "")
 215    is
 216       File_Control_Block : Stream_AFCB;
 217
 218    begin
 219       FIO.Open (File_Ptr  => AP (File),
 220                 Dummy_FCB => File_Control_Block,
 221                 Mode      => To_FCB (Mode),
 222                 Name      => Name,
 223                 Form      => Form,
 224                 Amethod   => 'S',
 225                 Creat     => False,
 226                 Text      => False);
 227
 228       --  Ensure that the stream index is set properly (e.g., for Append_File)
 229
 230       Reset (File, Mode);
 231
 232       File.Last_Op := Op_Read;
 233    end Open;
 234
 235    ----------
 236    -- Read --
 237    ----------
 238
 239    procedure Read
 240      (File : in File_Type;
 241       Item : out Stream_Element_Array;
 242       Last : out Stream_Element_Offset;
 243       From : in Positive_Count)
 244    is
 245    begin
 246       Set_Index (File, From);
 247       Read (File, Item, Last);
 248    end Read;
 249
 250    procedure Read
 251      (File : in File_Type;
 252       Item : out Stream_Element_Array;
 253       Last : out Stream_Element_Offset)
 254    is
 255       Nread : size_t;
 256
 257    begin
 258       FIO.Check_Read_Status (AP (File));
 259
 260       --  If last operation was not a read, or if in file sharing mode,
 261       --  then reset the physical pointer of the file to match the index
 262       --  We lock out task access over the two operations in this case.
 263
 264       if File.Last_Op /= Op_Read
 265         or else File.Shared_Status = FCB.Yes
 266       then
 267          Locked_Processing : begin
 268             SSL.Lock_Task.all;
 269             Set_Position (File);
 270             FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
 271             SSL.Unlock_Task.all;
 272
 273          exception
 274             when others =>
 275                SSL.Unlock_Task.all;
 276                raise;
 277          end Locked_Processing;
 278
 279       else
 280          FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
 281       end if;
 282
 283       File.Index := File.Index + Count (Nread);
 284       Last := Item'First + Stream_Element_Offset (Nread) - 1;
 285       File.Last_Op := Op_Read;
 286    end Read;
 287
 288    --  This version of Read is the primitive operation on the underlying
 289    --  Stream type, used when a Stream_IO file is treated as a Stream
 290
 291    procedure Read
 292      (File : in out Stream_AFCB;
 293       Item : out Ada.Streams.Stream_Element_Array;
 294       Last : out Ada.Streams.Stream_Element_Offset)
 295    is
 296    begin
 297       Read (File'Unchecked_Access, Item, Last);
 298    end Read;
 299
 300    -----------
 301    -- Reset --
 302    -----------
 303
 304    procedure Reset (File : in out File_Type; Mode : in File_Mode) is
 305    begin
 306       FIO.Check_File_Open (AP (File));
 307
 308       --  Reset file index to start of file for read/write cases. For
 309       --  the append case, the Set_Mode call repositions the index.
 310
 311       File.Index := 1;
 312       Set_Mode (File, Mode);
 313    end Reset;
 314
 315    procedure Reset (File : in out File_Type) is
 316    begin
 317       Reset (File, To_SIO (File.Mode));
 318    end Reset;
 319
 320    ---------------
 321    -- Set_Index --
 322    ---------------
 323
 324    procedure Set_Index (File : in File_Type; To : in Positive_Count) is
 325    begin
 326       FIO.Check_File_Open (AP (File));
 327       File.Index := Count (To);
 328       File.Last_Op := Op_Other;
 329    end Set_Index;
 330
 331    --------------
 332    -- Set_Mode --
 333    --------------
 334
 335    procedure Set_Mode (File : in out File_Type; Mode : in File_Mode) is
 336    begin
 337       FIO.Check_File_Open (AP (File));
 338
 339       --  If we are switching from read to write, or vice versa, and
 340       --  we are not already open in update mode, then reopen in update
 341       --  mode now. Note that we can use Inout_File as the mode for the
 342       --  call since File_IO handles all modes for all file types.
 343
 344       if ((File.Mode = FCB.In_File) /= (Mode = In_File))
 345         and then not File.Update_Mode
 346       then
 347          FIO.Reset (AP (File), FCB.Inout_File);
 348          File.Update_Mode := True;
 349       end if;
 350
 351       --  Set required mode and position to end of file if append mode
 352
 353       File.Mode := To_FCB (Mode);
 354       FIO.Append_Set (AP (File));
 355
 356       if File.Mode = FCB.Append_File then
 357          File.Index := Count (ftell (File.Stream)) + 1;
 358       end if;
 359
 360       File.Last_Op := Op_Other;
 361    end Set_Mode;
 362
 363    ------------------
 364    -- Set_Position --
 365    ------------------
 366
 367    procedure Set_Position (File : in File_Type) is
 368    begin
 369       if fseek (File.Stream, long (File.Index) - 1, SEEK_SET) /= 0 then
 370          raise Use_Error;
 371       end if;
 372    end Set_Position;
 373
 374    ----------
 375    -- Size --
 376    ----------
 377
 378    function Size (File : in File_Type) return Count is
 379    begin
 380       FIO.Check_File_Open (AP (File));
 381
 382       if File.File_Size = -1 then
 383          File.Last_Op := Op_Other;
 384
 385          if fseek (File.Stream, 0, SEEK_END) /= 0 then
 386             raise Device_Error;
 387          end if;
 388
 389          File.File_Size := Stream_Element_Offset (ftell (File.Stream));
 390       end if;
 391
 392       return Count (File.File_Size);
 393    end Size;
 394
 395    ------------
 396    -- Stream --
 397    ------------
 398
 399    function Stream (File : in File_Type) return Stream_Access is
 400    begin
 401       FIO.Check_File_Open (AP (File));
 402       return Stream_Access (File);
 403    end Stream;
 404
 405    -----------
 406    -- Write --
 407    -----------
 408
 409    procedure Write
 410      (File : in File_Type;
 411       Item : in Stream_Element_Array;
 412       To   : in Positive_Count)
 413    is
 414    begin
 415       Set_Index (File, To);
 416       Write (File, Item);
 417    end Write;
 418
 419    procedure Write (File : in File_Type; Item : in Stream_Element_Array) is
 420    begin
 421       FIO.Check_Write_Status (AP (File));
 422
 423       --  If last operation was not a write, or if in file sharing mode,
 424       --  then reset the physical pointer of the file to match the index
 425       --  We lock out task access over the two operations in this case.
 426
 427       if File.Last_Op /= Op_Write
 428         or else File.Shared_Status = FCB.Yes
 429       then
 430          Locked_Processing : begin
 431             SSL.Lock_Task.all;
 432             Set_Position (File);
 433             FIO.Write_Buf (AP (File), Item'Address, Item'Length);
 434             SSL.Unlock_Task.all;
 435
 436          exception
 437             when others =>
 438                SSL.Unlock_Task.all;
 439                raise;
 440          end Locked_Processing;
 441
 442       else
 443          FIO.Write_Buf (AP (File), Item'Address, Item'Length);
 444       end if;
 445
 446       File.Index := File.Index + Item'Length;
 447       File.Last_Op := Op_Write;
 448       File.File_Size := -1;
 449    end Write;
 450
 451    --  This version of Write is the primitive operation on the underlying
 452    --  Stream type, used when a Stream_IO file is treated as a Stream
 453
 454    procedure Write
 455      (File : in out Stream_AFCB;
 456       Item : in Ada.Streams.Stream_Element_Array)
 457    is
 458    begin
 459       Write (File'Unchecked_Access, Item);
 460    end Write;
 461
 462 end Ada.Streams.Stream_IO;