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 / s-stratt.adb < prev    next >
Text File  |  2000-07-19  |  17KB  |  675 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --             S Y S T E M . S T R E A M _ A T T R I B U T E S              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.7 $                              --
  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. with Ada.IO_Exceptions;
  37. with Ada.Streams; use Ada.Streams;
  38. with Unchecked_Conversion;
  39.  
  40. package body System.Stream_Attributes is
  41.  
  42.    Err : exception renames Ada.IO_Exceptions.End_Error;
  43.    --  Exception raised if insufficient data read (note that the RM implies
  44.    --  that Data_Error might be the appropriate choice, but AI195-00132
  45.    --  decides with a binding interpretation that End_Error is preferred).
  46.  
  47.    SU : constant := System.Storage_Unit;
  48.  
  49.    subtype SEA is Ada.Streams.Stream_Element_Array;
  50.    subtype SEO is Ada.Streams.Stream_Element_Offset;
  51.  
  52.    generic function UC renames Unchecked_Conversion;
  53.  
  54.    --  Subtypes used to define Stream_Element_Array values that map
  55.    --  into the elementary types, using unchecked conversion.
  56.  
  57.    Thin_Pointer_Size : constant := System.Address'Size;
  58.    Fat_Pointer_Size  : constant := System.Address'Size * 2;
  59.  
  60.    subtype S_AD  is SEA (1 .. (Fat_Pointer_Size              + SU - 1) / SU);
  61.    subtype S_AS  is SEA (1 .. (Thin_Pointer_Size             + SU - 1) / SU);
  62.    subtype S_B   is SEA (1 .. (Boolean'Size                  + SU - 1) / SU);
  63.    subtype S_C   is SEA (1 .. (Character'Size                + SU - 1) / SU);
  64.    subtype S_F   is SEA (1 .. (Float'Size                    + SU - 1) / SU);
  65.    subtype S_I   is SEA (1 .. (Integer'Size                  + SU - 1) / SU);
  66.    subtype S_LF  is SEA (1 .. (Long_Float'Size               + SU - 1) / SU);
  67.    subtype S_LI  is SEA (1 .. (Long_Integer'Size             + SU - 1) / SU);
  68.    subtype S_LLF is SEA (1 .. (Long_Long_Float'Size          + SU - 1) / SU);
  69.    subtype S_LLI is SEA (1 .. (Long_Long_Integer'Size        + SU - 1) / SU);
  70.    subtype S_LLU is SEA (1 .. (UST.Long_Long_Unsigned'Size   + SU - 1) / SU);
  71.    subtype S_LU  is SEA (1 .. (UST.Long_Unsigned'Size        + SU - 1) / SU);
  72.    subtype S_SF  is SEA (1 .. (Short_Float'Size              + SU - 1) / SU);
  73.    subtype S_SI  is SEA (1 .. (Short_Integer'Size            + SU - 1) / SU);
  74.    subtype S_SSI is SEA (1 .. (Short_Short_Integer'Size      + SU - 1) / SU);
  75.    subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU);
  76.    subtype S_SU  is SEA (1 .. (UST.Short_Unsigned'Size       + SU - 1) / SU);
  77.    subtype S_U   is SEA (1 .. (UST.Unsigned'Size             + SU - 1) / SU);
  78.    subtype S_WC  is SEA (1 .. (Wide_Character'Size           + SU - 1) / SU);
  79.  
  80.    --  Unchecked conversions from the elementary type to the stream type
  81.  
  82.    function From_AD  is new UC (Fat_Pointer,              S_AD);
  83.    function From_AS  is new UC (Thin_Pointer,             S_AS);
  84.    function From_C   is new UC (Character,                S_C);
  85.    function From_F   is new UC (Float,                    S_F);
  86.    function From_I   is new UC (Integer,                  S_I);
  87.    function From_LF  is new UC (Long_Float,               S_LF);
  88.    function From_LI  is new UC (Long_Integer,             S_LI);
  89.    function From_LLF is new UC (Long_Long_Float,          S_LLF);
  90.    function From_LLI is new UC (Long_Long_Integer,        S_LLI);
  91.    function From_LLU is new UC (UST.Long_Long_Unsigned,   S_LLU);
  92.    function From_LU  is new UC (UST.Long_Unsigned,        S_LU);
  93.    function From_SF  is new UC (Short_Float,              S_SF);
  94.    function From_SI  is new UC (Short_Integer,            S_SI);
  95.    function From_SSI is new UC (Short_Short_Integer,      S_SSI);
  96.    function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU);
  97.    function From_SU  is new UC (UST.Short_Unsigned,       S_SU);
  98.    function From_U   is new UC (UST.Unsigned,             S_U);
  99.    function From_WC  is new UC (Wide_Character,           S_WC);
  100.  
  101.    --  Unchecked conversions from the stream type to elementary type
  102.  
  103.    function To_AD  is new UC (S_AD,  Fat_Pointer);
  104.    function To_AS  is new UC (S_AS,  Thin_Pointer);
  105.    function To_C   is new UC (S_C,   Character);
  106.    function To_F   is new UC (S_F,   Float);
  107.    function To_I   is new UC (S_I,   Integer);
  108.    function To_LF  is new UC (S_LF,  Long_Float);
  109.    function To_LI  is new UC (S_LI,  Long_Integer);
  110.    function To_LLF is new UC (S_LLF, Long_Long_Float);
  111.    function To_LLI is new UC (S_LLI, Long_Long_Integer);
  112.    function To_LLU is new UC (S_LLU, UST.Long_Long_Unsigned);
  113.    function To_LU  is new UC (S_LU,  UST.Long_Unsigned);
  114.    function To_SF  is new UC (S_SF,  Short_Float);
  115.    function To_SI  is new UC (S_SI,  Short_Integer);
  116.    function To_SSI is new UC (S_SSI, Short_Short_Integer);
  117.    function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned);
  118.    function To_SU  is new UC (S_SU,  UST.Short_Unsigned);
  119.    function To_U   is new UC (S_U,   UST.Unsigned);
  120.    function To_WC  is new UC (S_WC,  Wide_Character);
  121.  
  122.    ----------
  123.    -- I_AD --
  124.    ----------
  125.  
  126.    function I_AD (Stream : access RST) return Fat_Pointer is
  127.       T : S_AD;
  128.       L : SEO;
  129.  
  130.    begin
  131.       Ada.Streams.Read (Stream.all, T, L);
  132.  
  133.       if L < T'Last then
  134.          raise Err;
  135.       else
  136.          return To_AD (T);
  137.       end if;
  138.    end I_AD;
  139.  
  140.    ----------
  141.    -- I_AS --
  142.    ----------
  143.  
  144.    function I_AS (Stream : access RST) return Thin_Pointer is
  145.       T : S_AS;
  146.       L : SEO;
  147.  
  148.    begin
  149.       Ada.Streams.Read (Stream.all, T, L);
  150.  
  151.       if L < T'Last then
  152.          raise Err;
  153.       else
  154.          return To_AS (T);
  155.       end if;
  156.    end I_AS;
  157.  
  158.    ---------
  159.    -- I_B --
  160.    ---------
  161.  
  162.    function I_B (Stream : access RST) return Boolean is
  163.       T : S_B;
  164.       L : SEO;
  165.  
  166.    begin
  167.       Ada.Streams.Read (Stream.all, T, L);
  168.  
  169.       if L < T'Last then
  170.          raise Err;
  171.       else
  172.          return Boolean'Val (T (1));
  173.       end if;
  174.    end I_B;
  175.  
  176.    ---------
  177.    -- I_C --
  178.    ---------
  179.  
  180.    function I_C (Stream : access RST) return Character is
  181.       T : S_C;
  182.       L : SEO;
  183.  
  184.    begin
  185.       Ada.Streams.Read (Stream.all, T, L);
  186.  
  187.       if L < T'Last then
  188.          raise Err;
  189.       else
  190.          return To_C (T);
  191.       end if;
  192.    end I_C;
  193.  
  194.    ---------
  195.    -- I_F --
  196.    ---------
  197.  
  198.    function I_F (Stream : access RST) return Float is
  199.       T : S_F;
  200.       L : SEO;
  201.  
  202.    begin
  203.       Ada.Streams.Read (Stream.all, T, L);
  204.  
  205.       if L < T'Last then
  206.          raise Err;
  207.       else
  208.          return To_F (T);
  209.       end if;
  210.    end I_F;
  211.  
  212.    ---------
  213.    -- I_I --
  214.    ---------
  215.  
  216.    function I_I (Stream : access RST) return Integer is
  217.       T : S_I;
  218.       L : SEO;
  219.  
  220.    begin
  221.       Ada.Streams.Read (Stream.all, T, L);
  222.  
  223.       if L < T'Last then
  224.          raise Err;
  225.       else
  226.          return To_I (T);
  227.       end if;
  228.    end I_I;
  229.  
  230.    ----------
  231.    -- I_LF --
  232.    ----------
  233.  
  234.    function I_LF (Stream : access RST) return Long_Float is
  235.       T : S_LF;
  236.       L : SEO;
  237.  
  238.    begin
  239.       Ada.Streams.Read (Stream.all, T, L);
  240.  
  241.       if L < T'Last then
  242.          raise Err;
  243.       else
  244.          return To_LF (T);
  245.       end if;
  246.    end I_LF;
  247.  
  248.    ----------
  249.    -- I_LI --
  250.    ----------
  251.  
  252.    function I_LI (Stream : access RST) return Long_Integer is
  253.       T : S_LI;
  254.       L : SEO;
  255.  
  256.    begin
  257.       Ada.Streams.Read (Stream.all, T, L);
  258.  
  259.       if L < T'Last then
  260.          raise Err;
  261.       else
  262.          return To_LI (T);
  263.       end if;
  264.    end I_LI;
  265.  
  266.    -----------
  267.    -- I_LLF --
  268.    -----------
  269.  
  270.    function I_LLF (Stream : access RST) return Long_Long_Float is
  271.       T : S_LLF;
  272.       L : SEO;
  273.  
  274.    begin
  275.       Ada.Streams.Read (Stream.all, T, L);
  276.  
  277.       if L < T'Last then
  278.          raise Err;
  279.       else
  280.          return To_LLF (T);
  281.       end if;
  282.    end I_LLF;
  283.  
  284.    -----------
  285.    -- I_LLI --
  286.    -----------
  287.  
  288.    function I_LLI (Stream : access RST) return Long_Long_Integer is
  289.       T : S_LLI;
  290.       L : SEO;
  291.  
  292.    begin
  293.       Ada.Streams.Read (Stream.all, T, L);
  294.  
  295.       if L < T'Last then
  296.          raise Err;
  297.       else
  298.          return To_LLI (T);
  299.       end if;
  300.    end I_LLI;
  301.  
  302.    -----------
  303.    -- I_LLU --
  304.    -----------
  305.  
  306.    function I_LLU (Stream : access RST) return UST.Long_Long_Unsigned is
  307.       T : S_LLU;
  308.       L : SEO;
  309.  
  310.    begin
  311.       Ada.Streams.Read (Stream.all, T, L);
  312.  
  313.       if L < T'Last then
  314.          raise Err;
  315.       else
  316.          return To_LLU (T);
  317.       end if;
  318.    end I_LLU;
  319.  
  320.    ----------
  321.    -- I_LU --
  322.    ----------
  323.  
  324.    function I_LU (Stream : access RST) return UST.Long_Unsigned is
  325.       T : S_LU;
  326.       L : SEO;
  327.  
  328.    begin
  329.       Ada.Streams.Read (Stream.all, T, L);
  330.  
  331.       if L < T'Last then
  332.          raise Err;
  333.       else
  334.          return To_LU (T);
  335.       end if;
  336.    end I_LU;
  337.  
  338.    ----------
  339.    -- I_SF --
  340.    ----------
  341.  
  342.    function I_SF (Stream : access RST) return Short_Float is
  343.       T : S_SF;
  344.       L : SEO;
  345.  
  346.    begin
  347.       Ada.Streams.Read (Stream.all, T, L);
  348.  
  349.       if L < T'Last then
  350.          raise Err;
  351.       else
  352.          return To_SF (T);
  353.       end if;
  354.    end I_SF;
  355.  
  356.    ----------
  357.    -- I_SI --
  358.    ----------
  359.  
  360.    function I_SI (Stream : access RST) return Short_Integer is
  361.       T : S_SI;
  362.       L : SEO;
  363.  
  364.    begin
  365.       Ada.Streams.Read (Stream.all, T, L);
  366.  
  367.       if L < T'Last then
  368.          raise Err;
  369.       else
  370.          return To_SI (T);
  371.       end if;
  372.    end I_SI;
  373.  
  374.    -----------
  375.    -- I_SSI --
  376.    -----------
  377.  
  378.    function I_SSI (Stream : access RST) return Short_Short_Integer is
  379.       T : S_SSI;
  380.       L : SEO;
  381.  
  382.    begin
  383.       Ada.Streams.Read (Stream.all, T, L);
  384.  
  385.       if L < T'Last then
  386.          raise Err;
  387.       else
  388.          return To_SSI (T);
  389.       end if;
  390.    end I_SSI;
  391.  
  392.    -----------
  393.    -- I_SSU --
  394.    -----------
  395.  
  396.    function I_SSU (Stream : access RST) return UST.Short_Short_Unsigned is
  397.       T : S_SSU;
  398.       L : SEO;
  399.  
  400.    begin
  401.       Ada.Streams.Read (Stream.all, T, L);
  402.  
  403.       if L < T'Last then
  404.          raise Err;
  405.       else
  406.          return To_SSU (T);
  407.       end if;
  408.    end I_SSU;
  409.  
  410.    ----------
  411.    -- I_SU --
  412.    ----------
  413.  
  414.    function I_SU (Stream : access RST) return UST.Short_Unsigned is
  415.       T : S_SU;
  416.       L : SEO;
  417.  
  418.    begin
  419.       Ada.Streams.Read (Stream.all, T, L);
  420.  
  421.       if L < T'Last then
  422.          raise Err;
  423.       else
  424.          return To_SU (T);
  425.       end if;
  426.    end I_SU;
  427.  
  428.    ---------
  429.    -- I_U --
  430.    ---------
  431.  
  432.    function I_U (Stream : access RST) return UST.Unsigned is
  433.       T : S_U;
  434.       L : SEO;
  435.  
  436.    begin
  437.       Ada.Streams.Read (Stream.all, T, L);
  438.  
  439.       if L < T'Last then
  440.          raise Err;
  441.       else
  442.          return To_U (T);
  443.       end if;
  444.    end I_U;
  445.  
  446.    ----------
  447.    -- I_WC --
  448.    ----------
  449.  
  450.    function I_WC (Stream : access RST) return Wide_Character is
  451.       T : S_WC;
  452.       L : SEO;
  453.  
  454.    begin
  455.       Ada.Streams.Read (Stream.all, T, L);
  456.  
  457.       if L < T'Last then
  458.          raise Err;
  459.       else
  460.          return To_WC (T);
  461.       end if;
  462.    end I_WC;
  463.  
  464.    ----------
  465.    -- W_AD --
  466.    ----------
  467.  
  468.    procedure W_AD (Stream : access RST; Item : in Fat_Pointer) is
  469.       T : constant S_AD := From_AD (Item);
  470.  
  471.    begin
  472.       Ada.Streams.Write (Stream.all, T);
  473.    end W_AD;
  474.  
  475.    ----------
  476.    -- W_AS --
  477.    ----------
  478.  
  479.    procedure W_AS (Stream : access RST; Item : in Thin_Pointer) is
  480.       T : constant S_AS := From_AS (Item);
  481.  
  482.    begin
  483.       Ada.Streams.Write (Stream.all, T);
  484.    end W_AS;
  485.  
  486.    ---------
  487.    -- W_B --
  488.    ---------
  489.  
  490.    procedure W_B (Stream : access RST; Item : in Boolean) is
  491.       T : S_B;
  492.  
  493.    begin
  494.       T (1) := Boolean'Pos (Item);
  495.       Ada.Streams.Write (Stream.all, T);
  496.    end W_B;
  497.  
  498.    ---------
  499.    -- W_C --
  500.    ---------
  501.  
  502.    procedure W_C (Stream : access RST; Item : in Character) is
  503.       T : constant S_C := From_C (Item);
  504.  
  505.    begin
  506.       Ada.Streams.Write (Stream.all, T);
  507.    end W_C;
  508.  
  509.    ---------
  510.    -- W_F --
  511.    ---------
  512.  
  513.    procedure W_F (Stream : access RST; Item : in Float) is
  514.       T : constant S_F := From_F (Item);
  515.  
  516.    begin
  517.       Ada.Streams.Write (Stream.all, T);
  518.    end W_F;
  519.  
  520.    ---------
  521.    -- W_I --
  522.    ---------
  523.  
  524.    procedure W_I (Stream : access RST; Item : in Integer) is
  525.       T : constant S_I := From_I (Item);
  526.  
  527.    begin
  528.       Ada.Streams.Write (Stream.all, T);
  529.    end W_I;
  530.  
  531.    ----------
  532.    -- W_LF --
  533.    ----------
  534.  
  535.    procedure W_LF (Stream : access RST; Item : in Long_Float) is
  536.       T : constant S_LF := From_LF (Item);
  537.  
  538.    begin
  539.       Ada.Streams.Write (Stream.all, T);
  540.    end W_LF;
  541.  
  542.    ----------
  543.    -- W_LI --
  544.    ----------
  545.  
  546.    procedure W_LI (Stream : access RST; Item : in Long_Integer) is
  547.       T : constant S_LI := From_LI (Item);
  548.  
  549.    begin
  550.       Ada.Streams.Write (Stream.all, T);
  551.    end W_LI;
  552.  
  553.    -----------
  554.    -- W_LLF --
  555.    -----------
  556.  
  557.    procedure W_LLF (Stream : access RST; Item : in Long_Long_Float) is
  558.       T : constant S_LLF := From_LLF (Item);
  559.  
  560.    begin
  561.       Ada.Streams.Write (Stream.all, T);
  562.    end W_LLF;
  563.  
  564.    -----------
  565.    -- W_LLI --
  566.    -----------
  567.  
  568.    procedure W_LLI (Stream : access RST; Item : in Long_Long_Integer) is
  569.       T : constant S_LLI := From_LLI (Item);
  570.  
  571.    begin
  572.       Ada.Streams.Write (Stream.all, T);
  573.    end W_LLI;
  574.  
  575.    -----------
  576.    -- W_LLU --
  577.    -----------
  578.  
  579.    procedure W_LLU (Stream : access RST; Item : in UST.Long_Long_Unsigned) is
  580.       T : constant S_LLU := From_LLU (Item);
  581.  
  582.    begin
  583.       Ada.Streams.Write (Stream.all, T);
  584.    end W_LLU;
  585.  
  586.    ----------
  587.    -- W_LU --
  588.    ----------
  589.  
  590.    procedure W_LU (Stream : access RST; Item : in UST.Long_Unsigned) is
  591.       T : constant S_LU := From_LU (Item);
  592.  
  593.    begin
  594.       Ada.Streams.Write (Stream.all, T);
  595.    end W_LU;
  596.  
  597.    ----------
  598.    -- W_SF --
  599.    ----------
  600.  
  601.    procedure W_SF (Stream : access RST; Item : in Short_Float) is
  602.       T : constant S_SF := From_SF (Item);
  603.  
  604.    begin
  605.       Ada.Streams.Write (Stream.all, T);
  606.    end W_SF;
  607.  
  608.    ----------
  609.    -- W_SI --
  610.    ----------
  611.  
  612.    procedure W_SI (Stream : access RST; Item : in Short_Integer) is
  613.       T : constant S_SI := From_SI (Item);
  614.  
  615.    begin
  616.       Ada.Streams.Write (Stream.all, T);
  617.    end W_SI;
  618.  
  619.    -----------
  620.    -- W_SSI --
  621.    -----------
  622.  
  623.    procedure W_SSI (Stream : access RST; Item : in Short_Short_Integer) is
  624.       T : constant S_SSI := From_SSI (Item);
  625.  
  626.    begin
  627.       Ada.Streams.Write (Stream.all, T);
  628.    end W_SSI;
  629.  
  630.    -----------
  631.    -- W_SSU --
  632.    -----------
  633.  
  634.    procedure W_SSU (Stream : access RST; Item : in UST.Short_Short_Unsigned) is
  635.       T : constant S_SSU := From_SSU (Item);
  636.  
  637.    begin
  638.       Ada.Streams.Write (Stream.all, T);
  639.    end W_SSU;
  640.  
  641.    ----------
  642.    -- W_SU --
  643.    ----------
  644.  
  645.    procedure W_SU (Stream : access RST; Item : in UST.Short_Unsigned) is
  646.       T : constant S_SU := From_SU (Item);
  647.  
  648.    begin
  649.       Ada.Streams.Write (Stream.all, T);
  650.    end W_SU;
  651.  
  652.    ---------
  653.    -- W_U --
  654.    ---------
  655.  
  656.    procedure W_U (Stream : access RST; Item : in UST.Unsigned) is
  657.       T : constant S_U := From_U (Item);
  658.  
  659.    begin
  660.       Ada.Streams.Write (Stream.all, T);
  661.    end W_U;
  662.  
  663.    ----------
  664.    -- W_WC --
  665.    ----------
  666.  
  667.    procedure W_WC (Stream : access RST; Item : in Wide_Character) is
  668.       T : constant S_WC := From_WC (Item);
  669.  
  670.    begin
  671.       Ada.Streams.Write (Stream.all, T);
  672.    end W_WC;
  673.  
  674. end System.Stream_Attributes;
  675.