File : types.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- T Y P E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2014, 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 3, 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 package body Types is
33
34 -----------------------
35 -- Local Subprograms --
36 -----------------------
37
38 function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat;
39 -- Extract two decimal digit value from time stamp
40
41 ---------
42 -- "<" --
43 ---------
44
45 function "<" (Left, Right : Time_Stamp_Type) return Boolean is
46 begin
47 return not (Left = Right) and then String (Left) < String (Right);
48 end "<";
49
50 ----------
51 -- "<=" --
52 ----------
53
54 function "<=" (Left, Right : Time_Stamp_Type) return Boolean is
55 begin
56 return not (Left > Right);
57 end "<=";
58
59 ---------
60 -- "=" --
61 ---------
62
63 function "=" (Left, Right : Time_Stamp_Type) return Boolean is
64 Sleft : Nat;
65 Sright : Nat;
66
67 begin
68 if String (Left) = String (Right) then
69 return True;
70
71 elsif Left (1) = ' ' or else Right (1) = ' ' then
72 return False;
73 end if;
74
75 -- In the following code we check for a difference of 2 seconds or less
76
77 -- Recall that the time stamp format is:
78
79 -- Y Y Y Y M M D D H H M M S S
80 -- 01 02 03 04 05 06 07 08 09 10 11 12 13 14
81
82 -- Note that we do not bother to worry about shifts in the day.
83 -- It seems unlikely that such shifts could ever occur in practice
84 -- and even if they do we err on the safe side, i.e., we say that the
85 -- time stamps are different.
86
87 Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09));
88 Sleft := V (Left, 13) + 60 * (V (Left, 11) + 60 * V (Left, 09));
89
90 -- So the check is: dates must be the same, times differ 2 sec at most
91
92 return abs (Sleft - Sright) <= 2
93 and then String (Left (1 .. 8)) = String (Right (1 .. 8));
94 end "=";
95
96 ---------
97 -- ">" --
98 ---------
99
100 function ">" (Left, Right : Time_Stamp_Type) return Boolean is
101 begin
102 return not (Left = Right) and then String (Left) > String (Right);
103 end ">";
104
105 ----------
106 -- ">=" --
107 ----------
108
109 function ">=" (Left, Right : Time_Stamp_Type) return Boolean is
110 begin
111 return not (Left < Right);
112 end ">=";
113
114 -------------------
115 -- Get_Char_Code --
116 -------------------
117
118 function Get_Char_Code (C : Character) return Char_Code is
119 begin
120 return Char_Code'Val (Character'Pos (C));
121 end Get_Char_Code;
122
123 -------------------
124 -- Get_Character --
125 -------------------
126
127 function Get_Character (C : Char_Code) return Character is
128 begin
129 pragma Assert (C <= 255);
130 return Character'Val (C);
131 end Get_Character;
132
133 --------------------
134 -- Get_Hex_String --
135 --------------------
136
137 subtype Wordh is Word range 0 .. 15;
138 Hex : constant array (Wordh) of Character := "0123456789abcdef";
139
140 function Get_Hex_String (W : Word) return Word_Hex_String is
141 X : Word := W;
142 WS : Word_Hex_String;
143
144 begin
145 for J in reverse 1 .. 8 loop
146 WS (J) := Hex (X mod 16);
147 X := X / 16;
148 end loop;
149
150 return WS;
151 end Get_Hex_String;
152
153 ------------------------
154 -- Get_Wide_Character --
155 ------------------------
156
157 function Get_Wide_Character (C : Char_Code) return Wide_Character is
158 begin
159 pragma Assert (C <= 65535);
160 return Wide_Character'Val (C);
161 end Get_Wide_Character;
162
163 ------------------------
164 -- In_Character_Range --
165 ------------------------
166
167 function In_Character_Range (C : Char_Code) return Boolean is
168 begin
169 return (C <= 255);
170 end In_Character_Range;
171
172 -----------------------------
173 -- In_Wide_Character_Range --
174 -----------------------------
175
176 function In_Wide_Character_Range (C : Char_Code) return Boolean is
177 begin
178 return (C <= 65535);
179 end In_Wide_Character_Range;
180
181 ---------------------
182 -- Make_Time_Stamp --
183 ---------------------
184
185 procedure Make_Time_Stamp
186 (Year : Nat;
187 Month : Nat;
188 Day : Nat;
189 Hour : Nat;
190 Minutes : Nat;
191 Seconds : Nat;
192 TS : out Time_Stamp_Type)
193 is
194 Z : constant := Character'Pos ('0');
195
196 begin
197 TS (01) := Character'Val (Z + Year / 1000);
198 TS (02) := Character'Val (Z + (Year / 100) mod 10);
199 TS (03) := Character'Val (Z + (Year / 10) mod 10);
200 TS (04) := Character'Val (Z + Year mod 10);
201 TS (05) := Character'Val (Z + Month / 10);
202 TS (06) := Character'Val (Z + Month mod 10);
203 TS (07) := Character'Val (Z + Day / 10);
204 TS (08) := Character'Val (Z + Day mod 10);
205 TS (09) := Character'Val (Z + Hour / 10);
206 TS (10) := Character'Val (Z + Hour mod 10);
207 TS (11) := Character'Val (Z + Minutes / 10);
208 TS (12) := Character'Val (Z + Minutes mod 10);
209 TS (13) := Character'Val (Z + Seconds / 10);
210 TS (14) := Character'Val (Z + Seconds mod 10);
211 end Make_Time_Stamp;
212
213 ----------------------
214 -- Split_Time_Stamp --
215 ----------------------
216
217 procedure Split_Time_Stamp
218 (TS : Time_Stamp_Type;
219 Year : out Nat;
220 Month : out Nat;
221 Day : out Nat;
222 Hour : out Nat;
223 Minutes : out Nat;
224 Seconds : out Nat)
225 is
226
227 begin
228 -- Y Y Y Y M M D D H H M M S S
229 -- 01 02 03 04 05 06 07 08 09 10 11 12 13 14
230
231 Year := 100 * V (TS, 01) + V (TS, 03);
232 Month := V (TS, 05);
233 Day := V (TS, 07);
234 Hour := V (TS, 09);
235 Minutes := V (TS, 11);
236 Seconds := V (TS, 13);
237 end Split_Time_Stamp;
238
239 -------
240 -- V --
241 -------
242
243 function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat is
244 begin
245 return 10 * (Character'Pos (T (X)) - Character'Pos ('0')) +
246 Character'Pos (T (X + 1)) - Character'Pos ('0');
247 end V;
248
249 end Types;