gcc/ada/g-regpat.adb

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