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       if Mode = Out_File then
 245          File.Last_Op := Op_Write;
 246       else
 247          File.Last_Op := Op_Read;
 248       end if;
 249    end Open;
 250
 251    ----------
 252    -- Read --
 253    ----------
 254
 255    procedure Read
 256      (File : File_Type;
 257       Item : out Stream_Element_Array;
 258       Last : out Stream_Element_Offset;
 259       From : Positive_Count)
 260    is
 261    begin
 262       Set_Index (File, From);
 263       Read (File, Item, Last);
 264    end Read;
 265
 266    procedure Read
 267      (File : File_Type;
 268       Item : out Stream_Element_Array;
 269       Last : out Stream_Element_Offset)
 270    is
 271       Nread : size_t;
 272
 273    begin
 274       FIO.Check_Read_Status (AP (File));
 275
 276       --  If last operation was not a read, or if in file sharing mode,
 277       --  then reset the physical pointer of the file to match the index
 278       --  We lock out task access over the two operations in this case.
 279
 280       if File.Last_Op /= Op_Read
 281         or else File.Shared_Status = FCB.Yes
 282       then
 283          Locked_Processing : begin
 284             SSL.Lock_Task.all;
 285             Set_Position (File);
 286             FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
 287             SSL.Unlock_Task.all;
 288
 289          exception
 290             when others =>
 291                SSL.Unlock_Task.all;
 292                raise;
 293          end Locked_Processing;
 294
 295       else
 296          FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
 297       end if;
 298
 299       File.Index := File.Index + Count (Nread);
 300       Last := Item'First + Stream_Element_Offset (Nread) - 1;
 301       File.Last_Op := Op_Read;
 302    end Read;
 303
 304    --  This version of Read is the primitive operation on the underlying
 305    --  Stream type, used when a Stream_IO file is treated as a Stream
 306
 307    procedure Read
 308      (File : in out Stream_AFCB;
 309       Item : out Ada.Streams.Stream_Element_Array;
 310       Last : out Ada.Streams.Stream_Element_Offset)
 311    is
 312    begin
 313       Read (File'Unchecked_Access, Item, Last);
 314    end Read;
 315
 316    -----------
 317    -- Reset --
 318    -----------
 319
 320    procedure Reset (File : in out File_Type; Mode : File_Mode) is
 321    begin
 322       FIO.Check_File_Open (AP (File));
 323
 324       --  Reset file index to start of file for read/write cases. For
 325       --  the append case, the Set_Mode call repositions the index.
 326
 327       File.Index := 1;
 328       Set_Mode (File, Mode);
 329    end Reset;
 330
 331    procedure Reset (File : in out File_Type) is
 332    begin
 333       Reset (File, To_SIO (File.Mode));
 334    end Reset;
 335
 336    ---------------
 337    -- Set_Index --
 338    ---------------
 339
 340    procedure Set_Index (File : File_Type; To : Positive_Count) is
 341    begin
 342       FIO.Check_File_Open (AP (File));
 343       File.Index := Count (To);
 344       File.Last_Op := Op_Other;
 345    end Set_Index;
 346
 347    --------------
 348    -- Set_Mode --
 349    --------------
 350
 351    procedure Set_Mode (File : in out File_Type; Mode : File_Mode) is
 352    begin
 353       FIO.Check_File_Open (AP (File));
 354
 355       --  If we are switching from read to write, or vice versa, and
 356       --  we are not already open in update mode, then reopen in update
 357       --  mode now. Note that we can use Inout_File as the mode for the
 358       --  call since File_IO handles all modes for all file types.
 359
 360       if ((File.Mode = FCB.In_File) /= (Mode = In_File))
 361         and then not File.Update_Mode
 362       then
 363          FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File);
 364          File.Update_Mode := True;
 365       end if;
 366
 367       --  Set required mode and position to end of file if append mode
 368
 369       File.Mode := To_FCB (Mode);
 370       FIO.Append_Set (AP (File));
 371
 372       if File.Mode = FCB.Append_File then
 373          File.Index := Count (ftell (File.Stream)) + 1;
 374       end if;
 375
 376       File.Last_Op := Op_Other;
 377    end Set_Mode;
 378
 379    ------------------
 380    -- Set_Position --
 381    ------------------
 382
 383    procedure Set_Position (File : File_Type) is
 384       use type System.CRTL.long;
 385    begin
 386       if fseek (File.Stream,
 387                 System.CRTL.long (File.Index) - 1, SEEK_SET) /= 0
 388       then
 389          raise Use_Error;
 390       end if;
 391    end Set_Position;
 392
 393    ----------
 394    -- Size --
 395    ----------
 396
 397    function Size (File : File_Type) return Count is
 398    begin
 399       FIO.Check_File_Open (AP (File));
 400
 401       if File.File_Size = -1 then
 402          File.Last_Op := Op_Other;
 403
 404          if fseek (File.Stream, 0, SEEK_END) /= 0 then
 405             raise Device_Error;
 406          end if;
 407
 408          File.File_Size := Stream_Element_Offset (ftell (File.Stream));
 409       end if;
 410
 411       return Count (File.File_Size);
 412    end Size;
 413
 414    ------------
 415    -- Stream --
 416    ------------
 417
 418    function Stream (File : File_Type) return Stream_Access is
 419    begin
 420       FIO.Check_File_Open (AP (File));
 421       return Stream_Access (File);
 422    end Stream;
 423
 424    -----------
 425    -- Write --
 426    -----------
 427
 428    procedure Write
 429      (File : File_Type;
 430       Item : Stream_Element_Array;
 431       To   : Positive_Count)
 432    is
 433    begin
 434       Set_Index (File, To);
 435       Write (File, Item);
 436    end Write;
 437
 438    procedure Write
 439      (File : File_Type;
 440       Item : Stream_Element_Array)
 441    is
 442    begin
 443       FIO.Check_Write_Status (AP (File));
 444
 445       --  If last operation was not a write, or if in file sharing mode,
 446       --  then reset the physical pointer of the file to match the index
 447       --  We lock out task access over the two operations in this case.
 448
 449       if File.Last_Op /= Op_Write
 450         or else File.Shared_Status = FCB.Yes
 451       then
 452          Locked_Processing : begin
 453             SSL.Lock_Task.all;
 454             Set_Position (File);
 455             FIO.Write_Buf (AP (File), Item'Address, Item'Length);
 456             SSL.Unlock_Task.all;
 457
 458          exception
 459             when others =>
 460                SSL.Unlock_Task.all;
 461                raise;
 462          end Locked_Processing;
 463
 464       else
 465          FIO.Write_Buf (AP (File), Item'Address, Item'Length);
 466       end if;
 467
 468       File.Index := File.Index + Item'Length;
 469       File.Last_Op := Op_Write;
 470       File.File_Size := -1;
 471    end Write;
 472
 473    --  This version of Write is the primitive operation on the underlying
 474    --  Stream type, used when a Stream_IO file is treated as a Stream
 475
 476    procedure Write
 477      (File : in out Stream_AFCB;
 478       Item : Ada.Streams.Stream_Element_Array)
 479    is
 480    begin
 481       Write (File'Unchecked_Access, Item);
 482    end Write;
 483
 484 end Ada.Streams.Stream_IO;