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