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