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