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