+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- G N A T . S P I T B O L . P A T T E R N S --
--- --
--- B o d y --
--- --
--- $Revision: 1.2 $
--- --
--- Copyright (C) 1998-2001, Ada Core Technologies, Inc. --
--- --
--- 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- 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. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- 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). --
--- --
-------------------------------------------------------------------------------
-
--- Note: the data structures and general approach used in this implementation
--- are derived from the original MINIMAL sources for SPITBOL. The code is not
--- 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;
-
-package body GNAT.Spitbol.Patterns is
-
- ------------------------
- -- Internal Debugging --
- ------------------------
-
- Internal_Debug : constant Boolean := False;
- -- Set this flag to True to activate some built-in debugging traceback
- -- These are all lines output with PutD and Put_LineD.
-
- procedure New_LineD;
- pragma Inline (New_LineD);
- -- Output new blank line with New_Line if Internal_Debug is True
-
- procedure PutD (Str : String);
- pragma Inline (PutD);
- -- Output string with Put if Internal_Debug is True
-
- procedure Put_LineD (Str : String);
- pragma Inline (Put_LineD);
- -- Output string with Put_Line if Internal_Debug is True
-
- -----------------------------
- -- Local Type Declarations --
- -----------------------------
-
- 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);
- -- 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;
-
- --------------------------------------------------
- -- Description of Algorithm and Data Structures --
- --------------------------------------------------
-
- -- A pattern structure is represented as a linked graph of nodes
- -- with the following structure:
-
- -- +------------------------------------+
- -- I Pcode I
- -- +------------------------------------+
- -- I Index I
- -- +------------------------------------+
- -- I Pthen I
- -- +------------------------------------+
- -- I parameter(s) I
- -- +------------------------------------+
-
- -- Pcode is a code value indicating the type of the patterm 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.
-
- -- Index is a serial index number. The use of these serial index
- -- numbers is described in a separate section.
-
- -- 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.
-
- -- The parameter or parameters are present for certain node types,
- -- and the type varies with the pattern code.
-
- 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;
- -- Serial index number of pattern element within pattern.
-
- Pthen : PE_Ptr;
- -- Successor element, to be matched after this one
-
- 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;
- -- Range of pattern codes that has an Alt field. This is used in the
- -- recursive traversals, since these links must be followed.
-
- EOP_Element : aliased constant PE := (PC_EOP, 0, N);
- -- This is the end of pattern element, and is thus the representation of
- -- a null pattern. It has a zero index element since it is never placed
- -- inside a pattern. Furthermore it does not need a successor, since it
- -- marks the end of the pattern, so that no more successors are needed.
-
- EOP : constant PE_Ptr := EOP_Element'Unrestricted_Access;
- -- This is the end of pattern pointer, that is used in the Pthen pointer
- -- of other nodes to signal end of pattern.
-
- -- The following array is used to determine if a pattern used as an
- -- argument for Arbno is eligible for treatment using the simple Arbno
- -- 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);
-
- -------------------------------
- -- The Pattern History Stack --
- -------------------------------
-
- -- The pattern history stack is used for controlling backtracking when
- -- a match fails. The idea is to stack entries that give a cursor value
- -- to be restored, and a node to be reestablished as the current node to
- -- attempt an appropriate rematch operation. The processing for a pattern
- -- element that has rematch alternatives pushes an appropriate entry or
- -- entry on to the stack, and the proceeds. If a match fails at any point,
- -- the top element of the stack is popped off, resetting the cursor and
- -- the match continues by accessing the node stored with this entry.
-
- type Stack_Entry is record
-
- Cursor : Integer;
- -- Saved cursor value that is restored when this entry is popped
- -- from the stack if a match attempt fails. Occasionally, this
- -- field is used to store a history stack pointer instead of a
- -- cursor. Such cases are noted in the documentation and the value
- -- stored is negative since stack pointer values are always negative.
-
- Node : PE_Ptr;
- -- This pattern element reference is reestablished as the current
- -- Node to be matched (which will attempt an appropriate rematch).
-
- end record;
-
- subtype Stack_Range is Integer range -Stack_Size .. -1;
-
- type Stack_Type is array (Stack_Range) of Stack_Entry;
- -- The type used for a history stack. The actual instance of the stack
- -- is declared as a local variable in the Match routine, to properly
- -- handle recursive calls to Match. All stack pointer values are negative
- -- to distinguish them from normal cursor values.
-
- -- Note: the pattern matching stack is used only to handle backtracking.
- -- If no backtracking occurs, its entries are never accessed, and never
- -- popped off, and in particular it is normal for a successful match
- -- to terminate with entries on the stack that are simply discarded.
-
- -- Note: in subsequent diagrams of the stack, we always place element
- -- zero (the deepest element) at the top of the page, then build the
- -- stack down on the page with the most recent (top of stack) element
- -- being the bottom-most entry on the page.
-
- -- Stack checking is handled by labeling every pattern with the maximum
- -- number of stack entries that are required, so a single check at the
- -- start of matching the pattern suffices. There are two exceptions.
-
- -- First, the count does not include entries for recursive pattern
- -- references. Such recursions must therefore perform a specific
- -- stack check with respect to the number of stack entries required
- -- by the recursive pattern that is accessed and the amount of stack
- -- that remains unused.
-
- -- Second, the count includes only one iteration of an Arbno pattern,
- -- so a specific check must be made on subsequent iterations that there
- -- is still enough stack space left. The Arbno node has a field that
- -- records the number of stack entries required by its argument for
- -- this purpose.
-
- ---------------------------------------------------
- -- Use of Serial Index Field in Pattern Elements --
- ---------------------------------------------------
-
- -- The serial index numbers for the pattern elements are assigned as
- -- a pattern is consructed 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.
-
- -- The index numbers meet three separate invariants, which are used for
- -- various purposes as described in this section.
-
- -- First, the numbers uniquely identify the pattern elements within a
- -- pattern. If Num is the number of elements in a given pattern, then
- -- the serial index numbers for the elements of this pattern will range
- -- from 1 .. Num, so that each element has a separate value.
-
- -- The purpose of this assignment is to provide a convenient auxiliary
- -- data structure mechanism during operations which must traverse a
- -- 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
- -- 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.
-
- -- Second, the pattern element referenced directly, i.e. the leading
- -- pattern element, is always the maximum numbered element and therefore
- -- indicates the total number of elements in the pattern. More precisely,
- -- the element referenced by the P field of a pattern value, or the
- -- element returned by any of the internal pattern construction routines
- -- in the body (that return a value of type PE_Ptr) always is this
- -- maximum element,
-
- -- The purpose of this requirement is to allow an immediate determination
- -- of the number of pattern elements within a pattern. This is used to
- -- properly size the vectors used to contain auxiliary information for
- -- traversal as described above.
-
- -- 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
- -- 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
- -- numbering of each compound pattern structure.
-
- -- The purpose of specifying the stylized numbering structures for the
- -- compound patterns is to help simplify the processing in the Image
- -- function, since it eases the task of retrieving the original recursive
- -- structure of the pattern from the flat graph structure of elements.
- -- This use in the Image function is the only point at which the code
- -- makes use of the stylized structures.
-
- type Ref_Array is array (IndexT range <>) of PE_Ptr;
- -- This type is used to build an array whose N'th entry references the
- -- element in a pattern whose Index value is N. See Build_Ref_Array.
-
- procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array);
- -- Given a pattern element which is the leading element of a pattern
- -- structure, and a Ref_Array with bounds 1 .. E.Index, fills in the
- -- Ref_Array so that its N'th entry references the element of the
- -- referenced pattern whose Index value is N.
-
- -------------------------------
- -- Recursive Pattern Matches --
- -------------------------------
-
- -- The pattern primitive (+P) where P is a Pattern_Ptr or Pattern_Func
- -- causes a recursive pattern match. This cannot be handled by an actual
- -- recursive call to the outer level Match routine, since this would not
- -- allow for possible backtracking into the region matched by the inner
- -- pattern. Indeed this is the classical clash between recursion and
- -- backtracking, and a simple recursive stack structure does not suffice.
-
- -- This section describes how this recursion and the possible associated
- -- backtracking is handled. We still use a single stack, but we establish
- -- the concept of nested regions on this stack, each of which has a stack
- -- base value pointing to the deepest stack entry of the region. The base
- -- value for the outer level is zero.
-
- -- When a recursive match is established, two special stack entries are
- -- made. The first entry is used to save the original node that starts
- -- the recursive match. This is saved so that the successor field of
- -- this node is accessible at the end of the match, but it is never
- -- popped and executed.
-
- -- The second entry corresponds to a standard new region action. A
- -- PC_R_Remove node is stacked, whose cursor field is used to store
- -- the outer stack base, and the stack base is reset to point to
- -- this PC_R_Remove node. Then the recursive pattern is matched and
- -- it can make history stack entries in the normal matter, so now
- -- the stack looks like:
-
- -- (stack entries made by outer level)
-
- -- (Special entry, node is (+P) successor
- -- cursor entry is not used)
-
- -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack base
- -- saved base value for the enclosing region)
-
- -- (stack entries made by inner level)
-
- -- If a subsequent failure occurs and pops the PC_R_Remove node, it
- -- removes itself and the special entry immediately underneath it,
- -- restores the stack base value for the enclosing region, and then
- -- again signals failure to look for alternatives that were stacked
- -- before the recursion was initiated.
-
- -- Now we need to consider what happens if the inner pattern succeeds, as
- -- signalled by accessing the special PC_EOP pattern primitive. First we
- -- recognize the nested case by looking at the Base value. If this Base
- -- value is Stack'First, then the entire match has succeeded, but if the
- -- base value is greater than Stack'First, then we have successfully
- -- matched an inner pattern, and processing continues at the outer level.
-
- -- There are two cases. The simple case is when the inner pattern has made
- -- no stack entries, as recognized by the fact that the current stack
- -- pointer is equal to the current base value. In this case it is fine to
- -- remove all trace of the recursion by restoring the outer base value and
- -- using the special entry to find the appropriate successor node.
-
- -- The more complex case arises when the inner match does make stack
- -- entries. In this case, the PC_EOP processing stacks a special entry
- -- whose cursor value saves the saved inner base value (the one that
- -- references the corresponding PC_R_Remove value), and whose node
- -- pointer references a PC_R_Restore node, so the stack looks like:
-
- -- (stack entries made by outer level)
-
- -- (Special entry, node is (+P) successor,
- -- cursor entry is not used)
-
- -- (PC_R_Remove entry, "cursor" value is (negative)
- -- saved base value for the enclosing region)
-
- -- (stack entries made by inner level)
-
- -- (PC_Region_Replace entry, "cursor" value is (negative)
- -- stack pointer value referencing the PC_R_Remove entry).
-
- -- If the entire match succeeds, then these stack entries are, as usual,
- -- ignored and abandoned. If on the other hand a subsequent failure
- -- causes the PC_Region_Replace entry to be popped, it restores the
- -- inner base value from its saved "cursor" value and then fails again.
- -- Note that it is OK that the cursor is temporarily clobbered by this
- -- pop, since the second failure will reestablish a proper cursor value.
-
- ---------------------------------
- -- Compound Pattern Structures --
- ---------------------------------
-
- -- This section discusses the compound structures used to represent
- -- constructed patterns. It shows the graph structures of pattern
- -- elements that are constructed, and in the case of patterns that
- -- provide backtracking possibilities, describes how the history
- -- 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
- -- 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
- -- alternative pointer from the element above it to the element below
- -- it. See individual sections for details on how alternatives are used.
-
- -------------------
- -- Concatenation --
- -------------------
-
- -- In the pattern structures listed in this section, a line that looks
- -- lile ----> 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
- -- is obtained by finding all such EOP pointers in L, and replacing
- -- them to point to R. This is the most important flattening that
- -- 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
- -- successor is always at hand.
-
- -- Concatenation itself generates no additional possibilities for
- -- backtracking, but the constituent patterns of the concatenated
- -- structure will make stack entries as usual. The maximum amount
- -- of stack required by the structure is thus simply the sum of the
- -- maximums required by L and R.
-
- -- The index numbering of a concatenation structure works by leaving
- -- the numbering of the right hand pattern, R, unchanged and adjusting
- -- the numbers in the left hand pattern, L up by the count of elements
- -- in R. This ensures that the maximum numbered element is the leading
- -- element as required (given that it was the leading element in L).
-
- -----------------
- -- Alternation --
- -----------------
-
- -- A pattern (L or R) constructs the structure:
-
- -- +---+ +---+
- -- | A |---->| L |---->
- -- +---+ +---+
- -- .
- -- .
- -- +---+
- -- | R |---->
- -- +---+
-
- -- The A element here is a PC_Alt node, and the dotted line represents
- -- the contents of the Alt field. When the PC_Alt element is matched,
- -- 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
- -- 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.
-
- -- Note that the difference between the index of the L leading element
- -- the index of the R leading element (after building the alt structure)
- -- indicates the number of nodes in L, and this is true even after the
- -- structure is incorporated into some larger structure. For example,
- -- if the A node has index 16, and L has index 15 and R has index
- -- 5, then we know that L has 10 (15-5) elements in it.
-
- -- Suppose that we now concatenate this structure to another pattern
- -- with 9 elements in it. We will now have the A node with an index
- -- of 25, L with an index of 24 and R with an index of 14. We still
- -- know that L has 10 (24-14) elements in it, numbered 15-24, and
- -- consequently the successor of the alternation structure has an
- -- index with a value less than 15. This is used in Image to figure
- -- out the original recursive structure of a pattern.
-
- -- To clarify the interaction of the alternation and concatenation
- -- structures, here is a more complex example of the structure built
- -- for the pattern:
-
- -- (V or W or X) (Y or Z)
-
- -- where A,B,C,D,E are all single element patterns:
-
- -- +---+ +---+ +---+ +---+
- -- I A I---->I V I---+-->I A I---->I Y I---->
- -- +---+ +---+ I +---+ +---+
- -- . I .
- -- . I .
- -- +---+ +---+ I +---+
- -- I A I---->I W I-->I I Z I---->
- -- +---+ +---+ I +---+
- -- . I
- -- . I
- -- +---+ I
- -- I X I------------>+
- -- +---+
-
- -- The numbering of the nodes would be as follows:
-
- -- +---+ +---+ +---+ +---+
- -- I 8 I---->I 7 I---+-->I 3 I---->I 2 I---->
- -- +---+ +---+ I +---+ +---+
- -- . I .
- -- . I .
- -- +---+ +---+ I +---+
- -- I 6 I---->I 5 I-->I I 1 I---->
- -- +---+ +---+ I +---+
- -- . I
- -- . I
- -- +---+ I
- -- I 4 I------------>+
- -- +---+
-
- -- Note: The above structure actually corresponds to
-
- -- (A or (B or C)) (D or E)
-
- -- rather than
-
- -- ((A or B) or C) (D or E)
-
- -- which is the more natural interpretation, but in fact alternation
- -- is associative, and the construction of an alternative changes the
- -- left grouped pattern to the right grouped pattern in any case, so
- -- that the Image function produces a more natural looking output.
-
- ---------
- -- Arb --
- ---------
-
- -- An Arb pattern builds the structure
-
- -- +---+
- -- | X |---->
- -- +---+
- -- .
- -- .
- -- +---+
- -- | Y |---->
- -- +---+
-
- -- The X node is a PC_Arb_X node, which matches null, and stacks a
- -- 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.
-
- -------------------------
- -- Arbno (simple case) --
- -------------------------
-
- -- The simple form of Arbno can be used where the pattern always
- -- matches at least one character if it succeeds, and it is known
- -- not to make any history stack entries. In this case, Arbno (P)
- -- can construct the following structure:
-
- -- +-------------+
- -- | ^
- -- V |
- -- +---+ |
- -- | S |----> |
- -- +---+ |
- -- . |
- -- . |
- -- +---+ |
- -- | P |---------->+
- -- +---+
-
- -- The S (PC_Arbno_S) node matches null stacking a pointer to the
- -- pattern P. If a subsequent failure causes P to be matched and
- -- this match succeeds, then node A gets restacked to try another
- -- instance if needed by a subsequent failure.
-
- -- The node numbering of the constituent pattern P is not affected.
- -- The S node has a node number of P.Index + 1.
-
- --------------------------
- -- Arbno (complex case) --
- --------------------------
-
- -- A call to Arbno (P), where P can match null (or at least is not
- -- known to require a non-null string) and/or P requires pattern stack
- -- entries, constructs the following structure:
-
- -- +--------------------------+
- -- | ^
- -- V |
- -- +---+ |
- -- | X |----> |
- -- +---+ |
- -- . |
- -- . |
- -- +---+ +---+ +---+ |
- -- | E |---->| P |---->| Y |--->+
- -- +---+ +---+ +---+
-
- -- The node X (PC_Arbno_X) matches null, stacking a pointer to the
- -- E-P-X structure used to match one Arbno instance.
-
- -- Here E is the PC_R_Enter node which matches null and creates two
- -- stack entries. The first is a special entry whose node field is
- -- not used at all, and whose cursor field has the initial cursor.
-
- -- The second entry corresponds to a standard new region action. A
- -- PC_R_Remove node is stacked, whose cursor field is used to store
- -- the outer stack base, and the stack base is reset to point to
- -- this PC_R_Remove node. Then the pattern P is matched, and it can
- -- make history stack entries in the normal manner, so now the stack
- -- looks like:
-
- -- (stack entries made before assign pattern)
-
- -- (Special entry, node field not used,
- -- used only to save initial cursor)
-
- -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
- -- saved base value for the enclosing region)
-
- -- (stack entries made by matching P)
-
- -- If the match of P fails, then the PC_R_Remove entry is popped and
- -- it removes both itself and the special entry underneath it,
- -- restores the outer stack base, and signals failure.
-
- -- If the match of P succeeds, then node Y, the PC_Arbno_Y node, pops
- -- the inner region. There are two possibilities. If matching P left
- -- no stack entries, then all traces of the inner region can be removed.
- -- If there are stack entries, then we push an PC_Region_Replace stack
- -- entry whose "cursor" value is the inner stack base value, and then
- -- restore the outer stack base value, so the stack looks like:
-
- -- (stack entries made before assign pattern)
-
- -- (Special entry, node field not used,
- -- used only to save initial cursor)
-
- -- (PC_R_Remove entry, "cursor" value is (negative)
- -- saved base value for the enclosing region)
-
- -- (stack entries made by matching P)
-
- -- (PC_Region_Replace entry, "cursor" value is (negative)
- -- stack pointer value referencing the PC_R_Remove entry).
-
- -- Now that we have matched another instance of the Arbno pattern,
- -- we need to move to the successor. There are two cases. If the
- -- Arbno pattern matched null, then there is no point in seeking
- -- alternatives, since we would just match a whole bunch of nulls.
- -- In this case we look through the alternative node, and move
- -- directly to its successor (i.e. the successor of the Arbno
- -- pattern). If on the other hand a non-null string was matched,
- -- we simply follow the successor to the alternative node, which
- -- sets up for another possible match of the Arbno pattern.
-
- -- As noted in the section on stack checking, the stack count (and
- -- hence the stack check) for a pattern includes only one iteration
- -- of the Arbno pattern. To make sure that multiple iterations do not
- -- overflow the stack, the Arbno node saves the stack count required
- -- by a single iteration, and the Concat function increments this to
- -- include stack entries required by any successor. The PC_Arbno_Y
- -- node uses this count to ensure that sufficient stack remains
- -- before proceeding after matching each new instance.
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the Y node is numbered N + 1,
- -- the E node is N + 2, and the X node is N + 3.
-
- ----------------------
- -- Assign Immediate --
- ----------------------
-
- -- Immediate assignment (P * V) constructs the following structure
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| A |---->
- -- +---+ +---+ +---+
-
- -- Here E is the PC_R_Enter node which matches null and creates two
- -- stack entries. The first is a special entry whose node field is
- -- not used at all, and whose cursor field has the initial cursor.
-
- -- The second entry corresponds to a standard new region action. A
- -- PC_R_Remove node is stacked, whose cursor field is used to store
- -- the outer stack base, and the stack base is reset to point to
- -- this PC_R_Remove node. Then the pattern P is matched, and it can
- -- make history stack entries in the normal manner, so now the stack
- -- looks like:
-
- -- (stack entries made before assign pattern)
-
- -- (Special entry, node field not used,
- -- used only to save initial cursor)
-
- -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
- -- saved base value for the enclosing region)
-
- -- (stack entries made by matching P)
-
- -- If the match of P fails, then the PC_R_Remove entry is popped
- -- and it removes both itself and the special entry underneath it,
- -- restores the outer stack base, and signals failure.
-
- -- If the match of P succeeds, then node A, which is the actual
- -- PC_Assign_Imm node, executes the assignment (using the stack
- -- base to locate the entry with the saved starting cursor value),
- -- and the pops the inner region. There are two possibilities, if
- -- matching P left no stack entries, then all traces of the inner
- -- region can be removed. If there are stack entries, then we push
- -- an PC_Region_Replace stack entry whose "cursor" value is the
- -- inner stack base value, and then restore the outer stack base
- -- value, so the stack looks like:
-
- -- (stack entries made before assign pattern)
-
- -- (Special entry, node field not used,
- -- used only to save initial cursor)
-
- -- (PC_R_Remove entry, "cursor" value is (negative)
- -- saved base value for the enclosing region)
-
- -- (stack entries made by matching P)
-
- -- (PC_Region_Replace entry, "cursor" value is the (negative)
- -- stack pointer value referencing the PC_R_Remove entry).
-
- -- If a subsequent failure occurs, the PC_Region_Replace node restores
- -- the inner stack base value and signals failure to explore rematches
- -- of the pattern P.
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the A node is numbered N + 1,
- -- and the E node is N + 2.
-
- ---------------------
- -- Assign On Match --
- ---------------------
-
- -- The assign on match (**) pattern is quite similar to the assign
- -- immediate pattern, except that the actual assignment has to be
- -- delayed. The following structure is constructed:
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| A |---->
- -- +---+ +---+ +---+
-
- -- The operation of this pattern is identical to that described above
- -- for deferred assignment, up to the point where P has been matched.
-
- -- The A node, which is the PC_Assign_OnM node first pushes a
- -- PC_Assign node onto the history stack. This node saves the ending
- -- cursor and acts as a flag for the final assignment, as further
- -- 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
- -- of the variable to be assigned at the end of the pattern.
-
- -- After that the inner region is terminated in the usual manner,
- -- by stacking a PC_R_Restore entry as described for the assign
- -- immediate case. Note that the optimization of completely
- -- removing the inner region does not happen in this case, since
- -- we have at least one stack entry (the PC_Assign one we just made).
- -- The stack now looks like:
-
- -- (stack entries made before assign pattern)
-
- -- (Special entry, node points to copy of
- -- the PC_Assign_OnM node, and the
- -- cursor field saves the initial cursor).
-
- -- (PC_R_Remove entry, "cursor" value is (negative)
- -- saved base value for the enclosing region)
-
- -- (stack entries made by matching P)
-
- -- (PC_Assign entry, saves final cursor)
-
- -- (PC_Region_Replace entry, "cursor" value is (negative)
- -- stack pointer value referencing the PC_R_Remove entry).
-
- -- If a subsequent failure causes the PC_Assign node to execute it
- -- simply removes itself and propagates the failure.
-
- -- If the match succeeds, then the history stack is scanned for
- -- PC_Assign nodes, and the assignments are executed (examination
- -- of the above diagram will show that all the necessary data is
- -- at hand for the assignment).
-
- -- To optimize the common case where no assign-on-match operations
- -- are present, a global flag Assign_OnM is maintained which is
- -- initialize to False, and gets set True as part of the execution
- -- of the PC_Assign_OnM node. The scan of the history stack for
- -- PC_Assign entries is done only if this flag is set.
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the A node is numbered N + 1,
- -- and the E node is N + 2.
-
- ---------
- -- Bal --
- ---------
-
- -- Bal builds a single node:
-
- -- +---+
- -- | B |---->
- -- +---+
-
- -- The node B is the PC_Bal node which matches a parentheses balanced
- -- 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.
-
- -- Since this is a single node it is numbered 1 (the reason we include
- -- it in the compound patterns section is that it backtracks).
-
- ------------
- -- BreakX --
- ------------
-
- -- BreakX builds the structure
-
- -- +---+ +---+
- -- | B |---->| A |---->
- -- +---+ +---+
- -- ^ .
- -- | .
- -- | +---+
- -- +<------| X |
- -- +---+
-
- -- Here the B node is the BreakX_xx node that performs a normal Break
- -- function. The A node is an alternative (PC_Alt) node that matches
- -- null, but stacks a pointer to node X (the PC_BreakX_X node) which
- -- extends the match one character (to eat up the previously detected
- -- break character), and then rematches the break.
-
- -- The B node is numbered 3, the alternative node is 1, and the X
- -- node is 2.
-
- -----------
- -- Fence --
- -----------
-
- -- Fence builds a single node:
-
- -- +---+
- -- | F |---->
- -- +---+
-
- -- The element F, PC_Fence, matches null, and stacks a pointer to a
- -- PC_Cancel element which will abort the match on a subsequent failure.
-
- -- Since this is a single element it is numbered 1 (the reason we
- -- include it in the compound patterns section is that it backtracks).
-
- --------------------
- -- Fence Function --
- --------------------
-
- -- A call to the Fence function builds the structure:
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| X |---->
- -- +---+ +---+ +---+
-
- -- Here E is the PC_R_Enter node which matches null and creates two
- -- stack entries. The first is a special entry which is not used at
- -- all in the fence case (it is present merely for uniformity with
- -- other cases of region enter operations).
-
- -- The second entry corresponds to a standard new region action. A
- -- PC_R_Remove node is stacked, whose cursor field is used to store
- -- the outer stack base, and the stack base is reset to point to
- -- this PC_R_Remove node. Then the pattern P is matched, and it can
- -- make history stack entries in the normal manner, so now the stack
- -- looks like:
-
- -- (stack entries made before fence pattern)
-
- -- (Special entry, not used at all)
-
- -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
- -- saved base value for the enclosing region)
-
- -- (stack entries made by matching P)
-
- -- If the match of P fails, then the PC_R_Remove entry is popped
- -- and it removes both itself and the special entry underneath it,
- -- restores the outer stack base, and signals failure.
-
- -- If the match of P succeeds, then node X, the PC_Fence_X node, gets
- -- control. One might be tempted to think that at this point, the
- -- history stack entries made by matching P can just be removed since
- -- they certainly are not going to be used for rematching (that is
- -- whole point of Fence after all!) However, this is wrong, because
- -- it would result in the loss of possible assign-on-match entries
- -- for deferred pattern assignments.
-
- -- Instead what we do is to make a special entry whose node references
- -- PC_Fence_Y, and whose cursor saves the inner stack base value, i.e.
- -- the pointer to the PC_R_Remove entry. Then the outer stack base
- -- pointer is restored, so the stack looks like:
-
- -- (stack entries made before assign pattern)
-
- -- (Special entry, not used at all)
-
- -- (PC_R_Remove entry, "cursor" value is (negative)
- -- saved base value for the enclosing region)
-
- -- (stack entries made by matching P)
-
- -- (PC_Fence_Y entry, "cursor" value is (negative) stack
- -- pointer value referencing the PC_R_Remove entry).
-
- -- If a subsequent failure occurs, then the PC_Fence_Y entry removes
- -- the entire inner region, including all entries made by matching P,
- -- and alternatives prior to the Fence pattern are sought.
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the X node is numbered N + 1,
- -- and the E node is N + 2.
-
- -------------
- -- Succeed --
- -------------
-
- -- Succeed builds a single node:
-
- -- +---+
- -- | S |---->
- -- +---+
-
- -- The node S is the PC_Succeed node which matches null, and stacks
- -- a pointer to itself on the history stack, so that a subsequent
- -- failure repeats the same match.
-
- -- Since this is a single node it is numbered 1 (the reason we include
- -- it in the compound patterns section is that it backtracks).
-
- ---------------------
- -- Write Immediate --
- ---------------------
-
- -- The structure built for a write immediate operation (P * F, where
- -- F is a file access value) is:
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| W |---->
- -- +---+ +---+ +---+
-
- -- Here E is the PC_R_Enter node and W is the PC_Write_Imm node. The
- -- handling is identical to that described above for Assign Immediate,
- -- except that at the point where a successful match occurs, the matched
- -- substring is written to the referenced file.
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the W node is numbered N + 1,
- -- and the E node is N + 2.
-
- --------------------
- -- Write On Match --
- --------------------
-
- -- The structure built for a write on match operation (P ** F, where
- -- F is a file access value) is:
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| W |---->
- -- +---+ +---+ +---+
-
- -- Here E is the PC_R_Enter node and W is the PC_Write_OnM node. The
- -- handling is identical to that described above for Assign On Match,
- -- except that at the point where a successful match has completed,
- -- the matched substring is written to the referenced file.
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the W node is numbered N + 1,
- -- and the E node is N + 2.
- -----------------------
- -- Constant Patterns --
- -----------------------
-
- -- 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
- -- need for a successor and no need for a node number
-
- 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);
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Alternate (L, R : PE_Ptr) return PE_Ptr;
- function "or" (L, R : PE_Ptr) return PE_Ptr renames Alternate;
- -- Build pattern structure corresponding to the alternation of L, R.
- -- (i.e. try to match L, and if that fails, try to match R).
-
- function Arbno_Simple (P : PE_Ptr) return PE_Ptr;
- -- Build simple Arbno pattern, P is a pattern that is guaranteed to
- -- match at least one character if it succeeds and to require no
- -- stack entries under all circumstances. The result returned is
- -- a simple Arbno structure as previously described.
-
- function Bracket (E, P, A : PE_Ptr) return PE_Ptr;
- -- Given two single node pattern elements E and A, and a (possible
- -- complex) pattern P, construct the concatenation E-->P-->A and
- -- return a pointer to E. The concatenation does not affect the
- -- node numbering in P. A has a number one higher than the maximum
- -- number in P, and E has a number two higher than the maximum
- -- number in P (see for example the Assign_Immediate structure to
- -- 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
- -- 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
- -- 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
- -- procedure does not copy L or R, so if a copy is required, it
- -- is the responsibility of the caller. The Incr parameter is an
- -- amount to be added to the Nat field of any P_Arbno_Y node that is
- -- 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 Copy (P : PE_Ptr) return PE_Ptr;
- -- Creates a copy of the pattern element referenced by the given
- -- pattern element reference. This is a deep copy, which means that
- -- it follows the Next and Alt pointers.
-
- function Image (P : PE_Ptr) return String;
- -- Returns the image of the address of the referenced pattern element.
- -- This is equivalent to Image (To_Address (P));
-
- function Is_In (C : Character; Str : String) return Boolean;
- pragma Inline (Is_In);
- -- Determines if the character C is in string Str.
-
- procedure Logic_Error;
- -- Called to raise Program_Error with an appropriate message if an
- -- internal logic error is detected.
-
- 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;
- -- These are debugging routines, which return a representation of the
- -- given access value (they are called only by Image and Dump)
-
- procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr);
- -- Adjusts all EOP pointers in Pat to point to Succ. No other changes
- -- are made. In particular, Succ is unchanged, and no index numbers
- -- are modified. Note that Pat may not be equal to EOP on entry.
-
- function S_To_PE (Str : PString) return PE_Ptr;
- -- Given a string, constructs a pattern element that matches the string
-
- procedure Uninitialized_Pattern;
- pragma No_Return (Uninitialized_Pattern);
- -- Called to raise Program_Error with an appropriate error message if
- -- an uninitialized pattern is used in any pattern construction or
- -- pattern matching operation.
-
- procedure XMatch
- (Subject : String;
- Pat_P : PE_Ptr;
- Pat_S : Natural;
- Start : out Natural;
- Stop : out Natural);
- -- This is the common pattern match routine. It is passed a string and
- -- a pattern, and it indicates success or failure, and on success the
- -- section of the string matched. It does not perform any assignments
- -- to the subject string, so pattern replacement is for the caller.
- --
- -- Subject The subject string. The lower bound is always one. In the
- -- Match procedures, it is fine to use strings whose lower bound
- -- is not one, but we perform a one time conversion before the
- -- call to XMatch, so that XMatch does not have to be bothered
- -- with strange lower bounds.
- --
- -- Pat_P Points to initial pattern element of pattern to be matched
- --
- -- Pat_S Maximum required stack entries for pattern to be matched
- --
- -- Start If match is successful, starting index of matched section.
- -- This value is always non-zero. A value of zero is used to
- -- indicate a failed match.
- --
- -- Stop If match is successful, ending index of matched section.
- -- This can be zero if we match the null string at the start,
- -- in which case Start is set to zero, and Stop to one. If the
- -- Match fails, then the contents of Stop is undefined.
-
- procedure XMatchD
- (Subject : String;
- Pat_P : PE_Ptr;
- Pat_S : Natural;
- Start : out Natural;
- Stop : out Natural);
- -- Identical in all respects to XMatch, except that trace information is
- -- output on Standard_Output during execution of the match. This is the
- -- version that is called if the original Match call has Debug => True.
-
- ---------
- -- "&" --
- ---------
-
- 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 "&" (L, R : PE_Ptr) return PE_Ptr is
- begin
- return Concat (L, R, 0);
- end "&";
-
- ---------
- -- "*" --
- ---------
-
- -- Assign immediate
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| A |---->
- -- +---+ +---+ +---+
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the A node is numbered N + 1,
- -- and the E node is N + 2.
-
- 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 "*";
-
- -- Write immediate
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| W |---->
- -- +---+ +---+ +---+
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the W node is numbered N + 1,
- -- and the E node is N + 2.
-
- 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 "*";
-
- ----------
- -- "**" --
- ----------
-
- -- Assign on match
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| A |---->
- -- +---+ +---+ +---+
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the A node is numbered N + 1,
- -- and the E node is N + 2.
-
- 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 "**";
-
- -- Write on match
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| W |---->
- -- +---+ +---+ +---+
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the W node is numbered N + 1,
- -- and the E node is N + 2.
-
- 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 "+";
-
- ----------
- -- "or" --
- ----------
-
- 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";
-
- ------------
- -- Adjust --
- ------------
-
- -- No two patterns share the same pattern elements, so the adjust
- -- procedure for a Pattern assignment must do a deep copy of the
- -- pattern element structure.
-
- procedure Adjust (Object : in out Pattern) is
- begin
- Object.P := Copy (Object.P);
- end Adjust;
-
- ---------------
- -- Alternate --
- ---------------
-
- function Alternate (L, R : PE_Ptr) return PE_Ptr is
- begin
- -- If the left pattern is null, then we just add the alternation
- -- node with an index one greater than the right hand pattern.
-
- if L = EOP then
- 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
- -- the right hand elements. Then add the alternation node.
-
- 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;
-
- ---------
- -- Any --
- ---------
-
- 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;
-
- ---------
- -- Arb --
- ---------
-
- -- +---+
- -- | X |---->
- -- +---+
- -- .
- -- .
- -- +---+
- -- | Y |---->
- -- +---+
-
- -- 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;
-
- -----------
- -- Arbno --
- -----------
-
- 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;
-
- -- This is the complex case, either the pattern makes stack entries
- -- or it is possible for the pattern to match the null string (more
- -- accurately, we don't know that this is not the case).
-
- -- +--------------------------+
- -- | ^
- -- V |
- -- +---+ |
- -- | X |----> |
- -- +---+ |
- -- . |
- -- . |
- -- +---+ +---+ +---+ |
- -- | E |---->| P |---->| Y |--->+
- -- +---+ +---+ +---+
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the Y node is numbered N + 1,
- -- the E node is N + 2, and the X node is N + 3.
-
- 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;
-
- ------------------
- -- Arbno_Simple --
- ------------------
-
- -- +-------------+
- -- | ^
- -- V |
- -- +---+ |
- -- | S |----> |
- -- +---+ |
- -- . |
- -- . |
- -- +---+ |
- -- | P |---------->+
- -- +---+
-
- -- The node numbering of the constituent pattern P is not affected.
- -- The S node has a node number of P.Index + 1.
-
- -- Note that we know that P cannot be EOP, because a null pattern
- -- does not meet the requirements for simple 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;
-
- ---------
- -- Bal --
- ---------
-
- function Bal return Pattern is
- begin
- return (AFC with 1, new PE'(PC_Bal, 1, EOP));
- end Bal;
-
- -------------
- -- Bracket --
- -------------
-
- 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;
-
- -----------
- -- Break --
- -----------
-
- 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;
-
- ------------
- -- BreakX --
- ------------
-
- 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;
-
- -----------------
- -- BreakX_Make --
- -----------------
-
- -- +---+ +---+
- -- | B |---->| A |---->
- -- +---+ +---+
- -- ^ .
- -- | .
- -- | +---+
- -- +<------| X |
- -- +---+
-
- -- The B node is numbered 3, the alternative node is 1, and the X
- -- node is 2.
-
- 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;
-
- ---------------------
- -- Build_Ref_Array --
- ---------------------
-
- procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array) is
-
- procedure Record_PE (E : PE_Ptr);
- -- Record given pattern element if not already recorded in RA,
- -- and also record any referenced pattern elements recursively.
-
- 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;
-
- -- Start of processing for Build_Ref_Array
-
- begin
- New_LineD;
- Put_LineD ("Entering Build_Ref_Array");
- Record_PE (E);
- New_LineD;
- end Build_Ref_Array;
-
- -------------
- -- C_To_PE --
- -------------
-
- function C_To_PE (C : PChar) return PE_Ptr is
- begin
- return new PE'(PC_Char, 1, EOP, C);
- end C_To_PE;
-
- ------------
- -- Cancel --
- ------------
-
- function Cancel return Pattern is
- begin
- return (AFC with 0, new PE'(PC_Cancel, 1, EOP));
- end Cancel;
-
- ------------
- -- Concat --
- ------------
-
- -- Concat needs to traverse the left operand performing the following
- -- set of fixups:
-
- -- a) Any successor pointers (Pthen fields) that are set to EOP are
- -- reset to point to the second operand.
-
- -- b) Any PC_Arbno_Y node has its stack count field incremented
- -- by the parameter Incr provided for this purpose.
-
- -- d) Num fields of all pattern elements in the left operand are
- -- adjusted to include the elements of the right operand.
-
- -- Note: we do not use Set_Successor in the processing for Concat, since
- -- there is no point in doing two traversals, we may as well do everything
- -- at the same time.
-
- 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);
- -- We build a reference array for L whose N'th element points to
- -- the pattern element of L whose original Index value is N.
-
- 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;
-
- ----------
- -- Copy --
- ----------
-
- function Copy (P : PE_Ptr) return PE_Ptr is
- begin
- if P = null then
- Uninitialized_Pattern;
-
- else
- declare
- Refs : Ref_Array (1 .. P.Index);
- -- 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.
-
- E : PE_Ptr;
-
- begin
- Build_Ref_Array (P, Refs);
-
- -- Now copy all nodes
-
- for J in Refs'Range loop
- Copy (J) := new PE'(Refs (J).all);
- end loop;
-
- -- Adjust all internal references
-
- for J in Copy'Range loop
- E := Copy (J);
-
- -- Adjust successor pointer to point to copy
-
- if E.Pthen /= EOP then
- E.Pthen := Copy (E.Pthen.Index);
- end if;
-
- -- Adjust Alt pointer if there is one to point to copy
-
- if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then
- E.Alt := Copy (E.Alt.Index);
- end if;
-
- -- Copy referenced string
-
- 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;
-
- ----------
- -- Dump --
- ----------
-
- procedure Dump (P : Pattern) is
-
- subtype Count is Ada.Text_IO.Count;
- Scol : Count;
- -- Used to keep track of column in dump output
-
- Refs : Ref_Array (1 .. P.P.Index);
- -- We build a reference array whose N'th element points to the
- -- pattern element whose Index value is N.
-
- Cols : Natural := 2;
- -- Number of columns used for pattern numbers, minimum is 2
-
- E : PE_Ptr;
-
- procedure Write_Node_Id (E : PE_Ptr);
- -- Writes out a string identifying the given pattern element.
-
- 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 uninitialized pattern, dump line and we are done
-
- if P.P = null then
- Put_Line ("Uninitialized pattern value");
- return;
- end if;
-
- -- If null pattern, just dump it and we are all done
-
- if P.P = EOP then
- Put_Line ("EOP (null pattern)");
- return;
- end if;
-
- Build_Ref_Array (P.P, Refs);
-
- -- Set number of columns required for node numbers
-
- while 10 ** Cols - 1 < Integer (P.P.Index) loop
- Cols := Cols + 1;
- end loop;
-
- -- Now dump the nodes in reverse sequence. We output them in reverse
- -- sequence since this corresponds to the natural order used to
- -- construct the patterns.
-
- 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;
-
- ----------
- -- Fail --
- ----------
-
- function Fail return Pattern is
- begin
- return (AFC with 0, new PE'(PC_Fail, 1, EOP));
- end Fail;
-
- -----------
- -- Fence --
- -----------
-
- -- Simple case
-
- function Fence return Pattern is
- begin
- return (AFC with 1, new PE'(PC_Fence, 1, EOP));
- end Fence;
-
- -- Function case
-
- -- +---+ +---+ +---+
- -- | E |---->| P |---->| X |---->
- -- +---+ +---+ +---+
-
- -- The node numbering of the constituent pattern P is not affected.
- -- Where N is the number of nodes in P, the X node is numbered N + 1,
- -- and the E node is N + 2.
-
- 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;
-
- --------------
- -- Finalize --
- --------------
-
- 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
- -- Nothing to do if already freed
-
- if Object.P = null then
- return;
-
- -- Otherwise we must free all elements
-
- else
- declare
- Refs : Ref_Array (1 .. Object.P.Index);
- -- References to elements in pattern to be finalized
-
- 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;
-
- -----------
- -- Image --
- -----------
-
- 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;
- -- Set True to delete next & to be output to Result
-
- Result : VString := Nul;
- -- The result is accumulated here, using Append
-
- Refs : Ref_Array (1 .. P.P.Index);
- -- We build a reference array whose N'th element points to the
- -- pattern element whose Index value is N.
-
- procedure Delete_Ampersand;
- -- Deletes the ampersand at the end of Result
-
- procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean);
- -- E refers to a pattern structure whose successor is given by Succ.
- -- This procedure appends to Result a representation of this pattern.
- -- The Paren parameter indicates whether parentheses are required if
- -- the output is more than one element.
-
- procedure Image_One (E : in out PE_Ptr);
- -- E refers to a pattern structure. This procedure appends to Result
- -- a representation of the single simple or compound pattern structure
- -- at the start of E and updates E to point to its successor.
-
- ----------------------
- -- Delete_Ampersand --
- ----------------------
-
- procedure Delete_Ampersand is
- L : Natural := Length (Result);
-
- begin
- if L > 2 then
- Delete (Result, L - 1, L);
- end if;
- end Delete_Ampersand;
-
- ---------------
- -- Image_One --
- ---------------
-
- procedure Image_One (E : in out PE_Ptr) is
-
- ER : PE_Ptr := E.Pthen;
- -- Successor set as result in E unless reset
-
- 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;
- -- 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
-
- E1 : PE_Ptr;
-
- begin
- -- The successor of the alternation node must have a lower
- -- index than any node that is in the left pattern or a
- -- higher index than the alternation node itself.
-
- 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;
-
- -- Other pattern codes should not appear as leading elements
-
- 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;
-
- ---------------
- -- Image_Seq --
- ---------------
-
- procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is
- E1 : PE_Ptr := E;
- Mult : Boolean := False;
- Indx : Natural := Length (Result);
-
- begin
- -- The image of EOP is "" (the null string)
-
- if E = EOP then
- Append (Result, """""");
-
- -- Else generate appropriate concatenation sequence
-
- 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;
-
- -- Start of processing for Image
-
- begin
- Build_Ref_Array (P.P, Refs);
- Image_Seq (P.P, EOP, False);
- return Result;
- end Image;
-
- -----------
- -- Is_In --
- -----------
-
- 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;
-
- ---------
- -- Len --
- ---------
-
- function Len (Count : Natural) return Pattern is
- begin
- -- Note, the following is not just an optimization, it is needed
- -- to ensure that Arbno (Len (0)) does not generate an infinite
- -- matching loop (since PC_Len_Nat is OK_For_Simple_Arbno).
-
- 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;
-
- -----------------
- -- Logic_Error --
- -----------------
-
- procedure Logic_Error is
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Internal logic error in GNAT.Spitbol.Patterns");
- end Logic_Error;
-
- -----------
- -- Match --
- -----------
-
- 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;
-
- ---------------
- -- New_LineD --
- ---------------
-
- procedure New_LineD is
- begin
- if Internal_Debug then
- New_Line;
- end if;
- end New_LineD;
-
- ------------
- -- NotAny --
- ------------
-
- 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;
-
- -----------
- -- NSpan --
- -----------
-
- 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;
-
- ---------
- -- Pos --
- ---------
-
- 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;
-
- ----------
- -- PutD --
- ----------
-
- procedure PutD (Str : String) is
- begin
- if Internal_Debug then
- Put (Str);
- end if;
- end PutD;
-
- ---------------
- -- Put_LineD --
- ---------------
-
- procedure Put_LineD (Str : String) is
- begin
- if Internal_Debug then
- Put_Line (Str);
- end if;
- end Put_LineD;
-
- -------------
- -- Replace --
- -------------
-
- 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;
-
- ----------
- -- Rest --
- ----------
-
- function Rest return Pattern is
- begin
- return (AFC with 0, new PE'(PC_Rest, 1, EOP));
- end Rest;
-
- ----------
- -- Rpos --
- ----------
-
- 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;
-
- ----------
- -- Rtab --
- ----------
-
- 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;
-
- -------------
- -- S_To_PE --
- -------------
-
- 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;
-
- -------------------
- -- Set_Successor --
- -------------------
-
- -- Note: this procedure is not used by the normal concatenation circuit,
- -- since other fixups are required on the left operand in this case, and
- -- they might as well be done all together.
-
- 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);
- -- We build a reference array for L whose N'th element points to
- -- the pattern element of L whose original Index value is N.
-
- 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;
-
- ------------
- -- Setcur --
- ------------
-
- function Setcur (Var : access Natural) return Pattern is
- begin
- return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var)));
- end Setcur;
-
- ----------
- -- Span --
- ----------
-
- 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;
-
- ------------
- -- Str_BF --
- ------------
-
- 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;
-
- ------------
- -- Str_FP --
- ------------
-
- function Str_FP (A : File_Ptr) return String is
- begin
- return "FP(" & Image (A.all'Address) & ')';
- end Str_FP;
-
- ------------
- -- Str_NF --
- ------------
-
- 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;
-
- ------------
- -- Str_NP --
- ------------
-
- function Str_NP (A : Natural_Ptr) return String is
- begin
- return "NP(" & Image (A.all'Address) & ')';
- end Str_NP;
-
- ------------
- -- Str_PP --
- ------------
-
- function Str_PP (A : Pattern_Ptr) return String is
- begin
- return "PP(" & Image (A.all'Address) & ')';
- end Str_PP;
-
- ------------
- -- Str_VF --
- ------------
-
- 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;
-
- ------------
- -- Str_VP --
- ------------
-
- function Str_VP (A : VString_Ptr) return String is
- begin
- return "VP(" & Image (A.all'Address) & ')';
- end Str_VP;
-
- -------------
- -- Succeed --
- -------------
-
- function Succeed return Pattern is
- begin
- return (AFC with 1, new PE'(PC_Succeed, 1, EOP));
- end Succeed;
-
- ---------
- -- Tab --
- ---------
-
- 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;
-
- ---------------------------
- -- Uninitialized_Pattern --
- ---------------------------
-
- procedure Uninitialized_Pattern is
- begin
- Raise_Exception
- (Program_Error'Identity,
- "uninitialized value of type GNAT.Spitbol.Patterns.Pattern");
- end Uninitialized_Pattern;
-
- ------------
- -- XMatch --
- ------------
-
- procedure XMatch
- (Subject : String;
- Pat_P : PE_Ptr;
- Pat_S : Natural;
- Start : out Natural;
- Stop : out Natural)
- is
- Node : PE_Ptr;
- -- Pointer to current pattern node. Initialized from Pat_P, and then
- -- updated as the match proceeds through its constituent elements.
-
- Length : constant Natural := Subject'Length;
- -- Length of string (= Subject'Last, since Subject'First is always 1)
-
- Cursor : Integer := 0;
- -- If the value is non-negative, then this value is the index showing
- -- the current position of the match in the subject string. The next
- -- character to be matched is at Subject (Cursor + 1). Note that since
- -- our view of the subject string in XMatch always has a lower bound
- -- of one, regardless of original bounds, that this definition exactly
- -- corresponds to the cursor value as referenced by functions like Pos.
- --
- -- If the value is negative, then this is a saved stack pointer,
- -- typically a base pointer of an inner or outer region. Cursor
- -- temporarily holds such a value when it is popped from the stack
- -- by Fail. In all cases, Cursor is reset to a proper non-negative
- -- cursor value before the match proceeds (e.g. by propagating the
- -- 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.
-
- Stack : Stack_Type;
- -- The pattern matching failure stack for this call to Match
-
- Stack_Ptr : Stack_Range;
- -- Current stack pointer. This points to the top element of the stack
- -- that is currently in use. At the outer level this is the special
- -- entry placed on the stack according to the anchor mode.
-
- Stack_Init : constant Stack_Range := Stack'First + 1;
- -- This is the initial value of the Stack_Ptr and Stack_Base. The
- -- initial (Stack'First) element of the stack is not used so that
- -- when we pop the last element off, Stack_Ptr is still in range.
-
- Stack_Base : Stack_Range;
- -- This value is the stack base value, i.e. the stack pointer for the
- -- first history stack entry in the current stack region. See separate
- -- section on handling of recursive pattern matches.
-
- Assign_OnM : Boolean := False;
- -- Set True if assign-on-match or write-on-match operations may be
- -- present in the history stack, which must then be scanned on a
- -- successful match.
-
- procedure Pop_Region;
- pragma Inline (Pop_Region);
- -- 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
-
- procedure Push_Region;
- pragma Inline (Push_Region);
- -- This procedure makes a new region on the history stack. The
- -- caller first establishes the special entry on the stack, but
- -- does not push the stack pointer. Then this call stacks a
- -- PC_Remove_Region node, on top of this entry, using the cursor
- -- field of the PC_Remove_Region entry to save the outer level
- -- stack base value, and resets the stack base to point to this
- -- PC_Remove_Region node.
-
- ----------------
- -- Pop_Region --
- ----------------
-
- procedure Pop_Region is
- begin
- -- If nothing was pushed in the inner region, we can just get
- -- rid of it entirely, leaving no traces that it was ever there
-
- if Stack_Ptr = Stack_Base then
- Stack_Ptr := Stack_Base - 2;
- Stack_Base := Stack (Stack_Ptr + 2).Cursor;
-
- -- If stuff was pushed in the inner region, then we have to
- -- push a PC_R_Restore node so that we properly handle possible
- -- rematches within the region.
-
- 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;
-
- ----------
- -- Push --
- ----------
-
- procedure Push (Node : PE_Ptr) is
- begin
- Stack_Ptr := Stack_Ptr + 1;
- Stack (Stack_Ptr).Cursor := Cursor;
- Stack (Stack_Ptr).Node := Node;
- end Push;
-
- -----------------
- -- Push_Region --
- -----------------
-
- 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;
-
- -- Start of processing for XMatch
-
- begin
- if Pat_P = null then
- Uninitialized_Pattern;
- end if;
-
- -- Check we have enough stack for this pattern. This check deals with
- -- every possibility except a match of a recursive pattern, where we
- -- make a check at each recursion level.
-
- if Pat_S >= Stack_Size - 1 then
- raise Pattern_Stack_Overflow;
- end if;
-
- -- In anchored mode, the bottom entry on the stack is an abort entry
-
- if Anchored_Mode then
- Stack (Stack_Init).Node := CP_Cancel'Access;
- Stack (Stack_Init).Cursor := 0;
-
- -- In unanchored more, the bottom entry on the stack references
- -- the special pattern element PE_Unanchored, whose Pthen field
- -- points to the initial pattern element. The cursor value in this
- -- entry is the number of anchor moves so far.
-
- 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;
-
- -----------------------------------------
- -- Main Pattern Matching State Control --
- -----------------------------------------
-
- -- This is a state machine which uses gotos to change state. The
- -- initial state is Match, to initiate the matching of the first
- -- element, so the goto Match above starts the match. In the
- -- following descriptions, we indicate the global values that
- -- are relevant for the state transition.
-
- -- Come here if entire match fails
-
- <<Match_Fail>>
- Start := 0;
- Stop := 0;
- return;
-
- -- Come here if entire match succeeds
-
- -- Cursor current position in subject string
-
- <<Match_Succeed>>
- Start := Stack (Stack_Init).Cursor + 1;
- Stop := Cursor;
-
- -- Scan history stack for deferred assignments or writes
-
- 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;
-
- -- Come here if attempt to match current element fails
-
- -- Stack_Base current stack base
- -- Stack_Ptr current stack pointer
-
- <<Fail>>
- Cursor := Stack (Stack_Ptr).Cursor;
- Node := Stack (Stack_Ptr).Node;
- Stack_Ptr := Stack_Ptr - 1;
- goto Match;
-
- -- Come here if attempt to match current element succeeds
-
- -- Cursor current position in subject string
- -- Node pointer to node successfully matched
- -- Stack_Base current stack base
- -- Stack_Ptr current stack pointer
-
- <<Succeed>>
- Node := Node.Pthen;
-
- -- Come here to match the next pattern element
-
- -- Cursor current position in subject string
- -- Node pointer to node to be matched
- -- Stack_Base current stack base
- -- Stack_Ptr current stack pointer
-
- <<Match>>
-
- --------------------------------------------------
- -- Main Pattern Match Element Matching Routines --
- --------------------------------------------------
-
- -- Here is the case statement that processes the current node. The
- -- processing for each element does one of five things:
-
- -- goto Succeed to move to the successor
- -- goto Match_Succeed if the entire match succeeds
- -- goto Match_Fail if the entire match fails
- -- goto Fail to signal failure of current match
-
- -- Processing is NOT allowed to fall through
-
- case Node.Pcode is
-
- -- Cancel
-
- when PC_Cancel =>
- goto Match_Fail;
-
- -- Alternation
-
- when PC_Alt =>
- Push (Node.Alt);
- Node := Node.Pthen;
- goto Match;
-
- -- Any (one character case)
-
- 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;
-
- -- Any (character set case)
-
- 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;
-
- -- Any (string function case)
-
- 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;
-
- -- Any (string pointer case)
-
- 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;
-
- -- Arb (initial match)
-
- when PC_Arb_X =>
- Push (Node.Alt);
- Node := Node.Pthen;
- goto Match;
-
- -- Arb (extension)
-
- when PC_Arb_Y =>
- if Cursor < Length then
- Cursor := Cursor + 1;
- Push (Node);
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- Arbno_S (simple Arbno initialize). This is the node that
- -- initiates the match of a simple Arbno structure.
-
- when PC_Arbno_S =>
- Push (Node.Alt);
- Node := Node.Pthen;
- goto Match;
-
- -- Arbno_X (Arbno initialize). This is the node that initiates
- -- the match of a complex Arbno structure.
-
- when PC_Arbno_X =>
- Push (Node.Alt);
- Node := Node.Pthen;
- goto Match;
-
- -- Arbno_Y (Arbno rematch). This is the node that is executed
- -- following successful matching of one instance of a complex
- -- Arbno pattern.
-
- when PC_Arbno_Y => declare
- Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor);
-
- begin
- Pop_Region;
-
- -- If arbno extension matched null, then immediately fail
-
- if Null_Match then
- goto Fail;
- end if;
-
- -- Here we must do a stack check to make sure enough stack
- -- is left. This check will happen once for each instance of
- -- the Arbno pattern that is matched. The Nat field of a
- -- PC_Arbno pattern contains the maximum stack entries needed
- -- for the Arbno with one instance and the successor pattern
-
- if Stack_Ptr + Node.Nat >= Stack'Last then
- raise Pattern_Stack_Overflow;
- end if;
-
- goto Succeed;
- end;
-
- -- Assign. If this node is executed, it means the assign-on-match
- -- or write-on-match operation will not happen after all, so we
- -- is propagate the failure, removing the PC_Assign node.
-
- when PC_Assign =>
- goto Fail;
-
- -- Assign immediate. This node performs the actual assignment.
-
- when PC_Assign_Imm =>
- Set_String
- (Node.VP.all,
- Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
- Pop_Region;
- goto Succeed;
-
- -- Assign on match. This node sets up for the eventual assignment
-
- when PC_Assign_OnM =>
- Stack (Stack_Base - 1).Node := Node;
- Push (CP_Assign'Access);
- Pop_Region;
- Assign_OnM := True;
- goto Succeed;
-
- -- Bal
-
- 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;
-
- -- Break (one character case)
-
- 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;
-
- -- Break (character set case)
-
- 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;
-
- -- Break (string function case)
-
- 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;
-
- -- Break (string pointer case)
-
- when PC_Break_VP => declare
- Str : 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;
-
- -- BreakX (one character case)
-
- 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;
-
- -- BreakX (character set case)
-
- 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;
-
- -- BreakX (string function case)
-
- 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;
-
- -- BreakX (string pointer case)
-
- when PC_BreakX_VP => declare
- Str : 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;
-
- -- BreakX_X (BreakX extension). See section on "Compound Pattern
- -- Structures". This node is the alternative that is stacked to
- -- skip past the break character and extend the break.
-
- when PC_BreakX_X =>
- Cursor := Cursor + 1;
- goto Succeed;
-
- -- Character (one character string)
-
- when PC_Char =>
- if Cursor < Length
- and then Subject (Cursor + 1) = Node.Char
- then
- Cursor := Cursor + 1;
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- End of Pattern
-
- when PC_EOP =>
- if Stack_Base = Stack_Init then
- goto Match_Succeed;
-
- -- End of recursive inner match. See separate section on
- -- handing of recursive pattern matches for details.
-
- else
- Node := Stack (Stack_Base - 1).Node;
- Pop_Region;
- goto Match;
- end if;
-
- -- Fail
-
- when PC_Fail =>
- goto Fail;
-
- -- Fence (built in pattern)
-
- when PC_Fence =>
- Push (CP_Cancel'Access);
- goto Succeed;
-
- -- Fence function node X. This is the node that gets control
- -- after a successful match of the fenced pattern.
-
- 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;
-
- -- Fence function node Y. This is the node that gets control on
- -- a failure that occurs after the fenced pattern has matched.
-
- -- Note: the Cursor at this stage is actually the inner stack
- -- base value. We don't reset this, but we do use it to strip
- -- off all the entries made by the fenced pattern.
-
- when PC_Fence_Y =>
- Stack_Ptr := Cursor - 2;
- goto Fail;
-
- -- Len (integer case)
-
- when PC_Len_Nat =>
- if Cursor + Node.Nat > Length then
- goto Fail;
- else
- Cursor := Cursor + Node.Nat;
- goto Succeed;
- end if;
-
- -- Len (Integer function case)
-
- 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;
-
- -- Len (integer pointer case)
-
- when PC_Len_NP =>
- if Cursor + Node.NP.all > Length then
- goto Fail;
- else
- Cursor := Cursor + Node.NP.all;
- goto Succeed;
- end if;
-
- -- NotAny (one character case)
-
- 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;
-
- -- NotAny (character set case)
-
- 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;
-
- -- NotAny (string function case)
-
- 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;
-
- -- NotAny (string pointer case)
-
- when PC_NotAny_VP => declare
- Str : 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;
-
- -- NSpan (one character case)
-
- when PC_NSpan_CH =>
- while Cursor < Length
- and then Subject (Cursor + 1) = Node.Char
- loop
- Cursor := Cursor + 1;
- end loop;
-
- goto Succeed;
-
- -- NSpan (character set case)
-
- when PC_NSpan_CS =>
- while Cursor < Length
- and then Is_In (Subject (Cursor + 1), Node.CS)
- loop
- Cursor := Cursor + 1;
- end loop;
-
- goto Succeed;
-
- -- NSpan (string function case)
-
- 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;
-
- -- NSpan (string pointer case)
-
- when PC_NSpan_VP => declare
- Str : 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;
-
- -- Null string
-
- when PC_Null =>
- goto Succeed;
-
- -- Pos (integer case)
-
- when PC_Pos_Nat =>
- if Cursor = Node.Nat then
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- Pos (Integer function case)
-
- when PC_Pos_NF => declare
- N : constant Natural := Node.NF.all;
-
- begin
- if Cursor = N then
- goto Succeed;
- else
- goto Fail;
- end if;
- end;
-
- -- Pos (integer pointer case)
-
- when PC_Pos_NP =>
- if Cursor = Node.NP.all then
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- Predicate function
-
- when PC_Pred_Func =>
- if Node.BF.all then
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- Region Enter. Initiate new pattern history stack region
-
- when PC_R_Enter =>
- Stack (Stack_Ptr + 1).Cursor := Cursor;
- Push_Region;
- goto Succeed;
-
- -- Region Remove node. This is the node stacked by an R_Enter.
- -- It removes the special format stack entry right underneath, and
- -- then restores the outer level stack base and signals failure.
-
- -- Note: the cursor value at this stage is actually the (negative)
- -- stack base value for the outer level.
-
- when PC_R_Remove =>
- Stack_Base := Cursor;
- Stack_Ptr := Stack_Ptr - 1;
- goto Fail;
-
- -- Region restore node. This is the node stacked at the end of an
- -- inner level match. Its function is to restore the inner level
- -- region, so that alternatives in this region can be sought.
-
- -- Note: the Cursor at this stage is actually the negative of the
- -- inner stack base value, which we use to restore the inner region.
-
- when PC_R_Restore =>
- Stack_Base := Cursor;
- goto Fail;
-
- -- Rest
-
- when PC_Rest =>
- Cursor := Length;
- goto Succeed;
-
- -- Initiate recursive match (pattern pointer case)
-
- 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;
-
- -- RPos (integer case)
-
- when PC_RPos_Nat =>
- if Cursor = (Length - Node.Nat) then
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- RPos (integer function case)
-
- 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;
-
- -- RPos (integer pointer case)
-
- when PC_RPos_NP =>
- if Cursor = (Length - Node.NP.all) then
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- RTab (integer case)
-
- when PC_RTab_Nat =>
- if Cursor <= (Length - Node.Nat) then
- Cursor := Length - Node.Nat;
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- RTab (integer function case)
-
- 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;
-
- -- RTab (integer pointer case)
-
- when PC_RTab_NP =>
- if Cursor <= (Length - Node.NP.all) then
- Cursor := Length - Node.NP.all;
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- Cursor assignment
-
- when PC_Setcur =>
- Node.Var.all := Cursor;
- goto Succeed;
-
- -- Span (one character case)
-
- 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;
-
- -- Span (character set case)
-
- 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;
-
- -- 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;
-
- 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;
-
- -- Span (string pointer case)
-
- when PC_Span_VP => declare
- Str : 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;
-
- -- String (two character case)
-
- 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;
-
- -- String (three character case)
-
- 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;
-
- -- String (four character case)
-
- 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;
-
- -- String (five character case)
-
- 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;
-
- -- String (six character case)
-
- 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;
-
- -- String (case of more than six characters)
-
- 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;
-
- -- 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;
-
- 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;
-
- -- String (pointer case)
-
- when PC_String_VP => declare
- S : 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;
-
- -- Succeed
-
- when PC_Succeed =>
- Push (Node);
- goto Succeed;
-
- -- Tab (integer case)
-
- when PC_Tab_Nat =>
- if Cursor <= Node.Nat then
- Cursor := Node.Nat;
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- Tab (integer function case)
-
- 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;
-
- -- Tab (integer pointer case)
-
- when PC_Tab_NP =>
- if Cursor <= Node.NP.all then
- Cursor := Node.NP.all;
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- Unanchored movement
-
- when PC_Unanchored =>
-
- -- All done if we tried every position
-
- if Cursor > Length then
- goto Match_Fail;
-
- -- Otherwise extend the anchor point, and restack ourself
-
- else
- Cursor := Cursor + 1;
- Push (Node);
- goto Succeed;
- end if;
-
- -- Write immediate. This node performs the actual write
-
- when PC_Write_Imm =>
- Put_Line
- (Node.FP.all,
- Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
- Pop_Region;
- goto Succeed;
-
- -- Write on match. This node sets up for the eventual write
-
- when PC_Write_OnM =>
- Stack (Stack_Base - 1).Node := Node;
- Push (CP_Assign'Access);
- Pop_Region;
- Assign_OnM := True;
- goto Succeed;
-
- end case;
-
- -- We are NOT allowed to fall though this case statement, since every
- -- match routine must end by executing a goto to the appropriate point
- -- in the finite state machine model.
-
- Logic_Error;
-
- end XMatch;
-
- -------------
- -- XMatchD --
- -------------
-
- -- Maintenance note: There is a LOT of code duplication between XMatch
- -- and XMatchD. This is quite intentional, the point is to avoid any
- -- unnecessary debugging overhead in the XMatch case, but this does mean
- -- that any changes to XMatchD must be mirrored in XMatch. In case of
- -- any major changes, the proper approach is to delete XMatch, make the
- -- changes to XMatchD, and then make a copy of XMatchD, removing all
- -- calls to Dout, and all Put and Put_Line operations. This copy becomes
- -- the new XMatch.
-
- procedure XMatchD
- (Subject : String;
- Pat_P : PE_Ptr;
- Pat_S : Natural;
- Start : out Natural;
- Stop : out Natural)
- is
- Node : PE_Ptr;
- -- Pointer to current pattern node. Initialized from Pat_P, and then
- -- updated as the match proceeds through its constituent elements.
-
- Length : constant Natural := Subject'Length;
- -- Length of string (= Subject'Last, since Subject'First is always 1)
-
- Cursor : Integer := 0;
- -- If the value is non-negative, then this value is the index showing
- -- the current position of the match in the subject string. The next
- -- character to be matched is at Subject (Cursor + 1). Note that since
- -- our view of the subject string in XMatch always has a lower bound
- -- of one, regardless of original bounds, that this definition exactly
- -- corresponds to the cursor value as referenced by functions like Pos.
- --
- -- If the value is negative, then this is a saved stack pointer,
- -- typically a base pointer of an inner or outer region. Cursor
- -- temporarily holds such a value when it is popped from the stack
- -- by Fail. In all cases, Cursor is reset to a proper non-negative
- -- cursor value before the match proceeds (e.g. by propagating the
- -- 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.
-
- Region_Level : Natural := 0;
- -- Keeps track of recursive region level. This is used only for
- -- debugging, it is the number of saved history stack base values.
-
- Stack : Stack_Type;
- -- The pattern matching failure stack for this call to Match
-
- Stack_Ptr : Stack_Range;
- -- Current stack pointer. This points to the top element of the stack
- -- that is currently in use. At the outer level this is the special
- -- entry placed on the stack according to the anchor mode.
-
- Stack_Init : constant Stack_Range := Stack'First + 1;
- -- This is the initial value of the Stack_Ptr and Stack_Base. The
- -- initial (Stack'First) element of the stack is not used so that
- -- when we pop the last element off, Stack_Ptr is still in range.
-
- Stack_Base : Stack_Range;
- -- This value is the stack base value, i.e. the stack pointer for the
- -- first history stack entry in the current stack region. See separate
- -- section on handling of recursive pattern matches.
-
- Assign_OnM : Boolean := False;
- -- Set True if assign-on-match or write-on-match operations may be
- -- present in the history stack, which must then be scanned on a
- -- successful match.
-
- procedure Dout (Str : String);
- -- Output string to standard error with bars indicating region level.
-
- procedure Dout (Str : String; A : Character);
- -- Calls Dout with the string S ('A')
-
- procedure Dout (Str : String; A : Character_Set);
- -- Calls Dout with the string S ("A")
-
- procedure Dout (Str : String; A : Natural);
- -- Calls Dout with the string S (A)
-
- procedure Dout (Str : String; A : String);
- -- Calls Dout with the string S ("A")
-
- function Img (P : PE_Ptr) return String;
- -- Returns a string of the form #nnn where nnn is P.Index
-
- procedure Pop_Region;
- pragma Inline (Pop_Region);
- -- 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
-
- procedure Push_Region;
- pragma Inline (Push_Region);
- -- This procedure makes a new region on the history stack. The
- -- caller first establishes the special entry on the stack, but
- -- does not push the stack pointer. Then this call stacks a
- -- PC_Remove_Region node, on top of this entry, using the cursor
- -- field of the PC_Remove_Region entry to save the outer level
- -- stack base value, and resets the stack base to point to this
- -- PC_Remove_Region node.
-
- ----------
- -- Dout --
- ----------
-
- 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;
-
- ---------
- -- Img --
- ---------
-
- function Img (P : PE_Ptr) return String is
- begin
- return "#" & Integer (P.Index) & " ";
- end Img;
-
- ----------------
- -- Pop_Region --
- ----------------
-
- procedure Pop_Region is
- begin
- Region_Level := Region_Level - 1;
-
- -- If nothing was pushed in the inner region, we can just get
- -- rid of it entirely, leaving no traces that it was ever there
-
- if Stack_Ptr = Stack_Base then
- Stack_Ptr := Stack_Base - 2;
- Stack_Base := Stack (Stack_Ptr + 2).Cursor;
-
- -- If stuff was pushed in the inner region, then we have to
- -- push a PC_R_Restore node so that we properly handle possible
- -- rematches within the region.
-
- 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;
-
- ----------
- -- Push --
- ----------
-
- procedure Push (Node : PE_Ptr) is
- begin
- Stack_Ptr := Stack_Ptr + 1;
- Stack (Stack_Ptr).Cursor := Cursor;
- Stack (Stack_Ptr).Node := Node;
- end Push;
-
- -----------------
- -- Push_Region --
- -----------------
-
- 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;
-
- -- Start of processing for XMatchD
-
- 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;
-
- -- Check we have enough stack for this pattern. This check deals with
- -- every possibility except a match of a recursive pattern, where we
- -- make a check at each recursion level.
-
- if Pat_S >= Stack_Size - 1 then
- raise Pattern_Stack_Overflow;
- end if;
-
- -- In anchored mode, the bottom entry on the stack is an abort entry
-
- if Anchored_Mode then
- Stack (Stack_Init).Node := CP_Cancel'Access;
- Stack (Stack_Init).Cursor := 0;
-
- -- In unanchored more, the bottom entry on the stack references
- -- the special pattern element PE_Unanchored, whose Pthen field
- -- points to the initial pattern element. The cursor value in this
- -- entry is the number of anchor moves so far.
-
- 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;
-
- -----------------------------------------
- -- Main Pattern Matching State Control --
- -----------------------------------------
-
- -- This is a state machine which uses gotos to change state. The
- -- initial state is Match, to initiate the matching of the first
- -- element, so the goto Match above starts the match. In the
- -- following descriptions, we indicate the global values that
- -- are relevant for the state transition.
-
- -- Come here if entire match fails
-
- <<Match_Fail>>
- Dout ("match fails");
- New_Line;
- Start := 0;
- Stop := 0;
- return;
-
- -- Come here if entire match succeeds
-
- -- Cursor current position in subject string
-
- <<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)));
-
- -- Scan history stack for deferred assignments or writes
-
- 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;
-
- -- Come here if attempt to match current element fails
-
- -- Stack_Base current stack base
- -- Stack_Ptr current stack pointer
-
- <<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;
-
- -- Come here if attempt to match current element succeeds
-
- -- Cursor current position in subject string
- -- Node pointer to node successfully matched
- -- Stack_Base current stack base
- -- Stack_Ptr current stack pointer
-
- <<Succeed>>
- Dout ("success, cursor = " & Cursor);
- Node := Node.Pthen;
-
- -- Come here to match the next pattern element
-
- -- Cursor current position in subject string
- -- Node pointer to node to be matched
- -- Stack_Base current stack base
- -- Stack_Ptr current stack pointer
-
- <<Match>>
-
- --------------------------------------------------
- -- Main Pattern Match Element Matching Routines --
- --------------------------------------------------
-
- -- Here is the case statement that processes the current node. The
- -- processing for each element does one of five things:
-
- -- goto Succeed to move to the successor
- -- goto Match_Succeed if the entire match succeeds
- -- goto Match_Fail if the entire match fails
- -- goto Fail to signal failure of current match
-
- -- Processing is NOT allowed to fall through
-
- case Node.Pcode is
-
- -- Cancel
-
- when PC_Cancel =>
- Dout (Img (Node) & "matching Cancel");
- goto Match_Fail;
-
- -- Alternation
-
- when PC_Alt =>
- Dout
- (Img (Node) & "setting up alternative " & Img (Node.Alt));
- Push (Node.Alt);
- Node := Node.Pthen;
- goto Match;
-
- -- Any (one character case)
-
- 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;
-
- -- Any (character set case)
-
- 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;
-
- -- Any (string function case)
-
- 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;
-
- -- Any (string pointer case)
-
- when PC_Any_VP => declare
- Str : 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;
-
- -- Arb (initial match)
-
- when PC_Arb_X =>
- Dout (Img (Node) & "matching Arb");
- Push (Node.Alt);
- Node := Node.Pthen;
- goto Match;
-
- -- Arb (extension)
-
- 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;
-
- -- Arbno_S (simple Arbno initialize). This is the node that
- -- initiates the match of a simple Arbno structure.
-
- when PC_Arbno_S =>
- Dout (Img (Node) &
- "setting up Arbno alternative " & Img (Node.Alt));
- Push (Node.Alt);
- Node := Node.Pthen;
- goto Match;
-
- -- Arbno_X (Arbno initialize). This is the node that initiates
- -- the match of a complex Arbno structure.
-
- when PC_Arbno_X =>
- Dout (Img (Node) &
- "setting up Arbno alternative " & Img (Node.Alt));
- Push (Node.Alt);
- Node := Node.Pthen;
- goto Match;
-
- -- Arbno_Y (Arbno rematch). This is the node that is executed
- -- following successful matching of one instance of a complex
- -- Arbno pattern.
-
- when PC_Arbno_Y => declare
- Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor);
-
- begin
- Dout (Img (Node) & "extending Arbno");
- Pop_Region;
-
- -- If arbno extension matched null, then immediately fail
-
- if Null_Match then
- Dout ("Arbno extension matched null, so fails");
- goto Fail;
- end if;
-
- -- Here we must do a stack check to make sure enough stack
- -- is left. This check will happen once for each instance of
- -- the Arbno pattern that is matched. The Nat field of a
- -- PC_Arbno pattern contains the maximum stack entries needed
- -- for the Arbno with one instance and the successor pattern
-
- if Stack_Ptr + Node.Nat >= Stack'Last then
- raise Pattern_Stack_Overflow;
- end if;
-
- goto Succeed;
- end;
-
- -- Assign. If this node is executed, it means the assign-on-match
- -- or write-on-match operation will not happen after all, so we
- -- is propagate the failure, removing the PC_Assign node.
-
- when PC_Assign =>
- Dout (Img (Node) & "deferred assign/write cancelled");
- goto Fail;
-
- -- Assign immediate. This node performs the actual assignment.
-
- 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;
-
- -- Assign on match. This node sets up for the eventual assignment
-
- 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;
-
- -- Bal
-
- 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;
-
- -- Break (one character case)
-
- 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;
-
- -- Break (character set case)
-
- 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;
-
- -- Break (string function case)
-
- 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;
-
- -- Break (string pointer case)
-
- when PC_Break_VP => declare
- Str : 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;
-
- -- BreakX (one character case)
-
- 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;
-
- -- BreakX (character set case)
-
- 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;
-
- -- BreakX (string function case)
-
- 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;
-
- -- BreakX (string pointer case)
-
- when PC_BreakX_VP => declare
- Str : 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;
-
- -- BreakX_X (BreakX extension). See section on "Compound Pattern
- -- Structures". This node is the alternative that is stacked
- -- to skip past the break character and extend the break.
-
- when PC_BreakX_X =>
- Dout (Img (Node) & "extending BreakX");
-
- Cursor := Cursor + 1;
- goto Succeed;
-
- -- Character (one character string)
-
- 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;
-
- -- End of Pattern
-
- when PC_EOP =>
- if Stack_Base = Stack_Init then
- Dout ("end of pattern");
- goto Match_Succeed;
-
- -- End of recursive inner match. See separate section on
- -- handing of recursive pattern matches for details.
-
- else
- Dout ("terminating recursive match");
- Node := Stack (Stack_Base - 1).Node;
- Pop_Region;
- goto Match;
- end if;
-
- -- Fail
-
- when PC_Fail =>
- Dout (Img (Node) & "matching Fail");
- goto Fail;
-
- -- Fence (built in pattern)
-
- when PC_Fence =>
- Dout (Img (Node) & "matching Fence");
- Push (CP_Cancel'Access);
- goto Succeed;
-
- -- Fence function node X. This is the node that gets control
- -- after a successful match of the fenced pattern.
-
- 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;
-
- -- Fence function node Y. This is the node that gets control on
- -- a failure that occurs after the fenced pattern has matched.
-
- -- Note: the Cursor at this stage is actually the inner stack
- -- base value. We don't reset this, but we do use it to strip
- -- off all the entries made by the fenced pattern.
-
- when PC_Fence_Y =>
- Dout (Img (Node) & "pattern matched by Fence caused failure");
- Stack_Ptr := Cursor - 2;
- goto Fail;
-
- -- Len (integer case)
-
- 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;
-
- -- Len (Integer function case)
-
- 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;
-
- -- Len (integer pointer case)
-
- 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;
-
- -- NotAny (one character case)
-
- 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;
-
- -- NotAny (character set case)
-
- 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;
-
- -- NotAny (string function case)
-
- 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;
-
- -- NotAny (string pointer case)
-
- when PC_NotAny_VP => declare
- Str : 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;
-
- -- NSpan (one character case)
-
- 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;
-
- -- NSpan (character set case)
-
- 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;
-
- -- NSpan (string function case)
-
- 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;
-
- -- NSpan (string pointer case)
-
- when PC_NSpan_VP => declare
- Str : 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;
-
- -- Pos (integer case)
-
- when PC_Pos_Nat =>
- Dout (Img (Node) & "matching Pos", Node.Nat);
-
- if Cursor = Node.Nat then
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- Pos (Integer function case)
-
- 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;
-
- -- Pos (integer pointer case)
-
- 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;
-
- -- Predicate function
-
- when PC_Pred_Func =>
- Dout (Img (Node) & "matching predicate function");
-
- if Node.BF.all then
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- Region Enter. Initiate new pattern history stack region
-
- when PC_R_Enter =>
- Dout (Img (Node) & "starting match of nested pattern");
- Stack (Stack_Ptr + 1).Cursor := Cursor;
- Push_Region;
- goto Succeed;
-
- -- Region Remove node. This is the node stacked by an R_Enter.
- -- It removes the special format stack entry right underneath, and
- -- then restores the outer level stack base and signals failure.
-
- -- Note: the cursor value at this stage is actually the (negative)
- -- stack base value for the outer level.
-
- 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;
-
- -- Region restore node. This is the node stacked at the end of an
- -- inner level match. Its function is to restore the inner level
- -- region, so that alternatives in this region can be sought.
-
- -- Note: the Cursor at this stage is actually the negative of the
- -- inner stack base value, which we use to restore the inner region.
-
- when PC_R_Restore =>
- Dout ("failure, search for alternatives in nested pattern");
- Region_Level := Region_Level + 1;
- Stack_Base := Cursor;
- goto Fail;
-
- -- Rest
-
- when PC_Rest =>
- Dout (Img (Node) & "matching Rest");
- Cursor := Length;
- goto Succeed;
-
- -- Initiate recursive match (pattern pointer case)
-
- 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;
-
- -- RPos (integer case)
-
- when PC_RPos_Nat =>
- Dout (Img (Node) & "matching RPos", Node.Nat);
-
- if Cursor = (Length - Node.Nat) then
- goto Succeed;
- else
- goto Fail;
- end if;
-
- -- RPos (integer function case)
-
- 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;
-
- -- RPos (integer pointer case)
-
- 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;
-
- -- RTab (integer case)
-
- 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;
-
- -- RTab (integer function case)
-
- 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;
-
- -- RTab (integer pointer case)
-
- 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;
-
- -- Cursor assignment
-
- when PC_Setcur =>
- Dout (Img (Node) & "matching Setcur");
- Node.Var.all := Cursor;
- goto Succeed;
-
- -- Span (one character case)
-
- 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;
-
- -- Span (character set case)
-
- 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;
-
- -- 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;
-
- 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;
-
- -- Span (string pointer case)
-
- when PC_Span_VP => declare
- Str : 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;
-
- -- String (two character case)
-
- 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;
-
- -- String (three character case)
-
- 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;
-
- -- String (four character case)
-
- 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;
-
- -- String (five character case)
-
- 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;
-
- -- String (six character case)
-
- 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;
-
- -- String (case of more than six characters)
-
- 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;
-
- -- 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;
-
- 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;
-
- -- 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);
-
- 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;
-
- -- Succeed
-
- when PC_Succeed =>
- Dout (Img (Node) & "matching Succeed");
- Push (Node);
- goto Succeed;
-
- -- Tab (integer case)
-
- 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;
-
- -- Tab (integer function case)
-
- 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;
-
- -- Tab (integer pointer case)
-
- 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;
-
- -- Unanchored movement
-
- when PC_Unanchored =>
- Dout ("attempting to move anchor point");
-
- -- All done if we tried every position
-
- if Cursor > Length then
- goto Match_Fail;
-
- -- Otherwise extend the anchor point, and restack ourself
-
- else
- Cursor := Cursor + 1;
- Push (Node);
- goto Succeed;
- end if;
-
- -- Write immediate. This node performs the actual write
-
- 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;
-
- -- Write on match. This node sets up for the eventual write
-
- 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;
-
- -- We are NOT allowed to fall though this case statement, since every
- -- match routine must end by executing a goto to the appropriate point
- -- in the finite state machine model.
-
- Logic_Error;
-
- end XMatchD;
-
-end GNAT.Spitbol.Patterns;
projects / msp430-gcc.git / blobdiff