1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . R E G P A T --
9 -- Copyright (C) 1986 by University of Toronto. --
10 -- Copyright (C) 1999-2017, AdaCore --
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 3, 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. --
19 -- As a special exception under Section 7 of GPL version 3, you are granted --
20 -- additional permissions described in the GCC Runtime Library Exception, --
21 -- version 3.1, as published by the Free Software Foundation. --
23 -- You should have received a copy of the GNU General Public License and --
24 -- a copy of the GCC Runtime Library Exception along with this program; --
25 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
26 -- <http://www.gnu.org/licenses/>. --
28 -- GNAT was originally developed by the GNAT team at New York University. --
29 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 ------------------------------------------------------------------------------
33 -- This is an altered Ada 95 version of the original V8 style regular
34 -- expression library written in C by Henry Spencer. Apart from the
35 -- translation to Ada, the interface has been considerably changed to
36 -- use the Ada String type instead of C-style nul-terminated strings.
38 -- Beware that some of this code is subtly aware of the way operator
39 -- precedence is structured in regular expressions. Serious changes in
40 -- regular-expression syntax might require a total rethink.
42 with System
.IO
; use System
.IO
;
43 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
44 with Ada
.Unchecked_Conversion
;
46 package body System
.Regpat
is
48 Debug
: constant Boolean := False;
49 -- Set to True to activate debug traces. This is normally set to constant
50 -- False to simply delete all the trace code. It is to be edited to True
51 -- for internal debugging of the package.
53 ----------------------------
54 -- Implementation details --
55 ----------------------------
57 -- This is essentially a linear encoding of a nondeterministic
58 -- finite-state machine, also known as syntax charts or
59 -- "railroad normal form" in parsing technology.
61 -- Each node is an opcode plus a "next" pointer, possibly plus an
62 -- operand. "Next" pointers of all nodes except BRANCH implement
63 -- concatenation; a "next" pointer with a BRANCH on both ends of it
64 -- is connecting two alternatives.
66 -- The operand of some types of node is a literal string; for others,
67 -- it is a node leading into a sub-FSM. In particular, the operand of
68 -- a BRANCH node is the first node of the branch.
69 -- (NB this is *not* a tree structure: the tail of the branch connects
70 -- to the thing following the set of BRANCHes).
72 -- You can see the exact byte-compiled version by using the Dump
73 -- subprogram. However, here are a few examples:
75 -- (a|b): 1 : BRANCH (next at 9)
76 -- 4 : EXACT (next at 17) operand=a
77 -- 9 : BRANCH (next at 17)
78 -- 12 : EXACT (next at 17) operand=b
79 -- 17 : EOP (next at 0)
81 -- (ab)*: 1 : CURLYX (next at 25) { 0, 32767}
82 -- 8 : OPEN 1 (next at 12)
83 -- 12 : EXACT (next at 18) operand=ab
84 -- 18 : CLOSE 1 (next at 22)
85 -- 22 : WHILEM (next at 0)
86 -- 25 : NOTHING (next at 28)
87 -- 28 : EOP (next at 0)
93 -- Name Operand? Meaning
95 (EOP
, -- no End of program
96 MINMOD
, -- no Next operator is not greedy
98 -- Classes of characters
100 ANY
, -- no Match any one character except newline
101 SANY
, -- no Match any character, including new line
102 ANYOF
, -- class Match any character in this class
103 EXACT
, -- str Match this string exactly
104 EXACTF
, -- str Match this string (case-folding is one)
105 NOTHING
, -- no Match empty string
106 SPACE
, -- no Match any whitespace character
107 NSPACE
, -- no Match any non-whitespace character
108 DIGIT
, -- no Match any numeric character
109 NDIGIT
, -- no Match any non-numeric character
110 ALNUM
, -- no Match any alphanumeric character
111 NALNUM
, -- no Match any non-alphanumeric character
115 BRANCH
, -- node Match this alternative, or the next
117 -- Simple loops (when the following node is one character in length)
119 STAR
, -- node Match this simple thing 0 or more times
120 PLUS
, -- node Match this simple thing 1 or more times
121 CURLY
, -- 2num node Match this simple thing between n and m times.
125 CURLYX
, -- 2num node Match this complex thing {n,m} times
126 -- The nums are coded on two characters each
128 WHILEM
, -- no Do curly processing and see if rest matches
130 -- Matches after or before a word
132 BOL
, -- no Match "" at beginning of line
133 MBOL
, -- no Same, assuming multiline (match after \n)
134 SBOL
, -- no Same, assuming single line (don't match at \n)
135 EOL
, -- no Match "" at end of line
136 MEOL
, -- no Same, assuming multiline (match before \n)
137 SEOL
, -- no Same, assuming single line (don't match at \n)
139 BOUND
, -- no Match "" at any word boundary
140 NBOUND
, -- no Match "" at any word non-boundary
142 -- Parenthesis groups handling
144 REFF
, -- num Match some already matched string, folded
145 OPEN
, -- num Mark this point in input as start of #n
146 CLOSE
); -- num Analogous to OPEN
148 for Opcode
'Size use 8;
153 -- The set of branches constituting a single choice are hooked
154 -- together with their "next" pointers, since precedence prevents
155 -- anything being concatenated to any individual branch. The
156 -- "next" pointer of the last BRANCH in a choice points to the
157 -- thing following the whole choice. This is also where the
158 -- final "next" pointer of each individual branch points; each
159 -- branch starts with the operand node of a BRANCH node.
162 -- '?', and complex '*' and '+', are implemented with CURLYX.
163 -- branches. Simple cases (one character per match) are implemented with
164 -- STAR and PLUS for speed and to minimize recursive plunges.
167 -- ...are numbered at compile time.
170 -- There are in fact two arguments, the first one is the length (minus
171 -- one of the string argument), coded on one character, the second
172 -- argument is the string itself, coded on length + 1 characters.
174 -- A node is one char of opcode followed by two chars of "next" pointer.
175 -- "Next" pointers are stored as two 8-bit pieces, high order first. The
176 -- value is a positive offset from the opcode of the node containing it.
177 -- An operand, if any, simply follows the node. (Note that much of the
178 -- code generation knows about this implicit relationship.)
180 -- Using two bytes for the "next" pointer is vast overkill for most
181 -- things, but allows patterns to get big without disasters.
183 Next_Pointer_Bytes
: constant := 3;
184 -- Points after the "next pointer" data. An instruction is therefore:
185 -- 1 byte: instruction opcode
186 -- 2 bytes: pointer to next instruction
187 -- * bytes: optional data for the instruction
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
197 type Class_Byte
is mod 256;
198 type Character_Class
is array (Class_Byte
range 0 .. 31) of Class_Byte
;
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);
204 type Std_Class
is (ANYOF_NONE
,
205 ANYOF_ALNUM
, -- Alphanumeric class [a-zA-Z0-9]
207 ANYOF_SPACE
, -- Space class [ \t\n\r\f]
209 ANYOF_DIGIT
, -- Digit class [0-9]
211 ANYOF_ALNUMC
, -- Alphanumeric class [a-zA-Z0-9]
213 ANYOF_ALPHA
, -- Alpha class [a-zA-Z]
215 ANYOF_ASCII
, -- Ascii class (7 bits) 0..127
217 ANYOF_CNTRL
, -- Control class
219 ANYOF_GRAPH
, -- Graphic class
221 ANYOF_LOWER
, -- Lower case class [a-z]
223 ANYOF_PRINT
, -- printable class
227 ANYOF_UPPER
, -- Upper case class [A-Z]
229 ANYOF_XDIGIT
, -- Hexadecimal digit
233 procedure Set_In_Class
234 (Bitmap
: in out Character_Class
;
236 -- Set the entry to True for C in the class Bitmap
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
243 procedure Reset_Class
(Bitmap
: out Character_Class
);
244 -- Clear all the entries in the class Bitmap
246 pragma Inline
(Set_In_Class
);
247 pragma Inline
(Get_From_Class
);
248 pragma Inline
(Reset_Class
);
250 -----------------------
251 -- Local Subprograms --
252 -----------------------
254 function "=" (Left
: Character; Right
: Opcode
) return Boolean;
256 function Is_Alnum
(C
: Character) return Boolean;
257 -- Return True if C is an alphanum character or an underscore ('_')
259 function Is_White_Space
(C
: Character) return Boolean;
260 -- Return True if C is a whitespace character
262 function Is_Printable
(C
: Character) return Boolean;
263 -- Return True if C is a printable character
265 function Operand
(P
: Pointer
) return Pointer
;
266 -- Return a pointer to the first operand of the node at P
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
273 function String_Operand
(P
: Pointer
) return Pointer
;
274 -- Return a pointer to the string argument of the node at P
276 procedure Bitmap_Operand
277 (Program
: Program_Data
;
279 Op
: out Character_Class
);
280 -- Return a pointer to the string argument of the node at P
283 (Program
: Program_Data
;
284 IP
: Pointer
) return Pointer
;
285 -- Dig the next instruction pointer out of a node
287 procedure Optimize
(Self
: in out Pattern_Matcher
);
288 -- Optimize a Pattern_Matcher by noting certain special cases
290 function Read_Natural
291 (Program
: Program_Data
;
292 IP
: Pointer
) return Natural;
293 -- Return the 2-byte natural coded at position IP
295 -- All of the subprograms above are tiny and should be inlined
298 pragma Inline
(Is_Alnum
);
299 pragma Inline
(Is_White_Space
);
300 pragma Inline
(Get_Next
);
301 pragma Inline
(Operand
);
302 pragma Inline
(Read_Natural
);
303 pragma Inline
(String_Length
);
304 pragma Inline
(String_Operand
);
306 type Expression_Flags
is record
307 Has_Width
, -- Known never to match null string
308 Simple
, -- Simple enough to be STAR/PLUS operand
309 SP_Start
: Boolean; -- Starts with * or +
312 Worst_Expression
: constant Expression_Flags
:= (others => False);
316 (Program
: Program_Data
;
317 Index
: in out Pointer
;
320 Do_Print
: Boolean := True);
321 -- Dump the program until the node Till (not included) is met. Every line
322 -- is indented with Index spaces at the beginning Dumps till the end if
325 procedure Dump_Operation
326 (Program
: Program_Data
;
329 -- Same as above, but only dumps a single operation, and compute its
330 -- indentation from the program.
336 function "=" (Left
: Character; Right
: Opcode
) return Boolean is
338 return Character'Pos (Left
) = Opcode
'Pos (Right
);
345 procedure Bitmap_Operand
346 (Program
: Program_Data
;
348 Op
: out Character_Class
)
350 function Convert
is new Ada
.Unchecked_Conversion
351 (Program_Data
, Character_Class
);
354 Op
(0 .. 31) := Convert
(Program
(P
+ Next_Pointer_Bytes
.. P
+ 34));
362 (Matcher
: out Pattern_Matcher
;
364 Final_Code_Size
: out Program_Size
;
365 Flags
: Regexp_Flags
:= No_Flags
)
367 -- We can't allocate space until we know how big the compiled form
368 -- will be, but we can't compile it (and thus know how big it is)
369 -- until we've got a place to put the code. So we cheat: we compile
370 -- it twice, once with code generation turned off and size counting
371 -- turned on, and once "for real".
373 -- This also means that we don't allocate space until we are sure
374 -- that the thing really will compile successfully, and we never
375 -- have to move the code and thus invalidate pointers into it.
377 -- Beware that the optimization-preparation code in here knows
378 -- about some of the structure of the compiled regexp.
380 PM
: Pattern_Matcher
renames Matcher
;
381 Program
: Program_Data
renames PM
.Program
;
383 Emit_Ptr
: Pointer
:= Program_First
;
385 Parse_Pos
: Natural := Expression
'First; -- Input-scan pointer
386 Parse_End
: constant Natural := Expression
'Last;
388 ----------------------------
389 -- Subprograms for Create --
390 ----------------------------
392 procedure Emit
(B
: Character);
393 -- Output the Character B to the Program. If code-generation is
394 -- disabled, simply increments the program counter.
396 function Emit_Node
(Op
: Opcode
) return Pointer
;
397 -- If code-generation is enabled, Emit_Node outputs the
398 -- opcode Op and reserves space for a pointer to the next node.
399 -- Return value is the location of new opcode, i.e. old Emit_Ptr.
401 procedure Emit_Natural
(IP
: Pointer
; N
: Natural);
402 -- Split N on two characters at position IP
404 procedure Emit_Class
(Bitmap
: Character_Class
);
405 -- Emits a character class
407 procedure Case_Emit
(C
: Character);
408 -- Emit C, after converting is to lower-case if the regular
409 -- expression is case insensitive.
412 (Parenthesized
: Boolean;
414 Flags
: out Expression_Flags
;
416 -- Parse regular expression, i.e. main body or parenthesized thing.
417 -- Caller must absorb opening parenthesis. Capturing should be set to
418 -- True when we have an open parenthesis from which we want the user
421 procedure Parse_Branch
422 (Flags
: out Expression_Flags
;
425 -- Implements the concatenation operator and handles '|'.
426 -- First should be true if this is the first item of the alternative.
428 procedure Parse_Piece
429 (Expr_Flags
: out Expression_Flags
;
431 -- Parse something followed by possible [*+?]
434 (Expr_Flags
: out Expression_Flags
;
436 -- Parse_Atom is the lowest level parse procedure.
438 -- Optimization: Gobbles an entire sequence of ordinary characters so
439 -- that it can turn them into a single node, which is smaller to store
440 -- and faster to run. Backslashed characters are exceptions, each
441 -- becoming a separate node; the code is simpler that way and it's
444 procedure Insert_Operator
447 Greedy
: Boolean := True);
448 -- Insert_Operator inserts an operator in front of an already-emitted
449 -- operand and relocates the operand. This applies to PLUS and STAR.
450 -- If Minmod is True, then the operator is non-greedy.
452 function Insert_Operator_Before
456 Opsize
: Pointer
) return Pointer
;
457 -- Insert an operator before Operand (and move the latter forward in the
458 -- program). Opsize is the size needed to represent the operator. This
459 -- returns the position at which the operator was inserted, and moves
460 -- Emit_Ptr after the new position of the operand.
462 procedure Insert_Curly_Operator
467 Greedy
: Boolean := True);
468 -- Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}).
469 -- If Minmod is True, then the operator is non-greedy.
471 procedure Link_Tail
(P
, Val
: Pointer
);
472 -- Link_Tail sets the next-pointer at the end of a node chain
474 procedure Link_Operand_Tail
(P
, Val
: Pointer
);
475 -- Link_Tail on operand of first argument; noop if operand-less
477 procedure Fail
(M
: String);
478 pragma No_Return
(Fail
);
479 -- Fail with a diagnostic message, if possible
481 function Is_Curly_Operator
(IP
: Natural) return Boolean;
482 -- Return True if IP is looking at a '{' that is the beginning
483 -- of a curly operator, i.e. it matches {\d+,?\d*}
485 function Is_Mult
(IP
: Natural) return Boolean;
486 -- Return True if C is a regexp multiplier: '+', '*' or '?'
488 procedure Get_Curly_Arguments
492 Greedy
: out Boolean);
493 -- Parse the argument list for a curly operator.
494 -- It is assumed that IP is indeed pointing at a valid operator.
495 -- So what is IP and how come IP is not referenced in the body ???
497 procedure Parse_Character_Class
(IP
: out Pointer
);
498 -- Parse a character class.
499 -- The calling subprogram should consume the opening '[' before.
501 procedure Parse_Literal
502 (Expr_Flags
: out Expression_Flags
;
504 -- Parse_Literal encodes a string of characters to be matched exactly
506 function Parse_Posix_Character_Class
return Std_Class
;
507 -- Parse a posix character class, like [:alpha:] or [:^alpha:].
508 -- The caller is supposed to absorb the opening [.
510 pragma Inline
(Is_Mult
);
511 pragma Inline
(Emit_Natural
);
512 pragma Inline
(Parse_Character_Class
); -- since used only once
518 procedure Case_Emit
(C
: Character) is
520 if (Flags
and Case_Insensitive
) /= 0 then
524 -- Dump current character
534 procedure Emit
(B
: Character) is
536 if Emit_Ptr
<= PM
.Size
then
537 Program
(Emit_Ptr
) := B
;
540 Emit_Ptr
:= Emit_Ptr
+ 1;
547 procedure Emit_Class
(Bitmap
: Character_Class
) is
548 subtype Program31
is Program_Data
(0 .. 31);
550 function Convert
is new Ada
.Unchecked_Conversion
551 (Character_Class
, Program31
);
554 -- What is the mysterious constant 31 here??? Can't it be expressed
555 -- symbolically (size of integer - 1 or some such???). In any case
556 -- it should be declared as a constant (and referenced presumably
557 -- as this constant + 1 below.
559 if Emit_Ptr
+ 31 <= PM
.Size
then
560 Program
(Emit_Ptr
.. Emit_Ptr
+ 31) := Convert
(Bitmap
);
563 Emit_Ptr
:= Emit_Ptr
+ 32;
570 procedure Emit_Natural
(IP
: Pointer
; N
: Natural) is
572 if IP
+ 1 <= PM
.Size
then
573 Program
(IP
+ 1) := Character'Val (N
/ 256);
574 Program
(IP
) := Character'Val (N
mod 256);
582 function Emit_Node
(Op
: Opcode
) return Pointer
is
583 Result
: constant Pointer
:= Emit_Ptr
;
586 if Emit_Ptr
+ 2 <= PM
.Size
then
587 Program
(Emit_Ptr
) := Character'Val (Opcode
'Pos (Op
));
588 Program
(Emit_Ptr
+ 1) := ASCII
.NUL
;
589 Program
(Emit_Ptr
+ 2) := ASCII
.NUL
;
592 Emit_Ptr
:= Emit_Ptr
+ Next_Pointer_Bytes
;
600 procedure Fail
(M
: String) is
602 raise Expression_Error
with M
;
605 -------------------------
606 -- Get_Curly_Arguments --
607 -------------------------
609 procedure Get_Curly_Arguments
613 Greedy
: out Boolean)
615 pragma Unreferenced
(IP
);
617 Save_Pos
: Natural := Parse_Pos
+ 1;
621 Max
:= Max_Curly_Repeat
;
623 while Expression
(Parse_Pos
) /= '}'
624 and then Expression
(Parse_Pos
) /= ','
626 Parse_Pos
:= Parse_Pos
+ 1;
629 Min
:= Natural'Value (Expression
(Save_Pos
.. Parse_Pos
- 1));
631 if Expression
(Parse_Pos
) = ',' then
632 Save_Pos
:= Parse_Pos
+ 1;
633 while Expression
(Parse_Pos
) /= '}' loop
634 Parse_Pos
:= Parse_Pos
+ 1;
637 if Save_Pos
/= Parse_Pos
then
638 Max
:= Natural'Value (Expression
(Save_Pos
.. Parse_Pos
- 1));
645 if Parse_Pos
< Expression
'Last
646 and then Expression
(Parse_Pos
+ 1) = '?'
649 Parse_Pos
:= Parse_Pos
+ 1;
654 end Get_Curly_Arguments
;
656 ---------------------------
657 -- Insert_Curly_Operator --
658 ---------------------------
660 procedure Insert_Curly_Operator
665 Greedy
: Boolean := True)
669 Old
:= Insert_Operator_Before
(Op
, Operand
, Greedy
, Opsize
=> 7);
670 Emit_Natural
(Old
+ Next_Pointer_Bytes
, Min
);
671 Emit_Natural
(Old
+ Next_Pointer_Bytes
+ 2, Max
);
672 end Insert_Curly_Operator
;
674 ----------------------------
675 -- Insert_Operator_Before --
676 ----------------------------
678 function Insert_Operator_Before
682 Opsize
: Pointer
) return Pointer
684 Dest
: constant Pointer
:= Emit_Ptr
;
686 Size
: Pointer
:= Opsize
;
689 -- If not greedy, we have to emit another opcode first
692 Size
:= Size
+ Next_Pointer_Bytes
;
695 -- Move the operand in the byte-compilation, so that we can insert
696 -- the operator before it.
698 if Emit_Ptr
+ Size
<= PM
.Size
then
699 Program
(Operand
+ Size
.. Emit_Ptr
+ Size
) :=
700 Program
(Operand
.. Emit_Ptr
);
703 -- Insert the operator at the position previously occupied by the
709 Old
:= Emit_Node
(MINMOD
);
710 Link_Tail
(Old
, Old
+ Next_Pointer_Bytes
);
713 Old
:= Emit_Node
(Op
);
714 Emit_Ptr
:= Dest
+ Size
;
716 end Insert_Operator_Before
;
718 ---------------------
719 -- Insert_Operator --
720 ---------------------
722 procedure Insert_Operator
725 Greedy
: Boolean := True)
728 pragma Warnings
(Off
, Discard
);
730 Discard
:= Insert_Operator_Before
731 (Op
, Operand
, Greedy
, Opsize
=> Next_Pointer_Bytes
);
734 -----------------------
735 -- Is_Curly_Operator --
736 -----------------------
738 function Is_Curly_Operator
(IP
: Natural) return Boolean is
739 Scan
: Natural := IP
;
742 if Expression
(Scan
) /= '{'
743 or else Scan
+ 2 > Expression
'Last
744 or else not Is_Digit
(Expression
(Scan
+ 1))
756 if Scan
> Expression
'Last then
760 exit when not Is_Digit
(Expression
(Scan
));
763 if Expression
(Scan
) = ',' then
767 if Scan
> Expression
'Last then
771 exit when not Is_Digit
(Expression
(Scan
));
775 return Expression
(Scan
) = '}';
776 end Is_Curly_Operator
;
782 function Is_Mult
(IP
: Natural) return Boolean is
783 C
: constant Character := Expression
(IP
);
789 or else (C
= '{' and then Is_Curly_Operator
(IP
));
792 -----------------------
793 -- Link_Operand_Tail --
794 -----------------------
796 procedure Link_Operand_Tail
(P
, Val
: Pointer
) is
798 if P
<= PM
.Size
and then Program
(P
) = BRANCH
then
799 Link_Tail
(Operand
(P
), Val
);
801 end Link_Operand_Tail
;
807 procedure Link_Tail
(P
, Val
: Pointer
) is
813 -- Find last node (the size of the pattern matcher might be too
814 -- small, so don't try to read past its end).
817 while Scan
+ Next_Pointer_Bytes
<= PM
.Size
loop
818 Temp
:= Get_Next
(Program
, Scan
);
819 exit when Temp
= Scan
;
823 Offset
:= Val
- Scan
;
825 Emit_Natural
(Scan
+ 1, Natural (Offset
));
832 -- Combining parenthesis handling with the base level of regular
833 -- expression is a trifle forced, but the need to tie the tails of the
834 -- the branches to what follows makes it hard to avoid.
837 (Parenthesized
: Boolean;
839 Flags
: out Expression_Flags
;
842 E
: String renames Expression
;
846 New_Flags
: Expression_Flags
;
847 Have_Branch
: Boolean := False;
850 Flags
:= (Has_Width
=> True, others => False); -- Tentatively
852 -- Make an OPEN node, if parenthesized
854 if Parenthesized
and then Capturing
then
855 if Matcher
.Paren_Count
> Max_Paren_Count
then
856 Fail
("too many ()");
859 Par_No
:= Matcher
.Paren_Count
+ 1;
860 Matcher
.Paren_Count
:= Matcher
.Paren_Count
+ 1;
861 IP
:= Emit_Node
(OPEN
);
862 Emit
(Character'Val (Par_No
));
868 -- Pick up the branches, linking them together
870 Parse_Branch
(New_Flags
, True, Br
);
877 if Parse_Pos
<= Parse_End
878 and then E
(Parse_Pos
) = '|'
880 Insert_Operator
(BRANCH
, Br
);
885 Link_Tail
(IP
, Br
); -- OPEN -> first
890 if not New_Flags
.Has_Width
then
891 Flags
.Has_Width
:= False;
894 Flags
.SP_Start
:= Flags
.SP_Start
or else New_Flags
.SP_Start
;
896 while Parse_Pos
<= Parse_End
897 and then (E
(Parse_Pos
) = '|')
899 Parse_Pos
:= Parse_Pos
+ 1;
900 Parse_Branch
(New_Flags
, False, Br
);
907 Link_Tail
(IP
, Br
); -- BRANCH -> BRANCH
909 if not New_Flags
.Has_Width
then
910 Flags
.Has_Width
:= False;
913 Flags
.SP_Start
:= Flags
.SP_Start
or else New_Flags
.SP_Start
;
916 -- Make a closing node, and hook it on the end
918 if Parenthesized
then
920 Ender
:= Emit_Node
(CLOSE
);
921 Emit
(Character'Val (Par_No
));
922 Link_Tail
(IP
, Ender
);
925 -- Need to keep looking after the closing parenthesis
930 Ender
:= Emit_Node
(EOP
);
931 Link_Tail
(IP
, Ender
);
934 if Have_Branch
and then Emit_Ptr
<= PM
.Size
+ 1 then
936 -- Hook the tails of the branches to the closing node
940 Link_Operand_Tail
(Br
, Ender
);
941 Br2
:= Get_Next
(Program
, Br
);
947 -- Check for proper termination
949 if Parenthesized
then
950 if Parse_Pos
> Parse_End
or else E
(Parse_Pos
) /= ')' then
951 Fail
("unmatched ()");
954 Parse_Pos
:= Parse_Pos
+ 1;
956 elsif Parse_Pos
<= Parse_End
then
957 if E
(Parse_Pos
) = ')' then
958 Fail
("unmatched ')'");
960 Fail
("junk on end"); -- "Can't happen"
970 (Expr_Flags
: out Expression_Flags
;
976 -- Tentatively set worst expression case
978 Expr_Flags
:= Worst_Expression
;
980 C
:= Expression
(Parse_Pos
);
981 Parse_Pos
:= Parse_Pos
+ 1;
987 (if (Flags
and Multiple_Lines
) /= 0 then MBOL
988 elsif (Flags
and Single_Line
) /= 0 then SBOL
994 (if (Flags
and Multiple_Lines
) /= 0 then MEOL
995 elsif (Flags
and Single_Line
) /= 0 then SEOL
1001 (if (Flags
and Single_Line
) /= 0 then SANY
else ANY
);
1003 Expr_Flags
.Has_Width
:= True;
1004 Expr_Flags
.Simple
:= True;
1007 Parse_Character_Class
(IP
);
1008 Expr_Flags
.Has_Width
:= True;
1009 Expr_Flags
.Simple
:= True;
1013 New_Flags
: Expression_Flags
;
1016 if Parse_Pos
<= Parse_End
- 1
1017 and then Expression
(Parse_Pos
) = '?'
1018 and then Expression
(Parse_Pos
+ 1) = ':'
1020 Parse_Pos
:= Parse_Pos
+ 2;
1022 -- Non-capturing parenthesis
1024 Parse
(True, False, New_Flags
, IP
);
1027 -- Capturing parenthesis
1029 Parse
(True, True, New_Flags
, IP
);
1030 Expr_Flags
.Has_Width
:=
1031 Expr_Flags
.Has_Width
or else New_Flags
.Has_Width
;
1032 Expr_Flags
.SP_Start
:=
1033 Expr_Flags
.SP_Start
or else New_Flags
.SP_Start
;
1040 when '|' | ASCII
.LF |
')' =>
1041 Fail
("internal urp"); -- Supposed to be caught earlier
1043 when '?' |
'+' |
'*' =>
1044 Fail
(C
& " follows nothing");
1047 if Is_Curly_Operator
(Parse_Pos
- 1) then
1048 Fail
(C
& " follows nothing");
1050 Parse_Literal
(Expr_Flags
, IP
);
1054 if Parse_Pos
> Parse_End
then
1055 Fail
("trailing \");
1058 Parse_Pos := Parse_Pos + 1;
1060 case Expression (Parse_Pos - 1) is
1062 IP := Emit_Node (BOUND);
1065 IP := Emit_Node (NBOUND);
1068 IP := Emit_Node (SPACE);
1069 Expr_Flags.Simple := True;
1070 Expr_Flags.Has_Width := True;
1073 IP := Emit_Node (NSPACE);
1074 Expr_Flags.Simple := True;
1075 Expr_Flags.Has_Width := True;
1078 IP := Emit_Node (DIGIT);
1079 Expr_Flags.Simple := True;
1080 Expr_Flags.Has_Width := True;
1083 IP := Emit_Node (NDIGIT);
1084 Expr_Flags.Simple := True;
1085 Expr_Flags.Has_Width := True;
1088 IP := Emit_Node (ALNUM);
1089 Expr_Flags.Simple := True;
1090 Expr_Flags.Has_Width := True;
1093 IP := Emit_Node (NALNUM);
1094 Expr_Flags.Simple := True;
1095 Expr_Flags.Has_Width := True;
1098 IP := Emit_Node (SBOL);
1101 IP := Emit_Node (SEOL);
1104 IP := Emit_Node (REFF);
1107 Save : constant Natural := Parse_Pos - 1;
1110 while Parse_Pos <= Expression'Last
1111 and then Is_Digit (Expression (Parse_Pos))
1113 Parse_Pos := Parse_Pos + 1;
1116 Emit (Character'Val (Natural'Value
1117 (Expression (Save .. Parse_Pos - 1))));
1121 Parse_Pos := Parse_Pos - 1;
1122 Parse_Literal (Expr_Flags, IP);
1126 Parse_Literal (Expr_Flags, IP);
1134 procedure Parse_Branch
1135 (Flags : out Expression_Flags;
1139 E : String renames Expression;
1142 New_Flags : Expression_Flags;
1145 pragma Warnings (Off, Discard);
1148 Flags := Worst_Expression; -- Tentatively
1149 IP := (if First then Emit_Ptr else Emit_Node (BRANCH));
1152 while Parse_Pos <= Parse_End
1153 and then E (Parse_Pos) /= ')'
1154 and then E (Parse_Pos) /= ASCII.LF
1155 and then E (Parse_Pos) /= '|'
1157 Parse_Piece (New_Flags, Last);
1164 Flags.Has_Width := Flags.Has_Width or else New_Flags.Has_Width;
1166 if Chain = 0 then -- First piece
1167 Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start;
1169 Link_Tail (Chain, Last);
1175 -- Case where loop ran zero CURLY
1178 Discard := Emit_Node (NOTHING);
1182 ---------------------------
1183 -- Parse_Character_Class --
1184 ---------------------------
1186 procedure Parse_Character_Class (IP : out Pointer) is
1187 Bitmap : Character_Class;
1188 Invert : Boolean := False;
1189 In_Range : Boolean := False;
1190 Named_Class : Std_Class := ANYOF_NONE;
1192 Last_Value : Character := ASCII.NUL;
1195 Reset_Class (Bitmap);
1197 -- Do we have an invert character class ?
1199 if Parse_Pos <= Parse_End
1200 and then Expression (Parse_Pos) = '^'
1203 Parse_Pos := Parse_Pos + 1;
1206 -- First character can be ] or - without closing the class
1208 if Parse_Pos <= Parse_End
1209 and then (Expression (Parse_Pos) = ']'
1210 or else Expression (Parse_Pos) = '-')
1212 Set_In_Class (Bitmap, Expression (Parse_Pos));
1213 Parse_Pos := Parse_Pos + 1;
1216 -- While we don't have the end of the class
1218 while Parse_Pos <= Parse_End
1219 and then Expression (Parse_Pos) /= ']'
1221 Named_Class := ANYOF_NONE;
1222 Value := Expression (Parse_Pos);
1223 Parse_Pos := Parse_Pos + 1;
1225 -- Do we have a Posix character class
1227 Named_Class := Parse_Posix_Character_Class;
1229 elsif Value = '\' then
1230 if Parse_Pos = Parse_End then
1231 Fail ("Trailing
\");
1233 Value
:= Expression
(Parse_Pos
);
1234 Parse_Pos
:= Parse_Pos
+ 1;
1237 when 'w' => Named_Class
:= ANYOF_ALNUM
;
1238 when 'W' => Named_Class
:= ANYOF_NALNUM
;
1239 when 's' => Named_Class
:= ANYOF_SPACE
;
1240 when 'S' => Named_Class
:= ANYOF_NSPACE
;
1241 when 'd' => Named_Class
:= ANYOF_DIGIT
;
1242 when 'D' => Named_Class
:= ANYOF_NDIGIT
;
1243 when 'n' => Value
:= ASCII
.LF
;
1244 when 'r' => Value
:= ASCII
.CR
;
1245 when 't' => Value
:= ASCII
.HT
;
1246 when 'f' => Value
:= ASCII
.FF
;
1247 when 'e' => Value
:= ASCII
.ESC
;
1248 when 'a' => Value
:= ASCII
.BEL
;
1250 -- when 'x' => ??? hexadecimal value
1251 -- when 'c' => ??? control character
1252 -- when '0'..'9' => ??? octal character
1254 when others => null;
1258 -- Do we have a character class?
1260 if Named_Class
/= ANYOF_NONE
then
1262 -- A range like 'a-\d' or 'a-[:digit:] is not a range
1265 Set_In_Class
(Bitmap
, Last_Value
);
1266 Set_In_Class
(Bitmap
, '-');
1273 when ANYOF_NONE
=> null;
1275 when ANYOF_ALNUM | ANYOF_ALNUMC
=>
1276 for Value
in Class_Byte
'Range loop
1277 if Is_Alnum
(Character'Val (Value
)) then
1278 Set_In_Class
(Bitmap
, Character'Val (Value
));
1282 when ANYOF_NALNUM | ANYOF_NALNUMC
=>
1283 for Value
in Class_Byte
'Range loop
1284 if not Is_Alnum
(Character'Val (Value
)) then
1285 Set_In_Class
(Bitmap
, Character'Val (Value
));
1290 for Value
in Class_Byte
'Range loop
1291 if Is_White_Space
(Character'Val (Value
)) then
1292 Set_In_Class
(Bitmap
, Character'Val (Value
));
1296 when ANYOF_NSPACE
=>
1297 for Value
in Class_Byte
'Range loop
1298 if not Is_White_Space
(Character'Val (Value
)) then
1299 Set_In_Class
(Bitmap
, Character'Val (Value
));
1304 for Value
in Class_Byte
'Range loop
1305 if Is_Digit
(Character'Val (Value
)) then
1306 Set_In_Class
(Bitmap
, Character'Val (Value
));
1310 when ANYOF_NDIGIT
=>
1311 for Value
in Class_Byte
'Range loop
1312 if not Is_Digit
(Character'Val (Value
)) then
1313 Set_In_Class
(Bitmap
, Character'Val (Value
));
1318 for Value
in Class_Byte
'Range loop
1319 if Is_Letter
(Character'Val (Value
)) then
1320 Set_In_Class
(Bitmap
, Character'Val (Value
));
1324 when ANYOF_NALPHA
=>
1325 for Value
in Class_Byte
'Range loop
1326 if not Is_Letter
(Character'Val (Value
)) then
1327 Set_In_Class
(Bitmap
, Character'Val (Value
));
1332 for Value
in 0 .. 127 loop
1333 Set_In_Class
(Bitmap
, Character'Val (Value
));
1336 when ANYOF_NASCII
=>
1337 for Value
in 128 .. 255 loop
1338 Set_In_Class
(Bitmap
, Character'Val (Value
));
1342 for Value
in Class_Byte
'Range loop
1343 if Is_Control
(Character'Val (Value
)) then
1344 Set_In_Class
(Bitmap
, Character'Val (Value
));
1348 when ANYOF_NCNTRL
=>
1349 for Value
in Class_Byte
'Range loop
1350 if not Is_Control
(Character'Val (Value
)) then
1351 Set_In_Class
(Bitmap
, Character'Val (Value
));
1356 for Value
in Class_Byte
'Range loop
1357 if Is_Graphic
(Character'Val (Value
)) then
1358 Set_In_Class
(Bitmap
, Character'Val (Value
));
1362 when ANYOF_NGRAPH
=>
1363 for Value
in Class_Byte
'Range loop
1364 if not Is_Graphic
(Character'Val (Value
)) then
1365 Set_In_Class
(Bitmap
, Character'Val (Value
));
1370 for Value
in Class_Byte
'Range loop
1371 if Is_Lower
(Character'Val (Value
)) then
1372 Set_In_Class
(Bitmap
, Character'Val (Value
));
1376 when ANYOF_NLOWER
=>
1377 for Value
in Class_Byte
'Range loop
1378 if not Is_Lower
(Character'Val (Value
)) then
1379 Set_In_Class
(Bitmap
, Character'Val (Value
));
1384 for Value
in Class_Byte
'Range loop
1385 if Is_Printable
(Character'Val (Value
)) then
1386 Set_In_Class
(Bitmap
, Character'Val (Value
));
1390 when ANYOF_NPRINT
=>
1391 for Value
in Class_Byte
'Range loop
1392 if not Is_Printable
(Character'Val (Value
)) then
1393 Set_In_Class
(Bitmap
, Character'Val (Value
));
1398 for Value
in Class_Byte
'Range loop
1399 if Is_Printable
(Character'Val (Value
))
1400 and then not Is_White_Space
(Character'Val (Value
))
1401 and then not Is_Alnum
(Character'Val (Value
))
1403 Set_In_Class
(Bitmap
, Character'Val (Value
));
1407 when ANYOF_NPUNCT
=>
1408 for Value
in Class_Byte
'Range loop
1409 if not Is_Printable
(Character'Val (Value
))
1410 or else Is_White_Space
(Character'Val (Value
))
1411 or else Is_Alnum
(Character'Val (Value
))
1413 Set_In_Class
(Bitmap
, Character'Val (Value
));
1418 for Value
in Class_Byte
'Range loop
1419 if Is_Upper
(Character'Val (Value
)) then
1420 Set_In_Class
(Bitmap
, Character'Val (Value
));
1424 when ANYOF_NUPPER
=>
1425 for Value
in Class_Byte
'Range loop
1426 if not Is_Upper
(Character'Val (Value
)) then
1427 Set_In_Class
(Bitmap
, Character'Val (Value
));
1431 when ANYOF_XDIGIT
=>
1432 for Value
in Class_Byte
'Range loop
1433 if Is_Hexadecimal_Digit
(Character'Val (Value
)) then
1434 Set_In_Class
(Bitmap
, Character'Val (Value
));
1438 when ANYOF_NXDIGIT
=>
1439 for Value
in Class_Byte
'Range loop
1440 if not Is_Hexadecimal_Digit
1441 (Character'Val (Value
))
1443 Set_In_Class
(Bitmap
, Character'Val (Value
));
1449 -- Not a character range
1451 elsif not In_Range
then
1452 Last_Value
:= Value
;
1454 if Parse_Pos
> Expression
'Last then
1455 Fail
("Empty character class []");
1458 if Expression
(Parse_Pos
) = '-'
1459 and then Parse_Pos
< Parse_End
1460 and then Expression
(Parse_Pos
+ 1) /= ']'
1462 Parse_Pos
:= Parse_Pos
+ 1;
1464 -- Do we have a range like '\d-a' and '[:space:]-a'
1465 -- which is not a real range
1467 if Named_Class
/= ANYOF_NONE
then
1468 Set_In_Class
(Bitmap
, '-');
1474 Set_In_Class
(Bitmap
, Value
);
1478 -- Else in a character range
1481 if Last_Value
> Value
then
1482 Fail
("Invalid Range [" & Last_Value
'Img
1483 & "-" & Value
'Img & "]");
1486 while Last_Value
<= Value
loop
1487 Set_In_Class
(Bitmap
, Last_Value
);
1488 Last_Value
:= Character'Succ (Last_Value
);
1497 -- Optimize case-insensitive ranges (put the upper case or lower
1498 -- case character into the bitmap)
1500 if (Flags
and Case_Insensitive
) /= 0 then
1501 for C
in Character'Range loop
1502 if Get_From_Class
(Bitmap
, C
) then
1503 Set_In_Class
(Bitmap
, To_Lower
(C
));
1504 Set_In_Class
(Bitmap
, To_Upper
(C
));
1509 -- Optimize inverted classes
1512 for J
in Bitmap
'Range loop
1513 Bitmap
(J
) := not Bitmap
(J
);
1517 Parse_Pos
:= Parse_Pos
+ 1;
1521 IP
:= Emit_Node
(ANYOF
);
1522 Emit_Class
(Bitmap
);
1523 end Parse_Character_Class
;
1529 -- This is a bit tricky due to quoted chars and due to
1530 -- the multiplier characters '*', '+', and '?' that
1531 -- take the SINGLE char previous as their operand.
1533 -- On entry, the character at Parse_Pos - 1 is going to go
1534 -- into the string, no matter what it is. It could be
1535 -- following a \ if Parse_Atom was entered from the '\' case.
1537 -- Basic idea is to pick up a good char in C and examine
1538 -- the next char. If Is_Mult (C) then twiddle, if it's a \
1539 -- then frozzle and if it's another magic char then push C and
1540 -- terminate the string. If none of the above, push C on the
1541 -- string and go around again.
1543 -- Start_Pos is used to remember where "the current character"
1544 -- starts in the string, if due to an Is_Mult we need to back
1545 -- up and put the current char in a separate 1-character string.
1546 -- When Start_Pos is 0, C is the only char in the string;
1547 -- this is used in Is_Mult handling, and in setting the SIMPLE
1550 procedure Parse_Literal
1551 (Expr_Flags
: out Expression_Flags
;
1554 Start_Pos
: Natural := 0;
1556 Length_Ptr
: Pointer
;
1558 Has_Special_Operator
: Boolean := False;
1561 Parse_Pos
:= Parse_Pos
- 1; -- Look at current character
1565 (if (Flags
and Case_Insensitive
) /= 0 then EXACTF
else EXACT
);
1567 Length_Ptr
:= Emit_Ptr
;
1568 Emit_Ptr
:= String_Operand
(IP
);
1572 C
:= Expression
(Parse_Pos
); -- Get current character
1575 when '.' |
'[' |
'(' |
')' |
'|' | ASCII
.LF |
'$' |
'^' =>
1577 if Start_Pos
= 0 then
1578 Start_Pos
:= Parse_Pos
;
1579 Emit
(C
); -- First character is always emitted
1581 exit Parse_Loop
; -- Else we are done
1584 when '?' |
'+' |
'*' |
'{' =>
1586 if Start_Pos
= 0 then
1587 Start_Pos
:= Parse_Pos
;
1588 Emit
(C
); -- First character is always emitted
1590 -- Are we looking at an operator, or is this
1591 -- simply a normal character ?
1593 elsif not Is_Mult
(Parse_Pos
) then
1594 Start_Pos
:= Parse_Pos
;
1598 -- We've got something like "abc?d". Mark this as a
1599 -- special case. What we want to emit is a first
1600 -- constant string for "ab", then one for "c" that will
1601 -- ultimately be transformed with a CURLY operator, A
1602 -- special case has to be handled for "a?", since there
1603 -- is no initial string to emit.
1605 Has_Special_Operator
:= True;
1610 Start_Pos
:= Parse_Pos
;
1612 if Parse_Pos
= Parse_End
then
1613 Fail
("Trailing \");
1616 case Expression (Parse_Pos + 1) is
1617 when 'b' | 'B' | 's' | 'S' | 'd' | 'D'
1618 | 'w' | 'W' | '0' .. '9' | 'G' | 'A'
1620 when 'n' => Emit (ASCII.LF);
1621 when 't' => Emit (ASCII.HT);
1622 when 'r' => Emit (ASCII.CR);
1623 when 'f' => Emit (ASCII.FF);
1624 when 'e' => Emit (ASCII.ESC);
1625 when 'a' => Emit (ASCII.BEL);
1626 when others => Emit (Expression (Parse_Pos + 1));
1629 Parse_Pos := Parse_Pos + 1;
1633 Start_Pos := Parse_Pos;
1637 Parse_Pos := Parse_Pos + 1;
1638 exit Parse_Loop when Parse_Pos > Parse_End
1639 or else Emit_Ptr - Length_Ptr = 254;
1640 end loop Parse_Loop;
1642 -- Is the string followed by a '*+?{' operator ? If yes, and if there
1643 -- is an initial string to emit, do it now.
1645 if Has_Special_Operator
1646 and then Emit_Ptr >= Length_Ptr + Next_Pointer_Bytes
1648 Emit_Ptr := Emit_Ptr - 1;
1649 Parse_Pos := Start_Pos;
1652 if Length_Ptr <= PM.Size then
1653 Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2);
1656 Expr_Flags.Has_Width := True;
1658 -- Slight optimization when there is a single character
1660 if Emit_Ptr = Length_Ptr + 2 then
1661 Expr_Flags.Simple := True;
1669 -- Note that the branching code sequences used for '?' and the
1670 -- general cases of '*' and + are somewhat optimized: they use
1671 -- the same NOTHING node as both the endmarker for their branch
1672 -- list and the body of the last branch. It might seem that
1673 -- this node could be dispensed with entirely, but the endmarker
1674 -- role is not redundant.
1676 procedure Parse_Piece
1677 (Expr_Flags : out Expression_Flags;
1681 New_Flags : Expression_Flags;
1682 Greedy : Boolean := True;
1685 Parse_Atom (New_Flags, IP);
1691 if Parse_Pos > Parse_End
1692 or else not Is_Mult (Parse_Pos)
1694 Expr_Flags := New_Flags;
1698 Op := Expression (Parse_Pos);
1702 then (SP_Start => True, others => False)
1703 else (Has_Width => True, others => False));
1705 -- Detect non greedy operators in the easy cases
1708 and then Parse_Pos + 1 <= Parse_End
1709 and then Expression (Parse_Pos + 1) = '?'
1712 Parse_Pos := Parse_Pos + 1;
1715 -- Generate the byte code
1720 if New_Flags.Simple then
1721 Insert_Operator (STAR, IP, Greedy);
1723 Link_Tail (IP, Emit_Node (WHILEM));
1724 Insert_Curly_Operator
1725 (CURLYX, 0, Max_Curly_Repeat, IP, Greedy);
1726 Link_Tail (IP, Emit_Node (NOTHING));
1731 if New_Flags.Simple then
1732 Insert_Operator (PLUS, IP, Greedy);
1734 Link_Tail (IP, Emit_Node (WHILEM));
1735 Insert_Curly_Operator
1736 (CURLYX, 1, Max_Curly_Repeat, IP, Greedy);
1737 Link_Tail (IP, Emit_Node (NOTHING));
1741 if New_Flags.Simple then
1742 Insert_Curly_Operator (CURLY, 0, 1, IP, Greedy);
1744 Link_Tail (IP, Emit_Node (WHILEM));
1745 Insert_Curly_Operator (CURLYX, 0, 1, IP, Greedy);
1746 Link_Tail (IP, Emit_Node (NOTHING));
1754 Get_Curly_Arguments (Parse_Pos, Min, Max, Greedy);
1756 if New_Flags.Simple then
1757 Insert_Curly_Operator (CURLY, Min, Max, IP, Greedy);
1759 Link_Tail (IP, Emit_Node (WHILEM));
1760 Insert_Curly_Operator (CURLYX, Min, Max, IP, Greedy);
1761 Link_Tail (IP, Emit_Node (NOTHING));
1769 Parse_Pos := Parse_Pos + 1;
1771 if Parse_Pos <= Parse_End
1772 and then Is_Mult (Parse_Pos)
1774 Fail ("nested
*+{");
1778 ---------------------------------
1779 -- Parse_Posix_Character_Class --
1780 ---------------------------------
1782 function Parse_Posix_Character_Class return Std_Class is
1783 Invert : Boolean := False;
1784 Class : Std_Class := ANYOF_NONE;
1785 E : String renames Expression;
1787 -- Class names. Note that code assumes that the length of all
1788 -- classes starting with the same letter have the same length.
1790 Alnum : constant String := "alnum
:]";
1791 Alpha : constant String := "alpha
:]";
1792 Ascii_C : constant String := "ascii
:]";
1793 Cntrl : constant String := "cntrl
:]";
1794 Digit : constant String := "digit
:]";
1795 Graph : constant String := "graph
:]";
1796 Lower : constant String := "lower
:]";
1797 Print : constant String := "print
:]";
1798 Punct : constant String := "punct
:]";
1799 Space : constant String := "space
:]";
1800 Upper : constant String := "upper
:]";
1801 Word : constant String := "word
:]";
1802 Xdigit : constant String := "xdigit
:]";
1805 -- Case of character class specified
1807 if Parse_Pos <= Parse_End
1808 and then Expression (Parse_Pos) = ':'
1810 Parse_Pos := Parse_Pos + 1;
1812 -- Do we have something like: [[:^alpha:]]
1814 if Parse_Pos <= Parse_End
1815 and then Expression (Parse_Pos) = '^'
1818 Parse_Pos := Parse_Pos + 1;
1821 -- Check for class names based on first letter
1823 case Expression (Parse_Pos) is
1826 -- All 'a' classes have the same length (Alnum'Length)
1828 if Parse_Pos + Alnum'Length - 1 <= Parse_End then
1830 E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) = Alnum
1833 (if Invert then ANYOF_NALNUMC else ANYOF_ALNUMC);
1834 Parse_Pos := Parse_Pos + Alnum'Length;
1837 E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) = Alpha
1840 (if Invert then ANYOF_NALPHA else ANYOF_ALPHA);
1841 Parse_Pos := Parse_Pos + Alpha'Length;
1843 elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) =
1847 (if Invert then ANYOF_NASCII else ANYOF_ASCII);
1848 Parse_Pos := Parse_Pos + Ascii_C'Length;
1850 Fail ("Invalid
character class
: " & E);
1854 Fail ("Invalid
character class
: " & E);
1858 if Parse_Pos + Cntrl'Length - 1 <= Parse_End
1860 E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) = Cntrl
1862 Class := (if Invert then ANYOF_NCNTRL else ANYOF_CNTRL);
1863 Parse_Pos := Parse_Pos + Cntrl'Length;
1865 Fail ("Invalid
character class
: " & E);
1869 if Parse_Pos + Digit'Length - 1 <= Parse_End
1871 E (Parse_Pos .. Parse_Pos + Digit'Length - 1) = Digit
1873 Class := (if Invert then ANYOF_NDIGIT else ANYOF_DIGIT);
1874 Parse_Pos := Parse_Pos + Digit'Length;
1878 if Parse_Pos + Graph'Length - 1 <= Parse_End
1880 E (Parse_Pos .. Parse_Pos + Graph'Length - 1) = Graph
1882 Class := (if Invert then ANYOF_NGRAPH else ANYOF_GRAPH);
1883 Parse_Pos := Parse_Pos + Graph'Length;
1885 Fail ("Invalid
character class
: " & E);
1889 if Parse_Pos + Lower'Length - 1 <= Parse_End
1891 E (Parse_Pos .. Parse_Pos + Lower'Length - 1) = Lower
1893 Class := (if Invert then ANYOF_NLOWER else ANYOF_LOWER);
1894 Parse_Pos := Parse_Pos + Lower'Length;
1896 Fail ("Invalid
character class
: " & E);
1901 -- All 'p' classes have the same length
1903 if Parse_Pos + Print'Length - 1 <= Parse_End then
1905 E (Parse_Pos .. Parse_Pos + Print'Length - 1) = Print
1908 (if Invert then ANYOF_NPRINT else ANYOF_PRINT);
1909 Parse_Pos := Parse_Pos + Print'Length;
1912 E (Parse_Pos .. Parse_Pos + Punct'Length - 1) = Punct
1915 (if Invert then ANYOF_NPUNCT else ANYOF_PUNCT);
1916 Parse_Pos := Parse_Pos + Punct'Length;
1919 Fail ("Invalid
character class
: " & E);
1923 Fail ("Invalid
character class
: " & E);
1927 if Parse_Pos + Space'Length - 1 <= Parse_End
1929 E (Parse_Pos .. Parse_Pos + Space'Length - 1) = Space
1931 Class := (if Invert then ANYOF_NSPACE else ANYOF_SPACE);
1932 Parse_Pos := Parse_Pos + Space'Length;
1934 Fail ("Invalid
character class
: " & E);
1938 if Parse_Pos + Upper'Length - 1 <= Parse_End
1940 E (Parse_Pos .. Parse_Pos + Upper'Length - 1) = Upper
1942 Class := (if Invert then ANYOF_NUPPER else ANYOF_UPPER);
1943 Parse_Pos := Parse_Pos + Upper'Length;
1945 Fail ("Invalid
character class
: " & E);
1949 if Parse_Pos + Word'Length - 1 <= Parse_End
1951 E (Parse_Pos .. Parse_Pos + Word'Length - 1) = Word
1953 Class := (if Invert then ANYOF_NALNUM else ANYOF_ALNUM);
1954 Parse_Pos := Parse_Pos + Word'Length;
1956 Fail ("Invalid
character class
: " & E);
1960 if Parse_Pos + Xdigit'Length - 1 <= Parse_End
1962 E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1) = Xdigit
1964 Class := (if Invert then ANYOF_NXDIGIT else ANYOF_XDIGIT);
1965 Parse_Pos := Parse_Pos + Xdigit'Length;
1968 Fail ("Invalid
character class
: " & E);
1972 Fail ("Invalid
character class
: " & E);
1975 -- Character class not specified
1982 end Parse_Posix_Character_Class;
1984 -- Local Declarations
1988 Expr_Flags : Expression_Flags;
1989 pragma Unreferenced (Expr_Flags);
1991 -- Start of processing for Compile
1994 Parse (False, False, Expr_Flags, Result);
1997 Fail ("Couldn
't compile expression
");
2000 Final_Code_Size := Emit_Ptr - 1;
2002 -- Do we want to actually compile the expression, or simply get the
2005 if Emit_Ptr <= PM.Size then
2013 (Expression : String;
2014 Flags : Regexp_Flags := No_Flags) return Pattern_Matcher
2016 -- Assume the compiled regexp will fit in 1000 chars. If it does not we
2017 -- will have to compile a second time once the correct size is known. If
2018 -- it fits, we save a significant amount of time by avoiding the second
2021 Dummy : Pattern_Matcher (1000);
2022 Size : Program_Size;
2025 Compile (Dummy, Expression, Size, Flags);
2027 if Size <= Dummy.Size then
2028 return Pattern_Matcher'
2030 First => Dummy.First,
2031 Anchored => Dummy.Anchored,
2032 Must_Have => Dummy.Must_Have,
2033 Must_Have_Length => Dummy.Must_Have_Length,
2034 Paren_Count => Dummy.Paren_Count,
2035 Flags => Dummy.Flags,
2038 (Dummy.Program'First .. Dummy.Program'First + Size - 1));
2040 -- We have to recompile now that we know the size
2041 -- ??? Can we use Ada 2005's return construct ?
2044 Result : Pattern_Matcher (Size);
2046 Compile (Result, Expression, Size, Flags);
2053 (Matcher : out Pattern_Matcher;
2054 Expression : String;
2055 Flags : Regexp_Flags := No_Flags)
2057 Size : Program_Size;
2060 Compile (Matcher, Expression, Size, Flags);
2062 if Size > Matcher.Size then
2063 raise Expression_Error with "Pattern_Matcher
is too small
";
2067 --------------------
2068 -- Dump_Operation --
2069 --------------------
2071 procedure Dump_Operation
2072 (Program : Program_Data;
2076 Current : Pointer := Index;
2078 Dump_Until (Program, Current, Current + 1, Indent);
2085 procedure Dump_Until
2086 (Program : Program_Data;
2087 Index : in out Pointer;
2090 Do_Print : Boolean := True)
2092 function Image (S : String) return String;
2093 -- Remove leading space
2099 function Image (S : String) return String is
2101 if S (S'First) = ' ' then
2102 return S (S'First + 1 .. S'Last);
2113 Local_Indent : Natural := Indent;
2115 -- Start of processing for Dump_Until
2118 while Index < Till loop
2119 Op := Opcode'Val (Character'Pos ((Program (Index))));
2120 Next := Get_Next (Program, Index);
2124 Point : constant String := Pointer'Image (Index);
2126 Put ((1 .. 4 - Point'Length => ' ')
2128 & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op));
2131 -- Print the parenthesis number
2133 if Op = OPEN or else Op = CLOSE or else Op = REFF then
2134 Put (Image (Natural'Image
2136 (Program (Index + Next_Pointer_Bytes)))));
2139 if Next = Index then
2142 Put (" (" & Image (Pointer'Image (Next)) & ")");
2149 Bitmap : Character_Class;
2150 Last : Character := ASCII.NUL;
2151 Current : Natural := 0;
2152 Current_Char : Character;
2155 Bitmap_Operand (Program, Index, Bitmap);
2160 while Current <= 255 loop
2161 Current_Char := Character'Val (Current);
2163 -- First item in a range
2165 if Get_From_Class (Bitmap, Current_Char) then
2166 Last := Current_Char;
2168 -- Search for the last item in the range
2171 Current := Current + 1;
2172 exit when Current > 255;
2173 Current_Char := Character'Val (Current);
2175 not Get_From_Class (Bitmap, Current_Char);
2178 if not Is_Graphic (Last) then
2184 if Character'Succ (Last) /= Current_Char then
2185 Put ("\-" & Character'Pred (Current_Char));
2189 Current := Current + 1;
2196 Index := Index + Next_Pointer_Bytes + Bitmap'Length;
2199 when EXACT | EXACTF =>
2200 Length := String_Length (Program, Index);
2202 Put (" (" & Image (Program_Size'Image (Length + 1))
2204 & String (Program (String_Operand (Index)
2205 .. String_Operand (Index)
2210 Index := String_Operand (Index) + Length + 1;
2214 when BRANCH | STAR | PLUS =>
2219 Index := Index + Next_Pointer_Bytes;
2220 Dump_Until (Program, Index, Pointer'Min (Next, Till),
2221 Local_Indent + 1, Do_Print);
2223 when CURLY | CURLYX =>
2227 & Image (Natural'Image
2228 (Read_Natural (Program, Index + Next_Pointer_Bytes)))
2230 & Image (Natural'Image (Read_Natural (Program, Index + 5)))
2235 Dump_Until (Program, Index, Pointer'Min (Next, Till),
2236 Local_Indent + 1, Do_Print);
2244 Local_Indent := Local_Indent + 1;
2246 when CLOSE | REFF =>
2254 Local_Indent := Local_Indent - 1;
2258 Index := Index + Next_Pointer_Bytes;
2273 procedure Dump (Self : Pattern_Matcher) is
2274 Program : Program_Data renames Self.Program;
2275 Index : Pointer := Program'First;
2277 -- Start of processing for Dump
2280 Put_Line ("Must start
with (Self
.First
) = "
2281 & Character'Image (Self.First));
2283 if (Self.Flags and Case_Insensitive) /= 0 then
2284 Put_Line (" Case_Insensitive mode
");
2287 if (Self.Flags and Single_Line) /= 0 then
2288 Put_Line (" Single_Line mode
");
2291 if (Self.Flags and Multiple_Lines) /= 0 then
2292 Put_Line (" Multiple_Lines mode
");
2295 Dump_Until (Program, Index, Self.Program'Last + 1, 0);
2298 --------------------
2299 -- Get_From_Class --
2300 --------------------
2302 function Get_From_Class
2303 (Bitmap : Character_Class;
2304 C : Character) return Boolean
2306 Value : constant Class_Byte := Character'Pos (C);
2309 (Bitmap (Value / 8) and Bit_Conversion (Value mod 8)) /= 0;
2316 function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is
2318 return IP + Pointer (Read_Natural (Program, IP + 1));
2325 function Is_Alnum (C : Character) return Boolean is
2327 return Is_Alphanumeric (C) or else C = '_';
2334 function Is_Printable (C : Character) return Boolean is
2336 -- Printable if space or graphic character or other whitespace
2337 -- Other white space includes (HT/LF/VT/FF/CR = codes 9-13)
2339 return C in Character'Val (32) .. Character'Val (126)
2340 or else C in ASCII.HT .. ASCII.CR;
2343 --------------------
2344 -- Is_White_Space --
2345 --------------------
2347 function Is_White_Space (C : Character) return Boolean is
2349 -- Note: HT = 9, LF = 10, VT = 11, FF = 12, CR = 13
2351 return C = ' ' or else C in ASCII.HT .. ASCII.CR;
2359 (Self : Pattern_Matcher;
2361 Matches : out Match_Array;
2362 Data_First : Integer := -1;
2363 Data_Last : Positive := Positive'Last)
2365 Program : Program_Data renames Self.Program; -- Shorter notation
2367 First_In_Data : constant Integer := Integer'Max (Data_First, Data'First);
2368 Last_In_Data : constant Integer := Integer'Min (Data_Last, Data'Last);
2370 -- Global work variables
2372 Input_Pos : Natural; -- String-input pointer
2373 BOL_Pos : Natural; -- Beginning of input, for ^ check
2374 Matched : Boolean := False; -- Until proven True
2376 Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count,
2378 -- Stores the value of all the parenthesis pairs.
2379 -- We do not use directly Matches, so that we can also use back
2380 -- references (REFF) even if Matches is too small.
2382 type Natural_Array is array (Match_Count range <>) of Natural;
2383 Matches_Tmp : Natural_Array (Matches_Full'Range);
2384 -- Save the opening position of parenthesis
2386 Last_Paren : Natural := 0;
2387 -- Last parenthesis seen
2389 Greedy : Boolean := True;
2390 -- True if the next operator should be greedy
2392 type Current_Curly_Record;
2393 type Current_Curly_Access is access all Current_Curly_Record;
2394 type Current_Curly_Record is record
2395 Paren_Floor : Natural; -- How far back to strip parenthesis data
2396 Cur : Integer; -- How many instances of scan we've matched
2397 Min : Natural; -- Minimal number of scans to match
2398 Max : Natural; -- Maximal number of scans to match
2399 Greedy : Boolean; -- Whether to work our way up or down
2400 Scan : Pointer; -- The thing to match
2401 Next : Pointer; -- What has to match after it
2402 Lastloc : Natural; -- Where we started matching this scan
2403 Old_Cc : Current_Curly_Access; -- Before we started this one
2405 -- Data used to handle the curly operator and the plus and star
2406 -- operators for complex expressions.
2408 Current_Curly : Current_Curly_Access := null;
2409 -- The curly currently being processed
2411 -----------------------
2412 -- Local Subprograms --
2413 -----------------------
2415 function Index (Start : Positive; C : Character) return Natural;
2416 -- Find character C in Data starting at Start and return position
2420 Max : Natural := Natural'Last) return Natural;
2421 -- Repeatedly match something simple, report how many
2422 -- It only matches on things of length 1.
2423 -- Starting from Input_Pos, it matches at most Max CURLY.
2425 function Try (Pos : Positive) return Boolean;
2426 -- Try to match at specific point
2428 function Match (IP : Pointer) return Boolean;
2429 -- This is the main matching routine. Conceptually the strategy
2430 -- is simple: check to see whether the current node matches,
2431 -- call self recursively to see whether the rest matches,
2432 -- and then act accordingly.
2434 -- In practice Match makes some effort to avoid recursion, in
2435 -- particular by going through "ordinary
" nodes (that don't
2436 -- need to know whether the rest of the match failed) by
2437 -- using a loop instead of recursion.
2438 -- Why is the above comment part of the spec rather than body ???
2440 function Match_Whilem return Boolean;
2441 -- Return True if a WHILEM matches the Current_Curly
2443 function Recurse_Match (IP : Pointer; From : Natural) return Boolean;
2444 pragma Inline (Recurse_Match);
2445 -- Calls Match recursively. It saves and restores the parenthesis
2446 -- status and location in the input stream correctly, so that
2447 -- backtracking is possible
2449 function Match_Simple_Operator
2453 Greedy : Boolean) return Boolean;
2454 -- Return True it the simple operator (possibly non-greedy) matches
2456 Dump_Indent : Integer := -1;
2457 procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True);
2458 procedure Dump_Error (Msg : String);
2459 -- Debug: print the current context
2461 pragma Inline (Index);
2462 pragma Inline (Repeat);
2464 -- These are two complex functions, but used only once
2466 pragma Inline (Match_Whilem);
2467 pragma Inline (Match_Simple_Operator);
2473 function Index (Start : Positive; C : Character) return Natural is
2475 for J in Start .. Last_In_Data loop
2476 if Data (J) = C then
2488 function Recurse_Match (IP : Pointer; From : Natural) return Boolean is
2489 L : constant Natural := Last_Paren;
2490 Tmp_F : constant Match_Array :=
2491 Matches_Full (From + 1 .. Matches_Full'Last);
2492 Start : constant Natural_Array :=
2493 Matches_Tmp (From + 1 .. Matches_Tmp'Last);
2494 Input : constant Natural := Input_Pos;
2496 Dump_Indent_Save : constant Integer := Dump_Indent;
2504 Matches_Full (Tmp_F'Range) := Tmp_F;
2505 Matches_Tmp (Start'Range) := Start;
2507 Dump_Indent := Dump_Indent_Save;
2515 procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is
2516 Length : constant := 10;
2517 Pos : constant String := Integer'Image (Input_Pos);
2521 Put ((1 .. 5 - Pos'Length => ' '));
2524 .. Integer'Min (Last_In_Data, Input_Pos + Length - 1)));
2525 Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' '));
2532 Dump_Operation (Program, Scan, Indent => Dump_Indent);
2539 procedure Dump_Error (Msg : String) is
2542 Put ((1 .. Dump_Indent * 2 => ' '));
2550 function Match (IP : Pointer) return Boolean is
2551 Scan : Pointer := IP;
2557 Dump_Indent := Dump_Indent + 1;
2561 pragma Assert (Scan /= 0);
2563 -- Determine current opcode and count its usage in debug mode
2565 Op := Opcode'Val (Character'Pos (Program (Scan)));
2567 -- Calculate offset of next instruction. Second character is most
2568 -- significant in Program_Data.
2570 Next := Get_Next (Program, Scan);
2573 Dump_Current (Scan);
2578 Dump_Indent := Dump_Indent - 1;
2579 return True; -- Success
2582 if Program (Next) /= BRANCH then
2583 Next := Operand (Scan); -- No choice, avoid recursion
2587 if Recurse_Match (Operand (Scan), 0) then
2588 Dump_Indent := Dump_Indent - 1;
2592 Scan := Get_Next (Program, Scan);
2593 exit when Scan = 0 or else Program (Scan) /= BRANCH;
2603 exit State_Machine when Input_Pos /= BOL_Pos
2604 and then ((Self.Flags and Multiple_Lines) = 0
2605 or else Data (Input_Pos - 1) /= ASCII.LF);
2608 exit State_Machine when Input_Pos /= BOL_Pos
2609 and then Data (Input_Pos - 1) /= ASCII.LF;
2612 exit State_Machine when Input_Pos /= BOL_Pos;
2616 -- A combination of MEOL and SEOL
2618 if (Self.Flags and Multiple_Lines) = 0 then
2622 exit State_Machine when Input_Pos <= Data'Last;
2624 elsif Input_Pos <= Last_In_Data then
2625 exit State_Machine when Data (Input_Pos) /= ASCII.LF;
2627 exit State_Machine when Last_In_Data /= Data'Last;
2631 if Input_Pos <= Last_In_Data then
2632 exit State_Machine when Data (Input_Pos) /= ASCII.LF;
2634 exit State_Machine when Last_In_Data /= Data'Last;
2639 -- If there is a character before Data'Last (even if
2640 -- Last_In_Data stops before then), we can't have the
2643 exit State_Machine when Input_Pos <= Data'Last;
2645 when BOUND | NBOUND =>
2647 -- Was last char in word ?
2650 N : Boolean := False;
2651 Ln : Boolean := False;
2654 if Input_Pos /= First_In_Data then
2655 N := Is_Alnum (Data (Input_Pos - 1));
2659 (if Input_Pos > Last_In_Data
2661 else Is_Alnum (Data (Input_Pos)));
2675 exit State_Machine when Input_Pos > Last_In_Data
2676 or else not Is_White_Space (Data (Input_Pos));
2677 Input_Pos := Input_Pos + 1;
2680 exit State_Machine when Input_Pos > Last_In_Data
2681 or else Is_White_Space (Data (Input_Pos));
2682 Input_Pos := Input_Pos + 1;
2685 exit State_Machine when Input_Pos > Last_In_Data
2686 or else not Is_Digit (Data (Input_Pos));
2687 Input_Pos := Input_Pos + 1;
2690 exit State_Machine when Input_Pos > Last_In_Data
2691 or else Is_Digit (Data (Input_Pos));
2692 Input_Pos := Input_Pos + 1;
2695 exit State_Machine when Input_Pos > Last_In_Data
2696 or else not Is_Alnum (Data (Input_Pos));
2697 Input_Pos := Input_Pos + 1;
2700 exit State_Machine when Input_Pos > Last_In_Data
2701 or else Is_Alnum (Data (Input_Pos));
2702 Input_Pos := Input_Pos + 1;
2705 exit State_Machine when Input_Pos > Last_In_Data
2706 or else Data (Input_Pos) = ASCII.LF;
2707 Input_Pos := Input_Pos + 1;
2710 exit State_Machine when Input_Pos > Last_In_Data;
2711 Input_Pos := Input_Pos + 1;
2715 Opnd : Pointer := String_Operand (Scan);
2716 Current : Positive := Input_Pos;
2717 Last : constant Pointer :=
2718 Opnd + String_Length (Program, Scan);
2721 while Opnd <= Last loop
2722 exit State_Machine when Current > Last_In_Data
2723 or else Program (Opnd) /= Data (Current);
2724 Current := Current + 1;
2728 Input_Pos := Current;
2733 Opnd : Pointer := String_Operand (Scan);
2734 Current : Positive := Input_Pos;
2736 Last : constant Pointer :=
2737 Opnd + String_Length (Program, Scan);
2740 while Opnd <= Last loop
2741 exit State_Machine when Current > Last_In_Data
2742 or else Program (Opnd) /= To_Lower (Data (Current));
2743 Current := Current + 1;
2747 Input_Pos := Current;
2752 Bitmap : Character_Class;
2754 Bitmap_Operand (Program, Scan, Bitmap);
2755 exit State_Machine when Input_Pos > Last_In_Data
2756 or else not Get_From_Class (Bitmap, Data (Input_Pos));
2757 Input_Pos := Input_Pos + 1;
2762 No : constant Natural :=
2763 Character'Pos (Program (Operand (Scan)));
2765 Matches_Tmp (No) := Input_Pos;
2770 No : constant Natural :=
2771 Character'Pos (Program (Operand (Scan)));
2774 Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1);
2776 if Last_Paren < No then
2783 No : constant Natural :=
2784 Character'Pos (Program (Operand (Scan)));
2789 -- If we haven't seen that parenthesis yet
2791 if Last_Paren < No then
2792 Dump_Indent := Dump_Indent - 1;
2795 Dump_Error ("REFF
: No match
, backtracking
");
2801 Data_Pos := Matches_Full (No).First;
2803 while Data_Pos <= Matches_Full (No).Last loop
2804 if Input_Pos > Last_In_Data
2805 or else Data (Input_Pos) /= Data (Data_Pos)
2807 Dump_Indent := Dump_Indent - 1;
2810 Dump_Error ("REFF
: No match
, backtracking
");
2816 Input_Pos := Input_Pos + 1;
2817 Data_Pos := Data_Pos + 1;
2824 when STAR | PLUS | CURLY =>
2826 Greed : constant Boolean := Greedy;
2829 Result := Match_Simple_Operator (Op, Scan, Next, Greed);
2830 Dump_Indent := Dump_Indent - 1;
2836 -- Looking at something like:
2838 -- 1: CURLYX {n,m} (->4)
2839 -- 2: code for complex thing (->3)
2844 Min : constant Natural :=
2845 Read_Natural (Program, Scan + Next_Pointer_Bytes);
2846 Max : constant Natural :=
2848 (Program, Scan + Next_Pointer_Bytes + 2);
2849 Cc : aliased Current_Curly_Record;
2851 Has_Match : Boolean;
2854 Cc := (Paren_Floor => Last_Paren,
2862 Old_Cc => Current_Curly);
2864 Current_Curly := Cc'Unchecked_Access;
2866 Has_Match := Match (Next - Next_Pointer_Bytes);
2868 -- Start on the WHILEM
2870 Current_Curly := Cc.Old_Cc;
2871 Dump_Indent := Dump_Indent - 1;
2873 if not Has_Match then
2875 Dump_Error ("CURLYX failed
...");
2883 Result := Match_Whilem;
2884 Dump_Indent := Dump_Indent - 1;
2886 if Debug and then not Result then
2887 Dump_Error ("WHILEM
: no match
, backtracking
");
2894 end loop State_Machine;
2897 Dump_Error ("failed
...");
2898 Dump_Indent := Dump_Indent - 1;
2901 -- If we get here, there is no match. For successful matches when EOP
2902 -- is the terminating point.
2907 ---------------------------
2908 -- Match_Simple_Operator --
2909 ---------------------------
2911 function Match_Simple_Operator
2915 Greedy : Boolean) return Boolean
2917 Next_Char : Character := ASCII.NUL;
2918 Next_Char_Known : Boolean := False;
2919 No : Integer; -- Can be negative
2921 Max : Natural := Natural'Last;
2922 Operand_Code : Pointer;
2925 Save : constant Natural := Input_Pos;
2928 -- Lookahead to avoid useless match attempts when we know what
2929 -- character comes next.
2931 if Program (Next) = EXACT then
2932 Next_Char := Program (String_Operand (Next));
2933 Next_Char_Known := True;
2936 -- Find the minimal and maximal values for the operator
2941 Operand_Code := Operand (Scan);
2945 Operand_Code := Operand (Scan);
2948 Min := Read_Natural (Program, Scan + Next_Pointer_Bytes);
2949 Max := Read_Natural (Program, Scan + Next_Pointer_Bytes + 2);
2950 Operand_Code := Scan + 7;
2954 Dump_Current (Operand_Code, Prefix => False);
2957 -- Non greedy operators
2961 -- Test we can repeat at least Min times
2964 No := Repeat (Operand_Code, Min);
2968 Dump_Error ("failed
... matched
" & No'Img & " times
");
2977 -- Find the place where 'next' could work
2979 if Next_Char_Known then
2981 -- Last position to check
2983 if Max = Natural'Last then
2984 Last_Pos := Last_In_Data;
2986 Last_Pos := Input_Pos + Max;
2988 if Last_Pos > Last_In_Data then
2989 Last_Pos := Last_In_Data;
2993 -- Look for the first possible opportunity
2996 Dump_Error ("Next_Char must be
" & Next_Char);
3000 -- Find the next possible position
3002 while Input_Pos <= Last_Pos
3003 and then Data (Input_Pos) /= Next_Char
3005 Input_Pos := Input_Pos + 1;
3008 if Input_Pos > Last_Pos then
3012 -- Check that we still match if we stop at the position we
3016 Num : constant Natural := Input_Pos - Old;
3022 Dump_Error ("Would we still match
at that position?
");
3025 if Repeat (Operand_Code, Num) < Num then
3030 -- Input_Pos now points to the new position
3032 if Match (Get_Next (Program, Scan)) then
3037 Input_Pos := Input_Pos + 1;
3040 -- We do not know what the next character is
3043 while Max >= Min loop
3045 Dump_Error ("Non
-greedy repeat
, N
=" & Min'Img);
3046 Dump_Error ("Do we still match Next
if we stop here?
");
3049 -- If the next character matches
3051 if Recurse_Match (Next, 1) then
3055 Input_Pos := Save + Min;
3057 -- Could not or did not match -- move forward
3059 if Repeat (Operand_Code, 1) /= 0 then
3063 Dump_Error ("Non
-greedy repeat failed
...");
3076 No := Repeat (Operand_Code, Max);
3078 if Debug and then No < Min then
3079 Dump_Error ("failed
... matched
" & No'Img & " times
");
3082 -- ??? Perl has some special code here in case the next
3083 -- instruction is of type EOL, since $ and \Z can match before
3084 -- *and* after newline at the end.
3086 -- ??? Perl has some special code here in case (paren) is True
3088 -- Else, if we don't have any parenthesis
3090 while No >= Min loop
3091 if not Next_Char_Known
3092 or else (Input_Pos <= Last_In_Data
3093 and then Data (Input_Pos) = Next_Char)
3095 if Match (Next) then
3100 -- Could not or did not work, we back up
3103 Input_Pos := Save + No;
3108 end Match_Simple_Operator;
3114 -- This is really hard to understand, because after we match what we
3115 -- are trying to match, we must make sure the rest of the REx is going
3116 -- to match for sure, and to do that we have to go back UP the parse
3117 -- tree by recursing ever deeper. And if it fails, we have to reset
3118 -- our parent's current state that we can try again after backing off.
3120 function Match_Whilem return Boolean is
3121 Cc : constant Current_Curly_Access := Current_Curly;
3123 N : constant Natural := Cc.Cur + 1;
3126 Lastloc : constant Natural := Cc.Lastloc;
3127 -- Detection of 0-len
3130 -- If degenerate scan matches "", assume scan done
3132 if Input_Pos = Cc.Lastloc
3133 and then N >= Cc.Min
3135 -- Temporarily restore the old context, and check that we
3136 -- match was comes after CURLYX.
3138 Current_Curly := Cc.Old_Cc;
3140 if Current_Curly /= null then
3141 Ln := Current_Curly.Cur;
3144 if Match (Cc.Next) then
3148 if Current_Curly /= null then
3149 Current_Curly.Cur := Ln;
3152 Current_Curly := Cc;
3156 -- First, just match a string of min scans
3160 Cc.Lastloc := Input_Pos;
3164 ("Tests that we match
at least
" & Cc.Min'Img & " N
=" & N'Img);
3167 if Match (Cc.Scan) then
3172 Cc.Lastloc := Lastloc;
3175 Dump_Error ("failed
...");
3181 -- Prefer next over scan for minimal matching
3183 if not Cc.Greedy then
3184 Current_Curly := Cc.Old_Cc;
3186 if Current_Curly /= null then
3187 Ln := Current_Curly.Cur;
3190 if Recurse_Match (Cc.Next, Cc.Paren_Floor) then
3194 if Current_Curly /= null then
3195 Current_Curly.Cur := Ln;
3198 Current_Curly := Cc;
3200 -- Maximum greed exceeded ?
3204 Dump_Error ("failed
...");
3209 -- Try scanning more and see if it helps
3211 Cc.Lastloc := Input_Pos;
3214 Dump_Error ("Next failed
, what about Current?
");
3217 if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3222 Cc.Lastloc := Lastloc;
3226 -- Prefer scan over next for maximal matching
3228 if N < Cc.Max then -- more greed allowed ?
3230 Cc.Lastloc := Input_Pos;
3233 Dump_Error ("Recurse
at current position
");
3236 if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3241 -- Failed deeper matches of scan, so see if this one works
3243 Current_Curly := Cc.Old_Cc;
3245 if Current_Curly /= null then
3246 Ln := Current_Curly.Cur;
3250 Dump_Error ("Failed matching
for later positions
");
3253 if Match (Cc.Next) then
3257 if Current_Curly /= null then
3258 Current_Curly.Cur := Ln;
3261 Current_Curly := Cc;
3263 Cc.Lastloc := Lastloc;
3266 Dump_Error ("failed
...");
3278 Max : Natural := Natural'Last) return Natural
3280 Scan : Natural := Input_Pos;
3282 Op : constant Opcode := Opcode'Val (Character'Pos (Program (IP)));
3285 Is_First : Boolean := True;
3286 Bitmap : Character_Class;
3289 if Max = Natural'Last or else Scan + Max - 1 > Last_In_Data then
3290 Last := Last_In_Data;
3292 Last := Scan + Max - 1;
3298 and then Data (Scan) /= ASCII.LF
3308 -- The string has only one character if Repeat was called
3310 C := Program (String_Operand (IP));
3312 and then C = Data (Scan)
3319 -- The string has only one character if Repeat was called
3321 C := Program (String_Operand (IP));
3323 and then To_Lower (C) = Data (Scan)
3330 Bitmap_Operand (Program, IP, Bitmap);
3335 and then Get_From_Class (Bitmap, Data (Scan))
3342 and then Is_Alnum (Data (Scan))
3349 and then not Is_Alnum (Data (Scan))
3356 and then Is_White_Space (Data (Scan))
3363 and then not Is_White_Space (Data (Scan))
3370 and then Is_Digit (Data (Scan))
3377 and then not Is_Digit (Data (Scan))
3383 raise Program_Error;
3386 Count := Scan - Input_Pos;
3395 function Try (Pos : Positive) return Boolean is
3399 Matches_Full := (others => No_Match);
3401 if Match (Program_First) then
3402 Matches_Full (0) := (Pos, Input_Pos - 1);
3409 -- Start of processing for Match
3412 -- Do we have the regexp Never_Match?
3414 if Self.Size = 0 then
3415 Matches := (others => No_Match);
3419 -- If there is a "must appear
" string, look for it
3421 if Self.Must_Have_Length > 0 then
3423 First : constant Character := Program (Self.Must_Have);
3424 Must_First : constant Pointer := Self.Must_Have;
3425 Must_Last : constant Pointer :=
3426 Must_First + Pointer (Self.Must_Have_Length - 1);
3427 Next_Try : Natural := Index (First_In_Data, First);
3431 and then Data (Next_Try .. Next_Try + Self.Must_Have_Length - 1)
3432 = String (Program (Must_First .. Must_Last))
3434 Next_Try := Index (Next_Try + 1, First);
3437 if Next_Try = 0 then
3438 Matches := (others => No_Match);
3439 return; -- Not present
3444 -- Mark beginning of line for ^
3446 BOL_Pos := Data'First;
3448 -- Simplest case first: an anchored match need be tried only once
3450 if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then
3451 Matched := Try (First_In_Data);
3453 elsif Self.Anchored then
3455 Next_Try : Natural := First_In_Data;
3457 -- Test the first position in the buffer
3458 Matched := Try (Next_Try);
3460 -- Else only test after newlines
3463 while Next_Try <= Last_In_Data loop
3464 while Next_Try <= Last_In_Data
3465 and then Data (Next_Try) /= ASCII.LF
3467 Next_Try := Next_Try + 1;
3470 Next_Try := Next_Try + 1;
3472 if Next_Try <= Last_In_Data then
3473 Matched := Try (Next_Try);
3480 elsif Self.First /= ASCII.NUL then
3481 -- We know what char it must start with
3484 Next_Try : Natural := Index (First_In_Data, Self.First);
3487 while Next_Try /= 0 loop
3488 Matched := Try (Next_Try);
3490 Next_Try := Index (Next_Try + 1, Self.First);
3495 -- Messy cases: try all locations (including for the empty string)
3497 Matched := Try (First_In_Data);
3500 for S in First_In_Data + 1 .. Last_In_Data loop
3507 -- Matched has its value
3509 for J in Last_Paren + 1 .. Matches'Last loop
3510 Matches_Full (J) := No_Match;
3513 Matches := Matches_Full (Matches'Range);
3521 (Self : Pattern_Matcher;
3523 Data_First : Integer := -1;
3524 Data_Last : Positive := Positive'Last) return Natural
3526 Matches : Match_Array (0 .. 0);
3529 Match (Self, Data, Matches, Data_First, Data_Last);
3530 if Matches (0) = No_Match then
3531 return Data'First - 1;
3533 return Matches (0).First;
3538 (Self : Pattern_Matcher;
3540 Data_First : Integer := -1;
3541 Data_Last : Positive := Positive'Last) return Boolean
3543 Matches : Match_Array (0 .. 0);
3546 Match (Self, Data, Matches, Data_First, Data_Last);
3547 return Matches (0).First >= Data'First;
3551 (Expression : String;
3553 Matches : out Match_Array;
3554 Size : Program_Size := Auto_Size;
3555 Data_First : Integer := -1;
3556 Data_Last : Positive := Positive'Last)
3558 PM : Pattern_Matcher (Size);
3559 Finalize_Size : Program_Size;
3560 pragma Unreferenced (Finalize_Size);
3563 Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
3565 Compile (PM, Expression, Finalize_Size);
3566 Match (PM, Data, Matches, Data_First, Data_Last);
3575 (Expression : String;
3577 Size : Program_Size := Auto_Size;
3578 Data_First : Integer := -1;
3579 Data_Last : Positive := Positive'Last) return Natural
3581 PM : Pattern_Matcher (Size);
3582 Final_Size : Program_Size;
3583 pragma Unreferenced (Final_Size);
3586 return Match (Compile (Expression), Data, Data_First, Data_Last);
3588 Compile (PM, Expression, Final_Size);
3589 return Match (PM, Data, Data_First, Data_Last);
3598 (Expression : String;
3600 Size : Program_Size := Auto_Size;
3601 Data_First : Integer := -1;
3602 Data_Last : Positive := Positive'Last) return Boolean
3604 Matches : Match_Array (0 .. 0);
3605 PM : Pattern_Matcher (Size);
3606 Final_Size : Program_Size;
3607 pragma Unreferenced (Final_Size);
3610 Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
3612 Compile (PM, Expression, Final_Size);
3613 Match (PM, Data, Matches, Data_First, Data_Last);
3616 return Matches (0).First >= Data'First;
3623 function Operand (P : Pointer) return Pointer is
3625 return P + Next_Pointer_Bytes;
3632 procedure Optimize (Self : in out Pattern_Matcher) is
3634 Program : Program_Data renames Self.Program;
3637 -- Start with safe defaults (no optimization):
3638 -- * No known first character of match
3639 -- * Does not necessarily start at beginning of line
3640 -- * No string known that has to appear in data
3642 Self.First := ASCII.NUL;
3643 Self.Anchored := False;
3644 Self.Must_Have := Program'Last + 1;
3645 Self.Must_Have_Length := 0;
3647 Scan := Program_First; -- First instruction (can be anything)
3649 if Program (Scan) = EXACT then
3650 Self.First := Program (String_Operand (Scan));
3652 elsif Program (Scan) = BOL
3653 or else Program (Scan) = SBOL
3654 or else Program (Scan) = MBOL
3656 Self.Anchored := True;
3664 function Paren_Count (Regexp : Pattern_Matcher) return Match_Count is
3666 return Regexp.Paren_Count;
3673 function Quote (Str : String) return String is
3674 S : String (1 .. Str'Length * 2);
3675 Last : Natural := 0;
3678 for J in Str'Range loop
3680 when '^' | '$' | '|' | '*' | '+' | '?' | '{' |
3681 '}' | '[' | ']' | '(' | ')' | '\' | '.' =>
3683 S (Last + 1) := '\';
3684 S (Last + 2) := Str (J);
3688 S (Last + 1) := Str (J);
3693 return S (1 .. Last);
3700 function Read_Natural
3701 (Program : Program_Data;
3702 IP : Pointer) return Natural
3705 return Character'Pos (Program (IP)) +
3706 256 * Character'Pos (Program (IP + 1));
3713 procedure Reset_Class (Bitmap : out Character_Class) is
3715 Bitmap := (others => 0);
3722 procedure Set_In_Class
3723 (Bitmap : in out Character_Class;
3726 Value : constant Class_Byte := Character'Pos (C);
3728 Bitmap (Value / 8) := Bitmap (Value / 8)
3729 or Bit_Conversion (Value mod 8);
3736 function String_Length
3737 (Program : Program_Data;
3738 P : Pointer) return Program_Size
3741 pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF);
3742 return Character'Pos (Program (P + Next_Pointer_Bytes));
3745 --------------------
3746 -- String_Operand --
3747 --------------------
3749 function String_Operand (P : Pointer) return Pointer is