home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / s-direio.adb < prev    next >
Text File  |  1996-09-28  |  9KB  |  316 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                     S Y S T E M . D I R E C T _ I O                      --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.6 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Ada.IO_Exceptions;         use Ada.IO_Exceptions;
  27. with Interfaces.C_Streams;      use Interfaces.C_Streams;
  28. with System;                    use System;
  29. with System.File_IO;
  30. with System.Tasking_Soft_Links;
  31. with Unchecked_Deallocation;
  32.  
  33. package body System.Direct_IO is
  34.  
  35.    package FIO renames System.File_IO;
  36.    subtype AP is FCB.AFCB_Ptr;
  37.  
  38.    -----------------------
  39.    -- Local Subprograms --
  40.    -----------------------
  41.  
  42.    procedure Set_Position (File : in File_Type);
  43.    --  Sets file position pointer according to value of current index
  44.  
  45.    -------------------
  46.    -- AFCB_Allocate --
  47.    -------------------
  48.  
  49.    function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr is
  50.    begin
  51.       return new Direct_AFCB;
  52.    end AFCB_Allocate;
  53.  
  54.    ----------------
  55.    -- AFCB_Close --
  56.    ----------------
  57.  
  58.    --  No special processing required for Direct_IO close
  59.  
  60.    procedure AFCB_Close (File : access Direct_AFCB) is
  61.    begin
  62.       null;
  63.    end AFCB_Close;
  64.  
  65.    ---------------
  66.    -- AFCB_Free --
  67.    ---------------
  68.  
  69.    procedure AFCB_Free (File : access Direct_AFCB) is
  70.  
  71.       type FCB_Ptr is access all Direct_AFCB;
  72.  
  73.       FT : FCB_Ptr := File;
  74.  
  75.       procedure Free is new
  76.         Unchecked_Deallocation (Direct_AFCB, FCB_Ptr);
  77.  
  78.    begin
  79.       Free (FT);
  80.    end AFCB_Free;
  81.  
  82.    ------------
  83.    -- Create --
  84.    ------------
  85.  
  86.    procedure Create
  87.      (File : in out File_Type;
  88.       Mode : in FCB.File_Mode := FCB.Inout_File;
  89.       Name : in String := "";
  90.       Form : in String := "")
  91.    is
  92.       File_Control_Block : Direct_AFCB;
  93.  
  94.    begin
  95.       FIO.Open (File_Ptr  => AP (File),
  96.                 Dummy_FCB => File_Control_Block,
  97.                 Mode      => Mode,
  98.                 Name      => Name,
  99.                 Form      => Form,
  100.                 Amethod   => 'D',
  101.                 Creat     => True,
  102.                 Text      => False);
  103.    end Create;
  104.  
  105.    -----------------
  106.    -- End_Of_File --
  107.    -----------------
  108.  
  109.    function End_Of_File (File : in File_Type) return Boolean is
  110.    begin
  111.       FIO.Check_Read_Status (AP (File));
  112.       return Count (File.Index) > Size (File);
  113.    end End_Of_File;
  114.  
  115.    -----------
  116.    -- Index --
  117.    -----------
  118.  
  119.    function Index (File : in File_Type) return Positive_Count is
  120.    begin
  121.       FIO.Check_File_Open (AP (File));
  122.       return Count (File.Index);
  123.    end Index;
  124.  
  125.    ----------
  126.    -- Open --
  127.    ----------
  128.  
  129.    procedure Open
  130.      (File : in out File_Type;
  131.       Mode : in FCB.File_Mode;
  132.       Name : in String;
  133.       Form : in String := "")
  134.    is
  135.       File_Control_Block : Direct_AFCB;
  136.  
  137.    begin
  138.       FIO.Open (File_Ptr  => AP (File),
  139.                 Dummy_FCB => File_Control_Block,
  140.                 Mode      => Mode,
  141.                 Name      => Name,
  142.                 Form      => Form,
  143.                 Amethod   => 'D',
  144.                 Creat     => False,
  145.                 Text      => False);
  146.    end Open;
  147.  
  148.    ----------
  149.    -- Read --
  150.    ----------
  151.  
  152.    procedure Read
  153.      (File : in File_Type;
  154.       Item : Address;
  155.       From : in Positive_Count)
  156.    is
  157.    begin
  158.       Set_Index (File, From);
  159.       Read (File, Item);
  160.    end Read;
  161.  
  162.    procedure Read
  163.      (File : in File_Type;
  164.      Item  : Address)
  165.    is
  166.    begin
  167.       FIO.Check_Read_Status (AP (File));
  168.  
  169.       --  If last operation was not a read, or if in file sharing mode,
  170.       --  then reset the physical pointer of the file to match the index
  171.       --  We lock out task access over the two operations in this case.
  172.  
  173.       if File.Last_Op /= Op_Read
  174.         or else File.Shared_Status = FCB.Yes
  175.       then
  176.          if End_Of_File (File) then
  177.             raise End_Error;
  178.          end if;
  179.  
  180.          System.Tasking_Soft_Links.Lock_Task;
  181.          Set_Position (File);
  182.          FIO.Read_Buf (AP (File), Item, File.Bytes);
  183.          System.Tasking_Soft_Links.Unlock_Task;
  184.  
  185.       else
  186.          FIO.Read_Buf (AP (File), Item, File.Bytes);
  187.       end if;
  188.  
  189.       File.Index := File.Index + 1;
  190.       File.Last_Op := Op_Read;
  191.    end Read;
  192.  
  193.    --  The following is the required overriding for Stream.Read, which is
  194.    --  not used, since we do not do Stream operations on Direct_IO files.
  195.  
  196.    procedure Read
  197.      (File : in out Direct_AFCB;
  198.       Item : out Ada.Streams.Stream_Element_Array;
  199.       Last : out Ada.Streams.Stream_Element_Offset)
  200.    is
  201.    begin
  202.       raise Program_Error;
  203.    end Read;
  204.  
  205.    -----------
  206.    -- Reset --
  207.    -----------
  208.  
  209.    procedure Reset (File : in out File_Type; Mode : in FCB.File_Mode) is
  210.    begin
  211.       FIO.Reset (AP (File), Mode);
  212.       File.Index := 1;
  213.       File.Last_Op := Op_Read;
  214.    end Reset;
  215.  
  216.    procedure Reset (File : in out File_Type) is
  217.    begin
  218.       FIO.Reset (AP (File));
  219.       File.Index := 1;
  220.       File.Last_Op := Op_Read;
  221.    end Reset;
  222.  
  223.    ---------------
  224.    -- Set_Index --
  225.    ---------------
  226.  
  227.    procedure Set_Index (File : in File_Type; To : in Positive_Count) is
  228.    begin
  229.       FIO.Check_File_Open (AP (File));
  230.       File.Index := Count (To);
  231.       File.Last_Op := Op_Other;
  232.    end Set_Index;
  233.  
  234.    ------------------
  235.    -- Set_Position --
  236.    ------------------
  237.  
  238.    procedure Set_Position (File : in File_Type) is
  239.    begin
  240.       if fseek
  241.            (File.Stream, long (File.Bytes) *
  242.               long (File.Index - 1), SEEK_SET) /= 0
  243.       then
  244.          raise Use_Error;
  245.       end if;
  246.    end Set_Position;
  247.  
  248.    ----------
  249.    -- Size --
  250.    ----------
  251.  
  252.    function Size (File : in File_Type) return Count is
  253.    begin
  254.       FIO.Check_File_Open (AP (File));
  255.       File.Last_Op := Op_Other;
  256.  
  257.       if fseek (File.Stream, 0, SEEK_END) /= 0 then
  258.          raise Device_Error;
  259.       end if;
  260.  
  261.       return Positive_Count (ftell (File.Stream) / long (File.Bytes));
  262.    end Size;
  263.  
  264.    -----------
  265.    -- Write --
  266.    -----------
  267.  
  268.    procedure Write
  269.      (File : File_Type;
  270.       Item : Address;
  271.       To   : Positive_Count)
  272.    is
  273.    begin
  274.       Set_Index (File, To);
  275.       Write (File, Item);
  276.    end Write;
  277.  
  278.    procedure Write
  279.      (File : File_Type;
  280.       Item : Address)
  281.    is
  282.    begin
  283.       FIO.Check_Write_Status (AP (File));
  284.  
  285.       --  If last operation was not a write, or if in file sharing mode,
  286.       --  then reset the physical pointer of the file to match the index
  287.       --  We lock out task access over the two operations in this case.
  288.  
  289.       if File.Last_Op /= Op_Write
  290.         or else File.Shared_Status = FCB.Yes
  291.       then
  292.          System.Tasking_Soft_Links.Lock_Task;
  293.          Set_Position (File);
  294.          FIO.Write_Buf (AP (File), Item, File.Bytes);
  295.          System.Tasking_Soft_Links.Unlock_Task;
  296.       else
  297.          FIO.Write_Buf (AP (File), Item, File.Bytes);
  298.       end if;
  299.  
  300.       File.Index := File.Index + 1;
  301.       File.Last_Op := Op_Write;
  302.    end Write;
  303.  
  304.    --  The following is the required overriding for Stream.Write, which is
  305.    --  not used, since we do not do Stream operations on Direct_IO files.
  306.  
  307.    procedure Write
  308.      (File : in out Direct_AFCB;
  309.       Item : in Ada.Streams.Stream_Element_Array)
  310.    is
  311.    begin
  312.       raise Program_Error;
  313.    end Write;
  314.  
  315. end System.Direct_IO;
  316.