gcc/ada/s-regexp.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                        S Y S T E M . R E G E X P                         --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 1999-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Unchecked_Deallocation;
  35 --  with Ada.Exceptions;
  36
  37 with System.Case_Util;
  38
  39 package body System.Regexp is
  40
  41    Open_Paren    : constant Character := '(';
  42    Close_Paren   : constant Character := ')';
  43    Open_Bracket  : constant Character := '[';
  44    Close_Bracket : constant Character := ']';
  45
  46    type State_Index is new Natural;
  47    type Column_Index is new Natural;
  48
  49    type Regexp_Array is array
  50      (State_Index range <>, Column_Index range <>) of State_Index;
  51    --  First index is for the state number
  52    --  Second index is for the character type
  53    --  Contents is the new State
  54
  55    type Regexp_Array_Access is access Regexp_Array;
  56    --  Use this type through the functions Set below, so that it
  57    --  can grow dynamically depending on the needs.
  58
  59    type Mapping is array (Character'Range) of Column_Index;
  60    --  Mapping between characters and column in the Regexp_Array
  61
  62    type Boolean_Array is array (State_Index range <>) of Boolean;
  63
  64    type Regexp_Value
  65      (Alphabet_Size : Column_Index;
  66       Num_States    : State_Index) is
  67    record
  68       Map            : Mapping;
  69       States         : Regexp_Array (1 .. Num_States, 0 .. Alphabet_Size);
  70       Is_Final       : Boolean_Array (1 .. Num_States);
  71       Case_Sensitive : Boolean;
  72    end record;
  73    --  Deterministic finite-state machine
  74
  75    -----------------------
  76    -- Local Subprograms --
  77    -----------------------
  78
  79    procedure Set
  80      (Table  : in out Regexp_Array_Access;
  81       State  : State_Index;
  82       Column : Column_Index;
  83       Value  : State_Index);
  84    --  Sets a value in the table. If the table is too small, reallocate it
  85    --  dynamically so that (State, Column) is a valid index in it.
  86
  87    function Get
  88      (Table  : Regexp_Array_Access;
  89       State  : State_Index;
  90       Column : Column_Index)
  91       return   State_Index;
  92    --  Returns the value in the table at (State, Column).
  93    --  If this index does not exist in the table, returns 0
  94
  95    procedure Free is new Ada.Unchecked_Deallocation
  96      (Regexp_Array, Regexp_Array_Access);
  97
  98    ------------
  99    -- Adjust --
 100    ------------
 101
 102    procedure Adjust (R : in out Regexp) is
 103       Tmp : Regexp_Access;
 104
 105    begin
 106       Tmp := new Regexp_Value (Alphabet_Size => R.R.Alphabet_Size,
 107                                Num_States    => R.R.Num_States);
 108       Tmp.all := R.R.all;
 109       R.R := Tmp;
 110    end Adjust;
 111
 112    -------------
 113    -- Compile --
 114    -------------
 115
 116    function Compile
 117      (Pattern        : String;
 118       Glob           : Boolean := False;
 119       Case_Sensitive : Boolean := True)
 120       return           Regexp
 121    is
 122       S : String := Pattern;
 123       --  The pattern which is really compiled (when the pattern is case
 124       --  insensitive, we convert this string to lower-cases
 125
 126       Map : Mapping := (others => 0);
 127       --  Mapping between characters and columns in the tables
 128
 129       Alphabet_Size : Column_Index := 0;
 130       --  Number of significant characters in the regular expression.
 131       --  This total does not include special operators, such as *, (, ...
 132
 133       procedure Create_Mapping;
 134       --  Creates a mapping between characters in the regexp and columns
 135       --  in the tables representing the regexp. Test that the regexp is
 136       --  well-formed Modifies Alphabet_Size and Map
 137
 138       procedure Create_Primary_Table
 139         (Table       : out Regexp_Array_Access;
 140          Num_States  : out State_Index;
 141          Start_State : out State_Index;
 142          End_State   : out State_Index);
 143       --  Creates the first version of the regexp (this is a non determinist
 144       --  finite state machine, which is unadapted for a fast pattern
 145       --  matching algorithm). We use a recursive algorithm to process the
 146       --  parenthesis sub-expressions.
 147       --
 148       --  Table : at the end of the procedure : Column 0 is for any character
 149       --  ('.') and the last columns are for no character (closure)
 150       --  Num_States is set to the number of states in the table
 151       --  Start_State is the number of the starting state in the regexp
 152       --  End_State is the number of the final state when the regexp matches
 153
 154       procedure Create_Primary_Table_Glob
 155         (Table       : out Regexp_Array_Access;
 156          Num_States  : out State_Index;
 157          Start_State : out State_Index;
 158          End_State   : out State_Index);
 159       --  Same function as above, but it deals with the second possible
 160       --  grammar for 'globbing pattern', which is a kind of subset of the
 161       --  whole regular expression grammar.
 162
 163       function Create_Secondary_Table
 164         (First_Table : Regexp_Array_Access;
 165          Num_States  : State_Index;
 166          Start_State : State_Index;
 167          End_State   : State_Index)
 168          return        Regexp;
 169       --  Creates the definitive table representing the regular expression
 170       --  This is actually a transformation of the primary table First_Table,
 171       --  where every state is grouped with the states in its 'no-character'
 172       --  columns. The transitions between the new states are then recalculated
 173       --  and if necessary some new states are created.
 174       --
 175       --  Note that the resulting finite-state machine is not optimized in
 176       --  terms of the number of states : it would be more time-consuming to
 177       --  add a third pass to reduce the number of states in the machine, with
 178       --  no speed improvement...
 179
 180       procedure Raise_Exception (M : String; Index : Integer);
 181       pragma No_Return (Raise_Exception);
 182       --  Raise an exception, indicating an error at character Index in S
 183
 184       --------------------
 185       -- Create_Mapping --
 186       --------------------
 187
 188       procedure Create_Mapping is
 189
 190          procedure Add_In_Map (C : Character);
 191          --  Add a character in the mapping, if it is not already defined
 192
 193          ----------------
 194          -- Add_In_Map --
 195          ----------------
 196
 197          procedure Add_In_Map (C : Character) is
 198          begin
 199             if Map (C) = 0 then
 200                Alphabet_Size := Alphabet_Size + 1;
 201                Map (C) := Alphabet_Size;
 202             end if;
 203          end Add_In_Map;
 204
 205          J                 : Integer := S'First;
 206          Parenthesis_Level : Integer := 0;
 207          Curly_Level       : Integer := 0;
 208
 209       --  Start of processing for Create_Mapping
 210
 211       begin
 212          while J <= S'Last loop
 213             case S (J) is
 214                when Open_Bracket =>
 215                   J := J + 1;
 216
 217                   if S (J) = '^' then
 218                      J := J + 1;
 219                   end if;
 220
 221                   if S (J) = ']' or S (J) = '-' then
 222                      J := J + 1;
 223                   end if;
 224
 225                   --  The first character never has a special meaning
 226
 227                   loop
 228                      if J > S'Last then
 229                         Raise_Exception
 230                           ("Ran out of characters while parsing ", J);
 231                      end if;
 232
 233                      exit when S (J) = Close_Bracket;
 234
 235                      if S (J) = '-'
 236                        and then S (J + 1) /= Close_Bracket
 237                      then
 238                         declare
 239                            Start : constant Integer := J - 1;
 240
 241                         begin
 242                            J := J + 1;
 243
 244                            if S (J) = '\' then
 245                               J := J + 1;
 246                            end if;
 247
 248                            for Char in S (Start) .. S (J) loop
 249                               Add_In_Map (Char);
 250                            end loop;
 251                         end;
 252                      else
 253                         if S (J) = '\' then
 254                            J := J + 1;
 255                         end if;
 256
 257                         Add_In_Map (S (J));
 258                      end if;
 259
 260                      J := J + 1;
 261                   end loop;
 262
 263                   --  A close bracket must follow a open_bracket,
 264                   --  and cannot be found alone on the line
 265
 266                when Close_Bracket =>
 267                   Raise_Exception
 268                     ("Incorrect character ']' in regular expression", J);
 269
 270                when '\' =>
 271                   if J < S'Last  then
 272                      J := J + 1;
 273                      Add_In_Map (S (J));
 274
 275                   else
 276                      --  \ not allowed at the end of the regexp
 277
 278                      Raise_Exception
 279                        ("Incorrect character '\' in regular expression", J);
 280                   end if;
 281
 282                when Open_Paren =>
 283                   if not Glob then
 284                      Parenthesis_Level := Parenthesis_Level + 1;
 285                   else
 286                      Add_In_Map (Open_Paren);
 287                   end if;
 288
 289                when Close_Paren =>
 290                   if not Glob then
 291                      Parenthesis_Level := Parenthesis_Level - 1;
 292
 293                      if Parenthesis_Level < 0 then
 294                         Raise_Exception
 295                           ("')' is not associated with '(' in regular "
 296                            & "expression", J);
 297                      end if;
 298
 299                      if S (J - 1) = Open_Paren then
 300                         Raise_Exception
 301                           ("Empty parenthesis not allowed in regular "
 302                            & "expression", J);
 303                      end if;
 304
 305                   else
 306                      Add_In_Map (Close_Paren);
 307                   end if;
 308
 309                when '.' =>
 310                   if Glob then
 311                      Add_In_Map ('.');
 312                   end if;
 313
 314                when '{' =>
 315                   if not Glob then
 316                      Add_In_Map (S (J));
 317                   else
 318                      Curly_Level := Curly_Level + 1;
 319                   end if;
 320
 321                when '}' =>
 322                   if not Glob then
 323                      Add_In_Map (S (J));
 324                   else
 325                      Curly_Level := Curly_Level - 1;
 326                   end if;
 327
 328                when '*' | '?' =>
 329                   if not Glob then
 330                      if J = S'First then
 331                         Raise_Exception
 332                           ("'*', '+', '?' and '|' operators cannot be in "
 333                            & "first position in regular expression", J);
 334                      end if;
 335                   end if;
 336
 337                when '|' | '+' =>
 338                   if not Glob then
 339                      if J = S'First then
 340
 341                         --  These operators must apply to a sub-expression,
 342                         --  and cannot be found at the beginning of the line
 343
 344                         Raise_Exception
 345                           ("'*', '+', '?' and '|' operators cannot be in "
 346                            & "first position in regular expression", J);
 347                      end if;
 348
 349                   else
 350                      Add_In_Map (S (J));
 351                   end if;
 352
 353                when others =>
 354                   Add_In_Map (S (J));
 355             end case;
 356
 357             J := J + 1;
 358          end loop;
 359
 360          --  A closing parenthesis must follow an open parenthesis
 361
 362          if Parenthesis_Level /= 0 then
 363             Raise_Exception
 364               ("'(' must always be associated with a ')'", J);
 365          end if;
 366
 367          if Curly_Level /= 0 then
 368             Raise_Exception
 369               ("'{' must always be associated with a '}'", J);
 370          end if;
 371       end Create_Mapping;
 372
 373       --------------------------
 374       -- Create_Primary_Table --
 375       --------------------------
 376
 377       procedure Create_Primary_Table
 378         (Table       : out Regexp_Array_Access;
 379          Num_States  : out State_Index;
 380          Start_State : out State_Index;
 381          End_State   : out State_Index)
 382       is
 383          Empty_Char : constant Column_Index := Alphabet_Size + 1;
 384
 385          Current_State : State_Index := 0;
 386          --  Index of the last created state
 387
 388          procedure Add_Empty_Char
 389            (State    : State_Index;
 390             To_State : State_Index);
 391          --  Add a empty-character transition from State to To_State
 392
 393          procedure Create_Repetition
 394            (Repetition : Character;
 395             Start_Prev : State_Index;
 396             End_Prev   : State_Index;
 397             New_Start  : out State_Index;
 398             New_End    : in out State_Index);
 399          --  Create the table in case we have a '*', '+' or '?'.
 400          --  Start_Prev .. End_Prev should indicate respectively the start and
 401          --  end index of the previous expression, to which '*', '+' or '?' is
 402          --  applied.
 403
 404          procedure Create_Simple
 405            (Start_Index : Integer;
 406             End_Index   : Integer;
 407             Start_State : out State_Index;
 408             End_State   : out State_Index);
 409          --  Fill the table for the regexp Simple.
 410          --  This is the recursive procedure called to handle () expressions
 411          --  If End_State = 0, then the call to Create_Simple creates an
 412          --  independent regexp, not a concatenation
 413          --  Start_Index .. End_Index is the starting index in the string S.
 414          --
 415          --  Warning: it may look like we are creating too many empty-string
 416          --  transitions, but they are needed to get the correct regexp.
 417          --  The table is filled as follow ( s means start-state, e means
 418          --  end-state) :
 419          --
 420          --  regexp   state_num | a b * empty_string
 421          --  -------  ------------------------------
 422          --    a          1 (s) | 2 - - -
 423          --               2 (e) | - - - -
 424          --
 425          --    ab         1 (s) | 2 - - -
 426          --               2     | - - - 3
 427          --               3     | - 4 - -
 428          --               4 (e) | - - - -
 429          --
 430          --    a|b        1     | 2 - - -
 431          --               2     | - - - 6
 432          --               3     | - 4 - -
 433          --               4     | - - - 6
 434          --               5 (s) | - - - 1,3
 435          --               6 (e) | - - - -
 436          --
 437          --    a*         1     | 2 - - -
 438          --               2     | - - - 4
 439          --               3 (s) | - - - 1,4
 440          --               4 (e) | - - - 3
 441          --
 442          --    (a)        1 (s) | 2 - - -
 443          --               2 (e) | - - - -
 444          --
 445          --    a+         1     | 2 - - -
 446          --               2     | - - - 4
 447          --               3 (s) | - - - 1
 448          --               4 (e) | - - - 3
 449          --
 450          --    a?         1     | 2 - - -
 451          --               2     | - - - 4
 452          --               3 (s) | - - - 1,4
 453          --               4 (e) | - - - -
 454          --
 455          --    .          1 (s) | 2 2 2 -
 456          --               2 (e) | - - - -
 457
 458          function Next_Sub_Expression
 459            (Start_Index : Integer;
 460             End_Index   : Integer)
 461             return        Integer;
 462          --  Returns the index of the last character of the next sub-expression
 463          --  in Simple. Index cannot be greater than End_Index.
 464
 465          --------------------
 466          -- Add_Empty_Char --
 467          --------------------
 468
 469          procedure Add_Empty_Char
 470            (State    : State_Index;
 471             To_State : State_Index)
 472          is
 473             J : Column_Index := Empty_Char;
 474
 475          begin
 476             while Get (Table, State, J) /= 0 loop
 477                J := J + 1;
 478             end loop;
 479
 480             Set (Table, State, J, To_State);
 481          end Add_Empty_Char;
 482
 483          -----------------------
 484          -- Create_Repetition --
 485          -----------------------
 486
 487          procedure Create_Repetition
 488            (Repetition : Character;
 489             Start_Prev : State_Index;
 490             End_Prev   : State_Index;
 491             New_Start  : out State_Index;
 492             New_End    : in out State_Index)
 493          is
 494          begin
 495             New_Start := Current_State + 1;
 496
 497             if New_End /= 0 then
 498                Add_Empty_Char (New_End, New_Start);
 499             end if;
 500
 501             Current_State := Current_State + 2;
 502             New_End   := Current_State;
 503
 504             Add_Empty_Char (End_Prev, New_End);
 505             Add_Empty_Char (New_Start, Start_Prev);
 506
 507             if Repetition /= '+' then
 508                Add_Empty_Char (New_Start, New_End);
 509             end if;
 510
 511             if Repetition /= '?' then
 512                Add_Empty_Char (New_End, New_Start);
 513             end if;
 514          end Create_Repetition;
 515
 516          -------------------
 517          -- Create_Simple --
 518          -------------------
 519
 520          procedure Create_Simple
 521            (Start_Index : Integer;
 522             End_Index   : Integer;
 523             Start_State : out State_Index;
 524             End_State   : out State_Index)
 525          is
 526             J          : Integer := Start_Index;
 527             Last_Start : State_Index := 0;
 528
 529          begin
 530             Start_State := 0;
 531             End_State   := 0;
 532             while J <= End_Index loop
 533                case S (J) is
 534                   when Open_Paren =>
 535                      declare
 536                         J_Start    : constant Integer := J + 1;
 537                         Next_Start : State_Index;
 538                         Next_End   : State_Index;
 539
 540                      begin
 541                         J := Next_Sub_Expression (J, End_Index);
 542                         Create_Simple (J_Start, J - 1, Next_Start, Next_End);
 543
 544                         if J < End_Index
 545                           and then (S (J + 1) = '*' or else
 546                                     S (J + 1) = '+' or else
 547                                     S (J + 1) = '?')
 548                         then
 549                            J := J + 1;
 550                            Create_Repetition
 551                              (S (J),
 552                               Next_Start,
 553                               Next_End,
 554                               Last_Start,
 555                               End_State);
 556
 557                         else
 558                            Last_Start := Next_Start;
 559
 560                            if End_State /= 0 then
 561                               Add_Empty_Char (End_State, Last_Start);
 562                            end if;
 563
 564                            End_State := Next_End;
 565                         end if;
 566                      end;
 567
 568                   when '|' =>
 569                      declare
 570                         Start_Prev : constant State_Index := Start_State;
 571                         End_Prev   : constant State_Index := End_State;
 572                         Start_J    : constant Integer     := J + 1;
 573                         Start_Next : State_Index := 0;
 574                         End_Next   : State_Index := 0;
 575
 576                      begin
 577                         J := Next_Sub_Expression (J, End_Index);
 578
 579                         --  Create a new state for the start of the alternative
 580
 581                         Current_State := Current_State + 1;
 582                         Last_Start := Current_State;
 583                         Start_State := Last_Start;
 584
 585                         --  Create the tree for the second part of alternative
 586
 587                         Create_Simple (Start_J, J, Start_Next, End_Next);
 588
 589                         --  Create the end state
 590
 591                         Add_Empty_Char (Last_Start, Start_Next);
 592                         Add_Empty_Char (Last_Start, Start_Prev);
 593                         Current_State := Current_State + 1;
 594                         End_State := Current_State;
 595                         Add_Empty_Char (End_Prev, End_State);
 596                         Add_Empty_Char (End_Next, End_State);
 597                      end;
 598
 599                   when Open_Bracket =>
 600                      Current_State := Current_State + 1;
 601
 602                      declare
 603                         Next_State : State_Index := Current_State + 1;
 604
 605                      begin
 606                         J := J + 1;
 607
 608                         if S (J) = '^' then
 609                            J := J + 1;
 610
 611                            Next_State := 0;
 612
 613                            for Column in 0 .. Alphabet_Size loop
 614                               Set (Table, Current_State, Column,
 615                                    Value => Current_State + 1);
 616                            end loop;
 617                         end if;
 618
 619                         --  Automatically add the first character
 620
 621                         if S (J) = '-' or S (J) = ']' then
 622                            Set (Table, Current_State, Map (S (J)),
 623                                 Value => Next_State);
 624                            J := J + 1;
 625                         end if;
 626
 627                         --  Loop till closing bracket found
 628
 629                         loop
 630                            exit when S (J) = Close_Bracket;
 631
 632                            if S (J) = '-'
 633                              and then S (J + 1) /= ']'
 634                            then
 635                               declare
 636                                  Start : constant Integer := J - 1;
 637
 638                               begin
 639                                  J := J + 1;
 640
 641                                  if S (J) = '\' then
 642                                     J := J + 1;
 643                                  end if;
 644
 645                                  for Char in S (Start) .. S (J) loop
 646                                     Set (Table, Current_State, Map (Char),
 647                                          Value => Next_State);
 648                                  end loop;
 649                               end;
 650
 651                            else
 652                               if S (J) = '\' then
 653                                  J := J + 1;
 654                               end if;
 655
 656                               Set (Table, Current_State, Map (S (J)),
 657                                    Value => Next_State);
 658                            end if;
 659                            J := J + 1;
 660                         end loop;
 661                      end;
 662
 663                      Current_State := Current_State + 1;
 664
 665                      --  If the next symbol is a special symbol
 666
 667                      if J < End_Index
 668                        and then (S (J + 1) = '*' or else
 669                                  S (J + 1) = '+' or else
 670                                  S (J + 1) = '?')
 671                      then
 672                         J := J + 1;
 673                         Create_Repetition
 674                           (S (J),
 675                            Current_State - 1,
 676                            Current_State,
 677                            Last_Start,
 678                            End_State);
 679
 680                      else
 681                         Last_Start := Current_State - 1;
 682
 683                         if End_State /= 0 then
 684                            Add_Empty_Char (End_State, Last_Start);
 685                         end if;
 686
 687                         End_State := Current_State;
 688                      end if;
 689
 690                   when '*' | '+' | '?' | Close_Paren | Close_Bracket =>
 691                      Raise_Exception
 692                        ("Incorrect character in regular expression :", J);
 693
 694                   when others =>
 695                      Current_State := Current_State + 1;
 696
 697                      --  Create the state for the symbol S (J)
 698
 699                      if S (J) = '.' then
 700                         for K in 0 .. Alphabet_Size loop
 701                            Set (Table, Current_State, K,
 702                                 Value => Current_State + 1);
 703                         end loop;
 704
 705                      else
 706                         if S (J) = '\' then
 707                            J := J + 1;
 708                         end if;
 709
 710                         Set (Table, Current_State, Map (S (J)),
 711                              Value => Current_State + 1);
 712                      end if;
 713
 714                      Current_State := Current_State + 1;
 715
 716                      --  If the next symbol is a special symbol
 717
 718                      if J < End_Index
 719                        and then (S (J + 1) = '*' or else
 720                                  S (J + 1) = '+' or else
 721                                  S (J + 1) = '?')
 722                      then
 723                         J := J + 1;
 724                         Create_Repetition
 725                           (S (J),
 726                            Current_State - 1,
 727                            Current_State,
 728                            Last_Start,
 729                            End_State);
 730
 731                      else
 732                         Last_Start := Current_State - 1;
 733
 734                         if End_State /= 0 then
 735                            Add_Empty_Char (End_State, Last_Start);
 736                         end if;
 737
 738                         End_State := Current_State;
 739                      end if;
 740
 741                end case;
 742
 743                if Start_State = 0 then
 744                   Start_State := Last_Start;
 745                end if;
 746
 747                J := J + 1;
 748             end loop;
 749          end Create_Simple;
 750
 751          -------------------------
 752          -- Next_Sub_Expression --
 753          -------------------------
 754
 755          function Next_Sub_Expression
 756            (Start_Index : Integer;
 757             End_Index   : Integer)
 758             return        Integer
 759          is
 760             J              : Integer := Start_Index;
 761             Start_On_Alter : Boolean := False;
 762
 763          begin
 764             if S (J) = '|' then
 765                Start_On_Alter := True;
 766             end if;
 767
 768             loop
 769                exit when J = End_Index;
 770                J := J + 1;
 771
 772                case S (J) is
 773                   when '\' =>
 774                      J := J + 1;
 775
 776                   when Open_Bracket =>
 777                      loop
 778                         J := J + 1;
 779                         exit when S (J) = Close_Bracket;
 780
 781                         if S (J) = '\' then
 782                            J := J + 1;
 783                         end if;
 784                      end loop;
 785
 786                   when Open_Paren =>
 787                      J := Next_Sub_Expression (J, End_Index);
 788
 789                   when Close_Paren =>
 790                      return J;
 791
 792                   when '|' =>
 793                      if Start_On_Alter then
 794                         return J - 1;
 795                      end if;
 796
 797                   when others =>
 798                      null;
 799                end case;
 800             end loop;
 801
 802             return J;
 803          end Next_Sub_Expression;
 804
 805       --  Start of Create_Primary_Table
 806
 807       begin
 808          Table.all := (others => (others => 0));
 809          Create_Simple (S'First, S'Last, Start_State, End_State);
 810          Num_States := Current_State;
 811       end Create_Primary_Table;
 812
 813       -------------------------------
 814       -- Create_Primary_Table_Glob --
 815       -------------------------------
 816
 817       procedure Create_Primary_Table_Glob
 818         (Table       : out Regexp_Array_Access;
 819          Num_States  : out State_Index;
 820          Start_State : out State_Index;
 821          End_State   : out State_Index)
 822       is
 823          Empty_Char : constant Column_Index := Alphabet_Size + 1;
 824
 825          Current_State : State_Index := 0;
 826          --  Index of the last created state
 827
 828          procedure Add_Empty_Char
 829            (State    : State_Index;
 830             To_State : State_Index);
 831          --  Add a empty-character transition from State to To_State
 832
 833          procedure Create_Simple
 834            (Start_Index : Integer;
 835             End_Index   : Integer;
 836             Start_State : out State_Index;
 837             End_State   : out State_Index);
 838          --  Fill the table for the S (Start_Index .. End_Index).
 839          --  This is the recursive procedure called to handle () expressions
 840
 841          --------------------
 842          -- Add_Empty_Char --
 843          --------------------
 844
 845          procedure Add_Empty_Char
 846            (State    : State_Index;
 847             To_State : State_Index)
 848          is
 849             J : Column_Index := Empty_Char;
 850
 851          begin
 852             while Get (Table, State, J) /= 0 loop
 853                J := J + 1;
 854             end loop;
 855
 856             Set (Table, State, J,
 857                  Value => To_State);
 858          end Add_Empty_Char;
 859
 860          -------------------
 861          -- Create_Simple --
 862          -------------------
 863
 864          procedure Create_Simple
 865            (Start_Index : Integer;
 866             End_Index   : Integer;
 867             Start_State : out State_Index;
 868             End_State   : out State_Index)
 869          is
 870             J          : Integer := Start_Index;
 871             Last_Start : State_Index := 0;
 872
 873          begin
 874             Start_State := 0;
 875             End_State   := 0;
 876
 877             while J <= End_Index loop
 878                case S (J) is
 879
 880                   when Open_Bracket =>
 881                      Current_State := Current_State + 1;
 882
 883                      declare
 884                         Next_State : State_Index := Current_State + 1;
 885
 886                      begin
 887                         J := J + 1;
 888
 889                         if S (J) = '^' then
 890                            J := J + 1;
 891                            Next_State := 0;
 892
 893                            for Column in 0 .. Alphabet_Size loop
 894                               Set (Table, Current_State, Column,
 895                                    Value => Current_State + 1);
 896                            end loop;
 897                         end if;
 898
 899                         --  Automatically add the first character
 900
 901                         if S (J) = '-' or S (J) = ']' then
 902                            Set (Table, Current_State, Map (S (J)),
 903                                 Value => Current_State);
 904                            J := J + 1;
 905                         end if;
 906
 907                         --  Loop till closing bracket found
 908
 909                         loop
 910                            exit when S (J) = Close_Bracket;
 911
 912                            if S (J) = '-'
 913                              and then S (J + 1) /= ']'
 914                            then
 915                               declare
 916                                  Start : constant Integer := J - 1;
 917                               begin
 918                                  J := J + 1;
 919
 920                                  if S (J) = '\' then
 921                                     J := J + 1;
 922                                  end if;
 923
 924                                  for Char in S (Start) .. S (J) loop
 925                                     Set (Table, Current_State, Map (Char),
 926                                          Value => Next_State);
 927                                  end loop;
 928                               end;
 929
 930                            else
 931                               if S (J) = '\' then
 932                                  J := J + 1;
 933                               end if;
 934
 935                               Set (Table, Current_State, Map (S (J)),
 936                                    Value => Next_State);
 937                            end if;
 938                            J := J + 1;
 939                         end loop;
 940                      end;
 941
 942                      Last_Start := Current_State;
 943                      Current_State := Current_State + 1;
 944
 945                      if End_State /= 0 then
 946                         Add_Empty_Char (End_State, Last_Start);
 947                      end if;
 948
 949                      End_State := Current_State;
 950
 951                   when '{' =>
 952                      declare
 953                         End_Sub          : Integer;
 954                         Start_Regexp_Sub : State_Index;
 955                         End_Regexp_Sub   : State_Index;
 956                         Create_Start     : State_Index := 0;
 957
 958                         Create_End : State_Index := 0;
 959                         --  Initialized to avoid junk warning
 960
 961                      begin
 962                         while S (J) /= '}' loop
 963
 964                            --  First step : find sub pattern
 965
 966                            End_Sub := J + 1;
 967                            while S (End_Sub) /= ','
 968                              and then S (End_Sub) /= '}'
 969                            loop
 970                               End_Sub := End_Sub + 1;
 971                            end loop;
 972
 973                            --  Second step : create a sub pattern
 974
 975                            Create_Simple
 976                              (J + 1,
 977                               End_Sub - 1,
 978                               Start_Regexp_Sub,
 979                               End_Regexp_Sub);
 980
 981                            J := End_Sub;
 982
 983                            --  Third step : create an alternative
 984
 985                            if Create_Start = 0 then
 986                               Current_State := Current_State + 1;
 987                               Create_Start := Current_State;
 988                               Add_Empty_Char (Create_Start, Start_Regexp_Sub);
 989                               Current_State := Current_State + 1;
 990                               Create_End := Current_State;
 991                               Add_Empty_Char (End_Regexp_Sub, Create_End);
 992
 993                            else
 994                               Current_State := Current_State + 1;
 995                               Add_Empty_Char (Current_State, Create_Start);
 996                               Create_Start := Current_State;
 997                               Add_Empty_Char (Create_Start, Start_Regexp_Sub);
 998                               Add_Empty_Char (End_Regexp_Sub, Create_End);
 999                            end if;
1000                         end loop;
1001
1002                         if End_State /= 0 then
1003                            Add_Empty_Char (End_State, Create_Start);
1004                         end if;
1005
1006                         End_State := Create_End;
1007                         Last_Start := Create_Start;
1008                      end;
1009
1010                   when '*' =>
1011                      Current_State := Current_State + 1;
1012
1013                      if End_State /= 0 then
1014                         Add_Empty_Char (End_State, Current_State);
1015                      end if;
1016
1017                      Add_Empty_Char (Current_State, Current_State + 1);
1018                      Add_Empty_Char (Current_State, Current_State + 3);
1019                      Last_Start := Current_State;
1020
1021                      Current_State := Current_State + 1;
1022
1023                      for K in 0 .. Alphabet_Size loop
1024                         Set (Table, Current_State, K,
1025                              Value => Current_State + 1);
1026                      end loop;
1027
1028                      Current_State := Current_State + 1;
1029                      Add_Empty_Char (Current_State, Current_State + 1);
1030
1031                      Current_State := Current_State + 1;
1032                      Add_Empty_Char (Current_State,  Last_Start);
1033                      End_State := Current_State;
1034
1035                   when others =>
1036                      Current_State := Current_State + 1;
1037
1038                      if S (J) = '?' then
1039                         for K in 0 .. Alphabet_Size loop
1040                            Set (Table, Current_State, K,
1041                                 Value => Current_State + 1);
1042                         end loop;
1043
1044                      else
1045                         if S (J) = '\' then
1046                            J := J + 1;
1047                         end if;
1048
1049                         --  Create the state for the symbol S (J)
1050
1051                         Set (Table, Current_State, Map (S (J)),
1052                              Value => Current_State + 1);
1053                      end if;
1054
1055                      Last_Start := Current_State;
1056                      Current_State := Current_State + 1;
1057
1058                      if End_State /= 0 then
1059                         Add_Empty_Char (End_State, Last_Start);
1060                      end if;
1061
1062                      End_State := Current_State;
1063
1064                end case;
1065
1066                if Start_State = 0 then
1067                   Start_State := Last_Start;
1068                end if;
1069
1070                J := J + 1;
1071             end loop;
1072          end Create_Simple;
1073
1074       --  Start of processing for Create_Primary_Table_Glob
1075
1076       begin
1077          Table.all := (others => (others => 0));
1078          Create_Simple (S'First, S'Last, Start_State, End_State);
1079          Num_States := Current_State;
1080       end Create_Primary_Table_Glob;
1081
1082       ----------------------------
1083       -- Create_Secondary_Table --
1084       ----------------------------
1085
1086       function Create_Secondary_Table
1087         (First_Table : Regexp_Array_Access;
1088          Num_States  : State_Index;
1089          Start_State : State_Index;
1090          End_State   : State_Index) return Regexp
1091       is
1092          pragma Warnings (Off, Num_States);
1093
1094          Last_Index : constant State_Index := First_Table'Last (1);
1095          type Meta_State is array (1 .. Last_Index) of Boolean;
1096
1097          Table : Regexp_Array (1 .. Last_Index, 0 .. Alphabet_Size) :=
1098                    (others => (others => 0));
1099
1100          Meta_States : array (1 .. Last_Index + 1) of Meta_State :=
1101                          (others => (others => False));
1102
1103          Temp_State_Not_Null : Boolean;
1104
1105          Is_Final : Boolean_Array (1 .. Last_Index) := (others => False);
1106
1107          Current_State       : State_Index := 1;
1108          Nb_State            : State_Index := 1;
1109
1110          procedure Closure
1111            (State : in out Meta_State;
1112             Item  :        State_Index);
1113          --  Compute the closure of the state (that is every other state which
1114          --  has a empty-character transition) and add it to the state
1115
1116          -------------
1117          -- Closure --
1118          -------------
1119
1120          procedure Closure
1121            (State : in out Meta_State;
1122             Item  : State_Index)
1123          is
1124          begin
1125             if State (Item) then
1126                return;
1127             end if;
1128
1129             State (Item) := True;
1130
1131             for Column in Alphabet_Size + 1 .. First_Table'Last (2) loop
1132                if First_Table (Item, Column) = 0 then
1133                   return;
1134                end if;
1135
1136                Closure (State, First_Table (Item, Column));
1137             end loop;
1138          end Closure;
1139
1140       --  Start of procesing for Create_Secondary_Table
1141
1142       begin
1143          --  Create a new state
1144
1145          Closure (Meta_States (Current_State), Start_State);
1146
1147          while Current_State <= Nb_State loop
1148
1149             --  If this new meta-state includes the primary table end state,
1150             --  then this meta-state will be a final state in the regexp
1151
1152             if Meta_States (Current_State)(End_State) then
1153                Is_Final (Current_State) := True;
1154             end if;
1155
1156             --  For every character in the regexp, calculate the possible
1157             --  transitions from Current_State
1158
1159             for Column in 0 .. Alphabet_Size loop
1160                Meta_States (Nb_State + 1) := (others => False);
1161                Temp_State_Not_Null := False;
1162
1163                for K in Meta_States (Current_State)'Range loop
1164                   if Meta_States (Current_State)(K)
1165                     and then First_Table (K, Column) /= 0
1166                   then
1167                      Closure
1168                        (Meta_States (Nb_State + 1), First_Table (K, Column));
1169                      Temp_State_Not_Null := True;
1170                   end if;
1171                end loop;
1172
1173                --  If at least one transition existed
1174
1175                if Temp_State_Not_Null then
1176
1177                   --  Check if this new state corresponds to an old one
1178
1179                   for K in 1 .. Nb_State loop
1180                      if Meta_States (K) = Meta_States (Nb_State + 1) then
1181                         Table (Current_State, Column) := K;
1182                         exit;
1183                      end if;
1184                   end loop;
1185
1186                   --  If not, create a new state
1187
1188                   if Table (Current_State, Column) = 0 then
1189                      Nb_State := Nb_State + 1;
1190                      Table (Current_State, Column) := Nb_State;
1191                   end if;
1192                end if;
1193             end loop;
1194
1195             Current_State := Current_State + 1;
1196          end loop;
1197
1198          --  Returns the regexp
1199
1200          declare
1201             R : Regexp_Access;
1202
1203          begin
1204             R := new Regexp_Value (Alphabet_Size => Alphabet_Size,
1205                                    Num_States    => Nb_State);
1206             R.Map            := Map;
1207             R.Is_Final       := Is_Final (1 .. Nb_State);
1208             R.Case_Sensitive := Case_Sensitive;
1209
1210             for State in 1 .. Nb_State loop
1211                for K in 0 .. Alphabet_Size loop
1212                   R.States (State, K) := Table (State, K);
1213                end loop;
1214             end loop;
1215
1216             return (Ada.Finalization.Controlled with R => R);
1217          end;
1218       end Create_Secondary_Table;
1219
1220       ---------------------
1221       -- Raise_Exception --
1222       ---------------------
1223
1224       procedure Raise_Exception (M : String; Index : Integer) is
1225       begin
1226          raise Error_In_Regexp with M & " at offset " & Index'Img;
1227       end Raise_Exception;
1228
1229    --  Start of processing for Compile
1230
1231    begin
1232       --  Special case for the empty string: it always matches, and the
1233       --  following processing would fail on it.
1234       if S = "" then
1235          return (Ada.Finalization.Controlled with
1236                  R => new Regexp_Value'
1237                       (Alphabet_Size => 0,
1238                        Num_States    => 1,
1239                        Map           => (others => 0),
1240                        States        => (others => (others => 1)),
1241                        Is_Final      => (others => True),
1242                        Case_Sensitive => True));
1243       end if;
1244
1245       if not Case_Sensitive then
1246          System.Case_Util.To_Lower (S);
1247       end if;
1248
1249       Create_Mapping;
1250
1251       --  Creates the primary table
1252
1253       declare
1254          Table : Regexp_Array_Access;
1255          Num_States  : State_Index;
1256          Start_State : State_Index;
1257          End_State   : State_Index;
1258          R           : Regexp;
1259
1260       begin
1261          Table := new Regexp_Array (1 .. 100,
1262                                     0 .. Alphabet_Size + 10);
1263          if not Glob then
1264             Create_Primary_Table (Table, Num_States, Start_State, End_State);
1265          else
1266             Create_Primary_Table_Glob
1267               (Table, Num_States, Start_State, End_State);
1268          end if;
1269
1270          --  Creates the secondary table
1271
1272          R := Create_Secondary_Table
1273            (Table, Num_States, Start_State, End_State);
1274          Free (Table);
1275          return R;
1276       end;
1277    end Compile;
1278
1279    --------------
1280    -- Finalize --
1281    --------------
1282
1283    procedure Finalize (R : in out Regexp) is
1284       procedure Free is new
1285         Ada.Unchecked_Deallocation (Regexp_Value, Regexp_Access);
1286
1287    begin
1288       Free (R.R);
1289    end Finalize;
1290
1291    ---------
1292    -- Get --
1293    ---------
1294
1295    function Get
1296      (Table  : Regexp_Array_Access;
1297       State  : State_Index;
1298       Column : Column_Index) return State_Index
1299    is
1300    begin
1301       if State <= Table'Last (1)
1302         and then Column <= Table'Last (2)
1303       then
1304          return Table (State, Column);
1305       else
1306          return 0;
1307       end if;
1308    end Get;
1309
1310    -----------
1311    -- Match --
1312    -----------
1313
1314    function Match (S : String; R : Regexp) return Boolean is
1315       Current_State : State_Index := 1;
1316
1317    begin
1318       if R.R = null then
1319          raise Constraint_Error;
1320       end if;
1321
1322       for Char in S'Range loop
1323
1324          if R.R.Case_Sensitive then
1325             Current_State := R.R.States (Current_State, R.R.Map (S (Char)));
1326          else
1327             Current_State :=
1328               R.R.States (Current_State,
1329                           R.R.Map (System.Case_Util.To_Lower (S (Char))));
1330          end if;
1331
1332          if Current_State = 0 then
1333             return False;
1334          end if;
1335
1336       end loop;
1337
1338       return R.R.Is_Final (Current_State);
1339    end Match;
1340
1341    ---------
1342    -- Set --
1343    ---------
1344
1345    procedure Set
1346      (Table  : in out Regexp_Array_Access;
1347       State  : State_Index;
1348       Column : Column_Index;
1349       Value  : State_Index)
1350    is
1351       New_Lines   : State_Index;
1352       New_Columns : Column_Index;
1353       New_Table   : Regexp_Array_Access;
1354
1355    begin
1356       if State <= Table'Last (1)
1357         and then Column <= Table'Last (2)
1358       then
1359          Table (State, Column) := Value;
1360       else
1361          --  Doubles the size of the table until it is big enough that
1362          --  (State, Column) is a valid index
1363
1364          New_Lines := Table'Last (1) * (State / Table'Last (1) + 1);
1365          New_Columns := Table'Last (2) * (Column / Table'Last (2) + 1);
1366          New_Table := new Regexp_Array (Table'First (1) .. New_Lines,
1367                                         Table'First (2) .. New_Columns);
1368          New_Table.all := (others => (others => 0));
1369
1370          for J in Table'Range (1) loop
1371             for K in Table'Range (2) loop
1372                New_Table (J, K) := Table (J, K);
1373             end loop;
1374          end loop;
1375
1376          Free (Table);
1377          Table := New_Table;
1378          Table (State, Column) := Value;
1379       end if;
1380    end Set;
1381
1382 end System.Regexp;