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