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-2012, 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 32with Ada.Strings; use Ada.Strings; 33with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux; 34 35with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; 36with GNAT.IO; use GNAT.IO; 37 38with System.String_Hash; 39 40with Ada.Unchecked_Deallocation; 41 42package 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 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 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 769end GNAT.Spitbol; 770