gcc/ada/libgnat/a-stwise.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --              A D A . S T R I N G S . W I D E _ S E A R C H               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, 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 -- 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.Wide_Maps; use Ada.Strings.Wide_Maps;
  33 with System;                use System;
  34
  35 package body Ada.Strings.Wide_Search is
  36
  37    -----------------------
  38    -- Local Subprograms --
  39    -----------------------
  40
  41    function Belongs
  42      (Element : Wide_Character;
  43       Set     : Wide_Maps.Wide_Character_Set;
  44       Test    : Membership) return Boolean;
  45    pragma Inline (Belongs);
  46    --  Determines if the given element is in (Test = Inside) or not in
  47    --  (Test = Outside) the given character set.
  48
  49    -------------
  50    -- Belongs --
  51    -------------
  52
  53    function Belongs
  54      (Element : Wide_Character;
  55       Set     : Wide_Maps.Wide_Character_Set;
  56       Test    : Membership) return Boolean
  57    is
  58    begin
  59       if Test = Inside then
  60          return Is_In (Element, Set);
  61       else
  62          return not Is_In (Element, Set);
  63       end if;
  64    end Belongs;
  65
  66    -----------
  67    -- Count --
  68    -----------
  69
  70    function Count
  71      (Source  : Wide_String;
  72       Pattern : Wide_String;
  73       Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
  74       return Natural
  75    is
  76       PL1 : constant Integer := Pattern'Length - 1;
  77       Num : Natural;
  78       Ind : Natural;
  79       Cur : Natural;
  80
  81    begin
  82       if Pattern = "" then
  83          raise Pattern_Error;
  84       end if;
  85
  86       Num := 0;
  87       Ind := Source'First;
  88
  89       --  Unmapped case
  90
  91       if Mapping'Address = Wide_Maps.Identity'Address then
  92          while Ind <= Source'Last - PL1 loop
  93             if Pattern = Source (Ind .. Ind + PL1) then
  94                Num := Num + 1;
  95                Ind := Ind + Pattern'Length;
  96             else
  97                Ind := Ind + 1;
  98             end if;
  99          end loop;
 100
 101       --  Mapped case
 102
 103       else
 104          while Ind <= Source'Last - PL1 loop
 105             Cur := Ind;
 106             for K in Pattern'Range loop
 107                if Pattern (K) /= Value (Mapping, Source (Cur)) then
 108                   Ind := Ind + 1;
 109                   goto Cont;
 110                else
 111                   Cur := Cur + 1;
 112                end if;
 113             end loop;
 114
 115             Num := Num + 1;
 116             Ind := Ind + Pattern'Length;
 117
 118          <<Cont>>
 119             null;
 120          end loop;
 121       end if;
 122
 123       --  Return result
 124
 125       return Num;
 126    end Count;
 127
 128    function Count
 129      (Source  : Wide_String;
 130       Pattern : Wide_String;
 131       Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
 132    is
 133       PL1 : constant Integer := Pattern'Length - 1;
 134       Num : Natural;
 135       Ind : Natural;
 136       Cur : Natural;
 137
 138    begin
 139       if Pattern = "" then
 140          raise Pattern_Error;
 141       end if;
 142
 143       --  Check for null pointer in case checks are off
 144
 145       if Mapping = null then
 146          raise Constraint_Error;
 147       end if;
 148
 149       Num := 0;
 150       Ind := Source'First;
 151       while Ind <= Source'Last - PL1 loop
 152          Cur := Ind;
 153          for K in Pattern'Range loop
 154             if Pattern (K) /= Mapping (Source (Cur)) then
 155                Ind := Ind + 1;
 156                goto Cont;
 157             else
 158                Cur := Cur + 1;
 159             end if;
 160          end loop;
 161
 162          Num := Num + 1;
 163          Ind := Ind + Pattern'Length;
 164
 165       <<Cont>>
 166          null;
 167       end loop;
 168
 169       return Num;
 170    end Count;
 171
 172    function Count
 173      (Source : Wide_String;
 174       Set    : Wide_Maps.Wide_Character_Set) return Natural
 175    is
 176       N : Natural := 0;
 177
 178    begin
 179       for J in Source'Range loop
 180          if Is_In (Source (J), Set) then
 181             N := N + 1;
 182          end if;
 183       end loop;
 184
 185       return N;
 186    end Count;
 187
 188    ----------------
 189    -- Find_Token --
 190    ----------------
 191
 192    procedure Find_Token
 193      (Source : Wide_String;
 194       Set    : Wide_Maps.Wide_Character_Set;
 195       From   : Positive;
 196       Test   : Membership;
 197       First  : out Positive;
 198       Last   : out Natural)
 199    is
 200    begin
 201       for J in From .. Source'Last loop
 202          if Belongs (Source (J), Set, Test) then
 203             First := J;
 204
 205             for K in J + 1 .. Source'Last loop
 206                if not Belongs (Source (K), Set, Test) then
 207                   Last := K - 1;
 208                   return;
 209                end if;
 210             end loop;
 211
 212             --  Here if J indexes first char of token, and all chars after J
 213             --  are in the token.
 214
 215             Last := Source'Last;
 216             return;
 217          end if;
 218       end loop;
 219
 220       --  Here if no token found
 221
 222       First := From;
 223       Last  := 0;
 224    end Find_Token;
 225
 226    procedure Find_Token
 227      (Source : Wide_String;
 228       Set    : Wide_Maps.Wide_Character_Set;
 229       Test   : Membership;
 230       First  : out Positive;
 231       Last   : out Natural)
 232    is
 233    begin
 234       for J in Source'Range loop
 235          if Belongs (Source (J), Set, Test) then
 236             First := J;
 237
 238             for K in J + 1 .. Source'Last loop
 239                if not Belongs (Source (K), Set, Test) then
 240                   Last := K - 1;
 241                   return;
 242                end if;
 243             end loop;
 244
 245             --  Here if J indexes first char of token, and all chars after J
 246             --  are in the token.
 247
 248             Last := Source'Last;
 249             return;
 250          end if;
 251       end loop;
 252
 253       --  Here if no token found
 254
 255       --  RM 2005 A.4.3 (68/1) specifies that an exception must be raised if
 256       --  Source'First is not positive and is assigned to First. Formulation
 257       --  is slightly different in RM 2012, but the intent seems similar, so
 258       --  we check explicitly for that condition.
 259
 260       if Source'First not in Positive then
 261          raise Constraint_Error;
 262
 263       else
 264          First := Source'First;
 265          Last  := 0;
 266       end if;
 267    end Find_Token;
 268
 269    -----------
 270    -- Index --
 271    -----------
 272
 273    function Index
 274      (Source  : Wide_String;
 275       Pattern : Wide_String;
 276       Going   : Direction := Forward;
 277       Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
 278       return Natural
 279    is
 280       PL1 : constant Integer := Pattern'Length - 1;
 281       Cur : Natural;
 282
 283       Ind : Integer;
 284       --  Index for start of match check. This can be negative if the pattern
 285       --  length is greater than the string length, which is why this variable
 286       --  is Integer instead of Natural. In this case, the search loops do not
 287       --  execute at all, so this Ind value is never used.
 288
 289    begin
 290       if Pattern = "" then
 291          raise Pattern_Error;
 292       end if;
 293
 294       --  Forwards case
 295
 296       if Going = Forward then
 297          Ind := Source'First;
 298
 299          --  Unmapped forward case
 300
 301          if Mapping'Address = Wide_Maps.Identity'Address then
 302             for J in 1 .. Source'Length - PL1 loop
 303                if Pattern = Source (Ind .. Ind + PL1) then
 304                   return Ind;
 305                else
 306                   Ind := Ind + 1;
 307                end if;
 308             end loop;
 309
 310          --  Mapped forward case
 311
 312          else
 313             for J in 1 .. Source'Length - PL1 loop
 314                Cur := Ind;
 315
 316                for K in Pattern'Range loop
 317                   if Pattern (K) /= Value (Mapping, Source (Cur)) then
 318                      goto Cont1;
 319                   else
 320                      Cur := Cur + 1;
 321                   end if;
 322                end loop;
 323
 324                return Ind;
 325
 326             <<Cont1>>
 327                Ind := Ind + 1;
 328             end loop;
 329          end if;
 330
 331       --  Backwards case
 332
 333       else
 334          --  Unmapped backward case
 335
 336          Ind := Source'Last - PL1;
 337
 338          if Mapping'Address = Wide_Maps.Identity'Address then
 339             for J in reverse 1 .. Source'Length - PL1 loop
 340                if Pattern = Source (Ind .. Ind + PL1) then
 341                   return Ind;
 342                else
 343                   Ind := Ind - 1;
 344                end if;
 345             end loop;
 346
 347          --  Mapped backward case
 348
 349          else
 350             for J in reverse 1 .. Source'Length - PL1 loop
 351                Cur := Ind;
 352
 353                for K in Pattern'Range loop
 354                   if Pattern (K) /= Value (Mapping, Source (Cur)) then
 355                      goto Cont2;
 356                   else
 357                      Cur := Cur + 1;
 358                   end if;
 359                end loop;
 360
 361                return Ind;
 362
 363             <<Cont2>>
 364                Ind := Ind - 1;
 365             end loop;
 366          end if;
 367       end if;
 368
 369       --  Fall through if no match found. Note that the loops are skipped
 370       --  completely in the case of the pattern being longer than the source.
 371
 372       return 0;
 373    end Index;
 374
 375    function Index
 376      (Source  : Wide_String;
 377       Pattern : Wide_String;
 378       Going   : Direction := Forward;
 379       Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
 380    is
 381       PL1 : constant Integer := Pattern'Length - 1;
 382       Ind : Natural;
 383       Cur : Natural;
 384
 385    begin
 386       if Pattern = "" then
 387          raise Pattern_Error;
 388       end if;
 389
 390       --  Check for null pointer in case checks are off
 391
 392       if Mapping = null then
 393          raise Constraint_Error;
 394       end if;
 395
 396       --  If Pattern longer than Source it can't be found
 397
 398       if Pattern'Length > Source'Length then
 399          return 0;
 400       end if;
 401
 402       --  Forwards case
 403
 404       if Going = Forward then
 405          Ind := Source'First;
 406          for J in 1 .. Source'Length - PL1 loop
 407             Cur := Ind;
 408
 409             for K in Pattern'Range loop
 410                if Pattern (K) /= Mapping.all (Source (Cur)) then
 411                   goto Cont1;
 412                else
 413                   Cur := Cur + 1;
 414                end if;
 415             end loop;
 416
 417             return Ind;
 418
 419          <<Cont1>>
 420             Ind := Ind + 1;
 421          end loop;
 422
 423       --  Backwards case
 424
 425       else
 426          Ind := Source'Last - PL1;
 427          for J in reverse 1 .. Source'Length - PL1 loop
 428             Cur := Ind;
 429
 430             for K in Pattern'Range loop
 431                if Pattern (K) /= Mapping.all (Source (Cur)) then
 432                   goto Cont2;
 433                else
 434                   Cur := Cur + 1;
 435                end if;
 436             end loop;
 437
 438             return Ind;
 439
 440          <<Cont2>>
 441             Ind := Ind - 1;
 442          end loop;
 443       end if;
 444
 445       --  Fall through if no match found. Note that the loops are skipped
 446       --  completely in the case of the pattern being longer than the source.
 447
 448       return 0;
 449    end Index;
 450
 451    function Index
 452      (Source : Wide_String;
 453       Set    : Wide_Maps.Wide_Character_Set;
 454       Test   : Membership := Inside;
 455       Going  : Direction  := Forward) return Natural
 456    is
 457    begin
 458       --  Forwards case
 459
 460       if Going = Forward then
 461          for J in Source'Range loop
 462             if Belongs (Source (J), Set, Test) then
 463                return J;
 464             end if;
 465          end loop;
 466
 467       --  Backwards case
 468
 469       else
 470          for J in reverse Source'Range loop
 471             if Belongs (Source (J), Set, Test) then
 472                return J;
 473             end if;
 474          end loop;
 475       end if;
 476
 477       --  Fall through if no match
 478
 479       return 0;
 480    end Index;
 481
 482    function Index
 483      (Source  : Wide_String;
 484       Pattern : Wide_String;
 485       From    : Positive;
 486       Going   : Direction := Forward;
 487       Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
 488       return Natural
 489    is
 490    begin
 491       if Going = Forward then
 492          if From < Source'First then
 493             raise Index_Error;
 494          end if;
 495
 496          return
 497            Index (Source (From .. Source'Last), Pattern, Forward, Mapping);
 498
 499       else
 500          if From > Source'Last then
 501             raise Index_Error;
 502          end if;
 503
 504          return
 505            Index (Source (Source'First .. From), Pattern, Backward, Mapping);
 506       end if;
 507    end Index;
 508
 509    function Index
 510      (Source  : Wide_String;
 511       Pattern : Wide_String;
 512       From    : Positive;
 513       Going   : Direction := Forward;
 514       Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
 515    is
 516    begin
 517       if Going = Forward then
 518          if From < Source'First then
 519             raise Index_Error;
 520          end if;
 521
 522          return Index
 523            (Source (From .. Source'Last), Pattern, Forward, Mapping);
 524
 525       else
 526          if From > Source'Last then
 527             raise Index_Error;
 528          end if;
 529
 530          return Index
 531            (Source (Source'First .. From), Pattern, Backward, Mapping);
 532       end if;
 533    end Index;
 534
 535    function Index
 536      (Source  : Wide_String;
 537       Set     : Wide_Maps.Wide_Character_Set;
 538       From    : Positive;
 539       Test    : Membership := Inside;
 540       Going   : Direction := Forward) return Natural
 541    is
 542    begin
 543       if Going = Forward then
 544          if From < Source'First then
 545             raise Index_Error;
 546          end if;
 547
 548          return
 549            Index (Source (From .. Source'Last), Set, Test, Forward);
 550
 551       else
 552          if From > Source'Last then
 553             raise Index_Error;
 554          end if;
 555
 556          return
 557            Index (Source (Source'First .. From), Set, Test, Backward);
 558       end if;
 559    end Index;
 560
 561    ---------------------
 562    -- Index_Non_Blank --
 563    ---------------------
 564
 565    function Index_Non_Blank
 566      (Source : Wide_String;
 567       Going  : Direction := Forward) return Natural
 568    is
 569    begin
 570       if Going = Forward then
 571          for J in Source'Range loop
 572             if Source (J) /= Wide_Space then
 573                return J;
 574             end if;
 575          end loop;
 576
 577       else -- Going = Backward
 578          for J in reverse Source'Range loop
 579             if Source (J) /= Wide_Space then
 580                return J;
 581             end if;
 582          end loop;
 583       end if;
 584
 585       --  Fall through if no match
 586
 587       return 0;
 588    end Index_Non_Blank;
 589
 590    function Index_Non_Blank
 591      (Source : Wide_String;
 592       From   : Positive;
 593       Going  : Direction := Forward) return Natural
 594    is
 595    begin
 596       if Going = Forward then
 597          if From < Source'First then
 598             raise Index_Error;
 599          end if;
 600
 601          return
 602            Index_Non_Blank (Source (From .. Source'Last), Forward);
 603
 604       else
 605          if From > Source'Last then
 606             raise Index_Error;
 607          end if;
 608
 609          return
 610            Index_Non_Blank (Source (Source'First .. From), Backward);
 611       end if;
 612    end Index_Non_Blank;
 613
 614 end Ada.Strings.Wide_Search;