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