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