| blob | f36d5bf9ffcee8da003ba8d4bf9e267ae3624049 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- G N A T . R E G P A T --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision: 1.31 $
10 -- --
11 -- Copyright (C) 1986 by University of Toronto. --
12 -- Copyright (C) 1996-2001 Ada Core Technologies, Inc. --
13 -- --
14 -- GNAT is free software; you can redistribute it and/or modify it under --
15 -- terms of the GNU General Public License as published by the Free Soft- --
16 -- ware Foundation; either version 2, or (at your option) any later ver- --
17 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
18 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
19 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
20 -- for more details. You should have received a copy of the GNU General --
21 -- Public License distributed with GNAT; see file COPYING. If not, write --
22 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
23 -- MA 02111-1307, USA. --
24 -- --
25 -- As a special exception, if other files instantiate generics from this --
26 -- unit, or you link this unit with other files to produce an executable, --
27 -- this unit does not by itself cause the resulting executable to be --
28 -- covered by the GNU General Public License. This exception does not --
29 -- however invalidate any other reasons why the executable file might be --
30 -- covered by the GNU Public License. --
31 -- --
32 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 -- --
34 ------------------------------------------------------------------------------
36 -- This is an altered Ada 95 version of the original V8 style regular
37 -- expression library written in C by Henry Spencer. Apart from the
38 -- translation to Ada, the interface has been considerably changed to
39 -- use the Ada String type instead of C-style nul-terminated strings.
41 -- Beware that some of this code is subtly aware of the way operator
42 -- precedence is structured in regular expressions. Serious changes in
43 -- regular-expression syntax might require a total rethink.
52 -- The first byte of the regexp internal "program" is actually
53 -- this magic number; the start node begins in the second byte.
54 --
55 -- This is used to make sure that a regular expression was correctly
56 -- compiled.
58 ----------------------------
59 -- Implementation details --
60 ----------------------------
62 -- This is essentially a linear encoding of a nondeterministic
63 -- finite-state machine, also known as syntax charts or
64 -- "railroad normal form" in parsing technology.
66 -- Each node is an opcode plus a "next" pointer, possibly plus an
67 -- operand. "Next" pointers of all nodes except BRANCH implement
68 -- concatenation; a "next" pointer with a BRANCH on both ends of it
69 -- is connecting two alternatives.
71 -- The operand of some types of node is a literal string; for others,
72 -- it is a node leading into a sub-FSM. In particular, the operand of
73 -- a BRANCH node is the first node of the branch.
74 -- (NB this is *not* a tree structure: the tail of the branch connects
75 -- to the thing following the set of BRANCHes).
77 -- You can see the exact byte-compiled version by using the Dump
78 -- subprogram. However, here are a few examples:
80 -- (a|b): 1 : MAGIC
81 -- 2 : BRANCH (next at 10)
82 -- 5 : EXACT (next at 18) operand=a
83 -- 10 : BRANCH (next at 18)
84 -- 13 : EXACT (next at 18) operand=b
85 -- 18 : EOP (next at 0)
86 --
87 -- (ab)*: 1 : MAGIC
88 -- 2 : CURLYX (next at 26) { 0, 32767}
89 -- 9 : OPEN 1 (next at 13)
90 -- 13 : EXACT (next at 19) operand=ab
91 -- 19 : CLOSE 1 (next at 23)
92 -- 23 : WHILEM (next at 0)
93 -- 26 : NOTHING (next at 29)
94 -- 29 : EOP (next at 0)
96 -- The opcodes are:
100 -- Name Operand? Meaning
105 -- Classes of characters
120 -- Branches
124 -- Simple loops (when the following node is one character in length)
130 -- Complex loops
133 -- The nums are coded on two characters each.
137 -- Matches after or before a word
149 -- Parenthesis groups handling
157 -- Opcode notes:
159 -- BRANCH
160 -- The set of branches constituting a single choice are hooked
161 -- together with their "next" pointers, since precedence prevents
162 -- anything being concatenated to any individual branch. The
163 -- "next" pointer of the last BRANCH in a choice points to the
164 -- thing following the whole choice. This is also where the
165 -- final "next" pointer of each individual branch points; each
166 -- branch starts with the operand node of a BRANCH node.
168 -- STAR,PLUS
169 -- '?', and complex '*' and '+', are implemented with CURLYX.
170 -- branches. Simple cases (one character per match) are implemented with
171 -- STAR and PLUS for speed and to minimize recursive plunges.
173 -- OPEN,CLOSE
174 -- ...are numbered at compile time.
176 -- EXACT, EXACTF
177 -- There are in fact two arguments, the first one is the length (minus
178 -- one of the string argument), coded on one character, the second
179 -- argument is the string itself, coded on length + 1 characters.
181 -- A node is one char of opcode followed by two chars of "next" pointer.
182 -- "Next" pointers are stored as two 8-bit pieces, high order first. The
183 -- value is a positive offset from the opcode of the node containing it.
184 -- An operand, if any, simply follows the node. (Note that much of the
185 -- code generation knows about this implicit relationship.)
187 -- Using two bytes for the "next" pointer is vast overkill for most
188 -- things, but allows patterns to get big without disasters.
190 -----------------------
191 -- Character classes --
192 -----------------------
193 -- This is the implementation for character classes ([...]) in the
194 -- syntax for regular expressions. Each character (0..256) has an
195 -- entry into the table. This makes for a very fast matching
196 -- algorithm.
207 ANYOF_NALNUM,
209 ANYOF_NSPACE,
211 ANYOF_NDIGIT,
213 ANYOF_NALNUMC,
215 ANYOF_NALPHA,
217 ANYOF_NASCII,
219 ANYOF_NCNTRL,
221 ANYOF_NGRAPH,
223 ANYOF_NLOWER,
225 ANYOF_NPRINT,
227 ANYOF_NPUNCT,
229 ANYOF_NUPPER,
231 ANYOF_NXDIGIT
232 );
234 procedure Set_In_Class
237 -- Set the entry to True for C in the class Bitmap.
239 function Get_From_Class
243 -- Return True if the entry is set for C in the class Bitmap.
246 -- Clear all the entries in the class Bitmap.
252 -----------------------
253 -- Local Subprograms --
254 -----------------------
261 -- Return True if C is an alphanum character or an underscore ('_')
264 -- Return True if C is a whitespace character
267 -- Return True if C is a printable character
270 -- Return a pointer to the first operand of the node at P
272 function String_Length
276 -- Return the length of the string argument of the node at P
279 -- Return a pointer to the string argument of the node at P
281 procedure Bitmap_Operand
285 -- Return a pointer to the string argument of the node at P
287 function Get_Next_Offset
291 -- Get the offset field of a node. Used by Get_Next.
293 function Get_Next
297 -- Dig the next instruction pointer out of a node
300 -- Optimize a Pattern_Matcher by noting certain special cases
302 function Read_Natural
306 -- Return the 2-byte natural coded at position IP.
308 -- All of the subprograms above are tiny and should be inlined
329 -- Worst case
331 ---------
332 -- "+" --
333 ---------
336 begin
340 ---------
341 -- "-" --
342 ---------
345 begin
349 ---------
350 -- "=" --
351 ---------
354 begin
358 --------------------
359 -- Bitmap_Operand --
360 --------------------
362 procedure Bitmap_Operand
366 is
370 begin
374 -------------
375 -- Compile --
376 -------------
378 procedure Compile
383 is
384 -- We can't allocate space until we know how big the compiled form
385 -- will be, but we can't compile it (and thus know how big it is)
386 -- until we've got a place to put the code. So we cheat: we compile
387 -- it twice, once with code generation turned off and size counting
388 -- turned on, and once "for real".
390 -- This also means that we don't allocate space until we are sure
391 -- that the thing really will compile successfully, and we never
392 -- have to move the code and thus invalidate pointers into it.
394 -- Beware that the optimization-preparation code in here knows
395 -- about some of the structure of the compiled regexp.
406 ----------------------------
407 -- Subprograms for Create --
408 ----------------------------
411 -- Output the Character to the Program.
412 -- If code-generation is disables, simply increments the program
413 -- counter.
416 -- If code-generation is enabled, Emit_Node outputs the
417 -- opcode and reserves space for a pointer to the next node.
418 -- Return value is the location of new opcode, ie old Emit_Ptr.
421 -- Split N on two characters at position IP.
424 -- Emits a character class.
427 -- Emit C, after converting is to lower-case if the regular
428 -- expression is case insensitive.
430 procedure Parse
434 -- Parse regular expression, i.e. main body or parenthesized thing
435 -- Caller must absorb opening parenthesis.
437 procedure Parse_Branch
441 -- Implements the concatenation operator and handles '|'
442 -- First should be true if this is the first item of the alternative.
444 procedure Parse_Piece
446 -- Parse something followed by possible [*+?]
448 procedure Parse_Atom
450 -- Parse_Atom is the lowest level parse procedure.
451 -- Optimization: gobbles an entire sequence of ordinary characters
452 -- so that it can turn them into a single node, which is smaller to
453 -- store and faster to run. Backslashed characters are exceptions,
454 -- each becoming a separate node; the code is simpler that way and
455 -- it's not worth fixing.
457 procedure Insert_Operator
461 -- Insert_Operator inserts an operator in front of an
462 -- already-emitted operand and relocates the operand.
463 -- This applies to PLUS and STAR.
464 -- If Minmod is True, then the operator is non-greedy.
466 procedure Insert_Curly_Operator
472 -- Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}).
473 -- If Minmod is True, then the operator is non-greedy.
476 -- Link_Tail sets the next-pointer at the end of a node chain
479 -- Link_Tail on operand of first argument; nop if operandless
482 -- Dig the "next" pointer out of a node
485 -- Fail with a diagnostic message, if possible
488 -- Return True if IP is looking at a '{' that is the beginning
489 -- of a curly operator, ie it matches {\d+,?\d*}
492 -- Return True if C is a regexp multiplier: '+', '*' or '?'
494 procedure Get_Curly_Arguments
499 -- Parse the argument list for a curly operator.
500 -- It is assumed that IP is indeed pointing at a valid operator.
503 -- Parse a character class.
504 -- The calling subprogram should consume the opening '[' before.
508 -- Parse_Literal encodes a string of characters
509 -- to be matched exactly.
512 -- Parse a posic character class, like [:alpha:] or [:^alpha:].
513 -- The called is suppoed to absorbe the opening [.
519 ---------------
520 -- Case_Emit --
521 ---------------
524 begin
528 else
529 -- Dump current character
535 ----------
536 -- Emit --
537 ----------
540 begin
548 ----------------
549 -- Emit_Class --
550 ----------------
558 begin
566 ------------------
567 -- Emit_Natural --
568 ------------------
571 begin
578 ---------------
579 -- Emit_Node --
580 ---------------
585 begin
596 ----------
597 -- Fail --
598 ----------
601 begin
605 -------------------------
606 -- Get_Curly_Arguments --
607 -------------------------
609 procedure Get_Curly_Arguments
614 is
617 begin
623 loop
639 else
645 then
649 else
654 ---------------------------
655 -- Insert_Curly_Operator --
656 ---------------------------
658 procedure Insert_Curly_Operator
664 is
669 begin
670 -- If the operand is not greedy, insert an extra operand before it
676 -- Move the operand in the byte-compilation, so that we can insert
677 -- the operator before it.
684 -- Insert the operator at the position previously occupied by the
685 -- operand.
701 ---------------------
702 -- Insert_Operator --
703 ---------------------
705 procedure Insert_Operator
709 is
714 begin
715 -- If not greedy, we have to emit another opcode first
721 -- Move the operand in the byte-compilation, so that we can insert
722 -- the operator before it.
729 -- Insert the operator at the position previously occupied by the
730 -- operand.
743 -----------------------
744 -- Is_Curly_Operator --
745 -----------------------
750 begin
754 then
760 -- The first digit
762 loop
773 loop
787 -------------
788 -- Is_Mult --
789 -------------
794 begin
801 -----------------------
802 -- Link_Operand_Tail --
803 -----------------------
806 begin
812 ---------------
813 -- Link_Tail --
814 ---------------
821 begin
826 -- Find last node
829 loop
840 ----------------------
841 -- Next_Instruction --
842 ----------------------
847 begin
861 -----------
862 -- Parse --
863 -----------
865 -- Combining parenthesis handling with the base level
866 -- of regular expression is a trifle forced, but the
867 -- need to tie the tails of the branches to what follows
868 -- makes it hard to avoid.
870 procedure Parse
874 is
882 begin
885 -- Make an OPEN node, if parenthesized
897 else
901 -- Pick up the branches, linking them together
912 then
919 else
931 loop
949 -- Make a closing node, and hook it on the end
954 else
962 -- Hook the tails of the branches to the closing node
965 loop
972 -- Check for proper termination
984 else
990 ----------------
991 -- Parse_Atom --
992 ----------------
994 procedure Parse_Atom
997 is
1000 begin
1001 -- Tentatively set worst expression case
1014 else
1023 else
1030 else
1042 declare
1045 begin
1067 end if;
1069 Parse_Pos := Parse_Pos + 1;
1071 case Expression (Parse_Pos - 1) is
1072 when 'b' =>
1073 IP := Emit_Node (BOUND);
1075 when 'B' =>
1076 IP := Emit_Node (NBOUND);
1078 when 's' =>
1079 IP := Emit_Node (SPACE);
1080 Expr_Flags.Simple := True;
1081 Expr_Flags.Has_Width := True;
1083 when 'S' =>
1084 IP := Emit_Node (NSPACE);
1085 Expr_Flags.Simple := True;
1086 Expr_Flags.Has_Width := True;
1088 when 'd' =>
1089 IP := Emit_Node (DIGIT);
1090 Expr_Flags.Simple := True;
1091 Expr_Flags.Has_Width := True;
1093 when 'D' =>
1094 IP := Emit_Node (NDIGIT);
1095 Expr_Flags.Simple := True;
1096 Expr_Flags.Has_Width := True;
1098 when 'w' =>
1099 IP := Emit_Node (ALNUM);
1100 Expr_Flags.Simple := True;
1101 Expr_Flags.Has_Width := True;
1103 when 'W' =>
1104 IP := Emit_Node (NALNUM);
1105 Expr_Flags.Simple := True;
1106 Expr_Flags.Has_Width := True;
1108 when 'A' =>
1109 IP := Emit_Node (SBOL);
1111 when 'G' =>
1112 IP := Emit_Node (SEOL);
1114 when '0' .. '9' =>
1115 IP := Emit_Node (REFF);
1117 declare
1118 Save : Natural := Parse_Pos - 1;
1120 begin
1121 while Parse_Pos <= Expression'Last
1122 and then Is_Digit (Expression (Parse_Pos))
1123 loop
1124 Parse_Pos := Parse_Pos + 1;
1125 end loop;
1127 Emit (Character'Val (Natural'Value
1128 (Expression (Save .. Parse_Pos - 1))));
1129 end;
1131 when others =>
1132 Parse_Pos := Parse_Pos - 1;
1133 Parse_Literal (Expr_Flags, IP);
1134 end case;
1136 when others => Parse_Literal (Expr_Flags, IP);
1137 end case;
1138 end Parse_Atom;
1140 ------------------
1141 -- Parse_Branch --
1142 ------------------
1144 procedure Parse_Branch
1145 (Flags : in out Expression_Flags;
1146 First : Boolean;
1147 IP : out Pointer)
1148 is
1149 E : String renames Expression;
1150 Chain : Pointer;
1151 Last : Pointer;
1152 New_Flags : Expression_Flags;
1153 Dummy : Pointer;
1155 begin
1156 Flags := Worst_Expression; -- Tentatively
1158 if First then
1159 IP := Emit_Ptr;
1160 else
1161 IP := Emit_Node (BRANCH);
1162 end if;
1164 Chain := 0;
1166 while Parse_Pos <= Parse_End
1167 and then E (Parse_Pos) /= ')'
1168 and then E (Parse_Pos) /= ASCII.LF
1169 and then E (Parse_Pos) /= '|'
1170 loop
1171 Parse_Piece (New_Flags, Last);
1173 if Last = 0 then
1174 IP := 0;
1175 return;
1176 end if;
1178 Flags.Has_Width := Flags.Has_Width or New_Flags.Has_Width;
1180 if Chain = 0 then -- First piece
1181 Flags.SP_Start := Flags.SP_Start or New_Flags.SP_Start;
1182 else
1183 Link_Tail (Chain, Last);
1184 end if;
1186 Chain := Last;
1187 end loop;
1189 if Chain = 0 then -- Loop ran zero CURLY
1190 Dummy := Emit_Node (NOTHING);
1191 end if;
1193 end Parse_Branch;
1195 ---------------------------
1196 -- Parse_Character_Class --
1197 ---------------------------
1199 procedure Parse_Character_Class (IP : out Pointer) is
1200 Bitmap : Character_Class;
1201 Invert : Boolean := False;
1202 In_Range : Boolean := False;
1203 Named_Class : Std_Class := ANYOF_NONE;
1204 Value : Character;
1205 Last_Value : Character := ASCII.Nul;
1207 begin
1208 Reset_Class (Bitmap);
1210 -- Do we have an invert character class ?
1212 if Parse_Pos <= Parse_End
1213 and then Expression (Parse_Pos) = '^'
1214 then
1215 Invert := True;
1216 Parse_Pos := Parse_Pos + 1;
1217 end if;
1219 -- First character can be ] or -, without closing the class.
1221 if Parse_Pos <= Parse_End
1222 and then (Expression (Parse_Pos) = ']'
1223 or else Expression (Parse_Pos) = '-')
1224 then
1225 Set_In_Class (Bitmap, Expression (Parse_Pos));
1226 Parse_Pos := Parse_Pos + 1;
1227 end if;
1229 -- While we don't have the end of the class
1231 while Parse_Pos <= Parse_End
1232 and then Expression (Parse_Pos) /= ']'
1233 loop
1234 Named_Class := ANYOF_NONE;
1235 Value := Expression (Parse_Pos);
1236 Parse_Pos := Parse_Pos + 1;
1238 -- Do we have a Posix character class
1239 if Value = '[' then
1240 Named_Class := Parse_Posix_Character_Class;
1242 elsif Value = '\' then
1243 if Parse_Pos = Parse_End then
1263 -- when 'x' => ??? hexadecimal value
1264 -- when 'c' => ??? control character
1265 -- when '0'..'9' => ??? octal character
1271 -- Do we have a character class?
1275 -- A range like 'a-\d' or 'a-[:digit:] is not a range
1283 -- Expand the range
1415 then
1425 then
1453 if not Is_Hexadecimal_Digit
1455 then
1462 -- Not a character range
1470 then
1473 -- Do we have a range like '\d-a' and '[:space:]-a'
1474 -- which is not a real range
1478 else
1482 else
1487 -- Else in a character range
1489 else
1506 -- Optimize case-insensitive ranges (put the upper case or lower
1507 -- case character into the bitmap)
1518 -- Optimize inverted classes
1528 -- Emit the class
1534 -------------------
1535 -- Parse_Literal --
1536 -------------------
1538 -- This is a bit tricky due to quoted chars and due to
1539 -- the multiplier characters '*', '+', and '?' that
1540 -- take the SINGLE char previous as their operand.
1541 --
1542 -- On entry, the character at Parse_Pos - 1 is going to go
1543 -- into the string, no matter what it is. It could be
1544 -- following a \ if Parse_Atom was entered from the '\' case.
1545 --
1546 -- Basic idea is to pick up a good char in C and examine
1547 -- the next char. If Is_Mult (C) then twiddle, if it's a \
1548 -- then frozzle and if it's another magic char then push C and
1549 -- terminate the string. If none of the above, push C on the
1550 -- string and go around again.
1551 --
1552 -- Start_Pos is used to remember where "the current character"
1553 -- starts in the string, if due to an Is_Mult we need to back
1554 -- up and put the current char in a separate 1-character string.
1555 -- When Start_Pos is 0, C is the only char in the string;
1556 -- this is used in Is_Mult handling, and in setting the SIMPLE
1557 -- flag at the end.
1559 procedure Parse_Literal
1562 is
1567 begin
1572 else
1579 Parse_Loop :
1580 loop
1589 else
1598 -- Are we looking at an operator, or is this
1599 -- simply a normal character ?
1602 else
1603 -- We've got something like "abc?d". Mark this as a
1604 -- special case. What we want to emit is a first
1605 -- constant string for "ab", then one for "c" that will
1606 -- ultimately be transformed with a CURLY operator, A
1607 -- special case has to be handled for "a?", since there
1608 -- is no initial string to emit.
1616 else
1617 case Expression (Parse_Pos + 1) is
1618 when 'b' | 'B' | 's' | 'S' | 'd' | 'D'
1619 | 'w' | 'W' | '0' .. '9' | 'G' | 'A'
1620 => exit Parse_Loop;
1621 when 'n' => Emit (ASCII.LF);
1622 when 't' => Emit (ASCII.HT);
1623 when 'r' => Emit (ASCII.CR);
1624 when 'f' => Emit (ASCII.FF);
1625 when 'e' => Emit (ASCII.ESC);
1626 when 'a' => Emit (ASCII.BEL);
1627 when others => Emit (Expression (Parse_Pos + 1));
1628 end case;
1629 Parse_Pos := Parse_Pos + 1;
1630 end if;
1632 when others => Case_Emit (C);
1633 end case;
1635 exit Parse_Loop when Emit_Ptr - Length_Ptr = 254;
1637 Start_Pos := Parse_Pos;
1638 Parse_Pos := Parse_Pos + 1;
1640 exit Parse_Loop when Parse_Pos > Parse_End;
1641 end loop Parse_Loop;
1643 -- Is the string followed by a '*+?{' operator ? If yes, and if there
1644 -- is an initial string to emit, do it now.
1646 if Start_Pos = Natural'Last
1647 and then Emit_Ptr >= Length_Ptr + 3
1648 then
1649 Emit_Ptr := Emit_Ptr - 1;
1650 Parse_Pos := Parse_Pos - 1;
1651 end if;
1653 if Emit_Code then
1654 Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2);
1655 end if;
1657 Expr_Flags.Has_Width := True;
1659 -- Slight optimization when there is a single character
1661 if Emit_Ptr = Length_Ptr + 2 then
1662 Expr_Flags.Simple := True;
1663 end if;
1664 end Parse_Literal;
1666 -----------------
1667 -- Parse_Piece --
1668 -----------------
1670 -- Note that the branching code sequences used for '?' and the
1671 -- general cases of '*' and + are somewhat optimized: they use
1672 -- the same NOTHING node as both the endmarker for their branch
1673 -- list and the body of the last branch. It might seem that
1674 -- this node could be dispensed with entirely, but the endmarker
1675 -- role is not redundant.
1677 procedure Parse_Piece
1678 (Expr_Flags : in out Expression_Flags;
1679 IP : out Pointer)
1680 is
1681 Op : Character;
1682 New_Flags : Expression_Flags;
1683 Greedy : Boolean := True;
1685 begin
1686 Parse_Atom (New_Flags, IP);
1688 if IP = 0 then
1689 return;
1690 end if;
1692 if Parse_Pos > Parse_End
1693 or else not Is_Mult (Parse_Pos)
1694 then
1695 Expr_Flags := New_Flags;
1696 return;
1697 end if;
1699 Op := Expression (Parse_Pos);
1701 if Op /= '+' then
1702 Expr_Flags := (SP_Start => True, others => False);
1703 else
1704 Expr_Flags := (Has_Width => True, others => False);
1705 end if;
1707 -- Detect non greedy operators in the easy cases
1709 if Op /= '{'
1710 and then Parse_Pos + 1 <= Parse_End
1711 and then Expression (Parse_Pos + 1) = '?'
1712 then
1713 Greedy := False;
1714 Parse_Pos := Parse_Pos + 1;
1715 end if;
1717 -- Generate the byte code
1719 case Op is
1720 when '*' =>
1722 if New_Flags.Simple then
1723 Insert_Operator (STAR, IP, Greedy);
1724 else
1725 Link_Tail (IP, Emit_Node (WHILEM));
1726 Insert_Curly_Operator
1727 (CURLYX, 0, Max_Curly_Repeat, IP, Greedy);
1728 Link_Tail (IP, Emit_Node (NOTHING));
1729 end if;
1731 when '+' =>
1733 if New_Flags.Simple then
1734 Insert_Operator (PLUS, IP, Greedy);
1735 else
1736 Link_Tail (IP, Emit_Node (WHILEM));
1737 Insert_Curly_Operator
1738 (CURLYX, 1, Max_Curly_Repeat, IP, Greedy);
1739 Link_Tail (IP, Emit_Node (NOTHING));
1740 end if;
1742 when '?' =>
1743 if New_Flags.Simple then
1744 Insert_Curly_Operator (CURLY, 0, 1, IP, Greedy);
1745 else
1746 Link_Tail (IP, Emit_Node (WHILEM));
1747 Insert_Curly_Operator (CURLYX, 0, 1, IP, Greedy);
1748 Link_Tail (IP, Emit_Node (NOTHING));
1749 end if;
1751 when '{' =>
1752 declare
1753 Min, Max : Natural;
1755 begin
1756 Get_Curly_Arguments (Parse_Pos, Min, Max, Greedy);
1758 if New_Flags.Simple then
1759 Insert_Curly_Operator (CURLY, Min, Max, IP, Greedy);
1760 else
1761 Link_Tail (IP, Emit_Node (WHILEM));
1762 Insert_Curly_Operator (CURLYX, Min, Max, IP, Greedy);
1763 Link_Tail (IP, Emit_Node (NOTHING));
1764 end if;
1765 end;
1767 when others =>
1768 null;
1769 end case;
1771 Parse_Pos := Parse_Pos + 1;
1773 if Parse_Pos <= Parse_End
1774 and then Is_Mult (Parse_Pos)
1775 then
1777 end if;
1778 end Parse_Piece;
1780 ---------------------------------
1781 -- Parse_Posix_Character_Class --
1782 ---------------------------------
1784 function Parse_Posix_Character_Class return Std_Class is
1785 Invert : Boolean := False;
1786 Class : Std_Class := ANYOF_NONE;
1787 E : String renames Expression;
1789 begin
1790 if Parse_Pos <= Parse_End
1791 and then Expression (Parse_Pos) = ':'
1792 then
1793 Parse_Pos := Parse_Pos + 1;
1795 -- Do we have something like: [[:^alpha:]]
1797 if Parse_Pos <= Parse_End
1798 and then Expression (Parse_Pos) = '^'
1799 then
1800 Invert := True;
1801 Parse_Pos := Parse_Pos + 1;
1802 end if;
1804 -- All classes have 6 characters at least
1805 -- ??? magid constant 6 should have a name!
1807 if Parse_Pos + 6 <= Parse_End then
1809 case Expression (Parse_Pos) is
1810 when 'a' =>
1812 if Invert then
1813 Class := ANYOF_NALNUMC;
1814 else
1815 Class := ANYOF_ALNUMC;
1816 end if;
1819 if Invert then
1820 Class := ANYOF_NALPHA;
1821 else
1822 Class := ANYOF_ALPHA;
1823 end if;
1826 if Invert then
1827 Class := ANYOF_NASCII;
1828 else
1829 Class := ANYOF_ASCII;
1830 end if;
1832 end if;
1834 when 'c' =>
1836 if Invert then
1837 Class := ANYOF_NCNTRL;
1838 else
1839 Class := ANYOF_CNTRL;
1840 end if;
1841 end if;
1843 when 'd' =>
1846 if Invert then
1847 Class := ANYOF_NDIGIT;
1848 else
1849 Class := ANYOF_DIGIT;
1850 end if;
1851 end if;
1853 when 'g' =>
1856 if Invert then
1857 Class := ANYOF_NGRAPH;
1858 else
1859 Class := ANYOF_GRAPH;
1860 end if;
1861 end if;
1863 when 'l' =>
1866 if Invert then
1867 Class := ANYOF_NLOWER;
1868 else
1869 Class := ANYOF_LOWER;
1870 end if;
1871 end if;
1873 when 'p' =>
1876 if Invert then
1877 Class := ANYOF_NPRINT;
1878 else
1879 Class := ANYOF_PRINT;
1880 end if;
1883 if Invert then
1884 Class := ANYOF_NPUNCT;
1885 else
1886 Class := ANYOF_PUNCT;
1887 end if;
1888 end if;
1890 when 's' =>
1893 if Invert then
1894 Class := ANYOF_NSPACE;
1895 else
1896 Class := ANYOF_SPACE;
1897 end if;
1898 end if;
1900 when 'u' =>
1903 if Invert then
1904 Class := ANYOF_NUPPER;
1905 else
1906 Class := ANYOF_UPPER;
1907 end if;
1908 end if;
1910 when 'w' =>
1913 if Invert then
1914 Class := ANYOF_NALNUM;
1915 else
1916 Class := ANYOF_ALNUM;
1917 end if;
1919 Parse_Pos := Parse_Pos - 1;
1920 end if;
1922 when 'x' =>
1924 if Parse_Pos + 7 <= Parse_End
1926 then
1927 if Invert then
1928 Class := ANYOF_NXDIGIT;
1929 else
1930 Class := ANYOF_XDIGIT;
1931 end if;
1933 Parse_Pos := Parse_Pos + 1;
1934 end if;
1936 when others =>
1937 Class := ANYOF_NONE;
1939 end case;
1941 if Class /= ANYOF_NONE then
1942 Parse_Pos := Parse_Pos + 7;
1943 end if;
1945 else
1947 end if;
1949 else
1950 return ANYOF_NONE;
1951 end if;
1953 return Class;
1954 end Parse_Posix_Character_Class;
1956 Expr_Flags : Expression_Flags;
1957 Result : Pointer;
1959 -- Start of processing for Compile
1961 begin
1962 Emit (MAGIC);
1963 Parse (False, Expr_Flags, Result);
1965 if Result = 0 then
1967 end if;
1969 Final_Code_Size := Emit_Ptr - 1;
1971 -- Do we want to actually compile the expression, or simply get the
1972 -- code size ???
1974 if Emit_Code then
1975 Optimize (PM);
1976 end if;
1978 PM.Flags := Flags;
1979 end Compile;
1981 function Compile
1982 (Expression : String;
1983 Flags : Regexp_Flags := No_Flags)
1984 return Pattern_Matcher
1985 is
1986 Size : Program_Size;
1987 Dummy : Pattern_Matcher (0);
1989 begin
1990 Compile (Dummy, Expression, Size, Flags);
1992 declare
1993 Result : Pattern_Matcher (Size);
1994 begin
1995 Compile (Result, Expression, Size, Flags);
1996 return Result;
1997 end;
1998 end Compile;
2000 procedure Compile
2001 (Matcher : out Pattern_Matcher;
2002 Expression : String;
2003 Flags : Regexp_Flags := No_Flags)
2004 is
2005 Size : Program_Size;
2007 begin
2008 Compile (Matcher, Expression, Size, Flags);
2009 end Compile;
2011 ----------
2012 -- Dump --
2013 ----------
2015 procedure Dump (Self : Pattern_Matcher) is
2017 -- Index : Pointer := Program_First + 1;
2018 -- What is the above line for ???
2020 Op : Opcode;
2021 Program : Program_Data renames Self.Program;
2023 procedure Dump_Until
2024 (Start : Pointer;
2025 Till : Pointer;
2026 Indent : Natural := 0);
2027 -- Dump the program until the node Till (not included) is met.
2028 -- Every line is indented with Index spaces at the beginning
2029 -- Dumps till the end if Till is 0.
2031 ----------------
2032 -- Dump_Until --
2033 ----------------
2035 procedure Dump_Until
2036 (Start : Pointer;
2037 Till : Pointer;
2038 Indent : Natural := 0)
2039 is
2040 Next : Pointer;
2041 Index : Pointer := Start;
2042 Local_Indent : Natural := Indent;
2043 Length : Pointer;
2045 begin
2046 while Index < Till loop
2048 Op := Opcode'Val (Character'Pos ((Self.Program (Index))));
2050 if Op = CLOSE then
2051 Local_Indent := Local_Indent - 3;
2052 end if;
2054 declare
2055 Point : String := Pointer'Image (Index);
2057 begin
2058 for J in 1 .. 6 - Point'Length loop
2059 Put (' ');
2060 end loop;
2062 Put (Point
2064 & (1 .. Local_Indent => ' ')
2065 & Opcode'Image (Op));
2066 end;
2068 -- Print the parenthesis number
2070 if Op = OPEN or else Op = CLOSE or else Op = REFF then
2071 Put (Natural'Image (Character'Pos (Program (Index + 3))));
2072 end if;
2074 Next := Index + Get_Next_Offset (Program, Index);
2076 if Next = Index then
2078 else
2080 end if;
2082 case Op is
2084 -- Character class operand
2086 when ANYOF => null;
2087 declare
2088 Bitmap : Character_Class;
2089 Last : Character := ASCII.Nul;
2090 Current : Natural := 0;
2092 Current_Char : Character;
2094 begin
2095 Bitmap_Operand (Program, Index, Bitmap);
2098 while Current <= 255 loop
2099 Current_Char := Character'Val (Current);
2101 -- First item in a range
2103 if Get_From_Class (Bitmap, Current_Char) then
2104 Last := Current_Char;
2106 -- Search for the last item in the range
2108 loop
2109 Current := Current + 1;
2110 exit when Current > 255;
2111 Current_Char := Character'Val (Current);
2112 exit when
2113 not Get_From_Class (Bitmap, Current_Char);
2115 end loop;
2117 if Last <= ' ' then
2118 Put (Last'Img);
2119 else
2120 Put (Last);
2121 end if;
2123 if Character'Succ (Last) /= Current_Char then
2125 end if;
2127 else
2128 Current := Current + 1;
2129 end if;
2130 end loop;
2132 New_Line;
2133 Index := Index + 3 + Bitmap'Length;
2134 end;
2136 -- string operand
2138 when EXACT | EXACTF =>
2139 Length := String_Length (Program, Index);
2142 & String (Program (String_Operand (Index)
2143 .. String_Operand (Index)
2144 + Length)));
2145 Index := String_Operand (Index) + Length + 1;
2146 New_Line;
2148 -- Node operand
2150 when BRANCH =>
2151 New_Line;
2152 Dump_Until (Index + 3, Next, Local_Indent + 3);
2153 Index := Next;
2155 when STAR | PLUS =>
2156 New_Line;
2158 -- Only one instruction
2160 Dump_Until (Index + 3, Index + 4, Local_Indent + 3);
2161 Index := Next;
2163 when CURLY | CURLYX =>
2165 & Natural'Image (Read_Natural (Program, Index + 3))
2167 & Natural'Image (Read_Natural (Program, Index + 5))
2169 New_Line;
2170 Dump_Until (Index + 7, Next, Local_Indent + 3);
2171 Index := Next;
2173 when OPEN =>
2174 New_Line;
2175 Index := Index + 4;
2176 Local_Indent := Local_Indent + 3;
2178 when CLOSE | REFF =>
2179 New_Line;
2180 Index := Index + 4;
2182 when EOP =>
2183 Index := Index + 3;
2184 New_Line;
2185 exit;
2187 -- No operand
2189 when others =>
2190 Index := Index + 3;
2191 New_Line;
2192 end case;
2193 end loop;
2194 end Dump_Until;
2196 -- Start of processing for Dump
2198 begin
2199 pragma Assert (Self.Program (Program_First) = MAGIC,
2203 & Character'Image (Self.First));
2205 if (Self.Flags and Case_Insensitive) /= 0 then
2207 end if;
2209 if (Self.Flags and Single_Line) /= 0 then
2211 end if;
2213 if (Self.Flags and Multiple_Lines) /= 0 then
2215 end if;
2218 Dump_Until (Program_First + 1, Self.Program'Last + 1);
2219 end Dump;
2221 --------------------
2222 -- Get_From_Class --
2223 --------------------
2225 function Get_From_Class
2226 (Bitmap : Character_Class;
2227 C : Character)
2228 return Boolean
2229 is
2230 Value : constant Class_Byte := Character'Pos (C);
2232 begin
2233 return (Bitmap (Value / 8)
2234 and Bit_Conversion (Value mod 8)) /= 0;
2235 end Get_From_Class;
2237 --------------
2238 -- Get_Next --
2239 --------------
2241 function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is
2242 Offset : constant Pointer := Get_Next_Offset (Program, IP);
2244 begin
2245 if Offset = 0 then
2246 return 0;
2247 else
2248 return IP + Offset;
2249 end if;
2250 end Get_Next;
2252 ---------------------
2253 -- Get_Next_Offset --
2254 ---------------------
2256 function Get_Next_Offset
2257 (Program : Program_Data;
2258 IP : Pointer)
2259 return Pointer
2260 is
2261 begin
2262 return Pointer (Read_Natural (Program, IP + 1));
2263 end Get_Next_Offset;
2265 --------------
2266 -- Is_Alnum --
2267 --------------
2269 function Is_Alnum (C : Character) return Boolean is
2270 begin
2271 return Is_Alphanumeric (C) or else C = '_';
2272 end Is_Alnum;
2274 ------------------
2275 -- Is_Printable --
2276 ------------------
2278 function Is_Printable (C : Character) return Boolean is
2279 Value : constant Natural := Character'Pos (C);
2281 begin
2282 return (Value > 32 and then Value < 127)
2283 or else Is_Space (C);
2284 end Is_Printable;
2286 --------------
2287 -- Is_Space --
2288 --------------
2290 function Is_Space (C : Character) return Boolean is
2291 begin
2292 return C = ' '
2293 or else C = ASCII.HT
2294 or else C = ASCII.CR
2295 or else C = ASCII.LF
2296 or else C = ASCII.VT
2297 or else C = ASCII.FF;
2298 end Is_Space;
2300 -----------
2301 -- Match --
2302 -----------
2304 procedure Match
2305 (Self : Pattern_Matcher;
2306 Data : String;
2307 Matches : out Match_Array)
2308 is
2309 Program : Program_Data renames Self.Program; -- Shorter notation
2311 -- Global work variables
2313 Input_Pos : Natural; -- String-input pointer
2314 BOL_Pos : Natural; -- Beginning of input, for ^ check
2315 Matched : Boolean := False; -- Until proven True
2317 Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count,
2318 Matches'Last));
2319 -- Stores the value of all the parenthesis pairs.
2320 -- We do not use directly Matches, so that we can also use back
2321 -- references (REFF) even if Matches is too small.
2323 type Natural_Array is array (Match_Count range <>) of Natural;
2324 Matches_Tmp : Natural_Array (Matches_Full'Range);
2325 -- Save the opening position of parenthesis.
2327 Last_Paren : Natural := 0;
2328 -- Last parenthesis seen
2330 Greedy : Boolean := True;
2331 -- True if the next operator should be greedy
2333 type Current_Curly_Record;
2334 type Current_Curly_Access is access all Current_Curly_Record;
2335 type Current_Curly_Record is record
2336 Paren_Floor : Natural; -- How far back to strip parenthesis data
2337 Cur : Integer; -- How many instances of scan we've matched
2338 Min : Natural; -- Minimal number of scans to match
2339 Max : Natural; -- Maximal number of scans to match
2340 Greedy : Boolean; -- Whether to work our way up or down
2341 Scan : Pointer; -- The thing to match
2342 Next : Pointer; -- What has to match after it
2343 Lastloc : Natural; -- Where we started matching this scan
2344 Old_Cc : Current_Curly_Access; -- Before we started this one
2345 end record;
2346 -- Data used to handle the curly operator and the plus and star
2347 -- operators for complex expressions.
2349 Current_Curly : Current_Curly_Access := null;
2350 -- The curly currently being processed.
2352 -----------------------
2353 -- Local Subprograms --
2354 -----------------------
2356 function Index (Start : Positive; C : Character) return Natural;
2357 -- Find character C in Data starting at Start and return position
2359 function Repeat
2360 (IP : Pointer;
2361 Max : Natural := Natural'Last)
2362 return Natural;
2363 -- Repeatedly match something simple, report how many
2364 -- It only matches on things of length 1.
2365 -- Starting from Input_Pos, it matches at most Max CURLY.
2367 function Try (Pos : in Positive) return Boolean;
2368 -- Try to match at specific point
2370 function Match (IP : Pointer) return Boolean;
2371 -- This is the main matching routine. Conceptually the strategy
2372 -- is simple: check to see whether the current node matches,
2373 -- call self recursively to see whether the rest matches,
2374 -- and then act accordingly.
2375 --
2376 -- In practice Match makes some effort to avoid recursion, in
2378 -- need to know whether the rest of the match failed) by
2379 -- using a loop instead of recursion.
2381 function Match_Whilem (IP : Pointer) return Boolean;
2382 -- Return True if a WHILEM matches
2384 function Recurse_Match (IP : Pointer; From : Natural) return Boolean;
2385 pragma Inline (Recurse_Match);
2386 -- Calls Match recursively. It saves and restores the parenthesis
2387 -- status and location in the input stream correctly, so that
2388 -- backtracking is possible
2390 function Match_Simple_Operator
2391 (Op : Opcode;
2392 Scan : Pointer;
2393 Next : Pointer;
2394 Greedy : Boolean)
2395 return Boolean;
2396 -- Return True it the simple operator (possibly non-greedy) matches
2398 pragma Inline_Always (Index);
2399 pragma Inline_Always (Repeat);
2401 -- These are two complex functions, but used only once.
2402 pragma Inline_Always (Match_Whilem);
2403 pragma Inline_Always (Match_Simple_Operator);
2405 -----------
2406 -- Index --
2407 -----------
2409 function Index
2410 (Start : Positive;
2411 C : Character)
2412 return Natural
2413 is
2414 begin
2415 for J in Start .. Data'Last loop
2416 if Data (J) = C then
2417 return J;
2418 end if;
2419 end loop;
2421 return 0;
2422 end Index;
2424 -------------------
2425 -- Recurse_Match --
2426 -------------------
2428 function Recurse_Match (IP : Pointer; From : Natural) return Boolean is
2429 L : constant Natural := Last_Paren;
2430 Tmp_F : constant Match_Array :=
2431 Matches_Full (From + 1 .. Matches_Full'Last);
2432 Start : constant Natural_Array :=
2433 Matches_Tmp (From + 1 .. Matches_Tmp'Last);
2434 Input : constant Natural := Input_Pos;
2435 begin
2436 if Match (IP) then
2437 return True;
2438 end if;
2439 Last_Paren := L;
2440 Matches_Full (Tmp_F'Range) := Tmp_F;
2441 Matches_Tmp (Start'Range) := Start;
2442 Input_Pos := Input;
2443 return False;
2444 end Recurse_Match;
2446 -----------
2447 -- Match --
2448 -----------
2450 function Match (IP : Pointer) return Boolean is
2451 Scan : Pointer := IP;
2452 Next : Pointer;
2453 Op : Opcode;
2455 begin
2456 State_Machine :
2457 loop
2458 pragma Assert (Scan /= 0);
2460 -- Determine current opcode and count its usage in debug mode
2462 Op := Opcode'Val (Character'Pos (Program (Scan)));
2464 -- Calculate offset of next instruction.
2465 -- Second character is most significant in Program_Data.
2467 Next := Get_Next (Program, Scan);
2469 case Op is
2470 when EOP =>
2471 return True; -- Success !
2473 when BRANCH =>
2474 if Program (Next) /= BRANCH then
2475 Next := Operand (Scan); -- No choice, avoid recursion
2477 else
2478 loop
2479 if Recurse_Match (Operand (Scan), 0) then
2480 return True;
2481 end if;
2483 Scan := Get_Next (Program, Scan);
2484 exit when Scan = 0 or Program (Scan) /= BRANCH;
2485 end loop;
2487 exit State_Machine;
2488 end if;
2490 when NOTHING =>
2491 null;
2493 when BOL =>
2494 exit State_Machine when
2495 Input_Pos /= BOL_Pos
2496 and then ((Self.Flags and Multiple_Lines) = 0
2497 or else Data (Input_Pos - 1) /= ASCII.LF);
2499 when MBOL =>
2500 exit State_Machine when
2501 Input_Pos /= BOL_Pos
2502 and then Data (Input_Pos - 1) /= ASCII.LF;
2504 when SBOL =>
2505 exit State_Machine when Input_Pos /= BOL_Pos;
2507 when EOL =>
2508 exit State_Machine when
2509 Input_Pos <= Data'Last
2510 and then ((Self.Flags and Multiple_Lines) = 0
2511 or else Data (Input_Pos) /= ASCII.LF);
2513 when MEOL =>
2514 exit State_Machine when
2515 Input_Pos <= Data'Last
2516 and then Data (Input_Pos) /= ASCII.LF;
2518 when SEOL =>
2519 exit State_Machine when Input_Pos <= Data'Last;
2521 when BOUND | NBOUND =>
2523 -- Was last char in word ?
2525 declare
2526 N : Boolean := False;
2527 Ln : Boolean := False;
2529 begin
2530 if Input_Pos /= Data'First then
2531 N := Is_Alnum (Data (Input_Pos - 1));
2532 end if;
2534 if Input_Pos > Data'Last then
2535 Ln := False;
2536 else
2537 Ln := Is_Alnum (Data (Input_Pos));
2538 end if;
2540 if Op = BOUND then
2541 if N = Ln then
2542 exit State_Machine;
2543 end if;
2544 else
2545 if N /= Ln then
2546 exit State_Machine;
2547 end if;
2548 end if;
2549 end;
2551 when SPACE =>
2552 exit State_Machine when
2553 Input_Pos > Data'Last
2554 or else not Is_Space (Data (Input_Pos));
2555 Input_Pos := Input_Pos + 1;
2557 when NSPACE =>
2558 exit State_Machine when
2559 Input_Pos > Data'Last
2560 or else Is_Space (Data (Input_Pos));
2561 Input_Pos := Input_Pos + 1;
2563 when DIGIT =>
2564 exit State_Machine when
2565 Input_Pos > Data'Last
2566 or else not Is_Digit (Data (Input_Pos));
2567 Input_Pos := Input_Pos + 1;
2569 when NDIGIT =>
2570 exit State_Machine when
2571 Input_Pos > Data'Last
2572 or else Is_Digit (Data (Input_Pos));
2573 Input_Pos := Input_Pos + 1;
2575 when ALNUM =>
2576 exit State_Machine when
2577 Input_Pos > Data'Last
2578 or else not Is_Alnum (Data (Input_Pos));
2579 Input_Pos := Input_Pos + 1;
2581 when NALNUM =>
2582 exit State_Machine when
2583 Input_Pos > Data'Last
2584 or else Is_Alnum (Data (Input_Pos));
2585 Input_Pos := Input_Pos + 1;
2587 when ANY =>
2588 exit State_Machine when Input_Pos > Data'Last
2589 or else Data (Input_Pos) = ASCII.LF;
2590 Input_Pos := Input_Pos + 1;
2592 when SANY =>
2593 exit State_Machine when Input_Pos > Data'Last;
2594 Input_Pos := Input_Pos + 1;
2596 when EXACT =>
2597 declare
2598 Opnd : Pointer := String_Operand (Scan);
2599 Current : Positive := Input_Pos;
2600 Last : constant Pointer :=
2601 Opnd + String_Length (Program, Scan);
2603 begin
2604 while Opnd <= Last loop
2605 exit State_Machine when Current > Data'Last
2606 or else Program (Opnd) /= Data (Current);
2607 Current := Current + 1;
2608 Opnd := Opnd + 1;
2609 end loop;
2611 Input_Pos := Current;
2612 end;
2614 when EXACTF =>
2615 declare
2616 Opnd : Pointer := String_Operand (Scan);
2617 Current : Positive := Input_Pos;
2618 Last : constant Pointer :=
2619 Opnd + String_Length (Program, Scan);
2621 begin
2622 while Opnd <= Last loop
2623 exit State_Machine when Current > Data'Last
2624 or else Program (Opnd) /= To_Lower (Data (Current));
2625 Current := Current + 1;
2626 Opnd := Opnd + 1;
2627 end loop;
2629 Input_Pos := Current;
2630 end;
2632 when ANYOF =>
2633 declare
2634 Bitmap : Character_Class;
2636 begin
2637 Bitmap_Operand (Program, Scan, Bitmap);
2638 exit State_Machine when
2639 Input_Pos > Data'Last
2640 or else not Get_From_Class (Bitmap, Data (Input_Pos));
2641 Input_Pos := Input_Pos + 1;
2642 end;
2644 when OPEN =>
2645 declare
2646 No : constant Natural :=
2647 Character'Pos (Program (Operand (Scan)));
2648 begin
2649 Matches_Tmp (No) := Input_Pos;
2650 end;
2652 when CLOSE =>
2653 declare
2654 No : constant Natural :=
2655 Character'Pos (Program (Operand (Scan)));
2656 begin
2657 Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1);
2658 if Last_Paren < No then
2659 Last_Paren := No;
2660 end if;
2661 end;
2663 when REFF =>
2664 declare
2665 No : constant Natural :=
2666 Character'Pos (Program (Operand (Scan)));
2667 Data_Pos : Natural;
2669 begin
2670 -- If we haven't seen that parenthesis yet
2672 if Last_Paren < No then
2673 return False;
2674 end if;
2676 Data_Pos := Matches_Full (No).First;
2677 while Data_Pos <= Matches_Full (No).Last loop
2678 if Input_Pos > Data'Last
2679 or else Data (Input_Pos) /= Data (Data_Pos)
2680 then
2681 return False;
2682 end if;
2684 Input_Pos := Input_Pos + 1;
2685 Data_Pos := Data_Pos + 1;
2686 end loop;
2687 end;
2689 when MINMOD =>
2690 Greedy := False;
2692 when STAR | PLUS | CURLY =>
2693 declare
2694 Greed : constant Boolean := Greedy;
2695 begin
2696 Greedy := True;
2697 return Match_Simple_Operator (Op, Scan, Next, Greed);
2698 end;
2700 when CURLYX =>
2702 -- Looking at something like:
2703 -- 1: CURLYX {n,m} (->4)
2704 -- 2: code for complex thing (->3)
2705 -- 3: WHILEM (->0)
2706 -- 4: NOTHING
2708 declare
2709 Cc : aliased Current_Curly_Record;
2710 Min : Natural := Read_Natural (Program, Scan + 3);
2711 Max : Natural := Read_Natural (Program, Scan + 5);
2713 Has_Match : Boolean;
2715 begin
2716 Cc := (Paren_Floor => Last_Paren,
2717 Cur => -1,
2718 Min => Min,
2719 Max => Max,
2720 Greedy => Greedy,
2721 Scan => Scan + 7,
2722 Next => Next,
2723 Lastloc => 0,
2724 Old_Cc => Current_Curly);
2725 Current_Curly := Cc'Unchecked_Access;
2727 Has_Match := Match (Next - 3);
2729 -- Start on the WHILEM
2731 Current_Curly := Cc.Old_Cc;
2732 return Has_Match;
2733 end;
2735 when WHILEM =>
2736 return Match_Whilem (IP);
2738 when others =>
2739 raise Expression_Error; -- Invalid instruction
2740 end case;
2742 Scan := Next;
2743 end loop State_Machine;
2745 -- If we get here, there is no match.
2746 -- For successful matches when EOP is the terminating point.
2748 return False;
2749 end Match;
2751 ---------------------------
2752 -- Match_Simple_Operator --
2753 ---------------------------
2755 function Match_Simple_Operator
2756 (Op : Opcode;
2757 Scan : Pointer;
2758 Next : Pointer;
2759 Greedy : Boolean)
2760 return Boolean
2761 is
2762 Next_Char : Character := ASCII.Nul;
2763 Next_Char_Known : Boolean := False;
2764 No : Integer; -- Can be negative
2765 Min : Natural;
2766 Max : Natural := Natural'Last;
2767 Operand_Code : Pointer;
2768 Old : Natural;
2769 Last_Pos : Natural;
2770 Save : Natural := Input_Pos;
2772 begin
2773 -- Lookahead to avoid useless match attempts
2774 -- when we know what character comes next.
2776 if Program (Next) = EXACT then
2777 Next_Char := Program (String_Operand (Next));
2778 Next_Char_Known := True;
2779 end if;
2781 -- Find the minimal and maximal values for the operator
2783 case Op is
2784 when STAR =>
2785 Min := 0;
2786 Operand_Code := Operand (Scan);
2788 when PLUS =>
2789 Min := 1;
2790 Operand_Code := Operand (Scan);
2792 when others =>
2793 Min := Read_Natural (Program, Scan + 3);
2794 Max := Read_Natural (Program, Scan + 5);
2795 Operand_Code := Scan + 7;
2796 end case;
2798 -- Non greedy operators
2800 if not Greedy then
2801 -- Test the minimal repetitions
2803 if Min /= 0
2804 and then Repeat (Operand_Code, Min) < Min
2805 then
2806 return False;
2807 end if;
2809 Old := Input_Pos;
2811 -- Find the place where 'next' could work
2813 if Next_Char_Known then
2814 -- Last position to check
2816 Last_Pos := Input_Pos + Max;
2818 if Last_Pos > Data'Last
2819 or else Max = Natural'Last
2820 then
2821 Last_Pos := Data'Last;
2822 end if;
2824 -- Look for the first possible opportunity
2826 loop
2827 -- Find the next possible position
2829 while Input_Pos <= Last_Pos
2830 and then Data (Input_Pos) /= Next_Char
2831 loop
2832 Input_Pos := Input_Pos + 1;
2833 end loop;
2835 if Input_Pos > Last_Pos then
2836 return False;
2837 end if;
2839 -- Check that we still match if we stop
2840 -- at the position we just found.
2842 declare
2843 Num : constant Natural := Input_Pos - Old;
2845 begin
2846 Input_Pos := Old;
2848 if Repeat (Operand_Code, Num) < Num then
2849 return False;
2850 end if;
2851 end;
2853 -- Input_Pos now points to the new position
2855 if Match (Get_Next (Program, Scan)) then
2856 return True;
2857 end if;
2859 Old := Input_Pos;
2860 Input_Pos := Input_Pos + 1;
2861 end loop;
2863 -- We know what the next character is
2865 else
2866 while Max >= Min loop
2868 -- If the next character matches
2870 if Match (Next) then
2871 return True;
2872 end if;
2874 Input_Pos := Save + Min;
2876 -- Could not or did not match -- move forward
2878 if Repeat (Operand_Code, 1) /= 0 then
2879 Min := Min + 1;
2880 else
2881 return False;
2882 end if;
2883 end loop;
2884 end if;
2886 return False;
2888 -- Greedy operators
2890 else
2891 No := Repeat (Operand_Code, Max);
2893 -- ??? Perl has some special code here in case the
2895 -- can match before *and* after newline at the end.
2897 -- ??? Perl has some special code here in case (paren)
2898 -- is True.
2900 -- Else, if we don't have any parenthesis
2902 while No >= Min loop
2903 if not Next_Char_Known
2904 or else (Input_Pos <= Data'Last
2905 and then Data (Input_Pos) = Next_Char)
2906 then
2907 if Match (Next) then
2908 return True;
2909 end if;
2910 end if;
2912 -- Could not or did not work, we back up
2914 No := No - 1;
2915 Input_Pos := Save + No;
2916 end loop;
2917 return False;
2918 end if;
2919 end Match_Simple_Operator;
2921 ------------------
2922 -- Match_Whilem --
2923 ------------------
2925 -- This is really hard to understand, because after we match what we're
2926 -- trying to match, we must make sure the rest of the REx is going to
2927 -- match for sure, and to do that we have to go back UP the parse tree
2928 -- by recursing ever deeper. And if it fails, we have to reset our
2929 -- parent's current state that we can try again after backing off.
2931 function Match_Whilem (IP : Pointer) return Boolean is
2932 Cc : Current_Curly_Access := Current_Curly;
2933 N : Natural := Cc.Cur + 1;
2934 Ln : Natural;
2935 Lastloc : Natural := Cc.Lastloc;
2936 -- Detection of 0-len.
2938 begin
2941 if Input_Pos = Cc.Lastloc
2942 and then N >= Cc.Min
2943 then
2944 -- Temporarily restore the old context, and check that we
2945 -- match was comes after CURLYX.
2947 Current_Curly := Cc.Old_Cc;
2949 if Current_Curly /= null then
2950 Ln := Current_Curly.Cur;
2951 end if;
2953 if Match (Cc.Next) then
2954 return True;
2955 end if;
2957 if Current_Curly /= null then
2958 Current_Curly.Cur := Ln;
2959 end if;
2961 Current_Curly := Cc;
2962 return False;
2963 end if;
2965 -- First, just match a string of min scans.
2967 if N < Cc.Min then
2968 Cc.Cur := N;
2969 Cc.Lastloc := Input_Pos;
2971 if Match (Cc.Scan) then
2972 return True;
2973 end if;
2975 Cc.Cur := N - 1;
2976 Cc.Lastloc := Lastloc;
2977 return False;
2978 end if;
2980 -- Prefer next over scan for minimal matching.
2982 if not Cc.Greedy then
2983 Current_Curly := Cc.Old_Cc;
2985 if Current_Curly /= null then
2986 Ln := Current_Curly.Cur;
2987 end if;
2989 if Recurse_Match (Cc.Next, Cc.Paren_Floor) then
2990 return True;
2991 end if;
2993 if Current_Curly /= null then
2994 Current_Curly.Cur := Ln;
2995 end if;
2997 Current_Curly := Cc;
2999 -- Maximum greed exceeded ?
3001 if N >= Cc.Max then
3002 return False;
3003 end if;
3005 -- Try scanning more and see if it helps
3006 Cc.Cur := N;
3007 Cc.Lastloc := Input_Pos;
3009 if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3010 return True;
3011 end if;
3013 Cc.Cur := N - 1;
3014 Cc.Lastloc := Lastloc;
3015 return False;
3016 end if;
3018 -- Prefer scan over next for maximal matching
3020 if N < Cc.Max then -- more greed allowed ?
3021 Cc.Cur := N;
3022 Cc.Lastloc := Input_Pos;
3024 if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
3025 return True;
3026 end if;
3027 end if;
3029 -- Failed deeper matches of scan, so see if this one works
3031 Current_Curly := Cc.Old_Cc;
3033 if Current_Curly /= null then
3034 Ln := Current_Curly.Cur;
3035 end if;
3037 if Match (Cc.Next) then
3038 return True;
3039 end if;
3041 if Current_Curly /= null then
3042 Current_Curly.Cur := Ln;
3043 end if;
3045 Current_Curly := Cc;
3046 Cc.Cur := N - 1;
3047 Cc.Lastloc := Lastloc;
3048 return False;
3049 end Match_Whilem;
3051 ------------
3052 -- Repeat --
3053 ------------
3055 function Repeat
3056 (IP : Pointer;
3057 Max : Natural := Natural'Last)
3058 return Natural
3059 is
3060 Scan : Natural := Input_Pos;
3061 Last : Natural;
3062 Op : constant Opcode := Opcode'Val (Character'Pos (Program (IP)));
3063 Count : Natural;
3064 C : Character;
3065 Is_First : Boolean := True;
3066 Bitmap : Character_Class;
3068 begin
3069 if Max = Natural'Last or else Scan + Max - 1 > Data'Last then
3070 Last := Data'Last;
3071 else
3072 Last := Scan + Max - 1;
3073 end if;
3075 case Op is
3076 when ANY =>
3077 while Scan <= Last
3078 and then Data (Scan) /= ASCII.LF
3079 loop
3080 Scan := Scan + 1;
3081 end loop;
3083 when SANY =>
3084 Scan := Last + 1;
3086 when EXACT =>
3088 -- The string has only one character if Repeat was called
3090 C := Program (String_Operand (IP));
3091 while Scan <= Last
3092 and then C = Data (Scan)
3093 loop
3094 Scan := Scan + 1;
3095 end loop;
3097 when EXACTF =>
3099 -- The string has only one character if Repeat was called
3101 C := Program (String_Operand (IP));
3102 while Scan <= Last
3103 and then To_Lower (C) = Data (Scan)
3104 loop
3105 Scan := Scan + 1;
3106 end loop;
3108 when ANYOF =>
3109 if Is_First then
3110 Bitmap_Operand (Program, IP, Bitmap);
3111 Is_First := False;
3112 end if;
3114 while Scan <= Last
3115 and then Get_From_Class (Bitmap, Data (Scan))
3116 loop
3117 Scan := Scan + 1;
3118 end loop;
3120 when ALNUM =>
3121 while Scan <= Last
3122 and then Is_Alnum (Data (Scan))
3123 loop
3124 Scan := Scan + 1;
3125 end loop;
3127 when NALNUM =>
3128 while Scan <= Last
3129 and then not Is_Alnum (Data (Scan))
3130 loop
3131 Scan := Scan + 1;
3132 end loop;
3134 when SPACE =>
3135 while Scan <= Last
3136 and then Is_Space (Data (Scan))
3137 loop
3138 Scan := Scan + 1;
3139 end loop;
3141 when NSPACE =>
3142 while Scan <= Last
3143 and then not Is_Space (Data (Scan))
3144 loop
3145 Scan := Scan + 1;
3146 end loop;
3148 when DIGIT =>
3149 while Scan <= Last
3150 and then Is_Digit (Data (Scan))
3151 loop
3152 Scan := Scan + 1;
3153 end loop;
3155 when NDIGIT =>
3156 while Scan <= Last
3157 and then not Is_Digit (Data (Scan))
3158 loop
3159 Scan := Scan + 1;
3160 end loop;
3162 when others =>
3163 raise Program_Error;
3164 end case;
3166 Count := Scan - Input_Pos;
3167 Input_Pos := Scan;
3168 return Count;
3169 end Repeat;
3171 ---------
3172 -- Try --
3173 ---------
3175 function Try (Pos : in Positive) return Boolean is
3176 begin
3177 Input_Pos := Pos;
3178 Last_Paren := 0;
3179 Matches_Full := (others => No_Match);
3181 if Match (Program_First + 1) then
3182 Matches_Full (0) := (Pos, Input_Pos - 1);
3183 return True;
3184 end if;
3186 return False;
3187 end Try;
3189 -- Start of processing for Match
3191 begin
3192 -- Do we have the regexp Never_Match?
3194 if Self.Size = 0 then
3195 Matches (0) := No_Match;
3196 return;
3197 end if;
3199 -- Check validity of program
3201 pragma Assert
3202 (Program (Program_First) = MAGIC,
3207 if Self.Must_Have_Length > 0 then
3208 declare
3209 First : constant Character := Program (Self.Must_Have);
3210 Must_First : constant Pointer := Self.Must_Have;
3211 Must_Last : constant Pointer :=
3212 Must_First + Pointer (Self.Must_Have_Length - 1);
3213 Next_Try : Natural := Index (Data'First, First);
3215 begin
3216 while Next_Try /= 0
3217 and then Data (Next_Try .. Next_Try + Self.Must_Have_Length - 1)
3218 = String (Program (Must_First .. Must_Last))
3219 loop
3220 Next_Try := Index (Next_Try + 1, First);
3221 end loop;
3223 if Next_Try = 0 then
3224 Matches_Full := (others => No_Match);
3225 return; -- Not present
3226 end if;
3227 end;
3228 end if;
3230 -- Mark beginning of line for ^
3232 BOL_Pos := Data'First;
3234 -- Simplest case first: an anchored match need be tried only once
3236 if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then
3237 Matched := Try (Data'First);
3239 elsif Self.Anchored then
3240 declare
3241 Next_Try : Natural := Data'First;
3242 begin
3243 -- Test the first position in the buffer
3244 Matched := Try (Next_Try);
3246 -- Else only test after newlines
3248 if not Matched then
3249 while Next_Try <= Data'Last loop
3250 while Next_Try <= Data'Last
3251 and then Data (Next_Try) /= ASCII.LF
3252 loop
3253 Next_Try := Next_Try + 1;
3254 end loop;
3256 Next_Try := Next_Try + 1;
3258 if Next_Try <= Data'Last then
3259 Matched := Try (Next_Try);
3260 exit when Matched;
3261 end if;
3262 end loop;
3263 end if;
3264 end;
3266 elsif Self.First /= ASCII.NUL then
3268 -- We know what char it must start with
3270 declare
3271 Next_Try : Natural := Index (Data'First, Self.First);
3273 begin
3274 while Next_Try /= 0 loop
3275 Matched := Try (Next_Try);
3276 exit when Matched;
3277 Next_Try := Index (Next_Try + 1, Self.First);
3278 end loop;
3279 end;
3281 else
3282 -- Messy cases: try all locations (including for the empty string)
3284 Matched := Try (Data'First);
3286 if not Matched then
3287 for S in Data'First + 1 .. Data'Last loop
3288 Matched := Try (S);
3289 exit when Matched;
3290 end loop;
3291 end if;
3292 end if;
3294 -- Matched has its value
3296 for J in Last_Paren + 1 .. Matches'Last loop
3297 Matches_Full (J) := No_Match;
3298 end loop;
3300 Matches := Matches_Full (Matches'Range);
3301 return;
3302 end Match;
3304 function Match
3305 (Self : Pattern_Matcher;
3306 Data : String)
3307 return Natural
3308 is
3309 Matches : Match_Array (0 .. 0);
3311 begin
3312 Match (Self, Data, Matches);
3313 if Matches (0) = No_Match then
3314 return Data'First - 1;
3315 else
3316 return Matches (0).First;
3317 end if;
3318 end Match;
3320 procedure Match
3321 (Expression : String;
3322 Data : String;
3323 Matches : out Match_Array;
3324 Size : Program_Size := 0)
3325 is
3326 PM : Pattern_Matcher (Size);
3327 Finalize_Size : Program_Size;
3329 begin
3330 if Size = 0 then
3331 Match (Compile (Expression), Data, Matches);
3332 else
3333 Compile (PM, Expression, Finalize_Size);
3334 Match (PM, Data, Matches);
3335 end if;
3336 end Match;
3338 function Match
3339 (Expression : String;
3340 Data : String;
3341 Size : Program_Size := 0)
3342 return Natural
3343 is
3344 PM : Pattern_Matcher (Size);
3345 Final_Size : Program_Size; -- unused
3347 begin
3348 if Size = 0 then
3349 return Match (Compile (Expression), Data);
3350 else
3351 Compile (PM, Expression, Final_Size);
3352 return Match (PM, Data);
3353 end if;
3354 end Match;
3356 function Match
3357 (Expression : String;
3358 Data : String;
3359 Size : Program_Size := 0)
3360 return Boolean
3361 is
3362 Matches : Match_Array (0 .. 0);
3363 PM : Pattern_Matcher (Size);
3364 Final_Size : Program_Size; -- unused
3366 begin
3367 if Size = 0 then
3368 Match (Compile (Expression), Data, Matches);
3369 else
3370 Compile (PM, Expression, Final_Size);
3371 Match (PM, Data, Matches);
3372 end if;
3374 return Matches (0).First >= Data'First;
3375 end Match;
3377 -------------
3378 -- Operand --
3379 -------------
3381 function Operand (P : Pointer) return Pointer is
3382 begin
3383 return P + 3;
3384 end Operand;
3386 --------------
3387 -- Optimize --
3388 --------------
3390 procedure Optimize (Self : in out Pattern_Matcher) is
3391 Max_Length : Program_Size;
3392 This_Length : Program_Size;
3393 Longest : Pointer;
3394 Scan : Pointer;
3395 Program : Program_Data renames Self.Program;
3397 begin
3398 -- Start with safe defaults (no optimization):
3399 -- * No known first character of match
3400 -- * Does not necessarily start at beginning of line
3401 -- * No string known that has to appear in data
3403 Self.First := ASCII.NUL;
3404 Self.Anchored := False;
3405 Self.Must_Have := Program'Last + 1;
3406 Self.Must_Have_Length := 0;
3408 Scan := Program_First + 1; -- First instruction (can be anything)
3410 if Program (Scan) = EXACT then
3411 Self.First := Program (String_Operand (Scan));
3413 elsif Program (Scan) = BOL
3414 or else Program (Scan) = SBOL
3415 or else Program (Scan) = MBOL
3416 then
3417 Self.Anchored := True;
3418 end if;
3420 -- If there's something expensive in the regexp, find the
3421 -- longest literal string that must appear and make it the
3422 -- regmust. Resolve ties in favor of later strings, since
3423 -- the regstart check works with the beginning of the regexp.
3424 -- and avoiding duplication strengthens checking. Not a
3425 -- strong reason, but sufficient in the absence of others.
3427 if False then -- if Flags.SP_Start then ???
3428 Longest := 0;
3429 Max_Length := 0;
3430 while Scan /= 0 loop
3431 if Program (Scan) = EXACT or else Program (Scan) = EXACTF then
3432 This_Length := String_Length (Program, Scan);
3434 if This_Length >= Max_Length then
3435 Longest := String_Operand (Scan);
3436 Max_Length := This_Length;
3437 end if;
3438 end if;
3440 Scan := Get_Next (Program, Scan);
3441 end loop;
3443 Self.Must_Have := Longest;
3444 Self.Must_Have_Length := Natural (Max_Length) + 1;
3445 end if;
3446 end Optimize;
3448 -----------------
3449 -- Paren_Count --
3450 -----------------
3452 function Paren_Count (Regexp : Pattern_Matcher) return Match_Count is
3453 begin
3454 return Regexp.Paren_Count;
3455 end Paren_Count;
3457 -----------
3458 -- Quote --
3459 -----------
3461 function Quote (Str : String) return String is
3462 S : String (1 .. Str'Length * 2);
3463 Last : Natural := 0;
3465 begin
3466 for J in Str'Range loop
3467 case Str (J) is
3468 when '^' | '$' | '|' | '*' | '+' | '?' | '{'
3469 | '}' | '[' | ']' | '(' | ')' | '\' =>
3471 S (Last + 1) := '\';
3472 S (Last + 2) := Str (J);
3473 Last := Last + 2;
3475 when others =>
3476 S (Last + 1) := Str (J);
3477 Last := Last + 1;
3478 end case;
3479 end loop;
3481 return S (1 .. Last);
3482 end Quote;
3484 ------------------
3485 -- Read_Natural --
3486 ------------------
3488 function Read_Natural
3489 (Program : Program_Data;
3490 IP : Pointer)
3491 return Natural
3492 is
3493 begin
3494 return Character'Pos (Program (IP)) +
3495 256 * Character'Pos (Program (IP + 1));
3496 end Read_Natural;
3498 -----------------
3499 -- Reset_Class --
3500 -----------------
3502 procedure Reset_Class (Bitmap : in out Character_Class) is
3503 begin
3504 Bitmap := (others => 0);
3505 end Reset_Class;
3507 ------------------
3508 -- Set_In_Class --
3509 ------------------
3511 procedure Set_In_Class
3512 (Bitmap : in out Character_Class;
3513 C : Character)
3514 is
3515 Value : constant Class_Byte := Character'Pos (C);
3517 begin
3518 Bitmap (Value / 8) := Bitmap (Value / 8)
3519 or Bit_Conversion (Value mod 8);
3520 end Set_In_Class;
3522 -------------------
3523 -- String_Length --
3524 -------------------
3526 function String_Length
3527 (Program : Program_Data;
3528 P : Pointer)
3529 return Program_Size
3530 is
3531 begin
3532 pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF);
3533 return Character'Pos (Program (P + 3));
3534 end String_Length;
3536 --------------------
3537 -- String_Operand --
3538 --------------------
3540 function String_Operand (P : Pointer) return Pointer is
3541 begin
3542 return P + 4;
3543 end String_Operand;
3545 end GNAT.Regpat;