gcc/ada/s-regexp.adb

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