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