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