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-2009, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Interfaces.C_Streams; use Interfaces.C_Streams;
  33
  34 with System;               use System;
  35 with System.File_IO;
  36 with System.Soft_Links;
  37 with System.CRTL;
  38
  39 with Ada.Unchecked_Conversion;
  40 with Ada.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 Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode);
  50    function To_SIO is new Ada.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 : 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    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 : not null access Stream_AFCB) is
  78       pragma Warnings (Off, File);
  79    begin
  80       null;
  81    end AFCB_Close;
  82
  83    ---------------
  84    -- AFCB_Free --
  85    ---------------
  86
  87    procedure AFCB_Free (File : not null access Stream_AFCB) is
  88       type FCB_Ptr is access all Stream_AFCB;
  89       FT : FCB_Ptr := FCB_Ptr (File);
  90
  91       procedure Free is new Ada.Unchecked_Deallocation (Stream_AFCB, FCB_Ptr);
  92
  93    begin
  94       Free (FT);
  95    end AFCB_Free;
  96
  97    -----------
  98    -- Close --
  99    -----------
 100
 101    procedure Close (File : in out File_Type) is
 102    begin
 103       FIO.Close (AP (File)'Unrestricted_Access);
 104    end Close;
 105
 106    ------------
 107    -- Create --
 108    ------------
 109
 110    procedure Create
 111      (File : in out File_Type;
 112       Mode : File_Mode := Out_File;
 113       Name : String := "";
 114       Form : String := "")
 115    is
 116       Dummy_File_Control_Block : Stream_AFCB;
 117       pragma Warnings (Off, Dummy_File_Control_Block);
 118       --  Yes, we know this is never assigned a value, only the tag
 119       --  is used for dispatching purposes, so that's expected.
 120
 121    begin
 122       FIO.Open (File_Ptr  => AP (File),
 123                 Dummy_FCB => Dummy_File_Control_Block,
 124                 Mode      => To_FCB (Mode),
 125                 Name      => Name,
 126                 Form      => Form,
 127                 Amethod   => 'S',
 128                 Creat     => True,
 129                 Text      => False);
 130       File.Last_Op := Op_Write;
 131    end Create;
 132
 133    ------------
 134    -- Delete --
 135    ------------
 136
 137    procedure Delete (File : in out File_Type) is
 138    begin
 139       FIO.Delete (AP (File)'Unrestricted_Access);
 140    end Delete;
 141
 142    -----------------
 143    -- End_Of_File --
 144    -----------------
 145
 146    function End_Of_File (File : File_Type) return Boolean is
 147    begin
 148       FIO.Check_Read_Status (AP (File));
 149       return Count (File.Index) > Size (File);
 150    end End_Of_File;
 151
 152    -----------
 153    -- Flush --
 154    -----------
 155
 156    procedure Flush (File : File_Type) is
 157    begin
 158       FIO.Flush (AP (File));
 159    end Flush;
 160
 161    ----------
 162    -- Form --
 163    ----------
 164
 165    function Form (File : File_Type) return String is
 166    begin
 167       return FIO.Form (AP (File));
 168    end Form;
 169
 170    -----------
 171    -- Index --
 172    -----------
 173
 174    function Index (File : File_Type) return Positive_Count is
 175    begin
 176       FIO.Check_File_Open (AP (File));
 177       return Count (File.Index);
 178    end Index;
 179
 180    -------------
 181    -- Is_Open --
 182    -------------
 183
 184    function Is_Open (File : File_Type) return Boolean is
 185    begin
 186       return FIO.Is_Open (AP (File));
 187    end Is_Open;
 188
 189    ----------
 190    -- Mode --
 191    ----------
 192
 193    function Mode (File : File_Type) return File_Mode is
 194    begin
 195       return To_SIO (FIO.Mode (AP (File)));
 196    end Mode;
 197
 198    ----------
 199    -- Name --
 200    ----------
 201
 202    function Name (File : File_Type) return String is
 203    begin
 204       return FIO.Name (AP (File));
 205    end Name;
 206
 207    ----------
 208    -- Open --
 209    ----------
 210
 211    procedure Open
 212      (File : in out File_Type;
 213       Mode : File_Mode;
 214       Name : String;
 215       Form : String := "")
 216    is
 217       Dummy_File_Control_Block : Stream_AFCB;
 218       pragma Warnings (Off, Dummy_File_Control_Block);
 219       --  Yes, we know this is never assigned a value, only the tag
 220       --  is used for dispatching purposes, so that's expected.
 221
 222    begin
 223       FIO.Open (File_Ptr  => AP (File),
 224                 Dummy_FCB => Dummy_File_Control_Block,
 225                 Mode      => To_FCB (Mode),
 226                 Name      => Name,
 227                 Form      => Form,
 228                 Amethod   => 'S',
 229                 Creat     => False,
 230                 Text      => False);
 231
 232       --  Ensure that the stream index is set properly (e.g., for Append_File)
 233
 234       Reset (File, Mode);
 235
 236       --  Set last operation. The purpose here is to ensure proper handling
 237       --  of the initial operation. In general, a write after a read requires
 238       --  resetting and doing a seek, so we set the last operation as Read
 239       --  for an In_Out file, but for an Out file we set the last operation
 240       --  to Op_Write, since in this case it is not necessary to do a seek
 241       --  (and furthermore there are situations (such as the case of writing
 242       --  a sequential Posix FIFO file) where the lseek would cause problems.
 243
 244       File.Last_Op := (if Mode = Out_File then Op_Write else Op_Read);
 245    end Open;
 246
 247    ----------
 248    -- Read --
 249    ----------
 250
 251    procedure Read
 252      (File : File_Type;
 253       Item : out Stream_Element_Array;
 254       Last : out Stream_Element_Offset;
 255       From : Positive_Count)
 256    is
 257    begin
 258       Set_Index (File, From);
 259       Read (File, Item, Last);
 260    end Read;
 261
 262    procedure Read
 263      (File : File_Type;
 264       Item : out Stream_Element_Array;
 265       Last : out Stream_Element_Offset)
 266    is
 267       Nread : size_t;
 268
 269    begin
 270       FIO.Check_Read_Status (AP (File));
 271
 272       --  If last operation was not a read, or if in file sharing mode,
 273       --  then reset the physical pointer of the file to match the index
 274       --  We lock out task access over the two operations in this case.
 275
 276       if File.Last_Op /= Op_Read
 277         or else File.Shared_Status = FCB.Yes
 278       then
 279          Locked_Processing : begin
 280             SSL.Lock_Task.all;
 281             Set_Position (File);
 282             FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
 283             SSL.Unlock_Task.all;
 284
 285          exception
 286             when others =>
 287                SSL.Unlock_Task.all;
 288                raise;
 289          end Locked_Processing;
 290
 291       else
 292          FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
 293       end if;
 294
 295       File.Index := File.Index + Count (Nread);
 296       Last := Item'First + Stream_Element_Offset (Nread) - 1;
 297       File.Last_Op := Op_Read;
 298    end Read;
 299
 300    --  This version of Read is the primitive operation on the underlying
 301    --  Stream type, used when a Stream_IO file is treated as a Stream
 302
 303    procedure Read
 304      (File : in out Stream_AFCB;
 305       Item : out Ada.Streams.Stream_Element_Array;
 306       Last : out Ada.Streams.Stream_Element_Offset)
 307    is
 308    begin
 309       Read (File'Unchecked_Access, Item, Last);
 310    end Read;
 311
 312    -----------
 313    -- Reset --
 314    -----------
 315
 316    procedure Reset (File : in out File_Type; Mode : File_Mode) is
 317    begin
 318       FIO.Check_File_Open (AP (File));
 319
 320       --  Reset file index to start of file for read/write cases. For
 321       --  the append case, the Set_Mode call repositions the index.
 322
 323       File.Index := 1;
 324       Set_Mode (File, Mode);
 325    end Reset;
 326
 327    procedure Reset (File : in out File_Type) is
 328    begin
 329       Reset (File, To_SIO (File.Mode));
 330    end Reset;
 331
 332    ---------------
 333    -- Set_Index --
 334    ---------------
 335
 336    procedure Set_Index (File : File_Type; To : Positive_Count) is
 337    begin
 338       FIO.Check_File_Open (AP (File));
 339       File.Index := Count (To);
 340       File.Last_Op := Op_Other;
 341    end Set_Index;
 342
 343    --------------
 344    -- Set_Mode --
 345    --------------
 346
 347    procedure Set_Mode (File : in out File_Type; Mode : File_Mode) is
 348    begin
 349       FIO.Check_File_Open (AP (File));
 350
 351       --  If we are switching from read to write, or vice versa, and
 352       --  we are not already open in update mode, then reopen in update
 353       --  mode now. Note that we can use Inout_File as the mode for the
 354       --  call since File_IO handles all modes for all file types.
 355
 356       if ((File.Mode = FCB.In_File) /= (Mode = In_File))
 357         and then not File.Update_Mode
 358       then
 359          FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File);
 360          File.Update_Mode := True;
 361       end if;
 362
 363       --  Set required mode and position to end of file if append mode
 364
 365       File.Mode := To_FCB (Mode);
 366       FIO.Append_Set (AP (File));
 367
 368       if File.Mode = FCB.Append_File then
 369          File.Index := Count (ftell (File.Stream)) + 1;
 370       end if;
 371
 372       File.Last_Op := Op_Other;
 373    end Set_Mode;
 374
 375    ------------------
 376    -- Set_Position --
 377    ------------------
 378
 379    procedure Set_Position (File : File_Type) is
 380       use type System.CRTL.long;
 381    begin
 382       if fseek (File.Stream,
 383                 System.CRTL.long (File.Index) - 1, SEEK_SET) /= 0
 384       then
 385          raise Use_Error;
 386       end if;
 387    end Set_Position;
 388
 389    ----------
 390    -- Size --
 391    ----------
 392
 393    function Size (File : File_Type) return Count is
 394    begin
 395       FIO.Check_File_Open (AP (File));
 396
 397       if File.File_Size = -1 then
 398          File.Last_Op := Op_Other;
 399
 400          if fseek (File.Stream, 0, SEEK_END) /= 0 then
 401             raise Device_Error;
 402          end if;
 403
 404          File.File_Size := Stream_Element_Offset (ftell (File.Stream));
 405       end if;
 406
 407       return Count (File.File_Size);
 408    end Size;
 409
 410    ------------
 411    -- Stream --
 412    ------------
 413
 414    function Stream (File : File_Type) return Stream_Access is
 415    begin
 416       FIO.Check_File_Open (AP (File));
 417       return Stream_Access (File);
 418    end Stream;
 419
 420    -----------
 421    -- Write --
 422    -----------
 423
 424    procedure Write
 425      (File : File_Type;
 426       Item : Stream_Element_Array;
 427       To   : Positive_Count)
 428    is
 429    begin
 430       Set_Index (File, To);
 431       Write (File, Item);
 432    end Write;
 433
 434    procedure Write
 435      (File : File_Type;
 436       Item : Stream_Element_Array)
 437    is
 438    begin
 439       FIO.Check_Write_Status (AP (File));
 440
 441       --  If last operation was not a write, or if in file sharing mode,
 442       --  then reset the physical pointer of the file to match the index
 443       --  We lock out task access over the two operations in this case.
 444
 445       if File.Last_Op /= Op_Write
 446         or else File.Shared_Status = FCB.Yes
 447       then
 448          Locked_Processing : begin
 449             SSL.Lock_Task.all;
 450             Set_Position (File);
 451             FIO.Write_Buf (AP (File), Item'Address, Item'Length);
 452             SSL.Unlock_Task.all;
 453
 454          exception
 455             when others =>
 456                SSL.Unlock_Task.all;
 457                raise;
 458          end Locked_Processing;
 459
 460       else
 461          FIO.Write_Buf (AP (File), Item'Address, Item'Length);
 462       end if;
 463
 464       File.Index := File.Index + Item'Length;
 465       File.Last_Op := Op_Write;
 466       File.File_Size := -1;
 467    end Write;
 468
 469    --  This version of Write is the primitive operation on the underlying
 470    --  Stream type, used when a Stream_IO file is treated as a Stream
 471
 472    procedure Write
 473      (File : in out Stream_AFCB;
 474       Item : Ada.Streams.Stream_Element_Array)
 475    is
 476    begin
 477       Write (File'Unchecked_Access, Item);
 478    end Write;
 479
 480 end Ada.Streams.Stream_IO;