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-2010, 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 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. --
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. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
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.
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.
44 with System
.IO
; use System
.IO
;
45 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
46 with Ada
.Unchecked_Conversion
;
48 package body System
.Regpat
is
50 Debug
: constant Boolean := False;
51 -- Set to True to activate debug traces. This is normally set to constant
52 -- False to simply delete all the trace code. It is to be edited to True
53 -- for internal debugging of the package.
55 ----------------------------
56 -- Implementation details --
57 ----------------------------
59 -- This is essentially a linear encoding of a nondeterministic
60 -- finite-state machine, also known as syntax charts or
61 -- "railroad normal form" in parsing technology.
63 -- Each node is an opcode plus a "next" pointer, possibly plus an
64 -- operand. "Next" pointers of all nodes except BRANCH implement
65 -- concatenation; a "next" pointer with a BRANCH on both ends of it
66 -- is connecting two alternatives.
68 -- The operand of some types of node is a literal string; for others,
69 -- it is a node leading into a sub-FSM. In particular, the operand of
70 -- a BRANCH node is the first node of the branch.
71 -- (NB this is *not* a tree structure: the tail of the branch connects
72 -- to the thing following the set of BRANCHes).
74 -- You can see the exact byte-compiled version by using the Dump
75 -- subprogram. However, here are a few examples:
77 -- (a|b): 1 : BRANCH (next at 9)
78 -- 4 : EXACT (next at 17) operand=a
79 -- 9 : BRANCH (next at 17)
80 -- 12 : EXACT (next at 17) operand=b
81 -- 17 : EOP (next at 0)
83 -- (ab)*: 1 : CURLYX (next at 25) { 0, 32767}
84 -- 8 : OPEN 1 (next at 12)
85 -- 12 : EXACT (next at 18) operand=ab
86 -- 18 : CLOSE 1 (next at 22)
87 -- 22 : WHILEM (next at 0)
88 -- 25 : NOTHING (next at 28)
89 -- 28 : EOP (next at 0)
95 -- Name Operand? Meaning
97 (EOP
, -- no End of program
98 MINMOD
, -- no Next operator is not greedy
100 -- Classes of characters
102 ANY
, -- no Match any one character except newline
103 SANY
, -- no Match any character, including new line
104 ANYOF
, -- class Match any character in this class
105 EXACT
, -- str Match this string exactly
106 EXACTF
, -- str Match this string (case-folding is one)
107 NOTHING
, -- no Match empty string
108 SPACE
, -- no Match any whitespace character
109 NSPACE
, -- no Match any non-whitespace character
110 DIGIT
, -- no Match any numeric character
111 NDIGIT
, -- no Match any non-numeric character
112 ALNUM
, -- no Match any alphanumeric character
113 NALNUM
, -- no Match any non-alphanumeric character
117 BRANCH
, -- node Match this alternative, or the next
119 -- Simple loops (when the following node is one character in length)
121 STAR
, -- node Match this simple thing 0 or more times
122 PLUS
, -- node Match this simple thing 1 or more times
123 CURLY
, -- 2num node Match this simple thing between n and m times.
127 CURLYX
, -- 2num node Match this complex thing {n,m} times
128 -- The nums are coded on two characters each
130 WHILEM
, -- no Do curly processing and see if rest matches
132 -- Matches after or before a word
134 BOL
, -- no Match "" at beginning of line
135 MBOL
, -- no Same, assuming multiline (match after \n)
136 SBOL
, -- no Same, assuming single line (don't match at \n)
137 EOL
, -- no Match "" at end of line
138 MEOL
, -- no Same, assuming multiline (match before \n)
139 SEOL
, -- no Same, assuming single line (don't match at \n)
141 BOUND
, -- no Match "" at any word boundary
142 NBOUND
, -- no Match "" at any word non-boundary
144 -- Parenthesis groups handling
146 REFF
, -- num Match some already matched string, folded
147 OPEN
, -- num Mark this point in input as start of #n
148 CLOSE
); -- num Analogous to OPEN
150 for Opcode
'Size use 8;
155 -- The set of branches constituting a single choice are hooked
156 -- together with their "next" pointers, since precedence prevents
157 -- anything being concatenated to any individual branch. The
158 -- "next" pointer of the last BRANCH in a choice points to the
159 -- thing following the whole choice. This is also where the
160 -- final "next" pointer of each individual branch points; each
161 -- branch starts with the operand node of a BRANCH node.
164 -- '?', and complex '*' and '+', are implemented with CURLYX.
165 -- branches. Simple cases (one character per match) are implemented with
166 -- STAR and PLUS for speed and to minimize recursive plunges.
169 -- ...are numbered at compile time.
172 -- There are in fact two arguments, the first one is the length (minus
173 -- one of the string argument), coded on one character, the second
174 -- argument is the string itself, coded on length + 1 characters.
176 -- A node is one char of opcode followed by two chars of "next" pointer.
177 -- "Next" pointers are stored as two 8-bit pieces, high order first. The
178 -- value is a positive offset from the opcode of the node containing it.
179 -- An operand, if any, simply follows the node. (Note that much of the
180 -- code generation knows about this implicit relationship.)
182 -- Using two bytes for the "next" pointer is vast overkill for most
183 -- things, but allows patterns to get big without disasters.
185 Next_Pointer_Bytes
: constant := 3;
186 -- Points after the "next pointer" data. An instruction is therefore:
187 -- 1 byte: instruction opcode
188 -- 2 bytes: pointer to next instruction
189 -- * bytes: optional data for the instruction
191 -----------------------
192 -- Character classes --
193 -----------------------
194 -- This is the implementation for character classes ([...]) in the
195 -- syntax for regular expressions. Each character (0..256) has an
196 -- entry into the table. This makes for a very fast matching
199 type Class_Byte
is mod 256;
200 type Character_Class
is array (Class_Byte
range 0 .. 31) of Class_Byte
;
202 type Bit_Conversion_Array
is array (Class_Byte
range 0 .. 7) of Class_Byte
;
203 Bit_Conversion
: constant Bit_Conversion_Array
:=
204 (1, 2, 4, 8, 16, 32, 64, 128);
206 type Std_Class
is (ANYOF_NONE
,
207 ANYOF_ALNUM
, -- Alphanumeric class [a-zA-Z0-9]
209 ANYOF_SPACE
, -- Space class [ \t\n\r\f]
211 ANYOF_DIGIT
, -- Digit class [0-9]
213 ANYOF_ALNUMC
, -- Alphanumeric class [a-zA-Z0-9]
215 ANYOF_ALPHA
, -- Alpha class [a-zA-Z]
217 ANYOF_ASCII
, -- Ascii class (7 bits) 0..127
219 ANYOF_CNTRL
, -- Control class
221 ANYOF_GRAPH
, -- Graphic class
223 ANYOF_LOWER
, -- Lower case class [a-z]
225 ANYOF_PRINT
, -- printable class
229 ANYOF_UPPER
, -- Upper case class [A-Z]
231 ANYOF_XDIGIT
, -- Hexadecimal digit
235 procedure Set_In_Class
236 (Bitmap
: in out Character_Class
;
238 -- Set the entry to True for C in the class Bitmap
240 function Get_From_Class
241 (Bitmap
: Character_Class
;
242 C
: Character) return Boolean;
243 -- Return True if the entry is set for C in the class Bitmap
245 procedure Reset_Class
(Bitmap
: out Character_Class
);
246 -- Clear all the entries in the class Bitmap
248 pragma Inline
(Set_In_Class
);
249 pragma Inline
(Get_From_Class
);
250 pragma Inline
(Reset_Class
);
252 -----------------------
253 -- Local Subprograms --
254 -----------------------
256 function "=" (Left
: Character; Right
: Opcode
) return Boolean;
258 function Is_Alnum
(C
: Character) return Boolean;
259 -- Return True if C is an alphanum character or an underscore ('_')
261 function Is_White_Space
(C
: Character) return Boolean;
262 -- Return True if C is a whitespace character
264 function Is_Printable
(C
: Character) return Boolean;
265 -- Return True if C is a printable character
267 function Operand
(P
: Pointer
) return Pointer
;
268 -- Return a pointer to the first operand of the node at P
270 function String_Length
271 (Program
: Program_Data
;
272 P
: Pointer
) return Program_Size
;
273 -- Return the length of the string argument of the node at P
275 function String_Operand
(P
: Pointer
) return Pointer
;
276 -- Return a pointer to the string argument of the node at P
278 procedure Bitmap_Operand
279 (Program
: Program_Data
;
281 Op
: out Character_Class
);
282 -- Return a pointer to the string argument of the node at P
285 (Program
: Program_Data
;
286 IP
: Pointer
) return Pointer
;
287 -- Dig the next instruction pointer out of a node
289 procedure Optimize
(Self
: in out Pattern_Matcher
);
290 -- Optimize a Pattern_Matcher by noting certain special cases
292 function Read_Natural
293 (Program
: Program_Data
;
294 IP
: Pointer
) return Natural;
295 -- Return the 2-byte natural coded at position IP
297 -- All of the subprograms above are tiny and should be inlined
300 pragma Inline
(Is_Alnum
);
301 pragma Inline
(Is_White_Space
);
302 pragma Inline
(Get_Next
);
303 pragma Inline
(Operand
);
304 pragma Inline
(Read_Natural
);
305 pragma Inline
(String_Length
);
306 pragma Inline
(String_Operand
);
308 type Expression_Flags
is record
309 Has_Width
, -- Known never to match null string
310 Simple
, -- Simple enough to be STAR/PLUS operand
311 SP_Start
: Boolean; -- Starts with * or +
314 Worst_Expression
: constant Expression_Flags
:= (others => False);
318 (Program
: Program_Data
;
319 Index
: in out Pointer
;
322 Do_Print
: Boolean := True);
323 -- Dump the program until the node Till (not included) is met. Every line
324 -- is indented with Index spaces at the beginning Dumps till the end if
327 procedure Dump_Operation
328 (Program
: Program_Data
;
331 -- Same as above, but only dumps a single operation, and compute its
332 -- indentation from the program.
338 function "=" (Left
: Character; Right
: Opcode
) return Boolean is
340 return Character'Pos (Left
) = Opcode
'Pos (Right
);
347 procedure Bitmap_Operand
348 (Program
: Program_Data
;
350 Op
: out Character_Class
)
352 function Convert
is new Ada
.Unchecked_Conversion
353 (Program_Data
, Character_Class
);
356 Op
(0 .. 31) := Convert
(Program
(P
+ Next_Pointer_Bytes
.. P
+ 34));
364 (Matcher
: out Pattern_Matcher
;
366 Final_Code_Size
: out Program_Size
;
367 Flags
: Regexp_Flags
:= No_Flags
)
369 -- We can't allocate space until we know how big the compiled form
370 -- will be, but we can't compile it (and thus know how big it is)
371 -- until we've got a place to put the code. So we cheat: we compile
372 -- it twice, once with code generation turned off and size counting
373 -- turned on, and once "for real".
375 -- This also means that we don't allocate space until we are sure
376 -- that the thing really will compile successfully, and we never
377 -- have to move the code and thus invalidate pointers into it.
379 -- Beware that the optimization-preparation code in here knows
380 -- about some of the structure of the compiled regexp.
382 PM
: Pattern_Matcher
renames Matcher
;
383 Program
: Program_Data
renames PM
.Program
;
385 Emit_Ptr
: Pointer
:= Program_First
;
387 Parse_Pos
: Natural := Expression
'First; -- Input-scan pointer
388 Parse_End
: constant Natural := Expression
'Last;
390 ----------------------------
391 -- Subprograms for Create --
392 ----------------------------
394 procedure Emit
(B
: Character);
395 -- Output the Character B to the Program. If code-generation is
396 -- disabled, simply increments the program counter.
398 function Emit_Node
(Op
: Opcode
) return Pointer
;
399 -- If code-generation is enabled, Emit_Node outputs the
400 -- opcode Op and reserves space for a pointer to the next node.
401 -- Return value is the location of new opcode, i.e. old Emit_Ptr.
403 procedure Emit_Natural
(IP
: Pointer
; N
: Natural);
404 -- Split N on two characters at position IP
406 procedure Emit_Class
(Bitmap
: Character_Class
);
407 -- Emits a character class
409 procedure Case_Emit
(C
: Character);
410 -- Emit C, after converting is to lower-case if the regular
411 -- expression is case insensitive.
414 (Parenthesized
: Boolean;
415 Flags
: out Expression_Flags
;
417 -- Parse regular expression, i.e. main body or parenthesized thing
418 -- Caller must absorb opening parenthesis.
420 procedure Parse_Branch
421 (Flags
: out Expression_Flags
;
424 -- Implements the concatenation operator and handles '|'
425 -- First should be true if this is the first item of the alternative.
427 procedure Parse_Piece
428 (Expr_Flags
: out Expression_Flags
;
430 -- Parse something followed by possible [*+?]
433 (Expr_Flags
: out Expression_Flags
;
435 -- Parse_Atom is the lowest level parse procedure.
437 -- Optimization: Gobbles an entire sequence of ordinary characters so
438 -- that it can turn them into a single node, which is smaller to store
439 -- and faster to run. Backslashed characters are exceptions, each
440 -- becoming a separate node; the code is simpler that way and it's
443 procedure Insert_Operator
446 Greedy
: Boolean := True);
447 -- Insert_Operator inserts an operator in front of an already-emitted
448 -- operand and relocates the operand. This applies to PLUS and STAR.
449 -- If Minmod is True, then the operator is non-greedy.
451 function Insert_Operator_Before
455 Opsize
: Pointer
) return Pointer
;
456 -- Insert an operator before Operand (and move the latter forward in the
457 -- program). Opsize is the size needed to represent the operator. This
458 -- returns the position at which the operator was inserted, and moves
459 -- Emit_Ptr after the new position of the operand.
461 procedure Insert_Curly_Operator
466 Greedy
: Boolean := True);
467 -- Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}).
468 -- If Minmod is True, then the operator is non-greedy.
470 procedure Link_Tail
(P
, Val
: Pointer
);
471 -- Link_Tail sets the next-pointer at the end of a node chain
473 procedure Link_Operand_Tail
(P
, Val
: Pointer
);
474 -- Link_Tail on operand of first argument; noop if operand-less
476 procedure Fail
(M
: String);
477 pragma No_Return
(Fail
);
478 -- Fail with a diagnostic message, if possible
480 function Is_Curly_Operator
(IP
: Natural) return Boolean;
481 -- Return True if IP is looking at a '{' that is the beginning
482 -- of a curly operator, i.e. it matches {\d+,?\d*}
484 function Is_Mult
(IP
: Natural) return Boolean;
485 -- Return True if C is a regexp multiplier: '+', '*' or '?'
487 procedure Get_Curly_Arguments
491 Greedy
: out Boolean);
492 -- Parse the argument list for a curly operator.
493 -- It is assumed that IP is indeed pointing at a valid operator.
494 -- So what is IP and how come IP is not referenced in the body ???
496 procedure Parse_Character_Class
(IP
: out Pointer
);
497 -- Parse a character class.
498 -- The calling subprogram should consume the opening '[' before.
500 procedure Parse_Literal
501 (Expr_Flags
: out Expression_Flags
;
503 -- Parse_Literal encodes a string of characters to be matched exactly
505 function Parse_Posix_Character_Class
return Std_Class
;
506 -- Parse a posix character class, like [:alpha:] or [:^alpha:].
507 -- The caller is supposed to absorb the opening [.
509 pragma Inline
(Is_Mult
);
510 pragma Inline
(Emit_Natural
);
511 pragma Inline
(Parse_Character_Class
); -- since used only once
517 procedure Case_Emit
(C
: Character) is
519 if (Flags
and Case_Insensitive
) /= 0 then
523 -- Dump current character
533 procedure Emit
(B
: Character) is
535 if Emit_Ptr
<= PM
.Size
then
536 Program
(Emit_Ptr
) := B
;
539 Emit_Ptr
:= Emit_Ptr
+ 1;
546 procedure Emit_Class
(Bitmap
: Character_Class
) is
547 subtype Program31
is Program_Data
(0 .. 31);
549 function Convert
is new Ada
.Unchecked_Conversion
550 (Character_Class
, Program31
);
553 -- What is the mysterious constant 31 here??? Can't it be expressed
554 -- symbolically (size of integer - 1 or some such???). In any case
555 -- it should be declared as a constant (and referenced presumably
556 -- as this constant + 1 below.
558 if Emit_Ptr
+ 31 <= PM
.Size
then
559 Program
(Emit_Ptr
.. Emit_Ptr
+ 31) := Convert
(Bitmap
);
562 Emit_Ptr
:= Emit_Ptr
+ 32;
569 procedure Emit_Natural
(IP
: Pointer
; N
: Natural) is
571 if IP
+ 1 <= PM
.Size
then
572 Program
(IP
+ 1) := Character'Val (N
/ 256);
573 Program
(IP
) := Character'Val (N
mod 256);
581 function Emit_Node
(Op
: Opcode
) return Pointer
is
582 Result
: constant Pointer
:= Emit_Ptr
;
585 if Emit_Ptr
+ 2 <= PM
.Size
then
586 Program
(Emit_Ptr
) := Character'Val (Opcode
'Pos (Op
));
587 Program
(Emit_Ptr
+ 1) := ASCII
.NUL
;
588 Program
(Emit_Ptr
+ 2) := ASCII
.NUL
;
591 Emit_Ptr
:= Emit_Ptr
+ Next_Pointer_Bytes
;
599 procedure Fail
(M
: String) is
601 raise Expression_Error
with M
;
604 -------------------------
605 -- Get_Curly_Arguments --
606 -------------------------
608 procedure Get_Curly_Arguments
612 Greedy
: out Boolean)
614 pragma Unreferenced
(IP
);
616 Save_Pos
: Natural := Parse_Pos
+ 1;
620 Max
:= Max_Curly_Repeat
;
622 while Expression
(Parse_Pos
) /= '}'
623 and then Expression
(Parse_Pos
) /= ','
625 Parse_Pos
:= Parse_Pos
+ 1;
628 Min
:= Natural'Value (Expression
(Save_Pos
.. Parse_Pos
- 1));
630 if Expression
(Parse_Pos
) = ',' then
631 Save_Pos
:= Parse_Pos
+ 1;
632 while Expression
(Parse_Pos
) /= '}' loop
633 Parse_Pos
:= Parse_Pos
+ 1;
636 if Save_Pos
/= Parse_Pos
then
637 Max
:= Natural'Value (Expression
(Save_Pos
.. Parse_Pos
- 1));
644 if Parse_Pos
< Expression
'Last
645 and then Expression
(Parse_Pos
+ 1) = '?'
648 Parse_Pos
:= Parse_Pos
+ 1;
653 end Get_Curly_Arguments
;
655 ---------------------------
656 -- Insert_Curly_Operator --
657 ---------------------------
659 procedure Insert_Curly_Operator
664 Greedy
: Boolean := True)
668 Old
:= Insert_Operator_Before
(Op
, Operand
, Greedy
, Opsize
=> 7);
669 Emit_Natural
(Old
+ Next_Pointer_Bytes
, Min
);
670 Emit_Natural
(Old
+ Next_Pointer_Bytes
+ 2, Max
);
671 end Insert_Curly_Operator
;
673 ----------------------------
674 -- Insert_Operator_Before --
675 ----------------------------
677 function Insert_Operator_Before
681 Opsize
: Pointer
) return Pointer
683 Dest
: constant Pointer
:= Emit_Ptr
;
685 Size
: Pointer
:= Opsize
;
688 -- If not greedy, we have to emit another opcode first
691 Size
:= Size
+ Next_Pointer_Bytes
;
694 -- Move the operand in the byte-compilation, so that we can insert
695 -- the operator before it.
697 if Emit_Ptr
+ Size
<= PM
.Size
then
698 Program
(Operand
+ Size
.. Emit_Ptr
+ Size
) :=
699 Program
(Operand
.. Emit_Ptr
);
702 -- Insert the operator at the position previously occupied by the
708 Old
:= Emit_Node
(MINMOD
);
709 Link_Tail
(Old
, Old
+ Next_Pointer_Bytes
);
712 Old
:= Emit_Node
(Op
);
713 Emit_Ptr
:= Dest
+ Size
;
715 end Insert_Operator_Before
;
717 ---------------------
718 -- Insert_Operator --
719 ---------------------
721 procedure Insert_Operator
724 Greedy
: Boolean := True)
727 pragma Warnings
(Off
, Discard
);
729 Discard
:= Insert_Operator_Before
730 (Op
, Operand
, Greedy
, Opsize
=> Next_Pointer_Bytes
);
733 -----------------------
734 -- Is_Curly_Operator --
735 -----------------------
737 function Is_Curly_Operator
(IP
: Natural) return Boolean is
738 Scan
: Natural := IP
;
741 if Expression
(Scan
) /= '{'
742 or else Scan
+ 2 > Expression
'Last
743 or else not Is_Digit
(Expression
(Scan
+ 1))
755 if Scan
> Expression
'Last then
759 exit when not Is_Digit
(Expression
(Scan
));
762 if Expression
(Scan
) = ',' then
766 if Scan
> Expression
'Last then
770 exit when not Is_Digit
(Expression
(Scan
));
774 return Expression
(Scan
) = '}';
775 end Is_Curly_Operator
;
781 function Is_Mult
(IP
: Natural) return Boolean is
782 C
: constant Character := Expression
(IP
);
788 or else (C
= '{' and then Is_Curly_Operator
(IP
));
791 -----------------------
792 -- Link_Operand_Tail --
793 -----------------------
795 procedure Link_Operand_Tail
(P
, Val
: Pointer
) is
797 if P
<= PM
.Size
and then Program
(P
) = BRANCH
then
798 Link_Tail
(Operand
(P
), Val
);
800 end Link_Operand_Tail
;
806 procedure Link_Tail
(P
, Val
: Pointer
) is
812 -- Find last node (the size of the pattern matcher might be too
813 -- small, so don't try to read past its end).
816 while Scan
+ Next_Pointer_Bytes
<= PM
.Size
loop
817 Temp
:= Get_Next
(Program
, Scan
);
818 exit when Temp
= Scan
;
822 Offset
:= Val
- Scan
;
824 Emit_Natural
(Scan
+ 1, Natural (Offset
));
831 -- Combining parenthesis handling with the base level of regular
832 -- expression is a trifle forced, but the need to tie the tails of the
833 -- the branches to what follows makes it hard to avoid.
836 (Parenthesized
: Boolean;
837 Flags
: out Expression_Flags
;
840 E
: String renames Expression
;
844 New_Flags
: Expression_Flags
;
845 Have_Branch
: Boolean := False;
848 Flags
:= (Has_Width
=> True, others => False); -- Tentatively
850 -- Make an OPEN node, if parenthesized
852 if Parenthesized
then
853 if Matcher
.Paren_Count
> Max_Paren_Count
then
854 Fail
("too many ()");
857 Par_No
:= Matcher
.Paren_Count
+ 1;
858 Matcher
.Paren_Count
:= Matcher
.Paren_Count
+ 1;
859 IP
:= Emit_Node
(OPEN
);
860 Emit
(Character'Val (Par_No
));
867 -- Pick up the branches, linking them together
869 Parse_Branch
(New_Flags
, True, Br
);
876 if Parse_Pos
<= Parse_End
877 and then E
(Parse_Pos
) = '|'
879 Insert_Operator
(BRANCH
, Br
);
884 Link_Tail
(IP
, Br
); -- OPEN -> first
889 if not New_Flags
.Has_Width
then
890 Flags
.Has_Width
:= False;
893 Flags
.SP_Start
:= Flags
.SP_Start
or else New_Flags
.SP_Start
;
895 while Parse_Pos
<= Parse_End
896 and then (E
(Parse_Pos
) = '|')
898 Parse_Pos
:= Parse_Pos
+ 1;
899 Parse_Branch
(New_Flags
, False, Br
);
906 Link_Tail
(IP
, Br
); -- BRANCH -> BRANCH
908 if not New_Flags
.Has_Width
then
909 Flags
.Has_Width
:= False;
912 Flags
.SP_Start
:= Flags
.SP_Start
or else New_Flags
.SP_Start
;
915 -- Make a closing node, and hook it on the end
917 if Parenthesized
then
918 Ender
:= Emit_Node
(CLOSE
);
919 Emit
(Character'Val (Par_No
));
921 Ender
:= Emit_Node
(EOP
);
924 Link_Tail
(IP
, Ender
);
926 if Have_Branch
and then Emit_Ptr
<= PM
.Size
then
928 -- Hook the tails of the branches to the closing node
932 Link_Operand_Tail
(Br
, Ender
);
933 Br2
:= Get_Next
(Program
, Br
);
939 -- Check for proper termination
941 if Parenthesized
then
942 if Parse_Pos
> Parse_End
or else E
(Parse_Pos
) /= ')' then
943 Fail
("unmatched ()");
946 Parse_Pos
:= Parse_Pos
+ 1;
948 elsif Parse_Pos
<= Parse_End
then
949 if E
(Parse_Pos
) = ')' then
950 Fail
("unmatched ()");
952 Fail
("junk on end"); -- "Can't happen"
962 (Expr_Flags
: out Expression_Flags
;
968 -- Tentatively set worst expression case
970 Expr_Flags
:= Worst_Expression
;
972 C
:= Expression
(Parse_Pos
);
973 Parse_Pos
:= Parse_Pos
+ 1;
979 (if (Flags
and Multiple_Lines
) /= 0 then MBOL
980 elsif (Flags
and Single_Line
) /= 0 then SBOL
986 (if (Flags
and Multiple_Lines
) /= 0 then MEOL
987 elsif (Flags
and Single_Line
) /= 0 then SEOL
993 (if (Flags
and Single_Line
) /= 0 then SANY
else ANY
);
995 Expr_Flags
.Has_Width
:= True;
996 Expr_Flags
.Simple
:= True;
999 Parse_Character_Class
(IP
);
1000 Expr_Flags
.Has_Width
:= True;
1001 Expr_Flags
.Simple
:= True;
1005 New_Flags
: Expression_Flags
;
1008 Parse
(True, New_Flags
, IP
);
1014 Expr_Flags
.Has_Width
:=
1015 Expr_Flags
.Has_Width
or else New_Flags
.Has_Width
;
1016 Expr_Flags
.SP_Start
:=
1017 Expr_Flags
.SP_Start
or else New_Flags
.SP_Start
;
1020 when '|' | ASCII
.LF |
')' =>
1021 Fail
("internal urp"); -- Supposed to be caught earlier
1023 when '?' |
'+' |
'*' =>
1024 Fail
(C
& " follows nothing");
1027 if Is_Curly_Operator
(Parse_Pos
- 1) then
1028 Fail
(C
& " follows nothing");
1030 Parse_Literal
(Expr_Flags
, IP
);
1034 if Parse_Pos
> Parse_End
then
1035 Fail
("trailing \");
1038 Parse_Pos := Parse_Pos + 1;
1040 case Expression (Parse_Pos - 1) is
1042 IP := Emit_Node (BOUND);
1045 IP := Emit_Node (NBOUND);
1048 IP := Emit_Node (SPACE);
1049 Expr_Flags.Simple := True;
1050 Expr_Flags.Has_Width := True;
1053 IP := Emit_Node (NSPACE);
1054 Expr_Flags.Simple := True;
1055 Expr_Flags.Has_Width := True;
1058 IP := Emit_Node (DIGIT);
1059 Expr_Flags.Simple := True;
1060 Expr_Flags.Has_Width := True;
1063 IP := Emit_Node (NDIGIT);
1064 Expr_Flags.Simple := True;
1065 Expr_Flags.Has_Width := True;
1068 IP := Emit_Node (ALNUM);
1069 Expr_Flags.Simple := True;
1070 Expr_Flags.Has_Width := True;
1073 IP := Emit_Node (NALNUM);
1074 Expr_Flags.Simple := True;
1075 Expr_Flags.Has_Width := True;
1078 IP := Emit_Node (SBOL);
1081 IP := Emit_Node (SEOL);
1084 IP := Emit_Node (REFF);
1087 Save : constant Natural := Parse_Pos - 1;
1090 while Parse_Pos <= Expression'Last
1091 and then Is_Digit (Expression (Parse_Pos))
1093 Parse_Pos := Parse_Pos + 1;
1096 Emit (Character'Val (Natural'Value
1097 (Expression (Save .. Parse_Pos - 1))));
1101 Parse_Pos := Parse_Pos - 1;
1102 Parse_Literal (Expr_Flags, IP);
1106 Parse_Literal (Expr_Flags, IP);
1114 procedure Parse_Branch
1115 (Flags : out Expression_Flags;
1119 E : String renames Expression;
1122 New_Flags : Expression_Flags;
1125 pragma Warnings (Off, Discard);
1128 Flags := Worst_Expression; -- Tentatively
1129 IP := (if First then Emit_Ptr else Emit_Node (BRANCH));
1132 while Parse_Pos <= Parse_End
1133 and then E (Parse_Pos) /= ')'
1134 and then E (Parse_Pos) /= ASCII.LF
1135 and then E (Parse_Pos) /= '|'
1137 Parse_Piece (New_Flags, Last);
1144 Flags.Has_Width := Flags.Has_Width or else New_Flags.Has_Width;
1146 if Chain = 0 then -- First piece
1147 Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start;
1149 Link_Tail (Chain, Last);
1155 -- Case where loop ran zero CURLY
1158 Discard := Emit_Node (NOTHING);
1162 ---------------------------
1163 -- Parse_Character_Class --
1164 ---------------------------
1166 procedure Parse_Character_Class (IP : out Pointer) is
1167 Bitmap : Character_Class;
1168 Invert : Boolean := False;
1169 In_Range : Boolean := False;
1170 Named_Class : Std_Class := ANYOF_NONE;
1172 Last_Value : Character := ASCII.NUL;
1175 Reset_Class (Bitmap);
1177 -- Do we have an invert character class ?
1179 if Parse_Pos <= Parse_End
1180 and then Expression (Parse_Pos) = '^'
1183 Parse_Pos := Parse_Pos + 1;
1186 -- First character can be ] or - without closing the class
1188 if Parse_Pos <= Parse_End
1189 and then (Expression (Parse_Pos) = ']'
1190 or else Expression (Parse_Pos) = '-')
1192 Set_In_Class (Bitmap, Expression (Parse_Pos));
1193 Parse_Pos := Parse_Pos + 1;
1196 -- While we don't have the end of the class
1198 while Parse_Pos <= Parse_End
1199 and then Expression (Parse_Pos) /= ']'
1201 Named_Class := ANYOF_NONE;
1202 Value := Expression (Parse_Pos);
1203 Parse_Pos := Parse_Pos + 1;
1205 -- Do we have a Posix character class
1207 Named_Class := Parse_Posix_Character_Class;
1209 elsif Value = '\' then
1210 if Parse_Pos = Parse_End then
1211 Fail ("Trailing
\");
1213 Value
:= Expression
(Parse_Pos
);
1214 Parse_Pos
:= Parse_Pos
+ 1;
1217 when 'w' => Named_Class
:= ANYOF_ALNUM
;
1218 when 'W' => Named_Class
:= ANYOF_NALNUM
;
1219 when 's' => Named_Class
:= ANYOF_SPACE
;
1220 when 'S' => Named_Class
:= ANYOF_NSPACE
;
1221 when 'd' => Named_Class
:= ANYOF_DIGIT
;
1222 when 'D' => Named_Class
:= ANYOF_NDIGIT
;
1223 when 'n' => Value
:= ASCII
.LF
;
1224 when 'r' => Value
:= ASCII
.CR
;
1225 when 't' => Value
:= ASCII
.HT
;
1226 when 'f' => Value
:= ASCII
.FF
;
1227 when 'e' => Value
:= ASCII
.ESC
;
1228 when 'a' => Value
:= ASCII
.BEL
;
1230 -- when 'x' => ??? hexadecimal value
1231 -- when 'c' => ??? control character
1232 -- when '0'..'9' => ??? octal character
1234 when others => null;
1238 -- Do we have a character class?
1240 if Named_Class
/= ANYOF_NONE
then
1242 -- A range like 'a-\d' or 'a-[:digit:] is not a range
1245 Set_In_Class
(Bitmap
, Last_Value
);
1246 Set_In_Class
(Bitmap
, '-');
1253 when ANYOF_NONE
=> null;
1255 when ANYOF_ALNUM | ANYOF_ALNUMC
=>
1256 for Value
in Class_Byte
'Range loop
1257 if Is_Alnum
(Character'Val (Value
)) then
1258 Set_In_Class
(Bitmap
, Character'Val (Value
));
1262 when ANYOF_NALNUM | ANYOF_NALNUMC
=>
1263 for Value
in Class_Byte
'Range loop
1264 if not Is_Alnum
(Character'Val (Value
)) then
1265 Set_In_Class
(Bitmap
, Character'Val (Value
));
1270 for Value
in Class_Byte
'Range loop
1271 if Is_White_Space
(Character'Val (Value
)) then
1272 Set_In_Class
(Bitmap
, Character'Val (Value
));
1276 when ANYOF_NSPACE
=>
1277 for Value
in Class_Byte
'Range loop
1278 if not Is_White_Space
(Character'Val (Value
)) then
1279 Set_In_Class
(Bitmap
, Character'Val (Value
));
1284 for Value
in Class_Byte
'Range loop
1285 if Is_Digit
(Character'Val (Value
)) then
1286 Set_In_Class
(Bitmap
, Character'Val (Value
));
1290 when ANYOF_NDIGIT
=>
1291 for Value
in Class_Byte
'Range loop
1292 if not Is_Digit
(Character'Val (Value
)) then
1293 Set_In_Class
(Bitmap
, Character'Val (Value
));
1298 for Value
in Class_Byte
'Range loop
1299 if Is_Letter
(Character'Val (Value
)) then
1300 Set_In_Class
(Bitmap
, Character'Val (Value
));
1304 when ANYOF_NALPHA
=>
1305 for Value
in Class_Byte
'Range loop
1306 if not Is_Letter
(Character'Val (Value
)) then
1307 Set_In_Class
(Bitmap
, Character'Val (Value
));
1312 for Value
in 0 .. 127 loop
1313 Set_In_Class
(Bitmap
, Character'Val (Value
));
1316 when ANYOF_NASCII
=>
1317 for Value
in 128 .. 255 loop
1318 Set_In_Class
(Bitmap
, Character'Val (Value
));
1322 for Value
in Class_Byte
'Range loop
1323 if Is_Control
(Character'Val (Value
)) then
1324 Set_In_Class
(Bitmap
, Character'Val (Value
));
1328 when ANYOF_NCNTRL
=>
1329 for Value
in Class_Byte
'Range loop
1330 if not Is_Control
(Character'Val (Value
)) then
1331 Set_In_Class
(Bitmap
, Character'Val (Value
));
1336 for Value
in Class_Byte
'Range loop
1337 if Is_Graphic
(Character'Val (Value
)) then
1338 Set_In_Class
(Bitmap
, Character'Val (Value
));
1342 when ANYOF_NGRAPH
=>
1343 for Value
in Class_Byte
'Range loop
1344 if not Is_Graphic
(Character'Val (Value
)) then
1345 Set_In_Class
(Bitmap
, Character'Val (Value
));
1350 for Value
in Class_Byte
'Range loop
1351 if Is_Lower
(Character'Val (Value
)) then
1352 Set_In_Class
(Bitmap
, Character'Val (Value
));
1356 when ANYOF_NLOWER
=>
1357 for Value
in Class_Byte
'Range loop
1358 if not Is_Lower
(Character'Val (Value
)) then
1359 Set_In_Class
(Bitmap
, Character'Val (Value
));
1364 for Value
in Class_Byte
'Range loop
1365 if Is_Printable
(Character'Val (Value
)) then
1366 Set_In_Class
(Bitmap
, Character'Val (Value
));
1370 when ANYOF_NPRINT
=>
1371 for Value
in Class_Byte
'Range loop
1372 if not Is_Printable
(Character'Val (Value
)) then
1373 Set_In_Class
(Bitmap
, Character'Val (Value
));
1378 for Value
in Class_Byte
'Range loop
1379 if Is_Printable
(Character'Val (Value
))
1380 and then not Is_White_Space
(Character'Val (Value
))
1381 and then not Is_Alnum
(Character'Val (Value
))
1383 Set_In_Class
(Bitmap
, Character'Val (Value
));
1387 when ANYOF_NPUNCT
=>
1388 for Value
in Class_Byte
'Range loop
1389 if not Is_Printable
(Character'Val (Value
))
1390 or else Is_White_Space
(Character'Val (Value
))
1391 or else Is_Alnum
(Character'Val (Value
))
1393 Set_In_Class
(Bitmap
, Character'Val (Value
));
1398 for Value
in Class_Byte
'Range loop
1399 if Is_Upper
(Character'Val (Value
)) then
1400 Set_In_Class
(Bitmap
, Character'Val (Value
));
1404 when ANYOF_NUPPER
=>
1405 for Value
in Class_Byte
'Range loop
1406 if not Is_Upper
(Character'Val (Value
)) then
1407 Set_In_Class
(Bitmap
, Character'Val (Value
));
1411 when ANYOF_XDIGIT
=>
1412 for Value
in Class_Byte
'Range loop
1413 if Is_Hexadecimal_Digit
(Character'Val (Value
)) then
1414 Set_In_Class
(Bitmap
, Character'Val (Value
));
1418 when ANYOF_NXDIGIT
=>
1419 for Value
in Class_Byte
'Range loop
1420 if not Is_Hexadecimal_Digit
1421 (Character'Val (Value
))
1423 Set_In_Class
(Bitmap
, Character'Val (Value
));
1429 -- Not a character range
1431 elsif not In_Range
then
1432 Last_Value
:= Value
;
1434 if Parse_Pos
> Expression
'Last then
1435 Fail
("Empty character class []");
1438 if Expression
(Parse_Pos
) = '-'
1439 and then Parse_Pos
< Parse_End
1440 and then Expression
(Parse_Pos
+ 1) /= ']'
1442 Parse_Pos
:= Parse_Pos
+ 1;
1444 -- Do we have a range like '\d-a' and '[:space:]-a'
1445 -- which is not a real range
1447 if Named_Class
/= ANYOF_NONE
then
1448 Set_In_Class
(Bitmap
, '-');
1454 Set_In_Class
(Bitmap
, Value
);
1458 -- Else in a character range
1461 if Last_Value
> Value
then
1462 Fail
("Invalid Range [" & Last_Value
'Img
1463 & "-" & Value
'Img & "]");
1466 while Last_Value
<= Value
loop
1467 Set_In_Class
(Bitmap
, Last_Value
);
1468 Last_Value
:= Character'Succ (Last_Value
);
1477 -- Optimize case-insensitive ranges (put the upper case or lower
1478 -- case character into the bitmap)
1480 if (Flags
and Case_Insensitive
) /= 0 then
1481 for C
in Character'Range loop
1482 if Get_From_Class
(Bitmap
, C
) then
1483 Set_In_Class
(Bitmap
, To_Lower
(C
));
1484 Set_In_Class
(Bitmap
, To_Upper
(C
));
1489 -- Optimize inverted classes
1492 for J
in Bitmap
'Range loop
1493 Bitmap
(J
) := not Bitmap
(J
);
1497 Parse_Pos
:= Parse_Pos
+ 1;
1501 IP
:= Emit_Node
(ANYOF
);
1502 Emit_Class
(Bitmap
);
1503 end Parse_Character_Class
;
1509 -- This is a bit tricky due to quoted chars and due to
1510 -- the multiplier characters '*', '+', and '?' that
1511 -- take the SINGLE char previous as their operand.
1513 -- On entry, the character at Parse_Pos - 1 is going to go
1514 -- into the string, no matter what it is. It could be
1515 -- following a \ if Parse_Atom was entered from the '\' case.
1517 -- Basic idea is to pick up a good char in C and examine
1518 -- the next char. If Is_Mult (C) then twiddle, if it's a \
1519 -- then frozzle and if it's another magic char then push C and
1520 -- terminate the string. If none of the above, push C on the
1521 -- string and go around again.
1523 -- Start_Pos is used to remember where "the current character"
1524 -- starts in the string, if due to an Is_Mult we need to back
1525 -- up and put the current char in a separate 1-character string.
1526 -- When Start_Pos is 0, C is the only char in the string;
1527 -- this is used in Is_Mult handling, and in setting the SIMPLE
1530 procedure Parse_Literal
1531 (Expr_Flags
: out Expression_Flags
;
1534 Start_Pos
: Natural := 0;
1536 Length_Ptr
: Pointer
;
1538 Has_Special_Operator
: Boolean := False;
1541 Parse_Pos
:= Parse_Pos
- 1; -- Look at current character
1545 (if (Flags
and Case_Insensitive
) /= 0 then EXACTF
else EXACT
);
1547 Length_Ptr
:= Emit_Ptr
;
1548 Emit_Ptr
:= String_Operand
(IP
);
1552 C
:= Expression
(Parse_Pos
); -- Get current character
1555 when '.' |
'[' |
'(' |
')' |
'|' | ASCII
.LF |
'$' |
'^' =>
1557 if Start_Pos
= 0 then
1558 Start_Pos
:= Parse_Pos
;
1559 Emit
(C
); -- First character is always emitted
1561 exit Parse_Loop
; -- Else we are done
1564 when '?' |
'+' |
'*' |
'{' =>
1566 if Start_Pos
= 0 then
1567 Start_Pos
:= Parse_Pos
;
1568 Emit
(C
); -- First character is always emitted
1570 -- Are we looking at an operator, or is this
1571 -- simply a normal character ?
1573 elsif not Is_Mult
(Parse_Pos
) then
1574 Start_Pos
:= Parse_Pos
;
1578 -- We've got something like "abc?d". Mark this as a
1579 -- special case. What we want to emit is a first
1580 -- constant string for "ab", then one for "c" that will
1581 -- ultimately be transformed with a CURLY operator, A
1582 -- special case has to be handled for "a?", since there
1583 -- is no initial string to emit.
1585 Has_Special_Operator
:= True;
1590 Start_Pos
:= Parse_Pos
;
1592 if Parse_Pos
= Parse_End
then
1593 Fail
("Trailing \");
1596 case Expression (Parse_Pos + 1) is
1597 when 'b' | 'B' | 's' | 'S' | 'd' | 'D'
1598 | 'w' | 'W' | '0' .. '9' | 'G' | 'A'
1600 when 'n' => Emit (ASCII.LF);
1601 when 't' => Emit (ASCII.HT);
1602 when 'r' => Emit (ASCII.CR);
1603 when 'f' => Emit (ASCII.FF);
1604 when 'e' => Emit (ASCII.ESC);
1605 when 'a' => Emit (ASCII.BEL);
1606 when others => Emit (Expression (Parse_Pos + 1));
1609 Parse_Pos := Parse_Pos + 1;
1613 Start_Pos := Parse_Pos;
1617 exit Parse_Loop when Emit_Ptr - Length_Ptr = 254;
1619 Parse_Pos := Parse_Pos + 1;
1621 exit Parse_Loop when Parse_Pos > Parse_End;
1622 end loop Parse_Loop;
1624 -- Is the string followed by a '*+?{' operator ? If yes, and if there
1625 -- is an initial string to emit, do it now.
1627 if Has_Special_Operator
1628 and then Emit_Ptr >= Length_Ptr + Next_Pointer_Bytes
1630 Emit_Ptr := Emit_Ptr - 1;
1631 Parse_Pos := Start_Pos;
1634 if Length_Ptr <= PM.Size then
1635 Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2);
1638 Expr_Flags.Has_Width := True;
1640 -- Slight optimization when there is a single character
1642 if Emit_Ptr = Length_Ptr + 2 then
1643 Expr_Flags.Simple := True;
1651 -- Note that the branching code sequences used for '?' and the
1652 -- general cases of '*' and + are somewhat optimized: they use
1653 -- the same NOTHING node as both the endmarker for their branch
1654 -- list and the body of the last branch. It might seem that
1655 -- this node could be dispensed with entirely, but the endmarker
1656 -- role is not redundant.
1658 procedure Parse_Piece
1659 (Expr_Flags : out Expression_Flags;
1663 New_Flags : Expression_Flags;
1664 Greedy : Boolean := True;
1667 Parse_Atom (New_Flags, IP);
1673 if Parse_Pos > Parse_End
1674 or else not Is_Mult (Parse_Pos)
1676 Expr_Flags := New_Flags;
1680 Op := Expression (Parse_Pos);
1684 then (SP_Start => True, others => False)
1685 else (Has_Width => True, others => False));
1687 -- Detect non greedy operators in the easy cases
1690 and then Parse_Pos + 1 <= Parse_End
1691 and then Expression (Parse_Pos + 1) = '?'
1694 Parse_Pos := Parse_Pos + 1;
1697 -- Generate the byte code
1702 if New_Flags.Simple then
1703 Insert_Operator (STAR, IP, Greedy);
1705 Link_Tail (IP, Emit_Node (WHILEM));
1706 Insert_Curly_Operator
1707 (CURLYX, 0, Max_Curly_Repeat, IP, Greedy);
1708 Link_Tail (IP, Emit_Node (NOTHING));
1713 if New_Flags.Simple then
1714 Insert_Operator (PLUS, IP, Greedy);
1716 Link_Tail (IP, Emit_Node (WHILEM));
1717 Insert_Curly_Operator
1718 (CURLYX, 1, Max_Curly_Repeat, IP, Greedy);
1719 Link_Tail (IP, Emit_Node (NOTHING));
1723 if New_Flags.Simple then
1724 Insert_Curly_Operator (CURLY, 0, 1, IP, Greedy);
1726 Link_Tail (IP, Emit_Node (WHILEM));
1727 Insert_Curly_Operator (CURLYX, 0, 1, IP, Greedy);
1728 Link_Tail (IP, Emit_Node (NOTHING));
1736 Get_Curly_Arguments (Parse_Pos, Min, Max, Greedy);
1738 if New_Flags.Simple then
1739 Insert_Curly_Operator (CURLY, Min, Max, IP, Greedy);
1741 Link_Tail (IP, Emit_Node (WHILEM));
1742 Insert_Curly_Operator (CURLYX, Min, Max, IP, Greedy);
1743 Link_Tail (IP, Emit_Node (NOTHING));
1751 Parse_Pos := Parse_Pos + 1;
1753 if Parse_Pos <= Parse_End
1754 and then Is_Mult (Parse_Pos)
1756 Fail ("nested
*+{");
1760 ---------------------------------
1761 -- Parse_Posix_Character_Class --
1762 ---------------------------------
1764 function Parse_Posix_Character_Class return Std_Class is
1765 Invert : Boolean := False;
1766 Class : Std_Class := ANYOF_NONE;
1767 E : String renames Expression;
1769 -- Class names. Note that code assumes that the length of all
1770 -- classes starting with the same letter have the same length.
1772 Alnum : constant String := "alnum
:]";
1773 Alpha : constant String := "alpha
:]";
1774 Ascii_C : constant String := "ascii
:]";
1775 Cntrl : constant String := "cntrl
:]";
1776 Digit : constant String := "digit
:]";
1777 Graph : constant String := "graph
:]";
1778 Lower : constant String := "lower
:]";
1779 Print : constant String := "print
:]";
1780 Punct : constant String := "punct
:]";
1781 Space : constant String := "space
:]";
1782 Upper : constant String := "upper
:]";
1783 Word : constant String := "word
:]";
1784 Xdigit : constant String := "xdigit
:]";
1787 -- Case of character class specified
1789 if Parse_Pos <= Parse_End
1790 and then Expression (Parse_Pos) = ':'
1792 Parse_Pos := Parse_Pos + 1;
1794 -- Do we have something like: [[:^alpha:]]
1796 if Parse_Pos <= Parse_End
1797 and then Expression (Parse_Pos) = '^'
1800 Parse_Pos := Parse_Pos + 1;
1803 -- Check for class names based on first letter
1805 case Expression (Parse_Pos) is
1808 -- All 'a' classes have the same length (Alnum'Length)
1810 if Parse_Pos + Alnum'Length - 1 <= Parse_End then
1812 E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) = Alnum
1815 (if Invert then ANYOF_NALNUMC else ANYOF_ALNUMC);
1816 Parse_Pos := Parse_Pos + Alnum'Length;
1819 E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) = Alpha
1822 (if Invert then ANYOF_NALPHA else ANYOF_ALPHA);
1823 Parse_Pos := Parse_Pos + Alpha'Length;
1825 elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) =
1829 (if Invert then ANYOF_NASCII else ANYOF_ASCII);
1830 Parse_Pos := Parse_Pos + Ascii_C'Length;
1832 Fail ("Invalid
character class
: " & E);
1836 Fail ("Invalid
character class
: " & E);
1840 if Parse_Pos + Cntrl'Length - 1 <= Parse_End
1842 E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) = Cntrl
1844 Class := (if Invert then ANYOF_NCNTRL else ANYOF_CNTRL);
1845 Parse_Pos := Parse_Pos + Cntrl'Length;
1847 Fail ("Invalid
character class
: " & E);
1851 if Parse_Pos + Digit'Length - 1 <= Parse_End
1853 E (Parse_Pos .. Parse_Pos + Digit'Length - 1) = Digit
1855 Class := (if Invert then ANYOF_NDIGIT else ANYOF_DIGIT);
1856 Parse_Pos := Parse_Pos + Digit'Length;
1860 if Parse_Pos + Graph'Length - 1 <= Parse_End
1862 E (Parse_Pos .. Parse_Pos + Graph'Length - 1) = Graph
1864 Class := (if Invert then ANYOF_NGRAPH else ANYOF_GRAPH);
1865 Parse_Pos := Parse_Pos + Graph'Length;
1867 Fail ("Invalid
character class
: " & E);
1871 if Parse_Pos + Lower'Length - 1 <= Parse_End
1873 E (Parse_Pos .. Parse_Pos + Lower'Length - 1) = Lower
1875 Class := (if Invert then ANYOF_NLOWER else ANYOF_LOWER);
1876 Parse_Pos := Parse_Pos + Lower'Length;
1878 Fail ("Invalid
character class
: " & E);
1883 -- All 'p' classes have the same length
1885 if Parse_Pos + Print'Length - 1 <= Parse_End then
1887 E (Parse_Pos .. Parse_Pos + Print'Length - 1) = Print
1890 (if Invert then ANYOF_NPRINT else ANYOF_PRINT);
1891 Parse_Pos := Parse_Pos + Print'Length;
1894 E (Parse_Pos .. Parse_Pos + Punct'Length - 1) = Punct
1897 (if Invert then ANYOF_NPUNCT else ANYOF_PUNCT);
1898 Parse_Pos := Parse_Pos + Punct'Length;
1901 Fail ("Invalid
character class
: " & E);
1905 Fail ("Invalid
character class
: " & E);
1909 if Parse_Pos + Space'Length - 1 <= Parse_End
1911 E (Parse_Pos .. Parse_Pos + Space'Length - 1) = Space
1913 Class := (if Invert then ANYOF_NSPACE else ANYOF_SPACE);
1914 Parse_Pos := Parse_Pos + Space'Length;
1916 Fail ("Invalid
character class
: " & E);
1920 if Parse_Pos + Upper'Length - 1 <= Parse_End
1922 E (Parse_Pos .. Parse_Pos + Upper'Length - 1) = Upper
1924 Class := (if Invert then ANYOF_NUPPER else ANYOF_UPPER);
1925 Parse_Pos := Parse_Pos + Upper'Length;
1927 Fail ("Invalid
character class
: " & E);
1931 if Parse_Pos + Word'Length - 1 <= Parse_End
1933 E (Parse_Pos .. Parse_Pos + Word'Length - 1) = Word
1935 Class := (if Invert then ANYOF_NALNUM else ANYOF_ALNUM);
1936 Parse_Pos := Parse_Pos + Word'Length;
1938 Fail ("Invalid
character class
: " & E);
1942 if Parse_Pos + Xdigit'Length - 1 <= Parse_End
1944 E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1) = Xdigit
1946 Class := (if Invert then ANYOF_NXDIGIT else ANYOF_XDIGIT);
1947 Parse_Pos := Parse_Pos + Xdigit'Length;
1950 Fail ("Invalid
character class
: " & E);
1954 Fail ("Invalid
character class
: " & E);
1957 -- Character class not specified
1964 end Parse_Posix_Character_Class;
1966 -- Local Declarations
1970 Expr_Flags : Expression_Flags;
1971 pragma Unreferenced (Expr_Flags);
1973 -- Start of processing for Compile
1976 Parse (False, Expr_Flags, Result);
1979 Fail ("Couldn
't compile expression
");
1982 Final_Code_Size := Emit_Ptr - 1;
1984 -- Do we want to actually compile the expression, or simply get the
1987 if Emit_Ptr <= PM.Size then
1995 (Expression : String;
1996 Flags : Regexp_Flags := No_Flags) return Pattern_Matcher
1998 -- Assume the compiled regexp will fit in 1000 chars. If it does not we
1999 -- will have to compile a second time once the correct size is known. If
2000 -- it fits, we save a significant amount of time by avoiding the second
2003 Dummy : Pattern_Matcher (1000);
2004 Size : Program_Size;
2007 Compile (Dummy, Expression, Size, Flags);
2009 if Size <= Dummy.Size then
2010 return Pattern_Matcher'
2012 First => Dummy.First,
2013 Anchored => Dummy.Anchored,
2014 Must_Have => Dummy.Must_Have,
2015 Must_Have_Length => Dummy.Must_Have_Length,
2016 Paren_Count => Dummy.Paren_Count,
2017 Flags => Dummy.Flags,
2018 Program => Dummy.Program
2019 (Dummy.Program'First .. Dummy.Program'First + Size - 1));
2021 -- We have to recompile now that we know the size
2022 -- ??? Can we use Ada05's return construct ?
2024 Result : Pattern_Matcher (Size);
2026 Compile (Result, Expression, Size, Flags);
2033 (Matcher : out Pattern_Matcher;
2034 Expression : String;
2035 Flags : Regexp_Flags := No_Flags)
2037 Size : Program_Size;
2040 Compile (Matcher, Expression, Size, Flags);
2042 if Size > Matcher.Size then
2043 raise Expression_Error with "Pattern_Matcher
is too small
";
2047 --------------------
2048 -- Dump_Operation --
2049 --------------------
2051 procedure Dump_Operation
2052 (Program : Program_Data;
2056 Current : Pointer := Index;
2058 Dump_Until (Program, Current, Current + 1, Indent);
2065 procedure Dump_Until
2066 (Program : Program_Data;
2067 Index : in out Pointer;
2070 Do_Print : Boolean := True)
2072 function Image (S : String) return String;
2073 -- Remove leading space
2079 function Image (S : String) return String is
2081 if S (S'First) = ' ' then
2082 return S (S'First + 1 .. S'Last);
2093 Local_Indent : Natural := Indent;
2095 -- Start of processing for Dump_Until
2098 while Index < Till loop
2099 Op := Opcode'Val (Character'Pos ((Program (Index))));
2100 Next := Get_Next (Program, Index);
2104 Point : constant String := Pointer'Image (Index);
2106 Put ((1 .. 4 - Point'Length => ' ')
2108 & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op));
2111 -- Print the parenthesis number
2113 if Op = OPEN or else Op = CLOSE or else Op = REFF then
2114 Put (Image (Natural'Image
2116 (Program (Index + Next_Pointer_Bytes)))));
2119 if Next = Index then
2122 Put (" (" & Image (Pointer'Image (Next)) & ")");
2129 Bitmap : Character_Class;
2130 Last : Character := ASCII.NUL;
2131 Current : Natural := 0;
2132 Current_Char : Character;
2135 Bitmap_Operand (Program, Index, Bitmap);
2140 while Current <= 255 loop
2141 Current_Char := Character'Val (Current);
2143 -- First item in a range
2145 if Get_From_Class (Bitmap, Current_Char) then
2146 Last := Current_Char;
2148 -- Search for the last item in the range
2151 Current := Current + 1;
2152 exit when Current > 255;
2153 Current_Char := Character'Val (Current);
2155 not Get_From_Class (Bitmap, Current_Char);
2158 if not Is_Graphic (Last) then
2164 if Character'Succ (Last) /= Current_Char then
2165 Put ("\-" & Character'Pred (Current_Char));
2169 Current := Current + 1;
2176 Index := Index + Next_Pointer_Bytes + Bitmap'Length;
2179 when EXACT | EXACTF =>
2180 Length := String_Length (Program, Index);
2182 Put (" (" & Image (Program_Size'Image (Length + 1))
2184 & String (Program (String_Operand (Index)
2185 .. String_Operand (Index)
2190 Index := String_Operand (Index) + Length + 1;
2194 when BRANCH | STAR | PLUS =>
2199 Index := Index + Next_Pointer_Bytes;
2200 Dump_Until (Program, Index, Pointer'Min (Next, Till),
2201 Local_Indent + 1, Do_Print);
2203 when CURLY | CURLYX =>
2207 & Image (Natural'Image
2208 (Read_Natural (Program, Index + Next_Pointer_Bytes)))
2210 & Image (Natural'Image (Read_Natural (Program, Index + 5)))
2215 Dump_Until (Program, Index, Pointer'Min (Next, Till),
2216 Local_Indent + 1, Do_Print);
2224 Local_Indent := Local_Indent + 1;
2226 when CLOSE | REFF =>
2234 Local_Indent := Local_Indent - 1;
2238 Index := Index + Next_Pointer_Bytes;
2253 procedure Dump (Self : Pattern_Matcher) is
2254 Program : Program_Data renames Self.Program;
2255 Index : Pointer := Program'First;
2257 -- Start of processing for Dump
2260 Put_Line ("Must start
with (Self
.First
) = "
2261 & Character'Image (Self.First));
2263 if (Self.Flags and Case_Insensitive) /= 0 then
2264 Put_Line (" Case_Insensitive mode
");
2267 if (Self.Flags and Single_Line) /= 0 then
2268 Put_Line (" Single_Line mode
");
2271 if (Self.Flags and Multiple_Lines) /= 0 then
2272 Put_Line (" Multiple_Lines mode
");
2275 Dump_Until (Program, Index, Self.Program'Last + 1, 0);
2278 --------------------
2279 -- Get_From_Class --
2280 --------------------
2282 function Get_From_Class
2283 (Bitmap : Character_Class;
2284 C : Character) return Boolean
2286 Value : constant Class_Byte := Character'Pos (C);
2289 (Bitmap (Value / 8) and Bit_Conversion (Value mod 8)) /= 0;
2296 function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is
2298 return IP + Pointer (Read_Natural (Program, IP + 1));
2305 function Is_Alnum (C : Character) return Boolean is
2307 return Is_Alphanumeric (C) or else C = '_';
2314 function Is_Printable (C : Character) return Boolean is
2316 -- Printable if space or graphic character or other whitespace
2317 -- Other white space includes (HT/LF/VT/FF/CR = codes 9-13)
2319 return C in Character'Val (32) .. Character'Val (126)
2320 or else C in ASCII.HT .. ASCII.CR;
2323 --------------------
2324 -- Is_White_Space --
2325 --------------------
2327 function Is_White_Space (C : Character) return Boolean is
2329 -- Note: HT = 9, LF = 10, VT = 11, FF = 12, CR = 13
2331 return C = ' ' or else C in ASCII.HT .. ASCII.CR;
2339 (Self : Pattern_Matcher;
2341 Matches : out Match_Array;
2342 Data_First : Integer := -1;
2343 Data_Last : Positive := Positive'Last)
2345 Program : Program_Data renames Self.Program; -- Shorter notation
2347 First_In_Data : constant Integer := Integer'Max (Data_First, Data'First);
2348 Last_In_Data : constant Integer := Integer'Min (Data_Last, Data'Last);
2350 -- Global work variables
2352 Input_Pos : Natural; -- String-input pointer
2353 BOL_Pos : Natural; -- Beginning of input, for ^ check
2354 Matched : Boolean := False; -- Until proven True
2356 Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count,
2358 -- Stores the value of all the parenthesis pairs.
2359 -- We do not use directly Matches, so that we can also use back
2360 -- references (REFF) even if Matches is too small.
2362 type Natural_Array is array (Match_Count range <>) of Natural;
2363 Matches_Tmp : Natural_Array (Matches_Full'Range);
2364 -- Save the opening position of parenthesis
2366 Last_Paren : Natural := 0;
2367 -- Last parenthesis seen
2369 Greedy : Boolean := True;
2370 -- True if the next operator should be greedy
2372 type Current_Curly_Record;
2373 type Current_Curly_Access is access all Current_Curly_Record;
2374 type Current_Curly_Record is record
2375 Paren_Floor : Natural; -- How far back to strip parenthesis data
2376 Cur : Integer; -- How many instances of scan we've matched
2377 Min : Natural; -- Minimal number of scans to match
2378 Max : Natural; -- Maximal number of scans to match
2379 Greedy : Boolean; -- Whether to work our way up or down
2380 Scan : Pointer; -- The thing to match
2381 Next : Pointer; -- What has to match after it
2382 Lastloc : Natural; -- Where we started matching this scan
2383 Old_Cc : Current_Curly_Access; -- Before we started this one
2385 -- Data used to handle the curly operator and the plus and star
2386 -- operators for complex expressions.
2388 Current_Curly : Current_Curly_Access := null;
2389 -- The curly currently being processed
2391 -----------------------
2392 -- Local Subprograms --
2393 -----------------------
2395 function Index (Start : Positive; C : Character) return Natural;
2396 -- Find character C in Data starting at Start and return position
2400 Max : Natural := Natural'Last) return Natural;
2401 -- Repeatedly match something simple, report how many
2402 -- It only matches on things of length 1.
2403 -- Starting from Input_Pos, it matches at most Max CURLY.
2405 function Try (Pos : Positive) return Boolean;
2406 -- Try to match at specific point
2408 function Match (IP : Pointer) return Boolean;
2409 -- This is the main matching routine. Conceptually the strategy
2410 -- is simple: check to see whether the current node matches,
2411 -- call self recursively to see whether the rest matches,
2412 -- and then act accordingly.
2414 -- In practice Match makes some effort to avoid recursion, in
2415 -- particular by going through "ordinary
" nodes (that don't
2416 -- need to know whether the rest of the match failed) by
2417 -- using a loop instead of recursion.
2418 -- Why is the above comment part of the spec rather than body ???
2420 function Match_Whilem return Boolean;
2421 -- Return True if a WHILEM matches the Current_Curly
2423 function Recurse_Match (IP : Pointer; From : Natural) return Boolean;
2424 pragma Inline (Recurse_Match);
2425 -- Calls Match recursively. It saves and restores the parenthesis
2426 -- status and location in the input stream correctly, so that
2427 -- backtracking is possible
2429 function Match_Simple_Operator
2433 Greedy : Boolean) return Boolean;
2434 -- Return True it the simple operator (possibly non-greedy) matches
2436 Dump_Indent : Integer := -1;
2437 procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True);
2438 procedure Dump_Error (Msg : String);
2439 -- Debug: print the current context
2441 pragma Inline (Index);
2442 pragma Inline (Repeat);
2444 -- These are two complex functions, but used only once
2446 pragma Inline (Match_Whilem);
2447 pragma Inline (Match_Simple_Operator);
2453 function Index (Start : Positive; C : Character) return Natural is
2455 for J in Start .. Last_In_Data loop
2456 if Data (J) = C then
2468 function Recurse_Match (IP : Pointer; From : Natural) return Boolean is
2469 L : constant Natural := Last_Paren;
2470 Tmp_F : constant Match_Array :=
2471 Matches_Full (From + 1 .. Matches_Full'Last);
2472 Start : constant Natural_Array :=
2473 Matches_Tmp (From + 1 .. Matches_Tmp'Last);
2474 Input : constant Natural := Input_Pos;
2476 Dump_Indent_Save : constant Integer := Dump_Indent;
2484 Matches_Full (Tmp_F'Range) := Tmp_F;
2485 Matches_Tmp (Start'Range) := Start;
2487 Dump_Indent := Dump_Indent_Save;
2495 procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is
2496 Length : constant := 10;
2497 Pos : constant String := Integer'Image (Input_Pos);
2501 Put ((1 .. 5 - Pos'Length => ' '));
2504 .. Integer'Min (Last_In_Data, Input_Pos + Length - 1)));
2505 Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' '));
2512 Dump_Operation (Program, Scan, Indent => Dump_Indent);
2519 procedure Dump_Error (Msg : String) is
2522 Put ((1 .. Dump_Indent * 2 => ' '));
2530 function Match (IP : Pointer) return Boolean is
2531 Scan : Pointer := IP;
2537 Dump_Indent := Dump_Indent + 1;
2541 pragma Assert (Scan /= 0);
2543 -- Determine current opcode and count its usage in debug mode
2545 Op := Opcode'Val (Character'Pos (Program (Scan)));
2547 -- Calculate offset of next instruction. Second character is most
2548 -- significant in Program_Data.
2550 Next := Get_Next (Program, Scan);
2553 Dump_Current (Scan);
2558 Dump_Indent := Dump_Indent - 1;
2559 return True; -- Success !
2562 if Program (Next) /= BRANCH then
2563 Next := Operand (Scan); -- No choice, avoid recursion
2567 if Recurse_Match (Operand (Scan), 0) then
2568 Dump_Indent := Dump_Indent - 1;
2572 Scan := Get_Next (Program, Scan);
2573 exit when Scan = 0 or else Program (Scan) /= BRANCH;
2583 exit State_Machine when Input_Pos /= BOL_Pos
2584 and then ((Self.Flags and Multiple_Lines) = 0
2585 or else Data (Input_Pos - 1) /= ASCII.LF);
2588 exit State_Machine when Input_Pos /= BOL_Pos
2589 and then Data (Input_Pos - 1) /= ASCII.LF;
2592 exit State_Machine when Input_Pos /= BOL_Pos;
2595 exit State_Machine when Input_Pos <= Data'Last
2596 and then ((Self.Flags and Multiple_Lines) = 0
2597 or else Data (Input_Pos) /= ASCII.LF);
2600 exit State_Machine when Input_Pos <= Data'Last
2601 and then Data (Input_Pos) /= ASCII.LF;
2604 exit State_Machine when Input_Pos <= Data'Last;
2606 when BOUND | NBOUND =>
2608 -- Was last char in word ?
2611 N : Boolean := False;
2612 Ln : Boolean := False;
2615 if Input_Pos /= First_In_Data then
2616 N := Is_Alnum (Data (Input_Pos - 1));
2620 (if Input_Pos > Last_In_Data
2622 else Is_Alnum (Data (Input_Pos)));
2636 exit State_Machine when Input_Pos > Last_In_Data
2637 or else not Is_White_Space (Data (Input_Pos));
2638 Input_Pos := Input_Pos + 1;
2641 exit State_Machine when Input_Pos > Last_In_Data
2642 or else Is_White_Space (Data (Input_Pos));
2643 Input_Pos := Input_Pos + 1;
2646 exit State_Machine when Input_Pos > Last_In_Data
2647 or else not Is_Digit (Data (Input_Pos));
2648 Input_Pos := Input_Pos + 1;
2651 exit State_Machine when Input_Pos > Last_In_Data
2652 or else Is_Digit (Data (Input_Pos));
2653 Input_Pos := Input_Pos + 1;
2656 exit State_Machine when Input_Pos > Last_In_Data
2657 or else not Is_Alnum (Data (Input_Pos));
2658 Input_Pos := Input_Pos + 1;
2661 exit State_Machine when Input_Pos > Last_In_Data
2662 or else Is_Alnum (Data (Input_Pos));
2663 Input_Pos := Input_Pos + 1;
2666 exit State_Machine when Input_Pos > Last_In_Data
2667 or else Data (Input_Pos) = ASCII.LF;
2668 Input_Pos := Input_Pos + 1;
2671 exit State_Machine when Input_Pos > Last_In_Data;
2672 Input_Pos := Input_Pos + 1;
2676 Opnd : Pointer := String_Operand (Scan);
2677 Current : Positive := Input_Pos;
2678 Last : constant Pointer :=
2679 Opnd + String_Length (Program, Scan);
2682 while Opnd <= Last loop
2683 exit State_Machine when Current > Last_In_Data
2684 or else Program (Opnd) /= Data (Current);
2685 Current := Current + 1;
2689 Input_Pos := Current;
2694 Opnd : Pointer := String_Operand (Scan);
2695 Current : Positive := Input_Pos;
2697 Last : constant Pointer :=
2698 Opnd + String_Length (Program, Scan);
2701 while Opnd <= Last loop
2702 exit State_Machine when Current > Last_In_Data
2703 or else Program (Opnd) /= To_Lower (Data (Current));
2704 Current := Current + 1;
2708 Input_Pos := Current;
2713 Bitmap : Character_Class;
2715 Bitmap_Operand (Program, Scan, Bitmap);
2716 exit State_Machine when Input_Pos > Last_In_Data
2717 or else not Get_From_Class (Bitmap, Data (Input_Pos));
2718 Input_Pos := Input_Pos + 1;
2723 No : constant Natural :=
2724 Character'Pos (Program (Operand (Scan)));
2726 Matches_Tmp (No) := Input_Pos;
2731 No : constant Natural :=
2732 Character'Pos (Program (Operand (Scan)));
2735 Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1);
2737 if Last_Paren < No then
2744 No : constant Natural :=
2745 Character'Pos (Program (Operand (Scan)));
2750 -- If we haven't seen that parenthesis yet
2752 if Last_Paren < No then
2753 Dump_Indent := Dump_Indent - 1;
2756 Dump_Error ("REFF
: No match
, backtracking
");
2762 Data_Pos := Matches_Full (No).First;
2764 while Data_Pos <= Matches_Full (No).Last loop
2765 if Input_Pos > Last_In_Data
2766 or else Data (Input_Pos) /= Data (Data_Pos)
2768 Dump_Indent := Dump_Indent - 1;
2771 Dump_Error ("REFF
: No match
, backtracking
");
2777 Input_Pos := Input_Pos + 1;
2778 Data_Pos := Data_Pos + 1;
2785 when STAR | PLUS | CURLY =>
2787 Greed : constant Boolean := Greedy;
2790 Result := Match_Simple_Operator (Op, Scan, Next, Greed);
2791 Dump_Indent := Dump_Indent - 1;
2797 -- Looking at something like:
2799 -- 1: CURLYX {n,m} (->4)
2800 -- 2: code for complex thing (->3)
2805 Min : constant Natural :=
2806 Read_Natural (Program, Scan + Next_Pointer_Bytes);
2807 Max : constant Natural :=
2809 (Program, Scan + Next_Pointer_Bytes + 2);
2810 Cc : aliased Current_Curly_Record;
2812 Has_Match : Boolean;
2815 Cc := (Paren_Floor => Last_Paren,
2823 Old_Cc => Current_Curly);
2825 Current_Curly := Cc'Unchecked_Access;
2827 Has_Match := Match (Next - Next_Pointer_Bytes);
2829 -- Start on the WHILEM
2831 Current_Curly := Cc.Old_Cc;
2832 Dump_Indent := Dump_Indent - 1;
2834 if not Has_Match then
2836 Dump_Error ("CURLYX failed
...");
2844 Result := Match_Whilem;
2845 Dump_Indent := Dump_Indent - 1;
2847 if Debug and then not Result then
2848 Dump_Error ("WHILEM
: no match
, backtracking
");
2855 end loop State_Machine;
2858 Dump_Error ("failed
...");
2859 Dump_Indent := Dump_Indent - 1;
2862 -- If we get here, there is no match. For successful matches when EOP
2863 -- is the terminating point.
2868 ---------------------------
2869 -- Match_Simple_Operator --
2870 ---------------------------
2872 function Match_Simple_Operator
2876 Greedy : Boolean) return Boolean
2878 Next_Char : Character := ASCII.NUL;
2879 Next_Char_Known : Boolean := False;
2880 No : Integer; -- Can be negative
2882 Max : Natural := Natural'Last;
2883 Operand_Code : Pointer;
2886 Save : constant Natural := Input_Pos;
2889 -- Lookahead to avoid useless match attempts when we know what
2890 -- character comes next.
2892 if Program (Next) = EXACT then
2893 Next_Char := Program (String_Operand (Next));
2894 Next_Char_Known := True;
2897 -- Find the minimal and maximal values for the operator
2902 Operand_Code := Operand (Scan);
2906 Operand_Code := Operand (Scan);
2909 Min := Read_Natural (Program, Scan + Next_Pointer_Bytes);
2910 Max := Read_Natural (Program, Scan + Next_Pointer_Bytes + 2);
2911 Operand_Code := Scan + 7;
2915 Dump_Current (Operand_Code, Prefix => False);
2918 -- Non greedy operators
2922 -- Test we can repeat at least Min times
2925 No := Repeat (Operand_Code, Min);
2929 Dump_Error ("failed
... matched
" & No'Img & " times
");
2938 -- Find the place where 'next' could work
2940 if Next_Char_Known then
2942 -- Last position to check
2944 if Max = Natural'Last then
2945 Last_Pos := Last_In_Data;
2947 Last_Pos := Input_Pos + Max;
2949 if Last_Pos > Last_In_Data then
2950 Last_Pos := Last_In_Data;
2954 -- Look for the first possible opportunity
2957 Dump_Error ("Next_Char must be
" & Next_Char);
2961 -- Find the next possible position
2963 while Input_Pos <= Last_Pos
2964 and then Data (Input_Pos) /= Next_Char
2966 Input_Pos := Input_Pos + 1;
2969 if Input_Pos > Last_Pos then
2973 -- Check that we still match if we stop at the position we
2977 Num : constant Natural := Input_Pos - Old;
2983 Dump_Error ("Would we still match
at that position?
");
2986 if Repeat (Operand_Code, Num) < Num then
2991 -- Input_Pos now points to the new position
2993 if Match (Get_Next (Program, Scan)) then
2998 Input_Pos := Input_Pos + 1;
3001 -- We do not know what the next character is
3004 while Max >= Min loop
3006 Dump_Error ("Non
-greedy repeat
, N
=" & Min'Img);
3007 Dump_Error ("Do we still match Next
if we stop here?
");
3010 -- If the next character matches
3012 if Recurse_Match (Next, 1) then
3016 Input_Pos := Save + Min;
3018 -- Could not or did not match -- move forward
3020 if Repeat (Operand_Code, 1) /= 0 then
3024 Dump_Error ("Non
-greedy repeat failed
...");
3037 No := Repeat (Operand_Code, Max);
3039 if Debug and then No < Min then
3040 Dump_Error ("failed
... matched
" & No'Img & " times
");
3043 -- ??? Perl has some special code here in case the next
3044 -- instruction is of type EOL, since $ and \Z can match before
3045 -- *and* after newline at the end.
3047 -- ??? Perl has some special code here in case (paren) is True
3049 -- Else, if we don't have any parenthesis
3051 while No >= Min loop
3052 if not Next_Char_Known
3053 or else (Input_Pos <= Last_In_Data
3054 and then Data (Input_Pos) = Next_Char)
3056 if Match (Next) then
3061 -- Could not or did not work, we back up
3064 Input_Pos := Save + No;
3069 end Match_Simple_Operator;
3075 -- This is really hard to understand, because after we match what we
3076 -- are trying to match, we must make sure the rest of the REx is going
3077 -- to match for sure, and to do that we have to go back UP the parse
3078 -- tree by recursing ever deeper. And if it fails, we have to reset
3079 -- our parent's current state that we can try again after backing off.
3081 function Match_Whilem return Boolean is
3082 Cc : constant Current_Curly_Access := Current_Curly;
3084 N : constant Natural := Cc.Cur + 1;
3087 Lastloc : constant Natural := Cc.Lastloc;
3088 -- Detection of 0-len
3091 -- If degenerate scan matches "", assume scan done
3093 if Input_Pos = Cc.Lastloc
3094 and then N >= Cc.Min
3096 -- Temporarily restore the old context, and check that we
3097 -- match was comes after CURLYX.
3099 Current_Curly := Cc.Old_Cc;
3101 if Current_Curly /= null then
3102 Ln := Current_Curly.Cur;
3105 if Match (Cc.Next) then
3109 if Current_Curly /= null then
3110 Current_Curly.Cur := Ln;
3113 Current_Curly := Cc;
3117 -- First, just match a string of min scans
3121 Cc.Lastloc := Input_Pos;
3125 ("Tests that we match
at least
" & Cc.Min'Img & " N
=" & N'Img);
3128 if Match (Cc.Scan) then
3133 Cc.Lastloc := Lastloc;
3136 Dump_Error ("failed
...");
3142 -- Prefer next over scan for minimal matching
3144 if not Cc.Greedy then
3145 Current_Curly := Cc.Old_Cc;
3147 if Current_Curly /= null then
3148 Ln := Current_Curly.Cur;
3151 if Recurse_Match (Cc.Next, Cc.Paren_Floor) then
3155 if Current_Curly /= null then
3156 Current_Curly.Cur := Ln;
3159 Current_Curly := Cc;
3161 -- Maximum greed exceeded ?
3165 Dump_Error ("failed
...");
3170 -- Try scanning more and see if it helps
3172 Cc.Lastloc := Input_Pos;
3175 Dump_Error ("Next failed
, what about Current?
");
3178 if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3183 Cc.Lastloc := Lastloc;
3187 -- Prefer scan over next for maximal matching
3189 if N < Cc.Max then -- more greed allowed ?
3191 Cc.Lastloc := Input_Pos;
3194 Dump_Error ("Recurse
at current position
");
3197 if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3202 -- Failed deeper matches of scan, so see if this one works
3204 Current_Curly := Cc.Old_Cc;
3206 if Current_Curly /= null then
3207 Ln := Current_Curly.Cur;
3211 Dump_Error ("Failed matching
for later positions
");
3214 if Match (Cc.Next) then
3218 if Current_Curly /= null then
3219 Current_Curly.Cur := Ln;
3222 Current_Curly := Cc;
3224 Cc.Lastloc := Lastloc;
3227 Dump_Error ("failed
...");
3239 Max : Natural := Natural'Last) return Natural
3241 Scan : Natural := Input_Pos;
3243 Op : constant Opcode := Opcode'Val (Character'Pos (Program (IP)));
3246 Is_First : Boolean := True;
3247 Bitmap : Character_Class;
3250 if Max = Natural'Last or else Scan + Max - 1 > Last_In_Data then
3251 Last := Last_In_Data;
3253 Last := Scan + Max - 1;
3259 and then Data (Scan) /= ASCII.LF
3269 -- The string has only one character if Repeat was called
3271 C := Program (String_Operand (IP));
3273 and then C = Data (Scan)
3280 -- The string has only one character if Repeat was called
3282 C := Program (String_Operand (IP));
3284 and then To_Lower (C) = Data (Scan)
3291 Bitmap_Operand (Program, IP, Bitmap);
3296 and then Get_From_Class (Bitmap, Data (Scan))
3303 and then Is_Alnum (Data (Scan))
3310 and then not Is_Alnum (Data (Scan))
3317 and then Is_White_Space (Data (Scan))
3324 and then not Is_White_Space (Data (Scan))
3331 and then Is_Digit (Data (Scan))
3338 and then not Is_Digit (Data (Scan))
3344 raise Program_Error;
3347 Count := Scan - Input_Pos;
3356 function Try (Pos : Positive) return Boolean is
3360 Matches_Full := (others => No_Match);
3362 if Match (Program_First) then
3363 Matches_Full (0) := (Pos, Input_Pos - 1);
3370 -- Start of processing for Match
3373 -- Do we have the regexp Never_Match?
3375 if Self.Size = 0 then
3376 Matches := (others => No_Match);
3380 -- If there is a "must appear
" string, look for it
3382 if Self.Must_Have_Length > 0 then
3384 First : constant Character := Program (Self.Must_Have);
3385 Must_First : constant Pointer := Self.Must_Have;
3386 Must_Last : constant Pointer :=
3387 Must_First + Pointer (Self.Must_Have_Length - 1);
3388 Next_Try : Natural := Index (First_In_Data, First);
3392 and then Data (Next_Try .. Next_Try + Self.Must_Have_Length - 1)
3393 = String (Program (Must_First .. Must_Last))
3395 Next_Try := Index (Next_Try + 1, First);
3398 if Next_Try = 0 then
3399 Matches := (others => No_Match);
3400 return; -- Not present
3405 -- Mark beginning of line for ^
3407 BOL_Pos := Data'First;
3409 -- Simplest case first: an anchored match need be tried only once
3411 if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then
3412 Matched := Try (First_In_Data);
3414 elsif Self.Anchored then
3416 Next_Try : Natural := First_In_Data;
3418 -- Test the first position in the buffer
3419 Matched := Try (Next_Try);
3421 -- Else only test after newlines
3424 while Next_Try <= Last_In_Data loop
3425 while Next_Try <= Last_In_Data
3426 and then Data (Next_Try) /= ASCII.LF
3428 Next_Try := Next_Try + 1;
3431 Next_Try := Next_Try + 1;
3433 if Next_Try <= Last_In_Data then
3434 Matched := Try (Next_Try);
3441 elsif Self.First /= ASCII.NUL then
3442 -- We know what char it must start with
3445 Next_Try : Natural := Index (First_In_Data, Self.First);
3448 while Next_Try /= 0 loop
3449 Matched := Try (Next_Try);
3451 Next_Try := Index (Next_Try + 1, Self.First);
3456 -- Messy cases: try all locations (including for the empty string)
3458 Matched := Try (First_In_Data);
3461 for S in First_In_Data + 1 .. Last_In_Data loop
3468 -- Matched has its value
3470 for J in Last_Paren + 1 .. Matches'Last loop
3471 Matches_Full (J) := No_Match;
3474 Matches := Matches_Full (Matches'Range);
3482 (Self : Pattern_Matcher;
3484 Data_First : Integer := -1;
3485 Data_Last : Positive := Positive'Last) return Natural
3487 Matches : Match_Array (0 .. 0);
3490 Match (Self, Data, Matches, Data_First, Data_Last);
3491 if Matches (0) = No_Match then
3492 return Data'First - 1;
3494 return Matches (0).First;
3499 (Self : Pattern_Matcher;
3501 Data_First : Integer := -1;
3502 Data_Last : Positive := Positive'Last) return Boolean
3504 Matches : Match_Array (0 .. 0);
3507 Match (Self, Data, Matches, Data_First, Data_Last);
3508 return Matches (0).First >= Data'First;
3512 (Expression : String;
3514 Matches : out Match_Array;
3515 Size : Program_Size := Auto_Size;
3516 Data_First : Integer := -1;
3517 Data_Last : Positive := Positive'Last)
3519 PM : Pattern_Matcher (Size);
3520 Finalize_Size : Program_Size;
3521 pragma Unreferenced (Finalize_Size);
3524 Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
3526 Compile (PM, Expression, Finalize_Size);
3527 Match (PM, Data, Matches, Data_First, Data_Last);
3536 (Expression : String;
3538 Size : Program_Size := Auto_Size;
3539 Data_First : Integer := -1;
3540 Data_Last : Positive := Positive'Last) return Natural
3542 PM : Pattern_Matcher (Size);
3543 Final_Size : Program_Size;
3544 pragma Unreferenced (Final_Size);
3547 return Match (Compile (Expression), Data, Data_First, Data_Last);
3549 Compile (PM, Expression, Final_Size);
3550 return Match (PM, Data, Data_First, Data_Last);
3559 (Expression : String;
3561 Size : Program_Size := Auto_Size;
3562 Data_First : Integer := -1;
3563 Data_Last : Positive := Positive'Last) return Boolean
3565 Matches : Match_Array (0 .. 0);
3566 PM : Pattern_Matcher (Size);
3567 Final_Size : Program_Size;
3568 pragma Unreferenced (Final_Size);
3571 Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
3573 Compile (PM, Expression, Final_Size);
3574 Match (PM, Data, Matches, Data_First, Data_Last);
3577 return Matches (0).First >= Data'First;
3584 function Operand (P : Pointer) return Pointer is
3586 return P + Next_Pointer_Bytes;
3593 procedure Optimize (Self : in out Pattern_Matcher) is
3595 Program : Program_Data renames Self.Program;
3598 -- Start with safe defaults (no optimization):
3599 -- * No known first character of match
3600 -- * Does not necessarily start at beginning of line
3601 -- * No string known that has to appear in data
3603 Self.First := ASCII.NUL;
3604 Self.Anchored := False;
3605 Self.Must_Have := Program'Last + 1;
3606 Self.Must_Have_Length := 0;
3608 Scan := Program_First; -- First instruction (can be anything)
3610 if Program (Scan) = EXACT then
3611 Self.First := Program (String_Operand (Scan));
3613 elsif Program (Scan) = BOL
3614 or else Program (Scan) = SBOL
3615 or else Program (Scan) = MBOL
3617 Self.Anchored := True;
3625 function Paren_Count (Regexp : Pattern_Matcher) return Match_Count is
3627 return Regexp.Paren_Count;
3634 function Quote (Str : String) return String is
3635 S : String (1 .. Str'Length * 2);
3636 Last : Natural := 0;
3639 for J in Str'Range loop
3641 when '^' | '$' | '|' | '*' | '+' | '?' | '{' |
3642 '}' | '[' | ']' | '(' | ')' | '\' | '.' =>
3644 S (Last + 1) := '\';
3645 S (Last + 2) := Str (J);
3649 S (Last + 1) := Str (J);
3654 return S (1 .. Last);
3661 function Read_Natural
3662 (Program : Program_Data;
3663 IP : Pointer) return Natural
3666 return Character'Pos (Program (IP)) +
3667 256 * Character'Pos (Program (IP + 1));
3674 procedure Reset_Class (Bitmap : out Character_Class) is
3676 Bitmap := (others => 0);
3683 procedure Set_In_Class
3684 (Bitmap : in out Character_Class;
3687 Value : constant Class_Byte := Character'Pos (C);
3689 Bitmap (Value / 8) := Bitmap (Value / 8)
3690 or Bit_Conversion (Value mod 8);
3697 function String_Length
3698 (Program : Program_Data;
3699 P : Pointer) return Program_Size
3702 pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF);
3703 return Character'Pos (Program (P + Next_Pointer_Bytes));
3706 --------------------
3707 -- String_Operand --
3708 --------------------
3710 function String_Operand (P : Pointer) return Pointer is