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