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