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-direio.adb < prev    next >
Text File  |  2000-07-19  |  8KB  |  274 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                        A D A . D I R E C T _ I O                         --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.22 $                             --
  10. --                                                                          --
  11. --          Copyright (C) 1992-1998 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. --  This is the generic template for Direct_IO, i.e. the code that gets
  37. --  duplicated. We absolutely minimize this code by either calling routines
  38. --  in System.File_IO (for common file functions), or in System.Direct_IO
  39. --  (for specialized Direct_IO functions)
  40.  
  41. with Interfaces.C_Streams; use Interfaces.C_Streams;
  42. with System;               use System;
  43. with System.File_Control_Block;
  44. with System.File_IO;
  45. with System.Direct_IO;
  46. with System.Storage_Elements;
  47. with Unchecked_Conversion;
  48.  
  49. use type System.Direct_IO.Count;
  50.  
  51. package body Ada.Direct_IO is
  52.  
  53.    Zeroes : System.Storage_Elements.Storage_Array :=
  54.               (1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0);
  55.    --  Buffer used to fill out partial records.
  56.  
  57.    package FCB renames System.File_Control_Block;
  58.    package FIO renames System.File_IO;
  59.    package DIO renames System.Direct_IO;
  60.  
  61.    SU : constant := System.Storage_Unit;
  62.  
  63.    subtype AP      is FCB.AFCB_Ptr;
  64.    subtype FP      is DIO.File_Type;
  65.    subtype DCount  is DIO.Count;
  66.    subtype DPCount is DIO.Positive_Count;
  67.  
  68.    function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
  69.    function To_DIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
  70.  
  71.    -----------
  72.    -- Close --
  73.    -----------
  74.  
  75.    procedure Close (File : in out File_Type) is
  76.    begin
  77.       FIO.Close (AP (File));
  78.    end Close;
  79.  
  80.    ------------
  81.    -- Create --
  82.    ------------
  83.  
  84.    procedure Create
  85.      (File : in out File_Type;
  86.       Mode : in File_Mode := Inout_File;
  87.       Name : in String := "";
  88.       Form : in String := "")
  89.    is
  90.    begin
  91.       DIO.Create (FP (File), To_FCB (Mode), Name, Form);
  92.       File.Bytes := Bytes;
  93.    end Create;
  94.  
  95.    ------------
  96.    -- Delete --
  97.    ------------
  98.  
  99.    procedure Delete (File : in out File_Type) is
  100.    begin
  101.       FIO.Delete (AP (File));
  102.    end Delete;
  103.  
  104.    -----------------
  105.    -- End_Of_File --
  106.    -----------------
  107.  
  108.    function End_Of_File (File : in File_Type) return Boolean is
  109.    begin
  110.       return DIO.End_Of_File (FP (File));
  111.    end End_Of_File;
  112.  
  113.    ----------
  114.    -- Form --
  115.    ----------
  116.  
  117.    function Form (File : in File_Type) return String is
  118.    begin
  119.       return FIO.Form (AP (File));
  120.    end Form;
  121.  
  122.    -----------
  123.    -- Index --
  124.    -----------
  125.  
  126.    function Index (File : in File_Type) return Positive_Count is
  127.    begin
  128.       return Positive_Count (DIO.Index (FP (File)));
  129.    end Index;
  130.  
  131.    -------------
  132.    -- Is_Open --
  133.    -------------
  134.  
  135.    function Is_Open (File : in File_Type) return Boolean is
  136.    begin
  137.       return FIO.Is_Open (AP (File));
  138.    end Is_Open;
  139.  
  140.    ----------
  141.    -- Mode --
  142.    ----------
  143.  
  144.    function Mode (File : in File_Type) return File_Mode is
  145.    begin
  146.       return To_DIO (FIO.Mode (AP (File)));
  147.    end Mode;
  148.  
  149.    ----------
  150.    -- Name --
  151.    ----------
  152.  
  153.    function Name (File : in File_Type) return String is
  154.    begin
  155.       return FIO.Name (AP (File));
  156.    end Name;
  157.  
  158.    ----------
  159.    -- Open --
  160.    ----------
  161.  
  162.    procedure Open
  163.      (File : in out File_Type;
  164.       Mode : in File_Mode;
  165.       Name : in String;
  166.       Form : in String := "")
  167.    is
  168.    begin
  169.       DIO.Open (FP (File), To_FCB (Mode), Name, Form);
  170.       File.Bytes := Bytes;
  171.    end Open;
  172.  
  173.    ----------
  174.    -- Read --
  175.    ----------
  176.  
  177.    procedure Read
  178.      (File : in File_Type;
  179.       Item : out Element_Type;
  180.       From : in Positive_Count)
  181.    is
  182.    begin
  183.       --  For a non-constrained variant record type, we read into an
  184.       --  intermediate buffer, since we may have the case of discriminated
  185.       --  records where a discriminant check is required, and we may need
  186.       --  to assign only part of the record buffer originally written
  187.  
  188.       if not Element_Type'Constrained then
  189.          declare
  190.             Buf : Element_Type;
  191.  
  192.          begin
  193.             DIO.Read (FP (File), Buf'Address, Bytes, DPCount (From));
  194.             Item := Buf;
  195.          end;
  196.  
  197.       --  In the normal case, we can read straight into the buffer
  198.  
  199.       else
  200.          DIO.Read (FP (File), Item'Address, Bytes, DPCount (From));
  201.       end if;
  202.    end Read;
  203.  
  204.    procedure Read (File : in File_Type; Item : out Element_Type) is
  205.    begin
  206.       --  Same processing for unconstrained case as above
  207.  
  208.       if not Element_Type'Constrained then
  209.          declare
  210.             Buf : Element_Type;
  211.  
  212.          begin
  213.             DIO.Read (FP (File), Buf'Address, Bytes);
  214.             Item := Buf;
  215.          end;
  216.  
  217.       else
  218.          DIO.Read (FP (File), Item'Address, Bytes);
  219.       end if;
  220.    end Read;
  221.  
  222.    -----------
  223.    -- Reset --
  224.    -----------
  225.  
  226.    procedure Reset (File : in out File_Type; Mode : in File_Mode) is
  227.    begin
  228.       DIO.Reset (FP (File), To_FCB (Mode));
  229.    end Reset;
  230.  
  231.    procedure Reset (File : in out File_Type) is
  232.    begin
  233.       DIO.Reset (FP (File));
  234.    end Reset;
  235.  
  236.    ---------------
  237.    -- Set_Index --
  238.    ---------------
  239.  
  240.    procedure Set_Index (File : in File_Type; To : in Positive_Count) is
  241.    begin
  242.       DIO.Set_Index (FP (File), DPCount (To));
  243.    end Set_Index;
  244.  
  245.    ----------
  246.    -- Size --
  247.    ----------
  248.  
  249.    function Size (File : in File_Type) return Count is
  250.    begin
  251.       return Count (DIO.Size (FP (File)));
  252.    end Size;
  253.  
  254.    -----------
  255.    -- Write --
  256.    -----------
  257.  
  258.    procedure Write
  259.      (File : in File_Type;
  260.       Item : in Element_Type;
  261.       To   : in Positive_Count)
  262.    is
  263.    begin
  264.       DIO.Set_Index (FP (File), DPCount (To));
  265.       DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes);
  266.    end Write;
  267.  
  268.    procedure Write (File : in File_Type; Item : in Element_Type) is
  269.    begin
  270.       DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes);
  271.    end Write;
  272.  
  273. end Ada.Direct_IO;
  274.