-- B o d y --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1999-2009, AdaCore --
+-- Copyright (C) 1999-2010, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
package body System.Regpat is
+ Debug : constant Boolean := False;
+ -- Set to True to activate debug traces
+
MAGIC : constant Character := Character'Val (10#0234#);
-- The first byte of the regexp internal "program" is actually
-- this magic number; the start node begins in the second byte.
Worst_Expression : constant Expression_Flags := (others => False);
-- Worst case
+ procedure Dump_Until
+ (Program : Program_Data;
+ Index : in out Pointer;
+ Till : Pointer;
+ Indent : Natural;
+ Do_Print : Boolean := True);
+ -- Dump the program until the node Till (not included) is met.
+ -- Every line is indented with Index spaces at the beginning
+ -- Dumps till the end if Till is 0.
+
+ procedure Dump_Operation
+ (Program : Program_Data;
+ Index : Pointer;
+ Indent : Natural);
+ -- Same as above, but only dumps a single operation, and compute its
+ -- indentation from the program
+
---------
-- "=" --
---------
Compile (Matcher, Expression, Size, Flags);
end Compile;
- ----------
- -- Dump --
- ----------
-
- procedure Dump (Self : Pattern_Matcher) is
- Op : Opcode;
- Program : Program_Data renames Self.Program;
-
- procedure Dump_Until
- (Start : Pointer;
- Till : Pointer;
- Indent : Natural := 0);
- -- Dump the program until the node Till (not included) is met.
- -- Every line is indented with Index spaces at the beginning
- -- Dumps till the end if Till is 0.
-
- ----------------
- -- Dump_Until --
- ----------------
+ --------------------
+ -- Dump_Operation --
+ --------------------
- procedure Dump_Until
- (Start : Pointer;
- Till : Pointer;
- Indent : Natural := 0)
- is
- Next : Pointer;
- Index : Pointer;
- Local_Indent : Natural := Indent;
- Length : Pointer;
+ procedure Dump_Operation
+ (Program : Program_Data;
+ Index : Pointer;
+ Indent : Natural)
+ is
+ Current : Pointer := Index;
+ begin
+ Dump_Until (Program, Current, Current + 1, Indent);
+ end Dump_Operation;
+
+ ----------------
+ -- Dump_Until --
+ ----------------
+
+ procedure Dump_Until
+ (Program : Program_Data;
+ Index : in out Pointer;
+ Till : Pointer;
+ Indent : Natural;
+ Do_Print : Boolean := True)
+ is
+ function Image (S : String) return String;
+ -- Remove leading space
+ function Image (S : String) return String is
begin
- Index := Start;
- while Index < Till loop
- Op := Opcode'Val (Character'Pos ((Self.Program (Index))));
+ if S (S'First) = ' ' then
+ return S (S'First + 1 .. S'Last);
+ else
+ return S;
+ end if;
+ end Image;
- if Op = CLOSE then
- Local_Indent := Local_Indent - 3;
- end if;
+ Op : Opcode;
+ Next : Pointer;
+ Length : Pointer;
+ Local_Indent : Natural := Indent;
- declare
- Point : constant String := Pointer'Image (Index);
+ begin
+ while Index < Till loop
+ Op := Opcode'Val (Character'Pos ((Program (Index))));
+ Next := Index + Get_Next_Offset (Program, Index);
+ if Do_Print then
+ declare
+ Point : constant String := Pointer'Image (Index);
begin
- for J in 1 .. 6 - Point'Length loop
- Put (' ');
- end loop;
-
- Put (Point
- & " : "
- & (1 .. Local_Indent => ' ')
- & Opcode'Image (Op));
+ Put ((1 .. 4 - Point'Length => ' ')
+ & Point & ":"
+ & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op));
end;
-- Print the parenthesis number
if Op = OPEN or else Op = CLOSE or else Op = REFF then
- Put (Natural'Image (Character'Pos (Program (Index + 3))));
+ Put
+ (Image (Natural'Image (Character'Pos (Program (Index + 3)))));
end if;
- Next := Index + Get_Next_Offset (Program, Index);
-
if Next = Index then
- Put (" (next at 0)");
+ Put (" (-)");
else
- Put (" (next at " & Pointer'Image (Next) & ")");
+ Put (" (" & Image (Pointer'Image (Next)) & ")");
end if;
+ end if;
- case Op is
-
- -- Character class operand
-
- when ANYOF => null;
- declare
- Bitmap : Character_Class;
- Last : Character := ASCII.NUL;
- Current : Natural := 0;
+ case Op is
+ when ANYOF =>
+ declare
+ Bitmap : Character_Class;
+ Last : Character := ASCII.NUL;
+ Current : Natural := 0;
+ Current_Char : Character;
- Current_Char : Character;
+ begin
+ Bitmap_Operand (Program, Index, Bitmap);
- begin
- Bitmap_Operand (Program, Index, Bitmap);
- Put (" operand=");
+ if Do_Print then
+ Put ("[");
while Current <= 255 loop
Current_Char := Character'Val (Current);
Current_Char := Character'Val (Current);
exit when
not Get_From_Class (Bitmap, Current_Char);
-
end loop;
- if Last <= ' ' then
+ if not Is_Graphic (Last) then
Put (Last'Img);
else
Put (Last);
end if;
if Character'Succ (Last) /= Current_Char then
- Put ("-" & Character'Pred (Current_Char));
+ Put ("\-" & Character'Pred (Current_Char));
end if;
else
end if;
end loop;
- New_Line;
- Index := Index + 3 + Bitmap'Length;
- end;
+ Put_Line ("]");
+ end if;
- -- string operand
+ Index := Index + 3 + Bitmap'Length;
+ end;
- when EXACT | EXACTF =>
- Length := String_Length (Program, Index);
- Put (" operand (length:" & Program_Size'Image (Length + 1)
- & ") ="
- & String (Program (String_Operand (Index)
- .. String_Operand (Index)
- + Length)));
- Index := String_Operand (Index) + Length + 1;
- New_Line;
+ when EXACT | EXACTF =>
+ Length := String_Length (Program, Index);
+ if Do_Print then
+ Put (" (" & Image (Program_Size'Image (Length + 1))
+ & " chars) <"
+ & String (Program (String_Operand (Index)
+ .. String_Operand (Index)
+ + Length)));
+ Put_Line (">");
+ end if;
- -- Node operand
+ Index := String_Operand (Index) + Length + 1;
- when BRANCH =>
- New_Line;
- Dump_Until (Index + 3, Next, Local_Indent + 3);
- Index := Next;
+ -- Node operand
- when STAR | PLUS =>
+ when BRANCH | STAR | PLUS =>
+ if Do_Print then
New_Line;
+ end if;
- -- Only one instruction
+ Index := Index + 3;
+ Dump_Until (Program, Index, Pointer'Min (Next, Till),
+ Local_Indent + 1, Do_Print);
+
+ when CURLY | CURLYX =>
+ if Do_Print then
+ Put_Line
+ (" {"
+ & Image (Natural'Image (Read_Natural (Program, Index + 3)))
+ & ","
+ & Image (Natural'Image (Read_Natural (Program, Index + 5)))
+ & "}");
+ end if;
- Dump_Until (Index + 3, Index + 4, Local_Indent + 3);
- Index := Next;
+ Index := Index + 7;
+ Dump_Until (Program, Index, Pointer'Min (Next, Till),
+ Local_Indent + 1, Do_Print);
- when CURLY | CURLYX =>
- Put (" {"
- & Natural'Image (Read_Natural (Program, Index + 3))
- & ","
- & Natural'Image (Read_Natural (Program, Index + 5))
- & "}");
+ when OPEN =>
+ if Do_Print then
New_Line;
- Dump_Until (Index + 7, Next, Local_Indent + 3);
- Index := Next;
+ end if;
- when OPEN =>
- New_Line;
- Index := Index + 4;
- Local_Indent := Local_Indent + 3;
+ Index := Index + 4;
+ Local_Indent := Local_Indent + 1;
- when CLOSE | REFF =>
+ when CLOSE | REFF =>
+ if Do_Print then
New_Line;
- Index := Index + 4;
+ end if;
- when EOP =>
- Index := Index + 3;
- New_Line;
- exit;
+ Index := Index + 4;
- -- No operand
+ if Op = CLOSE then
+ Local_Indent := Local_Indent - 1;
+ end if;
- when others =>
- Index := Index + 3;
+ when others =>
+ Index := Index + 3;
+
+ if Do_Print then
New_Line;
- end case;
- end loop;
- end Dump_Until;
+ end if;
+
+ exit when Op = EOP;
+ end case;
+ end loop;
+ end Dump_Until;
+
+ ----------
+ -- Dump --
+ ----------
+
+ procedure Dump (Self : Pattern_Matcher) is
+ Program : Program_Data renames Self.Program;
+ Index : Pointer := Program'First + 1;
-- Start of processing for Dump
Put_Line (" Multiple_Lines mode");
end if;
- Put_Line (" 1 : MAGIC");
- Dump_Until (Program_First + 1, Self.Program'Last + 1);
+ Put_Line (" 1:MAGIC");
+ Dump_Until (Program, Index, Self.Program'Last + 1, 0);
end Dump;
--------------------
-- using a loop instead of recursion.
-- Why is the above comment part of the spec rather than body ???
- function Match_Whilem (IP : Pointer) return Boolean;
- -- Return True if a WHILEM matches
- -- How come IP is unreferenced in the body ???
+ function Match_Whilem return Boolean;
+ -- Return True if a WHILEM matches the Current_Curly
function Recurse_Match (IP : Pointer; From : Natural) return Boolean;
pragma Inline (Recurse_Match);
Greedy : Boolean) return Boolean;
-- Return True it the simple operator (possibly non-greedy) matches
+ Dump_Indent : Integer := -1;
+ procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True);
+ procedure Dump_Error (Msg : String);
+ -- Debug: print the current context
+
pragma Inline (Index);
pragma Inline (Repeat);
function Recurse_Match (IP : Pointer; From : Natural) return Boolean is
L : constant Natural := Last_Paren;
-
Tmp_F : constant Match_Array :=
Matches_Full (From + 1 .. Matches_Full'Last);
-
Start : constant Natural_Array :=
Matches_Tmp (From + 1 .. Matches_Tmp'Last);
Input : constant Natural := Input_Pos;
+ Dump_Indent_Save : constant Integer := Dump_Indent;
begin
if Match (IP) then
Matches_Full (Tmp_F'Range) := Tmp_F;
Matches_Tmp (Start'Range) := Start;
Input_Pos := Input;
+ Dump_Indent := Dump_Indent_Save;
return False;
end Recurse_Match;
+ ------------------
+ -- Dump_Current --
+ ------------------
+
+ procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is
+ Length : constant := 10;
+ Pos : constant String := Integer'Image (Input_Pos);
+ begin
+ if Prefix then
+ Put ((1 .. 5 - Pos'Length => ' '));
+ Put (Pos & " <"
+ & Data (Input_Pos
+ .. Integer'Min (Last_In_Data, Input_Pos + Length - 1)));
+ Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' '));
+ Put ("> |");
+ else
+ Put (" ");
+ end if;
+ Dump_Operation (Program, Scan, Indent => Dump_Indent);
+ end Dump_Current;
+
+ ----------------
+ -- Dump_Error --
+ ----------------
+
+ procedure Dump_Error (Msg : String) is
+ begin
+ Put (" | ");
+ Put ((1 .. Dump_Indent * 2 => ' '));
+ Put_Line (Msg);
+ end Dump_Error;
+
-----------
-- Match --
-----------
Scan : Pointer := IP;
Next : Pointer;
Op : Opcode;
+ Result : Boolean;
begin
+ Dump_Indent := Dump_Indent + 1;
+
State_Machine :
loop
pragma Assert (Scan /= 0);
Next := Get_Next (Program, Scan);
+ if Debug then
+ Dump_Current (Scan);
+ end if;
+
case Op is
when EOP =>
+ Dump_Indent := Dump_Indent - 1;
return True; -- Success !
when BRANCH =>
else
loop
if Recurse_Match (Operand (Scan), 0) then
+ Dump_Indent := Dump_Indent - 1;
return True;
end if;
when BOL =>
exit State_Machine when Input_Pos /= BOL_Pos
and then ((Self.Flags and Multiple_Lines) = 0
- or else Data (Input_Pos - 1) /= ASCII.LF);
+ or else Data (Input_Pos - 1) /= ASCII.LF);
when MBOL =>
exit State_Machine when Input_Pos /= BOL_Pos
-- If we haven't seen that parenthesis yet
if Last_Paren < No then
+ Dump_Indent := Dump_Indent - 1;
+ if Debug then
+ Dump_Error ("REFF: No match, backtracking");
+ end if;
return False;
end if;
if Input_Pos > Last_In_Data
or else Data (Input_Pos) /= Data (Data_Pos)
then
+ Dump_Indent := Dump_Indent - 1;
+ if Debug then
+ Dump_Error ("REFF: No match, backtracking");
+ end if;
return False;
end if;
Greed : constant Boolean := Greedy;
begin
Greedy := True;
- return Match_Simple_Operator (Op, Scan, Next, Greed);
+ Result := Match_Simple_Operator (Op, Scan, Next, Greed);
+ Dump_Indent := Dump_Indent - 1;
+ return Result;
end;
when CURLYX =>
Next => Next,
Lastloc => 0,
Old_Cc => Current_Curly);
+ Greedy := True;
Current_Curly := Cc'Unchecked_Access;
Has_Match := Match (Next - 3);
-- Start on the WHILEM
Current_Curly := Cc.Old_Cc;
+ Dump_Indent := Dump_Indent - 1;
+ if not Has_Match then
+ if Debug then
+ Dump_Error ("CURLYX failed...");
+ end if;
+ end if;
return Has_Match;
end;
when WHILEM =>
- return Match_Whilem (IP);
+ Result := Match_Whilem;
+ Dump_Indent := Dump_Indent - 1;
+ if Debug and then not Result then
+ Dump_Error ("WHILEM: no match, backtracking");
+ end if;
+ return Result;
end case;
Scan := Next;
end loop State_Machine;
+ if Debug then
+ Dump_Error ("failed...");
+ Dump_Indent := Dump_Indent - 1;
+ end if;
+
-- If we get here, there is no match.
-- For successful matches when EOP is the terminating point.
Operand_Code := Scan + 7;
end case;
+ if Debug then
+ Dump_Current (Operand_Code, Prefix => False);
+ end if;
+
-- Non greedy operators
if not Greedy then
- -- Test the minimal repetitions
+ -- Test we can repeat at least Min times
- if Min /= 0
- and then Repeat (Operand_Code, Min) < Min
- then
- return False;
+ if Min /= 0 then
+ No := Repeat (Operand_Code, Min);
+ if No < Min then
+ if Debug then
+ Dump_Error ("failed... matched" & No'Img & " times");
+ end if;
+ return False;
+ end if;
end if;
Old := Input_Pos;
-- Look for the first possible opportunity
+ if Debug then
+ Dump_Error ("Next_Char must be " & Next_Char);
+ end if;
+
loop
-- Find the next possible position
begin
Input_Pos := Old;
+ if Debug then
+ Dump_Error ("Would we still match at that position?");
+ end if;
+
if Repeat (Operand_Code, Num) < Num then
return False;
end if;
Input_Pos := Input_Pos + 1;
end loop;
- -- We know what the next character is
+ -- We do not know what the next character is
else
while Max >= Min loop
+ if Debug then
+ Dump_Error ("Non-greedy repeat, N=" & Min'Img);
+ Dump_Error ("Do we still match Next if we stop here?");
+ end if;
-- If the next character matches
- if Match (Next) then
+ if Recurse_Match (Next, 1) then
return True;
end if;
if Repeat (Operand_Code, 1) /= 0 then
Min := Min + 1;
else
+ if Debug then
+ Dump_Error ("Non-greedy repeat failed...");
+ end if;
return False;
end if;
end loop;
else
No := Repeat (Operand_Code, Max);
+ if Debug and then No < Min then
+ Dump_Error ("failed... matched" & No'Img & " times");
+ end if;
+
-- ??? Perl has some special code here in case the
-- next instruction is of type EOL, since $ and \Z
-- can match before *and* after newline at the end.
-- tree by recursing ever deeper. And if it fails, we have to reset
-- our parent's current state that we can try again after backing off.
- function Match_Whilem (IP : Pointer) return Boolean is
- pragma Unreferenced (IP);
-
+ function Match_Whilem return Boolean is
Cc : constant Current_Curly_Access := Current_Curly;
N : constant Natural := Cc.Cur + 1;
Ln : Natural := 0;
Cc.Cur := N;
Cc.Lastloc := Input_Pos;
+ if Debug then
+ Dump_Error
+ ("Tests that we match at least" & Cc.Min'Img & " N=" & N'Img);
+ end if;
+
if Match (Cc.Scan) then
return True;
end if;
Cc.Cur := N - 1;
Cc.Lastloc := Lastloc;
+
+ if Debug then
+ Dump_Error ("failed...");
+ end if;
+
return False;
end if;
-- Maximum greed exceeded ?
if N >= Cc.Max then
+ if Debug then
+ Dump_Error ("failed...");
+ end if;
return False;
end if;
Cc.Cur := N;
Cc.Lastloc := Input_Pos;
+ if Debug then
+ Dump_Error ("Next failed, what about Current?");
+ end if;
+
if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
return True;
end if;
Cc.Cur := N;
Cc.Lastloc := Input_Pos;
+ if Debug then
+ Dump_Error ("Recurse at current position");
+ end if;
+
if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then
return True;
end if;
Ln := Current_Curly.Cur;
end if;
+ if Debug then
+ Dump_Error ("Failed matching for later positions");
+ end if;
+
if Match (Cc.Next) then
return True;
end if;
Current_Curly := Cc;
Cc.Cur := N - 1;
Cc.Lastloc := Lastloc;
+
+ if Debug then
+ Dump_Error ("failed...");
+ end if;
+
return False;
end Match_Whilem;
projects / thirdparty / gcc.git / commitdiff
