Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/g-spitbo.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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 -- --
9 -- Copyright (C) 1998-2017, AdaCore --
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;