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