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) 1996-2004 Ada Core Technologies, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
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 Unchecked_Conversion
;
48 package body GNAT
.Regpat
is
50 MAGIC
: constant Character := Character'Val (10#
0234#
);
51 -- The first byte of the regexp internal "program" is actually
52 -- this magic number; the start node begins in the second byte.
54 -- This is used to make sure that a regular expression was correctly
57 ----------------------------
58 -- Implementation details --
59 ----------------------------
61 -- This is essentially a linear encoding of a nondeterministic
62 -- finite-state machine, also known as syntax charts or
63 -- "railroad normal form" in parsing technology.
65 -- Each node is an opcode plus a "next" pointer, possibly plus an
66 -- operand. "Next" pointers of all nodes except BRANCH implement
67 -- concatenation; a "next" pointer with a BRANCH on both ends of it
68 -- is connecting two alternatives.
70 -- The operand of some types of node is a literal string; for others,
71 -- it is a node leading into a sub-FSM. In particular, the operand of
72 -- a BRANCH node is the first node of the branch.
73 -- (NB this is *not* a tree structure: the tail of the branch connects
74 -- to the thing following the set of BRANCHes).
76 -- You can see the exact byte-compiled version by using the Dump
77 -- subprogram. However, here are a few examples:
80 -- 2 : BRANCH (next at 10)
81 -- 5 : EXACT (next at 18) operand=a
82 -- 10 : BRANCH (next at 18)
83 -- 13 : EXACT (next at 18) operand=b
84 -- 18 : EOP (next at 0)
87 -- 2 : CURLYX (next at 26) { 0, 32767}
88 -- 9 : OPEN 1 (next at 13)
89 -- 13 : EXACT (next at 19) operand=ab
90 -- 19 : CLOSE 1 (next at 23)
91 -- 23 : WHILEM (next at 0)
92 -- 26 : NOTHING (next at 29)
93 -- 29 : EOP (next at 0)
99 -- Name Operand? Meaning
101 (EOP
, -- no End of program
102 MINMOD
, -- no Next operator is not greedy
104 -- Classes of characters
106 ANY
, -- no Match any one character except newline
107 SANY
, -- no Match any character, including new line
108 ANYOF
, -- class Match any character in this class
109 EXACT
, -- str Match this string exactly
110 EXACTF
, -- str Match this string (case-folding is one)
111 NOTHING
, -- no Match empty string
112 SPACE
, -- no Match any whitespace character
113 NSPACE
, -- no Match any non-whitespace character
114 DIGIT
, -- no Match any numeric character
115 NDIGIT
, -- no Match any non-numeric character
116 ALNUM
, -- no Match any alphanumeric character
117 NALNUM
, -- no Match any non-alphanumeric character
121 BRANCH
, -- node Match this alternative, or the next
123 -- Simple loops (when the following node is one character in length)
125 STAR
, -- node Match this simple thing 0 or more times
126 PLUS
, -- node Match this simple thing 1 or more times
127 CURLY
, -- 2num node Match this simple thing between n and m times.
131 CURLYX
, -- 2num node Match this complex thing {n,m} times
132 -- The nums are coded on two characters each.
134 WHILEM
, -- no Do curly processing and see if rest matches
136 -- Matches after or before a word
138 BOL
, -- no Match "" at beginning of line
139 MBOL
, -- no Same, assuming mutiline (match after \n)
140 SBOL
, -- no Same, assuming single line (don't match at \n)
141 EOL
, -- no Match "" at end of line
142 MEOL
, -- no Same, assuming mutiline (match before \n)
143 SEOL
, -- no Same, assuming single line (don't match at \n)
145 BOUND
, -- no Match "" at any word boundary
146 NBOUND
, -- no Match "" at any word non-boundary
148 -- Parenthesis groups handling
150 REFF
, -- num Match some already matched string, folded
151 OPEN
, -- num Mark this point in input as start of #n
152 CLOSE
); -- num Analogous to OPEN
154 for Opcode
'Size use 8;
159 -- The set of branches constituting a single choice are hooked
160 -- together with their "next" pointers, since precedence prevents
161 -- anything being concatenated to any individual branch. The
162 -- "next" pointer of the last BRANCH in a choice points to the
163 -- thing following the whole choice. This is also where the
164 -- final "next" pointer of each individual branch points; each
165 -- branch starts with the operand node of a BRANCH node.
168 -- '?', and complex '*' and '+', are implemented with CURLYX.
169 -- branches. Simple cases (one character per match) are implemented with
170 -- STAR and PLUS for speed and to minimize recursive plunges.
173 -- ...are numbered at compile time.
176 -- There are in fact two arguments, the first one is the length (minus
177 -- one of the string argument), coded on one character, the second
178 -- argument is the string itself, coded on length + 1 characters.
180 -- A node is one char of opcode followed by two chars of "next" pointer.
181 -- "Next" pointers are stored as two 8-bit pieces, high order first. The
182 -- value is a positive offset from the opcode of the node containing it.
183 -- An operand, if any, simply follows the node. (Note that much of the
184 -- code generation knows about this implicit relationship.)
186 -- Using two bytes for the "next" pointer is vast overkill for most
187 -- things, but allows patterns to get big without disasters.
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
282 function Get_Next_Offset
283 (Program
: Program_Data
;
284 IP
: Pointer
) return Pointer
;
285 -- Get the offset field of a node. Used by Get_Next.
288 (Program
: Program_Data
;
289 IP
: Pointer
) return Pointer
;
290 -- Dig the next instruction pointer out of a node
292 procedure Optimize
(Self
: in out Pattern_Matcher
);
293 -- Optimize a Pattern_Matcher by noting certain special cases
295 function Read_Natural
296 (Program
: Program_Data
;
297 IP
: Pointer
) return Natural;
298 -- Return the 2-byte natural coded at position IP.
300 -- All of the subprograms above are tiny and should be inlined
303 pragma Inline
(Is_Alnum
);
304 pragma Inline
(Is_White_Space
);
305 pragma Inline
(Get_Next
);
306 pragma Inline
(Get_Next_Offset
);
307 pragma Inline
(Operand
);
308 pragma Inline
(Read_Natural
);
309 pragma Inline
(String_Length
);
310 pragma Inline
(String_Operand
);
312 type Expression_Flags
is record
313 Has_Width
, -- Known never to match null string
314 Simple
, -- Simple enough to be STAR/PLUS operand
315 SP_Start
: Boolean; -- Starts with * or +
318 Worst_Expression
: constant Expression_Flags
:= (others => False);
325 function "=" (Left
: Character; Right
: Opcode
) return Boolean is
327 return Character'Pos (Left
) = Opcode
'Pos (Right
);
334 procedure Bitmap_Operand
335 (Program
: Program_Data
;
337 Op
: out Character_Class
)
339 function Convert
is new Unchecked_Conversion
340 (Program_Data
, Character_Class
);
343 Op
(0 .. 31) := Convert
(Program
(P
+ 3 .. P
+ 34));
351 (Matcher
: out Pattern_Matcher
;
353 Final_Code_Size
: out Program_Size
;
354 Flags
: Regexp_Flags
:= No_Flags
)
356 -- We can't allocate space until we know how big the compiled form
357 -- will be, but we can't compile it (and thus know how big it is)
358 -- until we've got a place to put the code. So we cheat: we compile
359 -- it twice, once with code generation turned off and size counting
360 -- turned on, and once "for real".
362 -- This also means that we don't allocate space until we are sure
363 -- that the thing really will compile successfully, and we never
364 -- have to move the code and thus invalidate pointers into it.
366 -- Beware that the optimization-preparation code in here knows
367 -- about some of the structure of the compiled regexp.
369 PM
: Pattern_Matcher
renames Matcher
;
370 Program
: Program_Data
renames PM
.Program
;
372 Emit_Code
: constant Boolean := PM
.Size
> 0;
373 Emit_Ptr
: Pointer
:= Program_First
;
375 Parse_Pos
: Natural := Expression
'First; -- Input-scan pointer
376 Parse_End
: constant Natural := Expression
'Last;
378 ----------------------------
379 -- Subprograms for Create --
380 ----------------------------
382 procedure Emit
(B
: Character);
383 -- Output the Character B to the Program. If code-generation is
384 -- disabled, simply increments the program counter.
386 function Emit_Node
(Op
: Opcode
) return Pointer
;
387 -- If code-generation is enabled, Emit_Node outputs the
388 -- opcode Op and reserves space for a pointer to the next node.
389 -- Return value is the location of new opcode, ie old Emit_Ptr.
391 procedure Emit_Natural
(IP
: Pointer
; N
: Natural);
392 -- Split N on two characters at position IP.
394 procedure Emit_Class
(Bitmap
: Character_Class
);
395 -- Emits a character class.
397 procedure Case_Emit
(C
: Character);
398 -- Emit C, after converting is to lower-case if the regular
399 -- expression is case insensitive.
402 (Parenthesized
: Boolean;
403 Flags
: out Expression_Flags
;
405 -- Parse regular expression, i.e. main body or parenthesized thing
406 -- Caller must absorb opening parenthesis.
408 procedure Parse_Branch
409 (Flags
: out Expression_Flags
;
412 -- Implements the concatenation operator and handles '|'
413 -- First should be true if this is the first item of the alternative.
415 procedure Parse_Piece
416 (Expr_Flags
: out Expression_Flags
;
418 -- Parse something followed by possible [*+?]
421 (Expr_Flags
: out Expression_Flags
;
423 -- Parse_Atom is the lowest level parse procedure.
424 -- Optimization: gobbles an entire sequence of ordinary characters
425 -- so that it can turn them into a single node, which is smaller to
426 -- store and faster to run. Backslashed characters are exceptions,
427 -- each becoming a separate node; the code is simpler that way and
428 -- it's not worth fixing.
430 procedure Insert_Operator
433 Greedy
: Boolean := True);
434 -- Insert_Operator inserts an operator in front of an
435 -- already-emitted operand and relocates the operand.
436 -- This applies to PLUS and STAR.
437 -- If Minmod is True, then the operator is non-greedy.
439 procedure Insert_Curly_Operator
444 Greedy
: Boolean := True);
445 -- Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}).
446 -- If Minmod is True, then the operator is non-greedy.
448 procedure Link_Tail
(P
, Val
: Pointer
);
449 -- Link_Tail sets the next-pointer at the end of a node chain
451 procedure Link_Operand_Tail
(P
, Val
: Pointer
);
452 -- Link_Tail on operand of first argument; nop if operandless
454 function Next_Instruction
(P
: Pointer
) return Pointer
;
455 -- Dig the "next" pointer out of a node
457 procedure Fail
(M
: in String);
458 pragma No_Return
(Fail
);
459 -- Fail with a diagnostic message, if possible
461 function Is_Curly_Operator
(IP
: Natural) return Boolean;
462 -- Return True if IP is looking at a '{' that is the beginning
463 -- of a curly operator, ie it matches {\d+,?\d*}
465 function Is_Mult
(IP
: Natural) return Boolean;
466 -- Return True if C is a regexp multiplier: '+', '*' or '?'
468 procedure Get_Curly_Arguments
472 Greedy
: out Boolean);
473 -- Parse the argument list for a curly operator.
474 -- It is assumed that IP is indeed pointing at a valid operator.
475 -- So what is IP and how come IP is not referenced in the body ???
477 procedure Parse_Character_Class
(IP
: out Pointer
);
478 -- Parse a character class.
479 -- The calling subprogram should consume the opening '[' before.
481 procedure Parse_Literal
482 (Expr_Flags
: out Expression_Flags
;
484 -- Parse_Literal encodes a string of characters to be matched exactly
486 function Parse_Posix_Character_Class
return Std_Class
;
487 -- Parse a posic character class, like [:alpha:] or [:^alpha:].
488 -- The called is suppoed to absorbe the opening [.
490 pragma Inline
(Is_Mult
);
491 pragma Inline
(Emit_Natural
);
492 pragma Inline
(Parse_Character_Class
); -- since used only once
498 procedure Case_Emit
(C
: Character) is
500 if (Flags
and Case_Insensitive
) /= 0 then
504 -- Dump current character
514 procedure Emit
(B
: Character) is
517 Program
(Emit_Ptr
) := B
;
520 Emit_Ptr
:= Emit_Ptr
+ 1;
527 procedure Emit_Class
(Bitmap
: Character_Class
) is
528 subtype Program31
is Program_Data
(0 .. 31);
530 function Convert
is new Unchecked_Conversion
531 (Character_Class
, Program31
);
535 Program
(Emit_Ptr
.. Emit_Ptr
+ 31) := Convert
(Bitmap
);
538 Emit_Ptr
:= Emit_Ptr
+ 32;
545 procedure Emit_Natural
(IP
: Pointer
; N
: Natural) is
548 Program
(IP
+ 1) := Character'Val (N
/ 256);
549 Program
(IP
) := Character'Val (N
mod 256);
557 function Emit_Node
(Op
: Opcode
) return Pointer
is
558 Result
: constant Pointer
:= Emit_Ptr
;
562 Program
(Emit_Ptr
) := Character'Val (Opcode
'Pos (Op
));
563 Program
(Emit_Ptr
+ 1) := ASCII
.NUL
;
564 Program
(Emit_Ptr
+ 2) := ASCII
.NUL
;
567 Emit_Ptr
:= Emit_Ptr
+ 3;
575 procedure Fail
(M
: in String) is
577 raise Expression_Error
;
580 -------------------------
581 -- Get_Curly_Arguments --
582 -------------------------
584 procedure Get_Curly_Arguments
588 Greedy
: out Boolean)
590 pragma Unreferenced
(IP
);
592 Save_Pos
: Natural := Parse_Pos
+ 1;
596 Max
:= Max_Curly_Repeat
;
598 while Expression
(Parse_Pos
) /= '}'
599 and then Expression
(Parse_Pos
) /= ','
601 Parse_Pos
:= Parse_Pos
+ 1;
604 Min
:= Natural'Value (Expression
(Save_Pos
.. Parse_Pos
- 1));
606 if Expression
(Parse_Pos
) = ',' then
607 Save_Pos
:= Parse_Pos
+ 1;
608 while Expression
(Parse_Pos
) /= '}' loop
609 Parse_Pos
:= Parse_Pos
+ 1;
612 if Save_Pos
/= Parse_Pos
then
613 Max
:= Natural'Value (Expression
(Save_Pos
.. Parse_Pos
- 1));
620 if Parse_Pos
< Expression
'Last
621 and then Expression
(Parse_Pos
+ 1) = '?'
624 Parse_Pos
:= Parse_Pos
+ 1;
629 end Get_Curly_Arguments
;
631 ---------------------------
632 -- Insert_Curly_Operator --
633 ---------------------------
635 procedure Insert_Curly_Operator
640 Greedy
: Boolean := True)
642 Dest
: constant Pointer
:= Emit_Ptr
;
647 -- If the operand is not greedy, insert an extra operand before it
653 -- Move the operand in the byte-compilation, so that we can insert
654 -- the operator before it.
657 Program
(Operand
+ Size
.. Emit_Ptr
+ Size
) :=
658 Program
(Operand
.. Emit_Ptr
);
661 -- Insert the operator at the position previously occupied by the
667 Old
:= Emit_Node
(MINMOD
);
668 Link_Tail
(Old
, Old
+ 3);
671 Old
:= Emit_Node
(Op
);
672 Emit_Natural
(Old
+ 3, Min
);
673 Emit_Natural
(Old
+ 5, Max
);
675 Emit_Ptr
:= Dest
+ Size
;
676 end Insert_Curly_Operator
;
678 ---------------------
679 -- Insert_Operator --
680 ---------------------
682 procedure Insert_Operator
685 Greedy
: Boolean := True)
687 Dest
: constant Pointer
:= Emit_Ptr
;
692 -- If not greedy, we have to emit another opcode first
698 -- Move the operand in the byte-compilation, so that we can insert
699 -- the operator before it.
702 Program
(Operand
+ Size
.. Emit_Ptr
+ Size
) :=
703 Program
(Operand
.. Emit_Ptr
);
706 -- Insert the operator at the position previously occupied by the
712 Old
:= Emit_Node
(MINMOD
);
713 Link_Tail
(Old
, Old
+ 3);
716 Old
:= Emit_Node
(Op
);
717 Emit_Ptr
:= Dest
+ Size
;
720 -----------------------
721 -- Is_Curly_Operator --
722 -----------------------
724 function Is_Curly_Operator
(IP
: Natural) return Boolean is
725 Scan
: Natural := IP
;
728 if Expression
(Scan
) /= '{'
729 or else Scan
+ 2 > Expression
'Last
730 or else not Is_Digit
(Expression
(Scan
+ 1))
742 if Scan
> Expression
'Last then
746 exit when not Is_Digit
(Expression
(Scan
));
749 if Expression
(Scan
) = ',' then
753 if Scan
> Expression
'Last then
757 exit when not Is_Digit
(Expression
(Scan
));
761 return Expression
(Scan
) = '}';
762 end Is_Curly_Operator
;
768 function Is_Mult
(IP
: Natural) return Boolean is
769 C
: constant Character := Expression
(IP
);
775 or else (C
= '{' and then Is_Curly_Operator
(IP
));
778 -----------------------
779 -- Link_Operand_Tail --
780 -----------------------
782 procedure Link_Operand_Tail
(P
, Val
: Pointer
) is
784 if Emit_Code
and then Program
(P
) = BRANCH
then
785 Link_Tail
(Operand
(P
), Val
);
787 end Link_Operand_Tail
;
793 procedure Link_Tail
(P
, Val
: Pointer
) is
799 if not Emit_Code
then
807 Temp
:= Next_Instruction
(Scan
);
812 Offset
:= Val
- Scan
;
814 Emit_Natural
(Scan
+ 1, Natural (Offset
));
817 ----------------------
818 -- Next_Instruction --
819 ----------------------
821 function Next_Instruction
(P
: Pointer
) return Pointer
is
825 if not Emit_Code
then
829 Offset
:= Get_Next_Offset
(Program
, P
);
836 end Next_Instruction
;
842 -- Combining parenthesis handling with the base level
843 -- of regular expression is a trifle forced, but the
844 -- need to tie the tails of the branches to what follows
845 -- makes it hard to avoid.
848 (Parenthesized
: in Boolean;
849 Flags
: out Expression_Flags
;
852 E
: String renames Expression
;
856 New_Flags
: Expression_Flags
;
857 Have_Branch
: Boolean := False;
860 Flags
:= (Has_Width
=> True, others => False); -- Tentatively
862 -- Make an OPEN node, if parenthesized
864 if Parenthesized
then
865 if Matcher
.Paren_Count
> Max_Paren_Count
then
866 Fail
("too many ()");
869 Par_No
:= Matcher
.Paren_Count
+ 1;
870 Matcher
.Paren_Count
:= Matcher
.Paren_Count
+ 1;
871 IP
:= Emit_Node
(OPEN
);
872 Emit
(Character'Val (Par_No
));
879 -- Pick up the branches, linking them together
881 Parse_Branch
(New_Flags
, True, Br
);
888 if Parse_Pos
<= Parse_End
889 and then E
(Parse_Pos
) = '|'
891 Insert_Operator
(BRANCH
, Br
);
896 Link_Tail
(IP
, Br
); -- OPEN -> first
901 if not New_Flags
.Has_Width
then
902 Flags
.Has_Width
:= False;
905 Flags
.SP_Start
:= Flags
.SP_Start
or New_Flags
.SP_Start
;
907 while Parse_Pos
<= Parse_End
908 and then (E
(Parse_Pos
) = '|')
910 Parse_Pos
:= Parse_Pos
+ 1;
911 Parse_Branch
(New_Flags
, False, Br
);
918 Link_Tail
(IP
, Br
); -- BRANCH -> BRANCH
920 if not New_Flags
.Has_Width
then
921 Flags
.Has_Width
:= False;
924 Flags
.SP_Start
:= Flags
.SP_Start
or New_Flags
.SP_Start
;
927 -- Make a closing node, and hook it on the end
929 if Parenthesized
then
930 Ender
:= Emit_Node
(CLOSE
);
931 Emit
(Character'Val (Par_No
));
933 Ender
:= Emit_Node
(EOP
);
936 Link_Tail
(IP
, Ender
);
940 -- Hook the tails of the branches to the closing node
945 Link_Operand_Tail
(Br
, Ender
);
946 Br
:= Next_Instruction
(Br
);
950 -- Check for proper termination
952 if Parenthesized
then
953 if Parse_Pos
> Parse_End
or else E
(Parse_Pos
) /= ')' then
954 Fail
("unmatched ()");
957 Parse_Pos
:= Parse_Pos
+ 1;
959 elsif Parse_Pos
<= Parse_End
then
960 if E
(Parse_Pos
) = ')' then
961 Fail
("unmatched ()");
963 Fail
("junk on end"); -- "Can't happen"
973 (Expr_Flags
: out Expression_Flags
;
979 -- Tentatively set worst expression case
981 Expr_Flags
:= Worst_Expression
;
983 C
:= Expression
(Parse_Pos
);
984 Parse_Pos
:= Parse_Pos
+ 1;
988 if (Flags
and Multiple_Lines
) /= 0 then
989 IP
:= Emit_Node
(MBOL
);
990 elsif (Flags
and Single_Line
) /= 0 then
991 IP
:= Emit_Node
(SBOL
);
993 IP
:= Emit_Node
(BOL
);
997 if (Flags
and Multiple_Lines
) /= 0 then
998 IP
:= Emit_Node
(MEOL
);
999 elsif (Flags
and Single_Line
) /= 0 then
1000 IP
:= Emit_Node
(SEOL
);
1002 IP
:= Emit_Node
(EOL
);
1006 if (Flags
and Single_Line
) /= 0 then
1007 IP
:= Emit_Node
(SANY
);
1009 IP
:= Emit_Node
(ANY
);
1012 Expr_Flags
.Has_Width
:= True;
1013 Expr_Flags
.Simple
:= True;
1016 Parse_Character_Class
(IP
);
1017 Expr_Flags
.Has_Width
:= True;
1018 Expr_Flags
.Simple
:= True;
1022 New_Flags
: Expression_Flags
;
1025 Parse
(True, New_Flags
, IP
);
1031 Expr_Flags
.Has_Width
:=
1032 Expr_Flags
.Has_Width
or New_Flags
.Has_Width
;
1033 Expr_Flags
.SP_Start
:=
1034 Expr_Flags
.SP_Start
or New_Flags
.SP_Start
;
1037 when '|' | ASCII
.LF |
')' =>
1038 Fail
("internal urp"); -- Supposed to be caught earlier
1040 when '?' |
'+' |
'*' =>
1041 Fail
(C
& " follows nothing");
1044 if Is_Curly_Operator
(Parse_Pos
- 1) then
1045 Fail
(C
& " follows nothing");
1047 Parse_Literal
(Expr_Flags
, IP
);
1051 if Parse_Pos
> Parse_End
then
1052 Fail
("trailing \");
1055 Parse_Pos := Parse_Pos + 1;
1057 case Expression (Parse_Pos - 1) is
1059 IP := Emit_Node (BOUND);
1062 IP := Emit_Node (NBOUND);
1065 IP := Emit_Node (SPACE);
1066 Expr_Flags.Simple := True;
1067 Expr_Flags.Has_Width := True;
1070 IP := Emit_Node (NSPACE);
1071 Expr_Flags.Simple := True;
1072 Expr_Flags.Has_Width := True;
1075 IP := Emit_Node (DIGIT);
1076 Expr_Flags.Simple := True;
1077 Expr_Flags.Has_Width := True;
1080 IP := Emit_Node (NDIGIT);
1081 Expr_Flags.Simple := True;
1082 Expr_Flags.Has_Width := True;
1085 IP := Emit_Node (ALNUM);
1086 Expr_Flags.Simple := True;
1087 Expr_Flags.Has_Width := True;
1090 IP := Emit_Node (NALNUM);
1091 Expr_Flags.Simple := True;
1092 Expr_Flags.Has_Width := True;
1095 IP := Emit_Node (SBOL);
1098 IP := Emit_Node (SEOL);
1101 IP := Emit_Node (REFF);
1104 Save : constant Natural := Parse_Pos - 1;
1107 while Parse_Pos <= Expression'Last
1108 and then Is_Digit (Expression (Parse_Pos))
1110 Parse_Pos := Parse_Pos + 1;
1113 Emit (Character'Val (Natural'Value
1114 (Expression (Save .. Parse_Pos - 1))));
1118 Parse_Pos := Parse_Pos - 1;
1119 Parse_Literal (Expr_Flags, IP);
1123 Parse_Literal (Expr_Flags, IP);
1131 procedure Parse_Branch
1132 (Flags : out Expression_Flags;
1136 E : String renames Expression;
1139 New_Flags : Expression_Flags;
1142 pragma Warnings (Off, Discard);
1145 Flags := Worst_Expression; -- Tentatively
1150 IP := Emit_Node (BRANCH);
1155 while Parse_Pos <= Parse_End
1156 and then E (Parse_Pos) /= ')'
1157 and then E (Parse_Pos) /= ASCII.LF
1158 and then E (Parse_Pos) /= '|'
1160 Parse_Piece (New_Flags, Last);
1167 Flags.Has_Width := Flags.Has_Width or New_Flags.Has_Width;
1169 if Chain = 0 then -- First piece
1170 Flags.SP_Start := Flags.SP_Start or New_Flags.SP_Start;
1172 Link_Tail (Chain, Last);
1178 -- Case where loop ran zero CURLY
1181 Discard := Emit_Node (NOTHING);
1185 ---------------------------
1186 -- Parse_Character_Class --
1187 ---------------------------
1189 procedure Parse_Character_Class (IP : out Pointer) is
1190 Bitmap : Character_Class;
1191 Invert : Boolean := False;
1192 In_Range : Boolean := False;
1193 Named_Class : Std_Class := ANYOF_NONE;
1195 Last_Value : Character := ASCII.Nul;
1198 Reset_Class (Bitmap);
1200 -- Do we have an invert character class ?
1202 if Parse_Pos <= Parse_End
1203 and then Expression (Parse_Pos) = '^'
1206 Parse_Pos := Parse_Pos + 1;
1209 -- First character can be ] or -, without closing the class.
1211 if Parse_Pos <= Parse_End
1212 and then (Expression (Parse_Pos) = ']'
1213 or else Expression (Parse_Pos) = '-')
1215 Set_In_Class (Bitmap, Expression (Parse_Pos));
1216 Parse_Pos := Parse_Pos + 1;
1219 -- While we don't have the end of the class
1221 while Parse_Pos <= Parse_End
1222 and then Expression (Parse_Pos) /= ']'
1224 Named_Class := ANYOF_NONE;
1225 Value := Expression (Parse_Pos);
1226 Parse_Pos := Parse_Pos + 1;
1228 -- Do we have a Posix character class
1230 Named_Class := Parse_Posix_Character_Class;
1232 elsif Value = '\' then
1233 if Parse_Pos = Parse_End then
1234 Fail ("Trailing
\");
1236 Value
:= Expression
(Parse_Pos
);
1237 Parse_Pos
:= Parse_Pos
+ 1;
1240 when 'w' => Named_Class
:= ANYOF_ALNUM
;
1241 when 'W' => Named_Class
:= ANYOF_NALNUM
;
1242 when 's' => Named_Class
:= ANYOF_SPACE
;
1243 when 'S' => Named_Class
:= ANYOF_NSPACE
;
1244 when 'd' => Named_Class
:= ANYOF_DIGIT
;
1245 when 'D' => Named_Class
:= ANYOF_NDIGIT
;
1246 when 'n' => Value
:= ASCII
.LF
;
1247 when 'r' => Value
:= ASCII
.CR
;
1248 when 't' => Value
:= ASCII
.HT
;
1249 when 'f' => Value
:= ASCII
.FF
;
1250 when 'e' => Value
:= ASCII
.ESC
;
1251 when 'a' => Value
:= ASCII
.BEL
;
1253 -- when 'x' => ??? hexadecimal value
1254 -- when 'c' => ??? control character
1255 -- when '0'..'9' => ??? octal character
1257 when others => null;
1261 -- Do we have a character class?
1263 if Named_Class
/= ANYOF_NONE
then
1265 -- A range like 'a-\d' or 'a-[:digit:] is not a range
1268 Set_In_Class
(Bitmap
, Last_Value
);
1269 Set_In_Class
(Bitmap
, '-');
1276 when ANYOF_NONE
=> null;
1278 when ANYOF_ALNUM | ANYOF_ALNUMC
=>
1279 for Value
in Class_Byte
'Range loop
1280 if Is_Alnum
(Character'Val (Value
)) then
1281 Set_In_Class
(Bitmap
, Character'Val (Value
));
1285 when ANYOF_NALNUM | ANYOF_NALNUMC
=>
1286 for Value
in Class_Byte
'Range loop
1287 if not Is_Alnum
(Character'Val (Value
)) then
1288 Set_In_Class
(Bitmap
, Character'Val (Value
));
1293 for Value
in Class_Byte
'Range loop
1294 if Is_White_Space
(Character'Val (Value
)) then
1295 Set_In_Class
(Bitmap
, Character'Val (Value
));
1299 when ANYOF_NSPACE
=>
1300 for Value
in Class_Byte
'Range loop
1301 if not Is_White_Space
(Character'Val (Value
)) then
1302 Set_In_Class
(Bitmap
, Character'Val (Value
));
1307 for Value
in Class_Byte
'Range loop
1308 if Is_Digit
(Character'Val (Value
)) then
1309 Set_In_Class
(Bitmap
, Character'Val (Value
));
1313 when ANYOF_NDIGIT
=>
1314 for Value
in Class_Byte
'Range loop
1315 if not Is_Digit
(Character'Val (Value
)) then
1316 Set_In_Class
(Bitmap
, Character'Val (Value
));
1321 for Value
in Class_Byte
'Range loop
1322 if Is_Letter
(Character'Val (Value
)) then
1323 Set_In_Class
(Bitmap
, Character'Val (Value
));
1327 when ANYOF_NALPHA
=>
1328 for Value
in Class_Byte
'Range loop
1329 if not Is_Letter
(Character'Val (Value
)) then
1330 Set_In_Class
(Bitmap
, Character'Val (Value
));
1335 for Value
in 0 .. 127 loop
1336 Set_In_Class
(Bitmap
, Character'Val (Value
));
1339 when ANYOF_NASCII
=>
1340 for Value
in 128 .. 255 loop
1341 Set_In_Class
(Bitmap
, Character'Val (Value
));
1345 for Value
in Class_Byte
'Range loop
1346 if Is_Control
(Character'Val (Value
)) then
1347 Set_In_Class
(Bitmap
, Character'Val (Value
));
1351 when ANYOF_NCNTRL
=>
1352 for Value
in Class_Byte
'Range loop
1353 if not Is_Control
(Character'Val (Value
)) then
1354 Set_In_Class
(Bitmap
, Character'Val (Value
));
1359 for Value
in Class_Byte
'Range loop
1360 if Is_Graphic
(Character'Val (Value
)) then
1361 Set_In_Class
(Bitmap
, Character'Val (Value
));
1365 when ANYOF_NGRAPH
=>
1366 for Value
in Class_Byte
'Range loop
1367 if not Is_Graphic
(Character'Val (Value
)) then
1368 Set_In_Class
(Bitmap
, Character'Val (Value
));
1373 for Value
in Class_Byte
'Range loop
1374 if Is_Lower
(Character'Val (Value
)) then
1375 Set_In_Class
(Bitmap
, Character'Val (Value
));
1379 when ANYOF_NLOWER
=>
1380 for Value
in Class_Byte
'Range loop
1381 if not Is_Lower
(Character'Val (Value
)) then
1382 Set_In_Class
(Bitmap
, Character'Val (Value
));
1387 for Value
in Class_Byte
'Range loop
1388 if Is_Printable
(Character'Val (Value
)) then
1389 Set_In_Class
(Bitmap
, Character'Val (Value
));
1393 when ANYOF_NPRINT
=>
1394 for Value
in Class_Byte
'Range loop
1395 if not Is_Printable
(Character'Val (Value
)) then
1396 Set_In_Class
(Bitmap
, Character'Val (Value
));
1401 for Value
in Class_Byte
'Range loop
1402 if Is_Printable
(Character'Val (Value
))
1403 and then not Is_White_Space
(Character'Val (Value
))
1404 and then not Is_Alnum
(Character'Val (Value
))
1406 Set_In_Class
(Bitmap
, Character'Val (Value
));
1410 when ANYOF_NPUNCT
=>
1411 for Value
in Class_Byte
'Range loop
1412 if not Is_Printable
(Character'Val (Value
))
1413 or else Is_White_Space
(Character'Val (Value
))
1414 or else Is_Alnum
(Character'Val (Value
))
1416 Set_In_Class
(Bitmap
, Character'Val (Value
));
1421 for Value
in Class_Byte
'Range loop
1422 if Is_Upper
(Character'Val (Value
)) then
1423 Set_In_Class
(Bitmap
, Character'Val (Value
));
1427 when ANYOF_NUPPER
=>
1428 for Value
in Class_Byte
'Range loop
1429 if not Is_Upper
(Character'Val (Value
)) then
1430 Set_In_Class
(Bitmap
, Character'Val (Value
));
1434 when ANYOF_XDIGIT
=>
1435 for Value
in Class_Byte
'Range loop
1436 if Is_Hexadecimal_Digit
(Character'Val (Value
)) then
1437 Set_In_Class
(Bitmap
, Character'Val (Value
));
1441 when ANYOF_NXDIGIT
=>
1442 for Value
in Class_Byte
'Range loop
1443 if not Is_Hexadecimal_Digit
1444 (Character'Val (Value
))
1446 Set_In_Class
(Bitmap
, Character'Val (Value
));
1452 -- Not a character range
1454 elsif not In_Range
then
1455 Last_Value
:= Value
;
1457 if Expression
(Parse_Pos
) = '-'
1458 and then Parse_Pos
< Parse_End
1459 and then Expression
(Parse_Pos
+ 1) /= ']'
1461 Parse_Pos
:= Parse_Pos
+ 1;
1463 -- Do we have a range like '\d-a' and '[:space:]-a'
1464 -- which is not a real range
1466 if Named_Class
/= ANYOF_NONE
then
1467 Set_In_Class
(Bitmap
, '-');
1473 Set_In_Class
(Bitmap
, Value
);
1477 -- Else in a character range
1480 if Last_Value
> Value
then
1481 Fail
("Invalid Range [" & Last_Value
'Img
1482 & "-" & Value
'Img & "]");
1485 while Last_Value
<= Value
loop
1486 Set_In_Class
(Bitmap
, Last_Value
);
1487 Last_Value
:= Character'Succ (Last_Value
);
1496 -- Optimize case-insensitive ranges (put the upper case or lower
1497 -- case character into the bitmap)
1499 if (Flags
and Case_Insensitive
) /= 0 then
1500 for C
in Character'Range loop
1501 if Get_From_Class
(Bitmap
, C
) then
1502 Set_In_Class
(Bitmap
, To_Lower
(C
));
1503 Set_In_Class
(Bitmap
, To_Upper
(C
));
1508 -- Optimize inverted classes
1511 for J
in Bitmap
'Range loop
1512 Bitmap
(J
) := not Bitmap
(J
);
1516 Parse_Pos
:= Parse_Pos
+ 1;
1520 IP
:= Emit_Node
(ANYOF
);
1521 Emit_Class
(Bitmap
);
1522 end Parse_Character_Class
;
1528 -- This is a bit tricky due to quoted chars and due to
1529 -- the multiplier characters '*', '+', and '?' that
1530 -- take the SINGLE char previous as their operand.
1532 -- On entry, the character at Parse_Pos - 1 is going to go
1533 -- into the string, no matter what it is. It could be
1534 -- following a \ if Parse_Atom was entered from the '\' case.
1536 -- Basic idea is to pick up a good char in C and examine
1537 -- the next char. If Is_Mult (C) then twiddle, if it's a \
1538 -- then frozzle and if it's another magic char then push C and
1539 -- terminate the string. If none of the above, push C on the
1540 -- string and go around again.
1542 -- Start_Pos is used to remember where "the current character"
1543 -- starts in the string, if due to an Is_Mult we need to back
1544 -- up and put the current char in a separate 1-character string.
1545 -- When Start_Pos is 0, C is the only char in the string;
1546 -- this is used in Is_Mult handling, and in setting the SIMPLE
1549 procedure Parse_Literal
1550 (Expr_Flags
: out Expression_Flags
;
1553 Start_Pos
: Natural := 0;
1555 Length_Ptr
: Pointer
;
1557 Has_Special_Operator
: Boolean := False;
1560 Parse_Pos
:= Parse_Pos
- 1; -- Look at current character
1562 if (Flags
and Case_Insensitive
) /= 0 then
1563 IP
:= Emit_Node
(EXACTF
);
1565 IP
:= Emit_Node
(EXACT
);
1568 Length_Ptr
:= Emit_Ptr
;
1569 Emit_Ptr
:= String_Operand
(IP
);
1573 C
:= Expression
(Parse_Pos
); -- Get current character
1576 when '.' |
'[' |
'(' |
')' |
'|' | ASCII
.LF |
'$' |
'^' =>
1578 if Start_Pos
= 0 then
1579 Start_Pos
:= Parse_Pos
;
1580 Emit
(C
); -- First character is always emitted
1582 exit Parse_Loop
; -- Else we are done
1585 when '?' |
'+' |
'*' |
'{' =>
1587 if Start_Pos
= 0 then
1588 Start_Pos
:= Parse_Pos
;
1589 Emit
(C
); -- First character is always emitted
1591 -- Are we looking at an operator, or is this
1592 -- simply a normal character ?
1594 elsif not Is_Mult
(Parse_Pos
) then
1595 Start_Pos
:= Parse_Pos
;
1599 -- We've got something like "abc?d". Mark this as a
1600 -- special case. What we want to emit is a first
1601 -- constant string for "ab", then one for "c" that will
1602 -- ultimately be transformed with a CURLY operator, A
1603 -- special case has to be handled for "a?", since there
1604 -- is no initial string to emit.
1606 Has_Special_Operator
:= True;
1611 Start_Pos
:= Parse_Pos
;
1613 if Parse_Pos
= Parse_End
then
1614 Fail
("Trailing \");
1617 case Expression (Parse_Pos + 1) is
1618 when 'b' | 'B' | 's' | 'S' | 'd' | 'D'
1619 | 'w' | 'W' | '0' .. '9' | 'G' | 'A'
1621 when 'n' => Emit (ASCII.LF);
1622 when 't' => Emit (ASCII.HT);
1623 when 'r' => Emit (ASCII.CR);
1624 when 'f' => Emit (ASCII.FF);
1625 when 'e' => Emit (ASCII.ESC);
1626 when 'a' => Emit (ASCII.BEL);
1627 when others => Emit (Expression (Parse_Pos + 1));
1630 Parse_Pos := Parse_Pos + 1;
1634 Start_Pos := Parse_Pos;
1638 exit Parse_Loop when Emit_Ptr - Length_Ptr = 254;
1640 Parse_Pos := Parse_Pos + 1;
1642 exit Parse_Loop when Parse_Pos > Parse_End;
1643 end loop Parse_Loop;
1645 -- Is the string followed by a '*+?{' operator ? If yes, and if there
1646 -- is an initial string to emit, do it now.
1648 if Has_Special_Operator
1649 and then Emit_Ptr >= Length_Ptr + 3
1651 Emit_Ptr := Emit_Ptr - 1;
1652 Parse_Pos := Start_Pos;
1656 Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2);
1659 Expr_Flags.Has_Width := True;
1661 -- Slight optimization when there is a single character
1663 if Emit_Ptr = Length_Ptr + 2 then
1664 Expr_Flags.Simple := True;
1672 -- Note that the branching code sequences used for '?' and the
1673 -- general cases of '*' and + are somewhat optimized: they use
1674 -- the same NOTHING node as both the endmarker for their branch
1675 -- list and the body of the last branch. It might seem that
1676 -- this node could be dispensed with entirely, but the endmarker
1677 -- role is not redundant.
1679 procedure Parse_Piece
1680 (Expr_Flags : out Expression_Flags;
1684 New_Flags : Expression_Flags;
1685 Greedy : Boolean := True;
1688 Parse_Atom (New_Flags, IP);
1694 if Parse_Pos > Parse_End
1695 or else not Is_Mult (Parse_Pos)
1697 Expr_Flags := New_Flags;
1701 Op := Expression (Parse_Pos);
1704 Expr_Flags := (SP_Start => True, others => False);
1706 Expr_Flags := (Has_Width => True, others => False);
1709 -- Detect non greedy operators in the easy cases
1712 and then Parse_Pos + 1 <= Parse_End
1713 and then Expression (Parse_Pos + 1) = '?'
1716 Parse_Pos := Parse_Pos + 1;
1719 -- Generate the byte code
1724 if New_Flags.Simple then
1725 Insert_Operator (STAR, IP, Greedy);
1727 Link_Tail (IP, Emit_Node (WHILEM));
1728 Insert_Curly_Operator
1729 (CURLYX, 0, Max_Curly_Repeat, IP, Greedy);
1730 Link_Tail (IP, Emit_Node (NOTHING));
1735 if New_Flags.Simple then
1736 Insert_Operator (PLUS, IP, Greedy);
1738 Link_Tail (IP, Emit_Node (WHILEM));
1739 Insert_Curly_Operator
1740 (CURLYX, 1, Max_Curly_Repeat, IP, Greedy);
1741 Link_Tail (IP, Emit_Node (NOTHING));
1745 if New_Flags.Simple then
1746 Insert_Curly_Operator (CURLY, 0, 1, IP, Greedy);
1748 Link_Tail (IP, Emit_Node (WHILEM));
1749 Insert_Curly_Operator (CURLYX, 0, 1, IP, Greedy);
1750 Link_Tail (IP, Emit_Node (NOTHING));
1758 Get_Curly_Arguments (Parse_Pos, Min, Max, Greedy);
1760 if New_Flags.Simple then
1761 Insert_Curly_Operator (CURLY, Min, Max, IP, Greedy);
1763 Link_Tail (IP, Emit_Node (WHILEM));
1764 Insert_Curly_Operator (CURLYX, Min, Max, IP, Greedy);
1765 Link_Tail (IP, Emit_Node (NOTHING));
1773 Parse_Pos := Parse_Pos + 1;
1775 if Parse_Pos <= Parse_End
1776 and then Is_Mult (Parse_Pos)
1778 Fail ("nested
*+{");
1782 ---------------------------------
1783 -- Parse_Posix_Character_Class --
1784 ---------------------------------
1786 function Parse_Posix_Character_Class return Std_Class is
1787 Invert : Boolean := False;
1788 Class : Std_Class := ANYOF_NONE;
1789 E : String renames Expression;
1791 -- Class names. Note that code assumes that the length of all
1792 -- classes starting with the same letter have the same length.
1794 Alnum : constant String := "alnum
:]";
1795 Alpha : constant String := "alpha
:]";
1796 Ascii_C : constant String := "ascii
:]";
1797 Cntrl : constant String := "cntrl
:]";
1798 Digit : constant String := "digit
:]";
1799 Graph : constant String := "graph
:]";
1800 Lower : constant String := "lower
:]";
1801 Print : constant String := "print
:]";
1802 Punct : constant String := "punct
:]";
1803 Space : constant String := "space
:]";
1804 Upper : constant String := "upper
:]";
1805 Word : constant String := "word
:]";
1806 Xdigit : constant String := "xdigit
:]";
1809 -- Case of character class specified
1811 if Parse_Pos <= Parse_End
1812 and then Expression (Parse_Pos) = ':'
1814 Parse_Pos := Parse_Pos + 1;
1816 -- Do we have something like: [[:^alpha:]]
1818 if Parse_Pos <= Parse_End
1819 and then Expression (Parse_Pos) = '^'
1822 Parse_Pos := Parse_Pos + 1;
1825 -- Check for class names based on first letter
1827 case Expression (Parse_Pos) is
1831 -- All 'a' classes have the same length (Alnum'Length)
1833 if Parse_Pos + Alnum'Length - 1 <= Parse_End then
1835 if E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) =
1839 Class := ANYOF_NALNUMC;
1841 Class := ANYOF_ALNUMC;
1844 Parse_Pos := Parse_Pos + Alnum'Length;
1846 elsif E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) =
1850 Class := ANYOF_NALPHA;
1852 Class := ANYOF_ALPHA;
1855 Parse_Pos := Parse_Pos + Alpha'Length;
1857 elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) =
1861 Class := ANYOF_NASCII;
1863 Class := ANYOF_ASCII;
1866 Parse_Pos := Parse_Pos + Ascii_C'Length;
1871 if Parse_Pos + Cntrl'Length - 1 <= Parse_End
1872 and then E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) =
1876 Class := ANYOF_NCNTRL;
1878 Class := ANYOF_CNTRL;
1881 Parse_Pos := Parse_Pos + Cntrl'Length;
1885 if Parse_Pos + Digit'Length - 1 <= Parse_End
1886 and then E (Parse_Pos .. Parse_Pos + Digit'Length - 1) =
1890 Class := ANYOF_NDIGIT;
1892 Class := ANYOF_DIGIT;
1895 Parse_Pos := Parse_Pos + Digit'Length;
1899 if Parse_Pos + Graph'Length - 1 <= Parse_End
1900 and then E (Parse_Pos .. Parse_Pos + Graph'Length - 1) =
1904 Class := ANYOF_NGRAPH;
1906 Class := ANYOF_GRAPH;
1908 Parse_Pos := Parse_Pos + Graph'Length;
1912 if Parse_Pos + Lower'Length - 1 <= Parse_End
1913 and then E (Parse_Pos .. Parse_Pos + Lower'Length - 1) =
1917 Class := ANYOF_NLOWER;
1919 Class := ANYOF_LOWER;
1921 Parse_Pos := Parse_Pos + Lower'Length;
1926 -- All 'p' classes have the same length
1928 if Parse_Pos + Print'Length - 1 <= Parse_End then
1929 if E (Parse_Pos .. Parse_Pos + Print'Length - 1) =
1933 Class := ANYOF_NPRINT;
1935 Class := ANYOF_PRINT;
1938 Parse_Pos := Parse_Pos + Print'Length;
1940 elsif E (Parse_Pos .. Parse_Pos + Punct'Length - 1) =
1944 Class := ANYOF_NPUNCT;
1946 Class := ANYOF_PUNCT;
1949 Parse_Pos := Parse_Pos + Punct'Length;
1954 if Parse_Pos + Space'Length - 1 <= Parse_End
1955 and then E (Parse_Pos .. Parse_Pos + Space'Length - 1) =
1959 Class := ANYOF_NSPACE;
1961 Class := ANYOF_SPACE;
1964 Parse_Pos := Parse_Pos + Space'Length;
1969 if Parse_Pos + Upper'Length - 1 <= Parse_End
1970 and then E (Parse_Pos .. Parse_Pos + Upper'Length - 1) =
1974 Class := ANYOF_NUPPER;
1976 Class := ANYOF_UPPER;
1978 Parse_Pos := Parse_Pos + Upper'Length;
1983 if Parse_Pos + Word'Length - 1 <= Parse_End
1984 and then E (Parse_Pos .. Parse_Pos + Word'Length - 1) =
1988 Class := ANYOF_NALNUM;
1990 Class := ANYOF_ALNUM;
1992 Parse_Pos := Parse_Pos + Word'Length;
1997 if Parse_Pos + Xdigit'Length - 1 <= Parse_End
1998 and then E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1)
2002 Class := ANYOF_NXDIGIT;
2004 Class := ANYOF_XDIGIT;
2007 Parse_Pos := Parse_Pos + Xdigit'Length;
2011 Fail ("Invalid
character class
");
2014 -- Character class not specified
2021 end Parse_Posix_Character_Class;
2023 Expr_Flags : Expression_Flags;
2026 -- Start of processing for Compile
2030 Parse (False, Expr_Flags, Result);
2033 Fail ("Couldn
't compile expression
");
2036 Final_Code_Size := Emit_Ptr - 1;
2038 -- Do we want to actually compile the expression, or simply get the
2049 (Expression : String;
2050 Flags : Regexp_Flags := No_Flags) return Pattern_Matcher
2052 Size : Program_Size;
2053 Dummy : Pattern_Matcher (0);
2056 Compile (Dummy, Expression, Size, Flags);
2059 Result : Pattern_Matcher (Size);
2061 Compile (Result, Expression, Size, Flags);
2067 (Matcher : out Pattern_Matcher;
2068 Expression : String;
2069 Flags : Regexp_Flags := No_Flags)
2071 Size : Program_Size;
2074 Compile (Matcher, Expression, Size, Flags);
2081 procedure Dump (Self : Pattern_Matcher) is
2083 -- Index : Pointer := Program_First + 1;
2084 -- What is the above line for ???
2087 Program : Program_Data renames Self.Program;
2089 procedure Dump_Until
2092 Indent : Natural := 0);
2093 -- Dump the program until the node Till (not included) is met.
2094 -- Every line is indented with Index spaces at the beginning
2095 -- Dumps till the end if Till is 0.
2101 procedure Dump_Until
2104 Indent : Natural := 0)
2107 Index : Pointer := Start;
2108 Local_Indent : Natural := Indent;
2112 while Index < Till loop
2114 Op := Opcode'Val (Character'Pos ((Self.Program (Index))));
2117 Local_Indent := Local_Indent - 3;
2121 Point : constant String := Pointer'Image (Index);
2124 for J in 1 .. 6 - Point'Length loop
2130 & (1 .. Local_Indent => ' ')
2131 & Opcode'Image (Op));
2134 -- Print the parenthesis number
2136 if Op = OPEN or else Op = CLOSE or else Op = REFF then
2137 Put (Natural'Image (Character'Pos (Program (Index + 3))));
2140 Next := Index + Get_Next_Offset (Program, Index);
2142 if Next = Index then
2143 Put (" (next
at 0)");
2145 Put (" (next
at " & Pointer'Image (Next) & ")");
2150 -- Character class operand
2154 Bitmap : Character_Class;
2155 Last : Character := ASCII.Nul;
2156 Current : Natural := 0;
2158 Current_Char : Character;
2161 Bitmap_Operand (Program, Index, Bitmap);
2164 while Current <= 255 loop
2165 Current_Char := Character'Val (Current);
2167 -- First item in a range
2169 if Get_From_Class (Bitmap, Current_Char) then
2170 Last := Current_Char;
2172 -- Search for the last item in the range
2175 Current := Current + 1;
2176 exit when Current > 255;
2177 Current_Char := Character'Val (Current);
2179 not Get_From_Class (Bitmap, Current_Char);
2189 if Character'Succ (Last) /= Current_Char then
2190 Put ("-" & Character'Pred (Current_Char));
2194 Current := Current + 1;
2199 Index := Index + 3 + Bitmap'Length;
2204 when EXACT | EXACTF =>
2205 Length := String_Length (Program, Index);
2206 Put (" operand
(length
:" & Program_Size'Image (Length + 1)
2208 & String (Program (String_Operand (Index)
2209 .. String_Operand (Index)
2211 Index := String_Operand (Index) + Length + 1;
2218 Dump_Until (Index + 3, Next, Local_Indent + 3);
2224 -- Only one instruction
2226 Dump_Until (Index + 3, Index + 4, Local_Indent + 3);
2229 when CURLY | CURLYX =>
2231 & Natural'Image (Read_Natural (Program, Index + 3))
2233 & Natural'Image (Read_Natural (Program, Index + 5))
2236 Dump_Until (Index + 7, Next, Local_Indent + 3);
2242 Local_Indent := Local_Indent + 3;
2244 when CLOSE | REFF =>
2262 -- Start of processing for Dump
2265 pragma Assert (Self.Program (Program_First) = MAGIC,
2266 "Corrupted Pattern_Matcher
");
2268 Put_Line ("Must start
with (Self
.First
) = "
2269 & Character'Image (Self.First));
2271 if (Self.Flags and Case_Insensitive) /= 0 then
2272 Put_Line (" Case_Insensitive mode
");
2275 if (Self.Flags and Single_Line) /= 0 then
2276 Put_Line (" Single_Line mode
");
2279 if (Self.Flags and Multiple_Lines) /= 0 then
2280 Put_Line (" Multiple_Lines mode
");
2283 Put_Line (" 1 : MAGIC
");
2284 Dump_Until (Program_First + 1, Self.Program'Last + 1);
2287 --------------------
2288 -- Get_From_Class --
2289 --------------------
2291 function Get_From_Class
2292 (Bitmap : Character_Class;
2293 C : Character) return Boolean
2295 Value : constant Class_Byte := Character'Pos (C);
2299 (Bitmap (Value / 8) and Bit_Conversion (Value mod 8)) /= 0;
2306 function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is
2307 Offset : constant Pointer := Get_Next_Offset (Program, IP);
2317 ---------------------
2318 -- Get_Next_Offset --
2319 ---------------------
2321 function Get_Next_Offset
2322 (Program : Program_Data;
2323 IP : Pointer) return Pointer
2326 return Pointer (Read_Natural (Program, IP + 1));
2327 end Get_Next_Offset;
2333 function Is_Alnum (C : Character) return Boolean is
2335 return Is_Alphanumeric (C) or else C = '_';
2342 function Is_Printable (C : Character) return Boolean is
2344 -- Printable if space or graphic character or other whitespace
2345 -- Other white space includes (HT/LF/VT/FF/CR = codes 9-13)
2347 return C in Character'Val (32) .. Character'Val (126)
2348 or else C in ASCII.HT .. ASCII.CR;
2351 --------------------
2352 -- Is_White_Space --
2353 --------------------
2355 function Is_White_Space (C : Character) return Boolean is
2357 -- Note: HT = 9, LF = 10, VT = 11, FF = 12, CR = 13
2359 return C = ' ' or else C in ASCII.HT .. ASCII.CR;
2367 (Self : Pattern_Matcher;
2369 Matches : out Match_Array;
2370 Data_First : Integer := -1;
2371 Data_Last : Positive := Positive'Last)
2373 Program : Program_Data renames Self.Program; -- Shorter notation
2375 First_In_Data : constant Integer := Integer'Max (Data_First, Data'First);
2376 Last_In_Data : constant Integer := Integer'Min (Data_Last, Data'Last);
2378 -- Global work variables
2380 Input_Pos : Natural; -- String-input pointer
2381 BOL_Pos : Natural; -- Beginning of input, for ^ check
2382 Matched : Boolean := False; -- Until proven True
2384 Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count,
2386 -- Stores the value of all the parenthesis pairs.
2387 -- We do not use directly Matches, so that we can also use back
2388 -- references (REFF) even if Matches is too small.
2390 type Natural_Array is array (Match_Count range <>) of Natural;
2391 Matches_Tmp : Natural_Array (Matches_Full'Range);
2392 -- Save the opening position of parenthesis.
2394 Last_Paren : Natural := 0;
2395 -- Last parenthesis seen
2397 Greedy : Boolean := True;
2398 -- True if the next operator should be greedy
2400 type Current_Curly_Record;
2401 type Current_Curly_Access is access all Current_Curly_Record;
2402 type Current_Curly_Record is record
2403 Paren_Floor : Natural; -- How far back to strip parenthesis data
2404 Cur : Integer; -- How many instances of scan we've matched
2405 Min : Natural; -- Minimal number of scans to match
2406 Max : Natural; -- Maximal number of scans to match
2407 Greedy : Boolean; -- Whether to work our way up or down
2408 Scan : Pointer; -- The thing to match
2409 Next : Pointer; -- What has to match after it
2410 Lastloc : Natural; -- Where we started matching this scan
2411 Old_Cc : Current_Curly_Access; -- Before we started this one
2413 -- Data used to handle the curly operator and the plus and star
2414 -- operators for complex expressions.
2416 Current_Curly : Current_Curly_Access := null;
2417 -- The curly currently being processed.
2419 -----------------------
2420 -- Local Subprograms --
2421 -----------------------
2423 function Index (Start : Positive; C : Character) return Natural;
2424 -- Find character C in Data starting at Start and return position
2428 Max : Natural := Natural'Last) return Natural;
2429 -- Repeatedly match something simple, report how many
2430 -- It only matches on things of length 1.
2431 -- Starting from Input_Pos, it matches at most Max CURLY.
2433 function Try (Pos : in Positive) return Boolean;
2434 -- Try to match at specific point
2436 function Match (IP : Pointer) return Boolean;
2437 -- This is the main matching routine. Conceptually the strategy
2438 -- is simple: check to see whether the current node matches,
2439 -- call self recursively to see whether the rest matches,
2440 -- and then act accordingly.
2442 -- In practice Match makes some effort to avoid recursion, in
2443 -- particular by going through "ordinary
" nodes (that don't
2444 -- need to know whether the rest of the match failed) by
2445 -- using a loop instead of recursion.
2446 -- Why is the above comment part of the spec rather than body ???
2448 function Match_Whilem (IP : Pointer) return Boolean;
2449 -- Return True if a WHILEM matches
2450 -- How come IP is unreferenced in the body ???
2452 function Recurse_Match (IP : Pointer; From : Natural) return Boolean;
2453 pragma Inline (Recurse_Match);
2454 -- Calls Match recursively. It saves and restores the parenthesis
2455 -- status and location in the input stream correctly, so that
2456 -- backtracking is possible
2458 function Match_Simple_Operator
2462 Greedy : Boolean) return Boolean;
2463 -- Return True it the simple operator (possibly non-greedy) matches
2465 pragma Inline (Index);
2466 pragma Inline (Repeat);
2468 -- These are two complex functions, but used only once.
2470 pragma Inline (Match_Whilem);
2471 pragma Inline (Match_Simple_Operator);
2477 function Index (Start : Positive; C : Character) return Natural is
2479 for J in Start .. Last_In_Data loop
2480 if Data (J) = C then
2492 function Recurse_Match (IP : Pointer; From : Natural) return Boolean is
2493 L : constant Natural := Last_Paren;
2495 Tmp_F : constant Match_Array :=
2496 Matches_Full (From + 1 .. Matches_Full'Last);
2498 Start : constant Natural_Array :=
2499 Matches_Tmp (From + 1 .. Matches_Tmp'Last);
2500 Input : constant Natural := Input_Pos;
2508 Matches_Full (Tmp_F'Range) := Tmp_F;
2509 Matches_Tmp (Start'Range) := Start;
2518 function Match (IP : Pointer) return Boolean is
2519 Scan : Pointer := IP;
2526 pragma Assert (Scan /= 0);
2528 -- Determine current opcode and count its usage in debug mode
2530 Op := Opcode'Val (Character'Pos (Program (Scan)));
2532 -- Calculate offset of next instruction.
2533 -- Second character is most significant in Program_Data.
2535 Next := Get_Next (Program, Scan);
2539 return True; -- Success !
2542 if Program (Next) /= BRANCH then
2543 Next := Operand (Scan); -- No choice, avoid recursion
2547 if Recurse_Match (Operand (Scan), 0) then
2551 Scan := Get_Next (Program, Scan);
2552 exit when Scan = 0 or Program (Scan) /= BRANCH;
2562 exit State_Machine when Input_Pos /= BOL_Pos
2563 and then ((Self.Flags and Multiple_Lines) = 0
2564 or else Data (Input_Pos - 1) /= ASCII.LF);
2567 exit State_Machine when Input_Pos /= BOL_Pos
2568 and then Data (Input_Pos - 1) /= ASCII.LF;
2571 exit State_Machine when Input_Pos /= BOL_Pos;
2574 exit State_Machine when Input_Pos <= Data'Last
2575 and then ((Self.Flags and Multiple_Lines) = 0
2576 or else Data (Input_Pos) /= ASCII.LF);
2579 exit State_Machine when Input_Pos <= Data'Last
2580 and then Data (Input_Pos) /= ASCII.LF;
2583 exit State_Machine when Input_Pos <= Data'Last;
2585 when BOUND | NBOUND =>
2587 -- Was last char in word ?
2590 N : Boolean := False;
2591 Ln : Boolean := False;
2594 if Input_Pos /= First_In_Data then
2595 N := Is_Alnum (Data (Input_Pos - 1));
2598 if Input_Pos > Last_In_Data then
2601 Ln := Is_Alnum (Data (Input_Pos));
2616 exit State_Machine when Input_Pos > Last_In_Data
2617 or else not Is_White_Space (Data (Input_Pos));
2618 Input_Pos := Input_Pos + 1;
2621 exit State_Machine when Input_Pos > Last_In_Data
2622 or else Is_White_Space (Data (Input_Pos));
2623 Input_Pos := Input_Pos + 1;
2626 exit State_Machine when Input_Pos > Last_In_Data
2627 or else not Is_Digit (Data (Input_Pos));
2628 Input_Pos := Input_Pos + 1;
2631 exit State_Machine when Input_Pos > Last_In_Data
2632 or else Is_Digit (Data (Input_Pos));
2633 Input_Pos := Input_Pos + 1;
2636 exit State_Machine when Input_Pos > Last_In_Data
2637 or else not Is_Alnum (Data (Input_Pos));
2638 Input_Pos := Input_Pos + 1;
2641 exit State_Machine when Input_Pos > Last_In_Data
2642 or else Is_Alnum (Data (Input_Pos));
2643 Input_Pos := Input_Pos + 1;
2646 exit State_Machine when Input_Pos > Last_In_Data
2647 or else Data (Input_Pos) = ASCII.LF;
2648 Input_Pos := Input_Pos + 1;
2651 exit State_Machine when Input_Pos > Last_In_Data;
2652 Input_Pos := Input_Pos + 1;
2656 Opnd : Pointer := String_Operand (Scan);
2657 Current : Positive := Input_Pos;
2659 Last : constant Pointer :=
2660 Opnd + String_Length (Program, Scan);
2663 while Opnd <= Last loop
2664 exit State_Machine when Current > Last_In_Data
2665 or else Program (Opnd) /= Data (Current);
2666 Current := Current + 1;
2670 Input_Pos := Current;
2675 Opnd : Pointer := String_Operand (Scan);
2676 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) /= To_Lower (Data (Current));
2685 Current := Current + 1;
2689 Input_Pos := Current;
2694 Bitmap : Character_Class;
2697 Bitmap_Operand (Program, Scan, Bitmap);
2698 exit State_Machine when Input_Pos > Last_In_Data
2699 or else not Get_From_Class (Bitmap, Data (Input_Pos));
2700 Input_Pos := Input_Pos + 1;
2705 No : constant Natural :=
2706 Character'Pos (Program (Operand (Scan)));
2709 Matches_Tmp (No) := Input_Pos;
2714 No : constant Natural :=
2715 Character'Pos (Program (Operand (Scan)));
2718 Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1);
2720 if Last_Paren < No then
2727 No : constant Natural :=
2728 Character'Pos (Program (Operand (Scan)));
2733 -- If we haven't seen that parenthesis yet
2735 if Last_Paren < No then
2739 Data_Pos := Matches_Full (No).First;
2741 while Data_Pos <= Matches_Full (No).Last loop
2742 if Input_Pos > Last_In_Data
2743 or else Data (Input_Pos) /= Data (Data_Pos)
2748 Input_Pos := Input_Pos + 1;
2749 Data_Pos := Data_Pos + 1;
2756 when STAR | PLUS | CURLY =>
2758 Greed : constant Boolean := Greedy;
2762 return Match_Simple_Operator (Op, Scan, Next, Greed);
2767 -- Looking at something like:
2769 -- 1: CURLYX {n,m} (->4)
2770 -- 2: code for complex thing (->3)
2775 Min : constant Natural :=
2776 Read_Natural (Program, Scan + 3);
2777 Max : constant Natural :=
2778 Read_Natural (Program, Scan + 5);
2779 Cc : aliased Current_Curly_Record;
2781 Has_Match : Boolean;
2784 Cc := (Paren_Floor => Last_Paren,
2792 Old_Cc => Current_Curly);
2793 Current_Curly := Cc'Unchecked_Access;
2795 Has_Match := Match (Next - 3);
2797 -- Start on the WHILEM
2799 Current_Curly := Cc.Old_Cc;
2804 return Match_Whilem (IP);
2808 end loop State_Machine;
2810 -- If we get here, there is no match.
2811 -- For successful matches when EOP is the terminating point.
2816 ---------------------------
2817 -- Match_Simple_Operator --
2818 ---------------------------
2820 function Match_Simple_Operator
2824 Greedy : Boolean) return Boolean
2826 Next_Char : Character := ASCII.Nul;
2827 Next_Char_Known : Boolean := False;
2828 No : Integer; -- Can be negative
2830 Max : Natural := Natural'Last;
2831 Operand_Code : Pointer;
2834 Save : constant Natural := Input_Pos;
2837 -- Lookahead to avoid useless match attempts
2838 -- when we know what character comes next.
2840 if Program (Next) = EXACT then
2841 Next_Char := Program (String_Operand (Next));
2842 Next_Char_Known := True;
2845 -- Find the minimal and maximal values for the operator
2850 Operand_Code := Operand (Scan);
2854 Operand_Code := Operand (Scan);
2857 Min := Read_Natural (Program, Scan + 3);
2858 Max := Read_Natural (Program, Scan + 5);
2859 Operand_Code := Scan + 7;
2862 -- Non greedy operators
2866 -- Test the minimal repetitions
2869 and then Repeat (Operand_Code, Min) < Min
2876 -- Find the place where 'next' could work
2878 if Next_Char_Known then
2879 -- Last position to check
2881 Last_Pos := Input_Pos + Max;
2883 if Last_Pos > Last_In_Data
2884 or else Max = Natural'Last
2886 Last_Pos := Last_In_Data;
2889 -- Look for the first possible opportunity
2892 -- Find the next possible position
2894 while Input_Pos <= Last_Pos
2895 and then Data (Input_Pos) /= Next_Char
2897 Input_Pos := Input_Pos + 1;
2900 if Input_Pos > Last_Pos then
2904 -- Check that we still match if we stop
2905 -- at the position we just found.
2908 Num : constant Natural := Input_Pos - Old;
2913 if Repeat (Operand_Code, Num) < Num then
2918 -- Input_Pos now points to the new position
2920 if Match (Get_Next (Program, Scan)) then
2925 Input_Pos := Input_Pos + 1;
2928 -- We know what the next character is
2931 while Max >= Min loop
2933 -- If the next character matches
2935 if Match (Next) then
2939 Input_Pos := Save + Min;
2941 -- Could not or did not match -- move forward
2943 if Repeat (Operand_Code, 1) /= 0 then
2956 No := Repeat (Operand_Code, Max);
2958 -- ??? Perl has some special code here in case the
2959 -- next instruction is of type EOL, since $ and \Z
2960 -- can match before *and* after newline at the end.
2962 -- ??? Perl has some special code here in case (paren)
2965 -- Else, if we don't have any parenthesis
2967 while No >= Min loop
2968 if not Next_Char_Known
2969 or else (Input_Pos <= Last_In_Data
2970 and then Data (Input_Pos) = Next_Char)
2972 if Match (Next) then
2977 -- Could not or did not work, we back up
2980 Input_Pos := Save + No;
2985 end Match_Simple_Operator;
2991 -- This is really hard to understand, because after we match what we
2992 -- are trying to match, we must make sure the rest of the REx is going
2993 -- to match for sure, and to do that we have to go back UP the parse
2994 -- tree by recursing ever deeper. And if it fails, we have to reset
2995 -- our parent's current state that we can try again after backing off.
2997 function Match_Whilem (IP : Pointer) return Boolean is
2998 pragma Unreferenced (IP);
3000 Cc : constant Current_Curly_Access := Current_Curly;
3001 N : constant Natural := Cc.Cur + 1;
3004 Lastloc : constant Natural := Cc.Lastloc;
3005 -- Detection of 0-len.
3008 -- If degenerate scan matches "", assume scan done.
3010 if Input_Pos = Cc.Lastloc
3011 and then N >= Cc.Min
3013 -- Temporarily restore the old context, and check that we
3014 -- match was comes after CURLYX.
3016 Current_Curly := Cc.Old_Cc;
3018 if Current_Curly /= null then
3019 Ln := Current_Curly.Cur;
3022 if Match (Cc.Next) then
3026 if Current_Curly /= null then
3027 Current_Curly.Cur := Ln;
3030 Current_Curly := Cc;
3034 -- First, just match a string of min scans.
3038 Cc.Lastloc := Input_Pos;
3040 if Match (Cc.Scan) then
3045 Cc.Lastloc := Lastloc;
3049 -- Prefer next over scan for minimal matching.
3051 if not Cc.Greedy then
3052 Current_Curly := Cc.Old_Cc;
3054 if Current_Curly /= null then
3055 Ln := Current_Curly.Cur;
3058 if Recurse_Match (Cc.Next, Cc.Paren_Floor) then
3062 if Current_Curly /= null then
3063 Current_Curly.Cur := Ln;
3066 Current_Curly := Cc;
3068 -- Maximum greed exceeded ?
3074 -- Try scanning more and see if it helps
3076 Cc.Lastloc := Input_Pos;
3078 if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3083 Cc.Lastloc := Lastloc;
3087 -- Prefer scan over next for maximal matching
3089 if N < Cc.Max then -- more greed allowed ?
3091 Cc.Lastloc := Input_Pos;
3093 if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3098 -- Failed deeper matches of scan, so see if this one works
3100 Current_Curly := Cc.Old_Cc;
3102 if Current_Curly /= null then
3103 Ln := Current_Curly.Cur;
3106 if Match (Cc.Next) then
3110 if Current_Curly /= null then
3111 Current_Curly.Cur := Ln;
3114 Current_Curly := Cc;
3116 Cc.Lastloc := Lastloc;
3126 Max : Natural := Natural'Last) return Natural
3128 Scan : Natural := Input_Pos;
3130 Op : constant Opcode := Opcode'Val (Character'Pos (Program (IP)));
3133 Is_First : Boolean := True;
3134 Bitmap : Character_Class;
3137 if Max = Natural'Last or else Scan + Max - 1 > Last_In_Data then
3138 Last := Last_In_Data;
3140 Last := Scan + Max - 1;
3146 and then Data (Scan) /= ASCII.LF
3156 -- The string has only one character if Repeat was called
3158 C := Program (String_Operand (IP));
3160 and then C = Data (Scan)
3167 -- The string has only one character if Repeat was called
3169 C := Program (String_Operand (IP));
3171 and then To_Lower (C) = Data (Scan)
3178 Bitmap_Operand (Program, IP, Bitmap);
3183 and then Get_From_Class (Bitmap, Data (Scan))
3190 and then Is_Alnum (Data (Scan))
3197 and then not Is_Alnum (Data (Scan))
3204 and then Is_White_Space (Data (Scan))
3211 and then not Is_White_Space (Data (Scan))
3218 and then Is_Digit (Data (Scan))
3225 and then not Is_Digit (Data (Scan))
3231 raise Program_Error;
3234 Count := Scan - Input_Pos;
3243 function Try (Pos : in Positive) return Boolean is
3247 Matches_Full := (others => No_Match);
3249 if Match (Program_First + 1) then
3250 Matches_Full (0) := (Pos, Input_Pos - 1);
3257 -- Start of processing for Match
3260 -- Do we have the regexp Never_Match?
3262 if Self.Size = 0 then
3263 Matches (0) := No_Match;
3267 -- Check validity of program
3270 (Program (Program_First) = MAGIC,
3271 "Corrupted Pattern_Matcher
");
3273 -- If there is a "must appear
" string, look for it
3275 if Self.Must_Have_Length > 0 then
3277 First : constant Character := Program (Self.Must_Have);
3278 Must_First : constant Pointer := Self.Must_Have;
3279 Must_Last : constant Pointer :=
3280 Must_First + Pointer (Self.Must_Have_Length - 1);
3281 Next_Try : Natural := Index (First_In_Data, First);
3285 and then Data (Next_Try .. Next_Try + Self.Must_Have_Length - 1)
3286 = String (Program (Must_First .. Must_Last))
3288 Next_Try := Index (Next_Try + 1, First);
3291 if Next_Try = 0 then
3292 Matches_Full := (others => No_Match);
3293 return; -- Not present
3298 -- Mark beginning of line for ^
3300 BOL_Pos := Data'First;
3302 -- Simplest case first: an anchored match need be tried only once
3304 if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then
3305 Matched := Try (First_In_Data);
3307 elsif Self.Anchored then
3309 Next_Try : Natural := First_In_Data;
3311 -- Test the first position in the buffer
3312 Matched := Try (Next_Try);
3314 -- Else only test after newlines
3317 while Next_Try <= Last_In_Data loop
3318 while Next_Try <= Last_In_Data
3319 and then Data (Next_Try) /= ASCII.LF
3321 Next_Try := Next_Try + 1;
3324 Next_Try := Next_Try + 1;
3326 if Next_Try <= Last_In_Data then
3327 Matched := Try (Next_Try);
3334 elsif Self.First /= ASCII.NUL then
3335 -- We know what char it must start with
3338 Next_Try : Natural := Index (First_In_Data, Self.First);
3341 while Next_Try /= 0 loop
3342 Matched := Try (Next_Try);
3344 Next_Try := Index (Next_Try + 1, Self.First);
3349 -- Messy cases: try all locations (including for the empty string)
3351 Matched := Try (First_In_Data);
3354 for S in First_In_Data + 1 .. Last_In_Data loop
3361 -- Matched has its value
3363 for J in Last_Paren + 1 .. Matches'Last loop
3364 Matches_Full (J) := No_Match;
3367 Matches := Matches_Full (Matches'Range);
3376 (Self : Pattern_Matcher;
3378 Data_First : Integer := -1;
3379 Data_Last : Positive := Positive'Last) return Natural
3381 Matches : Match_Array (0 .. 0);
3384 Match (Self, Data, Matches, Data_First, Data_Last);
3385 if Matches (0) = No_Match then
3386 return Data'First - 1;
3388 return Matches (0).First;
3393 (Self : Pattern_Matcher;
3395 Data_First : Integer := -1;
3396 Data_Last : Positive := Positive'Last) return Boolean
3398 Matches : Match_Array (0 .. 0);
3401 Match (Self, Data, Matches, Data_First, Data_Last);
3402 return Matches (0).First >= Data'First;
3406 (Expression : String;
3408 Matches : out Match_Array;
3409 Size : Program_Size := Auto_Size;
3410 Data_First : Integer := -1;
3411 Data_Last : Positive := Positive'Last)
3413 PM : Pattern_Matcher (Size);
3414 Finalize_Size : Program_Size;
3418 Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
3420 Compile (PM, Expression, Finalize_Size);
3421 Match (PM, Data, Matches, Data_First, Data_Last);
3430 (Expression : String;
3432 Size : Program_Size := Auto_Size;
3433 Data_First : Integer := -1;
3434 Data_Last : Positive := Positive'Last) return Natural
3436 PM : Pattern_Matcher (Size);
3437 Final_Size : Program_Size; -- unused
3441 return Match (Compile (Expression), Data, Data_First, Data_Last);
3443 Compile (PM, Expression, Final_Size);
3444 return Match (PM, Data, Data_First, Data_Last);
3453 (Expression : String;
3455 Size : Program_Size := Auto_Size;
3456 Data_First : Integer := -1;
3457 Data_Last : Positive := Positive'Last) return Boolean
3459 Matches : Match_Array (0 .. 0);
3460 PM : Pattern_Matcher (Size);
3461 Final_Size : Program_Size; -- unused
3465 Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
3467 Compile (PM, Expression, Final_Size);
3468 Match (PM, Data, Matches, Data_First, Data_Last);
3471 return Matches (0).First >= Data'First;
3478 function Operand (P : Pointer) return Pointer is
3487 procedure Optimize (Self : in out Pattern_Matcher) is
3488 Max_Length : Program_Size;
3489 This_Length : Program_Size;
3492 Program : Program_Data renames Self.Program;
3495 -- Start with safe defaults (no optimization):
3496 -- * No known first character of match
3497 -- * Does not necessarily start at beginning of line
3498 -- * No string known that has to appear in data
3500 Self.First := ASCII.NUL;
3501 Self.Anchored := False;
3502 Self.Must_Have := Program'Last + 1;
3503 Self.Must_Have_Length := 0;
3505 Scan := Program_First + 1; -- First instruction (can be anything)
3507 if Program (Scan) = EXACT then
3508 Self.First := Program (String_Operand (Scan));
3510 elsif Program (Scan) = BOL
3511 or else Program (Scan) = SBOL
3512 or else Program (Scan) = MBOL
3514 Self.Anchored := True;
3517 -- If there's something expensive in the regexp, find the
3518 -- longest literal string that must appear and make it the
3519 -- regmust. Resolve ties in favor of later strings, since
3520 -- the regstart check works with the beginning of the regexp.
3521 -- and avoiding duplication strengthens checking. Not a
3522 -- strong reason, but sufficient in the absence of others.
3524 if False then -- if Flags.SP_Start then ???
3527 while Scan /= 0 loop
3528 if Program (Scan) = EXACT or else Program (Scan) = EXACTF then
3529 This_Length := String_Length (Program, Scan);
3531 if This_Length >= Max_Length then
3532 Longest := String_Operand (Scan);
3533 Max_Length := This_Length;
3537 Scan := Get_Next (Program, Scan);
3540 Self.Must_Have := Longest;
3541 Self.Must_Have_Length := Natural (Max_Length) + 1;
3549 function Paren_Count (Regexp : Pattern_Matcher) return Match_Count is
3551 return Regexp.Paren_Count;
3558 function Quote (Str : String) return String is
3559 S : String (1 .. Str'Length * 2);
3560 Last : Natural := 0;
3563 for J in Str'Range loop
3565 when '^' | '$' | '|' | '*' | '+' | '?' | '{' |
3566 '}' | '[' | ']' | '(' | ')' | '\' =>
3568 S (Last + 1) := '\';
3569 S (Last + 2) := Str (J);
3573 S (Last + 1) := Str (J);
3578 return S (1 .. Last);
3585 function Read_Natural
3586 (Program : Program_Data;
3587 IP : Pointer) return Natural
3590 return Character'Pos (Program (IP)) +
3591 256 * Character'Pos (Program (IP + 1));
3598 procedure Reset_Class (Bitmap : out Character_Class) is
3600 Bitmap := (others => 0);
3607 procedure Set_In_Class
3608 (Bitmap : in out Character_Class;
3611 Value : constant Class_Byte := Character'Pos (C);
3613 Bitmap (Value / 8) := Bitmap (Value / 8)
3614 or Bit_Conversion (Value mod 8);
3621 function String_Length
3622 (Program : Program_Data;
3623 P : Pointer) return Program_Size
3626 pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF);
3627 return Character'Pos (Program (P + 3));
3630 --------------------
3631 -- String_Operand --
3632 --------------------
3634 function String_Operand (P : Pointer) return Pointer is