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 --                            $Revision: 1.32 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2000, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Interfaces.C_Streams;      use Interfaces.C_Streams;
  37 with System;                    use System;
  38 with System.File_IO;
  39 with System.Soft_Links;
  40 with Unchecked_Conversion;
  41 with 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 Unchecked_Conversion (File_Mode, FCB.File_Mode);
  51    function To_SIO is new 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 : in 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    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    begin
  79       null;
  80    end AFCB_Close;
  81
  82    ---------------
  83    -- AFCB_Free --
  84    ---------------
  85
  86    procedure AFCB_Free (File : access Stream_AFCB) is
  87       type FCB_Ptr is access all Stream_AFCB;
  88       FT : FCB_Ptr := FCB_Ptr (File);
  89
  90       procedure Free is new Unchecked_Deallocation (Stream_AFCB, FCB_Ptr);
  91
  92    begin
  93       Free (FT);
  94    end AFCB_Free;
  95
  96    -----------
  97    -- Close --
  98    -----------
  99
 100    procedure Close (File : in out File_Type) is
 101    begin
 102       FIO.Close (AP (File));
 103    end Close;
 104
 105    ------------
 106    -- Create --
 107    ------------
 108
 109    procedure Create
 110      (File : in out File_Type;
 111       Mode : in File_Mode := Out_File;
 112       Name : in String := "";
 113       Form : in String := "")
 114    is
 115       File_Control_Block : Stream_AFCB;
 116
 117    begin
 118       FIO.Open (File_Ptr  => AP (File),
 119                 Dummy_FCB => File_Control_Block,
 120                 Mode      => To_FCB (Mode),
 121                 Name      => Name,
 122                 Form      => Form,
 123                 Amethod   => 'S',
 124                 Creat     => True,
 125                 Text      => False);
 126       File.Last_Op := Op_Write;
 127    end Create;
 128
 129    ------------
 130    -- Delete --
 131    ------------
 132
 133    procedure Delete (File : in out File_Type) is
 134    begin
 135       FIO.Delete (AP (File));
 136    end Delete;
 137
 138    -----------------
 139    -- End_Of_File --
 140    -----------------
 141
 142    function End_Of_File (File : in File_Type) return Boolean is
 143    begin
 144       FIO.Check_Read_Status (AP (File));
 145       return Count (File.Index) > Size (File);
 146    end End_Of_File;
 147
 148    -----------
 149    -- Flush --
 150    -----------
 151
 152    procedure Flush (File : in out File_Type) is
 153    begin
 154       FIO.Flush (AP (File));
 155    end Flush;
 156
 157    ----------
 158    -- Form --
 159    ----------
 160
 161    function Form (File : in File_Type) return String is
 162    begin
 163       return FIO.Form (AP (File));
 164    end Form;
 165
 166    -----------
 167    -- Index --
 168    -----------
 169
 170    function Index (File : in File_Type) return Positive_Count is
 171    begin
 172       FIO.Check_File_Open (AP (File));
 173       return Count (File.Index);
 174    end Index;
 175
 176    -------------
 177    -- Is_Open --
 178    -------------
 179
 180    function Is_Open (File : in File_Type) return Boolean is
 181    begin
 182       return FIO.Is_Open (AP (File));
 183    end Is_Open;
 184
 185    ----------
 186    -- Mode --
 187    ----------
 188
 189    function Mode (File : in File_Type) return File_Mode is
 190    begin
 191       return To_SIO (FIO.Mode (AP (File)));
 192    end Mode;
 193
 194    ----------
 195    -- Name --
 196    ----------
 197
 198    function Name (File : in File_Type) return String is
 199    begin
 200       return FIO.Name (AP (File));
 201    end Name;
 202
 203    ----------
 204    -- Open --
 205    ----------
 206
 207    procedure Open
 208      (File : in out File_Type;
 209       Mode : in File_Mode;
 210       Name : in String;
 211       Form : in String := "")
 212    is
 213       File_Control_Block : Stream_AFCB;
 214
 215    begin
 216       FIO.Open (File_Ptr  => AP (File),
 217                 Dummy_FCB => File_Control_Block,
 218                 Mode      => To_FCB (Mode),
 219                 Name      => Name,
 220                 Form      => Form,
 221                 Amethod   => 'S',
 222                 Creat     => False,
 223                 Text      => False);
 224
 225       --  Ensure that the stream index is set properly (e.g., for Append_File)
 226
 227       Reset (File, Mode);
 228
 229       File.Last_Op := Op_Read;
 230    end Open;
 231
 232    ----------
 233    -- Read --
 234    ----------
 235
 236    procedure Read
 237      (File : in File_Type;
 238       Item : out Stream_Element_Array;
 239       Last : out Stream_Element_Offset;
 240       From : in Positive_Count)
 241    is
 242    begin
 243       Set_Index (File, From);
 244       Read (File, Item, Last);
 245    end Read;
 246
 247    procedure Read
 248      (File : in File_Type;
 249       Item : out Stream_Element_Array;
 250       Last : out Stream_Element_Offset)
 251    is
 252       Nread : size_t;
 253
 254    begin
 255       FIO.Check_Read_Status (AP (File));
 256
 257       --  If last operation was not a read, or if in file sharing mode,
 258       --  then reset the physical pointer of the file to match the index
 259       --  We lock out task access over the two operations in this case.
 260
 261       if File.Last_Op /= Op_Read
 262         or else File.Shared_Status = FCB.Yes
 263       then
 264          if End_Of_File (File) then
 265             raise End_Error;
 266          end if;
 267
 268          Locked_Processing : begin
 269             SSL.Lock_Task.all;
 270             Set_Position (File);
 271             FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
 272             SSL.Unlock_Task.all;
 273
 274          exception
 275             when others =>
 276                SSL.Unlock_Task.all;
 277                raise;
 278          end Locked_Processing;
 279
 280       else
 281          FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
 282       end if;
 283
 284       File.Index := File.Index + Count (Nread);
 285       Last := Item'First + Stream_Element_Offset (Nread) - 1;
 286       File.Last_Op := Op_Read;
 287    end Read;
 288
 289    --  This version of Read is the primitive operation on the underlying
 290    --  Stream type, used when a Stream_IO file is treated as a Stream
 291
 292    procedure Read
 293      (File : in out Stream_AFCB;
 294       Item : out Ada.Streams.Stream_Element_Array;
 295       Last : out Ada.Streams.Stream_Element_Offset)
 296    is
 297    begin
 298       Read (File'Unchecked_Access, Item, Last);
 299    end Read;
 300
 301    -----------
 302    -- Reset --
 303    -----------
 304
 305    procedure Reset (File : in out File_Type; Mode : in File_Mode) is
 306    begin
 307       FIO.Check_File_Open (AP (File));
 308
 309       --  Reset file index to start of file for read/write cases. For
 310       --  the append case, the Set_Mode call repositions the index.
 311
 312       File.Index := 1;
 313       Set_Mode (File, Mode);
 314    end Reset;
 315
 316    procedure Reset (File : in out File_Type) is
 317    begin
 318       Reset (File, To_SIO (File.Mode));
 319    end Reset;
 320
 321    ---------------
 322    -- Set_Index --
 323    ---------------
 324
 325    procedure Set_Index (File : in File_Type; To : in Positive_Count) is
 326    begin
 327       FIO.Check_File_Open (AP (File));
 328       File.Index := Count (To);
 329       File.Last_Op := Op_Other;
 330    end Set_Index;
 331
 332    --------------
 333    -- Set_Mode --
 334    --------------
 335
 336    procedure Set_Mode (File : in out File_Type; Mode : in File_Mode) is
 337    begin
 338       FIO.Check_File_Open (AP (File));
 339
 340       --  If we are switching from read to write, or vice versa, and
 341       --  we are not already open in update mode, then reopen in update
 342       --  mode now. Note that we can use Inout_File as the mode for the
 343       --  call since File_IO handles all modes for all file types.
 344
 345       if ((File.Mode = FCB.In_File) /= (Mode = In_File))
 346         and then not File.Update_Mode
 347       then
 348          FIO.Reset (AP (File), FCB.Inout_File);
 349          File.Update_Mode := True;
 350       end if;
 351
 352       --  Set required mode and position to end of file if append mode
 353
 354       File.Mode := To_FCB (Mode);
 355       FIO.Append_Set (AP (File));
 356
 357       if File.Mode = FCB.Append_File then
 358          File.Index := Count (ftell (File.Stream)) + 1;
 359       end if;
 360
 361       File.Last_Op := Op_Other;
 362    end Set_Mode;
 363
 364    ------------------
 365    -- Set_Position --
 366    ------------------
 367
 368    procedure Set_Position (File : in File_Type) is
 369    begin
 370       if fseek (File.Stream, long (File.Index) - 1, SEEK_SET) /= 0 then
 371          raise Use_Error;
 372       end if;
 373    end Set_Position;
 374
 375    ----------
 376    -- Size --
 377    ----------
 378
 379    function Size (File : in File_Type) return Count is
 380    begin
 381       FIO.Check_File_Open (AP (File));
 382
 383       if File.File_Size = -1 then
 384          File.Last_Op := Op_Other;
 385
 386          if fseek (File.Stream, 0, SEEK_END) /= 0 then
 387             raise Device_Error;
 388          end if;
 389
 390          File.File_Size := Stream_Element_Offset (ftell (File.Stream));
 391       end if;
 392
 393       return Count (File.File_Size);
 394    end Size;
 395
 396    ------------
 397    -- Stream --
 398    ------------
 399
 400    function Stream (File : in File_Type) return Stream_Access is
 401    begin
 402       FIO.Check_File_Open (AP (File));
 403       return Stream_Access (File);
 404    end Stream;
 405
 406    -----------
 407    -- Write --
 408    -----------
 409
 410    procedure Write
 411      (File : in File_Type;
 412       Item : in Stream_Element_Array;
 413       To   : in Positive_Count)
 414    is
 415    begin
 416       Set_Index (File, To);
 417       Write (File, Item);
 418    end Write;
 419
 420    procedure Write (File : in File_Type; Item : in Stream_Element_Array) is
 421    begin
 422       FIO.Check_Write_Status (AP (File));
 423
 424       --  If last operation was not a write, or if in file sharing mode,
 425       --  then reset the physical pointer of the file to match the index
 426       --  We lock out task access over the two operations in this case.
 427
 428       if File.Last_Op /= Op_Write
 429         or else File.Shared_Status = FCB.Yes
 430       then
 431          Locked_Processing : begin
 432             SSL.Lock_Task.all;
 433             Set_Position (File);
 434             FIO.Write_Buf (AP (File), Item'Address, Item'Length);
 435             SSL.Unlock_Task.all;
 436
 437          exception
 438             when others =>
 439                SSL.Unlock_Task.all;
 440                raise;
 441          end Locked_Processing;
 442
 443       else
 444          FIO.Write_Buf (AP (File), Item'Address, Item'Length);
 445       end if;
 446
 447       File.Index := File.Index + Item'Length;
 448       File.Last_Op := Op_Write;
 449       File.File_Size := -1;
 450    end Write;
 451
 452    --  This version of Write is the primitive operation on the underlying
 453    --  Stream type, used when a Stream_IO file is treated as a Stream
 454
 455    procedure Write
 456      (File : in out Stream_AFCB;
 457       Item : in Ada.Streams.Stream_Element_Array)
 458    is
 459    begin
 460       Write (File'Unchecked_Access, Item);
 461    end Write;
 462
 463 end Ada.Streams.Stream_IO;