gnatpsta.adb   [plain text]

------------------------------------------------------------------------------
--                                                                          --
--                          GNAT SYSTEM UTILITIES                           --
--                                                                          --
--                            G N A T P S T A                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--          Copyright (C) 1997-2001 Free Software Foundation, Inc.          --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Program to print out listing of Standard package for the target (not
--  the host) with all constants appearing explicitly. This is not really
--  valid Ada, since one cannot really define new base types, but it is a
--  helpful listing from a documentation point of view.

--  Note that special care has been taken to use the host parameters for
--  integer and floating point sizes.

with Ada.Text_IO; use Ada.Text_IO;
with Ttypef;      use Ttypef;
with Ttypes;      use Ttypes;
with Types;       use Types;

procedure GnatPsta is

   procedure P (Item : String) renames Ada.Text_IO.Put_Line;

   procedure P_Int_Range   (Size : Pos; Put_First : Boolean := True);
   --  Prints the range of an integer based on its Size. If Put_First is
   --  False, then skip the first bound.

   procedure P_Float_Range (Nb_Digits : Pos);
   --  Prints the maximum range of a Float whose 'Digits is given by Nb_Digits

   -------------------
   -- P_Float_Range --
   -------------------

   procedure P_Float_Range (Nb_Digits : Pos) is
   begin
      --  This routine assumes only IEEE floats.
      --  ??? Should the following be adapted for OpenVMS ?

      case Nb_Digits is
         when IEEES_Digits =>
            P ("     range " & IEEES_First'Universal_Literal_String & " .. " &
                               IEEES_Last'Universal_Literal_String & ";");
         when IEEEL_Digits =>
            P ("     range " & IEEEL_First'Universal_Literal_String & " .. " &
                               IEEEL_Last'Universal_Literal_String & ";");
         when IEEEX_Digits =>
            P ("     range " & IEEEX_First'Universal_Literal_String & " .. " &
                               IEEEX_Last'Universal_Literal_String & ";");

         when others =>
            P (";");
      end case;

      --  If one of the floating point types of the host computer has the
      --  same digits as the target float we are processing, then print out
      --  the float range using the host computer float type.

      if Nb_Digits = Short_Float'Digits then
         P ("     --    " &
            Short_Float'First'Img & " .. " & Short_Float'Last'Img);

      elsif Nb_Digits = Float'Digits then
         P ("     --    " &
            Float'First'Img & " .. " & Float'Last'Img);

      elsif Nb_Digits = Long_Float'Digits then
         P ("     --    " &
            Long_Float'First'Img & " .. " & Long_Float'Last'Img);

      elsif Nb_Digits = Long_Long_Float'Digits then
         P ("     --    " &
            Long_Long_Float'First'Img & " .. " & Long_Long_Float'Last'Img);
      end if;

      New_Line;
   end P_Float_Range;

   -----------------
   -- P_Int_Range --
   -----------------

   procedure P_Int_Range (Size : Pos; Put_First : Boolean := True) is
   begin
      if Put_First then
         Put (" is range -(2 **" & Pos'Image (Size - 1) & ")");
      end if;
      P (" .. +(2 **" & Pos'Image (Size - 1) & " - 1);");
   end P_Int_Range;

--  Start of processing for GnatPsta

begin
   P ("package Standard is");
   P ("pragma Pure(Standard);");
   New_Line;

   P ("   type Boolean is (False, True);");
   New_Line;

   --  Integer types

   Put ("   type Integer");
   P_Int_Range (Standard_Integer_Size);
   New_Line;

   Put ("   subtype Natural  is Integer range 0");
   P_Int_Range (Standard_Integer_Size, Put_First => False);

   Put ("   subtype Positive is Integer range 1");
   P_Int_Range (Standard_Integer_Size, Put_First => False);
   New_Line;

   Put ("   type Short_Short_Integer");
   P_Int_Range (Standard_Short_Short_Integer_Size);

   Put ("   type Short_Integer      ");
   P_Int_Range (Standard_Short_Integer_Size);

   Put ("   type Long_Integer       ");
   P_Int_Range (Standard_Long_Integer_Size);

   Put ("   type Long_Long_Integer  ");
   P_Int_Range (Standard_Long_Long_Integer_Size);
   New_Line;

   --  Floating point types

   P ("   type Short_Float     is digits"
      & Standard_Short_Float_Digits'Img);
   P_Float_Range (Standard_Short_Float_Digits);

   P ("   type Float           is digits"
      & Standard_Float_Digits'Img);
   P_Float_Range (Standard_Float_Digits);

   P ("   type Long_Float      is digits"
      & Standard_Long_Float_Digits'Img);
   P_Float_Range (Standard_Long_Float_Digits);

   P ("   type Long_Long_Float is digits"
      & Standard_Long_Long_Float_Digits'Img);
   P_Float_Range (Standard_Long_Long_Float_Digits);

   P ("   --  function ""*"" (Left : root_integer; Right : root_real)");
   P ("   --    return root_real;");
   New_Line;

   P ("   --  function ""*"" (Left : root_real;    Right : root_integer)");
   P ("   --    return root_real;");
   New_Line;

   P ("   --  function ""/"" (Left : root_real;    Right : root_integer)");
   P ("   --    return root_real;");
   New_Line;

   P ("   --  function ""*"" (Left : universal_fixed; " &
                                                "Right : universal_fixed)");
   P ("   --    return universal_fixed;");
   New_Line;

   P ("   --  function ""/"" (Left : universal_fixed; " &
                                                "Right : universal_fixed)");
   P ("   --    return universal_fixed;");
   New_Line;

   P ("   --  The declaration of type Character is based on the standard");
   P ("   --  ISO 8859-1 character set.");
   New_Line;

   P ("   --  There are no character literals corresponding to the positions");
   P ("   --  for control characters. They are indicated by lower case");
   P ("   --  identifiers in the following list.");
   New_Line;

   P ("   --  Note: this type cannot be represented accurately in Ada");
   New_Line;

   P ("   --  type Character is");
   New_Line;

   P ("   --    (nul,  soh,  stx,  etx,     eot,  enq,  ack,  bel,");
   P ("   --     bs,   ht,   lf,   vt,      ff,   cr,   so,   si,");
   New_Line;

   P ("   --     dle,  dc1,  dc2,  dc3,     dc4,  nak,  syn,  etb,");
   P ("   --     can,  em,   sub,  esc,     fs,   gs,   rs,   us,");
   New_Line;

   P ("   --     ' ',  '!',  '""', '#',     '$',  '%',  '&',  ''',");
   P ("   --     '(',  ')',  '*',  '+',     ',',  '-',  '.',  '/',");
   New_Line;

   P ("   --     '0',  '1',  '2',  '3',     '4',  '5',  '6',  '7',");
   P ("   --     '8',  '9',  ':',  ';',     '<',  '=',  '>',  '?',");
   New_Line;

   P ("   --     '@',  'A',  'B',  'C',     'D',  'E',  'F',  'G',");
   P ("   --     'H',  'I',  'J',  'K',     'L',  'M',  'N',  'O',");
   New_Line;

   P ("   --     'P',  'Q',  'R',  'S',     'T',  'U',  'V',  'W',");
   P ("   --     'X',  'Y',  'Z',  '[',     '\',  ']',  '^',  '_',");
   New_Line;

   P ("   --     '`',  'a',  'b',  'c',     'd',  'e',  'f',  'g',");
   P ("   --     'h',  'i',  'j',  'k',     'l',  'm',  'n',  'o',");
   New_Line;

   P ("   --     'p',  'q',  'r',  's',     't',  'u',  'v',  'w',");
   P ("   --     'x',  'y',  'z',  '{',     '|',  '}',  '~',  del,");
   New_Line;

   P ("   --     reserved_128,     reserved_129,  bph,  nbh,");
   P ("   --     reserved_132,     nel,     ssa,  esa,");
   New_Line;

   P ("   --     hts,  htj,  vts,  pld,     plu,  ri,   ss2,  ss3,");
   New_Line;

   P ("   --     dcs,  pu1,  pu2,  sts,     cch,  mw,   spa,  epa,");
   New_Line;

   P ("   --     sos, reserved_153, sci, csi,");
   P ("   --     st,   osc,  pm,   apc,");
   New_Line;

   P ("   --   ... );");
   New_Line;

   P ("   --  The declaration of type Wide_Character is based " &
                                                        "on the standard");
   P ("   --  ISO 10646 BMP character set.");
   New_Line;

   P ("   --  Note: this type cannot be represented accurately in Ada");
   New_Line;

   P ("   --  The first 256 positions have the same contents as " &
                                                        "type Character");
   New_Line;

   P ("   --  type Wide_Character is (nul, soh ... FFFE, FFFF);");
   New_Line;

   P ("   package ASCII is");
   New_Line;

   P ("      --  Control characters:");
   New_Line;

   P ("      NUL   : constant Character := Character'Val (16#00#);");
   P ("      SOH   : constant Character := Character'Val (16#01#);");
   P ("      STX   : constant Character := Character'Val (16#02#);");
   P ("      ETX   : constant Character := Character'Val (16#03#);");
   P ("      EOT   : constant Character := Character'Val (16#04#);");
   P ("      ENQ   : constant Character := Character'Val (16#05#);");
   P ("      ACK   : constant Character := Character'Val (16#06#);");
   P ("      BEL   : constant Character := Character'Val (16#07#);");
   P ("      BS    : constant Character := Character'Val (16#08#);");
   P ("      HT    : constant Character := Character'Val (16#09#);");
   P ("      LF    : constant Character := Character'Val (16#0A#);");
   P ("      VT    : constant Character := Character'Val (16#0B#);");
   P ("      FF    : constant Character := Character'Val (16#0C#);");
   P ("      CR    : constant Character := Character'Val (16#0D#);");
   P ("      SO    : constant Character := Character'Val (16#0E#);");
   P ("      SI    : constant Character := Character'Val (16#0F#);");
   P ("      DLE   : constant Character := Character'Val (16#10#);");
   P ("      DC1   : constant Character := Character'Val (16#11#);");
   P ("      DC2   : constant Character := Character'Val (16#12#);");
   P ("      DC3   : constant Character := Character'Val (16#13#);");
   P ("      DC4   : constant Character := Character'Val (16#14#);");
   P ("      NAK   : constant Character := Character'Val (16#15#);");
   P ("      SYN   : constant Character := Character'Val (16#16#);");
   P ("      ETB   : constant Character := Character'Val (16#17#);");
   P ("      CAN   : constant Character := Character'Val (16#18#);");
   P ("      EM    : constant Character := Character'Val (16#19#);");
   P ("      SUB   : constant Character := Character'Val (16#1A#);");
   P ("      ESC   : constant Character := Character'Val (16#1B#);");
   P ("      FS    : constant Character := Character'Val (16#1C#);");
   P ("      GS    : constant Character := Character'Val (16#1D#);");
   P ("      RS    : constant Character := Character'Val (16#1E#);");
   P ("      US    : constant Character := Character'Val (16#1F#);");
   P ("      DEL   : constant Character := Character'Val (16#7F#);");
   New_Line;

   P ("      -- Other characters:");
   New_Line;

   P ("      Exclam     : constant Character := '!';");
   P ("      Quotation  : constant Character := '""';");
   P ("      Sharp      : constant Character := '#';");
   P ("      Dollar     : constant Character := '$';");
   P ("      Percent    : constant Character := '%';");
   P ("      Ampersand  : constant Character := '&';");
   P ("      Colon      : constant Character := ':';");
   P ("      Semicolon  : constant Character := ';';");
   P ("      Query      : constant Character := '?';");
   P ("      At_Sign    : constant Character := '@';");
   P ("      L_Bracket  : constant Character := '[';");
   P ("      Back_Slash : constant Character := '\';");
   P ("      R_Bracket  : constant Character := ']';");
   P ("      Circumflex : constant Character := '^';");
   P ("      Underline  : constant Character := '_';");
   P ("      Grave      : constant Character := '`';");
   P ("      L_Brace    : constant Character := '{';");
   P ("      Bar        : constant Character := '|';");
   P ("      R_Brace    : constant Character := '}';");
   P ("      Tilde      : constant Character := '~';");
   New_Line;

   P ("      -- Lower case letters:");
   New_Line;

   for C in Character range 'a' .. 'z' loop
      P ("      LC_" & Character'Val (Character'Pos (C) - 32) &
                  " : constant Character := '" & C & "';");
   end loop;
   New_Line;

   P ("   end ASCII;");
   New_Line;

   P ("   type String is array (Positive range <>) of Character;");
   P ("   pragma Pack (String);");
   New_Line;

   P ("   type Wide_String is array (Positive range <>) of Wide_Character;");
   P ("   pragma Pack (Wide_String);");
   New_Line;

   --  Here it's OK to use the Duration type of the host compiler since
   --  the implementation of Duration in GNAT is target independent.

   P ("   type Duration is delta" &
            Duration'Image (Duration'Delta));
   P ("     range -((2 **" & Natural'Image (Duration'Size - 1) &
              " - 1) *" & Duration'Image (Duration'Delta) & ") ..");
   P ("           +((2 **" & Natural'Image (Duration'Size - 1) &
              " - 1) *" & Duration'Image (Duration'Delta) & ");");
   P ("   for Duration'Small use" & Duration'Image (Duration'Small) & ";");
   New_Line;

   P ("   Constraint_Error : exception;");
   P ("   Program_Error    : exception;");
   P ("   Storage_Error    : exception;");
   P ("   Tasking_Error    : exception;");
   New_Line;

   P ("end Standard;");
end GnatPsta;