-- --
-- B o d y --
-- --
--- $Revision: 1.21 $
--- --
--- Copyright (C) 1998-2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2007, 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- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- a direct translation, but the approach is followed closely. In particular,
-- we use the one stack approach developed in the SPITBOL implementation.
-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;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
package body GNAT.Spitbol.Patterns is
subtype String_Ptr is Ada.Strings.Unbounded.String_Access;
subtype File_Ptr is Ada.Text_IO.File_Access;
- function To_PE_Ptr is new Unchecked_Conversion (Address, PE_Ptr);
- function To_Address is new Unchecked_Conversion (PE_Ptr, Address);
+ function To_Address is new Ada.Unchecked_Conversion (PE_Ptr, Address);
-- Used only for debugging output purposes
subtype AFC is Ada.Finalization.Controlled;
N : constant PE_Ptr := null;
-- Shorthand used to initialize Copy fields to null
- type Character_Ptr is access all Character;
type Natural_Ptr is access all Natural;
type Pattern_Ptr is access all Pattern;
-- I parameter(s) I
-- +------------------------------------+
- -- Pcode is a code value indicating the type of the patterm node. This
+ -- Pcode is a code value indicating the type of the pattern node. This
-- code is used both as the discriminant value for the record, and as
-- the case index in the main match routine that branches to the proper
-- match code for the given element.
-- Pthen is a pointer to the successor node, i.e the node to be matched
-- if the attempt to match the node succeeds. If this is the last node
-- of the pattern to be matched, then Pthen points to a dummy node
- -- of kind PC_EOP (end of pattern), which initiales pattern exit.
+ -- of kind PC_EOP (end of pattern), which initializes pattern exit.
-- The parameter or parameters are present for certain node types,
-- and the type varies with the pattern code.
type PE (Pcode : Pattern_Code) is record
Index : IndexT;
- -- Serial index number of pattern element within pattern.
+ -- Serial index number of pattern element within pattern
Pthen : PE_Ptr;
-- Successor element, to be matched after this one
-- structure (i.e. it is a pattern that is guaranteed to match at least
-- one character on success, and not to make any entries on the stack.
- OK_For_Simple_Arbno :
- 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);
+ 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);
-------------------------------
-- The Pattern History Stack --
---------------------------------------------------
-- The serial index numbers for the pattern elements are assigned as
- -- a pattern is consructed from its constituent elements. Note that there
+ -- a pattern is constructed from its constituent elements. Note that there
-- is never any sharing of pattern elements between patterns (copies are
-- always made), so the serial index numbers are unique to a particular
-- pattern as referenced from the P field of a value of type Pattern.
-- pattern (e.g. copy and finalization processing). Once constructed
-- patterns are strictly read only. This is necessary to allow sharing
-- of patterns between tasks. This means that we cannot go marking the
- -- pattern (e.g. with a visited bit). Instead we cosntuct a separate
+ -- pattern (e.g. with a visited bit). Instead we construct a separate
-- vector that contains the necessary information indexed by the Index
-- values in the pattern elements. For this purpose the only requirement
-- is that they be uniquely assigned.
-- Third, as compound pattern structures are constructed, the way in which
-- constituent parts of the pattern are constructed is stylized. This is
- -- an automatic consequence of the way that these compounjd structures
+ -- an automatic consequence of the way that these compound structures
-- are constructed, and basically what we are doing is simply documenting
-- and specifying the natural result of the pattern construction. The
-- section describing compound pattern structures gives details of the
-- stack is used to control the backtracking. Finally, it notes the
-- way in which the Index numbers are assigned to the structure.
- -- In all diagrams, solid lines (built witth minus signs or vertical
+ -- In all diagrams, solid lines (built with minus signs or vertical
-- bars, represent successor pointers (Pthen fields) with > or V used
-- to indicate the direction of the pointer. The initial node of the
-- structure is in the upper left of the diagram. A dotted line is an
-------------------
-- In the pattern structures listed in this section, a line that looks
- -- lile ----> with nothing to the right indicates an end of pattern
+ -- like ----> with nothing to the right indicates an end of pattern
-- (EOP) pointer that represents the end of the match.
-- When a pattern concatenation (L & R) occurs, the resulting structure
-- occurs in constructing a pattern, and it means that the pattern
-- matching circuitry does not have to keep track of the structure
-- of a pattern with respect to concatenation, since the appropriate
- -- succesor is always at hand.
+ -- successor is always at hand.
-- Concatenation itself generates no additional possibilities for
-- backtracking, but the constituent patterns of the concatenated
-- it stacks a pointer to the leading element of R on the history stack
-- so that on subsequent failure, a match of R is attempted.
- -- The A node is the higest numbered element in the pattern. The
+ -- The A node is the highest numbered element in the pattern. The
-- original index numbers of R are unchanged, but the index numbers
-- of the L pattern are adjusted up by the count of elements in R.
-- pointer to Y node, which is the PC_Arb_Y node that matches one
-- extra character and restacks itself.
- -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1.
+ -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1
-------------------------
-- Arbno (simple case) --
-- described below.
-- It then stores a pointer to itself in the special entry node field.
- -- This was otherwise unused, and is now used to retrive the address
+ -- This was otherwise unused, and is now used to retrieve the address
-- of the variable to be assigned at the end of the pattern.
-- After that the inner region is terminated in the usual manner,
-- string, starting at the current cursor position. It then updates
-- the cursor past this matched string, and stacks a pointer to itself
-- with this updated cursor value on the history stack, to extend the
- -- matched string on a subequent failure.
+ -- matched string on a subsequent failure.
-- Since this is a single node it is numbered 1 (the reason we include
-- it in the compound patterns section is that it backtracks).
-- The following pattern elements are referenced only from the pattern
-- history stack. In each case the processing for the pattern element
- -- results in pattern match abort, or futher failure, so there is no
+ -- results in pattern match abort, or further failure, so there is no
-- need for a successor and no need for a node number
CP_Assign : aliased PE := (PC_Assign, 0, N);
-- understand a typical use of this function).
function BreakX_Make (B : PE_Ptr) return Pattern;
- -- Given a pattern element for a Break patternx, returns the
+ -- Given a pattern element for a Break pattern, returns the
-- corresponding BreakX compound pattern structure.
function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr;
- -- Creates a pattern eelement that represents a concatenation of the
+ -- Creates a pattern element that represents a concatenation of the
-- two given pattern elements (i.e. the pattern L followed by R).
-- The result returned is always the same as L, but the pattern
-- referenced by L is modified to have R as a successor. This
-- in the left operand, it represents the additional stack space
-- required by the right operand.
- function "&" (L, R : PE_Ptr) return PE_Ptr;
- pragma Inline ("&");
- -- Equivalent to Concat (L, R, 0)
-
function C_To_PE (C : PChar) return PE_Ptr;
-- Given a character, constructs a pattern element that matches
-- the single character.
function Is_In (C : Character; Str : String) return Boolean;
pragma Inline (Is_In);
- -- Determines if the character C is in string Str.
+ -- Determines if the character C is in string Str
procedure Logic_Error;
-- Called to raise Program_Error with an appropriate message if an
Start : out Natural;
Stop : out Natural);
-- Identical in all respects to XMatch, except that trace information is
- -- output on Standard_Ouput during execution of the match. This is the
+ -- output on Standard_Output during execution of the match. This is the
-- version that is called if the original Match call has Debug => True.
---------
return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk));
end "&";
- function "&" (L, R : PE_Ptr) return PE_Ptr is
- begin
- return Concat (L, R, 0);
- end "&";
-
---------
-- "*" --
---------
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 "*";
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 "*";
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 "*";
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 "*";
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 "*";
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 "*";
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 "**";
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 "**";
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 "**";
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 "**";
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 "**";
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 "**";
return new PE'(PC_Alt, R.Index + 1, EOP, R);
-- If the left pattern is non-null, then build a reference vector
- -- for its elements, and adjust their index values to acccomodate
+ -- for its elements, and adjust their index values to accommodate
-- the right hand elements. Then add the alternation node.
else
return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, Str));
end Any;
- function Any (Str : access VString) return Pattern is
+ function Any (Str : not null access VString) return Pattern is
begin
return (AFC with 0, new PE'(PC_Any_VP, 1, EOP, VString_Ptr (Str)));
end Any;
-- | Y |---->
-- +---+
- -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1.
+ -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1
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;
begin
if P'Length = 0 then
return (AFC with 0, EOP);
-
else
return (AFC with 0, Arbno_Simple (S_To_PE (P)));
end if;
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;
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;
return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, Str));
end Break;
- function Break (Str : access VString) return Pattern is
+ function Break (Str : not null access VString) return Pattern is
begin
- return (AFC with 0, new PE'(PC_Break_VP, 1, EOP, VString_Ptr (Str)));
+ return (AFC with 0,
+ new PE'(PC_Break_VP, 1, EOP, Str.all'Unchecked_Access));
end Break;
function Break (Str : VString_Func) return Pattern is
return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, Str));
end BreakX;
- function BreakX (Str : access VString) return Pattern is
+ function BreakX (Str : not null access VString) return Pattern is
begin
return BreakX_Make (new PE'(PC_BreakX_VP, 3, N, VString_Ptr (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);
-- Record given pattern element if not already recorded in RA,
-- and also record any referenced pattern elements recursively.
+ ---------------
+ -- Record_PE --
+ ---------------
+
procedure Record_PE (E : PE_Ptr) is
begin
PutD (" Record_PE called with PE_Ptr = " & Image (E));
-- References to elements in P, indexed by Index field
Copy : Ref_Array (1 .. P.Index);
- -- Holds copies of elements of P, indexed by Index field.
+ -- Holds copies of elements of P, indexed by Index field
E : PE_Ptr;
E : PE_Ptr;
procedure Write_Node_Id (E : PE_Ptr);
- -- Writes out a string identifying the given pattern element.
+ -- Writes out a string identifying the given pattern element
+
+ -------------------
+ -- Write_Node_Id --
+ -------------------
procedure Write_Node_Id (E : PE_Ptr) is
begin
end if;
end Write_Node_Id;
+ -- Start of processing for Dump
+
begin
New_Line;
Put ("Pattern Dump Output (pattern at " &
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);
+ procedure Free is new Ada.Unchecked_Deallocation (PE, PE_Ptr);
+ procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr);
begin
-- Nothing to do if already freed
----------------------
procedure Delete_Ampersand is
- L : Natural := Length (Result);
-
+ L : constant Natural := Length (Result);
begin
if L > 2 then
Delete (Result, L - 1, L);
when PC_Alt => Alt : declare
Elmts_In_L : constant IndexT := E.Pthen.Index - E.Alt.Index;
- -- Number of elements in left pattern of alternation.
+ -- Number of elements in left pattern of alternation
Lowest_In_L : constant IndexT := E.Index - Elmts_In_L;
-- Number of lowest index in elements of left pattern
when PC_Assign_Imm =>
Delete_Ampersand;
- Append (Result, "* " & Str_VP (Refs (E.Index - 1).VP));
+ Append (Result, "* " & Str_VP (Refs (E.Index).VP));
when PC_Assign_OnM =>
Delete_Ampersand;
- Append (Result, "** " & Str_VP (Refs (E.Index - 1).VP));
+ Append (Result, "** " & Str_VP (Refs (E.Index).VP));
when PC_Any_CH =>
Append (Result, "Any ('" & E.Char & "')");
---------------
procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is
+ Indx : constant Natural := Length (Result);
E1 : PE_Ptr := E;
Mult : Boolean := False;
- Indx : Natural := Length (Result);
begin
-- The image of EOP is "" (the null string)
return (AFC with 0, new PE'(PC_Len_NF, 1, EOP, Count));
end Len;
- function Len (Count : access Natural) return Pattern is
+ function Len (Count : not null 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");
+ raise Program_Error with
+ "Internal logic error in GNAT.Spitbol.Patterns";
end Logic_Error;
-----------
function Match
(Subject : VString;
- Pat : Pattern)
- return Boolean
+ Pat : Pattern) return Boolean
is
- Start, Stop : Natural;
+ S : String_Access;
+ L : Natural;
+
+ Start : Natural;
+ Stop : Natural;
+ pragma Unreferenced (Stop);
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
else
- XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
end if;
return Start /= 0;
function Match
(Subject : String;
- Pat : Pattern)
- return Boolean
+ Pat : Pattern) return Boolean
is
Start, Stop : Natural;
+ pragma Unreferenced (Stop);
+
subtype String1 is String (1 .. Subject'Length);
begin
function Match
(Subject : VString_Var;
Pat : Pattern;
- Replace : VString)
- return Boolean
+ Replace : VString) return Boolean
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
else
- XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
end if;
if Start = 0 then
return False;
else
+ Get_String (Replace, S, L);
Replace_Slice
- (Subject'Unrestricted_Access.all,
- Start, Stop, Get_String (Replace).all);
+ (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
return True;
end if;
end Match;
function Match
(Subject : VString_Var;
Pat : Pattern;
- Replace : String)
- return Boolean
+ Replace : String) return Boolean
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
else
- XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
end if;
if Start = 0 then
(Subject : VString;
Pat : Pattern)
is
- Start, Stop : Natural;
+ S : String_Access;
+ L : Natural;
+
+ Start : Natural;
+ Stop : Natural;
+ pragma Unreferenced (Start, Stop);
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
else
- XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
end if;
-
end Match;
procedure Match
Pat : Pattern)
is
Start, Stop : Natural;
+ pragma Unreferenced (Start, Stop);
+
subtype String1 is String (1 .. Subject'Length);
+
begin
if Debug_Mode then
XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
Pat : Pattern;
Replace : VString)
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
else
- XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
end if;
if Start /= 0 then
- Replace_Slice (Subject, Start, Stop, Get_String (Replace).all);
+ Get_String (Replace, S, L);
+ Replace_Slice (Subject, Start, Stop, S (1 .. L));
end if;
end Match;
Pat : Pattern;
Replace : String)
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
else
- XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
end if;
if Start /= 0 then
function Match
(Subject : VString;
- Pat : PString)
- return Boolean
+ 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);
+ Pat_Len : constant Natural := Pat'Length;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Anchored_Mode then
- if Pat_Len > Sub_Len then
+ if Pat_Len > L then
return False;
else
- return Pat = Sub_Str.all (1 .. Pat_Len);
+ return Pat = S (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
+ for J in 1 .. L - Pat_Len + 1 loop
+ if Pat = S (J .. J + (Pat_Len - 1)) then
return True;
end if;
end loop;
function Match
(Subject : String;
- Pat : PString)
- return Boolean
+ Pat : PString) return Boolean
is
Pat_Len : constant Natural := Pat'Length;
Sub_Len : constant Natural := Subject'Length;
function Match
(Subject : VString_Var;
Pat : PString;
- Replace : VString)
- return Boolean
+ Replace : VString) return Boolean
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
else
- XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
end if;
if Start = 0 then
return False;
else
+ Get_String (Replace, S, L);
Replace_Slice
- (Subject'Unrestricted_Access.all,
- Start, Stop, Get_String (Replace).all);
+ (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
return True;
end if;
end Match;
function Match
(Subject : VString_Var;
Pat : PString;
- Replace : String)
- return Boolean
+ Replace : String) return Boolean
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
else
- XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
end if;
if Start = 0 then
(Subject : VString;
Pat : PString)
is
- Start, Stop : Natural;
+ S : String_Access;
+ L : Natural;
+
+ Start : Natural;
+ Stop : Natural;
+ pragma Unreferenced (Start, Stop);
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
else
- XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
end if;
end Match;
Pat : PString)
is
Start, Stop : Natural;
+ pragma Unreferenced (Start, Stop);
+
subtype String1 is String (1 .. Subject'Length);
begin
Pat : PString;
Replace : VString)
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
else
- XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
end if;
if Start /= 0 then
- Replace_Slice (Subject, Start, Stop, Get_String (Replace).all);
+ Get_String (Replace, S, L);
+ Replace_Slice (Subject, Start, Stop, S (1 .. L));
end if;
end Match;
Pat : PString;
Replace : String)
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
else
- XMatch (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+ XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
end if;
if Start /= 0 then
function Match
(Subject : VString_Var;
Pat : Pattern;
- Result : Match_Result_Var)
- return Boolean
+ Result : Match_Result_Var) return Boolean
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
else
- XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
end if;
if Start = 0 then
Pat : Pattern;
Result : out Match_Result)
is
- Start, Stop : Natural;
+ Start : Natural;
+ Stop : Natural;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (Subject, S, L);
+
if Debug_Mode then
- XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
else
- XMatch (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+ XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
end if;
if Start = 0 then
Result.Var := null;
-
else
Result.Var := Subject'Unrestricted_Access;
Result.Start := Start;
return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str));
end NotAny;
- function NotAny (Str : access VString) return Pattern is
+ function NotAny (Str : not null access VString) return Pattern is
begin
return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str)));
end NotAny;
return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str));
end NSpan;
- function NSpan (Str : access VString) return Pattern is
+ function NSpan (Str : not null access VString) return Pattern is
begin
return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str)));
end NSpan;
return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count));
end Pos;
- function Pos (Count : access Natural) return Pattern is
+ function Pos (Count : not null access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count)));
end Pos;
(Result : in out Match_Result;
Replace : VString)
is
+ S : String_Access;
+ L : Natural;
+
begin
+ Get_String (Replace, S, L);
+
if Result.Var /= null then
- Replace_Slice
- (Result.Var.all,
- Result.Start,
- Result.Stop,
- Get_String (Replace).all);
+ Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L));
Result.Var := null;
end if;
end Replace;
return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count));
end Rpos;
- function Rpos (Count : access Natural) return Pattern is
+ function Rpos (Count : not null access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count)));
end Rpos;
return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count));
end Rtab;
- function Rtab (Count : access Natural) return Pattern is
+ function Rtab (Count : not null access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count)));
end Rtab;
return new PE'(PC_Null, 1, EOP);
when 1 =>
- return new PE'(PC_Char, 1, EOP, Str (1));
+ return new PE'(PC_Char, 1, EOP, Str (Str'First));
when 2 =>
return new PE'(PC_String_2, 1, EOP, Str);
-- Setcur --
------------
- function Setcur (Var : access Natural) return Pattern is
+ function Setcur (Var : not null access Natural) return Pattern is
begin
return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var)));
end Setcur;
return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str));
end Span;
- function Span (Str : access VString) return Pattern is
+ function Span (Str : not null access VString) return Pattern is
begin
return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str)));
end Span;
------------
function Str_BF (A : Boolean_Func) return String is
- function To_A is new Unchecked_Conversion (Boolean_Func, Address);
-
+ function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address);
begin
return "BF(" & Image (To_A (A)) & ')';
end Str_BF;
------------
function Str_NF (A : Natural_Func) return String is
- function To_A is new Unchecked_Conversion (Natural_Func, Address);
-
+ function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address);
begin
return "NF(" & Image (To_A (A)) & ')';
end Str_NF;
------------
function Str_VF (A : VString_Func) return String is
- function To_A is new Unchecked_Conversion (VString_Func, Address);
-
+ function To_A is new Ada.Unchecked_Conversion (VString_Func, Address);
begin
return "VF(" & Image (To_A (A)) & ')';
end Str_VF;
return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count));
end Tab;
- function Tab (Count : access Natural) return Pattern is
+ function Tab (Count : not null 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");
+ raise Program_Error with
+ "uninitialized value of type GNAT.Spitbol.Patterns.Pattern";
end Uninitialized_Pattern;
------------
-- failure and popping a "real" cursor value from the stack.
PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
- -- Dummy pattern element used in the unanchored case.
+ -- Dummy pattern element used in the unanchored case
Stack : Stack_Type;
-- The pattern matching failure stack for this call to Match
procedure Pop_Region;
pragma Inline (Pop_Region);
- -- Used at the end of processing of an inner region. if the inner
+ -- Used at the end of processing of an inner region. If the inner
-- region left no stack entries, then all trace of it is removed.
-- Otherwise a PC_Restore_Region entry is pushed to ensure proper
-- handling of alternatives in the inner region.
procedure Push (Node : PE_Ptr);
pragma Inline (Push);
- -- Make entry in pattern matching stack with current cursor valeu
+ -- Make entry in pattern matching stack with current cursor value
procedure Push_Region;
pragma Inline (Push_Region);
-- Any (string function case)
when PC_Any_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
if Cursor < Length
- and then Is_In (Subject (Cursor + 1), Str.all)
+ and then Is_In (Subject (Cursor + 1), S (1 .. L))
then
Cursor := Cursor + 1;
goto Succeed;
-- Any (string pointer case)
when PC_Any_VP => declare
- Str : constant String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
if Cursor < Length
- and then Is_In (Subject (Cursor + 1), Str.all)
+ and then Is_In (Subject (Cursor + 1), S (1 .. L))
then
Cursor := Cursor + 1;
goto Succeed;
-- Arbno pattern.
when PC_Arbno_Y => declare
- Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor);
+ Null_Match : constant Boolean :=
+ Cursor = Stack (Stack_Base - 1).Cursor;
begin
Pop_Region;
when PC_Assign =>
goto Fail;
- -- Assign immediate. This node performs the actual assignment.
+ -- Assign immediate. This node performs the actual assignment
when PC_Assign_Imm =>
Set_String
-- Break (string function case)
when PC_Break_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
while Cursor < Length loop
- if Is_In (Subject (Cursor + 1), Str.all) then
+ if Is_In (Subject (Cursor + 1), S (1 .. L)) then
goto Succeed;
else
Cursor := Cursor + 1;
-- Break (string pointer case)
when PC_Break_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
while Cursor < Length loop
- if Is_In (Subject (Cursor + 1), Str.all) then
+ if Is_In (Subject (Cursor + 1), S (1 .. L)) then
goto Succeed;
else
Cursor := Cursor + 1;
-- BreakX (string function case)
when PC_BreakX_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
while Cursor < Length loop
- if Is_In (Subject (Cursor + 1), Str.all) then
+ if Is_In (Subject (Cursor + 1), S (1 .. L)) then
goto Succeed;
else
Cursor := Cursor + 1;
-- BreakX (string pointer case)
when PC_BreakX_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
while Cursor < Length loop
- if Is_In (Subject (Cursor + 1), Str.all) then
+ if Is_In (Subject (Cursor + 1), S (1 .. L)) then
goto Succeed;
else
Cursor := Cursor + 1;
when PC_Len_NF => declare
N : constant Natural := Node.NF.all;
-
begin
if Cursor + N > Length then
goto Fail;
-- NotAny (string function case)
when PC_NotAny_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
if Cursor < Length
and then
- not Is_In (Subject (Cursor + 1), Str.all)
+ not Is_In (Subject (Cursor + 1), S (1 .. L))
then
Cursor := Cursor + 1;
goto Succeed;
-- NotAny (string pointer case)
when PC_NotAny_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
if Cursor < Length
and then
- not Is_In (Subject (Cursor + 1), Str.all)
+ not Is_In (Subject (Cursor + 1), S (1 .. L))
then
Cursor := Cursor + 1;
goto Succeed;
-- NSpan (string function case)
when PC_NSpan_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
while Cursor < Length
- and then Is_In (Subject (Cursor + 1), Str.all)
+ and then Is_In (Subject (Cursor + 1), S (1 .. L))
loop
Cursor := Cursor + 1;
end loop;
-- NSpan (string pointer case)
when PC_NSpan_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
+ Get_String (U, S, L);
+
while Cursor < Length
- and then Is_In (Subject (Cursor + 1), Str.all)
+ and then Is_In (Subject (Cursor + 1), S (1 .. L))
loop
Cursor := Cursor + 1;
end loop;
when PC_Pos_NF => declare
N : constant Natural := Node.NF.all;
-
begin
if Cursor = N then
goto Succeed;
when PC_RPos_NF => declare
N : constant Natural := Node.NF.all;
-
begin
if Length - Cursor = N then
goto Succeed;
when PC_RTab_NF => declare
N : constant Natural := Node.NF.all;
-
begin
if Length - Cursor >= N then
Cursor := Length - N;
-- Span (one character case)
when PC_Span_CH => declare
- P : Natural := Cursor;
+ P : Natural;
begin
+ P := Cursor;
while P < Length
and then Subject (P + 1) = Node.Char
loop
-- Span (character set case)
when PC_Span_CS => declare
- P : Natural := Cursor;
+ P : Natural;
begin
+ P := Cursor;
while P < Length
and then Is_In (Subject (P + 1), Node.CS)
loop
-- Span (string function case)
when PC_Span_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
- P : Natural := Cursor;
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
+ P : Natural;
begin
+ Get_String (U, S, L);
+
+ P := Cursor;
while P < Length
- and then Is_In (Subject (P + 1), Str.all)
+ and then Is_In (Subject (P + 1), S (1 .. L))
loop
P := P + 1;
end loop;
-- Span (string pointer case)
when PC_Span_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
- P : Natural := Cursor;
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
+ P : Natural;
begin
+ Get_String (U, S, L);
+
+ P := Cursor;
while P < Length
- and then Is_In (Subject (P + 1), Str.all)
+ and then Is_In (Subject (P + 1), S (1 .. L))
loop
P := P + 1;
end loop;
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)
-- String (function case)
when PC_String_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
- Len : constant Natural := Str'Length;
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
- if (Length - Cursor) >= Len
- and then Str.all = Subject (Cursor + 1 .. Cursor + Len)
+ Get_String (U, S, L);
+
+ if (Length - Cursor) >= L
+ and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
then
- Cursor := Cursor + Len;
+ Cursor := Cursor + L;
goto Succeed;
else
goto Fail;
-- String (pointer case)
when PC_String_VP => declare
- S : String_Access := Get_String (Node.VP.all);
- Len : constant Natural := S'Length;
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
- if (Length - Cursor) >= Len
- and then S.all = Subject (Cursor + 1 .. Cursor + Len)
+ Get_String (U, S, L);
+
+ if (Length - Cursor) >= L
+ and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
then
- Cursor := Cursor + Len;
+ Cursor := Cursor + L;
goto Succeed;
else
goto Fail;
when PC_Tab_NF => declare
N : constant Natural := Node.NF.all;
-
begin
if Cursor <= N then
Cursor := N;
-- match routine must end by executing a goto to the appropriate point
-- in the finite state machine model.
+ pragma Warnings (Off);
Logic_Error;
-
+ pragma Warnings (On);
end XMatch;
-------------
-- failure and popping a "real" cursor value from the stack.
PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
- -- Dummy pattern element used in the unanchored case.
+ -- Dummy pattern element used in the unanchored case
Region_Level : Natural := 0;
-- Keeps track of recursive region level. This is used only for
-- successful match.
procedure Dout (Str : String);
- -- Output string to standard error with bars indicating region level.
+ -- Output string to standard error with bars indicating region level
procedure Dout (Str : String; A : Character);
-- Calls Dout with the string S ('A')
procedure Pop_Region;
pragma Inline (Pop_Region);
- -- Used at the end of processing of an inner region. if the inner
+ -- Used at the end of processing of an inner region. If the inner
-- region left no stack entries, then all trace of it is removed.
-- Otherwise a PC_Restore_Region entry is pushed to ensure proper
-- handling of alternatives in the inner region.
procedure Push (Node : PE_Ptr);
pragma Inline (Push);
- -- Make entry in pattern matching stack with current cursor valeu
+ -- Make entry in pattern matching stack with current cursor value
procedure Push_Region;
pragma Inline (Push_Region);
-- Any (string function case)
when PC_Any_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching Any", Str.all);
+ Get_String (U, S, L);
+
+ Dout (Img (Node) & "matching Any", S (1 .. L));
if Cursor < Length
- and then Is_In (Subject (Cursor + 1), Str.all)
+ and then Is_In (Subject (Cursor + 1), S (1 .. L))
then
Cursor := Cursor + 1;
goto Succeed;
-- Any (string pointer case)
when PC_Any_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching Any", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching Any", S (1 .. L));
if Cursor < Length
- and then Is_In (Subject (Cursor + 1), Str.all)
+ and then Is_In (Subject (Cursor + 1), S (1 .. L))
then
Cursor := Cursor + 1;
goto Succeed;
-- Arbno pattern.
when PC_Arbno_Y => declare
- Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor);
+ Null_Match : constant Boolean :=
+ Cursor = Stack (Stack_Base - 1).Cursor;
begin
Dout (Img (Node) & "extending Arbno");
Dout (Img (Node) & "deferred assign/write cancelled");
goto Fail;
- -- Assign immediate. This node performs the actual assignment.
+ -- Assign immediate. This node performs the actual assignment
when PC_Assign_Imm =>
Dout
-- Break (string function case)
when PC_Break_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching Break", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching Break", S (1 .. L));
while Cursor < Length loop
- if Is_In (Subject (Cursor + 1), Str.all) then
+ if Is_In (Subject (Cursor + 1), S (1 .. L)) then
goto Succeed;
else
Cursor := Cursor + 1;
-- Break (string pointer case)
when PC_Break_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching Break", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching Break", S (1 .. L));
while Cursor < Length loop
- if Is_In (Subject (Cursor + 1), Str.all) then
+ if Is_In (Subject (Cursor + 1), S (1 .. L)) then
goto Succeed;
else
Cursor := Cursor + 1;
-- BreakX (string function case)
when PC_BreakX_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching BreakX", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching BreakX", S (1 .. L));
while Cursor < Length loop
- if Is_In (Subject (Cursor + 1), Str.all) then
+ if Is_In (Subject (Cursor + 1), S (1 .. L)) then
goto Succeed;
else
Cursor := Cursor + 1;
-- BreakX (string pointer case)
when PC_BreakX_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching BreakX", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching BreakX", S (1 .. L));
while Cursor < Length loop
- if Is_In (Subject (Cursor + 1), Str.all) then
+ if Is_In (Subject (Cursor + 1), S (1 .. L)) then
goto Succeed;
else
Cursor := Cursor + 1;
when PC_BreakX_X =>
Dout (Img (Node) & "extending BreakX");
-
Cursor := Cursor + 1;
goto Succeed;
-- NotAny (string function case)
when PC_NotAny_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching NotAny", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching NotAny", S (1 .. L));
if Cursor < Length
and then
- not Is_In (Subject (Cursor + 1), Str.all)
+ not Is_In (Subject (Cursor + 1), S (1 .. L))
then
Cursor := Cursor + 1;
goto Succeed;
-- NotAny (string pointer case)
when PC_NotAny_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching NotAny", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching NotAny", S (1 .. L));
if Cursor < Length
and then
- not Is_In (Subject (Cursor + 1), Str.all)
+ not Is_In (Subject (Cursor + 1), S (1 .. L))
then
Cursor := Cursor + 1;
goto Succeed;
-- NSpan (string function case)
when PC_NSpan_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching NSpan", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching NSpan", S (1 .. L));
while Cursor < Length
- and then Is_In (Subject (Cursor + 1), Str.all)
+ and then Is_In (Subject (Cursor + 1), S (1 .. L))
loop
Cursor := Cursor + 1;
end loop;
-- NSpan (string pointer case)
when PC_NSpan_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching NSpan", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching NSpan", S (1 .. L));
while Cursor < Length
- and then Is_In (Subject (Cursor + 1), Str.all)
+ and then Is_In (Subject (Cursor + 1), S (1 .. L))
loop
Cursor := Cursor + 1;
end loop;
-- Span (string function case)
when PC_Span_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
- P : Natural := Cursor;
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
+ P : Natural;
begin
- Dout (Img (Node) & "matching Span", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching Span", S (1 .. L));
+ P := Cursor;
while P < Length
- and then Is_In (Subject (P + 1), Str.all)
+ and then Is_In (Subject (P + 1), S (1 .. L))
loop
P := P + 1;
end loop;
-- Span (string pointer case)
when PC_Span_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
- P : Natural := Cursor;
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
+ P : Natural;
begin
- Dout (Img (Node) & "matching Span", Str.all);
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching Span", S (1 .. L));
+ P := Cursor;
while P < Length
- and then Is_In (Subject (P + 1), Str.all)
+ and then Is_In (Subject (P + 1), S (1 .. L))
loop
P := P + 1;
end loop;
-- String (function case)
when PC_String_VF => declare
- U : constant VString := Node.VF.all;
- Str : constant String_Access := Get_String (U);
- Len : constant Natural := Str'Length;
+ U : constant VString := Node.VF.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout (Img (Node) & "matching " & Image (Str.all));
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching " & Image (S (1 .. L)));
- if (Length - Cursor) >= Len
- and then Str.all = Subject (Cursor + 1 .. Cursor + Len)
+ if (Length - Cursor) >= L
+ and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
then
- Cursor := Cursor + Len;
+ Cursor := Cursor + L;
goto Succeed;
else
goto Fail;
-- String (vstring pointer case)
when PC_String_VP => declare
- S : String_Access := Get_String (Node.VP.all);
- Len : constant Natural :=
- Ada.Strings.Unbounded.Length (Node.VP.all);
+ U : constant VString := Node.VP.all;
+ S : String_Access;
+ L : Natural;
begin
- Dout
- (Img (Node) & "matching " & Image (S.all));
+ Get_String (U, S, L);
+ Dout (Img (Node) & "matching " & Image (S (1 .. L)));
- if (Length - Cursor) >= Len
- and then S.all = Subject (Cursor + 1 .. Cursor + Len)
+ if (Length - Cursor) >= L
+ and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
then
- Cursor := Cursor + Len;
+ Cursor := Cursor + L;
goto Succeed;
else
goto Fail;
-- match routine must end by executing a goto to the appropriate point
-- in the finite state machine model.
+ pragma Warnings (Off);
Logic_Error;
-
+ pragma Warnings (On);
end XMatchD;
end GNAT.Spitbol.Patterns;
OSDN Git Service
