gcc/ada/s-regpat.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                          G N A T . R E G P A T                           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --               Copyright (C) 1986 by University of Toronto.               --
  10 --                      Copyright (C) 1999-2010, AdaCore                    --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This is an altered Ada 95 version of the original V8 style regular
  36 --  expression library written in C by Henry Spencer. Apart from the
  37 --  translation to Ada, the interface has been considerably changed to
  38 --  use the Ada String type instead of C-style nul-terminated strings.
  39
  40 --  Beware that some of this code is subtly aware of the way operator
  41 --  precedence is structured in regular expressions. Serious changes in
  42 --  regular-expression syntax might require a total rethink.
  43
  44 with System.IO;               use System.IO;
  45 with Ada.Characters.Handling; use Ada.Characters.Handling;
  46 with Ada.Unchecked_Conversion;
  47
  48 package body System.Regpat is
  49
  50    Debug : constant Boolean := False;
  51    --  Set to True to activate debug traces. This is normally set to constant
  52    --  False to simply delete all the trace code. It is to be edited to True
  53    --  for internal debugging of the package.
  54
  55    ----------------------------
  56    -- Implementation details --
  57    ----------------------------
  58
  59    --  This is essentially a linear encoding of a nondeterministic
  60    --  finite-state machine, also known as syntax charts or
  61    --  "railroad normal form" in parsing technology.
  62
  63    --  Each node is an opcode plus a "next" pointer, possibly plus an
  64    --  operand. "Next" pointers of all nodes except BRANCH implement
  65    --  concatenation; a "next" pointer with a BRANCH on both ends of it
  66    --  is connecting two alternatives.
  67
  68    --  The operand of some types of node is a literal string; for others,
  69    --  it is a node leading into a sub-FSM. In particular, the operand of
  70    --  a BRANCH node is the first node of the branch.
  71    --  (NB this is *not* a tree structure:  the tail of the branch connects
  72    --  to the thing following the set of BRANCHes).
  73
  74    --  You can see the exact byte-compiled version by using the Dump
  75    --  subprogram. However, here are a few examples:
  76
  77    --  (a|b):  1 : BRANCH  (next at  9)
  78    --          4 :    EXACT  (next at  17)   operand=a
  79    --          9 : BRANCH  (next at  17)
  80    --         12 :    EXACT  (next at  17)   operand=b
  81    --         17 : EOP  (next at 0)
  82    --
  83    --  (ab)*:  1 : CURLYX  (next at  25)  { 0, 32767}
  84    --          8 :    OPEN 1  (next at  12)
  85    --         12 :       EXACT  (next at  18)   operand=ab
  86    --         18 :    CLOSE 1  (next at  22)
  87    --         22 :    WHILEM  (next at 0)
  88    --         25 : NOTHING  (next at  28)
  89    --         28 : EOP  (next at 0)
  90
  91    --  The opcodes are:
  92
  93    type Opcode is
  94
  95       --  Name          Operand?  Meaning
  96
  97      (EOP,        -- no        End of program
  98       MINMOD,     -- no        Next operator is not greedy
  99
 100       --  Classes of characters
 101
 102       ANY,        -- no        Match any one character except newline
 103       SANY,       -- no        Match any character, including new line
 104       ANYOF,      -- class     Match any character in this class
 105       EXACT,      -- str       Match this string exactly
 106       EXACTF,     -- str       Match this string (case-folding is one)
 107       NOTHING,    -- no        Match empty string
 108       SPACE,      -- no        Match any whitespace character
 109       NSPACE,     -- no        Match any non-whitespace character
 110       DIGIT,      -- no        Match any numeric character
 111       NDIGIT,     -- no        Match any non-numeric character
 112       ALNUM,      -- no        Match any alphanumeric character
 113       NALNUM,     -- no        Match any non-alphanumeric character
 114
 115       --  Branches
 116
 117       BRANCH,     -- node      Match this alternative, or the next
 118
 119       --  Simple loops (when the following node is one character in length)
 120
 121       STAR,       -- node      Match this simple thing 0 or more times
 122       PLUS,       -- node      Match this simple thing 1 or more times
 123       CURLY,      -- 2num node Match this simple thing between n and m times.
 124
 125       --  Complex loops
 126
 127       CURLYX,     -- 2num node Match this complex thing {n,m} times
 128       --                       The nums are coded on two characters each
 129
 130       WHILEM,     -- no        Do curly processing and see if rest matches
 131
 132       --  Matches after or before a word
 133
 134       BOL,        -- no        Match "" at beginning of line
 135       MBOL,       -- no        Same, assuming multiline (match after \n)
 136       SBOL,       -- no        Same, assuming single line (don't match at \n)
 137       EOL,        -- no        Match "" at end of line
 138       MEOL,       -- no        Same, assuming multiline (match before \n)
 139       SEOL,       -- no        Same, assuming single line (don't match at \n)
 140
 141       BOUND,      -- no        Match "" at any word boundary
 142       NBOUND,     -- no        Match "" at any word non-boundary
 143
 144       --  Parenthesis groups handling
 145
 146       REFF,       -- num       Match some already matched string, folded
 147       OPEN,       -- num       Mark this point in input as start of #n
 148       CLOSE);     -- num       Analogous to OPEN
 149
 150    for Opcode'Size use 8;
 151
 152    --  Opcode notes:
 153
 154    --  BRANCH
 155    --    The set of branches constituting a single choice are hooked
 156    --    together with their "next" pointers, since precedence prevents
 157    --    anything being concatenated to any individual branch. The
 158    --    "next" pointer of the last BRANCH in a choice points to the
 159    --    thing following the whole choice. This is also where the
 160    --    final "next" pointer of each individual branch points; each
 161    --    branch starts with the operand node of a BRANCH node.
 162
 163    --  STAR,PLUS
 164    --    '?', and complex '*' and '+', are implemented with CURLYX.
 165    --    branches. Simple cases (one character per match) are implemented with
 166    --    STAR and PLUS for speed and to minimize recursive plunges.
 167
 168    --  OPEN,CLOSE
 169    --    ...are numbered at compile time.
 170
 171    --  EXACT, EXACTF
 172    --    There are in fact two arguments, the first one is the length (minus
 173    --    one of the string argument), coded on one character, the second
 174    --    argument is the string itself, coded on length + 1 characters.
 175
 176    --  A node is one char of opcode followed by two chars of "next" pointer.
 177    --  "Next" pointers are stored as two 8-bit pieces, high order first. The
 178    --  value is a positive offset from the opcode of the node containing it.
 179    --  An operand, if any, simply follows the node. (Note that much of the
 180    --  code generation knows about this implicit relationship.)
 181
 182    --  Using two bytes for the "next" pointer is vast overkill for most
 183    --  things, but allows patterns to get big without disasters.
 184
 185    Next_Pointer_Bytes : constant := 3;
 186    --  Points after the "next pointer" data. An instruction is therefore:
 187    --     1 byte: instruction opcode
 188    --     2 bytes: pointer to next instruction
 189    --     * bytes: optional data for the instruction
 190
 191    -----------------------
 192    -- Character classes --
 193    -----------------------
 194    --  This is the implementation for character classes ([...]) in the
 195    --  syntax for regular expressions. Each character (0..256) has an
 196    --  entry into the table. This makes for a very fast matching
 197    --  algorithm.
 198
 199    type Class_Byte is mod 256;
 200    type Character_Class is array (Class_Byte range 0 .. 31) of Class_Byte;
 201
 202    type Bit_Conversion_Array is array (Class_Byte range 0 .. 7) of Class_Byte;
 203    Bit_Conversion : constant Bit_Conversion_Array :=
 204                       (1, 2, 4, 8, 16, 32, 64, 128);
 205
 206    type Std_Class is (ANYOF_NONE,
 207                       ANYOF_ALNUM,   --  Alphanumeric class [a-zA-Z0-9]
 208                       ANYOF_NALNUM,
 209                       ANYOF_SPACE,   --  Space class [ \t\n\r\f]
 210                       ANYOF_NSPACE,
 211                       ANYOF_DIGIT,   --  Digit class [0-9]
 212                       ANYOF_NDIGIT,
 213                       ANYOF_ALNUMC,  --  Alphanumeric class [a-zA-Z0-9]
 214                       ANYOF_NALNUMC,
 215                       ANYOF_ALPHA,   --  Alpha class [a-zA-Z]
 216                       ANYOF_NALPHA,
 217                       ANYOF_ASCII,   --  Ascii class (7 bits) 0..127
 218                       ANYOF_NASCII,
 219                       ANYOF_CNTRL,   --  Control class
 220                       ANYOF_NCNTRL,
 221                       ANYOF_GRAPH,   --  Graphic class
 222                       ANYOF_NGRAPH,
 223                       ANYOF_LOWER,   --  Lower case class [a-z]
 224                       ANYOF_NLOWER,
 225                       ANYOF_PRINT,   --  printable class
 226                       ANYOF_NPRINT,
 227                       ANYOF_PUNCT,   --
 228                       ANYOF_NPUNCT,
 229                       ANYOF_UPPER,   --  Upper case class [A-Z]
 230                       ANYOF_NUPPER,
 231                       ANYOF_XDIGIT,  --  Hexadecimal digit
 232                       ANYOF_NXDIGIT
 233                       );
 234
 235    procedure Set_In_Class
 236      (Bitmap : in out Character_Class;
 237       C      : Character);
 238    --  Set the entry to True for C in the class Bitmap
 239
 240    function Get_From_Class
 241      (Bitmap : Character_Class;
 242       C      : Character) return Boolean;
 243    --  Return True if the entry is set for C in the class Bitmap
 244
 245    procedure Reset_Class (Bitmap : out Character_Class);
 246    --  Clear all the entries in the class Bitmap
 247
 248    pragma Inline (Set_In_Class);
 249    pragma Inline (Get_From_Class);
 250    pragma Inline (Reset_Class);
 251
 252    -----------------------
 253    -- Local Subprograms --
 254    -----------------------
 255
 256    function "=" (Left : Character; Right : Opcode) return Boolean;
 257
 258    function Is_Alnum (C : Character) return Boolean;
 259    --  Return True if C is an alphanum character or an underscore ('_')
 260
 261    function Is_White_Space (C : Character) return Boolean;
 262    --  Return True if C is a whitespace character
 263
 264    function Is_Printable (C : Character) return Boolean;
 265    --  Return True if C is a printable character
 266
 267    function Operand (P : Pointer) return Pointer;
 268    --  Return a pointer to the first operand of the node at P
 269
 270    function String_Length
 271      (Program : Program_Data;
 272       P       : Pointer) return Program_Size;
 273    --  Return the length of the string argument of the node at P
 274
 275    function String_Operand (P : Pointer) return Pointer;
 276    --  Return a pointer to the string argument of the node at P
 277
 278    procedure Bitmap_Operand
 279      (Program : Program_Data;
 280       P       : Pointer;
 281       Op      : out Character_Class);
 282    --  Return a pointer to the string argument of the node at P
 283
 284    function Get_Next
 285      (Program : Program_Data;
 286       IP      : Pointer) return Pointer;
 287    --  Dig the next instruction pointer out of a node
 288
 289    procedure Optimize (Self : in out Pattern_Matcher);
 290    --  Optimize a Pattern_Matcher by noting certain special cases
 291
 292    function Read_Natural
 293      (Program : Program_Data;
 294       IP      : Pointer) return Natural;
 295    --  Return the 2-byte natural coded at position IP
 296
 297    --  All of the subprograms above are tiny and should be inlined
 298
 299    pragma Inline ("=");
 300    pragma Inline (Is_Alnum);
 301    pragma Inline (Is_White_Space);
 302    pragma Inline (Get_Next);
 303    pragma Inline (Operand);
 304    pragma Inline (Read_Natural);
 305    pragma Inline (String_Length);
 306    pragma Inline (String_Operand);
 307
 308    type Expression_Flags is record
 309       Has_Width,            -- Known never to match null string
 310       Simple,               -- Simple enough to be STAR/PLUS operand
 311       SP_Start  : Boolean;  -- Starts with * or +
 312    end record;
 313
 314    Worst_Expression : constant Expression_Flags := (others => False);
 315    --  Worst case
 316
 317    procedure Dump_Until
 318      (Program  : Program_Data;
 319       Index    : in out Pointer;
 320       Till     : Pointer;
 321       Indent   : Natural;
 322       Do_Print : Boolean := True);
 323    --  Dump the program until the node Till (not included) is met. Every line
 324    --  is indented with Index spaces at the beginning Dumps till the end if
 325    --  Till is 0.
 326
 327    procedure Dump_Operation
 328       (Program      : Program_Data;
 329        Index        : Pointer;
 330        Indent       : Natural);
 331    --  Same as above, but only dumps a single operation, and compute its
 332    --  indentation from the program.
 333
 334    ---------
 335    -- "=" --
 336    ---------
 337
 338    function "=" (Left : Character; Right : Opcode) return Boolean is
 339    begin
 340       return Character'Pos (Left) = Opcode'Pos (Right);
 341    end "=";
 342
 343    --------------------
 344    -- Bitmap_Operand --
 345    --------------------
 346
 347    procedure Bitmap_Operand
 348      (Program : Program_Data;
 349       P       : Pointer;
 350       Op      : out Character_Class)
 351    is
 352       function Convert is new Ada.Unchecked_Conversion
 353         (Program_Data, Character_Class);
 354
 355    begin
 356       Op (0 .. 31) := Convert (Program (P + Next_Pointer_Bytes .. P + 34));
 357    end Bitmap_Operand;
 358
 359    -------------
 360    -- Compile --
 361    -------------
 362
 363    procedure Compile
 364      (Matcher         : out Pattern_Matcher;
 365       Expression      : String;
 366       Final_Code_Size : out Program_Size;
 367       Flags           : Regexp_Flags := No_Flags)
 368    is
 369       --  We can't allocate space until we know how big the compiled form
 370       --  will be, but we can't compile it (and thus know how big it is)
 371       --  until we've got a place to put the code. So we cheat: we compile
 372       --  it twice, once with code generation turned off and size counting
 373       --  turned on, and once "for real".
 374
 375       --  This also means that we don't allocate space until we are sure
 376       --  that the thing really will compile successfully, and we never
 377       --  have to move the code and thus invalidate pointers into it.
 378
 379       --  Beware that the optimization-preparation code in here knows
 380       --  about some of the structure of the compiled regexp.
 381
 382       PM        : Pattern_Matcher renames Matcher;
 383       Program   : Program_Data renames PM.Program;
 384
 385       Emit_Ptr  : Pointer := Program_First;
 386
 387       Parse_Pos : Natural := Expression'First; -- Input-scan pointer
 388       Parse_End : constant Natural := Expression'Last;
 389
 390       ----------------------------
 391       -- Subprograms for Create --
 392       ----------------------------
 393
 394       procedure Emit (B : Character);
 395       --  Output the Character B to the Program. If code-generation is
 396       --  disabled, simply increments the program counter.
 397
 398       function  Emit_Node (Op : Opcode) return Pointer;
 399       --  If code-generation is enabled, Emit_Node outputs the
 400       --  opcode Op and reserves space for a pointer to the next node.
 401       --  Return value is the location of new opcode, i.e. old Emit_Ptr.
 402
 403       procedure Emit_Natural (IP : Pointer; N : Natural);
 404       --  Split N on two characters at position IP
 405
 406       procedure Emit_Class (Bitmap : Character_Class);
 407       --  Emits a character class
 408
 409       procedure Case_Emit (C : Character);
 410       --  Emit C, after converting is to lower-case if the regular
 411       --  expression is case insensitive.
 412
 413       procedure Parse
 414         (Parenthesized : Boolean;
 415          Flags         : out Expression_Flags;
 416          IP            : out Pointer);
 417       --  Parse regular expression, i.e. main body or parenthesized thing
 418       --  Caller must absorb opening parenthesis.
 419
 420       procedure Parse_Branch
 421         (Flags         : out Expression_Flags;
 422          First         : Boolean;
 423          IP            : out Pointer);
 424       --  Implements the concatenation operator and handles '|'
 425       --  First should be true if this is the first item of the alternative.
 426
 427       procedure Parse_Piece
 428         (Expr_Flags : out Expression_Flags;
 429          IP         : out Pointer);
 430       --  Parse something followed by possible [*+?]
 431
 432       procedure Parse_Atom
 433         (Expr_Flags : out Expression_Flags;
 434          IP         : out Pointer);
 435       --  Parse_Atom is the lowest level parse procedure.
 436       --
 437       --  Optimization: Gobbles an entire sequence of ordinary characters so
 438       --  that it can turn them into a single node, which is smaller to store
 439       --  and faster to run. Backslashed characters are exceptions, each
 440       --  becoming a separate node; the code is simpler that way and it's
 441       --  not worth fixing.
 442
 443       procedure Insert_Operator
 444         (Op       : Opcode;
 445          Operand  : Pointer;
 446          Greedy   : Boolean := True);
 447       --  Insert_Operator inserts an operator in front of an already-emitted
 448       --  operand and relocates the operand. This applies to PLUS and STAR.
 449       --  If Minmod is True, then the operator is non-greedy.
 450
 451       function Insert_Operator_Before
 452         (Op      : Opcode;
 453          Operand : Pointer;
 454          Greedy  : Boolean;
 455          Opsize  : Pointer) return Pointer;
 456       --  Insert an operator before Operand (and move the latter forward in the
 457       --  program). Opsize is the size needed to represent the operator. This
 458       --  returns the position at which the operator was inserted, and moves
 459       --  Emit_Ptr after the new position of the operand.
 460
 461       procedure Insert_Curly_Operator
 462         (Op      : Opcode;
 463          Min     : Natural;
 464          Max     : Natural;
 465          Operand : Pointer;
 466          Greedy  : Boolean := True);
 467       --  Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}).
 468       --  If Minmod is True, then the operator is non-greedy.
 469
 470       procedure Link_Tail (P, Val : Pointer);
 471       --  Link_Tail sets the next-pointer at the end of a node chain
 472
 473       procedure Link_Operand_Tail (P, Val : Pointer);
 474       --  Link_Tail on operand of first argument; noop if operand-less
 475
 476       procedure Fail (M : String);
 477       pragma No_Return (Fail);
 478       --  Fail with a diagnostic message, if possible
 479
 480       function Is_Curly_Operator (IP : Natural) return Boolean;
 481       --  Return True if IP is looking at a '{' that is the beginning
 482       --  of a curly operator, i.e. it matches {\d+,?\d*}
 483
 484       function Is_Mult (IP : Natural) return Boolean;
 485       --  Return True if C is a regexp multiplier: '+', '*' or '?'
 486
 487       procedure Get_Curly_Arguments
 488         (IP     : Natural;
 489          Min    : out Natural;
 490          Max    : out Natural;
 491          Greedy : out Boolean);
 492       --  Parse the argument list for a curly operator.
 493       --  It is assumed that IP is indeed pointing at a valid operator.
 494       --  So what is IP and how come IP is not referenced in the body ???
 495
 496       procedure Parse_Character_Class (IP : out Pointer);
 497       --  Parse a character class.
 498       --  The calling subprogram should consume the opening '[' before.
 499
 500       procedure Parse_Literal
 501         (Expr_Flags : out Expression_Flags;
 502          IP         : out Pointer);
 503       --  Parse_Literal encodes a string of characters to be matched exactly
 504
 505       function Parse_Posix_Character_Class return Std_Class;
 506       --  Parse a posix character class, like [:alpha:] or [:^alpha:].
 507       --  The caller is supposed to absorb the opening [.
 508
 509       pragma Inline (Is_Mult);
 510       pragma Inline (Emit_Natural);
 511       pragma Inline (Parse_Character_Class); --  since used only once
 512
 513       ---------------
 514       -- Case_Emit --
 515       ---------------
 516
 517       procedure Case_Emit (C : Character) is
 518       begin
 519          if (Flags and Case_Insensitive) /= 0 then
 520             Emit (To_Lower (C));
 521
 522          else
 523             --  Dump current character
 524
 525             Emit (C);
 526          end if;
 527       end Case_Emit;
 528
 529       ----------
 530       -- Emit --
 531       ----------
 532
 533       procedure Emit (B : Character) is
 534       begin
 535          if Emit_Ptr <= PM.Size then
 536             Program (Emit_Ptr) := B;
 537          end if;
 538
 539          Emit_Ptr := Emit_Ptr + 1;
 540       end Emit;
 541
 542       ----------------
 543       -- Emit_Class --
 544       ----------------
 545
 546       procedure Emit_Class (Bitmap : Character_Class) is
 547          subtype Program31 is Program_Data (0 .. 31);
 548
 549          function Convert is new Ada.Unchecked_Conversion
 550            (Character_Class, Program31);
 551
 552       begin
 553          --  What is the mysterious constant 31 here??? Can't it be expressed
 554          --  symbolically (size of integer - 1 or some such???). In any case
 555          --  it should be declared as a constant (and referenced presumably
 556          --  as this constant + 1 below.
 557
 558          if Emit_Ptr + 31 <= PM.Size then
 559             Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap);
 560          end if;
 561
 562          Emit_Ptr := Emit_Ptr + 32;
 563       end Emit_Class;
 564
 565       ------------------
 566       -- Emit_Natural --
 567       ------------------
 568
 569       procedure Emit_Natural (IP : Pointer; N : Natural) is
 570       begin
 571          if IP + 1 <= PM.Size then
 572             Program (IP + 1) := Character'Val (N / 256);
 573             Program (IP) := Character'Val (N mod 256);
 574          end if;
 575       end Emit_Natural;
 576
 577       ---------------
 578       -- Emit_Node --
 579       ---------------
 580
 581       function Emit_Node (Op : Opcode) return Pointer is
 582          Result : constant Pointer := Emit_Ptr;
 583
 584       begin
 585          if Emit_Ptr + 2 <= PM.Size then
 586             Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op));
 587             Program (Emit_Ptr + 1) := ASCII.NUL;
 588             Program (Emit_Ptr + 2) := ASCII.NUL;
 589          end if;
 590
 591          Emit_Ptr := Emit_Ptr + Next_Pointer_Bytes;
 592          return Result;
 593       end Emit_Node;
 594
 595       ----------
 596       -- Fail --
 597       ----------
 598
 599       procedure Fail (M : String) is
 600       begin
 601          raise Expression_Error with M;
 602       end Fail;
 603
 604       -------------------------
 605       -- Get_Curly_Arguments --
 606       -------------------------
 607
 608       procedure Get_Curly_Arguments
 609         (IP     : Natural;
 610          Min    : out Natural;
 611          Max    : out Natural;
 612          Greedy : out Boolean)
 613       is
 614          pragma Unreferenced (IP);
 615
 616          Save_Pos : Natural := Parse_Pos + 1;
 617
 618       begin
 619          Min := 0;
 620          Max := Max_Curly_Repeat;
 621
 622          while Expression (Parse_Pos) /= '}'
 623            and then Expression (Parse_Pos) /= ','
 624          loop
 625             Parse_Pos := Parse_Pos + 1;
 626          end loop;
 627
 628          Min := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1));
 629
 630          if Expression (Parse_Pos) = ',' then
 631             Save_Pos := Parse_Pos + 1;
 632             while Expression (Parse_Pos) /= '}' loop
 633                Parse_Pos := Parse_Pos + 1;
 634             end loop;
 635
 636             if Save_Pos /= Parse_Pos then
 637                Max := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1));
 638             end if;
 639
 640          else
 641             Max := Min;
 642          end if;
 643
 644          if Parse_Pos < Expression'Last
 645            and then Expression (Parse_Pos + 1) = '?'
 646          then
 647             Greedy := False;
 648             Parse_Pos := Parse_Pos + 1;
 649
 650          else
 651             Greedy := True;
 652          end if;
 653       end Get_Curly_Arguments;
 654
 655       ---------------------------
 656       -- Insert_Curly_Operator --
 657       ---------------------------
 658
 659       procedure Insert_Curly_Operator
 660         (Op      : Opcode;
 661          Min     : Natural;
 662          Max     : Natural;
 663          Operand : Pointer;
 664          Greedy  : Boolean := True)
 665       is
 666          Old    : Pointer;
 667       begin
 668          Old := Insert_Operator_Before (Op, Operand, Greedy, Opsize => 7);
 669          Emit_Natural (Old + Next_Pointer_Bytes, Min);
 670          Emit_Natural (Old + Next_Pointer_Bytes + 2, Max);
 671       end Insert_Curly_Operator;
 672
 673       ----------------------------
 674       -- Insert_Operator_Before --
 675       ----------------------------
 676
 677       function Insert_Operator_Before
 678         (Op      : Opcode;
 679          Operand : Pointer;
 680          Greedy  : Boolean;
 681          Opsize  : Pointer) return Pointer
 682       is
 683          Dest : constant Pointer := Emit_Ptr;
 684          Old  : Pointer;
 685          Size : Pointer := Opsize;
 686
 687       begin
 688          --  If not greedy, we have to emit another opcode first
 689
 690          if not Greedy then
 691             Size := Size + Next_Pointer_Bytes;
 692          end if;
 693
 694          --  Move the operand in the byte-compilation, so that we can insert
 695          --  the operator before it.
 696
 697          if Emit_Ptr + Size <= PM.Size then
 698             Program (Operand + Size .. Emit_Ptr + Size) :=
 699               Program (Operand .. Emit_Ptr);
 700          end if;
 701
 702          --  Insert the operator at the position previously occupied by the
 703          --  operand.
 704
 705          Emit_Ptr := Operand;
 706
 707          if not Greedy then
 708             Old := Emit_Node (MINMOD);
 709             Link_Tail (Old, Old + Next_Pointer_Bytes);
 710          end if;
 711
 712          Old := Emit_Node (Op);
 713          Emit_Ptr := Dest + Size;
 714          return Old;
 715       end Insert_Operator_Before;
 716
 717       ---------------------
 718       -- Insert_Operator --
 719       ---------------------
 720
 721       procedure Insert_Operator
 722         (Op      : Opcode;
 723          Operand : Pointer;
 724          Greedy  : Boolean := True)
 725       is
 726          Discard : Pointer;
 727          pragma Warnings (Off, Discard);
 728       begin
 729          Discard := Insert_Operator_Before
 730             (Op, Operand, Greedy, Opsize => Next_Pointer_Bytes);
 731       end Insert_Operator;
 732
 733       -----------------------
 734       -- Is_Curly_Operator --
 735       -----------------------
 736
 737       function Is_Curly_Operator (IP : Natural) return Boolean is
 738          Scan : Natural := IP;
 739
 740       begin
 741          if Expression (Scan) /= '{'
 742            or else Scan + 2 > Expression'Last
 743            or else not Is_Digit (Expression (Scan + 1))
 744          then
 745             return False;
 746          end if;
 747
 748          Scan := Scan + 1;
 749
 750          --  The first digit
 751
 752          loop
 753             Scan := Scan + 1;
 754
 755             if Scan > Expression'Last then
 756                return False;
 757             end if;
 758
 759             exit when not Is_Digit (Expression (Scan));
 760          end loop;
 761
 762          if Expression (Scan) = ',' then
 763             loop
 764                Scan := Scan + 1;
 765
 766                if Scan > Expression'Last then
 767                   return False;
 768                end if;
 769
 770                exit when not Is_Digit (Expression (Scan));
 771             end loop;
 772          end if;
 773
 774          return Expression (Scan) = '}';
 775       end Is_Curly_Operator;
 776
 777       -------------
 778       -- Is_Mult --
 779       -------------
 780
 781       function Is_Mult (IP : Natural) return Boolean is
 782          C : constant Character := Expression (IP);
 783
 784       begin
 785          return     C = '*'
 786            or else  C = '+'
 787            or else  C = '?'
 788            or else (C = '{' and then Is_Curly_Operator (IP));
 789       end Is_Mult;
 790
 791       -----------------------
 792       -- Link_Operand_Tail --
 793       -----------------------
 794
 795       procedure Link_Operand_Tail (P, Val : Pointer) is
 796       begin
 797          if P <= PM.Size and then Program (P) = BRANCH then
 798             Link_Tail (Operand (P), Val);
 799          end if;
 800       end Link_Operand_Tail;
 801
 802       ---------------
 803       -- Link_Tail --
 804       ---------------
 805
 806       procedure Link_Tail (P, Val : Pointer) is
 807          Scan   : Pointer;
 808          Temp   : Pointer;
 809          Offset : Pointer;
 810
 811       begin
 812          --  Find last node (the size of the pattern matcher might be too
 813          --  small, so don't try to read past its end).
 814
 815          Scan := P;
 816          while Scan + Next_Pointer_Bytes <= PM.Size loop
 817             Temp := Get_Next (Program, Scan);
 818             exit when Temp = Scan;
 819             Scan := Temp;
 820          end loop;
 821
 822          Offset := Val - Scan;
 823
 824          Emit_Natural (Scan + 1, Natural (Offset));
 825       end Link_Tail;
 826
 827       -----------
 828       -- Parse --
 829       -----------
 830
 831       --  Combining parenthesis handling with the base level of regular
 832       --  expression is a trifle forced, but the need to tie the tails of the
 833       --  the branches to what follows makes it hard to avoid.
 834
 835       procedure Parse
 836          (Parenthesized  : Boolean;
 837           Flags          : out Expression_Flags;
 838           IP             : out Pointer)
 839       is
 840          E           : String renames Expression;
 841          Br, Br2     : Pointer;
 842          Ender       : Pointer;
 843          Par_No      : Natural;
 844          New_Flags   : Expression_Flags;
 845          Have_Branch : Boolean := False;
 846
 847       begin
 848          Flags := (Has_Width => True, others => False);  -- Tentatively
 849
 850          --  Make an OPEN node, if parenthesized
 851
 852          if Parenthesized then
 853             if Matcher.Paren_Count > Max_Paren_Count then
 854                Fail ("too many ()");
 855             end if;
 856
 857             Par_No := Matcher.Paren_Count + 1;
 858             Matcher.Paren_Count := Matcher.Paren_Count + 1;
 859             IP := Emit_Node (OPEN);
 860             Emit (Character'Val (Par_No));
 861
 862          else
 863             IP := 0;
 864             Par_No := 0;
 865          end if;
 866
 867          --  Pick up the branches, linking them together
 868
 869          Parse_Branch (New_Flags, True, Br);
 870
 871          if Br = 0 then
 872             IP := 0;
 873             return;
 874          end if;
 875
 876          if Parse_Pos <= Parse_End
 877            and then E (Parse_Pos) = '|'
 878          then
 879             Insert_Operator (BRANCH, Br);
 880             Have_Branch := True;
 881          end if;
 882
 883          if IP /= 0 then
 884             Link_Tail (IP, Br);   -- OPEN -> first
 885          else
 886             IP := Br;
 887          end if;
 888
 889          if not New_Flags.Has_Width then
 890             Flags.Has_Width := False;
 891          end if;
 892
 893          Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start;
 894
 895          while Parse_Pos <= Parse_End
 896            and then (E (Parse_Pos) = '|')
 897          loop
 898             Parse_Pos := Parse_Pos + 1;
 899             Parse_Branch (New_Flags, False, Br);
 900
 901             if Br = 0 then
 902                IP := 0;
 903                return;
 904             end if;
 905
 906             Link_Tail (IP, Br);   -- BRANCH -> BRANCH
 907
 908             if not New_Flags.Has_Width then
 909                Flags.Has_Width := False;
 910             end if;
 911
 912             Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start;
 913          end loop;
 914
 915          --  Make a closing node, and hook it on the end
 916
 917          if Parenthesized then
 918             Ender := Emit_Node (CLOSE);
 919             Emit (Character'Val (Par_No));
 920          else
 921             Ender := Emit_Node (EOP);
 922          end if;
 923
 924          Link_Tail (IP, Ender);
 925
 926          if Have_Branch and then Emit_Ptr <= PM.Size then
 927
 928             --  Hook the tails of the branches to the closing node
 929
 930             Br := IP;
 931             loop
 932                Link_Operand_Tail (Br, Ender);
 933                Br2 := Get_Next (Program, Br);
 934                exit when Br2 = Br;
 935                Br := Br2;
 936             end loop;
 937          end if;
 938
 939          --  Check for proper termination
 940
 941          if Parenthesized then
 942             if Parse_Pos > Parse_End or else E (Parse_Pos) /= ')' then
 943                Fail ("unmatched ()");
 944             end if;
 945
 946             Parse_Pos := Parse_Pos + 1;
 947
 948          elsif Parse_Pos <= Parse_End then
 949             if E (Parse_Pos) = ')'  then
 950                Fail ("unmatched ()");
 951             else
 952                Fail ("junk on end");         -- "Can't happen"
 953             end if;
 954          end if;
 955       end Parse;
 956
 957       ----------------
 958       -- Parse_Atom --
 959       ----------------
 960
 961       procedure Parse_Atom
 962         (Expr_Flags : out Expression_Flags;
 963          IP         : out Pointer)
 964       is
 965          C : Character;
 966
 967       begin
 968          --  Tentatively set worst expression case
 969
 970          Expr_Flags := Worst_Expression;
 971
 972          C := Expression (Parse_Pos);
 973          Parse_Pos := Parse_Pos + 1;
 974
 975          case (C) is
 976             when '^' =>
 977                IP :=
 978                  Emit_Node
 979                    (if (Flags and Multiple_Lines) /= 0 then MBOL
 980                     elsif (Flags and Single_Line) /= 0 then SBOL
 981                     else BOL);
 982
 983             when '$' =>
 984                IP :=
 985                  Emit_Node
 986                    (if (Flags and Multiple_Lines) /= 0 then MEOL
 987                     elsif (Flags and Single_Line) /= 0 then SEOL
 988                     else EOL);
 989
 990             when '.' =>
 991                IP :=
 992                  Emit_Node
 993                    (if (Flags and Single_Line) /= 0 then SANY else ANY);
 994
 995                Expr_Flags.Has_Width := True;
 996                Expr_Flags.Simple := True;
 997
 998             when '[' =>
 999                Parse_Character_Class (IP);
1000                Expr_Flags.Has_Width := True;
1001                Expr_Flags.Simple := True;
1002
1003             when '(' =>
1004                declare
1005                   New_Flags : Expression_Flags;
1006
1007                begin
1008                   Parse (True, New_Flags, IP);
1009
1010                   if IP = 0 then
1011                      return;
1012                   end if;
1013
1014                   Expr_Flags.Has_Width :=
1015                     Expr_Flags.Has_Width or else New_Flags.Has_Width;
1016                   Expr_Flags.SP_Start :=
1017                     Expr_Flags.SP_Start or else New_Flags.SP_Start;
1018                end;
1019
1020             when '|' | ASCII.LF | ')' =>
1021                Fail ("internal urp");  --  Supposed to be caught earlier
1022
1023             when '?' | '+' | '*' =>
1024                Fail (C & " follows nothing");
1025
1026             when '{' =>
1027                if Is_Curly_Operator (Parse_Pos - 1) then
1028                   Fail (C & " follows nothing");
1029                else
1030                   Parse_Literal (Expr_Flags, IP);
1031                end if;
1032
1033             when '\' =>
1034                if Parse_Pos > Parse_End then
1035                   Fail ("trailing \");
1036                end if;
1037
1038                Parse_Pos := Parse_Pos + 1;
1039
1040                case Expression (Parse_Pos - 1) is
1041                   when 'b'        =>
1042                      IP := Emit_Node (BOUND);
1043
1044                   when 'B'        =>
1045                      IP := Emit_Node (NBOUND);
1046
1047                   when 's'        =>
1048                      IP := Emit_Node (SPACE);
1049                      Expr_Flags.Simple := True;
1050                      Expr_Flags.Has_Width := True;
1051
1052                   when 'S'        =>
1053                      IP := Emit_Node (NSPACE);
1054                      Expr_Flags.Simple := True;
1055                      Expr_Flags.Has_Width := True;
1056
1057                   when 'd'        =>
1058                      IP := Emit_Node (DIGIT);
1059                      Expr_Flags.Simple := True;
1060                      Expr_Flags.Has_Width := True;
1061
1062                   when 'D'        =>
1063                      IP := Emit_Node (NDIGIT);
1064                      Expr_Flags.Simple := True;
1065                      Expr_Flags.Has_Width := True;
1066
1067                   when 'w'        =>
1068                      IP := Emit_Node (ALNUM);
1069                      Expr_Flags.Simple := True;
1070                      Expr_Flags.Has_Width := True;
1071
1072                   when 'W'        =>
1073                      IP := Emit_Node (NALNUM);
1074                      Expr_Flags.Simple := True;
1075                      Expr_Flags.Has_Width := True;
1076
1077                   when 'A'        =>
1078                      IP := Emit_Node (SBOL);
1079
1080                   when 'G'        =>
1081                      IP := Emit_Node (SEOL);
1082
1083                   when '0' .. '9' =>
1084                      IP := Emit_Node (REFF);
1085
1086                      declare
1087                         Save : constant Natural := Parse_Pos - 1;
1088
1089                      begin
1090                         while Parse_Pos <= Expression'Last
1091                           and then Is_Digit (Expression (Parse_Pos))
1092                         loop
1093                            Parse_Pos := Parse_Pos + 1;
1094                         end loop;
1095
1096                         Emit (Character'Val (Natural'Value
1097                                (Expression (Save .. Parse_Pos - 1))));
1098                      end;
1099
1100                   when others =>
1101                      Parse_Pos := Parse_Pos - 1;
1102                      Parse_Literal (Expr_Flags, IP);
1103                end case;
1104
1105             when others =>
1106                Parse_Literal (Expr_Flags, IP);
1107          end case;
1108       end Parse_Atom;
1109
1110       ------------------
1111       -- Parse_Branch --
1112       ------------------
1113
1114       procedure Parse_Branch
1115         (Flags : out Expression_Flags;
1116          First : Boolean;
1117          IP    : out Pointer)
1118       is
1119          E         : String renames Expression;
1120          Chain     : Pointer;
1121          Last      : Pointer;
1122          New_Flags : Expression_Flags;
1123
1124          Discard : Pointer;
1125          pragma Warnings (Off, Discard);
1126
1127       begin
1128          Flags := Worst_Expression;    -- Tentatively
1129          IP := (if First then Emit_Ptr else Emit_Node (BRANCH));
1130
1131          Chain := 0;
1132          while Parse_Pos <= Parse_End
1133            and then E (Parse_Pos) /= ')'
1134            and then E (Parse_Pos) /= ASCII.LF
1135            and then E (Parse_Pos) /= '|'
1136          loop
1137             Parse_Piece (New_Flags, Last);
1138
1139             if Last = 0 then
1140                IP := 0;
1141                return;
1142             end if;
1143
1144             Flags.Has_Width := Flags.Has_Width or else New_Flags.Has_Width;
1145
1146             if Chain = 0 then            -- First piece
1147                Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start;
1148             else
1149                Link_Tail (Chain, Last);
1150             end if;
1151
1152             Chain := Last;
1153          end loop;
1154
1155          --  Case where loop ran zero CURLY
1156
1157          if Chain = 0 then
1158             Discard := Emit_Node (NOTHING);
1159          end if;
1160       end Parse_Branch;
1161
1162       ---------------------------
1163       -- Parse_Character_Class --
1164       ---------------------------
1165
1166       procedure Parse_Character_Class (IP : out Pointer) is
1167          Bitmap      : Character_Class;
1168          Invert      : Boolean := False;
1169          In_Range    : Boolean := False;
1170          Named_Class : Std_Class := ANYOF_NONE;
1171          Value       : Character;
1172          Last_Value  : Character := ASCII.NUL;
1173
1174       begin
1175          Reset_Class (Bitmap);
1176
1177          --  Do we have an invert character class ?
1178
1179          if Parse_Pos <= Parse_End
1180            and then Expression (Parse_Pos) = '^'
1181          then
1182             Invert := True;
1183             Parse_Pos := Parse_Pos + 1;
1184          end if;
1185
1186          --  First character can be ] or - without closing the class
1187
1188          if Parse_Pos <= Parse_End
1189            and then (Expression (Parse_Pos) = ']'
1190                       or else Expression (Parse_Pos) = '-')
1191          then
1192             Set_In_Class (Bitmap, Expression (Parse_Pos));
1193             Parse_Pos := Parse_Pos + 1;
1194          end if;
1195
1196          --  While we don't have the end of the class
1197
1198          while Parse_Pos <= Parse_End
1199            and then Expression (Parse_Pos) /= ']'
1200          loop
1201             Named_Class := ANYOF_NONE;
1202             Value := Expression (Parse_Pos);
1203             Parse_Pos := Parse_Pos + 1;
1204
1205             --  Do we have a Posix character class
1206             if Value = '[' then
1207                Named_Class := Parse_Posix_Character_Class;
1208
1209             elsif Value = '\' then
1210                if Parse_Pos = Parse_End then
1211                   Fail ("Trailing \");
1212                end if;
1213                Value := Expression (Parse_Pos);
1214                Parse_Pos := Parse_Pos + 1;
1215
1216                case Value is
1217                   when 'w' => Named_Class := ANYOF_ALNUM;
1218                   when 'W' => Named_Class := ANYOF_NALNUM;
1219                   when 's' => Named_Class := ANYOF_SPACE;
1220                   when 'S' => Named_Class := ANYOF_NSPACE;
1221                   when 'd' => Named_Class := ANYOF_DIGIT;
1222                   when 'D' => Named_Class := ANYOF_NDIGIT;
1223                   when 'n' => Value := ASCII.LF;
1224                   when 'r' => Value := ASCII.CR;
1225                   when 't' => Value := ASCII.HT;
1226                   when 'f' => Value := ASCII.FF;
1227                   when 'e' => Value := ASCII.ESC;
1228                   when 'a' => Value := ASCII.BEL;
1229
1230                   --  when 'x'  => ??? hexadecimal value
1231                   --  when 'c'  => ??? control character
1232                   --  when '0'..'9' => ??? octal character
1233
1234                   when others => null;
1235                end case;
1236             end if;
1237
1238             --  Do we have a character class?
1239
1240             if Named_Class /= ANYOF_NONE then
1241
1242                --  A range like 'a-\d' or 'a-[:digit:] is not a range
1243
1244                if In_Range then
1245                   Set_In_Class (Bitmap, Last_Value);
1246                   Set_In_Class (Bitmap, '-');
1247                   In_Range := False;
1248                end if;
1249
1250                --  Expand the range
1251
1252                case Named_Class is
1253                   when ANYOF_NONE => null;
1254
1255                   when ANYOF_ALNUM | ANYOF_ALNUMC =>
1256                      for Value in Class_Byte'Range loop
1257                         if Is_Alnum (Character'Val (Value)) then
1258                            Set_In_Class (Bitmap, Character'Val (Value));
1259                         end if;
1260                      end loop;
1261
1262                   when ANYOF_NALNUM | ANYOF_NALNUMC =>
1263                      for Value in Class_Byte'Range loop
1264                         if not Is_Alnum (Character'Val (Value)) then
1265                            Set_In_Class (Bitmap, Character'Val (Value));
1266                         end if;
1267                      end loop;
1268
1269                   when ANYOF_SPACE =>
1270                      for Value in Class_Byte'Range loop
1271                         if Is_White_Space (Character'Val (Value)) then
1272                            Set_In_Class (Bitmap, Character'Val (Value));
1273                         end if;
1274                      end loop;
1275
1276                   when ANYOF_NSPACE =>
1277                      for Value in Class_Byte'Range loop
1278                         if not Is_White_Space (Character'Val (Value)) then
1279                            Set_In_Class (Bitmap, Character'Val (Value));
1280                         end if;
1281                      end loop;
1282
1283                   when ANYOF_DIGIT =>
1284                      for Value in Class_Byte'Range loop
1285                         if Is_Digit (Character'Val (Value)) then
1286                            Set_In_Class (Bitmap, Character'Val (Value));
1287                         end if;
1288                      end loop;
1289
1290                   when ANYOF_NDIGIT =>
1291                      for Value in Class_Byte'Range loop
1292                         if not Is_Digit (Character'Val (Value)) then
1293                            Set_In_Class (Bitmap, Character'Val (Value));
1294                         end if;
1295                      end loop;
1296
1297                   when ANYOF_ALPHA =>
1298                      for Value in Class_Byte'Range loop
1299                         if Is_Letter (Character'Val (Value)) then
1300                            Set_In_Class (Bitmap, Character'Val (Value));
1301                         end if;
1302                      end loop;
1303
1304                   when ANYOF_NALPHA =>
1305                      for Value in Class_Byte'Range loop
1306                         if not Is_Letter (Character'Val (Value)) then
1307                            Set_In_Class (Bitmap, Character'Val (Value));
1308                         end if;
1309                      end loop;
1310
1311                   when ANYOF_ASCII =>
1312                      for Value in 0 .. 127 loop
1313                         Set_In_Class (Bitmap, Character'Val (Value));
1314                      end loop;
1315
1316                   when ANYOF_NASCII =>
1317                      for Value in 128 .. 255 loop
1318                         Set_In_Class (Bitmap, Character'Val (Value));
1319                      end loop;
1320
1321                   when ANYOF_CNTRL =>
1322                      for Value in Class_Byte'Range loop
1323                         if Is_Control (Character'Val (Value)) then
1324                            Set_In_Class (Bitmap, Character'Val (Value));
1325                         end if;
1326                      end loop;
1327
1328                   when ANYOF_NCNTRL =>
1329                      for Value in Class_Byte'Range loop
1330                         if not Is_Control (Character'Val (Value)) then
1331                            Set_In_Class (Bitmap, Character'Val (Value));
1332                         end if;
1333                      end loop;
1334
1335                   when ANYOF_GRAPH =>
1336                      for Value in Class_Byte'Range loop
1337                         if Is_Graphic (Character'Val (Value)) then
1338                            Set_In_Class (Bitmap, Character'Val (Value));
1339                         end if;
1340                      end loop;
1341
1342                   when ANYOF_NGRAPH =>
1343                      for Value in Class_Byte'Range loop
1344                         if not Is_Graphic (Character'Val (Value)) then
1345                            Set_In_Class (Bitmap, Character'Val (Value));
1346                         end if;
1347                      end loop;
1348
1349                   when ANYOF_LOWER =>
1350                      for Value in Class_Byte'Range loop
1351                         if Is_Lower (Character'Val (Value)) then
1352                            Set_In_Class (Bitmap, Character'Val (Value));
1353                         end if;
1354                      end loop;
1355
1356                   when ANYOF_NLOWER =>
1357                      for Value in Class_Byte'Range loop
1358                         if not Is_Lower (Character'Val (Value)) then
1359                            Set_In_Class (Bitmap, Character'Val (Value));
1360                         end if;
1361                      end loop;
1362
1363                   when ANYOF_PRINT =>
1364                      for Value in Class_Byte'Range loop
1365                         if Is_Printable (Character'Val (Value)) then
1366                            Set_In_Class (Bitmap, Character'Val (Value));
1367                         end if;
1368                      end loop;
1369
1370                   when ANYOF_NPRINT =>
1371                      for Value in Class_Byte'Range loop
1372                         if not Is_Printable (Character'Val (Value)) then
1373                            Set_In_Class (Bitmap, Character'Val (Value));
1374                         end if;
1375                      end loop;
1376
1377                   when ANYOF_PUNCT =>
1378                      for Value in Class_Byte'Range loop
1379                         if Is_Printable (Character'Val (Value))
1380                           and then not Is_White_Space (Character'Val (Value))
1381                           and then not Is_Alnum (Character'Val (Value))
1382                         then
1383                            Set_In_Class (Bitmap, Character'Val (Value));
1384                         end if;
1385                      end loop;
1386
1387                   when ANYOF_NPUNCT =>
1388                      for Value in Class_Byte'Range loop
1389                         if not Is_Printable (Character'Val (Value))
1390                           or else Is_White_Space (Character'Val (Value))
1391                           or else Is_Alnum (Character'Val (Value))
1392                         then
1393                            Set_In_Class (Bitmap, Character'Val (Value));
1394                         end if;
1395                      end loop;
1396
1397                   when ANYOF_UPPER =>
1398                      for Value in Class_Byte'Range loop
1399                         if Is_Upper (Character'Val (Value)) then
1400                            Set_In_Class (Bitmap, Character'Val (Value));
1401                         end if;
1402                      end loop;
1403
1404                   when ANYOF_NUPPER =>
1405                      for Value in Class_Byte'Range loop
1406                         if not Is_Upper (Character'Val (Value)) then
1407                            Set_In_Class (Bitmap, Character'Val (Value));
1408                         end if;
1409                      end loop;
1410
1411                   when ANYOF_XDIGIT =>
1412                      for Value in Class_Byte'Range loop
1413                         if Is_Hexadecimal_Digit (Character'Val (Value)) then
1414                            Set_In_Class (Bitmap, Character'Val (Value));
1415                         end if;
1416                      end loop;
1417
1418                   when ANYOF_NXDIGIT =>
1419                      for Value in Class_Byte'Range loop
1420                         if not Is_Hexadecimal_Digit
1421                           (Character'Val (Value))
1422                         then
1423                            Set_In_Class (Bitmap, Character'Val (Value));
1424                         end if;
1425                      end loop;
1426
1427                end case;
1428
1429             --  Not a character range
1430
1431             elsif not In_Range then
1432                Last_Value := Value;
1433
1434                if Parse_Pos > Expression'Last then
1435                   Fail ("Empty character class []");
1436                end if;
1437
1438                if Expression (Parse_Pos) = '-'
1439                  and then Parse_Pos < Parse_End
1440                  and then Expression (Parse_Pos + 1) /= ']'
1441                then
1442                   Parse_Pos := Parse_Pos + 1;
1443
1444                   --  Do we have a range like '\d-a' and '[:space:]-a'
1445                   --  which is not a real range
1446
1447                   if Named_Class /= ANYOF_NONE then
1448                      Set_In_Class (Bitmap, '-');
1449                   else
1450                      In_Range := True;
1451                   end if;
1452
1453                else
1454                   Set_In_Class (Bitmap, Value);
1455
1456                end if;
1457
1458             --  Else in a character range
1459
1460             else
1461                if Last_Value > Value then
1462                   Fail ("Invalid Range [" & Last_Value'Img
1463                         & "-" & Value'Img & "]");
1464                end if;
1465
1466                while Last_Value <= Value loop
1467                   Set_In_Class (Bitmap, Last_Value);
1468                   Last_Value := Character'Succ (Last_Value);
1469                end loop;
1470
1471                In_Range := False;
1472
1473             end if;
1474
1475          end loop;
1476
1477          --  Optimize case-insensitive ranges (put the upper case or lower
1478          --  case character into the bitmap)
1479
1480          if (Flags and Case_Insensitive) /= 0 then
1481             for C in Character'Range loop
1482                if Get_From_Class (Bitmap, C) then
1483                   Set_In_Class (Bitmap, To_Lower (C));
1484                   Set_In_Class (Bitmap, To_Upper (C));
1485                end if;
1486             end loop;
1487          end if;
1488
1489          --  Optimize inverted classes
1490
1491          if Invert then
1492             for J in Bitmap'Range loop
1493                Bitmap (J) := not Bitmap (J);
1494             end loop;
1495          end if;
1496
1497          Parse_Pos := Parse_Pos + 1;
1498
1499          --  Emit the class
1500
1501          IP := Emit_Node (ANYOF);
1502          Emit_Class (Bitmap);
1503       end Parse_Character_Class;
1504
1505       -------------------
1506       -- Parse_Literal --
1507       -------------------
1508
1509       --  This is a bit tricky due to quoted chars and due to
1510       --  the multiplier characters '*', '+', and '?' that
1511       --  take the SINGLE char previous as their operand.
1512
1513       --  On entry, the character at Parse_Pos - 1 is going to go
1514       --  into the string, no matter what it is. It could be
1515       --  following a \ if Parse_Atom was entered from the '\' case.
1516
1517       --  Basic idea is to pick up a good char in C and examine
1518       --  the next char. If Is_Mult (C) then twiddle, if it's a \
1519       --  then frozzle and if it's another magic char then push C and
1520       --  terminate the string. If none of the above, push C on the
1521       --  string and go around again.
1522
1523       --  Start_Pos is used to remember where "the current character"
1524       --  starts in the string, if due to an Is_Mult we need to back
1525       --  up and put the current char in a separate 1-character string.
1526       --  When Start_Pos is 0, C is the only char in the string;
1527       --  this is used in Is_Mult handling, and in setting the SIMPLE
1528       --  flag at the end.
1529
1530       procedure Parse_Literal
1531         (Expr_Flags : out Expression_Flags;
1532          IP         : out Pointer)
1533       is
1534          Start_Pos  : Natural := 0;
1535          C          : Character;
1536          Length_Ptr : Pointer;
1537
1538          Has_Special_Operator : Boolean := False;
1539
1540       begin
1541          Parse_Pos := Parse_Pos - 1;      --  Look at current character
1542
1543          IP :=
1544            Emit_Node
1545              (if (Flags and Case_Insensitive) /= 0 then EXACTF else EXACT);
1546
1547          Length_Ptr := Emit_Ptr;
1548          Emit_Ptr := String_Operand (IP);
1549
1550          Parse_Loop :
1551          loop
1552             C := Expression (Parse_Pos); --  Get current character
1553
1554             case C is
1555                when '.' | '[' | '(' | ')' | '|' | ASCII.LF | '$' | '^' =>
1556
1557                   if Start_Pos = 0 then
1558                      Start_Pos := Parse_Pos;
1559                      Emit (C);         --  First character is always emitted
1560                   else
1561                      exit Parse_Loop;  --  Else we are done
1562                   end if;
1563
1564                when '?' | '+' | '*' | '{' =>
1565
1566                   if Start_Pos = 0 then
1567                      Start_Pos := Parse_Pos;
1568                      Emit (C);         --  First character is always emitted
1569
1570                   --  Are we looking at an operator, or is this
1571                   --  simply a normal character ?
1572
1573                   elsif not Is_Mult (Parse_Pos) then
1574                      Start_Pos := Parse_Pos;
1575                      Case_Emit (C);
1576
1577                   else
1578                      --  We've got something like "abc?d".  Mark this as a
1579                      --  special case. What we want to emit is a first
1580                      --  constant string for "ab", then one for "c" that will
1581                      --  ultimately be transformed with a CURLY operator, A
1582                      --  special case has to be handled for "a?", since there
1583                      --  is no initial string to emit.
1584
1585                      Has_Special_Operator := True;
1586                      exit Parse_Loop;
1587                   end if;
1588
1589                when '\' =>
1590                   Start_Pos := Parse_Pos;
1591
1592                   if Parse_Pos = Parse_End then
1593                      Fail ("Trailing \");
1594
1595                   else
1596                      case Expression (Parse_Pos + 1) is
1597                         when 'b' | 'B' | 's' | 'S' | 'd' | 'D'
1598                           | 'w' | 'W' | '0' .. '9' | 'G' | 'A'
1599                           => exit Parse_Loop;
1600                         when 'n'         => Emit (ASCII.LF);
1601                         when 't'         => Emit (ASCII.HT);
1602                         when 'r'         => Emit (ASCII.CR);
1603                         when 'f'         => Emit (ASCII.FF);
1604                         when 'e'         => Emit (ASCII.ESC);
1605                         when 'a'         => Emit (ASCII.BEL);
1606                         when others      => Emit (Expression (Parse_Pos + 1));
1607                      end case;
1608
1609                      Parse_Pos := Parse_Pos + 1;
1610                   end if;
1611
1612                when others =>
1613                   Start_Pos := Parse_Pos;
1614                   Case_Emit (C);
1615             end case;
1616
1617             exit Parse_Loop when Emit_Ptr - Length_Ptr = 254;
1618
1619             Parse_Pos := Parse_Pos + 1;
1620
1621             exit Parse_Loop when Parse_Pos > Parse_End;
1622          end loop Parse_Loop;
1623
1624          --  Is the string followed by a '*+?{' operator ? If yes, and if there
1625          --  is an initial string to emit, do it now.
1626
1627          if Has_Special_Operator
1628            and then Emit_Ptr >= Length_Ptr + Next_Pointer_Bytes
1629          then
1630             Emit_Ptr := Emit_Ptr - 1;
1631             Parse_Pos := Start_Pos;
1632          end if;
1633
1634          if Length_Ptr <= PM.Size then
1635             Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2);
1636          end if;
1637
1638          Expr_Flags.Has_Width := True;
1639
1640          --  Slight optimization when there is a single character
1641
1642          if Emit_Ptr = Length_Ptr + 2 then
1643             Expr_Flags.Simple := True;
1644          end if;
1645       end Parse_Literal;
1646
1647       -----------------
1648       -- Parse_Piece --
1649       -----------------
1650
1651       --  Note that the branching code sequences used for '?' and the
1652       --  general cases of '*' and + are somewhat optimized: they use
1653       --  the same NOTHING node as both the endmarker for their branch
1654       --  list and the body of the last branch. It might seem that
1655       --  this node could be dispensed with entirely, but the endmarker
1656       --  role is not redundant.
1657
1658       procedure Parse_Piece
1659         (Expr_Flags : out Expression_Flags;
1660          IP         : out Pointer)
1661       is
1662          Op        : Character;
1663          New_Flags : Expression_Flags;
1664          Greedy    : Boolean := True;
1665
1666       begin
1667          Parse_Atom (New_Flags, IP);
1668
1669          if IP = 0 then
1670             return;
1671          end if;
1672
1673          if Parse_Pos > Parse_End
1674            or else not Is_Mult (Parse_Pos)
1675          then
1676             Expr_Flags := New_Flags;
1677             return;
1678          end if;
1679
1680          Op := Expression (Parse_Pos);
1681
1682          Expr_Flags :=
1683            (if Op /= '+'
1684             then (SP_Start  => True, others => False)
1685             else (Has_Width => True, others => False));
1686
1687          --  Detect non greedy operators in the easy cases
1688
1689          if Op /= '{'
1690            and then Parse_Pos + 1 <= Parse_End
1691            and then Expression (Parse_Pos + 1) = '?'
1692          then
1693             Greedy := False;
1694             Parse_Pos := Parse_Pos + 1;
1695          end if;
1696
1697          --  Generate the byte code
1698
1699          case Op is
1700             when '*' =>
1701
1702                if New_Flags.Simple then
1703                   Insert_Operator (STAR, IP, Greedy);
1704                else
1705                   Link_Tail (IP, Emit_Node (WHILEM));
1706                   Insert_Curly_Operator
1707                     (CURLYX, 0, Max_Curly_Repeat, IP, Greedy);
1708                   Link_Tail (IP, Emit_Node (NOTHING));
1709                end if;
1710
1711             when '+' =>
1712
1713                if New_Flags.Simple then
1714                   Insert_Operator (PLUS, IP, Greedy);
1715                else
1716                   Link_Tail (IP, Emit_Node (WHILEM));
1717                   Insert_Curly_Operator
1718                     (CURLYX, 1, Max_Curly_Repeat, IP, Greedy);
1719                   Link_Tail (IP, Emit_Node (NOTHING));
1720                end if;
1721
1722             when '?' =>
1723                if New_Flags.Simple then
1724                   Insert_Curly_Operator (CURLY, 0, 1, IP, Greedy);
1725                else
1726                   Link_Tail (IP, Emit_Node (WHILEM));
1727                   Insert_Curly_Operator (CURLYX, 0, 1, IP, Greedy);
1728                   Link_Tail (IP, Emit_Node (NOTHING));
1729                end if;
1730
1731             when '{' =>
1732                declare
1733                   Min, Max : Natural;
1734
1735                begin
1736                   Get_Curly_Arguments (Parse_Pos, Min, Max, Greedy);
1737
1738                   if New_Flags.Simple then
1739                      Insert_Curly_Operator (CURLY, Min, Max, IP, Greedy);
1740                   else
1741                      Link_Tail (IP, Emit_Node (WHILEM));
1742                      Insert_Curly_Operator (CURLYX, Min, Max, IP, Greedy);
1743                      Link_Tail (IP, Emit_Node (NOTHING));
1744                   end if;
1745                end;
1746
1747             when others =>
1748                null;
1749          end case;
1750
1751          Parse_Pos := Parse_Pos + 1;
1752
1753          if Parse_Pos <= Parse_End
1754            and then Is_Mult (Parse_Pos)
1755          then
1756             Fail ("nested *+{");
1757          end if;
1758       end Parse_Piece;
1759
1760       ---------------------------------
1761       -- Parse_Posix_Character_Class --
1762       ---------------------------------
1763
1764       function Parse_Posix_Character_Class return Std_Class is
1765          Invert : Boolean := False;
1766          Class  : Std_Class := ANYOF_NONE;
1767          E      : String renames Expression;
1768
1769          --  Class names. Note that code assumes that the length of all
1770          --  classes starting with the same letter have the same length.
1771
1772          Alnum   : constant String := "alnum:]";
1773          Alpha   : constant String := "alpha:]";
1774          Ascii_C : constant String := "ascii:]";
1775          Cntrl   : constant String := "cntrl:]";
1776          Digit   : constant String := "digit:]";
1777          Graph   : constant String := "graph:]";
1778          Lower   : constant String := "lower:]";
1779          Print   : constant String := "print:]";
1780          Punct   : constant String := "punct:]";
1781          Space   : constant String := "space:]";
1782          Upper   : constant String := "upper:]";
1783          Word    : constant String := "word:]";
1784          Xdigit  : constant String := "xdigit:]";
1785
1786       begin
1787          --  Case of character class specified
1788
1789          if Parse_Pos <= Parse_End
1790            and then Expression (Parse_Pos) = ':'
1791          then
1792             Parse_Pos := Parse_Pos + 1;
1793
1794             --  Do we have something like:  [[:^alpha:]]
1795
1796             if Parse_Pos <= Parse_End
1797               and then Expression (Parse_Pos) = '^'
1798             then
1799                Invert := True;
1800                Parse_Pos := Parse_Pos + 1;
1801             end if;
1802
1803             --  Check for class names based on first letter
1804
1805             case Expression (Parse_Pos) is
1806                when 'a' =>
1807
1808                   --  All 'a' classes have the same length (Alnum'Length)
1809
1810                   if Parse_Pos + Alnum'Length - 1 <= Parse_End then
1811                      if
1812                        E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) = Alnum
1813                      then
1814                         Class :=
1815                           (if Invert then ANYOF_NALNUMC else ANYOF_ALNUMC);
1816                         Parse_Pos := Parse_Pos + Alnum'Length;
1817
1818                      elsif
1819                        E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) = Alpha
1820                      then
1821                         Class :=
1822                           (if Invert then ANYOF_NALPHA else ANYOF_ALPHA);
1823                         Parse_Pos := Parse_Pos + Alpha'Length;
1824
1825                      elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) =
1826                                                                       Ascii_C
1827                      then
1828                         Class :=
1829                           (if Invert then ANYOF_NASCII else ANYOF_ASCII);
1830                         Parse_Pos := Parse_Pos + Ascii_C'Length;
1831                      else
1832                         Fail ("Invalid character class: " & E);
1833                      end if;
1834
1835                   else
1836                      Fail ("Invalid character class: " & E);
1837                   end if;
1838
1839                when 'c' =>
1840                   if Parse_Pos + Cntrl'Length - 1 <= Parse_End
1841                     and then
1842                       E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) = Cntrl
1843                   then
1844                      Class := (if Invert then ANYOF_NCNTRL else ANYOF_CNTRL);
1845                      Parse_Pos := Parse_Pos + Cntrl'Length;
1846                   else
1847                      Fail ("Invalid character class: " & E);
1848                   end if;
1849
1850                when 'd' =>
1851                   if Parse_Pos + Digit'Length - 1 <= Parse_End
1852                     and then
1853                       E (Parse_Pos .. Parse_Pos + Digit'Length - 1) = Digit
1854                   then
1855                      Class := (if Invert then ANYOF_NDIGIT else ANYOF_DIGIT);
1856                      Parse_Pos := Parse_Pos + Digit'Length;
1857                   end if;
1858
1859                when 'g' =>
1860                   if Parse_Pos + Graph'Length - 1 <= Parse_End
1861                     and then
1862                       E (Parse_Pos .. Parse_Pos + Graph'Length - 1) = Graph
1863                   then
1864                      Class := (if Invert then ANYOF_NGRAPH else ANYOF_GRAPH);
1865                      Parse_Pos := Parse_Pos + Graph'Length;
1866                   else
1867                      Fail ("Invalid character class: " & E);
1868                   end if;
1869
1870                when 'l' =>
1871                   if Parse_Pos + Lower'Length - 1 <= Parse_End
1872                     and then
1873                       E (Parse_Pos .. Parse_Pos + Lower'Length - 1) = Lower
1874                   then
1875                      Class := (if Invert then ANYOF_NLOWER else ANYOF_LOWER);
1876                      Parse_Pos := Parse_Pos + Lower'Length;
1877                   else
1878                      Fail ("Invalid character class: " & E);
1879                   end if;
1880
1881                when 'p' =>
1882
1883                   --  All 'p' classes have the same length
1884
1885                   if Parse_Pos + Print'Length - 1 <= Parse_End then
1886                      if
1887                        E (Parse_Pos .. Parse_Pos + Print'Length - 1) = Print
1888                      then
1889                         Class :=
1890                           (if Invert then ANYOF_NPRINT else ANYOF_PRINT);
1891                         Parse_Pos := Parse_Pos + Print'Length;
1892
1893                      elsif
1894                        E (Parse_Pos .. Parse_Pos + Punct'Length - 1) = Punct
1895                      then
1896                         Class :=
1897                           (if Invert then ANYOF_NPUNCT else ANYOF_PUNCT);
1898                         Parse_Pos := Parse_Pos + Punct'Length;
1899
1900                      else
1901                         Fail ("Invalid character class: " & E);
1902                      end if;
1903
1904                   else
1905                      Fail ("Invalid character class: " & E);
1906                   end if;
1907
1908                when 's' =>
1909                   if Parse_Pos + Space'Length - 1 <= Parse_End
1910                     and then
1911                       E (Parse_Pos .. Parse_Pos + Space'Length - 1) = Space
1912                   then
1913                      Class := (if Invert then ANYOF_NSPACE else ANYOF_SPACE);
1914                      Parse_Pos := Parse_Pos + Space'Length;
1915                   else
1916                      Fail ("Invalid character class: " & E);
1917                   end if;
1918
1919                when 'u' =>
1920                   if Parse_Pos + Upper'Length - 1 <= Parse_End
1921                     and then
1922                       E (Parse_Pos .. Parse_Pos + Upper'Length - 1) = Upper
1923                   then
1924                      Class := (if Invert then ANYOF_NUPPER else ANYOF_UPPER);
1925                      Parse_Pos := Parse_Pos + Upper'Length;
1926                   else
1927                      Fail ("Invalid character class: " & E);
1928                   end if;
1929
1930                when 'w' =>
1931                   if Parse_Pos + Word'Length - 1 <= Parse_End
1932                     and then
1933                       E (Parse_Pos .. Parse_Pos + Word'Length - 1) = Word
1934                   then
1935                      Class := (if Invert then ANYOF_NALNUM else ANYOF_ALNUM);
1936                      Parse_Pos := Parse_Pos + Word'Length;
1937                   else
1938                      Fail ("Invalid character class: " & E);
1939                   end if;
1940
1941                when 'x' =>
1942                   if Parse_Pos + Xdigit'Length - 1 <= Parse_End
1943                     and then
1944                       E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1) = Xdigit
1945                   then
1946                      Class := (if Invert then ANYOF_NXDIGIT else ANYOF_XDIGIT);
1947                      Parse_Pos := Parse_Pos + Xdigit'Length;
1948
1949                   else
1950                      Fail ("Invalid character class: " & E);
1951                   end if;
1952
1953                when others =>
1954                   Fail ("Invalid character class: " & E);
1955             end case;
1956
1957          --  Character class not specified
1958
1959          else
1960             return ANYOF_NONE;
1961          end if;
1962
1963          return Class;
1964       end Parse_Posix_Character_Class;
1965
1966       --  Local Declarations
1967
1968       Result : Pointer;
1969
1970       Expr_Flags : Expression_Flags;
1971       pragma Unreferenced (Expr_Flags);
1972
1973    --  Start of processing for Compile
1974
1975    begin
1976       Parse (False, Expr_Flags, Result);
1977
1978       if Result = 0 then
1979          Fail ("Couldn't compile expression");
1980       end if;
1981
1982       Final_Code_Size := Emit_Ptr - 1;
1983
1984       --  Do we want to actually compile the expression, or simply get the
1985       --  code size ???
1986
1987       if Emit_Ptr <= PM.Size then
1988          Optimize (PM);
1989       end if;
1990
1991       PM.Flags := Flags;
1992    end Compile;
1993
1994    function Compile
1995      (Expression : String;
1996       Flags      : Regexp_Flags := No_Flags) return Pattern_Matcher
1997    is
1998       --  Assume the compiled regexp will fit in 1000 chars. If it does not we
1999       --  will have to compile a second time once the correct size is known. If
2000       --  it fits, we save a significant amount of time by avoiding the second
2001       --  compilation.
2002
2003       Dummy : Pattern_Matcher (1000);
2004       Size  : Program_Size;
2005
2006    begin
2007       Compile (Dummy, Expression, Size, Flags);
2008
2009       if Size <= Dummy.Size then
2010          return Pattern_Matcher'
2011            (Size             => Size,
2012             First            => Dummy.First,
2013             Anchored         => Dummy.Anchored,
2014             Must_Have        => Dummy.Must_Have,
2015             Must_Have_Length => Dummy.Must_Have_Length,
2016             Paren_Count      => Dummy.Paren_Count,
2017             Flags            => Dummy.Flags,
2018             Program          => Dummy.Program
2019               (Dummy.Program'First .. Dummy.Program'First + Size - 1));
2020       else
2021          --  We have to recompile now that we know the size
2022          --  ??? Can we use Ada05's return construct ?
2023          declare
2024             Result : Pattern_Matcher (Size);
2025          begin
2026             Compile (Result, Expression, Size, Flags);
2027             return Result;
2028          end;
2029       end if;
2030    end Compile;
2031
2032    procedure Compile
2033      (Matcher    : out Pattern_Matcher;
2034       Expression : String;
2035       Flags      : Regexp_Flags := No_Flags)
2036    is
2037       Size : Program_Size;
2038
2039    begin
2040       Compile (Matcher, Expression, Size, Flags);
2041
2042       if Size > Matcher.Size then
2043          raise Expression_Error with "Pattern_Matcher is too small";
2044       end if;
2045    end Compile;
2046
2047    --------------------
2048    -- Dump_Operation --
2049    --------------------
2050
2051    procedure Dump_Operation
2052       (Program : Program_Data;
2053        Index   : Pointer;
2054        Indent  : Natural)
2055    is
2056       Current : Pointer := Index;
2057    begin
2058       Dump_Until (Program, Current, Current + 1, Indent);
2059    end Dump_Operation;
2060
2061    ----------------
2062    -- Dump_Until --
2063    ----------------
2064
2065    procedure Dump_Until
2066       (Program  : Program_Data;
2067        Index    : in out Pointer;
2068        Till     : Pointer;
2069        Indent   : Natural;
2070        Do_Print : Boolean := True)
2071    is
2072       function Image (S : String) return String;
2073       --  Remove leading space
2074
2075       -----------
2076       -- Image --
2077       -----------
2078
2079       function Image (S : String) return String is
2080       begin
2081          if S (S'First) = ' ' then
2082             return S (S'First + 1 .. S'Last);
2083          else
2084             return S;
2085          end if;
2086       end Image;
2087
2088       --  Local variables
2089
2090       Op           : Opcode;
2091       Next         : Pointer;
2092       Length       : Pointer;
2093       Local_Indent : Natural := Indent;
2094
2095    --  Start of processing for Dump_Until
2096
2097    begin
2098       while Index < Till loop
2099          Op   := Opcode'Val (Character'Pos ((Program (Index))));
2100          Next := Get_Next (Program, Index);
2101
2102          if Do_Print then
2103             declare
2104                Point   : constant String := Pointer'Image (Index);
2105             begin
2106                Put ((1 .. 4 - Point'Length => ' ')
2107                     & Point & ":"
2108                     & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op));
2109             end;
2110
2111             --  Print the parenthesis number
2112
2113             if Op = OPEN or else Op = CLOSE or else Op = REFF then
2114                Put (Image (Natural'Image
2115                             (Character'Pos
2116                                (Program (Index + Next_Pointer_Bytes)))));
2117             end if;
2118
2119             if Next = Index then
2120                Put (" (-)");
2121             else
2122                Put (" (" & Image (Pointer'Image (Next)) & ")");
2123             end if;
2124          end if;
2125
2126          case Op is
2127             when ANYOF =>
2128                declare
2129                   Bitmap       : Character_Class;
2130                   Last         : Character := ASCII.NUL;
2131                   Current      : Natural := 0;
2132                   Current_Char : Character;
2133
2134                begin
2135                   Bitmap_Operand (Program, Index, Bitmap);
2136
2137                   if Do_Print then
2138                      Put ("[");
2139
2140                      while Current <= 255 loop
2141                         Current_Char := Character'Val (Current);
2142
2143                         --  First item in a range
2144
2145                         if Get_From_Class (Bitmap, Current_Char) then
2146                            Last := Current_Char;
2147
2148                            --  Search for the last item in the range
2149
2150                            loop
2151                               Current := Current + 1;
2152                               exit when Current > 255;
2153                               Current_Char := Character'Val (Current);
2154                               exit when
2155                                 not Get_From_Class (Bitmap, Current_Char);
2156                            end loop;
2157
2158                            if not Is_Graphic (Last) then
2159                               Put (Last'Img);
2160                            else
2161                               Put (Last);
2162                            end if;
2163
2164                            if Character'Succ (Last) /= Current_Char then
2165                               Put ("\-" & Character'Pred (Current_Char));
2166                            end if;
2167
2168                         else
2169                            Current := Current + 1;
2170                         end if;
2171                      end loop;
2172
2173                      Put_Line ("]");
2174                   end if;
2175
2176                   Index := Index + Next_Pointer_Bytes + Bitmap'Length;
2177                end;
2178
2179             when EXACT | EXACTF =>
2180                Length := String_Length (Program, Index);
2181                if Do_Print then
2182                   Put (" (" & Image (Program_Size'Image (Length + 1))
2183                           & " chars) <"
2184                           & String (Program (String_Operand (Index)
2185                                               .. String_Operand (Index)
2186                                               + Length)));
2187                   Put_Line (">");
2188                end if;
2189
2190                Index := String_Operand (Index) + Length + 1;
2191
2192                --  Node operand
2193
2194             when BRANCH | STAR | PLUS =>
2195                if Do_Print then
2196                   New_Line;
2197                end if;
2198
2199                Index  := Index + Next_Pointer_Bytes;
2200                Dump_Until (Program, Index, Pointer'Min (Next, Till),
2201                            Local_Indent + 1, Do_Print);
2202
2203             when CURLY | CURLYX =>
2204                if Do_Print then
2205                   Put_Line
2206                     (" {"
2207                     & Image (Natural'Image
2208                        (Read_Natural (Program, Index + Next_Pointer_Bytes)))
2209                     & ","
2210                     & Image (Natural'Image (Read_Natural (Program, Index + 5)))
2211                     & "}");
2212                end if;
2213
2214                Index  := Index + 7;
2215                Dump_Until (Program, Index, Pointer'Min (Next, Till),
2216                            Local_Indent + 1, Do_Print);
2217
2218             when OPEN =>
2219                if Do_Print then
2220                   New_Line;
2221                end if;
2222
2223                Index := Index + 4;
2224                Local_Indent := Local_Indent + 1;
2225
2226             when CLOSE | REFF =>
2227                if Do_Print then
2228                   New_Line;
2229                end if;
2230
2231                Index := Index + 4;
2232
2233                if Op = CLOSE then
2234                   Local_Indent := Local_Indent - 1;
2235                end if;
2236
2237             when others =>
2238                Index := Index + Next_Pointer_Bytes;
2239
2240                if Do_Print then
2241                   New_Line;
2242                end if;
2243
2244                exit when Op = EOP;
2245          end case;
2246       end loop;
2247    end Dump_Until;
2248
2249    ----------
2250    -- Dump --
2251    ----------
2252
2253    procedure Dump (Self : Pattern_Matcher) is
2254       Program : Program_Data renames Self.Program;
2255       Index   : Pointer := Program'First;
2256
2257    --  Start of processing for Dump
2258
2259    begin
2260       Put_Line ("Must start with (Self.First) = "
2261                 & Character'Image (Self.First));
2262
2263       if (Self.Flags and Case_Insensitive) /= 0 then
2264          Put_Line ("  Case_Insensitive mode");
2265       end if;
2266
2267       if (Self.Flags and Single_Line) /= 0 then
2268          Put_Line ("  Single_Line mode");
2269       end if;
2270
2271       if (Self.Flags and Multiple_Lines) /= 0 then
2272          Put_Line ("  Multiple_Lines mode");
2273       end if;
2274
2275       Dump_Until (Program, Index, Self.Program'Last + 1, 0);
2276    end Dump;
2277
2278    --------------------
2279    -- Get_From_Class --
2280    --------------------
2281
2282    function Get_From_Class
2283      (Bitmap : Character_Class;
2284       C      : Character) return Boolean
2285    is
2286       Value : constant Class_Byte := Character'Pos (C);
2287    begin
2288       return
2289         (Bitmap (Value / 8) and Bit_Conversion (Value mod 8)) /= 0;
2290    end Get_From_Class;
2291
2292    --------------
2293    -- Get_Next --
2294    --------------
2295
2296    function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is
2297    begin
2298       return IP + Pointer (Read_Natural (Program, IP + 1));
2299    end Get_Next;
2300
2301    --------------
2302    -- Is_Alnum --
2303    --------------
2304
2305    function Is_Alnum (C : Character) return Boolean is
2306    begin
2307       return Is_Alphanumeric (C) or else C = '_';
2308    end Is_Alnum;
2309
2310    ------------------
2311    -- Is_Printable --
2312    ------------------
2313
2314    function Is_Printable (C : Character) return Boolean is
2315    begin
2316       --  Printable if space or graphic character or other whitespace
2317       --  Other white space includes (HT/LF/VT/FF/CR = codes 9-13)
2318
2319       return C in Character'Val (32) .. Character'Val (126)
2320         or else C in ASCII.HT .. ASCII.CR;
2321    end Is_Printable;
2322
2323    --------------------
2324    -- Is_White_Space --
2325    --------------------
2326
2327    function Is_White_Space (C : Character) return Boolean is
2328    begin
2329       --  Note: HT = 9, LF = 10, VT = 11, FF = 12, CR = 13
2330
2331       return C = ' ' or else C in ASCII.HT .. ASCII.CR;
2332    end Is_White_Space;
2333
2334    -----------
2335    -- Match --
2336    -----------
2337
2338    procedure Match
2339      (Self       : Pattern_Matcher;
2340       Data       : String;
2341       Matches    : out Match_Array;
2342       Data_First : Integer := -1;
2343       Data_Last  : Positive := Positive'Last)
2344    is
2345       Program : Program_Data renames Self.Program; -- Shorter notation
2346
2347       First_In_Data : constant Integer := Integer'Max (Data_First, Data'First);
2348       Last_In_Data  : constant Integer := Integer'Min (Data_Last, Data'Last);
2349
2350       --  Global work variables
2351
2352       Input_Pos : Natural;           -- String-input pointer
2353       BOL_Pos   : Natural;           -- Beginning of input, for ^ check
2354       Matched   : Boolean := False;  -- Until proven True
2355
2356       Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count,
2357                                                     Matches'Last));
2358       --  Stores the value of all the parenthesis pairs.
2359       --  We do not use directly Matches, so that we can also use back
2360       --  references (REFF) even if Matches is too small.
2361
2362       type Natural_Array is array (Match_Count range <>) of Natural;
2363       Matches_Tmp : Natural_Array (Matches_Full'Range);
2364       --  Save the opening position of parenthesis
2365
2366       Last_Paren  : Natural := 0;
2367       --  Last parenthesis seen
2368
2369       Greedy : Boolean := True;
2370       --  True if the next operator should be greedy
2371
2372       type Current_Curly_Record;
2373       type Current_Curly_Access is access all Current_Curly_Record;
2374       type Current_Curly_Record is record
2375          Paren_Floor : Natural;  --  How far back to strip parenthesis data
2376          Cur         : Integer;  --  How many instances of scan we've matched
2377          Min         : Natural;  --  Minimal number of scans to match
2378          Max         : Natural;  --  Maximal number of scans to match
2379          Greedy      : Boolean;  --  Whether to work our way up or down
2380          Scan        : Pointer;  --  The thing to match
2381          Next        : Pointer;  --  What has to match after it
2382          Lastloc     : Natural;  --  Where we started matching this scan
2383          Old_Cc      : Current_Curly_Access; --  Before we started this one
2384       end record;
2385       --  Data used to handle the curly operator and the plus and star
2386       --  operators for complex expressions.
2387
2388       Current_Curly : Current_Curly_Access := null;
2389       --  The curly currently being processed
2390
2391       -----------------------
2392       -- Local Subprograms --
2393       -----------------------
2394
2395       function Index (Start : Positive; C : Character) return Natural;
2396       --  Find character C in Data starting at Start and return position
2397
2398       function Repeat
2399         (IP  : Pointer;
2400          Max : Natural := Natural'Last) return Natural;
2401       --  Repeatedly match something simple, report how many
2402       --  It only matches on things of length 1.
2403       --  Starting from Input_Pos, it matches at most Max CURLY.
2404
2405       function Try (Pos : Positive) return Boolean;
2406       --  Try to match at specific point
2407
2408       function Match (IP : Pointer) return Boolean;
2409       --  This is the main matching routine. Conceptually the strategy
2410       --  is simple:  check to see whether the current node matches,
2411       --  call self recursively to see whether the rest matches,
2412       --  and then act accordingly.
2413       --
2414       --  In practice Match makes some effort to avoid recursion, in
2415       --  particular by going through "ordinary" nodes (that don't
2416       --  need to know whether the rest of the match failed) by
2417       --  using a loop instead of recursion.
2418       --  Why is the above comment part of the spec rather than body ???
2419
2420       function Match_Whilem return Boolean;
2421       --  Return True if a WHILEM matches the Current_Curly
2422
2423       function Recurse_Match (IP : Pointer; From : Natural) return Boolean;
2424       pragma Inline (Recurse_Match);
2425       --  Calls Match recursively. It saves and restores the parenthesis
2426       --  status and location in the input stream correctly, so that
2427       --  backtracking is possible
2428
2429       function Match_Simple_Operator
2430         (Op     : Opcode;
2431          Scan   : Pointer;
2432          Next   : Pointer;
2433          Greedy : Boolean) return Boolean;
2434       --  Return True it the simple operator (possibly non-greedy) matches
2435
2436       Dump_Indent : Integer := -1;
2437       procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True);
2438       procedure Dump_Error (Msg : String);
2439       --  Debug: print the current context
2440
2441       pragma Inline (Index);
2442       pragma Inline (Repeat);
2443
2444       --  These are two complex functions, but used only once
2445
2446       pragma Inline (Match_Whilem);
2447       pragma Inline (Match_Simple_Operator);
2448
2449       -----------
2450       -- Index --
2451       -----------
2452
2453       function Index (Start : Positive; C : Character) return Natural is
2454       begin
2455          for J in Start .. Last_In_Data loop
2456             if Data (J) = C then
2457                return J;
2458             end if;
2459          end loop;
2460
2461          return 0;
2462       end Index;
2463
2464       -------------------
2465       -- Recurse_Match --
2466       -------------------
2467
2468       function Recurse_Match (IP : Pointer; From : Natural) return Boolean is
2469          L     : constant Natural := Last_Paren;
2470          Tmp_F : constant Match_Array :=
2471                    Matches_Full (From + 1 .. Matches_Full'Last);
2472          Start : constant Natural_Array :=
2473                    Matches_Tmp (From + 1 .. Matches_Tmp'Last);
2474          Input : constant Natural := Input_Pos;
2475
2476          Dump_Indent_Save : constant Integer := Dump_Indent;
2477
2478       begin
2479          if Match (IP) then
2480             return True;
2481          end if;
2482
2483          Last_Paren := L;
2484          Matches_Full (Tmp_F'Range) := Tmp_F;
2485          Matches_Tmp (Start'Range) := Start;
2486          Input_Pos := Input;
2487          Dump_Indent := Dump_Indent_Save;
2488          return False;
2489       end Recurse_Match;
2490
2491       ------------------
2492       -- Dump_Current --
2493       ------------------
2494
2495       procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is
2496          Length : constant := 10;
2497          Pos    : constant String := Integer'Image (Input_Pos);
2498
2499       begin
2500          if Prefix then
2501             Put ((1 .. 5 - Pos'Length => ' '));
2502             Put (Pos & " <"
2503                  & Data (Input_Pos
2504                      .. Integer'Min (Last_In_Data, Input_Pos + Length - 1)));
2505             Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' '));
2506             Put ("> |");
2507
2508          else
2509             Put ("                    ");
2510          end if;
2511
2512          Dump_Operation (Program, Scan, Indent => Dump_Indent);
2513       end Dump_Current;
2514
2515       ----------------
2516       -- Dump_Error --
2517       ----------------
2518
2519       procedure Dump_Error (Msg : String) is
2520       begin
2521          Put ("                   |     ");
2522          Put ((1 .. Dump_Indent * 2 => ' '));
2523          Put_Line (Msg);
2524       end Dump_Error;
2525
2526       -----------
2527       -- Match --
2528       -----------
2529
2530       function Match (IP : Pointer) return Boolean is
2531          Scan   : Pointer := IP;
2532          Next   : Pointer;
2533          Op     : Opcode;
2534          Result : Boolean;
2535
2536       begin
2537          Dump_Indent := Dump_Indent + 1;
2538
2539          State_Machine :
2540          loop
2541             pragma Assert (Scan /= 0);
2542
2543             --  Determine current opcode and count its usage in debug mode
2544
2545             Op := Opcode'Val (Character'Pos (Program (Scan)));
2546
2547             --  Calculate offset of next instruction. Second character is most
2548             --  significant in Program_Data.
2549
2550             Next := Get_Next (Program, Scan);
2551
2552             if Debug then
2553                Dump_Current (Scan);
2554             end if;
2555
2556             case Op is
2557                when EOP =>
2558                   Dump_Indent := Dump_Indent - 1;
2559                   return True;  --  Success !
2560
2561                when BRANCH =>
2562                   if Program (Next) /= BRANCH then
2563                      Next := Operand (Scan); -- No choice, avoid recursion
2564
2565                   else
2566                      loop
2567                         if Recurse_Match (Operand (Scan), 0) then
2568                            Dump_Indent := Dump_Indent - 1;
2569                            return True;
2570                         end if;
2571
2572                         Scan := Get_Next (Program, Scan);
2573                         exit when Scan = 0 or else Program (Scan) /= BRANCH;
2574                      end loop;
2575
2576                      exit State_Machine;
2577                   end if;
2578
2579                when NOTHING =>
2580                   null;
2581
2582                when BOL =>
2583                   exit State_Machine when Input_Pos /= BOL_Pos
2584                     and then ((Self.Flags and Multiple_Lines) = 0
2585                                or else Data (Input_Pos - 1) /= ASCII.LF);
2586
2587                when MBOL =>
2588                   exit State_Machine when Input_Pos /= BOL_Pos
2589                     and then Data (Input_Pos - 1) /= ASCII.LF;
2590
2591                when SBOL =>
2592                   exit State_Machine when Input_Pos /= BOL_Pos;
2593
2594                when EOL =>
2595                   exit State_Machine when Input_Pos <= Data'Last
2596                     and then ((Self.Flags and Multiple_Lines) = 0
2597                                or else Data (Input_Pos) /= ASCII.LF);
2598
2599                when MEOL =>
2600                   exit State_Machine when Input_Pos <= Data'Last
2601                     and then Data (Input_Pos) /= ASCII.LF;
2602
2603                when SEOL =>
2604                   exit State_Machine when Input_Pos <= Data'Last;
2605
2606                when BOUND | NBOUND =>
2607
2608                   --  Was last char in word ?
2609
2610                   declare
2611                      N  : Boolean := False;
2612                      Ln : Boolean := False;
2613
2614                   begin
2615                      if Input_Pos /= First_In_Data then
2616                         N := Is_Alnum (Data (Input_Pos - 1));
2617                      end if;
2618
2619                      Ln :=
2620                        (if Input_Pos > Last_In_Data
2621                         then False
2622                         else Is_Alnum (Data (Input_Pos)));
2623
2624                      if Op = BOUND then
2625                         if N = Ln then
2626                            exit State_Machine;
2627                         end if;
2628                      else
2629                         if N /= Ln then
2630                            exit State_Machine;
2631                         end if;
2632                      end if;
2633                   end;
2634
2635                when SPACE =>
2636                   exit State_Machine when Input_Pos > Last_In_Data
2637                     or else not Is_White_Space (Data (Input_Pos));
2638                   Input_Pos := Input_Pos + 1;
2639
2640                when NSPACE =>
2641                   exit State_Machine when Input_Pos > Last_In_Data
2642                     or else Is_White_Space (Data (Input_Pos));
2643                   Input_Pos := Input_Pos + 1;
2644
2645                when DIGIT =>
2646                   exit State_Machine when Input_Pos > Last_In_Data
2647                     or else not Is_Digit (Data (Input_Pos));
2648                   Input_Pos := Input_Pos + 1;
2649
2650                when NDIGIT =>
2651                   exit State_Machine when Input_Pos > Last_In_Data
2652                     or else Is_Digit (Data (Input_Pos));
2653                   Input_Pos := Input_Pos + 1;
2654
2655                when ALNUM =>
2656                   exit State_Machine when Input_Pos > Last_In_Data
2657                     or else not Is_Alnum (Data (Input_Pos));
2658                   Input_Pos := Input_Pos + 1;
2659
2660                when NALNUM =>
2661                   exit State_Machine when Input_Pos > Last_In_Data
2662                     or else Is_Alnum (Data (Input_Pos));
2663                   Input_Pos := Input_Pos + 1;
2664
2665                when ANY =>
2666                   exit State_Machine when Input_Pos > Last_In_Data
2667                     or else Data (Input_Pos) = ASCII.LF;
2668                   Input_Pos := Input_Pos + 1;
2669
2670                when SANY =>
2671                   exit State_Machine when Input_Pos > Last_In_Data;
2672                   Input_Pos := Input_Pos + 1;
2673
2674                when EXACT =>
2675                   declare
2676                      Opnd    : Pointer  := String_Operand (Scan);
2677                      Current : Positive := Input_Pos;
2678                      Last    : constant Pointer :=
2679                                  Opnd + String_Length (Program, Scan);
2680
2681                   begin
2682                      while Opnd <= Last loop
2683                         exit State_Machine when Current > Last_In_Data
2684                           or else Program (Opnd) /= Data (Current);
2685                         Current := Current + 1;
2686                         Opnd := Opnd + 1;
2687                      end loop;
2688
2689                      Input_Pos := Current;
2690                   end;
2691
2692                when EXACTF =>
2693                   declare
2694                      Opnd    : Pointer  := String_Operand (Scan);
2695                      Current : Positive := Input_Pos;
2696
2697                      Last : constant Pointer :=
2698                               Opnd + String_Length (Program, Scan);
2699
2700                   begin
2701                      while Opnd <= Last loop
2702                         exit State_Machine when Current > Last_In_Data
2703                           or else Program (Opnd) /= To_Lower (Data (Current));
2704                         Current := Current + 1;
2705                         Opnd := Opnd + 1;
2706                      end loop;
2707
2708                      Input_Pos := Current;
2709                   end;
2710
2711                when ANYOF =>
2712                   declare
2713                      Bitmap : Character_Class;
2714                   begin
2715                      Bitmap_Operand (Program, Scan, Bitmap);
2716                      exit State_Machine when Input_Pos > Last_In_Data
2717                        or else not Get_From_Class (Bitmap, Data (Input_Pos));
2718                      Input_Pos := Input_Pos + 1;
2719                   end;
2720
2721                when OPEN =>
2722                   declare
2723                      No : constant Natural :=
2724                             Character'Pos (Program (Operand (Scan)));
2725                   begin
2726                      Matches_Tmp (No) := Input_Pos;
2727                   end;
2728
2729                when CLOSE =>
2730                   declare
2731                      No : constant Natural :=
2732                             Character'Pos (Program (Operand (Scan)));
2733
2734                   begin
2735                      Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1);
2736
2737                      if Last_Paren < No then
2738                         Last_Paren := No;
2739                      end if;
2740                   end;
2741
2742                when REFF =>
2743                   declare
2744                      No : constant Natural :=
2745                             Character'Pos (Program (Operand (Scan)));
2746
2747                      Data_Pos : Natural;
2748
2749                   begin
2750                      --  If we haven't seen that parenthesis yet
2751
2752                      if Last_Paren < No then
2753                         Dump_Indent := Dump_Indent - 1;
2754
2755                         if Debug then
2756                            Dump_Error ("REFF: No match, backtracking");
2757                         end if;
2758
2759                         return False;
2760                      end if;
2761
2762                      Data_Pos := Matches_Full (No).First;
2763
2764                      while Data_Pos <= Matches_Full (No).Last loop
2765                         if Input_Pos > Last_In_Data
2766                           or else Data (Input_Pos) /= Data (Data_Pos)
2767                         then
2768                            Dump_Indent := Dump_Indent - 1;
2769
2770                            if Debug then
2771                               Dump_Error ("REFF: No match, backtracking");
2772                            end if;
2773
2774                            return False;
2775                         end if;
2776
2777                         Input_Pos := Input_Pos + 1;
2778                         Data_Pos := Data_Pos + 1;
2779                      end loop;
2780                   end;
2781
2782                when MINMOD =>
2783                   Greedy := False;
2784
2785                when STAR | PLUS | CURLY =>
2786                   declare
2787                      Greed : constant Boolean := Greedy;
2788                   begin
2789                      Greedy := True;
2790                      Result := Match_Simple_Operator (Op, Scan, Next, Greed);
2791                      Dump_Indent := Dump_Indent - 1;
2792                      return Result;
2793                   end;
2794
2795                when CURLYX =>
2796
2797                   --  Looking at something like:
2798
2799                   --    1: CURLYX {n,m}  (->4)
2800                   --    2:   code for complex thing  (->3)
2801                   --    3:   WHILEM (->0)
2802                   --    4: NOTHING
2803
2804                   declare
2805                      Min : constant Natural :=
2806                              Read_Natural (Program, Scan + Next_Pointer_Bytes);
2807                      Max : constant Natural :=
2808                              Read_Natural
2809                                 (Program, Scan + Next_Pointer_Bytes + 2);
2810                      Cc  : aliased Current_Curly_Record;
2811
2812                      Has_Match : Boolean;
2813
2814                   begin
2815                      Cc := (Paren_Floor => Last_Paren,
2816                             Cur         => -1,
2817                             Min         => Min,
2818                             Max         => Max,
2819                             Greedy      => Greedy,
2820                             Scan        => Scan + 7,
2821                             Next        => Next,
2822                             Lastloc     => 0,
2823                             Old_Cc      => Current_Curly);
2824                      Greedy := True;
2825                      Current_Curly := Cc'Unchecked_Access;
2826
2827                      Has_Match := Match (Next - Next_Pointer_Bytes);
2828
2829                      --  Start on the WHILEM
2830
2831                      Current_Curly := Cc.Old_Cc;
2832                      Dump_Indent := Dump_Indent - 1;
2833
2834                      if not Has_Match then
2835                         if Debug then
2836                            Dump_Error ("CURLYX failed...");
2837                         end if;
2838                      end if;
2839
2840                      return Has_Match;
2841                   end;
2842
2843                when WHILEM =>
2844                   Result := Match_Whilem;
2845                   Dump_Indent := Dump_Indent - 1;
2846
2847                   if Debug and then not Result then
2848                      Dump_Error ("WHILEM: no match, backtracking");
2849                   end if;
2850
2851                   return Result;
2852             end case;
2853
2854             Scan := Next;
2855          end loop State_Machine;
2856
2857          if Debug then
2858             Dump_Error ("failed...");
2859             Dump_Indent := Dump_Indent - 1;
2860          end if;
2861
2862          --  If we get here, there is no match. For successful matches when EOP
2863          --  is the terminating point.
2864
2865          return False;
2866       end Match;
2867
2868       ---------------------------
2869       -- Match_Simple_Operator --
2870       ---------------------------
2871
2872       function Match_Simple_Operator
2873         (Op     : Opcode;
2874          Scan   : Pointer;
2875          Next   : Pointer;
2876          Greedy : Boolean) return Boolean
2877       is
2878          Next_Char       : Character := ASCII.NUL;
2879          Next_Char_Known : Boolean := False;
2880          No              : Integer;  --  Can be negative
2881          Min             : Natural;
2882          Max             : Natural := Natural'Last;
2883          Operand_Code    : Pointer;
2884          Old             : Natural;
2885          Last_Pos        : Natural;
2886          Save            : constant Natural := Input_Pos;
2887
2888       begin
2889          --  Lookahead to avoid useless match attempts when we know what
2890          --  character comes next.
2891
2892          if Program (Next) = EXACT then
2893             Next_Char := Program (String_Operand (Next));
2894             Next_Char_Known := True;
2895          end if;
2896
2897          --  Find the minimal and maximal values for the operator
2898
2899          case Op is
2900             when STAR =>
2901                Min := 0;
2902                Operand_Code := Operand (Scan);
2903
2904             when PLUS =>
2905                Min := 1;
2906                Operand_Code := Operand (Scan);
2907
2908             when others =>
2909                Min := Read_Natural (Program, Scan + Next_Pointer_Bytes);
2910                Max := Read_Natural (Program, Scan + Next_Pointer_Bytes + 2);
2911                Operand_Code := Scan + 7;
2912          end case;
2913
2914          if Debug then
2915             Dump_Current (Operand_Code, Prefix => False);
2916          end if;
2917
2918          --  Non greedy operators
2919
2920          if not Greedy then
2921
2922             --  Test we can repeat at least Min times
2923
2924             if Min /= 0 then
2925                No := Repeat (Operand_Code, Min);
2926
2927                if No < Min then
2928                   if Debug then
2929                      Dump_Error ("failed... matched" & No'Img & " times");
2930                   end if;
2931
2932                   return False;
2933                end if;
2934             end if;
2935
2936             Old := Input_Pos;
2937
2938             --  Find the place where 'next' could work
2939
2940             if Next_Char_Known then
2941
2942                --  Last position to check
2943
2944                if Max = Natural'Last then
2945                   Last_Pos := Last_In_Data;
2946                else
2947                   Last_Pos := Input_Pos + Max;
2948
2949                   if Last_Pos > Last_In_Data then
2950                      Last_Pos := Last_In_Data;
2951                   end if;
2952                end if;
2953
2954                --  Look for the first possible opportunity
2955
2956                if Debug then
2957                   Dump_Error ("Next_Char must be " & Next_Char);
2958                end if;
2959
2960                loop
2961                   --  Find the next possible position
2962
2963                   while Input_Pos <= Last_Pos
2964                     and then Data (Input_Pos) /= Next_Char
2965                   loop
2966                      Input_Pos := Input_Pos + 1;
2967                   end loop;
2968
2969                   if Input_Pos > Last_Pos then
2970                      return False;
2971                   end if;
2972
2973                   --  Check that we still match if we stop at the position we
2974                   --  just found.
2975
2976                   declare
2977                      Num : constant Natural := Input_Pos - Old;
2978
2979                   begin
2980                      Input_Pos := Old;
2981
2982                      if Debug then
2983                         Dump_Error ("Would we still match at that position?");
2984                      end if;
2985
2986                      if Repeat (Operand_Code, Num) < Num then
2987                         return False;
2988                      end if;
2989                   end;
2990
2991                   --  Input_Pos now points to the new position
2992
2993                   if Match (Get_Next (Program, Scan)) then
2994                      return True;
2995                   end if;
2996
2997                   Old := Input_Pos;
2998                   Input_Pos := Input_Pos + 1;
2999                end loop;
3000
3001             --  We do not know what the next character is
3002
3003             else
3004                while Max >= Min loop
3005                   if Debug then
3006                      Dump_Error ("Non-greedy repeat, N=" & Min'Img);
3007                      Dump_Error ("Do we still match Next if we stop here?");
3008                   end if;
3009
3010                   --  If the next character matches
3011
3012                   if Recurse_Match (Next, 1) then
3013                      return True;
3014                   end if;
3015
3016                   Input_Pos := Save + Min;
3017
3018                   --  Could not or did not match -- move forward
3019
3020                   if Repeat (Operand_Code, 1) /= 0 then
3021                      Min := Min + 1;
3022                   else
3023                      if Debug then
3024                         Dump_Error ("Non-greedy repeat failed...");
3025                      end if;
3026
3027                      return False;
3028                   end if;
3029                end loop;
3030             end if;
3031
3032             return False;
3033
3034          --  Greedy operators
3035
3036          else
3037             No := Repeat (Operand_Code, Max);
3038
3039             if Debug and then No < Min then
3040                Dump_Error ("failed... matched" & No'Img & " times");
3041             end if;
3042
3043             --  ??? Perl has some special code here in case the next
3044             --  instruction is of type EOL, since $ and \Z can match before
3045             --  *and* after newline at the end.
3046
3047             --  ??? Perl has some special code here in case (paren) is True
3048
3049             --  Else, if we don't have any parenthesis
3050
3051             while No >= Min loop
3052                if not Next_Char_Known
3053                  or else (Input_Pos <= Last_In_Data
3054                            and then Data (Input_Pos) = Next_Char)
3055                then
3056                   if Match (Next) then
3057                      return True;
3058                   end if;
3059                end if;
3060
3061                --  Could not or did not work, we back up
3062
3063                No := No - 1;
3064                Input_Pos := Save + No;
3065             end loop;
3066
3067             return False;
3068          end if;
3069       end Match_Simple_Operator;
3070
3071       ------------------
3072       -- Match_Whilem --
3073       ------------------
3074
3075       --  This is really hard to understand, because after we match what we
3076       --  are trying to match, we must make sure the rest of the REx is going
3077       --  to match for sure, and to do that we have to go back UP the parse
3078       --  tree by recursing ever deeper.  And if it fails, we have to reset
3079       --  our parent's current state that we can try again after backing off.
3080
3081       function Match_Whilem return Boolean is
3082          Cc : constant Current_Curly_Access := Current_Curly;
3083
3084          N  : constant Natural              := Cc.Cur + 1;
3085          Ln : Natural                       := 0;
3086
3087          Lastloc : constant Natural := Cc.Lastloc;
3088          --  Detection of 0-len
3089
3090       begin
3091          --  If degenerate scan matches "", assume scan done
3092
3093          if Input_Pos = Cc.Lastloc
3094            and then N >= Cc.Min
3095          then
3096             --  Temporarily restore the old context, and check that we
3097             --  match was comes after CURLYX.
3098
3099             Current_Curly := Cc.Old_Cc;
3100
3101             if Current_Curly /= null then
3102                Ln := Current_Curly.Cur;
3103             end if;
3104
3105             if Match (Cc.Next) then
3106                return True;
3107             end if;
3108
3109             if Current_Curly /= null then
3110                Current_Curly.Cur := Ln;
3111             end if;
3112
3113             Current_Curly := Cc;
3114             return False;
3115          end if;
3116
3117          --  First, just match a string of min scans
3118
3119          if N < Cc.Min then
3120             Cc.Cur := N;
3121             Cc.Lastloc := Input_Pos;
3122
3123             if Debug then
3124                Dump_Error
3125                  ("Tests that we match at least" & Cc.Min'Img & " N=" & N'Img);
3126             end if;
3127
3128             if Match (Cc.Scan) then
3129                return True;
3130             end if;
3131
3132             Cc.Cur := N - 1;
3133             Cc.Lastloc := Lastloc;
3134
3135             if Debug then
3136                Dump_Error ("failed...");
3137             end if;
3138
3139             return False;
3140          end if;
3141
3142          --  Prefer next over scan for minimal matching
3143
3144          if not Cc.Greedy then
3145             Current_Curly := Cc.Old_Cc;
3146
3147             if Current_Curly /= null then
3148                Ln := Current_Curly.Cur;
3149             end if;
3150
3151             if Recurse_Match (Cc.Next, Cc.Paren_Floor) then
3152                return True;
3153             end if;
3154
3155             if Current_Curly /= null then
3156                Current_Curly.Cur := Ln;
3157             end if;
3158
3159             Current_Curly := Cc;
3160
3161             --  Maximum greed exceeded ?
3162
3163             if N >= Cc.Max then
3164                if Debug then
3165                   Dump_Error ("failed...");
3166                end if;
3167                return False;
3168             end if;
3169
3170             --  Try scanning more and see if it helps
3171             Cc.Cur := N;
3172             Cc.Lastloc := Input_Pos;
3173
3174             if Debug then
3175                Dump_Error ("Next failed, what about Current?");
3176             end if;
3177
3178             if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3179                return True;
3180             end if;
3181
3182             Cc.Cur := N - 1;
3183             Cc.Lastloc := Lastloc;
3184             return False;
3185          end if;
3186
3187          --  Prefer scan over next for maximal matching
3188
3189          if N < Cc.Max then   --  more greed allowed ?
3190             Cc.Cur := N;
3191             Cc.Lastloc := Input_Pos;
3192
3193             if Debug then
3194                Dump_Error ("Recurse at current position");
3195             end if;
3196
3197             if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3198                return True;
3199             end if;
3200          end if;
3201
3202          --  Failed deeper matches of scan, so see if this one works
3203
3204          Current_Curly := Cc.Old_Cc;
3205
3206          if Current_Curly /= null then
3207             Ln := Current_Curly.Cur;
3208          end if;
3209
3210          if Debug then
3211             Dump_Error ("Failed matching for later positions");
3212          end if;
3213
3214          if Match (Cc.Next) then
3215             return True;
3216          end if;
3217
3218          if Current_Curly /= null then
3219             Current_Curly.Cur := Ln;
3220          end if;
3221
3222          Current_Curly := Cc;
3223          Cc.Cur := N - 1;
3224          Cc.Lastloc := Lastloc;
3225
3226          if Debug then
3227             Dump_Error ("failed...");
3228          end if;
3229
3230          return False;
3231       end Match_Whilem;
3232
3233       ------------
3234       -- Repeat --
3235       ------------
3236
3237       function Repeat
3238         (IP  : Pointer;
3239          Max : Natural := Natural'Last) return Natural
3240       is
3241          Scan  : Natural := Input_Pos;
3242          Last  : Natural;
3243          Op    : constant Opcode := Opcode'Val (Character'Pos (Program (IP)));
3244          Count : Natural;
3245          C     : Character;
3246          Is_First : Boolean := True;
3247          Bitmap   : Character_Class;
3248
3249       begin
3250          if Max = Natural'Last or else Scan + Max - 1 > Last_In_Data then
3251             Last := Last_In_Data;
3252          else
3253             Last := Scan + Max - 1;
3254          end if;
3255
3256          case Op is
3257             when ANY =>
3258                while Scan <= Last
3259                  and then Data (Scan) /= ASCII.LF
3260                loop
3261                   Scan := Scan + 1;
3262                end loop;
3263
3264             when SANY =>
3265                Scan := Last + 1;
3266
3267             when EXACT =>
3268
3269                --  The string has only one character if Repeat was called
3270
3271                C := Program (String_Operand (IP));
3272                while Scan <= Last
3273                  and then C = Data (Scan)
3274                loop
3275                   Scan := Scan + 1;
3276                end loop;
3277
3278             when EXACTF =>
3279
3280                --  The string has only one character if Repeat was called
3281
3282                C := Program (String_Operand (IP));
3283                while Scan <= Last
3284                  and then To_Lower (C) = Data (Scan)
3285                loop
3286                   Scan := Scan + 1;
3287                end loop;
3288
3289             when ANYOF =>
3290                if Is_First then
3291                   Bitmap_Operand (Program, IP, Bitmap);
3292                   Is_First := False;
3293                end if;
3294
3295                while Scan <= Last
3296                  and then Get_From_Class (Bitmap, Data (Scan))
3297                loop
3298                   Scan := Scan + 1;
3299                end loop;
3300
3301             when ALNUM =>
3302                while Scan <= Last
3303                  and then Is_Alnum (Data (Scan))
3304                loop
3305                   Scan := Scan + 1;
3306                end loop;
3307
3308             when NALNUM =>
3309                while Scan <= Last
3310                  and then not Is_Alnum (Data (Scan))
3311                loop
3312                   Scan := Scan + 1;
3313                end loop;
3314
3315             when SPACE =>
3316                while Scan <= Last
3317                  and then Is_White_Space (Data (Scan))
3318                loop
3319                   Scan := Scan + 1;
3320                end loop;
3321
3322             when NSPACE =>
3323                while Scan <= Last
3324                  and then not Is_White_Space (Data (Scan))
3325                loop
3326                   Scan := Scan + 1;
3327                end loop;
3328
3329             when DIGIT  =>
3330                while Scan <= Last
3331                  and then Is_Digit (Data (Scan))
3332                loop
3333                   Scan := Scan + 1;
3334                end loop;
3335
3336             when NDIGIT  =>
3337                while Scan <= Last
3338                  and then not Is_Digit (Data (Scan))
3339                loop
3340                   Scan := Scan + 1;
3341                end loop;
3342
3343             when others =>
3344                raise Program_Error;
3345          end case;
3346
3347          Count := Scan - Input_Pos;
3348          Input_Pos := Scan;
3349          return Count;
3350       end Repeat;
3351
3352       ---------
3353       -- Try --
3354       ---------
3355
3356       function Try (Pos : Positive) return Boolean is
3357       begin
3358          Input_Pos  := Pos;
3359          Last_Paren := 0;
3360          Matches_Full := (others => No_Match);
3361
3362          if Match (Program_First) then
3363             Matches_Full (0) := (Pos, Input_Pos - 1);
3364             return True;
3365          end if;
3366
3367          return False;
3368       end Try;
3369
3370    --  Start of processing for Match
3371
3372    begin
3373       --  Do we have the regexp Never_Match?
3374
3375       if Self.Size = 0 then
3376          Matches := (others => No_Match);
3377          return;
3378       end if;
3379
3380       --  If there is a "must appear" string, look for it
3381
3382       if Self.Must_Have_Length > 0 then
3383          declare
3384             First      : constant Character := Program (Self.Must_Have);
3385             Must_First : constant Pointer := Self.Must_Have;
3386             Must_Last  : constant Pointer :=
3387                            Must_First + Pointer (Self.Must_Have_Length - 1);
3388             Next_Try   : Natural := Index (First_In_Data, First);
3389
3390          begin
3391             while Next_Try /= 0
3392               and then Data (Next_Try .. Next_Try + Self.Must_Have_Length - 1)
3393                           = String (Program (Must_First .. Must_Last))
3394             loop
3395                Next_Try := Index (Next_Try + 1, First);
3396             end loop;
3397
3398             if Next_Try = 0 then
3399                Matches := (others => No_Match);
3400                return;                  -- Not present
3401             end if;
3402          end;
3403       end if;
3404
3405       --  Mark beginning of line for ^
3406
3407       BOL_Pos := Data'First;
3408
3409       --  Simplest case first: an anchored match need be tried only once
3410
3411       if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then
3412          Matched := Try (First_In_Data);
3413
3414       elsif Self.Anchored then
3415          declare
3416             Next_Try : Natural := First_In_Data;
3417          begin
3418             --  Test the first position in the buffer
3419             Matched := Try (Next_Try);
3420
3421             --  Else only test after newlines
3422
3423             if not Matched then
3424                while Next_Try <= Last_In_Data loop
3425                   while Next_Try <= Last_In_Data
3426                     and then Data (Next_Try) /= ASCII.LF
3427                   loop
3428                      Next_Try := Next_Try + 1;
3429                   end loop;
3430
3431                   Next_Try := Next_Try + 1;
3432
3433                   if Next_Try <= Last_In_Data then
3434                      Matched := Try (Next_Try);
3435                      exit when Matched;
3436                   end if;
3437                end loop;
3438             end if;
3439          end;
3440
3441       elsif Self.First /= ASCII.NUL then
3442          --  We know what char it must start with
3443
3444          declare
3445             Next_Try : Natural := Index (First_In_Data, Self.First);
3446
3447          begin
3448             while Next_Try /= 0 loop
3449                Matched := Try (Next_Try);
3450                exit when Matched;
3451                Next_Try := Index (Next_Try + 1, Self.First);
3452             end loop;
3453          end;
3454
3455       else
3456          --  Messy cases: try all locations (including for the empty string)
3457
3458          Matched := Try (First_In_Data);
3459
3460          if not Matched then
3461             for S in First_In_Data + 1 .. Last_In_Data loop
3462                Matched := Try (S);
3463                exit when Matched;
3464             end loop;
3465          end if;
3466       end if;
3467
3468       --  Matched has its value
3469
3470       for J in Last_Paren + 1 .. Matches'Last loop
3471          Matches_Full (J) := No_Match;
3472       end loop;
3473
3474       Matches := Matches_Full (Matches'Range);
3475    end Match;
3476
3477    -----------
3478    -- Match --
3479    -----------
3480
3481    function Match
3482      (Self       : Pattern_Matcher;
3483       Data       : String;
3484       Data_First : Integer := -1;
3485       Data_Last  : Positive := Positive'Last) return Natural
3486    is
3487       Matches : Match_Array (0 .. 0);
3488
3489    begin
3490       Match (Self, Data, Matches, Data_First, Data_Last);
3491       if Matches (0) = No_Match then
3492          return Data'First - 1;
3493       else
3494          return Matches (0).First;
3495       end if;
3496    end Match;
3497
3498    function Match
3499      (Self       : Pattern_Matcher;
3500       Data       : String;
3501       Data_First : Integer  := -1;
3502       Data_Last  : Positive := Positive'Last) return Boolean
3503    is
3504       Matches : Match_Array (0 .. 0);
3505
3506    begin
3507       Match (Self, Data, Matches, Data_First, Data_Last);
3508       return Matches (0).First >= Data'First;
3509    end Match;
3510
3511    procedure Match
3512      (Expression : String;
3513       Data       : String;
3514       Matches    : out Match_Array;
3515       Size       : Program_Size := Auto_Size;
3516       Data_First : Integer      := -1;
3517       Data_Last  : Positive     := Positive'Last)
3518    is
3519       PM            : Pattern_Matcher (Size);
3520       Finalize_Size : Program_Size;
3521       pragma Unreferenced (Finalize_Size);
3522    begin
3523       if Size = 0 then
3524          Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
3525       else
3526          Compile (PM, Expression, Finalize_Size);
3527          Match (PM, Data, Matches, Data_First, Data_Last);
3528       end if;
3529    end Match;
3530
3531    -----------
3532    -- Match --
3533    -----------
3534
3535    function Match
3536      (Expression : String;
3537       Data       : String;
3538       Size       : Program_Size := Auto_Size;
3539       Data_First : Integer      := -1;
3540       Data_Last  : Positive     := Positive'Last) return Natural
3541    is
3542       PM         : Pattern_Matcher (Size);
3543       Final_Size : Program_Size;
3544       pragma Unreferenced (Final_Size);
3545    begin
3546       if Size = 0 then
3547          return Match (Compile (Expression), Data, Data_First, Data_Last);
3548       else
3549          Compile (PM, Expression, Final_Size);
3550          return Match (PM, Data, Data_First, Data_Last);
3551       end if;
3552    end Match;
3553
3554    -----------
3555    -- Match --
3556    -----------
3557
3558    function  Match
3559      (Expression : String;
3560       Data       : String;
3561       Size       : Program_Size := Auto_Size;
3562       Data_First : Integer      := -1;
3563       Data_Last  : Positive     := Positive'Last) return Boolean
3564    is
3565       Matches    : Match_Array (0 .. 0);
3566       PM         : Pattern_Matcher (Size);
3567       Final_Size : Program_Size;
3568       pragma Unreferenced (Final_Size);
3569    begin
3570       if Size = 0 then
3571          Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
3572       else
3573          Compile (PM, Expression, Final_Size);
3574          Match (PM, Data, Matches, Data_First, Data_Last);
3575       end if;
3576
3577       return Matches (0).First >= Data'First;
3578    end Match;
3579
3580    -------------
3581    -- Operand --
3582    -------------
3583
3584    function Operand (P : Pointer) return Pointer is
3585    begin
3586       return P + Next_Pointer_Bytes;
3587    end Operand;
3588
3589    --------------
3590    -- Optimize --
3591    --------------
3592
3593    procedure Optimize (Self : in out Pattern_Matcher) is
3594       Scan    : Pointer;
3595       Program : Program_Data renames Self.Program;
3596
3597    begin
3598       --  Start with safe defaults (no optimization):
3599       --    *  No known first character of match
3600       --    *  Does not necessarily start at beginning of line
3601       --    *  No string known that has to appear in data
3602
3603       Self.First := ASCII.NUL;
3604       Self.Anchored := False;
3605       Self.Must_Have := Program'Last + 1;
3606       Self.Must_Have_Length := 0;
3607
3608       Scan := Program_First;  --  First instruction (can be anything)
3609
3610       if Program (Scan) = EXACT then
3611          Self.First := Program (String_Operand (Scan));
3612
3613       elsif Program (Scan) = BOL
3614         or else Program (Scan) = SBOL
3615         or else Program (Scan) = MBOL
3616       then
3617          Self.Anchored := True;
3618       end if;
3619    end Optimize;
3620
3621    -----------------
3622    -- Paren_Count --
3623    -----------------
3624
3625    function Paren_Count (Regexp : Pattern_Matcher) return Match_Count is
3626    begin
3627       return Regexp.Paren_Count;
3628    end Paren_Count;
3629
3630    -----------
3631    -- Quote --
3632    -----------
3633
3634    function Quote (Str : String) return String is
3635       S    : String (1 .. Str'Length * 2);
3636       Last : Natural := 0;
3637
3638    begin
3639       for J in Str'Range loop
3640          case Str (J) is
3641             when '^' | '$' | '|' | '*' | '+' | '?' | '{' |
3642                  '}' | '[' | ']' | '(' | ')' | '\' | '.' =>
3643
3644                S (Last + 1) := '\';
3645                S (Last + 2) := Str (J);
3646                Last := Last + 2;
3647
3648             when others =>
3649                S (Last + 1) := Str (J);
3650                Last := Last + 1;
3651          end case;
3652       end loop;
3653
3654       return S (1 .. Last);
3655    end Quote;
3656
3657    ------------------
3658    -- Read_Natural --
3659    ------------------
3660
3661    function Read_Natural
3662      (Program : Program_Data;
3663       IP      : Pointer) return Natural
3664    is
3665    begin
3666       return Character'Pos (Program (IP)) +
3667                256 * Character'Pos (Program (IP + 1));
3668    end Read_Natural;
3669
3670    -----------------
3671    -- Reset_Class --
3672    -----------------
3673
3674    procedure Reset_Class (Bitmap : out Character_Class) is
3675    begin
3676       Bitmap := (others => 0);
3677    end Reset_Class;
3678
3679    ------------------
3680    -- Set_In_Class --
3681    ------------------
3682
3683    procedure Set_In_Class
3684      (Bitmap : in out Character_Class;
3685       C      : Character)
3686    is
3687       Value : constant Class_Byte := Character'Pos (C);
3688    begin
3689       Bitmap (Value / 8) := Bitmap (Value / 8)
3690         or Bit_Conversion (Value mod 8);
3691    end Set_In_Class;
3692
3693    -------------------
3694    -- String_Length --
3695    -------------------
3696
3697    function String_Length
3698      (Program : Program_Data;
3699       P       : Pointer) return Program_Size
3700    is
3701    begin
3702       pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF);
3703       return Character'Pos (Program (P + Next_Pointer_Bytes));
3704    end String_Length;
3705
3706    --------------------
3707    -- String_Operand --
3708    --------------------
3709
3710    function String_Operand (P : Pointer) return Pointer is
3711    begin
3712       return P + 4;
3713    end String_Operand;
3714
3715 end System.Regpat;