File : s-regexp.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . R E G E X P --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1999-2015, AdaCore --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Ada.Unchecked_Deallocation;
33 with System.Case_Util;
34
35 package body System.Regexp is
36
37 Initial_Max_States_In_Primary_Table : constant := 100;
38 -- Initial size for the number of states in the indefinite state
39 -- machine. The number of states will be increased as needed.
40 --
41 -- This is also used as the maximal number of meta states (groups of
42 -- states) in the secondary table.
43
44 Open_Paren : constant Character := '(';
45 Close_Paren : constant Character := ')';
46 Open_Bracket : constant Character := '[';
47 Close_Bracket : constant Character := ']';
48
49 type State_Index is new Natural;
50 type Column_Index is new Natural;
51
52 type Regexp_Array is array
53 (State_Index range <>, Column_Index range <>) of State_Index;
54 -- First index is for the state number. Second index is for the character
55 -- type. Contents is the new State.
56
57 type Regexp_Array_Access is access Regexp_Array;
58 -- Use this type through the functions Set below, so that it can grow
59 -- dynamically depending on the needs.
60
61 type Mapping is array (Character'Range) of Column_Index;
62 -- Mapping between characters and column in the Regexp_Array
63
64 type Boolean_Array is array (State_Index range <>) of Boolean;
65
66 type Regexp_Value
67 (Alphabet_Size : Column_Index;
68 Num_States : State_Index) is
69 record
70 Map : Mapping;
71 States : Regexp_Array (1 .. Num_States, 0 .. Alphabet_Size);
72 Is_Final : Boolean_Array (1 .. Num_States);
73 Case_Sensitive : Boolean;
74 end record;
75 -- Deterministic finite-state machine
76
77 -----------------------
78 -- Local Subprograms --
79 -----------------------
80
81 procedure Set
82 (Table : in out Regexp_Array_Access;
83 State : State_Index;
84 Column : Column_Index;
85 Value : State_Index);
86 -- Sets a value in the table. If the table is too small, reallocate it
87 -- dynamically so that (State, Column) is a valid index in it.
88
89 function Get
90 (Table : Regexp_Array_Access;
91 State : State_Index;
92 Column : Column_Index) return State_Index;
93 -- Returns the value in the table at (State, Column). If this index does
94 -- not exist in the table, returns zero.
95
96 procedure Free is new Ada.Unchecked_Deallocation
97 (Regexp_Array, Regexp_Array_Access);
98
99 ------------
100 -- Adjust --
101 ------------
102
103 procedure Adjust (R : in out Regexp) is
104 Tmp : Regexp_Access;
105 begin
106 if R.R /= null then
107 Tmp := new Regexp_Value (Alphabet_Size => R.R.Alphabet_Size,
108 Num_States => R.R.Num_States);
109 Tmp.all := R.R.all;
110 R.R := Tmp;
111 end if;
112 end Adjust;
113
114 -------------
115 -- Compile --
116 -------------
117
118 function Compile
119 (Pattern : String;
120 Glob : Boolean := False;
121 Case_Sensitive : Boolean := True) return Regexp
122 is
123 S : String := Pattern;
124 -- The pattern which is really compiled (when the pattern is case
125 -- insensitive, we convert this string to lower-cases
126
127 Map : Mapping := (others => 0);
128 -- Mapping between characters and columns in the tables
129
130 Alphabet_Size : Column_Index := 0;
131 -- Number of significant characters in the regular expression.
132 -- This total does not include special operators, such as *, (, ...
133
134 procedure Check_Well_Formed_Pattern;
135 -- Check that the pattern to compile is well-formed, so that subsequent
136 -- code can rely on this without performing each time the checks to
137 -- avoid accessing the pattern outside its bounds. However, not all
138 -- well-formedness rules are checked. In particular, rules about special
139 -- characters not being treated as regular characters are not checked.
140
141 procedure Create_Mapping;
142 -- Creates a mapping between characters in the regexp and columns
143 -- in the tables representing the regexp. Test that the regexp is
144 -- well-formed Modifies Alphabet_Size and Map
145
146 procedure Create_Primary_Table
147 (Table : out Regexp_Array_Access;
148 Num_States : out State_Index;
149 Start_State : out State_Index;
150 End_State : out State_Index);
151 -- Creates the first version of the regexp (this is a non deterministic
152 -- finite state machine, which is unadapted for a fast pattern
153 -- matching algorithm). We use a recursive algorithm to process the
154 -- parenthesis sub-expressions.
155 --
156 -- Table : at the end of the procedure : Column 0 is for any character
157 -- ('.') and the last columns are for no character (closure). Num_States
158 -- is set to the number of states in the table Start_State is the number
159 -- of the starting state in the regexp End_State is the number of the
160 -- final state when the regexp matches.
161
162 procedure Create_Primary_Table_Glob
163 (Table : out Regexp_Array_Access;
164 Num_States : out State_Index;
165 Start_State : out State_Index;
166 End_State : out State_Index);
167 -- Same function as above, but it deals with the second possible
168 -- grammar for 'globbing pattern', which is a kind of subset of the
169 -- whole regular expression grammar.
170
171 function Create_Secondary_Table
172 (First_Table : Regexp_Array_Access;
173 Start_State : State_Index;
174 End_State : State_Index) return Regexp;
175 -- Creates the definitive table representing the regular expression
176 -- This is actually a transformation of the primary table First_Table,
177 -- where every state is grouped with the states in its 'no-character'
178 -- columns. The transitions between the new states are then recalculated
179 -- and if necessary some new states are created.
180 --
181 -- Note that the resulting finite-state machine is not optimized in
182 -- terms of the number of states : it would be more time-consuming to
183 -- add a third pass to reduce the number of states in the machine, with
184 -- no speed improvement...
185
186 procedure Raise_Exception (M : String; Index : Integer);
187 pragma No_Return (Raise_Exception);
188 -- Raise an exception, indicating an error at character Index in S
189
190 -------------------------------
191 -- Check_Well_Formed_Pattern --
192 -------------------------------
193
194 procedure Check_Well_Formed_Pattern is
195 J : Integer;
196
197 Past_Elmt : Boolean := False;
198 -- Set to True everywhere an elmt has been parsed, if Glob=False,
199 -- meaning there can be now an occurrence of '*', '+' and '?'.
200
201 Past_Term : Boolean := False;
202 -- Set to True everywhere a term has been parsed, if Glob=False,
203 -- meaning there can be now an occurrence of '|'.
204
205 Parenthesis_Level : Integer := 0;
206 Curly_Level : Integer := 0;
207
208 Last_Open : Integer := S'First - 1;
209 -- The last occurrence of an opening parenthesis, if Glob=False,
210 -- or the last occurrence of an opening curly brace, if Glob=True.
211
212 procedure Raise_Exception_If_No_More_Chars (K : Integer := 0);
213 -- If no more characters are raised, call Raise_Exception
214
215 --------------------------------------
216 -- Raise_Exception_If_No_More_Chars --
217 --------------------------------------
218
219 procedure Raise_Exception_If_No_More_Chars (K : Integer := 0) is
220 begin
221 if J + K > S'Last then
222 Raise_Exception ("Ill-formed pattern while parsing", J);
223 end if;
224 end Raise_Exception_If_No_More_Chars;
225
226 -- Start of processing for Check_Well_Formed_Pattern
227
228 begin
229 J := S'First;
230 while J <= S'Last loop
231 case S (J) is
232 when Open_Bracket =>
233 J := J + 1;
234 Raise_Exception_If_No_More_Chars;
235
236 if not Glob then
237 if S (J) = '^' then
238 J := J + 1;
239 Raise_Exception_If_No_More_Chars;
240 end if;
241 end if;
242
243 -- The first character never has a special meaning
244
245 if S (J) = ']' or else S (J) = '-' then
246 J := J + 1;
247 Raise_Exception_If_No_More_Chars;
248 end if;
249
250 -- The set of characters cannot be empty
251
252 if S (J) = ']' then
253 Raise_Exception
254 ("Set of characters cannot be empty in regular "
255 & "expression", J);
256 end if;
257
258 declare
259 Possible_Range_Start : Boolean := True;
260 -- Set True everywhere a range character '-' can occur
261
262 begin
263 loop
264 exit when S (J) = Close_Bracket;
265
266 -- The current character should be followed by a
267 -- closing bracket.
268
269 Raise_Exception_If_No_More_Chars (1);
270
271 if S (J) = '-'
272 and then S (J + 1) /= Close_Bracket
273 then
274 if not Possible_Range_Start then
275 Raise_Exception
276 ("No mix of ranges is allowed in "
277 & "regular expression", J);
278 end if;
279
280 J := J + 1;
281 Raise_Exception_If_No_More_Chars;
282
283 -- Range cannot be followed by '-' character,
284 -- except as last character in the set.
285
286 Possible_Range_Start := False;
287
288 else
289 Possible_Range_Start := True;
290 end if;
291
292 if S (J) = '\' then
293 J := J + 1;
294 Raise_Exception_If_No_More_Chars;
295 end if;
296
297 J := J + 1;
298 end loop;
299 end;
300
301 -- A closing bracket can end an elmt or term
302
303 Past_Elmt := True;
304 Past_Term := True;
305
306 when Close_Bracket =>
307
308 -- A close bracket must follow a open_bracket, and cannot be
309 -- found alone on the line.
310
311 Raise_Exception
312 ("Incorrect character ']' in regular expression", J);
313
314 when '\' =>
315 if J < S'Last then
316 J := J + 1;
317
318 -- Any character can be an elmt or a term
319
320 Past_Elmt := True;
321 Past_Term := True;
322
323 else
324 -- \ not allowed at the end of the regexp
325
326 Raise_Exception
327 ("Incorrect character '\' in regular expression", J);
328 end if;
329
330 when Open_Paren =>
331 if not Glob then
332 Parenthesis_Level := Parenthesis_Level + 1;
333 Last_Open := J;
334
335 -- An open parenthesis does not end an elmt or term
336
337 Past_Elmt := False;
338 Past_Term := False;
339 end if;
340
341 when Close_Paren =>
342 if not Glob then
343 Parenthesis_Level := Parenthesis_Level - 1;
344
345 if Parenthesis_Level < 0 then
346 Raise_Exception
347 ("')' is not associated with '(' in regular "
348 & "expression", J);
349 end if;
350
351 if J = Last_Open + 1 then
352 Raise_Exception
353 ("Empty parentheses not allowed in regular "
354 & "expression", J);
355 end if;
356
357 if not Past_Term then
358 Raise_Exception
359 ("Closing parenthesis not allowed here in regular "
360 & "expression", J);
361 end if;
362
363 -- A closing parenthesis can end an elmt or term
364
365 Past_Elmt := True;
366 Past_Term := True;
367 end if;
368
369 when '{' =>
370 if Glob then
371 Curly_Level := Curly_Level + 1;
372 Last_Open := J;
373
374 else
375 -- Any character can be an elmt or a term
376
377 Past_Elmt := True;
378 Past_Term := True;
379 end if;
380
381 -- No need to check for ',' as the code always accepts them
382
383 when '}' =>
384 if Glob then
385 Curly_Level := Curly_Level - 1;
386
387 if Curly_Level < 0 then
388 Raise_Exception
389 ("'}' is not associated with '{' in regular "
390 & "expression", J);
391 end if;
392
393 if J = Last_Open + 1 then
394 Raise_Exception
395 ("Empty curly braces not allowed in regular "
396 & "expression", J);
397 end if;
398
399 else
400 -- Any character can be an elmt or a term
401
402 Past_Elmt := True;
403 Past_Term := True;
404 end if;
405
406 when '*' | '?' | '+' =>
407 if not Glob then
408
409 -- These operators must apply to an elmt sub-expression,
410 -- and cannot be found if one has not just been parsed.
411
412 if not Past_Elmt then
413 Raise_Exception
414 ("'*', '+' and '?' operators must be "
415 & "applied to an element in regular expression", J);
416 end if;
417
418 Past_Elmt := False;
419 Past_Term := True;
420 end if;
421
422 when '|' =>
423 if not Glob then
424
425 -- This operator must apply to a term sub-expression,
426 -- and cannot be found if one has not just been parsed.
427
428 if not Past_Term then
429 Raise_Exception
430 ("'|' operator must be "
431 & "applied to a term in regular expression", J);
432 end if;
433
434 Past_Elmt := False;
435 Past_Term := False;
436 end if;
437
438 when others =>
439 if not Glob then
440
441 -- Any character can be an elmt or a term
442
443 Past_Elmt := True;
444 Past_Term := True;
445 end if;
446 end case;
447
448 J := J + 1;
449 end loop;
450
451 -- A closing parenthesis must follow an open parenthesis
452
453 if Parenthesis_Level /= 0 then
454 Raise_Exception
455 ("'(' must always be associated with a ')'", J);
456 end if;
457
458 -- A closing curly brace must follow an open curly brace
459
460 if Curly_Level /= 0 then
461 Raise_Exception
462 ("'{' must always be associated with a '}'", J);
463 end if;
464 end Check_Well_Formed_Pattern;
465
466 --------------------
467 -- Create_Mapping --
468 --------------------
469
470 procedure Create_Mapping is
471
472 procedure Add_In_Map (C : Character);
473 -- Add a character in the mapping, if it is not already defined
474
475 ----------------
476 -- Add_In_Map --
477 ----------------
478
479 procedure Add_In_Map (C : Character) is
480 begin
481 if Map (C) = 0 then
482 Alphabet_Size := Alphabet_Size + 1;
483 Map (C) := Alphabet_Size;
484 end if;
485 end Add_In_Map;
486
487 J : Integer := S'First;
488 Parenthesis_Level : Integer := 0;
489 Curly_Level : Integer := 0;
490 Last_Open : Integer := S'First - 1;
491
492 -- Start of processing for Create_Mapping
493
494 begin
495 while J <= S'Last loop
496 case S (J) is
497 when Open_Bracket =>
498 J := J + 1;
499
500 if S (J) = '^' then
501 J := J + 1;
502 end if;
503
504 if S (J) = ']' or else S (J) = '-' then
505 J := J + 1;
506 end if;
507
508 -- The first character never has a special meaning
509
510 loop
511 if J > S'Last then
512 Raise_Exception
513 ("Ran out of characters while parsing ", J);
514 end if;
515
516 exit when S (J) = Close_Bracket;
517
518 if S (J) = '-'
519 and then S (J + 1) /= Close_Bracket
520 then
521 declare
522 Start : constant Integer := J - 1;
523
524 begin
525 J := J + 1;
526
527 if S (J) = '\' then
528 J := J + 1;
529 end if;
530
531 for Char in S (Start) .. S (J) loop
532 Add_In_Map (Char);
533 end loop;
534 end;
535 else
536 if S (J) = '\' then
537 J := J + 1;
538 end if;
539
540 Add_In_Map (S (J));
541 end if;
542
543 J := J + 1;
544 end loop;
545
546 -- A close bracket must follow a open_bracket and cannot be
547 -- found alone on the line
548
549 when Close_Bracket =>
550 Raise_Exception
551 ("Incorrect character ']' in regular expression", J);
552
553 when '\' =>
554 if J < S'Last then
555 J := J + 1;
556 Add_In_Map (S (J));
557
558 else
559 -- Back slash \ not allowed at the end of the regexp
560
561 Raise_Exception
562 ("Incorrect character '\' in regular expression", J);
563 end if;
564
565 when Open_Paren =>
566 if not Glob then
567 Parenthesis_Level := Parenthesis_Level + 1;
568 Last_Open := J;
569 else
570 Add_In_Map (Open_Paren);
571 end if;
572
573 when Close_Paren =>
574 if not Glob then
575 Parenthesis_Level := Parenthesis_Level - 1;
576
577 if Parenthesis_Level < 0 then
578 Raise_Exception
579 ("')' is not associated with '(' in regular "
580 & "expression", J);
581 end if;
582
583 if J = Last_Open + 1 then
584 Raise_Exception
585 ("Empty parenthesis not allowed in regular "
586 & "expression", J);
587 end if;
588
589 else
590 Add_In_Map (Close_Paren);
591 end if;
592
593 when '.' =>
594 if Glob then
595 Add_In_Map ('.');
596 end if;
597
598 when '{' =>
599 if not Glob then
600 Add_In_Map (S (J));
601 else
602 Curly_Level := Curly_Level + 1;
603 end if;
604
605 when '}' =>
606 if not Glob then
607 Add_In_Map (S (J));
608 else
609 Curly_Level := Curly_Level - 1;
610 end if;
611
612 when '*' | '?' =>
613 if not Glob then
614 if J = S'First then
615 Raise_Exception
616 ("'*', '+', '?' and '|' operators cannot be in "
617 & "first position in regular expression", J);
618 end if;
619 end if;
620
621 when '|' | '+' =>
622 if not Glob then
623 if J = S'First then
624
625 -- These operators must apply to a sub-expression,
626 -- and cannot be found at the beginning of the line
627
628 Raise_Exception
629 ("'*', '+', '?' and '|' operators cannot be in "
630 & "first position in regular expression", J);
631 end if;
632
633 else
634 Add_In_Map (S (J));
635 end if;
636
637 when others =>
638 Add_In_Map (S (J));
639 end case;
640
641 J := J + 1;
642 end loop;
643
644 -- A closing parenthesis must follow an open parenthesis
645
646 if Parenthesis_Level /= 0 then
647 Raise_Exception
648 ("'(' must always be associated with a ')'", J);
649 end if;
650
651 if Curly_Level /= 0 then
652 Raise_Exception
653 ("'{' must always be associated with a '}'", J);
654 end if;
655 end Create_Mapping;
656
657 --------------------------
658 -- Create_Primary_Table --
659 --------------------------
660
661 procedure Create_Primary_Table
662 (Table : out Regexp_Array_Access;
663 Num_States : out State_Index;
664 Start_State : out State_Index;
665 End_State : out State_Index)
666 is
667 Empty_Char : constant Column_Index := Alphabet_Size + 1;
668
669 Current_State : State_Index := 0;
670 -- Index of the last created state
671
672 procedure Add_Empty_Char
673 (State : State_Index;
674 To_State : State_Index);
675 -- Add a empty-character transition from State to To_State
676
677 procedure Create_Repetition
678 (Repetition : Character;
679 Start_Prev : State_Index;
680 End_Prev : State_Index;
681 New_Start : out State_Index;
682 New_End : in out State_Index);
683 -- Create the table in case we have a '*', '+' or '?'.
684 -- Start_Prev .. End_Prev should indicate respectively the start and
685 -- end index of the previous expression, to which '*', '+' or '?' is
686 -- applied.
687
688 procedure Create_Simple
689 (Start_Index : Integer;
690 End_Index : Integer;
691 Start_State : out State_Index;
692 End_State : out State_Index);
693 -- Fill the table for the regexp Simple. This is the recursive
694 -- procedure called to handle () expressions If End_State = 0, then
695 -- the call to Create_Simple creates an independent regexp, not a
696 -- concatenation Start_Index .. End_Index is the starting index in
697 -- the string S.
698 --
699 -- Warning: it may look like we are creating too many empty-string
700 -- transitions, but they are needed to get the correct regexp.
701 -- The table is filled as follow ( s means start-state, e means
702 -- end-state) :
703 --
704 -- regexp state_num | a b * empty_string
705 -- ------- ------------------------------
706 -- a 1 (s) | 2 - - -
707 -- 2 (e) | - - - -
708 --
709 -- ab 1 (s) | 2 - - -
710 -- 2 | - - - 3
711 -- 3 | - 4 - -
712 -- 4 (e) | - - - -
713 --
714 -- a|b 1 | 2 - - -
715 -- 2 | - - - 6
716 -- 3 | - 4 - -
717 -- 4 | - - - 6
718 -- 5 (s) | - - - 1,3
719 -- 6 (e) | - - - -
720 --
721 -- a* 1 | 2 - - -
722 -- 2 | - - - 4
723 -- 3 (s) | - - - 1,4
724 -- 4 (e) | - - - 3
725 --
726 -- (a) 1 (s) | 2 - - -
727 -- 2 (e) | - - - -
728 --
729 -- a+ 1 | 2 - - -
730 -- 2 | - - - 4
731 -- 3 (s) | - - - 1
732 -- 4 (e) | - - - 3
733 --
734 -- a? 1 | 2 - - -
735 -- 2 | - - - 4
736 -- 3 (s) | - - - 1,4
737 -- 4 (e) | - - - -
738 --
739 -- . 1 (s) | 2 2 2 -
740 -- 2 (e) | - - - -
741
742 function Next_Sub_Expression
743 (Start_Index : Integer;
744 End_Index : Integer) return Integer;
745 -- Returns the index of the last character of the next sub-expression
746 -- in Simple. Index cannot be greater than End_Index.
747
748 --------------------
749 -- Add_Empty_Char --
750 --------------------
751
752 procedure Add_Empty_Char
753 (State : State_Index;
754 To_State : State_Index)
755 is
756 J : Column_Index := Empty_Char;
757
758 begin
759 while Get (Table, State, J) /= 0 loop
760 J := J + 1;
761 end loop;
762
763 Set (Table, State, J, To_State);
764 end Add_Empty_Char;
765
766 -----------------------
767 -- Create_Repetition --
768 -----------------------
769
770 procedure Create_Repetition
771 (Repetition : Character;
772 Start_Prev : State_Index;
773 End_Prev : State_Index;
774 New_Start : out State_Index;
775 New_End : in out State_Index)
776 is
777 begin
778 New_Start := Current_State + 1;
779
780 if New_End /= 0 then
781 Add_Empty_Char (New_End, New_Start);
782 end if;
783
784 Current_State := Current_State + 2;
785 New_End := Current_State;
786
787 Add_Empty_Char (End_Prev, New_End);
788 Add_Empty_Char (New_Start, Start_Prev);
789
790 if Repetition /= '+' then
791 Add_Empty_Char (New_Start, New_End);
792 end if;
793
794 if Repetition /= '?' then
795 Add_Empty_Char (New_End, New_Start);
796 end if;
797 end Create_Repetition;
798
799 -------------------
800 -- Create_Simple --
801 -------------------
802
803 procedure Create_Simple
804 (Start_Index : Integer;
805 End_Index : Integer;
806 Start_State : out State_Index;
807 End_State : out State_Index)
808 is
809 J : Integer := Start_Index;
810 Last_Start : State_Index := 0;
811
812 begin
813 Start_State := 0;
814 End_State := 0;
815 while J <= End_Index loop
816 case S (J) is
817 when Open_Paren =>
818 declare
819 J_Start : constant Integer := J + 1;
820 Next_Start : State_Index;
821 Next_End : State_Index;
822
823 begin
824 J := Next_Sub_Expression (J, End_Index);
825 Create_Simple (J_Start, J - 1, Next_Start, Next_End);
826
827 if J < End_Index
828 and then (S (J + 1) = '*' or else
829 S (J + 1) = '+' or else
830 S (J + 1) = '?')
831 then
832 J := J + 1;
833 Create_Repetition
834 (S (J),
835 Next_Start,
836 Next_End,
837 Last_Start,
838 End_State);
839
840 else
841 Last_Start := Next_Start;
842
843 if End_State /= 0 then
844 Add_Empty_Char (End_State, Last_Start);
845 end if;
846
847 End_State := Next_End;
848 end if;
849 end;
850
851 when '|' =>
852 declare
853 Start_Prev : constant State_Index := Start_State;
854 End_Prev : constant State_Index := End_State;
855 Start_J : constant Integer := J + 1;
856 Start_Next : State_Index := 0;
857 End_Next : State_Index := 0;
858
859 begin
860 J := Next_Sub_Expression (J, End_Index);
861
862 -- Create a new state for the start of the alternative
863
864 Current_State := Current_State + 1;
865 Last_Start := Current_State;
866 Start_State := Last_Start;
867
868 -- Create the tree for the second part of alternative
869
870 Create_Simple (Start_J, J, Start_Next, End_Next);
871
872 -- Create the end state
873
874 Add_Empty_Char (Last_Start, Start_Next);
875 Add_Empty_Char (Last_Start, Start_Prev);
876 Current_State := Current_State + 1;
877 End_State := Current_State;
878 Add_Empty_Char (End_Prev, End_State);
879 Add_Empty_Char (End_Next, End_State);
880 end;
881
882 when Open_Bracket =>
883 Current_State := Current_State + 1;
884
885 declare
886 Next_State : State_Index := Current_State + 1;
887
888 begin
889 J := J + 1;
890
891 if S (J) = '^' then
892 J := J + 1;
893
894 Next_State := 0;
895
896 for Column in 0 .. Alphabet_Size loop
897 Set (Table, Current_State, Column,
898 Value => Current_State + 1);
899 end loop;
900 end if;
901
902 -- Automatically add the first character
903
904 if S (J) = '-' or else S (J) = ']' then
905 Set (Table, Current_State, Map (S (J)),
906 Value => Next_State);
907 J := J + 1;
908 end if;
909
910 -- Loop till closing bracket found
911
912 loop
913 exit when S (J) = Close_Bracket;
914
915 if S (J) = '-'
916 and then S (J + 1) /= ']'
917 then
918 declare
919 Start : constant Integer := J - 1;
920
921 begin
922 J := J + 1;
923
924 if S (J) = '\' then
925 J := J + 1;
926 end if;
927
928 for Char in S (Start) .. S (J) loop
929 Set (Table, Current_State, Map (Char),
930 Value => Next_State);
931 end loop;
932 end;
933
934 else
935 if S (J) = '\' then
936 J := J + 1;
937 end if;
938
939 Set (Table, Current_State, Map (S (J)),
940 Value => Next_State);
941 end if;
942 J := J + 1;
943 end loop;
944 end;
945
946 Current_State := Current_State + 1;
947
948 -- If the next symbol is a special symbol
949
950 if J < End_Index
951 and then (S (J + 1) = '*' or else
952 S (J + 1) = '+' or else
953 S (J + 1) = '?')
954 then
955 J := J + 1;
956 Create_Repetition
957 (S (J),
958 Current_State - 1,
959 Current_State,
960 Last_Start,
961 End_State);
962
963 else
964 Last_Start := Current_State - 1;
965
966 if End_State /= 0 then
967 Add_Empty_Char (End_State, Last_Start);
968 end if;
969
970 End_State := Current_State;
971 end if;
972
973 when '*' | '+' | '?' | Close_Paren | Close_Bracket =>
974 Raise_Exception
975 ("Incorrect character in regular expression :", J);
976
977 when others =>
978 Current_State := Current_State + 1;
979
980 -- Create the state for the symbol S (J)
981
982 if S (J) = '.' then
983 for K in 0 .. Alphabet_Size loop
984 Set (Table, Current_State, K,
985 Value => Current_State + 1);
986 end loop;
987
988 else
989 if S (J) = '\' then
990 J := J + 1;
991 end if;
992
993 Set (Table, Current_State, Map (S (J)),
994 Value => Current_State + 1);
995 end if;
996
997 Current_State := Current_State + 1;
998
999 -- If the next symbol is a special symbol
1000
1001 if J < End_Index
1002 and then (S (J + 1) = '*' or else
1003 S (J + 1) = '+' or else
1004 S (J + 1) = '?')
1005 then
1006 J := J + 1;
1007 Create_Repetition
1008 (S (J),
1009 Current_State - 1,
1010 Current_State,
1011 Last_Start,
1012 End_State);
1013
1014 else
1015 Last_Start := Current_State - 1;
1016
1017 if End_State /= 0 then
1018 Add_Empty_Char (End_State, Last_Start);
1019 end if;
1020
1021 End_State := Current_State;
1022 end if;
1023
1024 end case;
1025
1026 if Start_State = 0 then
1027 Start_State := Last_Start;
1028 end if;
1029
1030 J := J + 1;
1031 end loop;
1032 end Create_Simple;
1033
1034 -------------------------
1035 -- Next_Sub_Expression --
1036 -------------------------
1037
1038 function Next_Sub_Expression
1039 (Start_Index : Integer;
1040 End_Index : Integer) return Integer
1041 is
1042 J : Integer := Start_Index;
1043 Start_On_Alter : Boolean := False;
1044
1045 begin
1046 if S (J) = '|' then
1047 Start_On_Alter := True;
1048 end if;
1049
1050 loop
1051 exit when J = End_Index;
1052 J := J + 1;
1053
1054 case S (J) is
1055 when '\' =>
1056 J := J + 1;
1057
1058 when Open_Bracket =>
1059 loop
1060 J := J + 1;
1061 exit when S (J) = Close_Bracket;
1062
1063 if S (J) = '\' then
1064 J := J + 1;
1065 end if;
1066 end loop;
1067
1068 when Open_Paren =>
1069 J := Next_Sub_Expression (J, End_Index);
1070
1071 when Close_Paren =>
1072 return J;
1073
1074 when '|' =>
1075 if Start_On_Alter then
1076 return J - 1;
1077 end if;
1078
1079 when others =>
1080 null;
1081 end case;
1082 end loop;
1083
1084 return J;
1085 end Next_Sub_Expression;
1086
1087 -- Start of processing for Create_Primary_Table
1088
1089 begin
1090 Table.all := (others => (others => 0));
1091 Create_Simple (S'First, S'Last, Start_State, End_State);
1092 Num_States := Current_State;
1093 end Create_Primary_Table;
1094
1095 -------------------------------
1096 -- Create_Primary_Table_Glob --
1097 -------------------------------
1098
1099 procedure Create_Primary_Table_Glob
1100 (Table : out Regexp_Array_Access;
1101 Num_States : out State_Index;
1102 Start_State : out State_Index;
1103 End_State : out State_Index)
1104 is
1105 Empty_Char : constant Column_Index := Alphabet_Size + 1;
1106
1107 Current_State : State_Index := 0;
1108 -- Index of the last created state
1109
1110 procedure Add_Empty_Char
1111 (State : State_Index;
1112 To_State : State_Index);
1113 -- Add a empty-character transition from State to To_State
1114
1115 procedure Create_Simple
1116 (Start_Index : Integer;
1117 End_Index : Integer;
1118 Start_State : out State_Index;
1119 End_State : out State_Index);
1120 -- Fill the table for the S (Start_Index .. End_Index).
1121 -- This is the recursive procedure called to handle () expressions
1122
1123 --------------------
1124 -- Add_Empty_Char --
1125 --------------------
1126
1127 procedure Add_Empty_Char
1128 (State : State_Index;
1129 To_State : State_Index)
1130 is
1131 J : Column_Index;
1132
1133 begin
1134 J := Empty_Char;
1135 while Get (Table, State, J) /= 0 loop
1136 J := J + 1;
1137 end loop;
1138
1139 Set (Table, State, J, Value => To_State);
1140 end Add_Empty_Char;
1141
1142 -------------------
1143 -- Create_Simple --
1144 -------------------
1145
1146 procedure Create_Simple
1147 (Start_Index : Integer;
1148 End_Index : Integer;
1149 Start_State : out State_Index;
1150 End_State : out State_Index)
1151 is
1152 J : Integer;
1153 Last_Start : State_Index := 0;
1154
1155 begin
1156 Start_State := 0;
1157 End_State := 0;
1158
1159 J := Start_Index;
1160 while J <= End_Index loop
1161 case S (J) is
1162
1163 when Open_Bracket =>
1164 Current_State := Current_State + 1;
1165
1166 declare
1167 Next_State : State_Index := Current_State + 1;
1168
1169 begin
1170 J := J + 1;
1171
1172 if S (J) = '^' then
1173 J := J + 1;
1174 Next_State := 0;
1175
1176 for Column in 0 .. Alphabet_Size loop
1177 Set (Table, Current_State, Column,
1178 Value => Current_State + 1);
1179 end loop;
1180 end if;
1181
1182 -- Automatically add the first character
1183
1184 if S (J) = '-' or else S (J) = ']' then
1185 Set (Table, Current_State, Map (S (J)),
1186 Value => Current_State);
1187 J := J + 1;
1188 end if;
1189
1190 -- Loop till closing bracket found
1191
1192 loop
1193 exit when S (J) = Close_Bracket;
1194
1195 if S (J) = '-'
1196 and then S (J + 1) /= ']'
1197 then
1198 declare
1199 Start : constant Integer := J - 1;
1200
1201 begin
1202 J := J + 1;
1203
1204 if S (J) = '\' then
1205 J := J + 1;
1206 end if;
1207
1208 for Char in S (Start) .. S (J) loop
1209 Set (Table, Current_State, Map (Char),
1210 Value => Next_State);
1211 end loop;
1212 end;
1213
1214 else
1215 if S (J) = '\' then
1216 J := J + 1;
1217 end if;
1218
1219 Set (Table, Current_State, Map (S (J)),
1220 Value => Next_State);
1221 end if;
1222 J := J + 1;
1223 end loop;
1224 end;
1225
1226 Last_Start := Current_State;
1227 Current_State := Current_State + 1;
1228
1229 if End_State /= 0 then
1230 Add_Empty_Char (End_State, Last_Start);
1231 end if;
1232
1233 End_State := Current_State;
1234
1235 when '{' =>
1236 declare
1237 End_Sub : Integer;
1238 Start_Regexp_Sub : State_Index;
1239 End_Regexp_Sub : State_Index;
1240 Create_Start : State_Index := 0;
1241
1242 Create_End : State_Index := 0;
1243 -- Initialized to avoid junk warning
1244
1245 begin
1246 while S (J) /= '}' loop
1247
1248 -- First step : find sub pattern
1249
1250 End_Sub := J + 1;
1251 while S (End_Sub) /= ','
1252 and then S (End_Sub) /= '}'
1253 loop
1254 End_Sub := End_Sub + 1;
1255 end loop;
1256
1257 -- Second step : create a sub pattern
1258
1259 Create_Simple
1260 (J + 1,
1261 End_Sub - 1,
1262 Start_Regexp_Sub,
1263 End_Regexp_Sub);
1264
1265 J := End_Sub;
1266
1267 -- Third step : create an alternative
1268
1269 if Create_Start = 0 then
1270 Current_State := Current_State + 1;
1271 Create_Start := Current_State;
1272 Add_Empty_Char (Create_Start, Start_Regexp_Sub);
1273 Current_State := Current_State + 1;
1274 Create_End := Current_State;
1275 Add_Empty_Char (End_Regexp_Sub, Create_End);
1276
1277 else
1278 Current_State := Current_State + 1;
1279 Add_Empty_Char (Current_State, Create_Start);
1280 Create_Start := Current_State;
1281 Add_Empty_Char (Create_Start, Start_Regexp_Sub);
1282 Add_Empty_Char (End_Regexp_Sub, Create_End);
1283 end if;
1284 end loop;
1285
1286 if End_State /= 0 then
1287 Add_Empty_Char (End_State, Create_Start);
1288 end if;
1289
1290 End_State := Create_End;
1291 Last_Start := Create_Start;
1292 end;
1293
1294 when '*' =>
1295 Current_State := Current_State + 1;
1296
1297 if End_State /= 0 then
1298 Add_Empty_Char (End_State, Current_State);
1299 end if;
1300
1301 Add_Empty_Char (Current_State, Current_State + 1);
1302 Add_Empty_Char (Current_State, Current_State + 3);
1303 Last_Start := Current_State;
1304
1305 Current_State := Current_State + 1;
1306
1307 for K in 0 .. Alphabet_Size loop
1308 Set (Table, Current_State, K,
1309 Value => Current_State + 1);
1310 end loop;
1311
1312 Current_State := Current_State + 1;
1313 Add_Empty_Char (Current_State, Current_State + 1);
1314
1315 Current_State := Current_State + 1;
1316 Add_Empty_Char (Current_State, Last_Start);
1317 End_State := Current_State;
1318
1319 when others =>
1320 Current_State := Current_State + 1;
1321
1322 if S (J) = '?' then
1323 for K in 0 .. Alphabet_Size loop
1324 Set (Table, Current_State, K,
1325 Value => Current_State + 1);
1326 end loop;
1327
1328 else
1329 if S (J) = '\' then
1330 J := J + 1;
1331 end if;
1332
1333 -- Create the state for the symbol S (J)
1334
1335 Set (Table, Current_State, Map (S (J)),
1336 Value => Current_State + 1);
1337 end if;
1338
1339 Last_Start := Current_State;
1340 Current_State := Current_State + 1;
1341
1342 if End_State /= 0 then
1343 Add_Empty_Char (End_State, Last_Start);
1344 end if;
1345
1346 End_State := Current_State;
1347
1348 end case;
1349
1350 if Start_State = 0 then
1351 Start_State := Last_Start;
1352 end if;
1353
1354 J := J + 1;
1355 end loop;
1356 end Create_Simple;
1357
1358 -- Start of processing for Create_Primary_Table_Glob
1359
1360 begin
1361 Table.all := (others => (others => 0));
1362 Create_Simple (S'First, S'Last, Start_State, End_State);
1363 Num_States := Current_State;
1364 end Create_Primary_Table_Glob;
1365
1366 ----------------------------
1367 -- Create_Secondary_Table --
1368 ----------------------------
1369
1370 function Create_Secondary_Table
1371 (First_Table : Regexp_Array_Access;
1372 Start_State : State_Index;
1373 End_State : State_Index) return Regexp
1374 is
1375 Last_Index : constant State_Index := First_Table'Last (1);
1376
1377 type Meta_State is array (0 .. Last_Index) of Boolean;
1378 pragma Pack (Meta_State);
1379 -- Whether a state from first_table belongs to a metastate.
1380
1381 No_States : constant Meta_State := (others => False);
1382
1383 type Meta_States_Array is array (State_Index range <>) of Meta_State;
1384 type Meta_States_List is access all Meta_States_Array;
1385 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1386 (Meta_States_Array, Meta_States_List);
1387 Meta_States : Meta_States_List;
1388 -- Components of meta-states. A given state might belong to
1389 -- several meta-states.
1390 -- This array grows dynamically.
1391
1392 type Char_To_State is array (0 .. Alphabet_Size) of State_Index;
1393 type Meta_States_Transition_Arr is
1394 array (State_Index range <>) of Char_To_State;
1395 type Meta_States_Transition is access all Meta_States_Transition_Arr;
1396 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1397 (Meta_States_Transition_Arr, Meta_States_Transition);
1398 Table : Meta_States_Transition;
1399 -- Documents the transitions between each meta-state. The
1400 -- first index is the meta-state, the second column is the
1401 -- character seen in the input, the value is the new meta-state.
1402
1403 Temp_State_Not_Null : Boolean;
1404
1405 Current_State : State_Index := 1;
1406 -- The current meta-state we are creating
1407
1408 Nb_State : State_Index := 1;
1409 -- The total number of meta-states created so far.
1410
1411 procedure Closure
1412 (Meta_State : State_Index;
1413 State : State_Index);
1414 -- Compute the closure of the state (that is every other state which
1415 -- has a empty-character transition) and add it to the state
1416
1417 procedure Ensure_Meta_State (Meta : State_Index);
1418 -- grows the Meta_States array as needed to make sure that there
1419 -- is enough space to store the new meta state.
1420
1421 -----------------------
1422 -- Ensure_Meta_State --
1423 -----------------------
1424
1425 procedure Ensure_Meta_State (Meta : State_Index) is
1426 Tmp : Meta_States_List := Meta_States;
1427 Tmp2 : Meta_States_Transition := Table;
1428
1429 begin
1430 if Meta_States = null then
1431 Meta_States := new Meta_States_Array
1432 (1 .. State_Index'Max (Last_Index, Meta) + 1);
1433 Meta_States (Meta_States'Range) := (others => No_States);
1434
1435 Table := new Meta_States_Transition_Arr
1436 (1 .. State_Index'Max (Last_Index, Meta) + 1);
1437 Table.all := (others => (others => 0));
1438
1439 elsif Meta > Meta_States'Last then
1440 Meta_States := new Meta_States_Array
1441 (1 .. State_Index'Max (2 * Tmp'Last, Meta));
1442 Meta_States (Tmp'Range) := Tmp.all;
1443 Meta_States (Tmp'Last + 1 .. Meta_States'Last) :=
1444 (others => No_States);
1445 Unchecked_Free (Tmp);
1446
1447 Table := new Meta_States_Transition_Arr
1448 (1 .. State_Index'Max (2 * Tmp2'Last, Meta) + 1);
1449 Table (Tmp2'Range) := Tmp2.all;
1450 Table (Tmp2'Last + 1 .. Table'Last) :=
1451 (others => (others => 0));
1452 Unchecked_Free (Tmp2);
1453 end if;
1454 end Ensure_Meta_State;
1455
1456 -------------
1457 -- Closure --
1458 -------------
1459
1460 procedure Closure
1461 (Meta_State : State_Index;
1462 State : State_Index)
1463 is
1464 begin
1465 if not Meta_States (Meta_State)(State) then
1466 Meta_States (Meta_State)(State) := True;
1467
1468 -- For each transition on empty-character
1469
1470 for Column in Alphabet_Size + 1 .. First_Table'Last (2) loop
1471 exit when First_Table (State, Column) = 0;
1472 Closure (Meta_State, First_Table (State, Column));
1473 end loop;
1474 end if;
1475 end Closure;
1476
1477 -- Start of processing for Create_Secondary_Table
1478
1479 begin
1480 -- Create a new state
1481
1482 Ensure_Meta_State (Current_State);
1483 Closure (Current_State, Start_State);
1484
1485 while Current_State <= Nb_State loop
1486
1487 -- We will be trying, below, to create the next meta-state
1488
1489 Ensure_Meta_State (Nb_State + 1);
1490
1491 -- For every character in the regexp, calculate the possible
1492 -- transitions from Current_State.
1493
1494 for Column in 0 .. Alphabet_Size loop
1495 Temp_State_Not_Null := False;
1496
1497 for K in Meta_States (Current_State)'Range loop
1498 if Meta_States (Current_State)(K)
1499 and then First_Table (K, Column) /= 0
1500 then
1501 Closure (Nb_State + 1, First_Table (K, Column));
1502 Temp_State_Not_Null := True;
1503 end if;
1504 end loop;
1505
1506 -- If at least one transition existed
1507
1508 if Temp_State_Not_Null then
1509
1510 -- Check if this new state corresponds to an old one
1511
1512 for K in 1 .. Nb_State loop
1513 if Meta_States (K) = Meta_States (Nb_State + 1) then
1514 Table (Current_State)(Column) := K;
1515
1516 -- Reset data, for the next time we try that state
1517
1518 Meta_States (Nb_State + 1) := No_States;
1519 exit;
1520 end if;
1521 end loop;
1522
1523 -- If not, create a new state
1524
1525 if Table (Current_State)(Column) = 0 then
1526 Nb_State := Nb_State + 1;
1527 Ensure_Meta_State (Nb_State + 1);
1528 Table (Current_State)(Column) := Nb_State;
1529 end if;
1530 end if;
1531 end loop;
1532
1533 Current_State := Current_State + 1;
1534 end loop;
1535
1536 -- Returns the regexp
1537
1538 declare
1539 R : Regexp_Access;
1540
1541 begin
1542 R := new Regexp_Value (Alphabet_Size => Alphabet_Size,
1543 Num_States => Nb_State);
1544 R.Map := Map;
1545 R.Case_Sensitive := Case_Sensitive;
1546
1547 for S in 1 .. Nb_State loop
1548 R.Is_Final (S) := Meta_States (S)(End_State);
1549 end loop;
1550
1551 for State in 1 .. Nb_State loop
1552 for K in 0 .. Alphabet_Size loop
1553 R.States (State, K) := Table (State)(K);
1554 end loop;
1555 end loop;
1556
1557 Unchecked_Free (Meta_States);
1558 Unchecked_Free (Table);
1559
1560 return (Ada.Finalization.Controlled with R => R);
1561 end;
1562 end Create_Secondary_Table;
1563
1564 ---------------------
1565 -- Raise_Exception --
1566 ---------------------
1567
1568 procedure Raise_Exception (M : String; Index : Integer) is
1569 begin
1570 raise Error_In_Regexp with M & " at offset" & Index'Img;
1571 end Raise_Exception;
1572
1573 -- Start of processing for Compile
1574
1575 begin
1576 -- Special case for the empty string: it always matches, and the
1577 -- following processing would fail on it.
1578
1579 if S = "" then
1580 return (Ada.Finalization.Controlled with
1581 R => new Regexp_Value'
1582 (Alphabet_Size => 0,
1583 Num_States => 1,
1584 Map => (others => 0),
1585 States => (others => (others => 1)),
1586 Is_Final => (others => True),
1587 Case_Sensitive => True));
1588 end if;
1589
1590 if not Case_Sensitive then
1591 System.Case_Util.To_Lower (S);
1592 end if;
1593
1594 -- Check the pattern is well-formed before any treatment
1595
1596 Check_Well_Formed_Pattern;
1597
1598 Create_Mapping;
1599
1600 -- Creates the primary table
1601
1602 declare
1603 Table : Regexp_Array_Access;
1604 Num_States : State_Index;
1605 Start_State : State_Index;
1606 End_State : State_Index;
1607 R : Regexp;
1608
1609 begin
1610 Table := new Regexp_Array (1 .. Initial_Max_States_In_Primary_Table,
1611 0 .. Alphabet_Size + 10);
1612 if not Glob then
1613 Create_Primary_Table (Table, Num_States, Start_State, End_State);
1614 else
1615 Create_Primary_Table_Glob
1616 (Table, Num_States, Start_State, End_State);
1617 end if;
1618
1619 -- Creates the secondary table
1620
1621 R := Create_Secondary_Table (Table, Start_State, End_State);
1622 Free (Table);
1623 return R;
1624 end;
1625 end Compile;
1626
1627 --------------
1628 -- Finalize --
1629 --------------
1630
1631 procedure Finalize (R : in out Regexp) is
1632 procedure Free is new
1633 Ada.Unchecked_Deallocation (Regexp_Value, Regexp_Access);
1634 begin
1635 Free (R.R);
1636 end Finalize;
1637
1638 ---------
1639 -- Get --
1640 ---------
1641
1642 function Get
1643 (Table : Regexp_Array_Access;
1644 State : State_Index;
1645 Column : Column_Index) return State_Index
1646 is
1647 begin
1648 if State <= Table'Last (1)
1649 and then Column <= Table'Last (2)
1650 then
1651 return Table (State, Column);
1652 else
1653 return 0;
1654 end if;
1655 end Get;
1656
1657 -----------
1658 -- Match --
1659 -----------
1660
1661 function Match (S : String; R : Regexp) return Boolean is
1662 Current_State : State_Index := 1;
1663
1664 begin
1665 if R.R = null then
1666 raise Constraint_Error;
1667 end if;
1668
1669 for Char in S'Range loop
1670
1671 if R.R.Case_Sensitive then
1672 Current_State := R.R.States (Current_State, R.R.Map (S (Char)));
1673 else
1674 Current_State :=
1675 R.R.States (Current_State,
1676 R.R.Map (System.Case_Util.To_Lower (S (Char))));
1677 end if;
1678
1679 if Current_State = 0 then
1680 return False;
1681 end if;
1682
1683 end loop;
1684
1685 return R.R.Is_Final (Current_State);
1686 end Match;
1687
1688 ---------
1689 -- Set --
1690 ---------
1691
1692 procedure Set
1693 (Table : in out Regexp_Array_Access;
1694 State : State_Index;
1695 Column : Column_Index;
1696 Value : State_Index)
1697 is
1698 New_Lines : State_Index;
1699 New_Columns : Column_Index;
1700 New_Table : Regexp_Array_Access;
1701
1702 begin
1703 if State <= Table'Last (1)
1704 and then Column <= Table'Last (2)
1705 then
1706 Table (State, Column) := Value;
1707 else
1708 -- Doubles the size of the table until it is big enough that
1709 -- (State, Column) is a valid index.
1710
1711 New_Lines := Table'Last (1) * (State / Table'Last (1) + 1);
1712 New_Columns := Table'Last (2) * (Column / Table'Last (2) + 1);
1713 New_Table := new Regexp_Array (Table'First (1) .. New_Lines,
1714 Table'First (2) .. New_Columns);
1715 New_Table.all := (others => (others => 0));
1716
1717 for J in Table'Range (1) loop
1718 for K in Table'Range (2) loop
1719 New_Table (J, K) := Table (J, K);
1720 end loop;
1721 end loop;
1722
1723 Free (Table);
1724 Table := New_Table;
1725 Table (State, Column) := Value;
1726 end if;
1727 end Set;
1728
1729 end System.Regexp;