gcc/ada/gnatpsta.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT SYSTEM UTILITIES                           --
   4 --                                                                          --
   5 --                            G N A T P S T A                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.10 $
  10 --                                                                          --
  11 --          Copyright (C) 1997-2001 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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 --  Program to print out listing of Standard package for the target (not
  30 --  the host) with all constants appearing explicitly. This is not really
  31 --  valid Ada, since one cannot really define new base types, but it is a
  32 --  helpful listing from a documentation point of view.
  33
  34 --  Note that special care has been taken to use the host parameters for
  35 --  integer and floating point sizes.
  36
  37 with Ada.Text_IO; use Ada.Text_IO;
  38 with Gnatvsn;
  39 with Ttypef;      use Ttypef;
  40 with Ttypes;      use Ttypes;
  41 with Types;       use Types;
  42
  43 procedure GnatPsta is
  44    pragma Ident (Gnatvsn.Gnat_Version_String);
  45
  46    procedure P (Item : String) renames Ada.Text_IO.Put_Line;
  47
  48    procedure P_Int_Range   (Size : Pos; Put_First : Boolean := True);
  49    --  Prints the range of an integer based on its Size. If Put_First is
  50    --  False, then skip the first bound.
  51
  52    procedure P_Float_Range (Nb_Digits : Pos);
  53    --  Prints the maximum range of a Float whose 'Digits is given by Nb_Digits
  54
  55    -------------------
  56    -- P_Float_Range --
  57    -------------------
  58
  59    procedure P_Float_Range (Nb_Digits : Pos) is
  60    begin
  61       --  This routine assumes only IEEE floats.
  62       --  ??? Should the following be adapted for OpenVMS ?
  63
  64       case Nb_Digits is
  65          when IEEES_Digits =>
  66             P ("     range " & IEEES_First'Universal_Literal_String & " .. " &
  67                                IEEES_Last'Universal_Literal_String & ";");
  68          when IEEEL_Digits =>
  69             P ("     range " & IEEEL_First'Universal_Literal_String & " .. " &
  70                                IEEEL_Last'Universal_Literal_String & ";");
  71          when IEEEX_Digits =>
  72             P ("     range " & IEEEX_First'Universal_Literal_String & " .. " &
  73                                IEEEX_Last'Universal_Literal_String & ";");
  74
  75          when others =>
  76             P (";");
  77       end case;
  78
  79       --  If one of the floating point types of the host computer has the
  80       --  same digits as the target float we are processing, then print out
  81       --  the float range using the host computer float type.
  82
  83       if Nb_Digits = Short_Float'Digits then
  84          P ("     --    " &
  85             Short_Float'First'Img & " .. " & Short_Float'Last'Img);
  86
  87       elsif Nb_Digits = Float'Digits then
  88          P ("     --    " &
  89             Float'First'Img & " .. " & Float'Last'Img);
  90
  91       elsif Nb_Digits = Long_Float'Digits then
  92          P ("     --    " &
  93             Long_Float'First'Img & " .. " & Long_Float'Last'Img);
  94
  95       elsif Nb_Digits = Long_Long_Float'Digits then
  96          P ("     --    " &
  97             Long_Long_Float'First'Img & " .. " & Long_Long_Float'Last'Img);
  98       end if;
  99
 100       New_Line;
 101    end P_Float_Range;
 102
 103    -----------------
 104    -- P_Int_Range --
 105    -----------------
 106
 107    procedure P_Int_Range (Size : Pos; Put_First : Boolean := True) is
 108    begin
 109       if Put_First then
 110          Put (" is range -(2 **" & Pos'Image (Size - 1) & ")");
 111       end if;
 112       P (" .. +(2 **" & Pos'Image (Size - 1) & " - 1);");
 113    end P_Int_Range;
 114
 115 --  Start of processing for GnatPsta
 116
 117 begin
 118    P ("package Standard is");
 119    P ("pragma Pure(Standard);");
 120    New_Line;
 121
 122    P ("   type Boolean is (False, True);");
 123    New_Line;
 124
 125    --  Integer types
 126
 127    Put ("   type Integer");
 128    P_Int_Range (Standard_Integer_Size);
 129    New_Line;
 130
 131    Put ("   subtype Natural  is Integer range 0");
 132    P_Int_Range (Standard_Integer_Size, Put_First => False);
 133
 134    Put ("   subtype Positive is Integer range 1");
 135    P_Int_Range (Standard_Integer_Size, Put_First => False);
 136    New_Line;
 137
 138    Put ("   type Short_Short_Integer");
 139    P_Int_Range (Standard_Short_Short_Integer_Size);
 140
 141    Put ("   type Short_Integer      ");
 142    P_Int_Range (Standard_Short_Integer_Size);
 143
 144    Put ("   type Long_Integer       ");
 145    P_Int_Range (Standard_Long_Integer_Size);
 146
 147    Put ("   type Long_Long_Integer  ");
 148    P_Int_Range (Standard_Long_Long_Integer_Size);
 149    New_Line;
 150
 151    --  Floating point types
 152
 153    P ("   type Short_Float     is digits"
 154       & Standard_Short_Float_Digits'Img);
 155    P_Float_Range (Standard_Short_Float_Digits);
 156
 157    P ("   type Float           is digits"
 158       & Standard_Float_Digits'Img);
 159    P_Float_Range (Standard_Float_Digits);
 160
 161    P ("   type Long_Float      is digits"
 162       & Standard_Long_Float_Digits'Img);
 163    P_Float_Range (Standard_Long_Float_Digits);
 164
 165    P ("   type Long_Long_Float is digits"
 166       & Standard_Long_Long_Float_Digits'Img);
 167    P_Float_Range (Standard_Long_Long_Float_Digits);
 168
 169    P ("   --  function ""*"" (Left : root_integer; Right : root_real)");
 170    P ("   --    return root_real;");
 171    New_Line;
 172
 173    P ("   --  function ""*"" (Left : root_real;    Right : root_integer)");
 174    P ("   --    return root_real;");
 175    New_Line;
 176
 177    P ("   --  function ""/"" (Left : root_real;    Right : root_integer)");
 178    P ("   --    return root_real;");
 179    New_Line;
 180
 181    P ("   --  function ""*"" (Left : universal_fixed; " &
 182                                                 "Right : universal_fixed)");
 183    P ("   --    return universal_fixed;");
 184    New_Line;
 185
 186    P ("   --  function ""/"" (Left : universal_fixed; " &
 187                                                 "Right : universal_fixed)");
 188    P ("   --    return universal_fixed;");
 189    New_Line;
 190
 191    P ("   --  The declaration of type Character is based on the standard");
 192    P ("   --  ISO 8859-1 character set.");
 193    New_Line;
 194
 195    P ("   --  There are no character literals corresponding to the positions");
 196    P ("   --  for control characters. They are indicated by lower case");
 197    P ("   --  identifiers in the following list.");
 198    New_Line;
 199
 200    P ("   --  Note: this type cannot be represented accurately in Ada");
 201    New_Line;
 202
 203    P ("   --  type Character is");
 204    New_Line;
 205
 206    P ("   --    (nul,  soh,  stx,  etx,     eot,  enq,  ack,  bel,");
 207    P ("   --     bs,   ht,   lf,   vt,      ff,   cr,   so,   si,");
 208    New_Line;
 209
 210    P ("   --     dle,  dc1,  dc2,  dc3,     dc4,  nak,  syn,  etb,");
 211    P ("   --     can,  em,   sub,  esc,     fs,   gs,   rs,   us,");
 212    New_Line;
 213
 214    P ("   --     ' ',  '!',  '""', '#',     '$',  '%',  '&',  ''',");
 215    P ("   --     '(',  ')',  '*',  '+',     ',',  '-',  '.',  '/',");
 216    New_Line;
 217
 218    P ("   --     '0',  '1',  '2',  '3',     '4',  '5',  '6',  '7',");
 219    P ("   --     '8',  '9',  ':',  ';',     '<',  '=',  '>',  '?',");
 220    New_Line;
 221
 222    P ("   --     '@',  'A',  'B',  'C',     'D',  'E',  'F',  'G',");
 223    P ("   --     'H',  'I',  'J',  'K',     'L',  'M',  'N',  'O',");
 224    New_Line;
 225
 226    P ("   --     'P',  'Q',  'R',  'S',     'T',  'U',  'V',  'W',");
 227    P ("   --     'X',  'Y',  'Z',  '[',     '\',  ']',  '^',  '_',");
 228    New_Line;
 229
 230    P ("   --     '`',  'a',  'b',  'c',     'd',  'e',  'f',  'g',");
 231    P ("   --     'h',  'i',  'j',  'k',     'l',  'm',  'n',  'o',");
 232    New_Line;
 233
 234    P ("   --     'p',  'q',  'r',  's',     't',  'u',  'v',  'w',");
 235    P ("   --     'x',  'y',  'z',  '{',     '|',  '}',  '~',  del,");
 236    New_Line;
 237
 238    P ("   --     reserved_128,     reserved_129,  bph,  nbh,");
 239    P ("   --     reserved_132,     nel,     ssa,  esa,");
 240    New_Line;
 241
 242    P ("   --     hts,  htj,  vts,  pld,     plu,  ri,   ss2,  ss3,");
 243    New_Line;
 244
 245    P ("   --     dcs,  pu1,  pu2,  sts,     cch,  mw,   spa,  epa,");
 246    New_Line;
 247
 248    P ("   --     sos, reserved_153, sci, csi,");
 249    P ("   --     st,   osc,  pm,   apc,");
 250    New_Line;
 251
 252    P ("   --   ... );");
 253    New_Line;
 254
 255    P ("   --  The declaration of type Wide_Character is based " &
 256                                                         "on the standard");
 257    P ("   --  ISO 10646 BMP character set.");
 258    New_Line;
 259
 260    P ("   --  Note: this type cannot be represented accurately in Ada");
 261    New_Line;
 262
 263    P ("   --  The first 256 positions have the same contents as " &
 264                                                         "type Character");
 265    New_Line;
 266
 267    P ("   --  type Wide_Character is (nul, soh ... FFFE, FFFF);");
 268    New_Line;
 269
 270    P ("   package ASCII is");
 271    New_Line;
 272
 273    P ("      --  Control characters:");
 274    New_Line;
 275
 276    P ("      NUL   : constant Character := Character'Val (16#00#);");
 277    P ("      SOH   : constant Character := Character'Val (16#01#);");
 278    P ("      STX   : constant Character := Character'Val (16#02#);");
 279    P ("      ETX   : constant Character := Character'Val (16#03#);");
 280    P ("      EOT   : constant Character := Character'Val (16#04#);");
 281    P ("      ENQ   : constant Character := Character'Val (16#05#);");
 282    P ("      ACK   : constant Character := Character'Val (16#06#);");
 283    P ("      BEL   : constant Character := Character'Val (16#07#);");
 284    P ("      BS    : constant Character := Character'Val (16#08#);");
 285    P ("      HT    : constant Character := Character'Val (16#09#);");
 286    P ("      LF    : constant Character := Character'Val (16#0A#);");
 287    P ("      VT    : constant Character := Character'Val (16#0B#);");
 288    P ("      FF    : constant Character := Character'Val (16#0C#);");
 289    P ("      CR    : constant Character := Character'Val (16#0D#);");
 290    P ("      SO    : constant Character := Character'Val (16#0E#);");
 291    P ("      SI    : constant Character := Character'Val (16#0F#);");
 292    P ("      DLE   : constant Character := Character'Val (16#10#);");
 293    P ("      DC1   : constant Character := Character'Val (16#11#);");
 294    P ("      DC2   : constant Character := Character'Val (16#12#);");
 295    P ("      DC3   : constant Character := Character'Val (16#13#);");
 296    P ("      DC4   : constant Character := Character'Val (16#14#);");
 297    P ("      NAK   : constant Character := Character'Val (16#15#);");
 298    P ("      SYN   : constant Character := Character'Val (16#16#);");
 299    P ("      ETB   : constant Character := Character'Val (16#17#);");
 300    P ("      CAN   : constant Character := Character'Val (16#18#);");
 301    P ("      EM    : constant Character := Character'Val (16#19#);");
 302    P ("      SUB   : constant Character := Character'Val (16#1A#);");
 303    P ("      ESC   : constant Character := Character'Val (16#1B#);");
 304    P ("      FS    : constant Character := Character'Val (16#1C#);");
 305    P ("      GS    : constant Character := Character'Val (16#1D#);");
 306    P ("      RS    : constant Character := Character'Val (16#1E#);");
 307    P ("      US    : constant Character := Character'Val (16#1F#);");
 308    P ("      DEL   : constant Character := Character'Val (16#7F#);");
 309    New_Line;
 310
 311    P ("      -- Other characters:");
 312    New_Line;
 313
 314    P ("      Exclam     : constant Character := '!';");
 315    P ("      Quotation  : constant Character := '""';");
 316    P ("      Sharp      : constant Character := '#';");
 317    P ("      Dollar     : constant Character := '$';");
 318    P ("      Percent    : constant Character := '%';");
 319    P ("      Ampersand  : constant Character := '&';");
 320    P ("      Colon      : constant Character := ':';");
 321    P ("      Semicolon  : constant Character := ';';");
 322    P ("      Query      : constant Character := '?';");
 323    P ("      At_Sign    : constant Character := '@';");
 324    P ("      L_Bracket  : constant Character := '[';");
 325    P ("      Back_Slash : constant Character := '\';");
 326    P ("      R_Bracket  : constant Character := ']';");
 327    P ("      Circumflex : constant Character := '^';");
 328    P ("      Underline  : constant Character := '_';");
 329    P ("      Grave      : constant Character := '`';");
 330    P ("      L_Brace    : constant Character := '{';");
 331    P ("      Bar        : constant Character := '|';");
 332    P ("      R_Brace    : constant Character := '}';");
 333    P ("      Tilde      : constant Character := '~';");
 334    New_Line;
 335
 336    P ("      -- Lower case letters:");
 337    New_Line;
 338
 339    for C in Character range 'a' .. 'z' loop
 340       P ("      LC_" & Character'Val (Character'Pos (C) - 32) &
 341                   " : constant Character := '" & C & "';");
 342    end loop;
 343    New_Line;
 344
 345    P ("   end ASCII;");
 346    New_Line;
 347
 348    P ("   type String is array (Positive range <>) of Character;");
 349    P ("   pragma Pack (String);");
 350    New_Line;
 351
 352    P ("   type Wide_String is array (Positive range <>) of Wide_Character;");
 353    P ("   pragma Pack (Wide_String);");
 354    New_Line;
 355
 356    --  Here it's OK to use the Duration type of the host compiler since
 357    --  the implementation of Duration in GNAT is target independent.
 358
 359    P ("   type Duration is delta" &
 360             Duration'Image (Duration'Delta));
 361    P ("     range -((2 **" & Natural'Image (Duration'Size - 1) &
 362               " - 1) *" & Duration'Image (Duration'Delta) & ") ..");
 363    P ("           +((2 **" & Natural'Image (Duration'Size - 1) &
 364               " - 1) *" & Duration'Image (Duration'Delta) & ");");
 365    P ("   for Duration'Small use" & Duration'Image (Duration'Small) & ";");
 366    New_Line;
 367
 368    P ("   Constraint_Error : exception;");
 369    P ("   Program_Error    : exception;");
 370    P ("   Storage_Error    : exception;");
 371    P ("   Tasking_Error    : exception;");
 372    New_Line;
 373
 374    P ("end Standard;");
 375 end GnatPsta;