with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
with System; use System;
with Unchecked_Conversion;
with Unchecked_Deallocation;
package body GNAT.Spitbol.Patterns is
Internal_Debug : constant Boolean := False;
procedure New_LineD;
pragma Inline (New_LineD);
procedure PutD (Str : String);
pragma Inline (PutD);
procedure Put_LineD (Str : String);
pragma Inline (Put_LineD);
subtype String_Ptr is Ada.Strings.Unbounded.String_Access;
subtype File_Ptr is Ada.Text_IO.File_Access;
function To_Address is new Unchecked_Conversion (PE_Ptr, Address);
subtype AFC is Ada.Finalization.Controlled;
N : constant PE_Ptr := null;
type Natural_Ptr is access all Natural;
type Pattern_Ptr is access all Pattern;
type Pattern_Code is (
PC_Arb_Y,
PC_Assign,
PC_Bal,
PC_BreakX_X,
PC_Cancel,
PC_EOP,
PC_Fail,
PC_Fence,
PC_Fence_X,
PC_Fence_Y,
PC_R_Enter,
PC_R_Remove,
PC_R_Restore,
PC_Rest,
PC_Succeed,
PC_Unanchored,
PC_Alt,
PC_Arb_X,
PC_Arbno_S,
PC_Arbno_X,
PC_Rpat,
PC_Pred_Func,
PC_Assign_Imm,
PC_Assign_OnM,
PC_Any_VP,
PC_Break_VP,
PC_BreakX_VP,
PC_NotAny_VP,
PC_NSpan_VP,
PC_Span_VP,
PC_String_VP,
PC_Write_Imm,
PC_Write_OnM,
PC_Null,
PC_String,
PC_String_2,
PC_String_3,
PC_String_4,
PC_String_5,
PC_String_6,
PC_Setcur,
PC_Any_CH,
PC_Break_CH,
PC_BreakX_CH,
PC_Char,
PC_NotAny_CH,
PC_NSpan_CH,
PC_Span_CH,
PC_Any_CS,
PC_Break_CS,
PC_BreakX_CS,
PC_NotAny_CS,
PC_NSpan_CS,
PC_Span_CS,
PC_Arbno_Y,
PC_Len_Nat,
PC_Pos_Nat,
PC_RPos_Nat,
PC_RTab_Nat,
PC_Tab_Nat,
PC_Pos_NF,
PC_Len_NF,
PC_RPos_NF,
PC_RTab_NF,
PC_Tab_NF,
PC_Pos_NP,
PC_Len_NP,
PC_RPos_NP,
PC_RTab_NP,
PC_Tab_NP,
PC_Any_VF,
PC_Break_VF,
PC_BreakX_VF,
PC_NotAny_VF,
PC_NSpan_VF,
PC_Span_VF,
PC_String_VF);
type IndexT is range 0 .. +(2 **15 - 1);
type PE (Pcode : Pattern_Code) is record
Index : IndexT;
Pthen : PE_Ptr;
case Pcode is
when PC_Arb_Y |
PC_Assign |
PC_Bal |
PC_BreakX_X |
PC_Cancel |
PC_EOP |
PC_Fail |
PC_Fence |
PC_Fence_X |
PC_Fence_Y |
PC_Null |
PC_R_Enter |
PC_R_Remove |
PC_R_Restore |
PC_Rest |
PC_Succeed |
PC_Unanchored => null;
when PC_Alt |
PC_Arb_X |
PC_Arbno_S |
PC_Arbno_X => Alt : PE_Ptr;
when PC_Rpat => PP : Pattern_Ptr;
when PC_Pred_Func => BF : Boolean_Func;
when PC_Assign_Imm |
PC_Assign_OnM |
PC_Any_VP |
PC_Break_VP |
PC_BreakX_VP |
PC_NotAny_VP |
PC_NSpan_VP |
PC_Span_VP |
PC_String_VP => VP : VString_Ptr;
when PC_Write_Imm |
PC_Write_OnM => FP : File_Ptr;
when PC_String => Str : String_Ptr;
when PC_String_2 => Str2 : String (1 .. 2);
when PC_String_3 => Str3 : String (1 .. 3);
when PC_String_4 => Str4 : String (1 .. 4);
when PC_String_5 => Str5 : String (1 .. 5);
when PC_String_6 => Str6 : String (1 .. 6);
when PC_Setcur => Var : Natural_Ptr;
when PC_Any_CH |
PC_Break_CH |
PC_BreakX_CH |
PC_Char |
PC_NotAny_CH |
PC_NSpan_CH |
PC_Span_CH => Char : Character;
when PC_Any_CS |
PC_Break_CS |
PC_BreakX_CS |
PC_NotAny_CS |
PC_NSpan_CS |
PC_Span_CS => CS : Character_Set;
when PC_Arbno_Y |
PC_Len_Nat |
PC_Pos_Nat |
PC_RPos_Nat |
PC_RTab_Nat |
PC_Tab_Nat => Nat : Natural;
when PC_Pos_NF |
PC_Len_NF |
PC_RPos_NF |
PC_RTab_NF |
PC_Tab_NF => NF : Natural_Func;
when PC_Pos_NP |
PC_Len_NP |
PC_RPos_NP |
PC_RTab_NP |
PC_Tab_NP => NP : Natural_Ptr;
when PC_Any_VF |
PC_Break_VF |
PC_BreakX_VF |
PC_NotAny_VF |
PC_NSpan_VF |
PC_Span_VF |
PC_String_VF => VF : VString_Func;
end case;
end record;
subtype PC_Has_Alt is Pattern_Code range PC_Alt .. PC_Arbno_X;
EOP_Element : aliased constant PE := (PC_EOP, 0, N);
EOP : constant PE_Ptr := EOP_Element'Unrestricted_Access;
OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean :=
(PC_Any_CS |
PC_Any_CH |
PC_Any_VF |
PC_Any_VP |
PC_Char |
PC_Len_Nat |
PC_NotAny_CS |
PC_NotAny_CH |
PC_NotAny_VF |
PC_NotAny_VP |
PC_Span_CS |
PC_Span_CH |
PC_Span_VF |
PC_Span_VP |
PC_String |
PC_String_2 |
PC_String_3 |
PC_String_4 |
PC_String_5 |
PC_String_6 => True,
others => False);
type Stack_Entry is record
Cursor : Integer;
Node : PE_Ptr;
end record;
subtype Stack_Range is Integer range -Stack_Size .. -1;
type Stack_Type is array (Stack_Range) of Stack_Entry;
type Ref_Array is array (IndexT range <>) of PE_Ptr;
procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array);
CP_Assign : aliased PE := (PC_Assign, 0, N);
CP_Cancel : aliased PE := (PC_Cancel, 0, N);
CP_Fence_Y : aliased PE := (PC_Fence_Y, 0, N);
CP_R_Remove : aliased PE := (PC_R_Remove, 0, N);
CP_R_Restore : aliased PE := (PC_R_Restore, 0, N);
function Alternate (L, R : PE_Ptr) return PE_Ptr;
function "or" (L, R : PE_Ptr) return PE_Ptr renames Alternate;
function Arbno_Simple (P : PE_Ptr) return PE_Ptr;
function Bracket (E, P, A : PE_Ptr) return PE_Ptr;
function BreakX_Make (B : PE_Ptr) return Pattern;
function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr;
function C_To_PE (C : PChar) return PE_Ptr;
function Copy (P : PE_Ptr) return PE_Ptr;
function Image (P : PE_Ptr) return String;
function Is_In (C : Character; Str : String) return Boolean;
pragma Inline (Is_In);
procedure Logic_Error;
function Str_BF (A : Boolean_Func) return String;
function Str_FP (A : File_Ptr) return String;
function Str_NF (A : Natural_Func) return String;
function Str_NP (A : Natural_Ptr) return String;
function Str_PP (A : Pattern_Ptr) return String;
function Str_VF (A : VString_Func) return String;
function Str_VP (A : VString_Ptr) return String;
procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr);
function S_To_PE (Str : PString) return PE_Ptr;
procedure Uninitialized_Pattern;
pragma No_Return (Uninitialized_Pattern);
procedure XMatch
(Subject : String;
Pat_P : PE_Ptr;
Pat_S : Natural;
Start : out Natural;
Stop : out Natural);
procedure XMatchD
(Subject : String;
Pat_P : PE_Ptr;
Pat_S : Natural;
Start : out Natural;
Stop : out Natural);
function "&" (L : PString; R : Pattern) return Pattern is
begin
return (AFC with R.Stk, Concat (S_To_PE (L), Copy (R.P), R.Stk));
end "&";
function "&" (L : Pattern; R : PString) return Pattern is
begin
return (AFC with L.Stk, Concat (Copy (L.P), S_To_PE (R), 0));
end "&";
function "&" (L : PChar; R : Pattern) return Pattern is
begin
return (AFC with R.Stk, Concat (C_To_PE (L), Copy (R.P), R.Stk));
end "&";
function "&" (L : Pattern; R : PChar) return Pattern is
begin
return (AFC with L.Stk, Concat (Copy (L.P), C_To_PE (R), 0));
end "&";
function "&" (L : Pattern; R : Pattern) return Pattern is
begin
return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk));
end "&";
function "*" (P : Pattern; Var : VString_Var) return Pattern is
Pat : constant PE_Ptr := Copy (P.P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
A : constant PE_Ptr :=
new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access);
begin
return (AFC with P.Stk + 3, Bracket (E, Pat, A));
end "*";
function "*" (P : PString; Var : VString_Var) return Pattern is
Pat : constant PE_Ptr := S_To_PE (P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
A : constant PE_Ptr :=
new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access);
begin
return (AFC with 3, Bracket (E, Pat, A));
end "*";
function "*" (P : PChar; Var : VString_Var) return Pattern is
Pat : constant PE_Ptr := C_To_PE (P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
A : constant PE_Ptr :=
new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access);
begin
return (AFC with 3, Bracket (E, Pat, A));
end "*";
function "*" (P : Pattern; Fil : File_Access) return Pattern is
Pat : constant PE_Ptr := Copy (P.P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil);
begin
return (AFC with 3, Bracket (E, Pat, W));
end "*";
function "*" (P : PString; Fil : File_Access) return Pattern is
Pat : constant PE_Ptr := S_To_PE (P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil);
begin
return (AFC with 3, Bracket (E, Pat, W));
end "*";
function "*" (P : PChar; Fil : File_Access) return Pattern is
Pat : constant PE_Ptr := C_To_PE (P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil);
begin
return (AFC with 3, Bracket (E, Pat, W));
end "*";
function "**" (P : Pattern; Var : VString_Var) return Pattern is
Pat : constant PE_Ptr := Copy (P.P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
A : constant PE_Ptr :=
new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access);
begin
return (AFC with P.Stk + 3, Bracket (E, Pat, A));
end "**";
function "**" (P : PString; Var : VString_Var) return Pattern is
Pat : constant PE_Ptr := S_To_PE (P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
A : constant PE_Ptr :=
new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access);
begin
return (AFC with 3, Bracket (E, Pat, A));
end "**";
function "**" (P : PChar; Var : VString_Var) return Pattern is
Pat : constant PE_Ptr := C_To_PE (P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
A : constant PE_Ptr :=
new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access);
begin
return (AFC with 3, Bracket (E, Pat, A));
end "**";
function "**" (P : Pattern; Fil : File_Access) return Pattern is
Pat : constant PE_Ptr := Copy (P.P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil);
begin
return (AFC with P.Stk + 3, Bracket (E, Pat, W));
end "**";
function "**" (P : PString; Fil : File_Access) return Pattern is
Pat : constant PE_Ptr := S_To_PE (P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil);
begin
return (AFC with 3, Bracket (E, Pat, W));
end "**";
function "**" (P : PChar; Fil : File_Access) return Pattern is
Pat : constant PE_Ptr := C_To_PE (P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil);
begin
return (AFC with 3, Bracket (E, Pat, W));
end "**";
function "+" (Str : VString_Var) return Pattern is
begin
return
(AFC with 0,
new PE'(PC_String_VP, 1, EOP, Str'Unrestricted_Access));
end "+";
function "+" (Str : VString_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_String_VF, 1, EOP, Str));
end "+";
function "+" (P : Pattern_Var) return Pattern is
begin
return
(AFC with 3,
new PE'(PC_Rpat, 1, EOP, P'Unrestricted_Access));
end "+";
function "+" (P : Boolean_Func) return Pattern is
begin
return (AFC with 3, new PE'(PC_Pred_Func, 1, EOP, P));
end "+";
function "or" (L : PString; R : Pattern) return Pattern is
begin
return (AFC with R.Stk + 1, S_To_PE (L) or Copy (R.P));
end "or";
function "or" (L : Pattern; R : PString) return Pattern is
begin
return (AFC with L.Stk + 1, Copy (L.P) or S_To_PE (R));
end "or";
function "or" (L : PString; R : PString) return Pattern is
begin
return (AFC with 1, S_To_PE (L) or S_To_PE (R));
end "or";
function "or" (L : Pattern; R : Pattern) return Pattern is
begin
return (AFC with
Natural'Max (L.Stk, R.Stk) + 1, Copy (L.P) or Copy (R.P));
end "or";
function "or" (L : PChar; R : Pattern) return Pattern is
begin
return (AFC with 1, C_To_PE (L) or Copy (R.P));
end "or";
function "or" (L : Pattern; R : PChar) return Pattern is
begin
return (AFC with 1, Copy (L.P) or C_To_PE (R));
end "or";
function "or" (L : PChar; R : PChar) return Pattern is
begin
return (AFC with 1, C_To_PE (L) or C_To_PE (R));
end "or";
function "or" (L : PString; R : PChar) return Pattern is
begin
return (AFC with 1, S_To_PE (L) or C_To_PE (R));
end "or";
function "or" (L : PChar; R : PString) return Pattern is
begin
return (AFC with 1, C_To_PE (L) or S_To_PE (R));
end "or";
procedure Adjust (Object : in out Pattern) is
begin
Object.P := Copy (Object.P);
end Adjust;
function Alternate (L, R : PE_Ptr) return PE_Ptr is
begin
if L = EOP then
return new PE'(PC_Alt, R.Index + 1, EOP, R);
else
declare
Refs : Ref_Array (1 .. L.Index);
begin
Build_Ref_Array (L, Refs);
for J in Refs'Range loop
Refs (J).Index := Refs (J).Index + R.Index;
end loop;
end;
return new PE'(PC_Alt, L.Index + 1, L, R);
end if;
end Alternate;
function Any (Str : String) return Pattern is
begin
return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, To_Set (Str)));
end Any;
function Any (Str : VString) return Pattern is
begin
return Any (S (Str));
end Any;
function Any (Str : Character) return Pattern is
begin
return (AFC with 0, new PE'(PC_Any_CH, 1, EOP, Str));
end Any;
function Any (Str : Character_Set) return Pattern is
begin
return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, Str));
end Any;
function Any (Str : access VString) return Pattern is
begin
return (AFC with 0, new PE'(PC_Any_VP, 1, EOP, VString_Ptr (Str)));
end Any;
function Any (Str : VString_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_Any_VF, 1, EOP, Str));
end Any;
function Arb return Pattern is
Y : constant PE_Ptr := new PE'(PC_Arb_Y, 1, EOP);
X : constant PE_Ptr := new PE'(PC_Arb_X, 2, EOP, Y);
begin
return (AFC with 1, X);
end Arb;
function Arbno (P : PString) return Pattern is
begin
if P'Length = 0 then
return (AFC with 0, EOP);
else
return (AFC with 0, Arbno_Simple (S_To_PE (P)));
end if;
end Arbno;
function Arbno (P : PChar) return Pattern is
begin
return (AFC with 0, Arbno_Simple (C_To_PE (P)));
end Arbno;
function Arbno (P : Pattern) return Pattern is
Pat : constant PE_Ptr := Copy (P.P);
begin
if P.Stk = 0
and then OK_For_Simple_Arbno (Pat.Pcode)
then
return (AFC with 0, Arbno_Simple (Pat));
end if;
declare
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
X : constant PE_Ptr := new PE'(PC_Arbno_X, 0, EOP, E);
Y : constant PE_Ptr := new PE'(PC_Arbno_Y, 0, X, P.Stk + 3);
EPY : constant PE_Ptr := Bracket (E, Pat, Y);
begin
X.Alt := EPY;
X.Index := EPY.Index + 1;
return (AFC with P.Stk + 3, X);
end;
end Arbno;
function Arbno_Simple (P : PE_Ptr) return PE_Ptr is
S : constant PE_Ptr := new PE'(PC_Arbno_S, P.Index + 1, EOP, P);
begin
Set_Successor (P, S);
return S;
end Arbno_Simple;
function Bal return Pattern is
begin
return (AFC with 1, new PE'(PC_Bal, 1, EOP));
end Bal;
function Bracket (E, P, A : PE_Ptr) return PE_Ptr is
begin
if P = EOP then
E.Pthen := A;
E.Index := 2;
A.Index := 1;
else
E.Pthen := P;
Set_Successor (P, A);
E.Index := P.Index + 2;
A.Index := P.Index + 1;
end if;
return E;
end Bracket;
function Break (Str : String) return Pattern is
begin
return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, To_Set (Str)));
end Break;
function Break (Str : VString) return Pattern is
begin
return Break (S (Str));
end Break;
function Break (Str : Character) return Pattern is
begin
return (AFC with 0, new PE'(PC_Break_CH, 1, EOP, Str));
end Break;
function Break (Str : Character_Set) return Pattern is
begin
return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, Str));
end Break;
function Break (Str : access VString) return Pattern is
begin
return (AFC with 0, new PE'(PC_Break_VP, 1, EOP, VString_Ptr (Str)));
end Break;
function Break (Str : VString_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_Break_VF, 1, EOP, Str));
end Break;
function BreakX (Str : String) return Pattern is
begin
return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, To_Set (Str)));
end BreakX;
function BreakX (Str : VString) return Pattern is
begin
return BreakX (S (Str));
end BreakX;
function BreakX (Str : Character) return Pattern is
begin
return BreakX_Make (new PE'(PC_BreakX_CH, 3, N, Str));
end BreakX;
function BreakX (Str : Character_Set) return Pattern is
begin
return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, Str));
end BreakX;
function BreakX (Str : access VString) return Pattern is
begin
return BreakX_Make (new PE'(PC_BreakX_VP, 3, N, VString_Ptr (Str)));
end BreakX;
function BreakX (Str : VString_Func) return Pattern is
begin
return BreakX_Make (new PE'(PC_BreakX_VF, 3, N, Str));
end BreakX;
function BreakX_Make (B : PE_Ptr) return Pattern is
X : constant PE_Ptr := new PE'(PC_BreakX_X, 2, B);
A : constant PE_Ptr := new PE'(PC_Alt, 1, EOP, X);
begin
B.Pthen := A;
return (AFC with 2, B);
end BreakX_Make;
procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array) is
procedure Record_PE (E : PE_Ptr);
procedure Record_PE (E : PE_Ptr) is
begin
PutD (" Record_PE called with PE_Ptr = " & Image (E));
if E = EOP or else RA (E.Index) /= null then
Put_LineD (", nothing to do");
return;
else
Put_LineD (", recording" & IndexT'Image (E.Index));
RA (E.Index) := E;
Record_PE (E.Pthen);
if E.Pcode in PC_Has_Alt then
Record_PE (E.Alt);
end if;
end if;
end Record_PE;
begin
New_LineD;
Put_LineD ("Entering Build_Ref_Array");
Record_PE (E);
New_LineD;
end Build_Ref_Array;
function C_To_PE (C : PChar) return PE_Ptr is
begin
return new PE'(PC_Char, 1, EOP, C);
end C_To_PE;
function Cancel return Pattern is
begin
return (AFC with 0, new PE'(PC_Cancel, 1, EOP));
end Cancel;
function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr is
begin
if L = EOP then
return R;
elsif R = EOP then
return L;
else
declare
Refs : Ref_Array (1 .. L.Index);
P : PE_Ptr;
begin
Build_Ref_Array (L, Refs);
for J in Refs'Range loop
P := Refs (J);
P.Index := P.Index + R.Index;
if P.Pcode = PC_Arbno_Y then
P.Nat := P.Nat + Incr;
end if;
if P.Pthen = EOP then
P.Pthen := R;
end if;
if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
P.Alt := R;
end if;
end loop;
end;
return L;
end if;
end Concat;
function Copy (P : PE_Ptr) return PE_Ptr is
begin
if P = null then
Uninitialized_Pattern;
else
declare
Refs : Ref_Array (1 .. P.Index);
Copy : Ref_Array (1 .. P.Index);
E : PE_Ptr;
begin
Build_Ref_Array (P, Refs);
for J in Refs'Range loop
Copy (J) := new PE'(Refs (J).all);
end loop;
for J in Copy'Range loop
E := Copy (J);
if E.Pthen /= EOP then
E.Pthen := Copy (E.Pthen.Index);
end if;
if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then
E.Alt := Copy (E.Alt.Index);
end if;
if E.Pcode = PC_String then
E.Str := new String'(E.Str.all);
end if;
end loop;
return Copy (P.Index);
end;
end if;
end Copy;
procedure Dump (P : Pattern) is
subtype Count is Ada.Text_IO.Count;
Scol : Count;
Refs : Ref_Array (1 .. P.P.Index);
Cols : Natural := 2;
E : PE_Ptr;
procedure Write_Node_Id (E : PE_Ptr);
procedure Write_Node_Id (E : PE_Ptr) is
begin
if E = EOP then
Put ("EOP");
for J in 4 .. Cols loop
Put (' ');
end loop;
else
declare
Str : String (1 .. Cols);
N : Natural := Natural (E.Index);
begin
Put ("#");
for J in reverse Str'Range loop
Str (J) := Character'Val (48 + N mod 10);
N := N / 10;
end loop;
Put (Str);
end;
end if;
end Write_Node_Id;
begin
New_Line;
Put ("Pattern Dump Output (pattern at " &
Image (P'Address) &
", S = " & Natural'Image (P.Stk) & ')');
Scol := Col;
New_Line;
while Col < Scol loop
Put ('-');
end loop;
New_Line;
if P.P = null then
Put_Line ("Uninitialized pattern value");
return;
end if;
if P.P = EOP then
Put_Line ("EOP (null pattern)");
return;
end if;
Build_Ref_Array (P.P, Refs);
while 10 ** Cols - 1 < Integer (P.P.Index) loop
Cols := Cols + 1;
end loop;
for J in reverse Refs'Range loop
E := Refs (J);
Write_Node_Id (E);
Set_Col (Count (Cols) + 4);
Put (Image (E));
Put (" ");
Put (Pattern_Code'Image (E.Pcode));
Put (" ");
Set_Col (21 + Count (Cols) + Address_Image_Length);
Write_Node_Id (E.Pthen);
Set_Col (24 + 2 * Count (Cols) + Address_Image_Length);
case E.Pcode is
when PC_Alt |
PC_Arb_X |
PC_Arbno_S |
PC_Arbno_X =>
Write_Node_Id (E.Alt);
when PC_Rpat =>
Put (Str_PP (E.PP));
when PC_Pred_Func =>
Put (Str_BF (E.BF));
when PC_Assign_Imm |
PC_Assign_OnM |
PC_Any_VP |
PC_Break_VP |
PC_BreakX_VP |
PC_NotAny_VP |
PC_NSpan_VP |
PC_Span_VP |
PC_String_VP =>
Put (Str_VP (E.VP));
when PC_Write_Imm |
PC_Write_OnM =>
Put (Str_FP (E.FP));
when PC_String =>
Put (Image (E.Str.all));
when PC_String_2 =>
Put (Image (E.Str2));
when PC_String_3 =>
Put (Image (E.Str3));
when PC_String_4 =>
Put (Image (E.Str4));
when PC_String_5 =>
Put (Image (E.Str5));
when PC_String_6 =>
Put (Image (E.Str6));
when PC_Setcur =>
Put (Str_NP (E.Var));
when PC_Any_CH |
PC_Break_CH |
PC_BreakX_CH |
PC_Char |
PC_NotAny_CH |
PC_NSpan_CH |
PC_Span_CH =>
Put (''' & E.Char & ''');
when PC_Any_CS |
PC_Break_CS |
PC_BreakX_CS |
PC_NotAny_CS |
PC_NSpan_CS |
PC_Span_CS =>
Put ('"' & To_Sequence (E.CS) & '"');
when PC_Arbno_Y |
PC_Len_Nat |
PC_Pos_Nat |
PC_RPos_Nat |
PC_RTab_Nat |
PC_Tab_Nat =>
Put (S (E.Nat));
when PC_Pos_NF |
PC_Len_NF |
PC_RPos_NF |
PC_RTab_NF |
PC_Tab_NF =>
Put (Str_NF (E.NF));
when PC_Pos_NP |
PC_Len_NP |
PC_RPos_NP |
PC_RTab_NP |
PC_Tab_NP =>
Put (Str_NP (E.NP));
when PC_Any_VF |
PC_Break_VF |
PC_BreakX_VF |
PC_NotAny_VF |
PC_NSpan_VF |
PC_Span_VF |
PC_String_VF =>
Put (Str_VF (E.VF));
when others => null;
end case;
New_Line;
end loop;
New_Line;
end Dump;
function Fail return Pattern is
begin
return (AFC with 0, new PE'(PC_Fail, 1, EOP));
end Fail;
function Fence return Pattern is
begin
return (AFC with 1, new PE'(PC_Fence, 1, EOP));
end Fence;
function Fence (P : Pattern) return Pattern is
Pat : constant PE_Ptr := Copy (P.P);
E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
X : constant PE_Ptr := new PE'(PC_Fence_X, 0, EOP);
begin
return (AFC with P.Stk + 1, Bracket (E, Pat, X));
end Fence;
procedure Finalize (Object : in out Pattern) is
procedure Free is new Unchecked_Deallocation (PE, PE_Ptr);
procedure Free is new Unchecked_Deallocation (String, String_Ptr);
begin
if Object.P = null then
return;
else
declare
Refs : Ref_Array (1 .. Object.P.Index);
begin
Build_Ref_Array (Object.P, Refs);
for J in Refs'Range loop
if Refs (J).Pcode = PC_String then
Free (Refs (J).Str);
end if;
Free (Refs (J));
end loop;
Object.P := null;
end;
end if;
end Finalize;
function Image (P : PE_Ptr) return String is
begin
return Image (To_Address (P));
end Image;
function Image (P : Pattern) return String is
begin
return S (Image (P));
end Image;
function Image (P : Pattern) return VString is
Kill_Ampersand : Boolean := False;
Result : VString := Nul;
Refs : Ref_Array (1 .. P.P.Index);
procedure Delete_Ampersand;
procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean);
procedure Image_One (E : in out PE_Ptr);
procedure Delete_Ampersand is
L : constant Natural := Length (Result);
begin
if L > 2 then
Delete (Result, L - 1, L);
end if;
end Delete_Ampersand;
procedure Image_One (E : in out PE_Ptr) is
ER : PE_Ptr := E.Pthen;
begin
case E.Pcode is
when PC_Cancel =>
Append (Result, "Cancel");
when PC_Alt => Alt : declare
Elmts_In_L : constant IndexT := E.Pthen.Index - E.Alt.Index;
Lowest_In_L : constant IndexT := E.Index - Elmts_In_L;
E1 : PE_Ptr;
begin
while ER /= EOP
and then ER.Index >= Lowest_In_L
and then ER.Index < E.Index
loop
ER := ER.Pthen;
end loop;
Append (Result, '(');
E1 := E;
loop
Image_Seq (E1.Pthen, ER, False);
Append (Result, " or ");
E1 := E1.Alt;
exit when E1.Pcode /= PC_Alt;
end loop;
Image_Seq (E1, ER, False);
Append (Result, ')');
end Alt;
when PC_Any_CS =>
Append (Result, "Any (" & Image (To_Sequence (E.CS)) & ')');
when PC_Any_VF =>
Append (Result, "Any (" & Str_VF (E.VF) & ')');
when PC_Any_VP =>
Append (Result, "Any (" & Str_VP (E.VP) & ')');
when PC_Arb_X =>
Append (Result, "Arb");
when PC_Arbno_S =>
Append (Result, "Arbno (");
Image_Seq (E.Alt, E, False);
Append (Result, ')');
when PC_Arbno_X =>
Append (Result, "Arbno (");
Image_Seq (E.Alt.Pthen, Refs (E.Index - 2), False);
Append (Result, ')');
when PC_Assign_Imm =>
Delete_Ampersand;
Append (Result, "* " & Str_VP (Refs (E.Index - 1).VP));
when PC_Assign_OnM =>
Delete_Ampersand;
Append (Result, "** " & Str_VP (Refs (E.Index - 1).VP));
when PC_Any_CH =>
Append (Result, "Any ('" & E.Char & "')");
when PC_Bal =>
Append (Result, "Bal");
when PC_Break_CH =>
Append (Result, "Break ('" & E.Char & "')");
when PC_Break_CS =>
Append (Result, "Break (" & Image (To_Sequence (E.CS)) & ')');
when PC_Break_VF =>
Append (Result, "Break (" & Str_VF (E.VF) & ')');
when PC_Break_VP =>
Append (Result, "Break (" & Str_VP (E.VP) & ')');
when PC_BreakX_CH =>
Append (Result, "BreakX ('" & E.Char & "')");
ER := ER.Pthen;
when PC_BreakX_CS =>
Append (Result, "BreakX (" & Image (To_Sequence (E.CS)) & ')');
ER := ER.Pthen;
when PC_BreakX_VF =>
Append (Result, "BreakX (" & Str_VF (E.VF) & ')');
ER := ER.Pthen;
when PC_BreakX_VP =>
Append (Result, "BreakX (" & Str_VP (E.VP) & ')');
ER := ER.Pthen;
when PC_Char =>
Append (Result, ''' & E.Char & ''');
when PC_Fail =>
Append (Result, "Fail");
when PC_Fence =>
Append (Result, "Fence");
when PC_Fence_X =>
Append (Result, "Fence (");
Image_Seq (E.Pthen, Refs (E.Index - 1), False);
Append (Result, ")");
ER := Refs (E.Index - 1).Pthen;
when PC_Len_Nat =>
Append (Result, "Len (" & E.Nat & ')');
when PC_Len_NF =>
Append (Result, "Len (" & Str_NF (E.NF) & ')');
when PC_Len_NP =>
Append (Result, "Len (" & Str_NP (E.NP) & ')');
when PC_NotAny_CH =>
Append (Result, "NotAny ('" & E.Char & "')");
when PC_NotAny_CS =>
Append (Result, "NotAny (" & Image (To_Sequence (E.CS)) & ')');
when PC_NotAny_VF =>
Append (Result, "NotAny (" & Str_VF (E.VF) & ')');
when PC_NotAny_VP =>
Append (Result, "NotAny (" & Str_VP (E.VP) & ')');
when PC_NSpan_CH =>
Append (Result, "NSpan ('" & E.Char & "')");
when PC_NSpan_CS =>
Append (Result, "NSpan (" & Image (To_Sequence (E.CS)) & ')');
when PC_NSpan_VF =>
Append (Result, "NSpan (" & Str_VF (E.VF) & ')');
when PC_NSpan_VP =>
Append (Result, "NSpan (" & Str_VP (E.VP) & ')');
when PC_Null =>
Append (Result, """""");
when PC_Pos_Nat =>
Append (Result, "Pos (" & E.Nat & ')');
when PC_Pos_NF =>
Append (Result, "Pos (" & Str_NF (E.NF) & ')');
when PC_Pos_NP =>
Append (Result, "Pos (" & Str_NP (E.NP) & ')');
when PC_R_Enter =>
Kill_Ampersand := True;
when PC_Rest =>
Append (Result, "Rest");
when PC_Rpat =>
Append (Result, "(+ " & Str_PP (E.PP) & ')');
when PC_Pred_Func =>
Append (Result, "(+ " & Str_BF (E.BF) & ')');
when PC_RPos_Nat =>
Append (Result, "RPos (" & E.Nat & ')');
when PC_RPos_NF =>
Append (Result, "RPos (" & Str_NF (E.NF) & ')');
when PC_RPos_NP =>
Append (Result, "RPos (" & Str_NP (E.NP) & ')');
when PC_RTab_Nat =>
Append (Result, "RTab (" & E.Nat & ')');
when PC_RTab_NF =>
Append (Result, "RTab (" & Str_NF (E.NF) & ')');
when PC_RTab_NP =>
Append (Result, "RTab (" & Str_NP (E.NP) & ')');
when PC_Setcur =>
Append (Result, "Setcur (" & Str_NP (E.Var) & ')');
when PC_Span_CH =>
Append (Result, "Span ('" & E.Char & "')");
when PC_Span_CS =>
Append (Result, "Span (" & Image (To_Sequence (E.CS)) & ')');
when PC_Span_VF =>
Append (Result, "Span (" & Str_VF (E.VF) & ')');
when PC_Span_VP =>
Append (Result, "Span (" & Str_VP (E.VP) & ')');
when PC_String =>
Append (Result, Image (E.Str.all));
when PC_String_2 =>
Append (Result, Image (E.Str2));
when PC_String_3 =>
Append (Result, Image (E.Str3));
when PC_String_4 =>
Append (Result, Image (E.Str4));
when PC_String_5 =>
Append (Result, Image (E.Str5));
when PC_String_6 =>
Append (Result, Image (E.Str6));
when PC_String_VF =>
Append (Result, "(+" & Str_VF (E.VF) & ')');
when PC_String_VP =>
Append (Result, "(+" & Str_VP (E.VP) & ')');
when PC_Succeed =>
Append (Result, "Succeed");
when PC_Tab_Nat =>
Append (Result, "Tab (" & E.Nat & ')');
when PC_Tab_NF =>
Append (Result, "Tab (" & Str_NF (E.NF) & ')');
when PC_Tab_NP =>
Append (Result, "Tab (" & Str_NP (E.NP) & ')');
when PC_Write_Imm =>
Append (Result, '(');
Image_Seq (E, Refs (E.Index - 1), True);
Append (Result, " * " & Str_FP (Refs (E.Index - 1).FP));
ER := Refs (E.Index - 1).Pthen;
when PC_Write_OnM =>
Append (Result, '(');
Image_Seq (E.Pthen, Refs (E.Index - 1), True);
Append (Result, " ** " & Str_FP (Refs (E.Index - 1).FP));
ER := Refs (E.Index - 1).Pthen;
when PC_Arb_Y |
PC_Arbno_Y |
PC_Assign |
PC_BreakX_X |
PC_EOP |
PC_Fence_Y |
PC_R_Remove |
PC_R_Restore |
PC_Unanchored =>
Append (Result, "???");
end case;
E := ER;
end Image_One;
procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is
Indx : constant Natural := Length (Result);
E1 : PE_Ptr := E;
Mult : Boolean := False;
begin
if E = EOP then
Append (Result, """""");
else
loop
Image_One (E1);
exit when E1 = Succ;
exit when E1 = EOP;
Mult := True;
if Kill_Ampersand then
Kill_Ampersand := False;
else
Append (Result, " & ");
end if;
end loop;
end if;
if Mult and Paren then
Insert (Result, Indx + 1, "(");
Append (Result, ")");
end if;
end Image_Seq;
begin
Build_Ref_Array (P.P, Refs);
Image_Seq (P.P, EOP, False);
return Result;
end Image;
function Is_In (C : Character; Str : String) return Boolean is
begin
for J in Str'Range loop
if Str (J) = C then
return True;
end if;
end loop;
return False;
end Is_In;
function Len (Count : Natural) return Pattern is
begin
if Count = 0 then
return (AFC with 0, new PE'(PC_Null, 1, EOP));
else
return (AFC with 0, new PE'(PC_Len_Nat, 1, EOP, Count));
end if;
end Len;
function Len (Count : Natural_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_Len_NF, 1, EOP, Count));
end Len;
function Len (Count : access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_Len_NP, 1, EOP, Natural_Ptr (Count)));
end Len;
procedure Logic_Error is
begin
Raise_Exception
(Program_Error'Identity,
"Internal logic error in GNAT.Spitbol.Patterns");
end Logic_Error;
function Match
(Subject : VString;
Pat : Pattern)
return Boolean
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
else
XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
end if;
return Start /= 0;
end Match;
function Match
(Subject : String;
Pat : Pattern)
return Boolean
is
Start, Stop : Natural;
subtype String1 is String (1 .. Subject'Length);
begin
if Debug_Mode then
XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
else
XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
end if;
return Start /= 0;
end Match;
function Match
(Subject : VString_Var;
Pat : Pattern;
Replace : VString)
return Boolean
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
else
XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
end if;
if Start = 0 then
return False;
else
Replace_Slice
(Subject'Unrestricted_Access.all,
Start, Stop, Get_String (Replace).all);
return True;
end if;
end Match;
function Match
(Subject : VString_Var;
Pat : Pattern;
Replace : String)
return Boolean
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
else
XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
end if;
if Start = 0 then
return False;
else
Replace_Slice
(Subject'Unrestricted_Access.all, Start, Stop, Replace);
return True;
end if;
end Match;
procedure Match
(Subject : VString;
Pat : Pattern)
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
else
XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
end if;
end Match;
procedure Match
(Subject : String;
Pat : Pattern)
is
Start, Stop : Natural;
subtype String1 is String (1 .. Subject'Length);
begin
if Debug_Mode then
XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
else
XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
end if;
end Match;
procedure Match
(Subject : in out VString;
Pat : Pattern;
Replace : VString)
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
else
XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
end if;
if Start /= 0 then
Replace_Slice (Subject, Start, Stop, Get_String (Replace).all);
end if;
end Match;
procedure Match
(Subject : in out VString;
Pat : Pattern;
Replace : String)
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
else
XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
end if;
if Start /= 0 then
Replace_Slice (Subject, Start, Stop, Replace);
end if;
end Match;
function Match
(Subject : VString;
Pat : PString)
return Boolean
is
Pat_Len : constant Natural := Pat'Length;
Sub_Len : constant Natural := Length (Subject);
Sub_Str : constant String_Access := Get_String (Subject);
begin
if Anchored_Mode then
if Pat_Len > Sub_Len then
return False;
else
return Pat = Sub_Str.all (1 .. Pat_Len);
end if;
else
for J in 1 .. Sub_Len - Pat_Len + 1 loop
if Pat = Sub_Str.all (J .. J + (Pat_Len - 1)) then
return True;
end if;
end loop;
return False;
end if;
end Match;
function Match
(Subject : String;
Pat : PString)
return Boolean
is
Pat_Len : constant Natural := Pat'Length;
Sub_Len : constant Natural := Subject'Length;
SFirst : constant Natural := Subject'First;
begin
if Anchored_Mode then
if Pat_Len > Sub_Len then
return False;
else
return Pat = Subject (SFirst .. SFirst + Pat_Len - 1);
end if;
else
for J in SFirst .. SFirst + Sub_Len - Pat_Len loop
if Pat = Subject (J .. J + (Pat_Len - 1)) then
return True;
end if;
end loop;
return False;
end if;
end Match;
function Match
(Subject : VString_Var;
Pat : PString;
Replace : VString)
return Boolean
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
else
XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
end if;
if Start = 0 then
return False;
else
Replace_Slice
(Subject'Unrestricted_Access.all,
Start, Stop, Get_String (Replace).all);
return True;
end if;
end Match;
function Match
(Subject : VString_Var;
Pat : PString;
Replace : String)
return Boolean
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
else
XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
end if;
if Start = 0 then
return False;
else
Replace_Slice
(Subject'Unrestricted_Access.all, Start, Stop, Replace);
return True;
end if;
end Match;
procedure Match
(Subject : VString;
Pat : PString)
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
else
XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
end if;
end Match;
procedure Match
(Subject : String;
Pat : PString)
is
Start, Stop : Natural;
subtype String1 is String (1 .. Subject'Length);
begin
if Debug_Mode then
XMatchD (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
else
XMatch (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
end if;
end Match;
procedure Match
(Subject : in out VString;
Pat : PString;
Replace : VString)
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
else
XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
end if;
if Start /= 0 then
Replace_Slice (Subject, Start, Stop, Get_String (Replace).all);
end if;
end Match;
procedure Match
(Subject : in out VString;
Pat : PString;
Replace : String)
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
else
XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
end if;
if Start /= 0 then
Replace_Slice (Subject, Start, Stop, Replace);
end if;
end Match;
function Match
(Subject : VString_Var;
Pat : Pattern;
Result : Match_Result_Var)
return Boolean
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
else
XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
end if;
if Start = 0 then
Result'Unrestricted_Access.all.Var := null;
return False;
else
Result'Unrestricted_Access.all.Var := Subject'Unrestricted_Access;
Result'Unrestricted_Access.all.Start := Start;
Result'Unrestricted_Access.all.Stop := Stop;
return True;
end if;
end Match;
procedure Match
(Subject : in out VString;
Pat : Pattern;
Result : out Match_Result)
is
Start, Stop : Natural;
begin
if Debug_Mode then
XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
else
XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
end if;
if Start = 0 then
Result.Var := null;
else
Result.Var := Subject'Unrestricted_Access;
Result.Start := Start;
Result.Stop := Stop;
end if;
end Match;
procedure New_LineD is
begin
if Internal_Debug then
New_Line;
end if;
end New_LineD;
function NotAny (Str : String) return Pattern is
begin
return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, To_Set (Str)));
end NotAny;
function NotAny (Str : VString) return Pattern is
begin
return NotAny (S (Str));
end NotAny;
function NotAny (Str : Character) return Pattern is
begin
return (AFC with 0, new PE'(PC_NotAny_CH, 1, EOP, Str));
end NotAny;
function NotAny (Str : Character_Set) return Pattern is
begin
return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str));
end NotAny;
function NotAny (Str : access VString) return Pattern is
begin
return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str)));
end NotAny;
function NotAny (Str : VString_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_NotAny_VF, 1, EOP, Str));
end NotAny;
function NSpan (Str : String) return Pattern is
begin
return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, To_Set (Str)));
end NSpan;
function NSpan (Str : VString) return Pattern is
begin
return NSpan (S (Str));
end NSpan;
function NSpan (Str : Character) return Pattern is
begin
return (AFC with 0, new PE'(PC_NSpan_CH, 1, EOP, Str));
end NSpan;
function NSpan (Str : Character_Set) return Pattern is
begin
return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str));
end NSpan;
function NSpan (Str : access VString) return Pattern is
begin
return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str)));
end NSpan;
function NSpan (Str : VString_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_NSpan_VF, 1, EOP, Str));
end NSpan;
function Pos (Count : Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_Pos_Nat, 1, EOP, Count));
end Pos;
function Pos (Count : Natural_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count));
end Pos;
function Pos (Count : access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count)));
end Pos;
procedure PutD (Str : String) is
begin
if Internal_Debug then
Put (Str);
end if;
end PutD;
procedure Put_LineD (Str : String) is
begin
if Internal_Debug then
Put_Line (Str);
end if;
end Put_LineD;
procedure Replace
(Result : in out Match_Result;
Replace : VString)
is
begin
if Result.Var /= null then
Replace_Slice
(Result.Var.all,
Result.Start,
Result.Stop,
Get_String (Replace).all);
Result.Var := null;
end if;
end Replace;
function Rest return Pattern is
begin
return (AFC with 0, new PE'(PC_Rest, 1, EOP));
end Rest;
function Rpos (Count : Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_RPos_Nat, 1, EOP, Count));
end Rpos;
function Rpos (Count : Natural_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count));
end Rpos;
function Rpos (Count : access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count)));
end Rpos;
function Rtab (Count : Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_RTab_Nat, 1, EOP, Count));
end Rtab;
function Rtab (Count : Natural_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count));
end Rtab;
function Rtab (Count : access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count)));
end Rtab;
function S_To_PE (Str : PString) return PE_Ptr is
Len : constant Natural := Str'Length;
begin
case Len is
when 0 =>
return new PE'(PC_Null, 1, EOP);
when 1 =>
return new PE'(PC_Char, 1, EOP, Str (1));
when 2 =>
return new PE'(PC_String_2, 1, EOP, Str);
when 3 =>
return new PE'(PC_String_3, 1, EOP, Str);
when 4 =>
return new PE'(PC_String_4, 1, EOP, Str);
when 5 =>
return new PE'(PC_String_5, 1, EOP, Str);
when 6 =>
return new PE'(PC_String_6, 1, EOP, Str);
when others =>
return new PE'(PC_String, 1, EOP, new String'(Str));
end case;
end S_To_PE;
procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is
begin
if Pat = null then
Uninitialized_Pattern;
elsif Pat = EOP then
Logic_Error;
else
declare
Refs : Ref_Array (1 .. Pat.Index);
P : PE_Ptr;
begin
Build_Ref_Array (Pat, Refs);
for J in Refs'Range loop
P := Refs (J);
if P.Pthen = EOP then
P.Pthen := Succ;
end if;
if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
P.Alt := Succ;
end if;
end loop;
end;
end if;
end Set_Successor;
function Setcur (Var : access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var)));
end Setcur;
function Span (Str : String) return Pattern is
begin
return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, To_Set (Str)));
end Span;
function Span (Str : VString) return Pattern is
begin
return Span (S (Str));
end Span;
function Span (Str : Character) return Pattern is
begin
return (AFC with 0, new PE'(PC_Span_CH, 1, EOP, Str));
end Span;
function Span (Str : Character_Set) return Pattern is
begin
return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str));
end Span;
function Span (Str : access VString) return Pattern is
begin
return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str)));
end Span;
function Span (Str : VString_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_Span_VF, 1, EOP, Str));
end Span;
function Str_BF (A : Boolean_Func) return String is
function To_A is new Unchecked_Conversion (Boolean_Func, Address);
begin
return "BF(" & Image (To_A (A)) & ')';
end Str_BF;
function Str_FP (A : File_Ptr) return String is
begin
return "FP(" & Image (A.all'Address) & ')';
end Str_FP;
function Str_NF (A : Natural_Func) return String is
function To_A is new Unchecked_Conversion (Natural_Func, Address);
begin
return "NF(" & Image (To_A (A)) & ')';
end Str_NF;
function Str_NP (A : Natural_Ptr) return String is
begin
return "NP(" & Image (A.all'Address) & ')';
end Str_NP;
function Str_PP (A : Pattern_Ptr) return String is
begin
return "PP(" & Image (A.all'Address) & ')';
end Str_PP;
function Str_VF (A : VString_Func) return String is
function To_A is new Unchecked_Conversion (VString_Func, Address);
begin
return "VF(" & Image (To_A (A)) & ')';
end Str_VF;
function Str_VP (A : VString_Ptr) return String is
begin
return "VP(" & Image (A.all'Address) & ')';
end Str_VP;
function Succeed return Pattern is
begin
return (AFC with 1, new PE'(PC_Succeed, 1, EOP));
end Succeed;
function Tab (Count : Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_Tab_Nat, 1, EOP, Count));
end Tab;
function Tab (Count : Natural_Func) return Pattern is
begin
return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count));
end Tab;
function Tab (Count : access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count)));
end Tab;
procedure Uninitialized_Pattern is
begin
Raise_Exception
(Program_Error'Identity,
"uninitialized value of type GNAT.Spitbol.Patterns.Pattern");
end Uninitialized_Pattern;
procedure XMatch
(Subject : String;
Pat_P : PE_Ptr;
Pat_S : Natural;
Start : out Natural;
Stop : out Natural)
is
Node : PE_Ptr;
Length : constant Natural := Subject'Length;
Cursor : Integer := 0;
PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
Stack : Stack_Type;
Stack_Ptr : Stack_Range;
Stack_Init : constant Stack_Range := Stack'First + 1;
Stack_Base : Stack_Range;
Assign_OnM : Boolean := False;
procedure Pop_Region;
pragma Inline (Pop_Region);
procedure Push (Node : PE_Ptr);
pragma Inline (Push);
procedure Push_Region;
pragma Inline (Push_Region);
procedure Pop_Region is
begin
if Stack_Ptr = Stack_Base then
Stack_Ptr := Stack_Base - 2;
Stack_Base := Stack (Stack_Ptr + 2).Cursor;
else
Stack_Ptr := Stack_Ptr + 1;
Stack (Stack_Ptr).Cursor := Stack_Base;
Stack (Stack_Ptr).Node := CP_R_Restore'Access;
Stack_Base := Stack (Stack_Base).Cursor;
end if;
end Pop_Region;
procedure Push (Node : PE_Ptr) is
begin
Stack_Ptr := Stack_Ptr + 1;
Stack (Stack_Ptr).Cursor := Cursor;
Stack (Stack_Ptr).Node := Node;
end Push;
procedure Push_Region is
begin
Stack_Ptr := Stack_Ptr + 2;
Stack (Stack_Ptr).Cursor := Stack_Base;
Stack (Stack_Ptr).Node := CP_R_Remove'Access;
Stack_Base := Stack_Ptr;
end Push_Region;
begin
if Pat_P = null then
Uninitialized_Pattern;
end if;
if Pat_S >= Stack_Size - 1 then
raise Pattern_Stack_Overflow;
end if;
if Anchored_Mode then
Stack (Stack_Init).Node := CP_Cancel'Access;
Stack (Stack_Init).Cursor := 0;
else
Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
Stack (Stack_Init).Cursor := 0;
end if;
Stack_Ptr := Stack_Init;
Stack_Base := Stack_Ptr;
Cursor := 0;
Node := Pat_P;
goto Match;
<<Match_Fail>>
Start := 0;
Stop := 0;
return;
<<Match_Succeed>>
Start := Stack (Stack_Init).Cursor + 1;
Stop := Cursor;
if Assign_OnM then
for S in Stack_Init .. Stack_Ptr loop
if Stack (S).Node = CP_Assign'Access then
declare
Inner_Base : constant Stack_Range :=
Stack (S + 1).Cursor;
Special_Entry : constant Stack_Range :=
Inner_Base - 1;
Node_OnM : constant PE_Ptr :=
Stack (Special_Entry).Node;
Start : constant Natural :=
Stack (Special_Entry).Cursor + 1;
Stop : constant Natural := Stack (S).Cursor;
begin
if Node_OnM.Pcode = PC_Assign_OnM then
Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
elsif Node_OnM.Pcode = PC_Write_OnM then
Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
else
Logic_Error;
end if;
end;
end if;
end loop;
end if;
return;
<<Fail>>
Cursor := Stack (Stack_Ptr).Cursor;
Node := Stack (Stack_Ptr).Node;
Stack_Ptr := Stack_Ptr - 1;
goto Match;
<<Succeed>>
Node := Node.Pthen;
<<Match>>
case Node.Pcode is
when PC_Cancel =>
goto Match_Fail;
when PC_Alt =>
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
when PC_Any_CH =>
if Cursor < Length
and then Subject (Cursor + 1) = Node.Char
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_Any_CS =>
if Cursor < Length
and then Is_In (Subject (Cursor + 1), Node.CS)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_Any_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
if Cursor < Length
and then Is_In (Subject (Cursor + 1), Str.all)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Any_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
if Cursor < Length
and then Is_In (Subject (Cursor + 1), Str.all)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Arb_X =>
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
when PC_Arb_Y =>
if Cursor < Length then
Cursor := Cursor + 1;
Push (Node);
goto Succeed;
else
goto Fail;
end if;
when PC_Arbno_S =>
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
when PC_Arbno_X =>
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
when PC_Arbno_Y => declare
Null_Match : constant Boolean :=
Cursor = Stack (Stack_Base - 1).Cursor;
begin
Pop_Region;
if Null_Match then
goto Fail;
end if;
if Stack_Ptr + Node.Nat >= Stack'Last then
raise Pattern_Stack_Overflow;
end if;
goto Succeed;
end;
when PC_Assign =>
goto Fail;
when PC_Assign_Imm =>
Set_String
(Node.VP.all,
Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
Pop_Region;
goto Succeed;
when PC_Assign_OnM =>
Stack (Stack_Base - 1).Node := Node;
Push (CP_Assign'Access);
Pop_Region;
Assign_OnM := True;
goto Succeed;
when PC_Bal =>
if Cursor >= Length or else Subject (Cursor + 1) = ')' then
goto Fail;
elsif Subject (Cursor + 1) = '(' then
declare
Paren_Count : Natural := 1;
begin
loop
Cursor := Cursor + 1;
if Cursor >= Length then
goto Fail;
elsif Subject (Cursor + 1) = '(' then
Paren_Count := Paren_Count + 1;
elsif Subject (Cursor + 1) = ')' then
Paren_Count := Paren_Count - 1;
exit when Paren_Count = 0;
end if;
end loop;
end;
end if;
Cursor := Cursor + 1;
Push (Node);
goto Succeed;
when PC_Break_CH =>
while Cursor < Length loop
if Subject (Cursor + 1) = Node.Char then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
when PC_Break_CS =>
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Node.CS) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
when PC_Break_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Str.all) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
end;
when PC_Break_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Str.all) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
end;
when PC_BreakX_CH =>
while Cursor < Length loop
if Subject (Cursor + 1) = Node.Char then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
when PC_BreakX_CS =>
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Node.CS) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
when PC_BreakX_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Str.all) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
end;
when PC_BreakX_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Str.all) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
end;
when PC_BreakX_X =>
Cursor := Cursor + 1;
goto Succeed;
when PC_Char =>
if Cursor < Length
and then Subject (Cursor + 1) = Node.Char
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_EOP =>
if Stack_Base = Stack_Init then
goto Match_Succeed;
else
Node := Stack (Stack_Base - 1).Node;
Pop_Region;
goto Match;
end if;
when PC_Fail =>
goto Fail;
when PC_Fence =>
Push (CP_Cancel'Access);
goto Succeed;
when PC_Fence_X =>
Stack_Ptr := Stack_Ptr + 1;
Stack (Stack_Ptr).Cursor := Stack_Base;
Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
Stack_Base := Stack (Stack_Base).Cursor;
goto Succeed;
when PC_Fence_Y =>
Stack_Ptr := Cursor - 2;
goto Fail;
when PC_Len_Nat =>
if Cursor + Node.Nat > Length then
goto Fail;
else
Cursor := Cursor + Node.Nat;
goto Succeed;
end if;
when PC_Len_NF => declare
N : constant Natural := Node.NF.all;
begin
if Cursor + N > Length then
goto Fail;
else
Cursor := Cursor + N;
goto Succeed;
end if;
end;
when PC_Len_NP =>
if Cursor + Node.NP.all > Length then
goto Fail;
else
Cursor := Cursor + Node.NP.all;
goto Succeed;
end if;
when PC_NotAny_CH =>
if Cursor < Length
and then Subject (Cursor + 1) /= Node.Char
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_NotAny_CS =>
if Cursor < Length
and then not Is_In (Subject (Cursor + 1), Node.CS)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_NotAny_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
if Cursor < Length
and then
not Is_In (Subject (Cursor + 1), Str.all)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_NotAny_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
if Cursor < Length
and then
not Is_In (Subject (Cursor + 1), Str.all)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_NSpan_CH =>
while Cursor < Length
and then Subject (Cursor + 1) = Node.Char
loop
Cursor := Cursor + 1;
end loop;
goto Succeed;
when PC_NSpan_CS =>
while Cursor < Length
and then Is_In (Subject (Cursor + 1), Node.CS)
loop
Cursor := Cursor + 1;
end loop;
goto Succeed;
when PC_NSpan_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
while Cursor < Length
and then Is_In (Subject (Cursor + 1), Str.all)
loop
Cursor := Cursor + 1;
end loop;
goto Succeed;
end;
when PC_NSpan_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
while Cursor < Length
and then Is_In (Subject (Cursor + 1), Str.all)
loop
Cursor := Cursor + 1;
end loop;
goto Succeed;
end;
when PC_Null =>
goto Succeed;
when PC_Pos_Nat =>
if Cursor = Node.Nat then
goto Succeed;
else
goto Fail;
end if;
when PC_Pos_NF => declare
N : constant Natural := Node.NF.all;
begin
if Cursor = N then
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Pos_NP =>
if Cursor = Node.NP.all then
goto Succeed;
else
goto Fail;
end if;
when PC_Pred_Func =>
if Node.BF.all then
goto Succeed;
else
goto Fail;
end if;
when PC_R_Enter =>
Stack (Stack_Ptr + 1).Cursor := Cursor;
Push_Region;
goto Succeed;
when PC_R_Remove =>
Stack_Base := Cursor;
Stack_Ptr := Stack_Ptr - 1;
goto Fail;
when PC_R_Restore =>
Stack_Base := Cursor;
goto Fail;
when PC_Rest =>
Cursor := Length;
goto Succeed;
when PC_Rpat =>
Stack (Stack_Ptr + 1).Node := Node.Pthen;
Push_Region;
if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
raise Pattern_Stack_Overflow;
else
Node := Node.PP.all.P;
goto Match;
end if;
when PC_RPos_Nat =>
if Cursor = (Length - Node.Nat) then
goto Succeed;
else
goto Fail;
end if;
when PC_RPos_NF => declare
N : constant Natural := Node.NF.all;
begin
if Length - Cursor = N then
goto Succeed;
else
goto Fail;
end if;
end;
when PC_RPos_NP =>
if Cursor = (Length - Node.NP.all) then
goto Succeed;
else
goto Fail;
end if;
when PC_RTab_Nat =>
if Cursor <= (Length - Node.Nat) then
Cursor := Length - Node.Nat;
goto Succeed;
else
goto Fail;
end if;
when PC_RTab_NF => declare
N : constant Natural := Node.NF.all;
begin
if Length - Cursor >= N then
Cursor := Length - N;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_RTab_NP =>
if Cursor <= (Length - Node.NP.all) then
Cursor := Length - Node.NP.all;
goto Succeed;
else
goto Fail;
end if;
when PC_Setcur =>
Node.Var.all := Cursor;
goto Succeed;
when PC_Span_CH => declare
P : Natural := Cursor;
begin
while P < Length
and then Subject (P + 1) = Node.Char
loop
P := P + 1;
end loop;
if P /= Cursor then
Cursor := P;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Span_CS => declare
P : Natural := Cursor;
begin
while P < Length
and then Is_In (Subject (P + 1), Node.CS)
loop
P := P + 1;
end loop;
if P /= Cursor then
Cursor := P;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Span_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
P : Natural := Cursor;
begin
while P < Length
and then Is_In (Subject (P + 1), Str.all)
loop
P := P + 1;
end loop;
if P /= Cursor then
Cursor := P;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Span_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
P : Natural := Cursor;
begin
while P < Length
and then Is_In (Subject (P + 1), Str.all)
loop
P := P + 1;
end loop;
if P /= Cursor then
Cursor := P;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_String_2 =>
if (Length - Cursor) >= 2
and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
then
Cursor := Cursor + 2;
goto Succeed;
else
goto Fail;
end if;
when PC_String_3 =>
if (Length - Cursor) >= 3
and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
then
Cursor := Cursor + 3;
goto Succeed;
else
goto Fail;
end if;
when PC_String_4 =>
if (Length - Cursor) >= 4
and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
then
Cursor := Cursor + 4;
goto Succeed;
else
goto Fail;
end if;
when PC_String_5 =>
if (Length - Cursor) >= 5
and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
then
Cursor := Cursor + 5;
goto Succeed;
else
goto Fail;
end if;
when PC_String_6 =>
if (Length - Cursor) >= 6
and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
then
Cursor := Cursor + 6;
goto Succeed;
else
goto Fail;
end if;
when PC_String => declare
Len : constant Natural := Node.Str'Length;
begin
if (Length - Cursor) >= Len
and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
then
Cursor := Cursor + Len;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_String_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
Len : constant Natural := Str'Length;
begin
if (Length - Cursor) >= Len
and then Str.all = Subject (Cursor + 1 .. Cursor + Len)
then
Cursor := Cursor + Len;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_String_VP => declare
S : constant String_Access := Get_String (Node.VP.all);
Len : constant Natural := S'Length;
begin
if (Length - Cursor) >= Len
and then S.all = Subject (Cursor + 1 .. Cursor + Len)
then
Cursor := Cursor + Len;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Succeed =>
Push (Node);
goto Succeed;
when PC_Tab_Nat =>
if Cursor <= Node.Nat then
Cursor := Node.Nat;
goto Succeed;
else
goto Fail;
end if;
when PC_Tab_NF => declare
N : constant Natural := Node.NF.all;
begin
if Cursor <= N then
Cursor := N;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Tab_NP =>
if Cursor <= Node.NP.all then
Cursor := Node.NP.all;
goto Succeed;
else
goto Fail;
end if;
when PC_Unanchored =>
if Cursor > Length then
goto Match_Fail;
else
Cursor := Cursor + 1;
Push (Node);
goto Succeed;
end if;
when PC_Write_Imm =>
Put_Line
(Node.FP.all,
Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
Pop_Region;
goto Succeed;
when PC_Write_OnM =>
Stack (Stack_Base - 1).Node := Node;
Push (CP_Assign'Access);
Pop_Region;
Assign_OnM := True;
goto Succeed;
end case;
pragma Warnings (Off);
Logic_Error;
pragma Warnings (On);
end XMatch;
procedure XMatchD
(Subject : String;
Pat_P : PE_Ptr;
Pat_S : Natural;
Start : out Natural;
Stop : out Natural)
is
Node : PE_Ptr;
Length : constant Natural := Subject'Length;
Cursor : Integer := 0;
PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
Region_Level : Natural := 0;
Stack : Stack_Type;
Stack_Ptr : Stack_Range;
Stack_Init : constant Stack_Range := Stack'First + 1;
Stack_Base : Stack_Range;
Assign_OnM : Boolean := False;
procedure Dout (Str : String);
procedure Dout (Str : String; A : Character);
procedure Dout (Str : String; A : Character_Set);
procedure Dout (Str : String; A : Natural);
procedure Dout (Str : String; A : String);
function Img (P : PE_Ptr) return String;
procedure Pop_Region;
pragma Inline (Pop_Region);
procedure Push (Node : PE_Ptr);
pragma Inline (Push);
procedure Push_Region;
pragma Inline (Push_Region);
procedure Dout (Str : String) is
begin
for J in 1 .. Region_Level loop
Put ("| ");
end loop;
Put_Line (Str);
end Dout;
procedure Dout (Str : String; A : Character) is
begin
Dout (Str & " ('" & A & "')");
end Dout;
procedure Dout (Str : String; A : Character_Set) is
begin
Dout (Str & " (" & Image (To_Sequence (A)) & ')');
end Dout;
procedure Dout (Str : String; A : Natural) is
begin
Dout (Str & " (" & A & ')');
end Dout;
procedure Dout (Str : String; A : String) is
begin
Dout (Str & " (" & Image (A) & ')');
end Dout;
function Img (P : PE_Ptr) return String is
begin
return "#" & Integer (P.Index) & " ";
end Img;
procedure Pop_Region is
begin
Region_Level := Region_Level - 1;
if Stack_Ptr = Stack_Base then
Stack_Ptr := Stack_Base - 2;
Stack_Base := Stack (Stack_Ptr + 2).Cursor;
else
Stack_Ptr := Stack_Ptr + 1;
Stack (Stack_Ptr).Cursor := Stack_Base;
Stack (Stack_Ptr).Node := CP_R_Restore'Access;
Stack_Base := Stack (Stack_Base).Cursor;
end if;
end Pop_Region;
procedure Push (Node : PE_Ptr) is
begin
Stack_Ptr := Stack_Ptr + 1;
Stack (Stack_Ptr).Cursor := Cursor;
Stack (Stack_Ptr).Node := Node;
end Push;
procedure Push_Region is
begin
Region_Level := Region_Level + 1;
Stack_Ptr := Stack_Ptr + 2;
Stack (Stack_Ptr).Cursor := Stack_Base;
Stack (Stack_Ptr).Node := CP_R_Remove'Access;
Stack_Base := Stack_Ptr;
end Push_Region;
begin
New_Line;
Put_Line ("Initiating pattern match, subject = " & Image (Subject));
Put ("--------------------------------------");
for J in 1 .. Length loop
Put ('-');
end loop;
New_Line;
Put_Line ("subject length = " & Length);
if Pat_P = null then
Uninitialized_Pattern;
end if;
if Pat_S >= Stack_Size - 1 then
raise Pattern_Stack_Overflow;
end if;
if Anchored_Mode then
Stack (Stack_Init).Node := CP_Cancel'Access;
Stack (Stack_Init).Cursor := 0;
else
Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
Stack (Stack_Init).Cursor := 0;
end if;
Stack_Ptr := Stack_Init;
Stack_Base := Stack_Ptr;
Cursor := 0;
Node := Pat_P;
goto Match;
<<Match_Fail>>
Dout ("match fails");
New_Line;
Start := 0;
Stop := 0;
return;
<<Match_Succeed>>
Dout ("match succeeds");
Start := Stack (Stack_Init).Cursor + 1;
Stop := Cursor;
Dout ("first matched character index = " & Start);
Dout ("last matched character index = " & Stop);
Dout ("matched substring = " & Image (Subject (Start .. Stop)));
if Assign_OnM then
for S in Stack'First .. Stack_Ptr loop
if Stack (S).Node = CP_Assign'Access then
declare
Inner_Base : constant Stack_Range :=
Stack (S + 1).Cursor;
Special_Entry : constant Stack_Range :=
Inner_Base - 1;
Node_OnM : constant PE_Ptr :=
Stack (Special_Entry).Node;
Start : constant Natural :=
Stack (Special_Entry).Cursor + 1;
Stop : constant Natural := Stack (S).Cursor;
begin
if Node_OnM.Pcode = PC_Assign_OnM then
Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
Dout
(Img (Stack (S).Node) &
"deferred assignment of " &
Image (Subject (Start .. Stop)));
elsif Node_OnM.Pcode = PC_Write_OnM then
Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
Dout
(Img (Stack (S).Node) &
"deferred write of " &
Image (Subject (Start .. Stop)));
else
Logic_Error;
end if;
end;
end if;
end loop;
end if;
New_Line;
return;
<<Fail>>
Cursor := Stack (Stack_Ptr).Cursor;
Node := Stack (Stack_Ptr).Node;
Stack_Ptr := Stack_Ptr - 1;
if Cursor >= 0 then
Dout ("failure, cursor reset to " & Cursor);
end if;
goto Match;
<<Succeed>>
Dout ("success, cursor = " & Cursor);
Node := Node.Pthen;
<<Match>>
case Node.Pcode is
when PC_Cancel =>
Dout (Img (Node) & "matching Cancel");
goto Match_Fail;
when PC_Alt =>
Dout
(Img (Node) & "setting up alternative " & Img (Node.Alt));
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
when PC_Any_CH =>
Dout (Img (Node) & "matching Any", Node.Char);
if Cursor < Length
and then Subject (Cursor + 1) = Node.Char
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_Any_CS =>
Dout (Img (Node) & "matching Any", Node.CS);
if Cursor < Length
and then Is_In (Subject (Cursor + 1), Node.CS)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_Any_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
Dout (Img (Node) & "matching Any", Str.all);
if Cursor < Length
and then Is_In (Subject (Cursor + 1), Str.all)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Any_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching Any", Str.all);
if Cursor < Length
and then Is_In (Subject (Cursor + 1), Str.all)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Arb_X =>
Dout (Img (Node) & "matching Arb");
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
when PC_Arb_Y =>
Dout (Img (Node) & "extending Arb");
if Cursor < Length then
Cursor := Cursor + 1;
Push (Node);
goto Succeed;
else
goto Fail;
end if;
when PC_Arbno_S =>
Dout (Img (Node) &
"setting up Arbno alternative " & Img (Node.Alt));
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
when PC_Arbno_X =>
Dout (Img (Node) &
"setting up Arbno alternative " & Img (Node.Alt));
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
when PC_Arbno_Y => declare
Null_Match : constant Boolean :=
Cursor = Stack (Stack_Base - 1).Cursor;
begin
Dout (Img (Node) & "extending Arbno");
Pop_Region;
if Null_Match then
Dout ("Arbno extension matched null, so fails");
goto Fail;
end if;
if Stack_Ptr + Node.Nat >= Stack'Last then
raise Pattern_Stack_Overflow;
end if;
goto Succeed;
end;
when PC_Assign =>
Dout (Img (Node) & "deferred assign/write cancelled");
goto Fail;
when PC_Assign_Imm =>
Dout
(Img (Node) & "executing immediate assignment of " &
Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)));
Set_String
(Node.VP.all,
Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
Pop_Region;
goto Succeed;
when PC_Assign_OnM =>
Dout (Img (Node) & "registering deferred assignment");
Stack (Stack_Base - 1).Node := Node;
Push (CP_Assign'Access);
Pop_Region;
Assign_OnM := True;
goto Succeed;
when PC_Bal =>
Dout (Img (Node) & "matching or extending Bal");
if Cursor >= Length or else Subject (Cursor + 1) = ')' then
goto Fail;
elsif Subject (Cursor + 1) = '(' then
declare
Paren_Count : Natural := 1;
begin
loop
Cursor := Cursor + 1;
if Cursor >= Length then
goto Fail;
elsif Subject (Cursor + 1) = '(' then
Paren_Count := Paren_Count + 1;
elsif Subject (Cursor + 1) = ')' then
Paren_Count := Paren_Count - 1;
exit when Paren_Count = 0;
end if;
end loop;
end;
end if;
Cursor := Cursor + 1;
Push (Node);
goto Succeed;
when PC_Break_CH =>
Dout (Img (Node) & "matching Break", Node.Char);
while Cursor < Length loop
if Subject (Cursor + 1) = Node.Char then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
when PC_Break_CS =>
Dout (Img (Node) & "matching Break", Node.CS);
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Node.CS) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
when PC_Break_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
Dout (Img (Node) & "matching Break", Str.all);
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Str.all) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
end;
when PC_Break_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching Break", Str.all);
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Str.all) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
end;
when PC_BreakX_CH =>
Dout (Img (Node) & "matching BreakX", Node.Char);
while Cursor < Length loop
if Subject (Cursor + 1) = Node.Char then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
when PC_BreakX_CS =>
Dout (Img (Node) & "matching BreakX", Node.CS);
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Node.CS) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
when PC_BreakX_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
Dout (Img (Node) & "matching BreakX", Str.all);
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Str.all) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
end;
when PC_BreakX_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching BreakX", Str.all);
while Cursor < Length loop
if Is_In (Subject (Cursor + 1), Str.all) then
goto Succeed;
else
Cursor := Cursor + 1;
end if;
end loop;
goto Fail;
end;
when PC_BreakX_X =>
Dout (Img (Node) & "extending BreakX");
Cursor := Cursor + 1;
goto Succeed;
when PC_Char =>
Dout (Img (Node) & "matching '" & Node.Char & ''');
if Cursor < Length
and then Subject (Cursor + 1) = Node.Char
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_EOP =>
if Stack_Base = Stack_Init then
Dout ("end of pattern");
goto Match_Succeed;
else
Dout ("terminating recursive match");
Node := Stack (Stack_Base - 1).Node;
Pop_Region;
goto Match;
end if;
when PC_Fail =>
Dout (Img (Node) & "matching Fail");
goto Fail;
when PC_Fence =>
Dout (Img (Node) & "matching Fence");
Push (CP_Cancel'Access);
goto Succeed;
when PC_Fence_X =>
Dout (Img (Node) & "matching Fence function");
Stack_Ptr := Stack_Ptr + 1;
Stack (Stack_Ptr).Cursor := Stack_Base;
Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
Stack_Base := Stack (Stack_Base).Cursor;
Region_Level := Region_Level - 1;
goto Succeed;
when PC_Fence_Y =>
Dout (Img (Node) & "pattern matched by Fence caused failure");
Stack_Ptr := Cursor - 2;
goto Fail;
when PC_Len_Nat =>
Dout (Img (Node) & "matching Len", Node.Nat);
if Cursor + Node.Nat > Length then
goto Fail;
else
Cursor := Cursor + Node.Nat;
goto Succeed;
end if;
when PC_Len_NF => declare
N : constant Natural := Node.NF.all;
begin
Dout (Img (Node) & "matching Len", N);
if Cursor + N > Length then
goto Fail;
else
Cursor := Cursor + N;
goto Succeed;
end if;
end;
when PC_Len_NP =>
Dout (Img (Node) & "matching Len", Node.NP.all);
if Cursor + Node.NP.all > Length then
goto Fail;
else
Cursor := Cursor + Node.NP.all;
goto Succeed;
end if;
when PC_NotAny_CH =>
Dout (Img (Node) & "matching NotAny", Node.Char);
if Cursor < Length
and then Subject (Cursor + 1) /= Node.Char
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_NotAny_CS =>
Dout (Img (Node) & "matching NotAny", Node.CS);
if Cursor < Length
and then not Is_In (Subject (Cursor + 1), Node.CS)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
when PC_NotAny_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
Dout (Img (Node) & "matching NotAny", Str.all);
if Cursor < Length
and then
not Is_In (Subject (Cursor + 1), Str.all)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_NotAny_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching NotAny", Str.all);
if Cursor < Length
and then
not Is_In (Subject (Cursor + 1), Str.all)
then
Cursor := Cursor + 1;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_NSpan_CH =>
Dout (Img (Node) & "matching NSpan", Node.Char);
while Cursor < Length
and then Subject (Cursor + 1) = Node.Char
loop
Cursor := Cursor + 1;
end loop;
goto Succeed;
when PC_NSpan_CS =>
Dout (Img (Node) & "matching NSpan", Node.CS);
while Cursor < Length
and then Is_In (Subject (Cursor + 1), Node.CS)
loop
Cursor := Cursor + 1;
end loop;
goto Succeed;
when PC_NSpan_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
begin
Dout (Img (Node) & "matching NSpan", Str.all);
while Cursor < Length
and then Is_In (Subject (Cursor + 1), Str.all)
loop
Cursor := Cursor + 1;
end loop;
goto Succeed;
end;
when PC_NSpan_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching NSpan", Str.all);
while Cursor < Length
and then Is_In (Subject (Cursor + 1), Str.all)
loop
Cursor := Cursor + 1;
end loop;
goto Succeed;
end;
when PC_Null =>
Dout (Img (Node) & "matching null");
goto Succeed;
when PC_Pos_Nat =>
Dout (Img (Node) & "matching Pos", Node.Nat);
if Cursor = Node.Nat then
goto Succeed;
else
goto Fail;
end if;
when PC_Pos_NF => declare
N : constant Natural := Node.NF.all;
begin
Dout (Img (Node) & "matching Pos", N);
if Cursor = N then
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Pos_NP =>
Dout (Img (Node) & "matching Pos", Node.NP.all);
if Cursor = Node.NP.all then
goto Succeed;
else
goto Fail;
end if;
when PC_Pred_Func =>
Dout (Img (Node) & "matching predicate function");
if Node.BF.all then
goto Succeed;
else
goto Fail;
end if;
when PC_R_Enter =>
Dout (Img (Node) & "starting match of nested pattern");
Stack (Stack_Ptr + 1).Cursor := Cursor;
Push_Region;
goto Succeed;
when PC_R_Remove =>
Dout ("failure, match of nested pattern terminated");
Stack_Base := Cursor;
Region_Level := Region_Level - 1;
Stack_Ptr := Stack_Ptr - 1;
goto Fail;
when PC_R_Restore =>
Dout ("failure, search for alternatives in nested pattern");
Region_Level := Region_Level + 1;
Stack_Base := Cursor;
goto Fail;
when PC_Rest =>
Dout (Img (Node) & "matching Rest");
Cursor := Length;
goto Succeed;
when PC_Rpat =>
Stack (Stack_Ptr + 1).Node := Node.Pthen;
Push_Region;
Dout (Img (Node) & "initiating recursive match");
if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
raise Pattern_Stack_Overflow;
else
Node := Node.PP.all.P;
goto Match;
end if;
when PC_RPos_Nat =>
Dout (Img (Node) & "matching RPos", Node.Nat);
if Cursor = (Length - Node.Nat) then
goto Succeed;
else
goto Fail;
end if;
when PC_RPos_NF => declare
N : constant Natural := Node.NF.all;
begin
Dout (Img (Node) & "matching RPos", N);
if Length - Cursor = N then
goto Succeed;
else
goto Fail;
end if;
end;
when PC_RPos_NP =>
Dout (Img (Node) & "matching RPos", Node.NP.all);
if Cursor = (Length - Node.NP.all) then
goto Succeed;
else
goto Fail;
end if;
when PC_RTab_Nat =>
Dout (Img (Node) & "matching RTab", Node.Nat);
if Cursor <= (Length - Node.Nat) then
Cursor := Length - Node.Nat;
goto Succeed;
else
goto Fail;
end if;
when PC_RTab_NF => declare
N : constant Natural := Node.NF.all;
begin
Dout (Img (Node) & "matching RPos", N);
if Length - Cursor >= N then
Cursor := Length - N;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_RTab_NP =>
Dout (Img (Node) & "matching RPos", Node.NP.all);
if Cursor <= (Length - Node.NP.all) then
Cursor := Length - Node.NP.all;
goto Succeed;
else
goto Fail;
end if;
when PC_Setcur =>
Dout (Img (Node) & "matching Setcur");
Node.Var.all := Cursor;
goto Succeed;
when PC_Span_CH => declare
P : Natural := Cursor;
begin
Dout (Img (Node) & "matching Span", Node.Char);
while P < Length
and then Subject (P + 1) = Node.Char
loop
P := P + 1;
end loop;
if P /= Cursor then
Cursor := P;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Span_CS => declare
P : Natural := Cursor;
begin
Dout (Img (Node) & "matching Span", Node.CS);
while P < Length
and then Is_In (Subject (P + 1), Node.CS)
loop
P := P + 1;
end loop;
if P /= Cursor then
Cursor := P;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Span_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
P : Natural := Cursor;
begin
Dout (Img (Node) & "matching Span", Str.all);
while P < Length
and then Is_In (Subject (P + 1), Str.all)
loop
P := P + 1;
end loop;
if P /= Cursor then
Cursor := P;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Span_VP => declare
Str : constant String_Access := Get_String (Node.VP.all);
P : Natural := Cursor;
begin
Dout (Img (Node) & "matching Span", Str.all);
while P < Length
and then Is_In (Subject (P + 1), Str.all)
loop
P := P + 1;
end loop;
if P /= Cursor then
Cursor := P;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_String_2 =>
Dout (Img (Node) & "matching " & Image (Node.Str2));
if (Length - Cursor) >= 2
and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
then
Cursor := Cursor + 2;
goto Succeed;
else
goto Fail;
end if;
when PC_String_3 =>
Dout (Img (Node) & "matching " & Image (Node.Str3));
if (Length - Cursor) >= 3
and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
then
Cursor := Cursor + 3;
goto Succeed;
else
goto Fail;
end if;
when PC_String_4 =>
Dout (Img (Node) & "matching " & Image (Node.Str4));
if (Length - Cursor) >= 4
and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
then
Cursor := Cursor + 4;
goto Succeed;
else
goto Fail;
end if;
when PC_String_5 =>
Dout (Img (Node) & "matching " & Image (Node.Str5));
if (Length - Cursor) >= 5
and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
then
Cursor := Cursor + 5;
goto Succeed;
else
goto Fail;
end if;
when PC_String_6 =>
Dout (Img (Node) & "matching " & Image (Node.Str6));
if (Length - Cursor) >= 6
and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
then
Cursor := Cursor + 6;
goto Succeed;
else
goto Fail;
end if;
when PC_String => declare
Len : constant Natural := Node.Str'Length;
begin
Dout (Img (Node) & "matching " & Image (Node.Str.all));
if (Length - Cursor) >= Len
and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
then
Cursor := Cursor + Len;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_String_VF => declare
U : constant VString := Node.VF.all;
Str : constant String_Access := Get_String (U);
Len : constant Natural := Str'Length;
begin
Dout (Img (Node) & "matching " & Image (Str.all));
if (Length - Cursor) >= Len
and then Str.all = Subject (Cursor + 1 .. Cursor + Len)
then
Cursor := Cursor + Len;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_String_VP => declare
S : constant String_Access := Get_String (Node.VP.all);
Len : constant Natural :=
Ada.Strings.Unbounded.Length (Node.VP.all);
begin
Dout
(Img (Node) & "matching " & Image (S.all));
if (Length - Cursor) >= Len
and then S.all = Subject (Cursor + 1 .. Cursor + Len)
then
Cursor := Cursor + Len;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Succeed =>
Dout (Img (Node) & "matching Succeed");
Push (Node);
goto Succeed;
when PC_Tab_Nat =>
Dout (Img (Node) & "matching Tab", Node.Nat);
if Cursor <= Node.Nat then
Cursor := Node.Nat;
goto Succeed;
else
goto Fail;
end if;
when PC_Tab_NF => declare
N : constant Natural := Node.NF.all;
begin
Dout (Img (Node) & "matching Tab ", N);
if Cursor <= N then
Cursor := N;
goto Succeed;
else
goto Fail;
end if;
end;
when PC_Tab_NP =>
Dout (Img (Node) & "matching Tab ", Node.NP.all);
if Cursor <= Node.NP.all then
Cursor := Node.NP.all;
goto Succeed;
else
goto Fail;
end if;
when PC_Unanchored =>
Dout ("attempting to move anchor point");
if Cursor > Length then
goto Match_Fail;
else
Cursor := Cursor + 1;
Push (Node);
goto Succeed;
end if;
when PC_Write_Imm =>
Dout (Img (Node) & "executing immediate write of " &
Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
Put_Line
(Node.FP.all,
Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
Pop_Region;
goto Succeed;
when PC_Write_OnM =>
Dout (Img (Node) & "registering deferred write");
Stack (Stack_Base - 1).Node := Node;
Push (CP_Assign'Access);
Pop_Region;
Assign_OnM := True;
goto Succeed;
end case;
pragma Warnings (Off);
Logic_Error;
pragma Warnings (On);
end XMatchD;
end GNAT.Spitbol.Patterns;