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