gcc/ada/a-ststio.adb

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