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