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