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