|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- G N A T . S P I T B O L --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1998-2019, AdaCore --
|
|
111
|
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 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
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 with Ada.Strings; use Ada.Strings;
|
|
|
33 with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
|
|
|
34
|
|
|
35 with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
|
|
|
36 with GNAT.IO; use GNAT.IO;
|
|
|
37
|
|
|
38 with System.String_Hash;
|
|
|
39
|
|
|
40 with Ada.Unchecked_Deallocation;
|
|
|
41
|
|
|
42 package body GNAT.Spitbol is
|
|
|
43
|
|
|
44 ---------
|
|
|
45 -- "&" --
|
|
|
46 ---------
|
|
|
47
|
|
|
48 function "&" (Num : Integer; Str : String) return String is
|
|
|
49 begin
|
|
|
50 return S (Num) & Str;
|
|
|
51 end "&";
|
|
|
52
|
|
|
53 function "&" (Str : String; Num : Integer) return String is
|
|
|
54 begin
|
|
|
55 return Str & S (Num);
|
|
|
56 end "&";
|
|
|
57
|
|
|
58 function "&" (Num : Integer; Str : VString) return VString is
|
|
|
59 begin
|
|
|
60 return S (Num) & Str;
|
|
|
61 end "&";
|
|
|
62
|
|
|
63 function "&" (Str : VString; Num : Integer) return VString is
|
|
|
64 begin
|
|
|
65 return Str & S (Num);
|
|
|
66 end "&";
|
|
|
67
|
|
|
68 ----------
|
|
|
69 -- Char --
|
|
|
70 ----------
|
|
|
71
|
|
|
72 function Char (Num : Natural) return Character is
|
|
|
73 begin
|
|
|
74 return Character'Val (Num);
|
|
|
75 end Char;
|
|
|
76
|
|
|
77 ----------
|
|
|
78 -- Lpad --
|
|
|
79 ----------
|
|
|
80
|
|
|
81 function Lpad
|
|
|
82 (Str : VString;
|
|
|
83 Len : Natural;
|
|
|
84 Pad : Character := ' ') return VString
|
|
|
85 is
|
|
|
86 begin
|
|
|
87 if Length (Str) >= Len then
|
|
|
88 return Str;
|
|
|
89 else
|
|
|
90 return Tail (Str, Len, Pad);
|
|
|
91 end if;
|
|
|
92 end Lpad;
|
|
|
93
|
|
|
94 function Lpad
|
|
|
95 (Str : String;
|
|
|
96 Len : Natural;
|
|
|
97 Pad : Character := ' ') return VString
|
|
|
98 is
|
|
|
99 begin
|
|
|
100 if Str'Length >= Len then
|
|
|
101 return V (Str);
|
|
|
102
|
|
|
103 else
|
|
|
104 declare
|
|
|
105 R : String (1 .. Len);
|
|
|
106
|
|
|
107 begin
|
|
|
108 for J in 1 .. Len - Str'Length loop
|
|
|
109 R (J) := Pad;
|
|
|
110 end loop;
|
|
|
111
|
|
|
112 R (Len - Str'Length + 1 .. Len) := Str;
|
|
|
113 return V (R);
|
|
|
114 end;
|
|
|
115 end if;
|
|
|
116 end Lpad;
|
|
|
117
|
|
|
118 procedure Lpad
|
|
|
119 (Str : in out VString;
|
|
|
120 Len : Natural;
|
|
|
121 Pad : Character := ' ')
|
|
|
122 is
|
|
|
123 begin
|
|
|
124 if Length (Str) >= Len then
|
|
|
125 return;
|
|
|
126 else
|
|
|
127 Tail (Str, Len, Pad);
|
|
|
128 end if;
|
|
|
129 end Lpad;
|
|
|
130
|
|
|
131 -------
|
|
|
132 -- N --
|
|
|
133 -------
|
|
|
134
|
|
|
135 function N (Str : VString) return Integer is
|
|
|
136 S : Big_String_Access;
|
|
|
137 L : Natural;
|
|
|
138 begin
|
|
|
139 Get_String (Str, S, L);
|
|
|
140 return Integer'Value (S (1 .. L));
|
|
|
141 end N;
|
|
|
142
|
|
|
143 --------------------
|
|
|
144 -- Reverse_String --
|
|
|
145 --------------------
|
|
|
146
|
|
|
147 function Reverse_String (Str : VString) return VString is
|
|
|
148 S : Big_String_Access;
|
|
|
149 L : Natural;
|
|
|
150
|
|
|
151 begin
|
|
|
152 Get_String (Str, S, L);
|
|
|
153
|
|
|
154 declare
|
|
|
155 Result : String (1 .. L);
|
|
|
156
|
|
|
157 begin
|
|
|
158 for J in 1 .. L loop
|
|
|
159 Result (J) := S (L + 1 - J);
|
|
|
160 end loop;
|
|
|
161
|
|
|
162 return V (Result);
|
|
|
163 end;
|
|
|
164 end Reverse_String;
|
|
|
165
|
|
|
166 function Reverse_String (Str : String) return VString is
|
|
|
167 Result : String (1 .. Str'Length);
|
|
|
168
|
|
|
169 begin
|
|
|
170 for J in 1 .. Str'Length loop
|
|
|
171 Result (J) := Str (Str'Last + 1 - J);
|
|
|
172 end loop;
|
|
|
173
|
|
|
174 return V (Result);
|
|
|
175 end Reverse_String;
|
|
|
176
|
|
|
177 procedure Reverse_String (Str : in out VString) is
|
|
|
178 S : Big_String_Access;
|
|
|
179 L : Natural;
|
|
|
180
|
|
|
181 begin
|
|
|
182 Get_String (Str, S, L);
|
|
|
183
|
|
|
184 declare
|
|
|
185 Result : String (1 .. L);
|
|
|
186
|
|
|
187 begin
|
|
|
188 for J in 1 .. L loop
|
|
|
189 Result (J) := S (L + 1 - J);
|
|
|
190 end loop;
|
|
|
191
|
|
|
192 Set_Unbounded_String (Str, Result);
|
|
|
193 end;
|
|
|
194 end Reverse_String;
|
|
|
195
|
|
|
196 ----------
|
|
|
197 -- Rpad --
|
|
|
198 ----------
|
|
|
199
|
|
|
200 function Rpad
|
|
|
201 (Str : VString;
|
|
|
202 Len : Natural;
|
|
|
203 Pad : Character := ' ') return VString
|
|
|
204 is
|
|
|
205 begin
|
|
|
206 if Length (Str) >= Len then
|
|
|
207 return Str;
|
|
|
208 else
|
|
|
209 return Head (Str, Len, Pad);
|
|
|
210 end if;
|
|
|
211 end Rpad;
|
|
|
212
|
|
|
213 function Rpad
|
|
|
214 (Str : String;
|
|
|
215 Len : Natural;
|
|
|
216 Pad : Character := ' ') return VString
|
|
|
217 is
|
|
|
218 begin
|
|
|
219 if Str'Length >= Len then
|
|
|
220 return V (Str);
|
|
|
221
|
|
|
222 else
|
|
|
223 declare
|
|
|
224 R : String (1 .. Len);
|
|
|
225
|
|
|
226 begin
|
|
|
227 for J in Str'Length + 1 .. Len loop
|
|
|
228 R (J) := Pad;
|
|
|
229 end loop;
|
|
|
230
|
|
|
231 R (1 .. Str'Length) := Str;
|
|
|
232 return V (R);
|
|
|
233 end;
|
|
|
234 end if;
|
|
|
235 end Rpad;
|
|
|
236
|
|
|
237 procedure Rpad
|
|
|
238 (Str : in out VString;
|
|
|
239 Len : Natural;
|
|
|
240 Pad : Character := ' ')
|
|
|
241 is
|
|
|
242 begin
|
|
|
243 if Length (Str) >= Len then
|
|
|
244 return;
|
|
|
245
|
|
|
246 else
|
|
|
247 Head (Str, Len, Pad);
|
|
|
248 end if;
|
|
|
249 end Rpad;
|
|
|
250
|
|
|
251 -------
|
|
|
252 -- S --
|
|
|
253 -------
|
|
|
254
|
|
|
255 function S (Num : Integer) return String is
|
|
|
256 Buf : String (1 .. 30);
|
|
|
257 Ptr : Natural := Buf'Last + 1;
|
|
|
258 Val : Natural := abs (Num);
|
|
|
259
|
|
|
260 begin
|
|
|
261 loop
|
|
|
262 Ptr := Ptr - 1;
|
|
|
263 Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
|
|
|
264 Val := Val / 10;
|
|
|
265 exit when Val = 0;
|
|
|
266 end loop;
|
|
|
267
|
|
|
268 if Num < 0 then
|
|
|
269 Ptr := Ptr - 1;
|
|
|
270 Buf (Ptr) := '-';
|
|
|
271 end if;
|
|
|
272
|
|
|
273 return Buf (Ptr .. Buf'Last);
|
|
|
274 end S;
|
|
|
275
|
|
|
276 ------------
|
|
|
277 -- Substr --
|
|
|
278 ------------
|
|
|
279
|
|
|
280 function Substr
|
|
|
281 (Str : VString;
|
|
|
282 Start : Positive;
|
|
|
283 Len : Natural) return VString
|
|
|
284 is
|
|
|
285 S : Big_String_Access;
|
|
|
286 L : Natural;
|
|
|
287
|
|
|
288 begin
|
|
|
289 Get_String (Str, S, L);
|
|
|
290
|
|
|
291 if Start > L then
|
|
|
292 raise Index_Error;
|
|
|
293 elsif Start + Len - 1 > L then
|
|
|
294 raise Length_Error;
|
|
|
295 else
|
|
|
296 return V (S (Start .. Start + Len - 1));
|
|
|
297 end if;
|
|
|
298 end Substr;
|
|
|
299
|
|
|
300 function Substr
|
|
|
301 (Str : String;
|
|
|
302 Start : Positive;
|
|
|
303 Len : Natural) return VString
|
|
|
304 is
|
|
|
305 begin
|
|
|
306 if Start > Str'Length then
|
|
|
307 raise Index_Error;
|
|
|
308 elsif Start + Len - 1 > Str'Length then
|
|
|
309 raise Length_Error;
|
|
|
310 else
|
|
|
311 return
|
|
|
312 V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2));
|
|
|
313 end if;
|
|
|
314 end Substr;
|
|
|
315
|
|
|
316 -----------
|
|
|
317 -- Table --
|
|
|
318 -----------
|
|
|
319
|
|
|
320 package body Table is
|
|
|
321
|
|
|
322 procedure Free is new
|
|
|
323 Ada.Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);
|
|
|
324
|
|
|
325 -----------------------
|
|
|
326 -- Local Subprograms --
|
|
|
327 -----------------------
|
|
|
328
|
|
|
329 function Hash is new System.String_Hash.Hash
|
|
|
330 (Character, String, Unsigned_32);
|
|
|
331
|
|
|
332 ------------
|
|
|
333 -- Adjust --
|
|
|
334 ------------
|
|
|
335
|
|
|
336 overriding procedure Adjust (Object : in out Table) is
|
|
|
337 Ptr1 : Hash_Element_Ptr;
|
|
|
338 Ptr2 : Hash_Element_Ptr;
|
|
|
339
|
|
|
340 begin
|
|
|
341 for J in Object.Elmts'Range loop
|
|
|
342 Ptr1 := Object.Elmts (J)'Unrestricted_Access;
|
|
|
343
|
|
|
344 if Ptr1.Name /= null then
|
|
|
345 loop
|
|
|
346 Ptr1.Name := new String'(Ptr1.Name.all);
|
|
|
347 exit when Ptr1.Next = null;
|
|
|
348 Ptr2 := Ptr1.Next;
|
|
|
349 Ptr1.Next := new Hash_Element'(Ptr2.all);
|
|
|
350 Ptr1 := Ptr1.Next;
|
|
|
351 end loop;
|
|
|
352 end if;
|
|
|
353 end loop;
|
|
|
354 end Adjust;
|
|
|
355
|
|
|
356 -----------
|
|
|
357 -- Clear --
|
|
|
358 -----------
|
|
|
359
|
|
|
360 procedure Clear (T : in out Table) is
|
|
|
361 Ptr1 : Hash_Element_Ptr;
|
|
|
362 Ptr2 : Hash_Element_Ptr;
|
|
|
363
|
|
|
364 begin
|
|
|
365 for J in T.Elmts'Range loop
|
|
|
366 if T.Elmts (J).Name /= null then
|
|
|
367 Free (T.Elmts (J).Name);
|
|
|
368 T.Elmts (J).Value := Null_Value;
|
|
|
369
|
|
|
370 Ptr1 := T.Elmts (J).Next;
|
|
|
371 T.Elmts (J).Next := null;
|
|
|
372
|
|
|
373 while Ptr1 /= null loop
|
|
|
374 Ptr2 := Ptr1.Next;
|
|
|
375 Free (Ptr1.Name);
|
|
|
376 Free (Ptr1);
|
|
|
377 Ptr1 := Ptr2;
|
|
|
378 end loop;
|
|
|
379 end if;
|
|
|
380 end loop;
|
|
|
381 end Clear;
|
|
|
382
|
|
|
383 ----------------------
|
|
|
384 -- Convert_To_Array --
|
|
|
385 ----------------------
|
|
|
386
|
|
|
387 function Convert_To_Array (T : Table) return Table_Array is
|
|
|
388 Num_Elmts : Natural := 0;
|
|
|
389 Elmt : Hash_Element_Ptr;
|
|
|
390
|
|
|
391 begin
|
|
|
392 for J in T.Elmts'Range loop
|
|
|
393 Elmt := T.Elmts (J)'Unrestricted_Access;
|
|
|
394
|
|
|
395 if Elmt.Name /= null then
|
|
|
396 loop
|
|
|
397 Num_Elmts := Num_Elmts + 1;
|
|
|
398 Elmt := Elmt.Next;
|
|
|
399 exit when Elmt = null;
|
|
|
400 end loop;
|
|
|
401 end if;
|
|
|
402 end loop;
|
|
|
403
|
|
|
404 declare
|
|
|
405 TA : Table_Array (1 .. Num_Elmts);
|
|
|
406 P : Natural := 1;
|
|
|
407
|
|
|
408 begin
|
|
|
409 for J in T.Elmts'Range loop
|
|
|
410 Elmt := T.Elmts (J)'Unrestricted_Access;
|
|
|
411
|
|
|
412 if Elmt.Name /= null then
|
|
|
413 loop
|
|
|
414 Set_Unbounded_String (TA (P).Name, Elmt.Name.all);
|
|
|
415 TA (P).Value := Elmt.Value;
|
|
|
416 P := P + 1;
|
|
|
417 Elmt := Elmt.Next;
|
|
|
418 exit when Elmt = null;
|
|
|
419 end loop;
|
|
|
420 end if;
|
|
|
421 end loop;
|
|
|
422
|
|
|
423 return TA;
|
|
|
424 end;
|
|
|
425 end Convert_To_Array;
|
|
|
426
|
|
|
427 ----------
|
|
|
428 -- Copy --
|
|
|
429 ----------
|
|
|
430
|
|
|
431 procedure Copy (From : Table; To : in out Table) is
|
|
|
432 Elmt : Hash_Element_Ptr;
|
|
|
433
|
|
|
434 begin
|
|
|
435 Clear (To);
|
|
|
436
|
|
|
437 for J in From.Elmts'Range loop
|
|
|
438 Elmt := From.Elmts (J)'Unrestricted_Access;
|
|
|
439 if Elmt.Name /= null then
|
|
|
440 loop
|
|
|
441 Set (To, Elmt.Name.all, Elmt.Value);
|
|
|
442 Elmt := Elmt.Next;
|
|
|
443 exit when Elmt = null;
|
|
|
444 end loop;
|
|
|
445 end if;
|
|
|
446 end loop;
|
|
|
447 end Copy;
|
|
|
448
|
|
|
449 ------------
|
|
|
450 -- Delete --
|
|
|
451 ------------
|
|
|
452
|
|
|
453 procedure Delete (T : in out Table; Name : Character) is
|
|
|
454 begin
|
|
|
455 Delete (T, String'(1 => Name));
|
|
|
456 end Delete;
|
|
|
457
|
|
|
458 procedure Delete (T : in out Table; Name : VString) is
|
|
|
459 S : Big_String_Access;
|
|
|
460 L : Natural;
|
|
|
461 begin
|
|
|
462 Get_String (Name, S, L);
|
|
|
463 Delete (T, S (1 .. L));
|
|
|
464 end Delete;
|
|
|
465
|
|
|
466 procedure Delete (T : in out Table; Name : String) is
|
|
|
467 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
|
|
|
468 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
|
|
|
469 Next : Hash_Element_Ptr;
|
|
|
470
|
|
|
471 begin
|
|
|
472 if Elmt.Name = null then
|
|
|
473 null;
|
|
|
474
|
|
|
475 elsif Elmt.Name.all = Name then
|
|
|
476 Free (Elmt.Name);
|
|
|
477
|
|
|
478 if Elmt.Next = null then
|
|
|
479 Elmt.Value := Null_Value;
|
|
|
480 return;
|
|
|
481
|
|
|
482 else
|
|
|
483 Next := Elmt.Next;
|
|
|
484 Elmt.Name := Next.Name;
|
|
|
485 Elmt.Value := Next.Value;
|
|
|
486 Elmt.Next := Next.Next;
|
|
|
487 Free (Next);
|
|
|
488 return;
|
|
|
489 end if;
|
|
|
490
|
|
|
491 else
|
|
|
492 loop
|
|
|
493 Next := Elmt.Next;
|
|
|
494
|
|
|
495 if Next = null then
|
|
|
496 return;
|
|
|
497
|
|
|
498 elsif Next.Name.all = Name then
|
|
|
499 Free (Next.Name);
|
|
|
500 Elmt.Next := Next.Next;
|
|
|
501 Free (Next);
|
|
|
502 return;
|
|
|
503
|
|
|
504 else
|
|
|
505 Elmt := Next;
|
|
|
506 end if;
|
|
|
507 end loop;
|
|
|
508 end if;
|
|
|
509 end Delete;
|
|
|
510
|
|
|
511 ----------
|
|
|
512 -- Dump --
|
|
|
513 ----------
|
|
|
514
|
|
|
515 procedure Dump (T : Table; Str : String := "Table") is
|
|
|
516 Num_Elmts : Natural := 0;
|
|
|
517 Elmt : Hash_Element_Ptr;
|
|
|
518
|
|
|
519 begin
|
|
|
520 for J in T.Elmts'Range loop
|
|
|
521 Elmt := T.Elmts (J)'Unrestricted_Access;
|
|
|
522
|
|
|
523 if Elmt.Name /= null then
|
|
|
524 loop
|
|
|
525 Num_Elmts := Num_Elmts + 1;
|
|
|
526 Put_Line
|
|
|
527 (Str & '<' & Image (Elmt.Name.all) & "> = " &
|
|
|
528 Img (Elmt.Value));
|
|
|
529 Elmt := Elmt.Next;
|
|
|
530 exit when Elmt = null;
|
|
|
531 end loop;
|
|
|
532 end if;
|
|
|
533 end loop;
|
|
|
534
|
|
|
535 if Num_Elmts = 0 then
|
|
|
536 Put_Line (Str & " is empty");
|
|
|
537 end if;
|
|
|
538 end Dump;
|
|
|
539
|
|
|
540 procedure Dump (T : Table_Array; Str : String := "Table_Array") is
|
|
|
541 begin
|
|
|
542 if T'Length = 0 then
|
|
|
543 Put_Line (Str & " is empty");
|
|
|
544
|
|
|
545 else
|
|
|
546 for J in T'Range loop
|
|
|
547 Put_Line
|
|
|
548 (Str & '(' & Image (To_String (T (J).Name)) & ") = " &
|
|
|
549 Img (T (J).Value));
|
|
|
550 end loop;
|
|
|
551 end if;
|
|
|
552 end Dump;
|
|
|
553
|
|
|
554 --------------
|
|
|
555 -- Finalize --
|
|
|
556 --------------
|
|
|
557
|
|
|
558 overriding procedure Finalize (Object : in out Table) is
|
|
|
559 Ptr1 : Hash_Element_Ptr;
|
|
|
560 Ptr2 : Hash_Element_Ptr;
|
|
|
561
|
|
|
562 begin
|
|
|
563 for J in Object.Elmts'Range loop
|
|
|
564 Ptr1 := Object.Elmts (J).Next;
|
|
|
565 Free (Object.Elmts (J).Name);
|
|
|
566 while Ptr1 /= null loop
|
|
|
567 Ptr2 := Ptr1.Next;
|
|
|
568 Free (Ptr1.Name);
|
|
|
569 Free (Ptr1);
|
|
|
570 Ptr1 := Ptr2;
|
|
|
571 end loop;
|
|
|
572 end loop;
|
|
|
573 end Finalize;
|
|
|
574
|
|
|
575 ---------
|
|
|
576 -- Get --
|
|
|
577 ---------
|
|
|
578
|
|
|
579 function Get (T : Table; Name : Character) return Value_Type is
|
|
|
580 begin
|
|
|
581 return Get (T, String'(1 => Name));
|
|
|
582 end Get;
|
|
|
583
|
|
|
584 function Get (T : Table; Name : VString) return Value_Type is
|
|
|
585 S : Big_String_Access;
|
|
|
586 L : Natural;
|
|
|
587 begin
|
|
|
588 Get_String (Name, S, L);
|
|
|
589 return Get (T, S (1 .. L));
|
|
|
590 end Get;
|
|
|
591
|
|
|
592 function Get (T : Table; Name : String) return Value_Type is
|
|
|
593 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
|
|
|
594 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
|
|
|
595
|
|
|
596 begin
|
|
|
597 if Elmt.Name = null then
|
|
|
598 return Null_Value;
|
|
|
599
|
|
|
600 else
|
|
|
601 loop
|
|
|
602 if Name = Elmt.Name.all then
|
|
|
603 return Elmt.Value;
|
|
|
604
|
|
|
605 else
|
|
|
606 Elmt := Elmt.Next;
|
|
|
607
|
|
|
608 if Elmt = null then
|
|
|
609 return Null_Value;
|
|
|
610 end if;
|
|
|
611 end if;
|
|
|
612 end loop;
|
|
|
613 end if;
|
|
|
614 end Get;
|
|
|
615
|
|
|
616 -------------
|
|
|
617 -- Present --
|
|
|
618 -------------
|
|
|
619
|
|
|
620 function Present (T : Table; Name : Character) return Boolean is
|
|
|
621 begin
|
|
|
622 return Present (T, String'(1 => Name));
|
|
|
623 end Present;
|
|
|
624
|
|
|
625 function Present (T : Table; Name : VString) return Boolean is
|
|
|
626 S : Big_String_Access;
|
|
|
627 L : Natural;
|
|
|
628 begin
|
|
|
629 Get_String (Name, S, L);
|
|
|
630 return Present (T, S (1 .. L));
|
|
|
631 end Present;
|
|
|
632
|
|
|
633 function Present (T : Table; Name : String) return Boolean is
|
|
|
634 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
|
|
|
635 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
|
|
|
636
|
|
|
637 begin
|
|
|
638 if Elmt.Name = null then
|
|
|
639 return False;
|
|
|
640
|
|
|
641 else
|
|
|
642 loop
|
|
|
643 if Name = Elmt.Name.all then
|
|
|
644 return True;
|
|
|
645
|
|
|
646 else
|
|
|
647 Elmt := Elmt.Next;
|
|
|
648
|
|
|
649 if Elmt = null then
|
|
|
650 return False;
|
|
|
651 end if;
|
|
|
652 end if;
|
|
|
653 end loop;
|
|
|
654 end if;
|
|
|
655 end Present;
|
|
|
656
|
|
|
657 ---------
|
|
|
658 -- Set --
|
|
|
659 ---------
|
|
|
660
|
|
|
661 procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
|
|
|
662 S : Big_String_Access;
|
|
|
663 L : Natural;
|
|
|
664 begin
|
|
|
665 Get_String (Name, S, L);
|
|
|
666 Set (T, S (1 .. L), Value);
|
|
|
667 end Set;
|
|
|
668
|
|
|
669 procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
|
|
|
670 begin
|
|
|
671 Set (T, String'(1 => Name), Value);
|
|
|
672 end Set;
|
|
|
673
|
|
|
674 procedure Set
|
|
|
675 (T : in out Table;
|
|
|
676 Name : String;
|
|
|
677 Value : Value_Type)
|
|
|
678 is
|
|
|
679 begin
|
|
|
680 if Value = Null_Value then
|
|
|
681 Delete (T, Name);
|
|
|
682
|
|
|
683 else
|
|
|
684 declare
|
|
|
685 Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
|
|
|
686 Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
|
|
|
687
|
|
|
688 subtype String1 is String (1 .. Name'Length);
|
|
|
689
|
|
|
690 begin
|
|
|
691 if Elmt.Name = null then
|
|
|
692 Elmt.Name := new String'(String1 (Name));
|
|
|
693 Elmt.Value := Value;
|
|
|
694 return;
|
|
|
695
|
|
|
696 else
|
|
|
697 loop
|
|
|
698 if Name = Elmt.Name.all then
|
|
|
699 Elmt.Value := Value;
|
|
|
700 return;
|
|
|
701
|
|
|
702 elsif Elmt.Next = null then
|
|
|
703 Elmt.Next := new Hash_Element'(
|
|
|
704 Name => new String'(String1 (Name)),
|
|
|
705 Value => Value,
|
|
|
706 Next => null);
|
|
|
707 return;
|
|
|
708
|
|
|
709 else
|
|
|
710 Elmt := Elmt.Next;
|
|
|
711 end if;
|
|
|
712 end loop;
|
|
|
713 end if;
|
|
|
714 end;
|
|
|
715 end if;
|
|
|
716 end Set;
|
|
|
717 end Table;
|
|
|
718
|
|
|
719 ----------
|
|
|
720 -- Trim --
|
|
|
721 ----------
|
|
|
722
|
|
|
723 function Trim (Str : VString) return VString is
|
|
|
724 begin
|
|
|
725 return Trim (Str, Right);
|
|
|
726 end Trim;
|
|
|
727
|
|
|
728 function Trim (Str : String) return VString is
|
|
|
729 begin
|
|
|
730 for J in reverse Str'Range loop
|
|
|
731 if Str (J) /= ' ' then
|
|
|
732 return V (Str (Str'First .. J));
|
|
|
733 end if;
|
|
|
734 end loop;
|
|
|
735
|
|
|
736 return Nul;
|
|
|
737 end Trim;
|
|
|
738
|
|
|
739 procedure Trim (Str : in out VString) is
|
|
|
740 begin
|
|
|
741 Trim (Str, Right);
|
|
|
742 end Trim;
|
|
|
743
|
|
|
744 -------
|
|
|
745 -- V --
|
|
|
746 -------
|
|
|
747
|
|
|
748 function V (Num : Integer) return VString is
|
|
|
749 Buf : String (1 .. 30);
|
|
|
750 Ptr : Natural := Buf'Last + 1;
|
|
|
751 Val : Natural := abs (Num);
|
|
|
752
|
|
|
753 begin
|
|
|
754 loop
|
|
|
755 Ptr := Ptr - 1;
|
|
|
756 Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
|
|
|
757 Val := Val / 10;
|
|
|
758 exit when Val = 0;
|
|
|
759 end loop;
|
|
|
760
|
|
|
761 if Num < 0 then
|
|
|
762 Ptr := Ptr - 1;
|
|
|
763 Buf (Ptr) := '-';
|
|
|
764 end if;
|
|
|
765
|
|
|
766 return V (Buf (Ptr .. Buf'Last));
|
|
|
767 end V;
|
|
|
768
|
|
|
769 end GNAT.Spitbol;
|
