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