1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . S P I T B O L . P A T T E R N S --
9 -- Copyright (C) 1998-2018, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- Note: the data structures and general approach used in this implementation
33 -- are derived from the original MINIMAL sources for SPITBOL. The code is not
34 -- a direct translation, but the approach is followed closely. In particular,
35 -- we use the one stack approach developed in the SPITBOL implementation.
37 with Ada
.Strings
.Unbounded
.Aux
; use Ada
.Strings
.Unbounded
.Aux
;
39 with GNAT
.Debug_Utilities
; use GNAT
.Debug_Utilities
;
41 with System
; use System
;
43 with Ada
.Unchecked_Conversion
;
44 with Ada
.Unchecked_Deallocation
;
46 package body GNAT
.Spitbol
.Patterns
is
48 ------------------------
49 -- Internal Debugging --
50 ------------------------
52 Internal_Debug
: constant Boolean := False;
53 -- Set this flag to True to activate some built-in debugging traceback
54 -- These are all lines output with PutD and Put_LineD.
57 pragma Inline
(New_LineD
);
58 -- Output new blank line with New_Line if Internal_Debug is True
60 procedure PutD
(Str
: String);
62 -- Output string with Put if Internal_Debug is True
64 procedure Put_LineD
(Str
: String);
65 pragma Inline
(Put_LineD
);
66 -- Output string with Put_Line if Internal_Debug is True
68 -----------------------------
69 -- Local Type Declarations --
70 -----------------------------
72 subtype String_Ptr
is Ada
.Strings
.Unbounded
.String_Access
;
73 subtype File_Ptr
is Ada
.Text_IO
.File_Access
;
75 function To_Address
is new Ada
.Unchecked_Conversion
(PE_Ptr
, Address
);
76 -- Used only for debugging output purposes
78 subtype AFC
is Ada
.Finalization
.Controlled
;
80 N
: constant PE_Ptr
:= null;
81 -- Shorthand used to initialize Copy fields to null
83 type Natural_Ptr
is access all Natural;
84 type Pattern_Ptr
is access all Pattern
;
86 --------------------------------------------------
87 -- Description of Algorithm and Data Structures --
88 --------------------------------------------------
90 -- A pattern structure is represented as a linked graph of nodes
91 -- with the following structure:
93 -- +------------------------------------+
95 -- +------------------------------------+
97 -- +------------------------------------+
99 -- +------------------------------------+
101 -- +------------------------------------+
103 -- Pcode is a code value indicating the type of the pattern node. This
104 -- code is used both as the discriminant value for the record, and as
105 -- the case index in the main match routine that branches to the proper
106 -- match code for the given element.
108 -- Index is a serial index number. The use of these serial index
109 -- numbers is described in a separate section.
111 -- Pthen is a pointer to the successor node, i.e the node to be matched
112 -- if the attempt to match the node succeeds. If this is the last node
113 -- of the pattern to be matched, then Pthen points to a dummy node
114 -- of kind PC_EOP (end of pattern), which initializes pattern exit.
116 -- The parameter or parameters are present for certain node types,
117 -- and the type varies with the pattern code.
119 type Pattern_Code
is (
212 type IndexT
is range 0 .. +(2 **15 - 1);
214 type PE
(Pcode
: Pattern_Code
) is record
217 -- Serial index number of pattern element within pattern
220 -- Successor element, to be matched after this one
277 Str2
: String (1 .. 2);
280 Str3
: String (1 .. 3);
283 Str4
: String (1 .. 4);
286 Str5
: String (1 .. 5);
289 Str6
: String (1 .. 6);
350 subtype PC_Has_Alt
is Pattern_Code
range PC_Alt
.. PC_Arbno_X
;
351 -- Range of pattern codes that has an Alt field. This is used in the
352 -- recursive traversals, since these links must be followed.
354 EOP_Element
: aliased constant PE
:= (PC_EOP
, 0, N
);
355 -- This is the end of pattern element, and is thus the representation of
356 -- a null pattern. It has a zero index element since it is never placed
357 -- inside a pattern. Furthermore it does not need a successor, since it
358 -- marks the end of the pattern, so that no more successors are needed.
360 EOP
: constant PE_Ptr
:= EOP_Element
'Unrestricted_Access;
361 -- This is the end of pattern pointer, that is used in the Pthen pointer
362 -- of other nodes to signal end of pattern.
364 -- The following array is used to determine if a pattern used as an
365 -- argument for Arbno is eligible for treatment using the simple Arbno
366 -- structure (i.e. it is a pattern that is guaranteed to match at least
367 -- one character on success, and not to make any entries on the stack.
369 OK_For_Simple_Arbno
: constant array (Pattern_Code
) of Boolean :=
392 -------------------------------
393 -- The Pattern History Stack --
394 -------------------------------
396 -- The pattern history stack is used for controlling backtracking when
397 -- a match fails. The idea is to stack entries that give a cursor value
398 -- to be restored, and a node to be reestablished as the current node to
399 -- attempt an appropriate rematch operation. The processing for a pattern
400 -- element that has rematch alternatives pushes an appropriate entry or
401 -- entry on to the stack, and the proceeds. If a match fails at any point,
402 -- the top element of the stack is popped off, resetting the cursor and
403 -- the match continues by accessing the node stored with this entry.
405 type Stack_Entry
is record
408 -- Saved cursor value that is restored when this entry is popped
409 -- from the stack if a match attempt fails. Occasionally, this
410 -- field is used to store a history stack pointer instead of a
411 -- cursor. Such cases are noted in the documentation and the value
412 -- stored is negative since stack pointer values are always negative.
415 -- This pattern element reference is reestablished as the current
416 -- Node to be matched (which will attempt an appropriate rematch).
420 subtype Stack_Range
is Integer range -Stack_Size
.. -1;
422 type Stack_Type
is array (Stack_Range
) of Stack_Entry
;
423 -- The type used for a history stack. The actual instance of the stack
424 -- is declared as a local variable in the Match routine, to properly
425 -- handle recursive calls to Match. All stack pointer values are negative
426 -- to distinguish them from normal cursor values.
428 -- Note: the pattern matching stack is used only to handle backtracking.
429 -- If no backtracking occurs, its entries are never accessed, and never
430 -- popped off, and in particular it is normal for a successful match
431 -- to terminate with entries on the stack that are simply discarded.
433 -- Note: in subsequent diagrams of the stack, we always place element
434 -- zero (the deepest element) at the top of the page, then build the
435 -- stack down on the page with the most recent (top of stack) element
436 -- being the bottom-most entry on the page.
438 -- Stack checking is handled by labeling every pattern with the maximum
439 -- number of stack entries that are required, so a single check at the
440 -- start of matching the pattern suffices. There are two exceptions.
442 -- First, the count does not include entries for recursive pattern
443 -- references. Such recursions must therefore perform a specific
444 -- stack check with respect to the number of stack entries required
445 -- by the recursive pattern that is accessed and the amount of stack
446 -- that remains unused.
448 -- Second, the count includes only one iteration of an Arbno pattern,
449 -- so a specific check must be made on subsequent iterations that there
450 -- is still enough stack space left. The Arbno node has a field that
451 -- records the number of stack entries required by its argument for
454 ---------------------------------------------------
455 -- Use of Serial Index Field in Pattern Elements --
456 ---------------------------------------------------
458 -- The serial index numbers for the pattern elements are assigned as
459 -- a pattern is constructed from its constituent elements. Note that there
460 -- is never any sharing of pattern elements between patterns (copies are
461 -- always made), so the serial index numbers are unique to a particular
462 -- pattern as referenced from the P field of a value of type Pattern.
464 -- The index numbers meet three separate invariants, which are used for
465 -- various purposes as described in this section.
467 -- First, the numbers uniquely identify the pattern elements within a
468 -- pattern. If Num is the number of elements in a given pattern, then
469 -- the serial index numbers for the elements of this pattern will range
470 -- from 1 .. Num, so that each element has a separate value.
472 -- The purpose of this assignment is to provide a convenient auxiliary
473 -- data structure mechanism during operations which must traverse a
474 -- pattern (e.g. copy and finalization processing). Once constructed
475 -- patterns are strictly read only. This is necessary to allow sharing
476 -- of patterns between tasks. This means that we cannot go marking the
477 -- pattern (e.g. with a visited bit). Instead we construct a separate
478 -- vector that contains the necessary information indexed by the Index
479 -- values in the pattern elements. For this purpose the only requirement
480 -- is that they be uniquely assigned.
482 -- Second, the pattern element referenced directly, i.e. the leading
483 -- pattern element, is always the maximum numbered element and therefore
484 -- indicates the total number of elements in the pattern. More precisely,
485 -- the element referenced by the P field of a pattern value, or the
486 -- element returned by any of the internal pattern construction routines
487 -- in the body (that return a value of type PE_Ptr) always is this
490 -- The purpose of this requirement is to allow an immediate determination
491 -- of the number of pattern elements within a pattern. This is used to
492 -- properly size the vectors used to contain auxiliary information for
493 -- traversal as described above.
495 -- Third, as compound pattern structures are constructed, the way in which
496 -- constituent parts of the pattern are constructed is stylized. This is
497 -- an automatic consequence of the way that these compound structures
498 -- are constructed, and basically what we are doing is simply documenting
499 -- and specifying the natural result of the pattern construction. The
500 -- section describing compound pattern structures gives details of the
501 -- numbering of each compound pattern structure.
503 -- The purpose of specifying the stylized numbering structures for the
504 -- compound patterns is to help simplify the processing in the Image
505 -- function, since it eases the task of retrieving the original recursive
506 -- structure of the pattern from the flat graph structure of elements.
507 -- This use in the Image function is the only point at which the code
508 -- makes use of the stylized structures.
510 type Ref_Array
is array (IndexT
range <>) of PE_Ptr
;
511 -- This type is used to build an array whose N'th entry references the
512 -- element in a pattern whose Index value is N. See Build_Ref_Array.
514 procedure Build_Ref_Array
(E
: PE_Ptr
; RA
: out Ref_Array
);
515 -- Given a pattern element which is the leading element of a pattern
516 -- structure, and a Ref_Array with bounds 1 .. E.Index, fills in the
517 -- Ref_Array so that its N'th entry references the element of the
518 -- referenced pattern whose Index value is N.
520 -------------------------------
521 -- Recursive Pattern Matches --
522 -------------------------------
524 -- The pattern primitive (+P) where P is a Pattern_Ptr or Pattern_Func
525 -- causes a recursive pattern match. This cannot be handled by an actual
526 -- recursive call to the outer level Match routine, since this would not
527 -- allow for possible backtracking into the region matched by the inner
528 -- pattern. Indeed this is the classical clash between recursion and
529 -- backtracking, and a simple recursive stack structure does not suffice.
531 -- This section describes how this recursion and the possible associated
532 -- backtracking is handled. We still use a single stack, but we establish
533 -- the concept of nested regions on this stack, each of which has a stack
534 -- base value pointing to the deepest stack entry of the region. The base
535 -- value for the outer level is zero.
537 -- When a recursive match is established, two special stack entries are
538 -- made. The first entry is used to save the original node that starts
539 -- the recursive match. This is saved so that the successor field of
540 -- this node is accessible at the end of the match, but it is never
541 -- popped and executed.
543 -- The second entry corresponds to a standard new region action. A
544 -- PC_R_Remove node is stacked, whose cursor field is used to store
545 -- the outer stack base, and the stack base is reset to point to
546 -- this PC_R_Remove node. Then the recursive pattern is matched and
547 -- it can make history stack entries in the normal matter, so now
548 -- the stack looks like:
550 -- (stack entries made by outer level)
552 -- (Special entry, node is (+P) successor
553 -- cursor entry is not used)
555 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack base
556 -- saved base value for the enclosing region)
558 -- (stack entries made by inner level)
560 -- If a subsequent failure occurs and pops the PC_R_Remove node, it
561 -- removes itself and the special entry immediately underneath it,
562 -- restores the stack base value for the enclosing region, and then
563 -- again signals failure to look for alternatives that were stacked
564 -- before the recursion was initiated.
566 -- Now we need to consider what happens if the inner pattern succeeds, as
567 -- signalled by accessing the special PC_EOP pattern primitive. First we
568 -- recognize the nested case by looking at the Base value. If this Base
569 -- value is Stack'First, then the entire match has succeeded, but if the
570 -- base value is greater than Stack'First, then we have successfully
571 -- matched an inner pattern, and processing continues at the outer level.
573 -- There are two cases. The simple case is when the inner pattern has made
574 -- no stack entries, as recognized by the fact that the current stack
575 -- pointer is equal to the current base value. In this case it is fine to
576 -- remove all trace of the recursion by restoring the outer base value and
577 -- using the special entry to find the appropriate successor node.
579 -- The more complex case arises when the inner match does make stack
580 -- entries. In this case, the PC_EOP processing stacks a special entry
581 -- whose cursor value saves the saved inner base value (the one that
582 -- references the corresponding PC_R_Remove value), and whose node
583 -- pointer references a PC_R_Restore node, so the stack looks like:
585 -- (stack entries made by outer level)
587 -- (Special entry, node is (+P) successor,
588 -- cursor entry is not used)
590 -- (PC_R_Remove entry, "cursor" value is (negative)
591 -- saved base value for the enclosing region)
593 -- (stack entries made by inner level)
595 -- (PC_Region_Replace entry, "cursor" value is (negative)
596 -- stack pointer value referencing the PC_R_Remove entry).
598 -- If the entire match succeeds, then these stack entries are, as usual,
599 -- ignored and abandoned. If on the other hand a subsequent failure
600 -- causes the PC_Region_Replace entry to be popped, it restores the
601 -- inner base value from its saved "cursor" value and then fails again.
602 -- Note that it is OK that the cursor is temporarily clobbered by this
603 -- pop, since the second failure will reestablish a proper cursor value.
605 ---------------------------------
606 -- Compound Pattern Structures --
607 ---------------------------------
609 -- This section discusses the compound structures used to represent
610 -- constructed patterns. It shows the graph structures of pattern
611 -- elements that are constructed, and in the case of patterns that
612 -- provide backtracking possibilities, describes how the history
613 -- stack is used to control the backtracking. Finally, it notes the
614 -- way in which the Index numbers are assigned to the structure.
616 -- In all diagrams, solid lines (built with minus signs or vertical
617 -- bars, represent successor pointers (Pthen fields) with > or V used
618 -- to indicate the direction of the pointer. The initial node of the
619 -- structure is in the upper left of the diagram. A dotted line is an
620 -- alternative pointer from the element above it to the element below
621 -- it. See individual sections for details on how alternatives are used.
627 -- In the pattern structures listed in this section, a line that looks
628 -- like ----> with nothing to the right indicates an end of pattern
629 -- (EOP) pointer that represents the end of the match.
631 -- When a pattern concatenation (L & R) occurs, the resulting structure
632 -- is obtained by finding all such EOP pointers in L, and replacing
633 -- them to point to R. This is the most important flattening that
634 -- occurs in constructing a pattern, and it means that the pattern
635 -- matching circuitry does not have to keep track of the structure
636 -- of a pattern with respect to concatenation, since the appropriate
637 -- successor is always at hand.
639 -- Concatenation itself generates no additional possibilities for
640 -- backtracking, but the constituent patterns of the concatenated
641 -- structure will make stack entries as usual. The maximum amount
642 -- of stack required by the structure is thus simply the sum of the
643 -- maximums required by L and R.
645 -- The index numbering of a concatenation structure works by leaving
646 -- the numbering of the right hand pattern, R, unchanged and adjusting
647 -- the numbers in the left hand pattern, L up by the count of elements
648 -- in R. This ensures that the maximum numbered element is the leading
649 -- element as required (given that it was the leading element in L).
655 -- A pattern (L or R) constructs the structure:
658 -- | A |---->| L |---->
666 -- The A element here is a PC_Alt node, and the dotted line represents
667 -- the contents of the Alt field. When the PC_Alt element is matched,
668 -- it stacks a pointer to the leading element of R on the history stack
669 -- so that on subsequent failure, a match of R is attempted.
671 -- The A node is the highest numbered element in the pattern. The
672 -- original index numbers of R are unchanged, but the index numbers
673 -- of the L pattern are adjusted up by the count of elements in R.
675 -- Note that the difference between the index of the L leading element
676 -- the index of the R leading element (after building the alt structure)
677 -- indicates the number of nodes in L, and this is true even after the
678 -- structure is incorporated into some larger structure. For example,
679 -- if the A node has index 16, and L has index 15 and R has index
680 -- 5, then we know that L has 10 (15-5) elements in it.
682 -- Suppose that we now concatenate this structure to another pattern
683 -- with 9 elements in it. We will now have the A node with an index
684 -- of 25, L with an index of 24 and R with an index of 14. We still
685 -- know that L has 10 (24-14) elements in it, numbered 15-24, and
686 -- consequently the successor of the alternation structure has an
687 -- index with a value less than 15. This is used in Image to figure
688 -- out the original recursive structure of a pattern.
690 -- To clarify the interaction of the alternation and concatenation
691 -- structures, here is a more complex example of the structure built
694 -- (V or W or X) (Y or Z)
696 -- where A,B,C,D,E are all single element patterns:
698 -- +---+ +---+ +---+ +---+
699 -- I A I---->I V I---+-->I A I---->I Y I---->
700 -- +---+ +---+ I +---+ +---+
703 -- +---+ +---+ I +---+
704 -- I A I---->I W I-->I I Z I---->
705 -- +---+ +---+ I +---+
709 -- I X I------------>+
712 -- The numbering of the nodes would be as follows:
714 -- +---+ +---+ +---+ +---+
715 -- I 8 I---->I 7 I---+-->I 3 I---->I 2 I---->
716 -- +---+ +---+ I +---+ +---+
719 -- +---+ +---+ I +---+
720 -- I 6 I---->I 5 I-->I I 1 I---->
721 -- +---+ +---+ I +---+
725 -- I 4 I------------>+
728 -- Note: The above structure actually corresponds to
730 -- (A or (B or C)) (D or E)
734 -- ((A or B) or C) (D or E)
736 -- which is the more natural interpretation, but in fact alternation
737 -- is associative, and the construction of an alternative changes the
738 -- left grouped pattern to the right grouped pattern in any case, so
739 -- that the Image function produces a more natural looking output.
745 -- An Arb pattern builds the structure
756 -- The X node is a PC_Arb_X node, which matches null, and stacks a
757 -- pointer to Y node, which is the PC_Arb_Y node that matches one
758 -- extra character and restacks itself.
760 -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1
762 -------------------------
763 -- Arbno (simple case) --
764 -------------------------
766 -- The simple form of Arbno can be used where the pattern always
767 -- matches at least one character if it succeeds, and it is known
768 -- not to make any history stack entries. In this case, Arbno (P)
769 -- can construct the following structure:
783 -- The S (PC_Arbno_S) node matches null stacking a pointer to the
784 -- pattern P. If a subsequent failure causes P to be matched and
785 -- this match succeeds, then node A gets restacked to try another
786 -- instance if needed by a subsequent failure.
788 -- The node numbering of the constituent pattern P is not affected.
789 -- The S node has a node number of P.Index + 1.
791 --------------------------
792 -- Arbno (complex case) --
793 --------------------------
795 -- A call to Arbno (P), where P can match null (or at least is not
796 -- known to require a non-null string) and/or P requires pattern stack
797 -- entries, constructs the following structure:
799 -- +--------------------------+
807 -- +---+ +---+ +---+ |
808 -- | E |---->| P |---->| Y |--->+
811 -- The node X (PC_Arbno_X) matches null, stacking a pointer to the
812 -- E-P-X structure used to match one Arbno instance.
814 -- Here E is the PC_R_Enter node which matches null and creates two
815 -- stack entries. The first is a special entry whose node field is
816 -- not used at all, and whose cursor field has the initial cursor.
818 -- The second entry corresponds to a standard new region action. A
819 -- PC_R_Remove node is stacked, whose cursor field is used to store
820 -- the outer stack base, and the stack base is reset to point to
821 -- this PC_R_Remove node. Then the pattern P is matched, and it can
822 -- make history stack entries in the normal manner, so now the stack
825 -- (stack entries made before assign pattern)
827 -- (Special entry, node field not used,
828 -- used only to save initial cursor)
830 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
831 -- saved base value for the enclosing region)
833 -- (stack entries made by matching P)
835 -- If the match of P fails, then the PC_R_Remove entry is popped and
836 -- it removes both itself and the special entry underneath it,
837 -- restores the outer stack base, and signals failure.
839 -- If the match of P succeeds, then node Y, the PC_Arbno_Y node, pops
840 -- the inner region. There are two possibilities. If matching P left
841 -- no stack entries, then all traces of the inner region can be removed.
842 -- If there are stack entries, then we push an PC_Region_Replace stack
843 -- entry whose "cursor" value is the inner stack base value, and then
844 -- restore the outer stack base value, so the stack looks like:
846 -- (stack entries made before assign pattern)
848 -- (Special entry, node field not used,
849 -- used only to save initial cursor)
851 -- (PC_R_Remove entry, "cursor" value is (negative)
852 -- saved base value for the enclosing region)
854 -- (stack entries made by matching P)
856 -- (PC_Region_Replace entry, "cursor" value is (negative)
857 -- stack pointer value referencing the PC_R_Remove entry).
859 -- Now that we have matched another instance of the Arbno pattern,
860 -- we need to move to the successor. There are two cases. If the
861 -- Arbno pattern matched null, then there is no point in seeking
862 -- alternatives, since we would just match a whole bunch of nulls.
863 -- In this case we look through the alternative node, and move
864 -- directly to its successor (i.e. the successor of the Arbno
865 -- pattern). If on the other hand a non-null string was matched,
866 -- we simply follow the successor to the alternative node, which
867 -- sets up for another possible match of the Arbno pattern.
869 -- As noted in the section on stack checking, the stack count (and
870 -- hence the stack check) for a pattern includes only one iteration
871 -- of the Arbno pattern. To make sure that multiple iterations do not
872 -- overflow the stack, the Arbno node saves the stack count required
873 -- by a single iteration, and the Concat function increments this to
874 -- include stack entries required by any successor. The PC_Arbno_Y
875 -- node uses this count to ensure that sufficient stack remains
876 -- before proceeding after matching each new instance.
878 -- The node numbering of the constituent pattern P is not affected.
879 -- Where N is the number of nodes in P, the Y node is numbered N + 1,
880 -- the E node is N + 2, and the X node is N + 3.
882 ----------------------
883 -- Assign Immediate --
884 ----------------------
886 -- Immediate assignment (P * V) constructs the following structure
889 -- | E |---->| P |---->| A |---->
892 -- Here E is the PC_R_Enter node which matches null and creates two
893 -- stack entries. The first is a special entry whose node field is
894 -- not used at all, and whose cursor field has the initial cursor.
896 -- The second entry corresponds to a standard new region action. A
897 -- PC_R_Remove node is stacked, whose cursor field is used to store
898 -- the outer stack base, and the stack base is reset to point to
899 -- this PC_R_Remove node. Then the pattern P is matched, and it can
900 -- make history stack entries in the normal manner, so now the stack
903 -- (stack entries made before assign pattern)
905 -- (Special entry, node field not used,
906 -- used only to save initial cursor)
908 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
909 -- saved base value for the enclosing region)
911 -- (stack entries made by matching P)
913 -- If the match of P fails, then the PC_R_Remove entry is popped
914 -- and it removes both itself and the special entry underneath it,
915 -- restores the outer stack base, and signals failure.
917 -- If the match of P succeeds, then node A, which is the actual
918 -- PC_Assign_Imm node, executes the assignment (using the stack
919 -- base to locate the entry with the saved starting cursor value),
920 -- and the pops the inner region. There are two possibilities, if
921 -- matching P left no stack entries, then all traces of the inner
922 -- region can be removed. If there are stack entries, then we push
923 -- an PC_Region_Replace stack entry whose "cursor" value is the
924 -- inner stack base value, and then restore the outer stack base
925 -- value, so the stack looks like:
927 -- (stack entries made before assign pattern)
929 -- (Special entry, node field not used,
930 -- used only to save initial cursor)
932 -- (PC_R_Remove entry, "cursor" value is (negative)
933 -- saved base value for the enclosing region)
935 -- (stack entries made by matching P)
937 -- (PC_Region_Replace entry, "cursor" value is the (negative)
938 -- stack pointer value referencing the PC_R_Remove entry).
940 -- If a subsequent failure occurs, the PC_Region_Replace node restores
941 -- the inner stack base value and signals failure to explore rematches
944 -- The node numbering of the constituent pattern P is not affected.
945 -- Where N is the number of nodes in P, the A node is numbered N + 1,
946 -- and the E node is N + 2.
948 ---------------------
949 -- Assign On Match --
950 ---------------------
952 -- The assign on match (**) pattern is quite similar to the assign
953 -- immediate pattern, except that the actual assignment has to be
954 -- delayed. The following structure is constructed:
957 -- | E |---->| P |---->| A |---->
960 -- The operation of this pattern is identical to that described above
961 -- for deferred assignment, up to the point where P has been matched.
963 -- The A node, which is the PC_Assign_OnM node first pushes a
964 -- PC_Assign node onto the history stack. This node saves the ending
965 -- cursor and acts as a flag for the final assignment, as further
968 -- It then stores a pointer to itself in the special entry node field.
969 -- This was otherwise unused, and is now used to retrieve the address
970 -- of the variable to be assigned at the end of the pattern.
972 -- After that the inner region is terminated in the usual manner,
973 -- by stacking a PC_R_Restore entry as described for the assign
974 -- immediate case. Note that the optimization of completely
975 -- removing the inner region does not happen in this case, since
976 -- we have at least one stack entry (the PC_Assign one we just made).
977 -- The stack now looks like:
979 -- (stack entries made before assign pattern)
981 -- (Special entry, node points to copy of
982 -- the PC_Assign_OnM node, and the
983 -- cursor field saves the initial cursor).
985 -- (PC_R_Remove entry, "cursor" value is (negative)
986 -- saved base value for the enclosing region)
988 -- (stack entries made by matching P)
990 -- (PC_Assign entry, saves final cursor)
992 -- (PC_Region_Replace entry, "cursor" value is (negative)
993 -- stack pointer value referencing the PC_R_Remove entry).
995 -- If a subsequent failure causes the PC_Assign node to execute it
996 -- simply removes itself and propagates the failure.
998 -- If the match succeeds, then the history stack is scanned for
999 -- PC_Assign nodes, and the assignments are executed (examination
1000 -- of the above diagram will show that all the necessary data is
1001 -- at hand for the assignment).
1003 -- To optimize the common case where no assign-on-match operations
1004 -- are present, a global flag Assign_OnM is maintained which is
1005 -- initialize to False, and gets set True as part of the execution
1006 -- of the PC_Assign_OnM node. The scan of the history stack for
1007 -- PC_Assign entries is done only if this flag is set.
1009 -- The node numbering of the constituent pattern P is not affected.
1010 -- Where N is the number of nodes in P, the A node is numbered N + 1,
1011 -- and the E node is N + 2.
1017 -- Bal builds a single node:
1023 -- The node B is the PC_Bal node which matches a parentheses balanced
1024 -- string, starting at the current cursor position. It then updates
1025 -- the cursor past this matched string, and stacks a pointer to itself
1026 -- with this updated cursor value on the history stack, to extend the
1027 -- matched string on a subsequent failure.
1029 -- Since this is a single node it is numbered 1 (the reason we include
1030 -- it in the compound patterns section is that it backtracks).
1036 -- BreakX builds the structure
1039 -- | B |---->| A |---->
1047 -- Here the B node is the BreakX_xx node that performs a normal Break
1048 -- function. The A node is an alternative (PC_Alt) node that matches
1049 -- null, but stacks a pointer to node X (the PC_BreakX_X node) which
1050 -- extends the match one character (to eat up the previously detected
1051 -- break character), and then rematches the break.
1053 -- The B node is numbered 3, the alternative node is 1, and the X
1060 -- Fence builds a single node:
1066 -- The element F, PC_Fence, matches null, and stacks a pointer to a
1067 -- PC_Cancel element which will abort the match on a subsequent failure.
1069 -- Since this is a single element it is numbered 1 (the reason we
1070 -- include it in the compound patterns section is that it backtracks).
1072 --------------------
1073 -- Fence Function --
1074 --------------------
1076 -- A call to the Fence function builds the structure:
1078 -- +---+ +---+ +---+
1079 -- | E |---->| P |---->| X |---->
1080 -- +---+ +---+ +---+
1082 -- Here E is the PC_R_Enter node which matches null and creates two
1083 -- stack entries. The first is a special entry which is not used at
1084 -- all in the fence case (it is present merely for uniformity with
1085 -- other cases of region enter operations).
1087 -- The second entry corresponds to a standard new region action. A
1088 -- PC_R_Remove node is stacked, whose cursor field is used to store
1089 -- the outer stack base, and the stack base is reset to point to
1090 -- this PC_R_Remove node. Then the pattern P is matched, and it can
1091 -- make history stack entries in the normal manner, so now the stack
1094 -- (stack entries made before fence pattern)
1096 -- (Special entry, not used at all)
1098 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
1099 -- saved base value for the enclosing region)
1101 -- (stack entries made by matching P)
1103 -- If the match of P fails, then the PC_R_Remove entry is popped
1104 -- and it removes both itself and the special entry underneath it,
1105 -- restores the outer stack base, and signals failure.
1107 -- If the match of P succeeds, then node X, the PC_Fence_X node, gets
1108 -- control. One might be tempted to think that at this point, the
1109 -- history stack entries made by matching P can just be removed since
1110 -- they certainly are not going to be used for rematching (that is
1111 -- whole point of Fence after all). However, this is wrong, because
1112 -- it would result in the loss of possible assign-on-match entries
1113 -- for deferred pattern assignments.
1115 -- Instead what we do is to make a special entry whose node references
1116 -- PC_Fence_Y, and whose cursor saves the inner stack base value, i.e.
1117 -- the pointer to the PC_R_Remove entry. Then the outer stack base
1118 -- pointer is restored, so the stack looks like:
1120 -- (stack entries made before assign pattern)
1122 -- (Special entry, not used at all)
1124 -- (PC_R_Remove entry, "cursor" value is (negative)
1125 -- saved base value for the enclosing region)
1127 -- (stack entries made by matching P)
1129 -- (PC_Fence_Y entry, "cursor" value is (negative) stack
1130 -- pointer value referencing the PC_R_Remove entry).
1132 -- If a subsequent failure occurs, then the PC_Fence_Y entry removes
1133 -- the entire inner region, including all entries made by matching P,
1134 -- and alternatives prior to the Fence pattern are sought.
1136 -- The node numbering of the constituent pattern P is not affected.
1137 -- Where N is the number of nodes in P, the X node is numbered N + 1,
1138 -- and the E node is N + 2.
1144 -- Succeed builds a single node:
1150 -- The node S is the PC_Succeed node which matches null, and stacks
1151 -- a pointer to itself on the history stack, so that a subsequent
1152 -- failure repeats the same match.
1154 -- Since this is a single node it is numbered 1 (the reason we include
1155 -- it in the compound patterns section is that it backtracks).
1157 ---------------------
1158 -- Write Immediate --
1159 ---------------------
1161 -- The structure built for a write immediate operation (P * F, where
1162 -- F is a file access value) is:
1164 -- +---+ +---+ +---+
1165 -- | E |---->| P |---->| W |---->
1166 -- +---+ +---+ +---+
1168 -- Here E is the PC_R_Enter node and W is the PC_Write_Imm node. The
1169 -- handling is identical to that described above for Assign Immediate,
1170 -- except that at the point where a successful match occurs, the matched
1171 -- substring is written to the referenced file.
1173 -- The node numbering of the constituent pattern P is not affected.
1174 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1175 -- and the E node is N + 2.
1177 --------------------
1178 -- Write On Match --
1179 --------------------
1181 -- The structure built for a write on match operation (P ** F, where
1182 -- F is a file access value) is:
1184 -- +---+ +---+ +---+
1185 -- | E |---->| P |---->| W |---->
1186 -- +---+ +---+ +---+
1188 -- Here E is the PC_R_Enter node and W is the PC_Write_OnM node. The
1189 -- handling is identical to that described above for Assign On Match,
1190 -- except that at the point where a successful match has completed,
1191 -- the matched substring is written to the referenced file.
1193 -- The node numbering of the constituent pattern P is not affected.
1194 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1195 -- and the E node is N + 2.
1196 -----------------------
1197 -- Constant Patterns --
1198 -----------------------
1200 -- The following pattern elements are referenced only from the pattern
1201 -- history stack. In each case the processing for the pattern element
1202 -- results in pattern match abort, or further failure, so there is no
1203 -- need for a successor and no need for a node number
1205 CP_Assign
: aliased PE
:= (PC_Assign
, 0, N
);
1206 CP_Cancel
: aliased PE
:= (PC_Cancel
, 0, N
);
1207 CP_Fence_Y
: aliased PE
:= (PC_Fence_Y
, 0, N
);
1208 CP_R_Remove
: aliased PE
:= (PC_R_Remove
, 0, N
);
1209 CP_R_Restore
: aliased PE
:= (PC_R_Restore
, 0, N
);
1211 -----------------------
1212 -- Local Subprograms --
1213 -----------------------
1215 function Alternate
(L
, R
: PE_Ptr
) return PE_Ptr
;
1216 function "or" (L
, R
: PE_Ptr
) return PE_Ptr
renames Alternate
;
1217 -- Build pattern structure corresponding to the alternation of L, R.
1218 -- (i.e. try to match L, and if that fails, try to match R).
1220 function Arbno_Simple
(P
: PE_Ptr
) return PE_Ptr
;
1221 -- Build simple Arbno pattern, P is a pattern that is guaranteed to
1222 -- match at least one character if it succeeds and to require no
1223 -- stack entries under all circumstances. The result returned is
1224 -- a simple Arbno structure as previously described.
1226 function Bracket
(E
, P
, A
: PE_Ptr
) return PE_Ptr
;
1227 -- Given two single node pattern elements E and A, and a (possible
1228 -- complex) pattern P, construct the concatenation E-->P-->A and
1229 -- return a pointer to E. The concatenation does not affect the
1230 -- node numbering in P. A has a number one higher than the maximum
1231 -- number in P, and E has a number two higher than the maximum
1232 -- number in P (see for example the Assign_Immediate structure to
1233 -- understand a typical use of this function).
1235 function BreakX_Make
(B
: PE_Ptr
) return Pattern
;
1236 -- Given a pattern element for a Break pattern, returns the
1237 -- corresponding BreakX compound pattern structure.
1239 function Concat
(L
, R
: PE_Ptr
; Incr
: Natural) return PE_Ptr
;
1240 -- Creates a pattern element that represents a concatenation of the
1241 -- two given pattern elements (i.e. the pattern L followed by R).
1242 -- The result returned is always the same as L, but the pattern
1243 -- referenced by L is modified to have R as a successor. This
1244 -- procedure does not copy L or R, so if a copy is required, it
1245 -- is the responsibility of the caller. The Incr parameter is an
1246 -- amount to be added to the Nat field of any P_Arbno_Y node that is
1247 -- in the left operand, it represents the additional stack space
1248 -- required by the right operand.
1250 function C_To_PE
(C
: PChar
) return PE_Ptr
;
1251 -- Given a character, constructs a pattern element that matches
1252 -- the single character.
1254 function Copy
(P
: PE_Ptr
) return PE_Ptr
;
1255 -- Creates a copy of the pattern element referenced by the given
1256 -- pattern element reference. This is a deep copy, which means that
1257 -- it follows the Next and Alt pointers.
1259 function Image
(P
: PE_Ptr
) return String;
1260 -- Returns the image of the address of the referenced pattern element.
1261 -- This is equivalent to Image (To_Address (P));
1263 function Is_In
(C
: Character; Str
: String) return Boolean;
1264 pragma Inline
(Is_In
);
1265 -- Determines if the character C is in string Str
1267 procedure Logic_Error
;
1268 -- Called to raise Program_Error with an appropriate message if an
1269 -- internal logic error is detected.
1271 function Str_BF
(A
: Boolean_Func
) return String;
1272 function Str_FP
(A
: File_Ptr
) return String;
1273 function Str_NF
(A
: Natural_Func
) return String;
1274 function Str_NP
(A
: Natural_Ptr
) return String;
1275 function Str_PP
(A
: Pattern_Ptr
) return String;
1276 function Str_VF
(A
: VString_Func
) return String;
1277 function Str_VP
(A
: VString_Ptr
) return String;
1278 -- These are debugging routines, which return a representation of the
1279 -- given access value (they are called only by Image and Dump)
1281 procedure Set_Successor
(Pat
: PE_Ptr
; Succ
: PE_Ptr
);
1282 -- Adjusts all EOP pointers in Pat to point to Succ. No other changes
1283 -- are made. In particular, Succ is unchanged, and no index numbers
1284 -- are modified. Note that Pat may not be equal to EOP on entry.
1286 function S_To_PE
(Str
: PString
) return PE_Ptr
;
1287 -- Given a string, constructs a pattern element that matches the string
1289 procedure Uninitialized_Pattern
;
1290 pragma No_Return
(Uninitialized_Pattern
);
1291 -- Called to raise Program_Error with an appropriate error message if
1292 -- an uninitialized pattern is used in any pattern construction or
1293 -- pattern matching operation.
1299 Start
: out Natural;
1300 Stop
: out Natural);
1301 -- This is the common pattern match routine. It is passed a string and
1302 -- a pattern, and it indicates success or failure, and on success the
1303 -- section of the string matched. It does not perform any assignments
1304 -- to the subject string, so pattern replacement is for the caller.
1306 -- Subject The subject string. The lower bound is always one. In the
1307 -- Match procedures, it is fine to use strings whose lower bound
1308 -- is not one, but we perform a one time conversion before the
1309 -- call to XMatch, so that XMatch does not have to be bothered
1310 -- with strange lower bounds.
1312 -- Pat_P Points to initial pattern element of pattern to be matched
1314 -- Pat_S Maximum required stack entries for pattern to be matched
1316 -- Start If match is successful, starting index of matched section.
1317 -- This value is always non-zero. A value of zero is used to
1318 -- indicate a failed match.
1320 -- Stop If match is successful, ending index of matched section.
1321 -- This can be zero if we match the null string at the start,
1322 -- in which case Start is set to zero, and Stop to one. If the
1323 -- Match fails, then the contents of Stop is undefined.
1329 Start
: out Natural;
1330 Stop
: out Natural);
1331 -- Identical in all respects to XMatch, except that trace information is
1332 -- output on Standard_Output during execution of the match. This is the
1333 -- version that is called if the original Match call has Debug => True.
1339 function "&" (L
: PString
; R
: Pattern
) return Pattern
is
1341 return (AFC
with R
.Stk
, Concat
(S_To_PE
(L
), Copy
(R
.P
), R
.Stk
));
1344 function "&" (L
: Pattern
; R
: PString
) return Pattern
is
1346 return (AFC
with L
.Stk
, Concat
(Copy
(L
.P
), S_To_PE
(R
), 0));
1349 function "&" (L
: PChar
; R
: Pattern
) return Pattern
is
1351 return (AFC
with R
.Stk
, Concat
(C_To_PE
(L
), Copy
(R
.P
), R
.Stk
));
1354 function "&" (L
: Pattern
; R
: PChar
) return Pattern
is
1356 return (AFC
with L
.Stk
, Concat
(Copy
(L
.P
), C_To_PE
(R
), 0));
1359 function "&" (L
: Pattern
; R
: Pattern
) return Pattern
is
1361 return (AFC
with L
.Stk
+ R
.Stk
, Concat
(Copy
(L
.P
), Copy
(R
.P
), R
.Stk
));
1370 -- +---+ +---+ +---+
1371 -- | E |---->| P |---->| A |---->
1372 -- +---+ +---+ +---+
1374 -- The node numbering of the constituent pattern P is not affected.
1375 -- Where N is the number of nodes in P, the A node is numbered N + 1,
1376 -- and the E node is N + 2.
1378 function "*" (P
: Pattern
; Var
: VString_Var
) return Pattern
is
1379 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
1380 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1381 A : constant PE_Ptr :=
1382 new PE'(PC_Assign_Imm
, 0, EOP
, Var
'Unrestricted_Access);
1384 return (AFC
with P
.Stk
+ 3, Bracket
(E
, Pat
, A
));
1387 function "*" (P
: PString
; Var
: VString_Var
) return Pattern
is
1388 Pat
: constant PE_Ptr
:= S_To_PE
(P
);
1389 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1390 A : constant PE_Ptr :=
1391 new PE'(PC_Assign_Imm
, 0, EOP
, Var
'Unrestricted_Access);
1393 return (AFC
with 3, Bracket
(E
, Pat
, A
));
1396 function "*" (P
: PChar
; Var
: VString_Var
) return Pattern
is
1397 Pat
: constant PE_Ptr
:= C_To_PE
(P
);
1398 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1399 A : constant PE_Ptr :=
1400 new PE'(PC_Assign_Imm
, 0, EOP
, Var
'Unrestricted_Access);
1402 return (AFC
with 3, Bracket
(E
, Pat
, A
));
1407 -- +---+ +---+ +---+
1408 -- | E |---->| P |---->| W |---->
1409 -- +---+ +---+ +---+
1411 -- The node numbering of the constituent pattern P is not affected.
1412 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1413 -- and the E node is N + 2.
1415 function "*" (P
: Pattern
; Fil
: File_Access
) return Pattern
is
1416 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
1417 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1418 W : constant PE_Ptr := new PE'(PC_Write_Imm
, 0, EOP
, Fil
);
1420 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1423 function "*" (P
: PString
; Fil
: File_Access
) return Pattern
is
1424 Pat
: constant PE_Ptr
:= S_To_PE
(P
);
1425 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1426 W : constant PE_Ptr := new PE'(PC_Write_Imm
, 0, EOP
, Fil
);
1428 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1431 function "*" (P
: PChar
; Fil
: File_Access
) return Pattern
is
1432 Pat
: constant PE_Ptr
:= C_To_PE
(P
);
1433 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1434 W : constant PE_Ptr := new PE'(PC_Write_Imm
, 0, EOP
, Fil
);
1436 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1445 -- +---+ +---+ +---+
1446 -- | E |---->| P |---->| A |---->
1447 -- +---+ +---+ +---+
1449 -- The node numbering of the constituent pattern P is not affected.
1450 -- Where N is the number of nodes in P, the A node is numbered N + 1,
1451 -- and the E node is N + 2.
1453 function "**" (P
: Pattern
; Var
: VString_Var
) return Pattern
is
1454 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
1455 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1456 A : constant PE_Ptr :=
1457 new PE'(PC_Assign_OnM
, 0, EOP
, Var
'Unrestricted_Access);
1459 return (AFC
with P
.Stk
+ 3, Bracket
(E
, Pat
, A
));
1462 function "**" (P
: PString
; Var
: VString_Var
) return Pattern
is
1463 Pat
: constant PE_Ptr
:= S_To_PE
(P
);
1464 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1465 A : constant PE_Ptr :=
1466 new PE'(PC_Assign_OnM
, 0, EOP
, Var
'Unrestricted_Access);
1468 return (AFC
with 3, Bracket
(E
, Pat
, A
));
1471 function "**" (P
: PChar
; Var
: VString_Var
) return Pattern
is
1472 Pat
: constant PE_Ptr
:= C_To_PE
(P
);
1473 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1474 A : constant PE_Ptr :=
1475 new PE'(PC_Assign_OnM
, 0, EOP
, Var
'Unrestricted_Access);
1477 return (AFC
with 3, Bracket
(E
, Pat
, A
));
1482 -- +---+ +---+ +---+
1483 -- | E |---->| P |---->| W |---->
1484 -- +---+ +---+ +---+
1486 -- The node numbering of the constituent pattern P is not affected.
1487 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1488 -- and the E node is N + 2.
1490 function "**" (P
: Pattern
; Fil
: File_Access
) return Pattern
is
1491 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
1492 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1493 W : constant PE_Ptr := new PE'(PC_Write_OnM
, 0, EOP
, Fil
);
1495 return (AFC
with P
.Stk
+ 3, Bracket
(E
, Pat
, W
));
1498 function "**" (P
: PString
; Fil
: File_Access
) return Pattern
is
1499 Pat
: constant PE_Ptr
:= S_To_PE
(P
);
1500 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1501 W : constant PE_Ptr := new PE'(PC_Write_OnM
, 0, EOP
, Fil
);
1503 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1506 function "**" (P
: PChar
; Fil
: File_Access
) return Pattern
is
1507 Pat
: constant PE_Ptr
:= C_To_PE
(P
);
1508 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1509 W : constant PE_Ptr := new PE'(PC_Write_OnM
, 0, EOP
, Fil
);
1511 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1518 function "+" (Str
: VString_Var
) return Pattern
is
1522 new PE
'(PC_String_VP, 1, EOP, Str'Unrestricted_Access));
1525 function "+" (Str : VString_Func) return Pattern is
1527 return (AFC with 0, new PE'(PC_String_VF
, 1, EOP
, Str
));
1530 function "+" (P
: Pattern_Var
) return Pattern
is
1534 new PE
'(PC_Rpat, 1, EOP, P'Unrestricted_Access));
1537 function "+" (P : Boolean_Func) return Pattern is
1539 return (AFC with 3, new PE'(PC_Pred_Func
, 1, EOP
, P
));
1546 function "or" (L
: PString
; R
: Pattern
) return Pattern
is
1548 return (AFC
with R
.Stk
+ 1, S_To_PE
(L
) or Copy
(R
.P
));
1551 function "or" (L
: Pattern
; R
: PString
) return Pattern
is
1553 return (AFC
with L
.Stk
+ 1, Copy
(L
.P
) or S_To_PE
(R
));
1556 function "or" (L
: PString
; R
: PString
) return Pattern
is
1558 return (AFC
with 1, S_To_PE
(L
) or S_To_PE
(R
));
1561 function "or" (L
: Pattern
; R
: Pattern
) return Pattern
is
1564 Natural'Max (L
.Stk
, R
.Stk
) + 1, Copy
(L
.P
) or Copy
(R
.P
));
1567 function "or" (L
: PChar
; R
: Pattern
) return Pattern
is
1569 return (AFC
with 1, C_To_PE
(L
) or Copy
(R
.P
));
1572 function "or" (L
: Pattern
; R
: PChar
) return Pattern
is
1574 return (AFC
with 1, Copy
(L
.P
) or C_To_PE
(R
));
1577 function "or" (L
: PChar
; R
: PChar
) return Pattern
is
1579 return (AFC
with 1, C_To_PE
(L
) or C_To_PE
(R
));
1582 function "or" (L
: PString
; R
: PChar
) return Pattern
is
1584 return (AFC
with 1, S_To_PE
(L
) or C_To_PE
(R
));
1587 function "or" (L
: PChar
; R
: PString
) return Pattern
is
1589 return (AFC
with 1, C_To_PE
(L
) or S_To_PE
(R
));
1596 -- No two patterns share the same pattern elements, so the adjust
1597 -- procedure for a Pattern assignment must do a deep copy of the
1598 -- pattern element structure.
1600 procedure Adjust
(Object
: in out Pattern
) is
1602 Object
.P
:= Copy
(Object
.P
);
1609 function Alternate
(L
, R
: PE_Ptr
) return PE_Ptr
is
1611 -- If the left pattern is null, then we just add the alternation
1612 -- node with an index one greater than the right hand pattern.
1615 return new PE
'(PC_Alt, R.Index + 1, EOP, R);
1617 -- If the left pattern is non-null, then build a reference vector
1618 -- for its elements, and adjust their index values to accommodate
1619 -- the right hand elements. Then add the alternation node.
1623 Refs : Ref_Array (1 .. L.Index);
1626 Build_Ref_Array (L, Refs);
1628 for J in Refs'Range loop
1629 Refs (J).Index := Refs (J).Index + R.Index;
1633 return new PE'(PC_Alt
, L
.Index
+ 1, L
, R
);
1641 function Any
(Str
: String) return Pattern
is
1643 return (AFC
with 0, new PE
'(PC_Any_CS, 1, EOP, To_Set (Str)));
1646 function Any (Str : VString) return Pattern is
1648 return Any (S (Str));
1651 function Any (Str : Character) return Pattern is
1653 return (AFC with 0, new PE'(PC_Any_CH
, 1, EOP
, Str
));
1656 function Any
(Str
: Character_Set
) return Pattern
is
1658 return (AFC
with 0, new PE
'(PC_Any_CS, 1, EOP, Str));
1661 function Any (Str : not null access VString) return Pattern is
1663 return (AFC with 0, new PE'(PC_Any_VP
, 1, EOP
, VString_Ptr
(Str
)));
1666 function Any
(Str
: VString_Func
) return Pattern
is
1668 return (AFC
with 0, new PE
'(PC_Any_VF, 1, EOP, Str));
1684 -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1
1686 function Arb return Pattern is
1687 Y : constant PE_Ptr := new PE'(PC_Arb_Y
, 1, EOP
);
1688 X
: constant PE_Ptr
:= new PE
'(PC_Arb_X, 2, EOP, Y);
1690 return (AFC with 1, X);
1697 function Arbno (P : PString) return Pattern is
1699 if P'Length = 0 then
1700 return (AFC with 0, EOP);
1702 return (AFC with 0, Arbno_Simple (S_To_PE (P)));
1706 function Arbno (P : PChar) return Pattern is
1708 return (AFC with 0, Arbno_Simple (C_To_PE (P)));
1711 function Arbno (P : Pattern) return Pattern is
1712 Pat : constant PE_Ptr := Copy (P.P);
1716 and then OK_For_Simple_Arbno (Pat.Pcode)
1718 return (AFC with 0, Arbno_Simple (Pat));
1721 -- This is the complex case, either the pattern makes stack entries
1722 -- or it is possible for the pattern to match the null string (more
1723 -- accurately, we don't know that this is not the case).
1725 -- +--------------------------+
1733 -- +---+ +---+ +---+ |
1734 -- | E |---->| P |---->| Y |--->+
1735 -- +---+ +---+ +---+
1737 -- The node numbering of the constituent pattern P is not affected.
1738 -- Where N is the number of nodes in P, the Y node is numbered N + 1,
1739 -- the E node is N + 2, and the X node is N + 3.
1742 E : constant PE_Ptr := new PE'(PC_R_Enter
, 0, EOP
);
1743 X
: constant PE_Ptr
:= new PE
'(PC_Arbno_X, 0, EOP, E);
1744 Y : constant PE_Ptr := new PE'(PC_Arbno_Y
, 0, X
, P
.Stk
+ 3);
1745 EPY
: constant PE_Ptr
:= Bracket
(E
, Pat
, Y
);
1748 X
.Index
:= EPY
.Index
+ 1;
1749 return (AFC
with P
.Stk
+ 3, X
);
1766 -- | P |---------->+
1769 -- The node numbering of the constituent pattern P is not affected.
1770 -- The S node has a node number of P.Index + 1.
1772 -- Note that we know that P cannot be EOP, because a null pattern
1773 -- does not meet the requirements for simple Arbno.
1775 function Arbno_Simple
(P
: PE_Ptr
) return PE_Ptr
is
1776 S
: constant PE_Ptr
:= new PE
'(PC_Arbno_S, P.Index + 1, EOP, P);
1778 Set_Successor (P, S);
1786 function Bal return Pattern is
1788 return (AFC with 1, new PE'(PC_Bal
, 1, EOP
));
1795 function Bracket
(E
, P
, A
: PE_Ptr
) return PE_Ptr
is
1804 Set_Successor
(P
, A
);
1805 E
.Index
:= P
.Index
+ 2;
1806 A
.Index
:= P
.Index
+ 1;
1816 function Break
(Str
: String) return Pattern
is
1818 return (AFC
with 0, new PE
'(PC_Break_CS, 1, EOP, To_Set (Str)));
1821 function Break (Str : VString) return Pattern is
1823 return Break (S (Str));
1826 function Break (Str : Character) return Pattern is
1828 return (AFC with 0, new PE'(PC_Break_CH
, 1, EOP
, Str
));
1831 function Break
(Str
: Character_Set
) return Pattern
is
1833 return (AFC
with 0, new PE
'(PC_Break_CS, 1, EOP, Str));
1836 function Break (Str : not null access VString) return Pattern is
1839 new PE'(PC_Break_VP
, 1, EOP
, Str
.all'Unchecked_Access));
1842 function Break
(Str
: VString_Func
) return Pattern
is
1844 return (AFC
with 0, new PE
'(PC_Break_VF, 1, EOP, Str));
1851 function BreakX (Str : String) return Pattern is
1853 return BreakX_Make (new PE'(PC_BreakX_CS
, 3, N
, To_Set
(Str
)));
1856 function BreakX
(Str
: VString
) return Pattern
is
1858 return BreakX
(S
(Str
));
1861 function BreakX
(Str
: Character) return Pattern
is
1863 return BreakX_Make
(new PE
'(PC_BreakX_CH, 3, N, Str));
1866 function BreakX (Str : Character_Set) return Pattern is
1868 return BreakX_Make (new PE'(PC_BreakX_CS
, 3, N
, Str
));
1871 function BreakX
(Str
: not null access VString
) return Pattern
is
1873 return BreakX_Make
(new PE
'(PC_BreakX_VP, 3, N, VString_Ptr (Str)));
1876 function BreakX (Str : VString_Func) return Pattern is
1878 return BreakX_Make (new PE'(PC_BreakX_VF
, 3, N
, Str
));
1886 -- | B |---->| A |---->
1894 -- The B node is numbered 3, the alternative node is 1, and the X
1897 function BreakX_Make
(B
: PE_Ptr
) return Pattern
is
1898 X
: constant PE_Ptr
:= new PE
'(PC_BreakX_X, 2, B);
1899 A : constant PE_Ptr := new PE'(PC_Alt
, 1, EOP
, X
);
1902 return (AFC
with 2, B
);
1905 ---------------------
1906 -- Build_Ref_Array --
1907 ---------------------
1909 procedure Build_Ref_Array
(E
: PE_Ptr
; RA
: out Ref_Array
) is
1911 procedure Record_PE
(E
: PE_Ptr
);
1912 -- Record given pattern element if not already recorded in RA,
1913 -- and also record any referenced pattern elements recursively.
1919 procedure Record_PE
(E
: PE_Ptr
) is
1921 PutD
(" Record_PE called with PE_Ptr = " & Image
(E
));
1923 if E
= EOP
or else RA
(E
.Index
) /= null then
1924 Put_LineD
(", nothing to do");
1928 Put_LineD
(", recording" & IndexT
'Image (E
.Index
));
1930 Record_PE
(E
.Pthen
);
1932 if E
.Pcode
in PC_Has_Alt
then
1938 -- Start of processing for Build_Ref_Array
1942 Put_LineD
("Entering Build_Ref_Array");
1945 end Build_Ref_Array
;
1951 function C_To_PE
(C
: PChar
) return PE_Ptr
is
1953 return new PE
'(PC_Char, 1, EOP, C);
1960 function Cancel return Pattern is
1962 return (AFC with 0, new PE'(PC_Cancel
, 1, EOP
));
1969 -- Concat needs to traverse the left operand performing the following
1972 -- a) Any successor pointers (Pthen fields) that are set to EOP are
1973 -- reset to point to the second operand.
1975 -- b) Any PC_Arbno_Y node has its stack count field incremented
1976 -- by the parameter Incr provided for this purpose.
1978 -- d) Num fields of all pattern elements in the left operand are
1979 -- adjusted to include the elements of the right operand.
1981 -- Note: we do not use Set_Successor in the processing for Concat, since
1982 -- there is no point in doing two traversals, we may as well do everything
1983 -- at the same time.
1985 function Concat
(L
, R
: PE_Ptr
; Incr
: Natural) return PE_Ptr
is
1995 Refs
: Ref_Array
(1 .. L
.Index
);
1996 -- We build a reference array for L whose N'th element points to
1997 -- the pattern element of L whose original Index value is N.
2002 Build_Ref_Array
(L
, Refs
);
2004 for J
in Refs
'Range loop
2007 P
.Index
:= P
.Index
+ R
.Index
;
2009 if P
.Pcode
= PC_Arbno_Y
then
2010 P
.Nat
:= P
.Nat
+ Incr
;
2013 if P
.Pthen
= EOP
then
2017 if P
.Pcode
in PC_Has_Alt
and then P
.Alt
= EOP
then
2031 function Copy
(P
: PE_Ptr
) return PE_Ptr
is
2034 Uninitialized_Pattern
;
2038 Refs
: Ref_Array
(1 .. P
.Index
);
2039 -- References to elements in P, indexed by Index field
2041 Copy
: Ref_Array
(1 .. P
.Index
);
2042 -- Holds copies of elements of P, indexed by Index field
2047 Build_Ref_Array
(P
, Refs
);
2049 -- Now copy all nodes
2051 for J
in Refs
'Range loop
2052 Copy
(J
) := new PE
'(Refs (J).all);
2055 -- Adjust all internal references
2057 for J in Copy'Range loop
2060 -- Adjust successor pointer to point to copy
2062 if E.Pthen /= EOP then
2063 E.Pthen := Copy (E.Pthen.Index);
2066 -- Adjust Alt pointer if there is one to point to copy
2068 if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then
2069 E.Alt := Copy (E.Alt.Index);
2072 -- Copy referenced string
2074 if E.Pcode = PC_String then
2075 E.Str := new String'(E
.Str
.all);
2079 return Copy
(P
.Index
);
2088 procedure Dump
(P
: Pattern
) is
2089 procedure Write_Node_Id
(E
: PE_Ptr
; Cols
: Natural);
2090 -- Writes out a string identifying the given pattern element. Cols is
2091 -- the column indentation level.
2097 procedure Write_Node_Id
(E
: PE_Ptr
; Cols
: Natural) is
2102 for J
in 4 .. Cols
loop
2108 Str
: String (1 .. Cols
);
2109 N
: Natural := Natural (E
.Index
);
2114 for J
in reverse Str
'Range loop
2115 Str
(J
) := Character'Val (48 + N
mod 10);
2126 Cols
: Natural := 2;
2127 -- Number of columns used for pattern numbers, minimum is 2
2131 subtype Count
is Ada
.Text_IO
.Count
;
2133 -- Used to keep track of column in dump output
2135 -- Start of processing for Dump
2140 ("Pattern Dump Output (pattern at "
2143 & Natural'Image (P
.Stk
) & ')');
2148 while Col
< Scol
loop
2154 -- If uninitialized pattern, dump line and we are done
2157 Put_Line
("Uninitialized pattern value");
2161 -- If null pattern, just dump it and we are all done
2164 Put_Line
("EOP (null pattern)");
2169 Refs
: Ref_Array
(1 .. P
.P
.Index
);
2170 -- We build a reference array whose N'th element points to the
2171 -- pattern element whose Index value is N.
2174 Build_Ref_Array
(P
.P
, Refs
);
2176 -- Set number of columns required for node numbers
2178 while 10 ** Cols
- 1 < Integer (P
.P
.Index
) loop
2182 -- Now dump the nodes in reverse sequence. We output them in reverse
2183 -- sequence since this corresponds to the natural order used to
2184 -- construct the patterns.
2186 for J
in reverse Refs
'Range loop
2188 Write_Node_Id
(E
, Cols
);
2189 Set_Col
(Count
(Cols
) + 4);
2192 Put
(Pattern_Code
'Image (E
.Pcode
));
2194 Set_Col
(21 + Count
(Cols
) + Address_Image_Length
);
2195 Write_Node_Id
(E
.Pthen
, Cols
);
2196 Set_Col
(24 + 2 * Count
(Cols
) + Address_Image_Length
);
2204 Write_Node_Id
(E
.Alt
, Cols
);
2207 Put
(Str_PP
(E
.PP
));
2209 when PC_Pred_Func
=>
2210 Put
(Str_BF
(E
.BF
));
2222 Put
(Str_VP
(E
.VP
));
2227 Put
(Str_FP
(E
.FP
));
2230 Put
(Image
(E
.Str
.all));
2233 Put
(Image
(E
.Str2
));
2236 Put
(Image
(E
.Str3
));
2239 Put
(Image
(E
.Str4
));
2242 Put
(Image
(E
.Str5
));
2245 Put
(Image
(E
.Str6
));
2248 Put
(Str_NP
(E
.Var
));
2258 Put
(''' & E
.Char
& ''');
2267 Put
('"' & To_Sequence
(E
.CS
) & '"');
2284 Put
(Str_NF
(E
.NF
));
2292 Put
(Str_NP
(E
.NP
));
2302 Put
(Str_VF
(E
.VF
));
2319 function Fail
return Pattern
is
2321 return (AFC
with 0, new PE
'(PC_Fail, 1, EOP));
2330 function Fence return Pattern is
2332 return (AFC with 1, new PE'(PC_Fence
, 1, EOP
));
2337 -- +---+ +---+ +---+
2338 -- | E |---->| P |---->| X |---->
2339 -- +---+ +---+ +---+
2341 -- The node numbering of the constituent pattern P is not affected.
2342 -- Where N is the number of nodes in P, the X node is numbered N + 1,
2343 -- and the E node is N + 2.
2345 function Fence
(P
: Pattern
) return Pattern
is
2346 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
2347 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
2348 X : constant PE_Ptr := new PE'(PC_Fence_X
, 0, EOP
);
2350 return (AFC
with P
.Stk
+ 1, Bracket
(E
, Pat
, X
));
2357 procedure Finalize
(Object
: in out Pattern
) is
2359 procedure Free
is new Ada
.Unchecked_Deallocation
(PE
, PE_Ptr
);
2360 procedure Free
is new Ada
.Unchecked_Deallocation
(String, String_Ptr
);
2363 -- Nothing to do if already freed
2365 if Object
.P
= null then
2368 -- Otherwise we must free all elements
2372 Refs
: Ref_Array
(1 .. Object
.P
.Index
);
2373 -- References to elements in pattern to be finalized
2376 Build_Ref_Array
(Object
.P
, Refs
);
2378 for J
in Refs
'Range loop
2379 if Refs
(J
).Pcode
= PC_String
then
2380 Free
(Refs
(J
).Str
);
2395 function Image
(P
: PE_Ptr
) return String is
2397 return Image
(To_Address
(P
));
2400 function Image
(P
: Pattern
) return String is
2402 return S
(Image
(P
));
2405 function Image
(P
: Pattern
) return VString
is
2407 Kill_Ampersand
: Boolean := False;
2408 -- Set True to delete next & to be output to Result
2410 Result
: VString
:= Nul
;
2411 -- The result is accumulated here, using Append
2413 Refs
: Ref_Array
(1 .. P
.P
.Index
);
2414 -- We build a reference array whose N'th element points to the
2415 -- pattern element whose Index value is N.
2417 procedure Delete_Ampersand
;
2418 -- Deletes the ampersand at the end of Result
2420 procedure Image_Seq
(E
: PE_Ptr
; Succ
: PE_Ptr
; Paren
: Boolean);
2421 -- E refers to a pattern structure whose successor is given by Succ.
2422 -- This procedure appends to Result a representation of this pattern.
2423 -- The Paren parameter indicates whether parentheses are required if
2424 -- the output is more than one element.
2426 procedure Image_One
(E
: in out PE_Ptr
);
2427 -- E refers to a pattern structure. This procedure appends to Result
2428 -- a representation of the single simple or compound pattern structure
2429 -- at the start of E and updates E to point to its successor.
2431 ----------------------
2432 -- Delete_Ampersand --
2433 ----------------------
2435 procedure Delete_Ampersand
is
2436 L
: constant Natural := Length
(Result
);
2439 Delete
(Result
, L
- 1, L
);
2441 end Delete_Ampersand
;
2447 procedure Image_One
(E
: in out PE_Ptr
) is
2449 ER
: PE_Ptr
:= E
.Pthen
;
2450 -- Successor set as result in E unless reset
2455 Append
(Result
, "Cancel");
2457 when PC_Alt
=> Alt
: declare
2459 Elmts_In_L
: constant IndexT
:= E
.Pthen
.Index
- E
.Alt
.Index
;
2460 -- Number of elements in left pattern of alternation
2462 Lowest_In_L
: constant IndexT
:= E
.Index
- Elmts_In_L
;
2463 -- Number of lowest index in elements of left pattern
2468 -- The successor of the alternation node must have a lower
2469 -- index than any node that is in the left pattern or a
2470 -- higher index than the alternation node itself.
2473 and then ER
.Index
>= Lowest_In_L
2474 and then ER
.Index
< E
.Index
2479 Append
(Result
, '(');
2483 Image_Seq
(E1
.Pthen
, ER
, False);
2484 Append
(Result
, " or ");
2486 exit when E1
.Pcode
/= PC_Alt
;
2489 Image_Seq
(E1
, ER
, False);
2490 Append
(Result
, ')');
2494 Append
(Result
, "Any (" & Image
(To_Sequence
(E
.CS
)) & ')');
2497 Append
(Result
, "Any (" & Str_VF
(E
.VF
) & ')');
2500 Append
(Result
, "Any (" & Str_VP
(E
.VP
) & ')');
2503 Append
(Result
, "Arb");
2506 Append
(Result
, "Arbno (");
2507 Image_Seq
(E
.Alt
, E
, False);
2508 Append
(Result
, ')');
2511 Append
(Result
, "Arbno (");
2512 Image_Seq
(E
.Alt
.Pthen
, Refs
(E
.Index
- 2), False);
2513 Append
(Result
, ')');
2515 when PC_Assign_Imm
=>
2517 Append
(Result
, "* " & Str_VP
(Refs
(E
.Index
).VP
));
2519 when PC_Assign_OnM
=>
2521 Append
(Result
, "** " & Str_VP
(Refs
(E
.Index
).VP
));
2524 Append
(Result
, "Any ('" & E
.Char
& "')");
2527 Append
(Result
, "Bal");
2530 Append
(Result
, "Break ('" & E
.Char
& "')");
2533 Append
(Result
, "Break (" & Image
(To_Sequence
(E
.CS
)) & ')');
2536 Append
(Result
, "Break (" & Str_VF
(E
.VF
) & ')');
2539 Append
(Result
, "Break (" & Str_VP
(E
.VP
) & ')');
2541 when PC_BreakX_CH
=>
2542 Append
(Result
, "BreakX ('" & E
.Char
& "')");
2545 when PC_BreakX_CS
=>
2546 Append
(Result
, "BreakX (" & Image
(To_Sequence
(E
.CS
)) & ')');
2549 when PC_BreakX_VF
=>
2550 Append
(Result
, "BreakX (" & Str_VF
(E
.VF
) & ')');
2553 when PC_BreakX_VP
=>
2554 Append
(Result
, "BreakX (" & Str_VP
(E
.VP
) & ')');
2558 Append
(Result
, ''' & E
.Char
& ''');
2561 Append
(Result
, "Fail");
2564 Append
(Result
, "Fence");
2567 Append
(Result
, "Fence (");
2568 Image_Seq
(E
.Pthen
, Refs
(E
.Index
- 1), False);
2569 Append
(Result
, ")");
2570 ER
:= Refs
(E
.Index
- 1).Pthen
;
2573 Append
(Result
, "Len (" & E
.Nat
& ')');
2576 Append
(Result
, "Len (" & Str_NF
(E
.NF
) & ')');
2579 Append
(Result
, "Len (" & Str_NP
(E
.NP
) & ')');
2581 when PC_NotAny_CH
=>
2582 Append
(Result
, "NotAny ('" & E
.Char
& "')");
2584 when PC_NotAny_CS
=>
2585 Append
(Result
, "NotAny (" & Image
(To_Sequence
(E
.CS
)) & ')');
2587 when PC_NotAny_VF
=>
2588 Append
(Result
, "NotAny (" & Str_VF
(E
.VF
) & ')');
2590 when PC_NotAny_VP
=>
2591 Append
(Result
, "NotAny (" & Str_VP
(E
.VP
) & ')');
2594 Append
(Result
, "NSpan ('" & E
.Char
& "')");
2597 Append
(Result
, "NSpan (" & Image
(To_Sequence
(E
.CS
)) & ')');
2600 Append
(Result
, "NSpan (" & Str_VF
(E
.VF
) & ')');
2603 Append
(Result
, "NSpan (" & Str_VP
(E
.VP
) & ')');
2606 Append
(Result
, """""");
2609 Append
(Result
, "Pos (" & E
.Nat
& ')');
2612 Append
(Result
, "Pos (" & Str_NF
(E
.NF
) & ')');
2615 Append
(Result
, "Pos (" & Str_NP
(E
.NP
) & ')');
2618 Kill_Ampersand
:= True;
2621 Append
(Result
, "Rest");
2624 Append
(Result
, "(+ " & Str_PP
(E
.PP
) & ')');
2626 when PC_Pred_Func
=>
2627 Append
(Result
, "(+ " & Str_BF
(E
.BF
) & ')');
2630 Append
(Result
, "RPos (" & E
.Nat
& ')');
2633 Append
(Result
, "RPos (" & Str_NF
(E
.NF
) & ')');
2636 Append
(Result
, "RPos (" & Str_NP
(E
.NP
) & ')');
2639 Append
(Result
, "RTab (" & E
.Nat
& ')');
2642 Append
(Result
, "RTab (" & Str_NF
(E
.NF
) & ')');
2645 Append
(Result
, "RTab (" & Str_NP
(E
.NP
) & ')');
2648 Append
(Result
, "Setcur (" & Str_NP
(E
.Var
) & ')');
2651 Append
(Result
, "Span ('" & E
.Char
& "')");
2654 Append
(Result
, "Span (" & Image
(To_Sequence
(E
.CS
)) & ')');
2657 Append
(Result
, "Span (" & Str_VF
(E
.VF
) & ')');
2660 Append
(Result
, "Span (" & Str_VP
(E
.VP
) & ')');
2663 Append
(Result
, Image
(E
.Str
.all));
2666 Append
(Result
, Image
(E
.Str2
));
2669 Append
(Result
, Image
(E
.Str3
));
2672 Append
(Result
, Image
(E
.Str4
));
2675 Append
(Result
, Image
(E
.Str5
));
2678 Append
(Result
, Image
(E
.Str6
));
2680 when PC_String_VF
=>
2681 Append
(Result
, "(+" & Str_VF
(E
.VF
) & ')');
2683 when PC_String_VP
=>
2684 Append
(Result
, "(+" & Str_VP
(E
.VP
) & ')');
2687 Append
(Result
, "Succeed");
2690 Append
(Result
, "Tab (" & E
.Nat
& ')');
2693 Append
(Result
, "Tab (" & Str_NF
(E
.NF
) & ')');
2696 Append
(Result
, "Tab (" & Str_NP
(E
.NP
) & ')');
2698 when PC_Write_Imm
=>
2699 Append
(Result
, '(');
2700 Image_Seq
(E
, Refs
(E
.Index
- 1), True);
2701 Append
(Result
, " * " & Str_FP
(Refs
(E
.Index
- 1).FP
));
2702 ER
:= Refs
(E
.Index
- 1).Pthen
;
2704 when PC_Write_OnM
=>
2705 Append
(Result
, '(');
2706 Image_Seq
(E
.Pthen
, Refs
(E
.Index
- 1), True);
2707 Append
(Result
, " ** " & Str_FP
(Refs
(E
.Index
- 1).FP
));
2708 ER
:= Refs
(E
.Index
- 1).Pthen
;
2710 -- Other pattern codes should not appear as leading elements
2722 Append
(Result
, "???");
2732 procedure Image_Seq
(E
: PE_Ptr
; Succ
: PE_Ptr
; Paren
: Boolean) is
2733 Indx
: constant Natural := Length
(Result
);
2735 Mult
: Boolean := False;
2738 -- The image of EOP is "" (the null string)
2741 Append
(Result
, """""");
2743 -- Else generate appropriate concatenation sequence
2748 exit when E1
= Succ
;
2752 if Kill_Ampersand
then
2753 Kill_Ampersand
:= False;
2755 Append
(Result
, " & ");
2760 if Mult
and Paren
then
2761 Insert
(Result
, Indx
+ 1, "(");
2762 Append
(Result
, ")");
2766 -- Start of processing for Image
2769 Build_Ref_Array
(P
.P
, Refs
);
2770 Image_Seq
(P
.P
, EOP
, False);
2778 function Is_In
(C
: Character; Str
: String) return Boolean is
2780 for J
in Str
'Range loop
2793 function Len
(Count
: Natural) return Pattern
is
2795 -- Note, the following is not just an optimization, it is needed
2796 -- to ensure that Arbno (Len (0)) does not generate an infinite
2797 -- matching loop (since PC_Len_Nat is OK_For_Simple_Arbno).
2800 return (AFC
with 0, new PE
'(PC_Null, 1, EOP));
2803 return (AFC with 0, new PE'(PC_Len_Nat
, 1, EOP
, Count
));
2807 function Len
(Count
: Natural_Func
) return Pattern
is
2809 return (AFC
with 0, new PE
'(PC_Len_NF, 1, EOP, Count));
2812 function Len (Count : not null access Natural) return Pattern is
2814 return (AFC with 0, new PE'(PC_Len_NP
, 1, EOP
, Natural_Ptr
(Count
)));
2821 procedure Logic_Error
is
2823 raise Program_Error
with
2824 "Internal logic error in GNAT.Spitbol.Patterns";
2833 Pat
: Pattern
) return Boolean
2835 S
: Big_String_Access
;
2839 pragma Unreferenced
(Stop
);
2842 Get_String
(Subject
, S
, L
);
2845 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2847 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2855 Pat
: Pattern
) return Boolean
2857 Start
, Stop
: Natural;
2858 pragma Unreferenced
(Stop
);
2860 subtype String1
is String (1 .. Subject
'Length);
2864 XMatchD
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2866 XMatch
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2873 (Subject
: VString_Var
;
2875 Replace
: VString
) return Boolean
2879 S
: Big_String_Access
;
2883 Get_String
(Subject
, S
, L
);
2886 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2888 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2894 Get_String
(Replace
, S
, L
);
2896 (Subject
'Unrestricted_Access.all, Start
, Stop
, S
(1 .. L
));
2902 (Subject
: VString_Var
;
2904 Replace
: String) return Boolean
2908 S
: Big_String_Access
;
2912 Get_String
(Subject
, S
, L
);
2915 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2917 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2924 (Subject
'Unrestricted_Access.all, Start
, Stop
, Replace
);
2933 S
: Big_String_Access
;
2938 pragma Unreferenced
(Start
, Stop
);
2941 Get_String
(Subject
, S
, L
);
2944 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2946 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2954 Start
, Stop
: Natural;
2955 pragma Unreferenced
(Start
, Stop
);
2957 subtype String1
is String (1 .. Subject
'Length);
2961 XMatchD
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2963 XMatch
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2968 (Subject
: in out VString
;
2974 S
: Big_String_Access
;
2978 Get_String
(Subject
, S
, L
);
2981 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2983 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2987 Get_String
(Replace
, S
, L
);
2988 Replace_Slice
(Subject
, Start
, Stop
, S
(1 .. L
));
2993 (Subject
: in out VString
;
2999 S
: Big_String_Access
;
3003 Get_String
(Subject
, S
, L
);
3006 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3008 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3012 Replace_Slice
(Subject
, Start
, Stop
, Replace
);
3018 Pat
: PString
) return Boolean
3020 Pat_Len
: constant Natural := Pat
'Length;
3021 S
: Big_String_Access
;
3025 Get_String
(Subject
, S
, L
);
3027 if Anchored_Mode
then
3031 return Pat
= S
(1 .. Pat_Len
);
3035 for J
in 1 .. L
- Pat_Len
+ 1 loop
3036 if Pat
= S
(J
.. J
+ (Pat_Len
- 1)) then
3047 Pat
: PString
) return Boolean
3049 Pat_Len
: constant Natural := Pat
'Length;
3050 Sub_Len
: constant Natural := Subject
'Length;
3051 SFirst
: constant Natural := Subject
'First;
3054 if Anchored_Mode
then
3055 if Pat_Len
> Sub_Len
then
3058 return Pat
= Subject
(SFirst
.. SFirst
+ Pat_Len
- 1);
3062 for J
in SFirst
.. SFirst
+ Sub_Len
- Pat_Len
loop
3063 if Pat
= Subject
(J
.. J
+ (Pat_Len
- 1)) then
3073 (Subject
: VString_Var
;
3075 Replace
: VString
) return Boolean
3079 S
: Big_String_Access
;
3083 Get_String
(Subject
, S
, L
);
3086 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3088 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3094 Get_String
(Replace
, S
, L
);
3096 (Subject
'Unrestricted_Access.all, Start
, Stop
, S
(1 .. L
));
3102 (Subject
: VString_Var
;
3104 Replace
: String) return Boolean
3108 S
: Big_String_Access
;
3112 Get_String
(Subject
, S
, L
);
3115 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3117 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3124 (Subject
'Unrestricted_Access.all, Start
, Stop
, Replace
);
3133 S
: Big_String_Access
;
3138 pragma Unreferenced
(Start
, Stop
);
3141 Get_String
(Subject
, S
, L
);
3144 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3146 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3154 Start
, Stop
: Natural;
3155 pragma Unreferenced
(Start
, Stop
);
3157 subtype String1
is String (1 .. Subject
'Length);
3161 XMatchD
(String1
(Subject
), S_To_PE
(Pat
), 0, Start
, Stop
);
3163 XMatch
(String1
(Subject
), S_To_PE
(Pat
), 0, Start
, Stop
);
3168 (Subject
: in out VString
;
3174 S
: Big_String_Access
;
3178 Get_String
(Subject
, S
, L
);
3181 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3183 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3187 Get_String
(Replace
, S
, L
);
3188 Replace_Slice
(Subject
, Start
, Stop
, S
(1 .. L
));
3193 (Subject
: in out VString
;
3199 S
: Big_String_Access
;
3203 Get_String
(Subject
, S
, L
);
3206 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3208 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3212 Replace_Slice
(Subject
, Start
, Stop
, Replace
);
3217 (Subject
: VString_Var
;
3219 Result
: Match_Result_Var
) return Boolean
3223 S
: Big_String_Access
;
3227 Get_String
(Subject
, S
, L
);
3230 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3232 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3236 Result
'Unrestricted_Access.all.Var
:= null;
3240 Result
'Unrestricted_Access.all.Var
:= Subject
'Unrestricted_Access;
3241 Result
'Unrestricted_Access.all.Start
:= Start
;
3242 Result
'Unrestricted_Access.all.Stop
:= Stop
;
3248 (Subject
: in out VString
;
3250 Result
: out Match_Result
)
3254 S
: Big_String_Access
;
3258 Get_String
(Subject
, S
, L
);
3261 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3263 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3269 Result
.Var
:= Subject
'Unrestricted_Access;
3270 Result
.Start
:= Start
;
3271 Result
.Stop
:= Stop
;
3279 procedure New_LineD
is
3281 if Internal_Debug
then
3290 function NotAny
(Str
: String) return Pattern
is
3292 return (AFC
with 0, new PE
'(PC_NotAny_CS, 1, EOP, To_Set (Str)));
3295 function NotAny (Str : VString) return Pattern is
3297 return NotAny (S (Str));
3300 function NotAny (Str : Character) return Pattern is
3302 return (AFC with 0, new PE'(PC_NotAny_CH
, 1, EOP
, Str
));
3305 function NotAny
(Str
: Character_Set
) return Pattern
is
3307 return (AFC
with 0, new PE
'(PC_NotAny_CS, 1, EOP, Str));
3310 function NotAny (Str : not null access VString) return Pattern is
3312 return (AFC with 0, new PE'(PC_NotAny_VP
, 1, EOP
, VString_Ptr
(Str
)));
3315 function NotAny
(Str
: VString_Func
) return Pattern
is
3317 return (AFC
with 0, new PE
'(PC_NotAny_VF, 1, EOP, Str));
3324 function NSpan (Str : String) return Pattern is
3326 return (AFC with 0, new PE'(PC_NSpan_CS
, 1, EOP
, To_Set
(Str
)));
3329 function NSpan
(Str
: VString
) return Pattern
is
3331 return NSpan
(S
(Str
));
3334 function NSpan
(Str
: Character) return Pattern
is
3336 return (AFC
with 0, new PE
'(PC_NSpan_CH, 1, EOP, Str));
3339 function NSpan (Str : Character_Set) return Pattern is
3341 return (AFC with 0, new PE'(PC_NSpan_CS
, 1, EOP
, Str
));
3344 function NSpan
(Str
: not null access VString
) return Pattern
is
3346 return (AFC
with 0, new PE
'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str)));
3349 function NSpan (Str : VString_Func) return Pattern is
3351 return (AFC with 0, new PE'(PC_NSpan_VF
, 1, EOP
, Str
));
3358 function Pos
(Count
: Natural) return Pattern
is
3360 return (AFC
with 0, new PE
'(PC_Pos_Nat, 1, EOP, Count));
3363 function Pos (Count : Natural_Func) return Pattern is
3365 return (AFC with 0, new PE'(PC_Pos_NF
, 1, EOP
, Count
));
3368 function Pos
(Count
: not null access Natural) return Pattern
is
3370 return (AFC
with 0, new PE
'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count)));
3377 procedure PutD (Str : String) is
3379 if Internal_Debug then
3388 procedure Put_LineD (Str : String) is
3390 if Internal_Debug then
3400 (Result : in out Match_Result;
3403 S : Big_String_Access;
3407 Get_String (Replace, S, L);
3409 if Result.Var /= null then
3410 Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L));
3419 function Rest return Pattern is
3421 return (AFC with 0, new PE'(PC_Rest
, 1, EOP
));
3428 function Rpos
(Count
: Natural) return Pattern
is
3430 return (AFC
with 0, new PE
'(PC_RPos_Nat, 1, EOP, Count));
3433 function Rpos (Count : Natural_Func) return Pattern is
3435 return (AFC with 0, new PE'(PC_RPos_NF
, 1, EOP
, Count
));
3438 function Rpos
(Count
: not null access Natural) return Pattern
is
3440 return (AFC
with 0, new PE
'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count)));
3447 function Rtab (Count : Natural) return Pattern is
3449 return (AFC with 0, new PE'(PC_RTab_Nat
, 1, EOP
, Count
));
3452 function Rtab
(Count
: Natural_Func
) return Pattern
is
3454 return (AFC
with 0, new PE
'(PC_RTab_NF, 1, EOP, Count));
3457 function Rtab (Count : not null access Natural) return Pattern is
3459 return (AFC with 0, new PE'(PC_RTab_NP
, 1, EOP
, Natural_Ptr
(Count
)));
3466 function S_To_PE
(Str
: PString
) return PE_Ptr
is
3467 Len
: constant Natural := Str
'Length;
3472 return new PE
'(PC_Null, 1, EOP);
3475 return new PE'(PC_Char
, 1, EOP
, Str
(Str
'First));
3478 return new PE
'(PC_String_2, 1, EOP, Str);
3481 return new PE'(PC_String_3
, 1, EOP
, Str
);
3484 return new PE
'(PC_String_4, 1, EOP, Str);
3487 return new PE'(PC_String_5
, 1, EOP
, Str
);
3490 return new PE
'(PC_String_6, 1, EOP, Str);
3493 return new PE'(PC_String
, 1, EOP
, new String'(Str));
3501 -- Note: this procedure is not used by the normal concatenation circuit,
3502 -- since other fixups are required on the left operand in this case, and
3503 -- they might as well be done all together.
3505 procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is
3508 Uninitialized_Pattern;
3510 elsif Pat = EOP then
3515 Refs : Ref_Array (1 .. Pat.Index);
3516 -- We build a reference array for L whose N'th element points to
3517 -- the pattern element of L whose original Index value is N.
3522 Build_Ref_Array (Pat, Refs);
3524 for J in Refs'Range loop
3527 if P.Pthen = EOP then
3531 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
3543 function Setcur (Var : not null access Natural) return Pattern is
3545 return (AFC with 0, new PE'(PC_Setcur
, 1, EOP
, Natural_Ptr
(Var
)));
3552 function Span
(Str
: String) return Pattern
is
3554 return (AFC
with 0, new PE
'(PC_Span_CS, 1, EOP, To_Set (Str)));
3557 function Span (Str : VString) return Pattern is
3559 return Span (S (Str));
3562 function Span (Str : Character) return Pattern is
3564 return (AFC with 0, new PE'(PC_Span_CH
, 1, EOP
, Str
));
3567 function Span
(Str
: Character_Set
) return Pattern
is
3569 return (AFC
with 0, new PE
'(PC_Span_CS, 1, EOP, Str));
3572 function Span (Str : not null access VString) return Pattern is
3574 return (AFC with 0, new PE'(PC_Span_VP
, 1, EOP
, VString_Ptr
(Str
)));
3577 function Span
(Str
: VString_Func
) return Pattern
is
3579 return (AFC
with 0, new PE
'(PC_Span_VF, 1, EOP, Str));
3586 function Str_BF (A : Boolean_Func) return String is
3587 function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address);
3589 return "BF(" & Image (To_A (A)) & ')';
3596 function Str_FP (A : File_Ptr) return String is
3598 return "FP(" & Image (A.all'Address) & ')';
3605 function Str_NF (A : Natural_Func) return String is
3606 function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address);
3608 return "NF(" & Image (To_A (A)) & ')';
3615 function Str_NP (A : Natural_Ptr) return String is
3617 return "NP(" & Image (A.all'Address) & ')';
3624 function Str_PP (A : Pattern_Ptr) return String is
3626 return "PP(" & Image (A.all'Address) & ')';
3633 function Str_VF (A : VString_Func) return String is
3634 function To_A is new Ada.Unchecked_Conversion (VString_Func, Address);
3636 return "VF(" & Image (To_A (A)) & ')';
3643 function Str_VP (A : VString_Ptr) return String is
3645 return "VP(" & Image (A.all'Address) & ')';
3652 function Succeed return Pattern is
3654 return (AFC with 1, new PE'(PC_Succeed
, 1, EOP
));
3661 function Tab
(Count
: Natural) return Pattern
is
3663 return (AFC
with 0, new PE
'(PC_Tab_Nat, 1, EOP, Count));
3666 function Tab (Count : Natural_Func) return Pattern is
3668 return (AFC with 0, new PE'(PC_Tab_NF
, 1, EOP
, Count
));
3671 function Tab
(Count
: not null access Natural) return Pattern
is
3673 return (AFC
with 0, new PE
'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count)));
3676 ---------------------------
3677 -- Uninitialized_Pattern --
3678 ---------------------------
3680 procedure Uninitialized_Pattern is
3682 raise Program_Error with
3683 "uninitialized value of type GNAT.Spitbol.Patterns.Pattern";
3684 end Uninitialized_Pattern;
3694 Start : out Natural;
3698 -- Pointer to current pattern node. Initialized from Pat_P, and then
3699 -- updated as the match proceeds through its constituent elements.
3701 Length : constant Natural := Subject'Length;
3702 -- Length of string (= Subject'Last, since Subject'First is always 1)
3704 Cursor : Integer := 0;
3705 -- If the value is non-negative, then this value is the index showing
3706 -- the current position of the match in the subject string. The next
3707 -- character to be matched is at Subject (Cursor + 1). Note that since
3708 -- our view of the subject string in XMatch always has a lower bound
3709 -- of one, regardless of original bounds, that this definition exactly
3710 -- corresponds to the cursor value as referenced by functions like Pos.
3712 -- If the value is negative, then this is a saved stack pointer,
3713 -- typically a base pointer of an inner or outer region. Cursor
3714 -- temporarily holds such a value when it is popped from the stack
3715 -- by Fail. In all cases, Cursor is reset to a proper non-negative
3716 -- cursor value before the match proceeds (e.g. by propagating the
3717 -- failure and popping a "real" cursor value from the stack.
3719 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
3720 -- Dummy pattern element used in the unanchored case
3723 -- The pattern matching failure stack for this call to Match
3725 Stack_Ptr : Stack_Range;
3726 -- Current stack pointer. This points to the top element of the stack
3727 -- that is currently in use. At the outer level this is the special
3728 -- entry placed on the stack according to the anchor mode.
3730 Stack_Init : constant Stack_Range := Stack'First + 1;
3731 -- This is the initial value of the Stack_Ptr and Stack_Base. The
3732 -- initial (Stack'First) element of the stack is not used so that
3733 -- when we pop the last element off, Stack_Ptr is still in range.
3735 Stack_Base : Stack_Range;
3736 -- This value is the stack base value, i.e. the stack pointer for the
3737 -- first history stack entry in the current stack region. See separate
3738 -- section on handling of recursive pattern matches.
3740 Assign_OnM : Boolean := False;
3741 -- Set True if assign-on-match or write-on-match operations may be
3742 -- present in the history stack, which must then be scanned on a
3743 -- successful match.
3745 procedure Pop_Region;
3746 pragma Inline (Pop_Region);
3747 -- Used at the end of processing of an inner region. If the inner
3748 -- region left no stack entries, then all trace of it is removed.
3749 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
3750 -- handling of alternatives in the inner region.
3752 procedure Push (Node : PE_Ptr);
3753 pragma Inline (Push);
3754 -- Make entry in pattern matching stack with current cursor value
3756 procedure Push_Region;
3757 pragma Inline (Push_Region);
3758 -- This procedure makes a new region on the history stack. The
3759 -- caller first establishes the special entry on the stack, but
3760 -- does not push the stack pointer. Then this call stacks a
3761 -- PC_Remove_Region node, on top of this entry, using the cursor
3762 -- field of the PC_Remove_Region entry to save the outer level
3763 -- stack base value, and resets the stack base to point to this
3764 -- PC_Remove_Region node.
3770 procedure Pop_Region is
3772 -- If nothing was pushed in the inner region, we can just get
3773 -- rid of it entirely, leaving no traces that it was ever there
3775 if Stack_Ptr = Stack_Base then
3776 Stack_Ptr := Stack_Base - 2;
3777 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
3779 -- If stuff was pushed in the inner region, then we have to
3780 -- push a PC_R_Restore node so that we properly handle possible
3781 -- rematches within the region.
3784 Stack_Ptr := Stack_Ptr + 1;
3785 Stack (Stack_Ptr).Cursor := Stack_Base;
3786 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
3787 Stack_Base := Stack (Stack_Base).Cursor;
3795 procedure Push (Node : PE_Ptr) is
3797 Stack_Ptr := Stack_Ptr + 1;
3798 Stack (Stack_Ptr).Cursor := Cursor;
3799 Stack (Stack_Ptr).Node := Node;
3806 procedure Push_Region is
3808 Stack_Ptr := Stack_Ptr + 2;
3809 Stack (Stack_Ptr).Cursor := Stack_Base;
3810 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
3811 Stack_Base := Stack_Ptr;
3814 -- Start of processing for XMatch
3817 if Pat_P = null then
3818 Uninitialized_Pattern;
3821 -- Check we have enough stack for this pattern. This check deals with
3822 -- every possibility except a match of a recursive pattern, where we
3823 -- make a check at each recursion level.
3825 if Pat_S >= Stack_Size - 1 then
3826 raise Pattern_Stack_Overflow;
3829 -- In anchored mode, the bottom entry on the stack is an abort entry
3831 if Anchored_Mode then
3832 Stack (Stack_Init).Node := CP_Cancel'Access;
3833 Stack (Stack_Init).Cursor := 0;
3835 -- In unanchored more, the bottom entry on the stack references
3836 -- the special pattern element PE_Unanchored, whose Pthen field
3837 -- points to the initial pattern element. The cursor value in this
3838 -- entry is the number of anchor moves so far.
3841 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
3842 Stack (Stack_Init).Cursor := 0;
3845 Stack_Ptr := Stack_Init;
3846 Stack_Base := Stack_Ptr;
3851 -----------------------------------------
3852 -- Main Pattern Matching State Control --
3853 -----------------------------------------
3855 -- This is a state machine which uses gotos to change state. The
3856 -- initial state is Match, to initiate the matching of the first
3857 -- element, so the goto Match above starts the match. In the
3858 -- following descriptions, we indicate the global values that
3859 -- are relevant for the state transition.
3861 -- Come here if entire match fails
3868 -- Come here if entire match succeeds
3870 -- Cursor current position in subject string
3873 Start := Stack (Stack_Init).Cursor + 1;
3876 -- Scan history stack for deferred assignments or writes
3879 for S in Stack_Init .. Stack_Ptr loop
3880 if Stack (S).Node = CP_Assign'Access then
3882 Inner_Base : constant Stack_Range :=
3883 Stack (S + 1).Cursor;
3884 Special_Entry : constant Stack_Range :=
3886 Node_OnM : constant PE_Ptr :=
3887 Stack (Special_Entry).Node;
3888 Start : constant Natural :=
3889 Stack (Special_Entry).Cursor + 1;
3890 Stop : constant Natural := Stack (S).Cursor;
3893 if Node_OnM.Pcode = PC_Assign_OnM then
3894 Set_Unbounded_String
3895 (Node_OnM.VP.all, Subject (Start .. Stop));
3897 elsif Node_OnM.Pcode = PC_Write_OnM then
3898 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
3910 -- Come here if attempt to match current element fails
3912 -- Stack_Base current stack base
3913 -- Stack_Ptr current stack pointer
3916 Cursor := Stack (Stack_Ptr).Cursor;
3917 Node := Stack (Stack_Ptr).Node;
3918 Stack_Ptr := Stack_Ptr - 1;
3921 -- Come here if attempt to match current element succeeds
3923 -- Cursor current position in subject string
3924 -- Node pointer to node successfully matched
3925 -- Stack_Base current stack base
3926 -- Stack_Ptr current stack pointer
3931 -- Come here to match the next pattern element
3933 -- Cursor current position in subject string
3934 -- Node pointer to node to be matched
3935 -- Stack_Base current stack base
3936 -- Stack_Ptr current stack pointer
3940 --------------------------------------------------
3941 -- Main Pattern Match Element Matching Routines --
3942 --------------------------------------------------
3944 -- Here is the case statement that processes the current node. The
3945 -- processing for each element does one of five things:
3947 -- goto Succeed to move to the successor
3948 -- goto Match_Succeed if the entire match succeeds
3949 -- goto Match_Fail if the entire match fails
3950 -- goto Fail to signal failure of current match
3952 -- Processing is NOT allowed to fall through
3968 -- Any (one character case)
3972 and then Subject (Cursor + 1) = Node.Char
3974 Cursor := Cursor + 1;
3980 -- Any (character set case)
3984 and then Is_In (Subject (Cursor + 1), Node.CS)
3986 Cursor := Cursor + 1;
3992 -- Any (string function case)
3994 when PC_Any_VF => declare
3995 U : constant VString := Node.VF.all;
3996 S : Big_String_Access;
4000 Get_String (U, S, L);
4003 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4005 Cursor := Cursor + 1;
4012 -- Any (string pointer case)
4014 when PC_Any_VP => declare
4015 U : constant VString := Node.VP.all;
4016 S : Big_String_Access;
4020 Get_String (U, S, L);
4023 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4025 Cursor := Cursor + 1;
4032 -- Arb (initial match)
4042 if Cursor < Length then
4043 Cursor := Cursor + 1;
4050 -- Arbno_S (simple Arbno initialize). This is the node that
4051 -- initiates the match of a simple Arbno structure.
4058 -- Arbno_X (Arbno initialize). This is the node that initiates
4059 -- the match of a complex Arbno structure.
4066 -- Arbno_Y (Arbno rematch). This is the node that is executed
4067 -- following successful matching of one instance of a complex
4070 when PC_Arbno_Y => declare
4071 Null_Match : constant Boolean :=
4072 Cursor = Stack (Stack_Base - 1).Cursor;
4077 -- If arbno extension matched null, then immediately fail
4083 -- Here we must do a stack check to make sure enough stack
4084 -- is left. This check will happen once for each instance of
4085 -- the Arbno pattern that is matched. The Nat field of a
4086 -- PC_Arbno pattern contains the maximum stack entries needed
4087 -- for the Arbno with one instance and the successor pattern
4089 if Stack_Ptr + Node.Nat >= Stack'Last then
4090 raise Pattern_Stack_Overflow;
4096 -- Assign. If this node is executed, it means the assign-on-match
4097 -- or write-on-match operation will not happen after all, so we
4098 -- is propagate the failure, removing the PC_Assign node.
4103 -- Assign immediate. This node performs the actual assignment
4105 when PC_Assign_Imm =>
4106 Set_Unbounded_String
4108 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4112 -- Assign on match. This node sets up for the eventual assignment
4114 when PC_Assign_OnM =>
4115 Stack (Stack_Base - 1).Node := Node;
4116 Push (CP_Assign'Access);
4124 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
4127 elsif Subject (Cursor + 1) = '(' then
4129 Paren_Count : Natural := 1;
4133 Cursor := Cursor + 1;
4135 if Cursor >= Length then
4138 elsif Subject (Cursor + 1) = '(' then
4139 Paren_Count := Paren_Count + 1;
4141 elsif Subject (Cursor + 1) = ')' then
4142 Paren_Count := Paren_Count - 1;
4143 exit when Paren_Count = 0;
4149 Cursor := Cursor + 1;
4153 -- Break (one character case)
4156 while Cursor < Length loop
4157 if Subject (Cursor + 1) = Node.Char then
4160 Cursor := Cursor + 1;
4166 -- Break (character set case)
4169 while Cursor < Length loop
4170 if Is_In (Subject (Cursor + 1), Node.CS) then
4173 Cursor := Cursor + 1;
4179 -- Break (string function case)
4181 when PC_Break_VF => declare
4182 U : constant VString := Node.VF.all;
4183 S : Big_String_Access;
4187 Get_String (U, S, L);
4189 while Cursor < Length loop
4190 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4193 Cursor := Cursor + 1;
4200 -- Break (string pointer case)
4202 when PC_Break_VP => declare
4203 U : constant VString := Node.VP.all;
4204 S : Big_String_Access;
4208 Get_String (U, S, L);
4210 while Cursor < Length loop
4211 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4214 Cursor := Cursor + 1;
4221 -- BreakX (one character case)
4223 when PC_BreakX_CH =>
4224 while Cursor < Length loop
4225 if Subject (Cursor + 1) = Node.Char then
4228 Cursor := Cursor + 1;
4234 -- BreakX (character set case)
4236 when PC_BreakX_CS =>
4237 while Cursor < Length loop
4238 if Is_In (Subject (Cursor + 1), Node.CS) then
4241 Cursor := Cursor + 1;
4247 -- BreakX (string function case)
4249 when PC_BreakX_VF => declare
4250 U : constant VString := Node.VF.all;
4251 S : Big_String_Access;
4255 Get_String (U, S, L);
4257 while Cursor < Length loop
4258 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4261 Cursor := Cursor + 1;
4268 -- BreakX (string pointer case)
4270 when PC_BreakX_VP => declare
4271 U : constant VString := Node.VP.all;
4272 S : Big_String_Access;
4276 Get_String (U, S, L);
4278 while Cursor < Length loop
4279 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4282 Cursor := Cursor + 1;
4289 -- BreakX_X (BreakX extension). See section on "Compound Pattern
4290 -- Structures". This node is the alternative that is stacked to
4291 -- skip past the break character and extend the break.
4294 Cursor := Cursor + 1;
4297 -- Character (one character string)
4301 and then Subject (Cursor + 1) = Node.Char
4303 Cursor := Cursor + 1;
4312 if Stack_Base = Stack_Init then
4315 -- End of recursive inner match. See separate section on
4316 -- handing of recursive pattern matches for details.
4319 Node := Stack (Stack_Base - 1).Node;
4329 -- Fence (built in pattern)
4332 Push (CP_Cancel'Access);
4335 -- Fence function node X. This is the node that gets control
4336 -- after a successful match of the fenced pattern.
4339 Stack_Ptr := Stack_Ptr + 1;
4340 Stack (Stack_Ptr).Cursor := Stack_Base;
4341 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
4342 Stack_Base := Stack (Stack_Base).Cursor;
4345 -- Fence function node Y. This is the node that gets control on
4346 -- a failure that occurs after the fenced pattern has matched.
4348 -- Note: the Cursor at this stage is actually the inner stack
4349 -- base value. We don't reset this, but we do use it to strip
4350 -- off all the entries made by the fenced pattern.
4353 Stack_Ptr := Cursor - 2;
4356 -- Len (integer case)
4359 if Cursor + Node.Nat > Length then
4362 Cursor := Cursor + Node.Nat;
4366 -- Len (Integer function case)
4368 when PC_Len_NF => declare
4369 N : constant Natural := Node.NF.all;
4371 if Cursor + N > Length then
4374 Cursor := Cursor + N;
4379 -- Len (integer pointer case)
4382 if Cursor + Node.NP.all > Length then
4385 Cursor := Cursor + Node.NP.all;
4389 -- NotAny (one character case)
4391 when PC_NotAny_CH =>
4393 and then Subject (Cursor + 1) /= Node.Char
4395 Cursor := Cursor + 1;
4401 -- NotAny (character set case)
4403 when PC_NotAny_CS =>
4405 and then not Is_In (Subject (Cursor + 1), Node.CS)
4407 Cursor := Cursor + 1;
4413 -- NotAny (string function case)
4415 when PC_NotAny_VF => declare
4416 U : constant VString := Node.VF.all;
4417 S : Big_String_Access;
4421 Get_String (U, S, L);
4425 not Is_In (Subject (Cursor + 1), S (1 .. L))
4427 Cursor := Cursor + 1;
4434 -- NotAny (string pointer case)
4436 when PC_NotAny_VP => declare
4437 U : constant VString := Node.VP.all;
4438 S : Big_String_Access;
4442 Get_String (U, S, L);
4446 not Is_In (Subject (Cursor + 1), S (1 .. L))
4448 Cursor := Cursor + 1;
4455 -- NSpan (one character case)
4458 while Cursor < Length
4459 and then Subject (Cursor + 1) = Node.Char
4461 Cursor := Cursor + 1;
4466 -- NSpan (character set case)
4469 while Cursor < Length
4470 and then Is_In (Subject (Cursor + 1), Node.CS)
4472 Cursor := Cursor + 1;
4477 -- NSpan (string function case)
4479 when PC_NSpan_VF => declare
4480 U : constant VString := Node.VF.all;
4481 S : Big_String_Access;
4485 Get_String (U, S, L);
4487 while Cursor < Length
4488 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4490 Cursor := Cursor + 1;
4496 -- NSpan (string pointer case)
4498 when PC_NSpan_VP => declare
4499 U : constant VString := Node.VP.all;
4500 S : Big_String_Access;
4504 Get_String (U, S, L);
4506 while Cursor < Length
4507 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4509 Cursor := Cursor + 1;
4520 -- Pos (integer case)
4523 if Cursor = Node.Nat then
4529 -- Pos (Integer function case)
4531 when PC_Pos_NF => declare
4532 N : constant Natural := Node.NF.all;
4541 -- Pos (integer pointer case)
4544 if Cursor = Node.NP.all then
4550 -- Predicate function
4552 when PC_Pred_Func =>
4559 -- Region Enter. Initiate new pattern history stack region
4562 Stack (Stack_Ptr + 1).Cursor := Cursor;
4566 -- Region Remove node. This is the node stacked by an R_Enter.
4567 -- It removes the special format stack entry right underneath, and
4568 -- then restores the outer level stack base and signals failure.
4570 -- Note: the cursor value at this stage is actually the (negative)
4571 -- stack base value for the outer level.
4574 Stack_Base := Cursor;
4575 Stack_Ptr := Stack_Ptr - 1;
4578 -- Region restore node. This is the node stacked at the end of an
4579 -- inner level match. Its function is to restore the inner level
4580 -- region, so that alternatives in this region can be sought.
4582 -- Note: the Cursor at this stage is actually the negative of the
4583 -- inner stack base value, which we use to restore the inner region.
4585 when PC_R_Restore =>
4586 Stack_Base := Cursor;
4595 -- Initiate recursive match (pattern pointer case)
4598 Stack (Stack_Ptr + 1).Node := Node.Pthen;
4601 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
4602 raise Pattern_Stack_Overflow;
4604 Node := Node.PP.all.P;
4608 -- RPos (integer case)
4611 if Cursor = (Length - Node.Nat) then
4617 -- RPos (integer function case)
4619 when PC_RPos_NF => declare
4620 N : constant Natural := Node.NF.all;
4622 if Length - Cursor = N then
4629 -- RPos (integer pointer case)
4632 if Cursor = (Length - Node.NP.all) then
4638 -- RTab (integer case)
4641 if Cursor <= (Length - Node.Nat) then
4642 Cursor := Length - Node.Nat;
4648 -- RTab (integer function case)
4650 when PC_RTab_NF => declare
4651 N : constant Natural := Node.NF.all;
4653 if Length - Cursor >= N then
4654 Cursor := Length - N;
4661 -- RTab (integer pointer case)
4664 if Cursor <= (Length - Node.NP.all) then
4665 Cursor := Length - Node.NP.all;
4671 -- Cursor assignment
4674 Node.Var.all := Cursor;
4677 -- Span (one character case)
4679 when PC_Span_CH => declare
4685 and then Subject (P + 1) = Node.Char
4698 -- Span (character set case)
4700 when PC_Span_CS => declare
4706 and then Is_In (Subject (P + 1), Node.CS)
4719 -- Span (string function case)
4721 when PC_Span_VF => declare
4722 U : constant VString := Node.VF.all;
4723 S : Big_String_Access;
4728 Get_String (U, S, L);
4732 and then Is_In (Subject (P + 1), S (1 .. L))
4745 -- Span (string pointer case)
4747 when PC_Span_VP => declare
4748 U : constant VString := Node.VP.all;
4749 S : Big_String_Access;
4754 Get_String (U, S, L);
4758 and then Is_In (Subject (P + 1), S (1 .. L))
4771 -- String (two character case)
4774 if (Length - Cursor) >= 2
4775 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
4777 Cursor := Cursor + 2;
4783 -- String (three character case)
4786 if (Length - Cursor) >= 3
4787 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
4789 Cursor := Cursor + 3;
4795 -- String (four character case)
4798 if (Length - Cursor) >= 4
4799 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
4801 Cursor := Cursor + 4;
4807 -- String (five character case)
4810 if (Length - Cursor) >= 5
4811 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
4813 Cursor := Cursor + 5;
4819 -- String (six character case)
4822 if (Length - Cursor) >= 6
4823 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
4825 Cursor := Cursor + 6;
4831 -- String (case of more than six characters)
4833 when PC_String => declare
4834 Len : constant Natural := Node.Str'Length;
4836 if (Length - Cursor) >= Len
4837 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
4839 Cursor := Cursor + Len;
4846 -- String (function case)
4848 when PC_String_VF => declare
4849 U : constant VString := Node.VF.all;
4850 S : Big_String_Access;
4854 Get_String (U, S, L);
4856 if (Length - Cursor) >= L
4857 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4859 Cursor := Cursor + L;
4866 -- String (pointer case)
4868 when PC_String_VP => declare
4869 U : constant VString := Node.VP.all;
4870 S : Big_String_Access;
4874 Get_String (U, S, L);
4876 if (Length - Cursor) >= L
4877 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4879 Cursor := Cursor + L;
4892 -- Tab (integer case)
4895 if Cursor <= Node.Nat then
4902 -- Tab (integer function case)
4904 when PC_Tab_NF => declare
4905 N : constant Natural := Node.NF.all;
4915 -- Tab (integer pointer case)
4918 if Cursor <= Node.NP.all then
4919 Cursor := Node.NP.all;
4925 -- Unanchored movement
4927 when PC_Unanchored =>
4929 -- All done if we tried every position
4931 if Cursor > Length then
4934 -- Otherwise extend the anchor point, and restack ourself
4937 Cursor := Cursor + 1;
4942 -- Write immediate. This node performs the actual write
4944 when PC_Write_Imm =>
4947 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4951 -- Write on match. This node sets up for the eventual write
4953 when PC_Write_OnM =>
4954 Stack (Stack_Base - 1).Node := Node;
4955 Push (CP_Assign'Access);
4961 -- We are NOT allowed to fall though this case statement, since every
4962 -- match routine must end by executing a goto to the appropriate point
4963 -- in the finite state machine model.
4965 pragma Warnings (Off);
4967 pragma Warnings (On);
4974 -- Maintenance note: There is a LOT of code duplication between XMatch
4975 -- and XMatchD. This is quite intentional, the point is to avoid any
4976 -- unnecessary debugging overhead in the XMatch case, but this does mean
4977 -- that any changes to XMatchD must be mirrored in XMatch. In case of
4978 -- any major changes, the proper approach is to delete XMatch, make the
4979 -- changes to XMatchD, and then make a copy of XMatchD, removing all
4980 -- calls to Dout, and all Put and Put_Line operations. This copy becomes
4987 Start : out Natural;
4991 -- Pointer to current pattern node. Initialized from Pat_P, and then
4992 -- updated as the match proceeds through its constituent elements.
4994 Length : constant Natural := Subject'Length;
4995 -- Length of string (= Subject'Last, since Subject'First is always 1)
4997 Cursor : Integer := 0;
4998 -- If the value is non-negative, then this value is the index showing
4999 -- the current position of the match in the subject string. The next
5000 -- character to be matched is at Subject (Cursor + 1). Note that since
5001 -- our view of the subject string in XMatch always has a lower bound
5002 -- of one, regardless of original bounds, that this definition exactly
5003 -- corresponds to the cursor value as referenced by functions like Pos.
5005 -- If the value is negative, then this is a saved stack pointer,
5006 -- typically a base pointer of an inner or outer region. Cursor
5007 -- temporarily holds such a value when it is popped from the stack
5008 -- by Fail. In all cases, Cursor is reset to a proper non-negative
5009 -- cursor value before the match proceeds (e.g. by propagating the
5010 -- failure and popping a "real" cursor value from the stack.
5012 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
5013 -- Dummy pattern element used in the unanchored case
5015 Region_Level : Natural := 0;
5016 -- Keeps track of recursive region level. This is used only for
5017 -- debugging, it is the number of saved history stack base values.
5020 -- The pattern matching failure stack for this call to Match
5022 Stack_Ptr : Stack_Range;
5023 -- Current stack pointer. This points to the top element of the stack
5024 -- that is currently in use. At the outer level this is the special
5025 -- entry placed on the stack according to the anchor mode.
5027 Stack_Init : constant Stack_Range := Stack'First + 1;
5028 -- This is the initial value of the Stack_Ptr and Stack_Base. The
5029 -- initial (Stack'First) element of the stack is not used so that
5030 -- when we pop the last element off, Stack_Ptr is still in range.
5032 Stack_Base : Stack_Range;
5033 -- This value is the stack base value, i.e. the stack pointer for the
5034 -- first history stack entry in the current stack region. See separate
5035 -- section on handling of recursive pattern matches.
5037 Assign_OnM : Boolean := False;
5038 -- Set True if assign-on-match or write-on-match operations may be
5039 -- present in the history stack, which must then be scanned on a
5040 -- successful match.
5042 procedure Dout (Str : String);
5043 -- Output string to standard error with bars indicating region level
5045 procedure Dout (Str : String; A : Character);
5046 -- Calls Dout with the string S ('A
')
5048 procedure Dout (Str : String; A : Character_Set);
5049 -- Calls Dout with the string S ("A")
5051 procedure Dout (Str : String; A : Natural);
5052 -- Calls Dout with the string S (A)
5054 procedure Dout (Str : String; A : String);
5055 -- Calls Dout with the string S ("A")
5057 function Img (P : PE_Ptr) return String;
5058 -- Returns a string of the form #nnn where nnn is P.Index
5060 procedure Pop_Region;
5061 pragma Inline (Pop_Region);
5062 -- Used at the end of processing of an inner region. If the inner
5063 -- region left no stack entries, then all trace of it is removed.
5064 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
5065 -- handling of alternatives in the inner region.
5067 procedure Push (Node : PE_Ptr);
5068 pragma Inline (Push);
5069 -- Make entry in pattern matching stack with current cursor value
5071 procedure Push_Region;
5072 pragma Inline (Push_Region);
5073 -- This procedure makes a new region on the history stack. The
5074 -- caller first establishes the special entry on the stack, but
5075 -- does not push the stack pointer. Then this call stacks a
5076 -- PC_Remove_Region node, on top of this entry, using the cursor
5077 -- field of the PC_Remove_Region entry to save the outer level
5078 -- stack base value, and resets the stack base to point to this
5079 -- PC_Remove_Region node.
5085 procedure Dout (Str : String) is
5087 for J in 1 .. Region_Level loop
5094 procedure Dout (Str : String; A : Character) is
5096 Dout (Str & " ('" & A & "')");
5099 procedure Dout (Str : String; A : Character_Set) is
5101 Dout (Str & " (" & Image (To_Sequence (A)) & ')');
5104 procedure Dout (Str : String; A : Natural) is
5106 Dout (Str & " (" & A & ')');
5109 procedure Dout (Str : String; A : String) is
5111 Dout (Str & " (" & Image (A) & ')');
5118 function Img (P : PE_Ptr) return String is
5120 return "#" & Integer (P.Index) & " ";
5127 procedure Pop_Region is
5129 Region_Level := Region_Level - 1;
5131 -- If nothing was pushed in the inner region, we can just get
5132 -- rid of it entirely, leaving no traces that it was ever there
5134 if Stack_Ptr = Stack_Base then
5135 Stack_Ptr := Stack_Base - 2;
5136 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
5138 -- If stuff was pushed in the inner region, then we have to
5139 -- push a PC_R_Restore node so that we properly handle possible
5140 -- rematches within the region.
5143 Stack_Ptr := Stack_Ptr + 1;
5144 Stack (Stack_Ptr).Cursor := Stack_Base;
5145 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
5146 Stack_Base := Stack (Stack_Base).Cursor;
5154 procedure Push (Node : PE_Ptr) is
5156 Stack_Ptr := Stack_Ptr + 1;
5157 Stack (Stack_Ptr).Cursor := Cursor;
5158 Stack (Stack_Ptr).Node := Node;
5165 procedure Push_Region is
5167 Region_Level := Region_Level + 1;
5168 Stack_Ptr := Stack_Ptr + 2;
5169 Stack (Stack_Ptr).Cursor := Stack_Base;
5170 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
5171 Stack_Base := Stack_Ptr;
5174 -- Start of processing for XMatchD
5178 Put_Line ("Initiating pattern match, subject = " & Image (Subject));
5179 Put ("--------------------------------------");
5181 for J in 1 .. Length loop
5186 Put_Line ("subject length = " & Length);
5188 if Pat_P = null then
5189 Uninitialized_Pattern;
5192 -- Check we have enough stack for this pattern. This check deals with
5193 -- every possibility except a match of a recursive pattern, where we
5194 -- make a check at each recursion level.
5196 if Pat_S >= Stack_Size - 1 then
5197 raise Pattern_Stack_Overflow;
5200 -- In anchored mode, the bottom entry on the stack is an abort entry
5202 if Anchored_Mode then
5203 Stack (Stack_Init).Node := CP_Cancel'Access;
5204 Stack (Stack_Init).Cursor := 0;
5206 -- In unanchored more, the bottom entry on the stack references
5207 -- the special pattern element PE_Unanchored, whose Pthen field
5208 -- points to the initial pattern element. The cursor value in this
5209 -- entry is the number of anchor moves so far.
5212 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
5213 Stack (Stack_Init).Cursor := 0;
5216 Stack_Ptr := Stack_Init;
5217 Stack_Base := Stack_Ptr;
5222 -----------------------------------------
5223 -- Main Pattern Matching State Control --
5224 -----------------------------------------
5226 -- This is a state machine which uses gotos to change state. The
5227 -- initial state is Match, to initiate the matching of the first
5228 -- element, so the goto Match above starts the match. In the
5229 -- following descriptions, we indicate the global values that
5230 -- are relevant for the state transition.
5232 -- Come here if entire match fails
5235 Dout ("match fails");
5241 -- Come here if entire match succeeds
5243 -- Cursor current position in subject string
5246 Dout ("match succeeds");
5247 Start := Stack (Stack_Init).Cursor + 1;
5249 Dout ("first matched character index = " & Start);
5250 Dout ("last matched character index = " & Stop);
5251 Dout ("matched substring = " & Image (Subject (Start .. Stop)));
5253 -- Scan history stack for deferred assignments or writes
5256 for S in Stack'First .. Stack_Ptr loop
5257 if Stack (S).Node = CP_Assign'Access then
5259 Inner_Base : constant Stack_Range :=
5260 Stack (S + 1).Cursor;
5261 Special_Entry : constant Stack_Range :=
5263 Node_OnM : constant PE_Ptr :=
5264 Stack (Special_Entry).Node;
5265 Start : constant Natural :=
5266 Stack (Special_Entry).Cursor + 1;
5267 Stop : constant Natural := Stack (S).Cursor;
5270 if Node_OnM.Pcode = PC_Assign_OnM then
5271 Set_Unbounded_String
5272 (Node_OnM.VP.all, Subject (Start .. Stop));
5274 (Img (Stack (S).Node) &
5275 "deferred assignment of " &
5276 Image (Subject (Start .. Stop)));
5278 elsif Node_OnM.Pcode = PC_Write_OnM then
5279 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
5281 (Img (Stack (S).Node) &
5282 "deferred write of " &
5283 Image (Subject (Start .. Stop)));
5296 -- Come here if attempt to match current element fails
5298 -- Stack_Base current stack base
5299 -- Stack_Ptr current stack pointer
5302 Cursor := Stack (Stack_Ptr).Cursor;
5303 Node := Stack (Stack_Ptr).Node;
5304 Stack_Ptr := Stack_Ptr - 1;
5307 Dout ("failure, cursor reset to " & Cursor);
5312 -- Come here if attempt to match current element succeeds
5314 -- Cursor current position in subject string
5315 -- Node pointer to node successfully matched
5316 -- Stack_Base current stack base
5317 -- Stack_Ptr current stack pointer
5320 Dout ("success, cursor = " & Cursor);
5323 -- Come here to match the next pattern element
5325 -- Cursor current position in subject string
5326 -- Node pointer to node to be matched
5327 -- Stack_Base current stack base
5328 -- Stack_Ptr current stack pointer
5332 --------------------------------------------------
5333 -- Main Pattern Match Element Matching Routines --
5334 --------------------------------------------------
5336 -- Here is the case statement that processes the current node. The
5337 -- processing for each element does one of five things:
5339 -- goto Succeed to move to the successor
5340 -- goto Match_Succeed if the entire match succeeds
5341 -- goto Match_Fail if the entire match fails
5342 -- goto Fail to signal failure of current match
5344 -- Processing is NOT allowed to fall through
5351 Dout (Img (Node) & "matching Cancel");
5357 Dout (Img (Node) & "setting up alternative " & Img (Node.Alt));
5362 -- Any (one character case)
5365 Dout (Img (Node) & "matching Any", Node.Char);
5368 and then Subject (Cursor + 1) = Node.Char
5370 Cursor := Cursor + 1;
5376 -- Any (character set case)
5379 Dout (Img (Node) & "matching Any", Node.CS);
5382 and then Is_In (Subject (Cursor + 1), Node.CS)
5384 Cursor := Cursor + 1;
5390 -- Any (string function case)
5392 when PC_Any_VF => declare
5393 U : constant VString := Node.VF.all;
5394 S : Big_String_Access;
5398 Get_String (U, S, L);
5400 Dout (Img (Node) & "matching Any", S (1 .. L));
5403 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5405 Cursor := Cursor + 1;
5412 -- Any (string pointer case)
5414 when PC_Any_VP => declare
5415 U : constant VString := Node.VP.all;
5416 S : Big_String_Access;
5420 Get_String (U, S, L);
5421 Dout (Img (Node) & "matching Any", S (1 .. L));
5424 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5426 Cursor := Cursor + 1;
5433 -- Arb (initial match)
5436 Dout (Img (Node) & "matching Arb");
5444 Dout (Img (Node) & "extending Arb");
5446 if Cursor < Length then
5447 Cursor := Cursor + 1;
5454 -- Arbno_S (simple Arbno initialize). This is the node that
5455 -- initiates the match of a simple Arbno structure.
5459 "setting up Arbno alternative " & Img (Node.Alt));
5464 -- Arbno_X (Arbno initialize). This is the node that initiates
5465 -- the match of a complex Arbno structure.
5469 "setting up Arbno alternative " & Img (Node.Alt));
5474 -- Arbno_Y (Arbno rematch). This is the node that is executed
5475 -- following successful matching of one instance of a complex
5478 when PC_Arbno_Y => declare
5479 Null_Match : constant Boolean :=
5480 Cursor = Stack (Stack_Base - 1).Cursor;
5483 Dout (Img (Node) & "extending Arbno");
5486 -- If arbno extension matched null, then immediately fail
5489 Dout ("Arbno extension matched null, so fails");
5493 -- Here we must do a stack check to make sure enough stack
5494 -- is left. This check will happen once for each instance of
5495 -- the Arbno pattern that is matched. The Nat field of a
5496 -- PC_Arbno pattern contains the maximum stack entries needed
5497 -- for the Arbno with one instance and the successor pattern
5499 if Stack_Ptr + Node.Nat >= Stack'Last then
5500 raise Pattern_Stack_Overflow;
5506 -- Assign. If this node is executed, it means the assign-on-match
5507 -- or write-on-match operation will not happen after all, so we
5508 -- is propagate the failure, removing the PC_Assign node.
5511 Dout (Img (Node) & "deferred assign/write cancelled");
5514 -- Assign immediate. This node performs the actual assignment
5516 when PC_Assign_Imm =>
5518 (Img (Node) & "executing immediate assignment of " &
5519 Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)));
5520 Set_Unbounded_String
5522 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
5526 -- Assign on match. This node sets up for the eventual assignment
5528 when PC_Assign_OnM =>
5529 Dout (Img (Node) & "registering deferred assignment");
5530 Stack (Stack_Base - 1).Node := Node;
5531 Push (CP_Assign'Access);
5539 Dout (Img (Node) & "matching or extending Bal");
5540 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
5543 elsif Subject (Cursor + 1) = '(' then
5545 Paren_Count : Natural := 1;
5549 Cursor := Cursor + 1;
5551 if Cursor >= Length then
5554 elsif Subject (Cursor + 1) = '(' then
5555 Paren_Count := Paren_Count + 1;
5557 elsif Subject (Cursor + 1) = ')' then
5558 Paren_Count := Paren_Count - 1;
5559 exit when Paren_Count = 0;
5565 Cursor := Cursor + 1;
5569 -- Break (one character case)
5572 Dout (Img (Node) & "matching Break", Node.Char);
5574 while Cursor < Length loop
5575 if Subject (Cursor + 1) = Node.Char then
5578 Cursor := Cursor + 1;
5584 -- Break (character set case)
5587 Dout (Img (Node) & "matching Break", Node.CS);
5589 while Cursor < Length loop
5590 if Is_In (Subject (Cursor + 1), Node.CS) then
5593 Cursor := Cursor + 1;
5599 -- Break (string function case)
5601 when PC_Break_VF => declare
5602 U : constant VString := Node.VF.all;
5603 S : Big_String_Access;
5607 Get_String (U, S, L);
5608 Dout (Img (Node) & "matching Break", S (1 .. L));
5610 while Cursor < Length loop
5611 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5614 Cursor := Cursor + 1;
5621 -- Break (string pointer case)
5623 when PC_Break_VP => declare
5624 U : constant VString := Node.VP.all;
5625 S : Big_String_Access;
5629 Get_String (U, S, L);
5630 Dout (Img (Node) & "matching Break", S (1 .. L));
5632 while Cursor < Length loop
5633 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5636 Cursor := Cursor + 1;
5643 -- BreakX (one character case)
5645 when PC_BreakX_CH =>
5646 Dout (Img (Node) & "matching BreakX", Node.Char);
5648 while Cursor < Length loop
5649 if Subject (Cursor + 1) = Node.Char then
5652 Cursor := Cursor + 1;
5658 -- BreakX (character set case)
5660 when PC_BreakX_CS =>
5661 Dout (Img (Node) & "matching BreakX", Node.CS);
5663 while Cursor < Length loop
5664 if Is_In (Subject (Cursor + 1), Node.CS) then
5667 Cursor := Cursor + 1;
5673 -- BreakX (string function case)
5675 when PC_BreakX_VF => declare
5676 U : constant VString := Node.VF.all;
5677 S : Big_String_Access;
5681 Get_String (U, S, L);
5682 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5684 while Cursor < Length loop
5685 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5688 Cursor := Cursor + 1;
5695 -- BreakX (string pointer case)
5697 when PC_BreakX_VP => declare
5698 U : constant VString := Node.VP.all;
5699 S : Big_String_Access;
5703 Get_String (U, S, L);
5704 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5706 while Cursor < Length loop
5707 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5710 Cursor := Cursor + 1;
5717 -- BreakX_X (BreakX extension). See section on "Compound Pattern
5718 -- Structures". This node is the alternative that is stacked
5719 -- to skip past the break character and extend the break.
5722 Dout (Img (Node) & "extending BreakX");
5723 Cursor := Cursor + 1;
5726 -- Character (one character string)
5729 Dout (Img (Node) & "matching '" & Node.Char & ''');
5732 and then Subject (Cursor + 1) = Node.Char
5734 Cursor := Cursor + 1;
5743 if Stack_Base = Stack_Init then
5744 Dout ("end of pattern
");
5747 -- End of recursive inner match. See separate section on
5748 -- handing of recursive pattern matches for details.
5751 Dout ("terminating recursive match
");
5752 Node := Stack (Stack_Base - 1).Node;
5760 Dout (Img (Node) & "matching Fail
");
5763 -- Fence (built in pattern)
5766 Dout (Img (Node) & "matching Fence
");
5767 Push (CP_Cancel'Access);
5770 -- Fence function node X. This is the node that gets control
5771 -- after a successful match of the fenced pattern.
5774 Dout (Img (Node) & "matching Fence
function");
5775 Stack_Ptr := Stack_Ptr + 1;
5776 Stack (Stack_Ptr).Cursor := Stack_Base;
5777 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
5778 Stack_Base := Stack (Stack_Base).Cursor;
5779 Region_Level := Region_Level - 1;
5782 -- Fence function node Y. This is the node that gets control on
5783 -- a failure that occurs after the fenced pattern has matched.
5785 -- Note: the Cursor at this stage is actually the inner stack
5786 -- base value. We don't reset this, but we do use it to strip
5787 -- off all the entries made by the fenced pattern.
5790 Dout (Img (Node) & "pattern matched by Fence caused failure
");
5791 Stack_Ptr := Cursor - 2;
5794 -- Len (integer case)
5797 Dout (Img (Node) & "matching Len
", Node.Nat);
5799 if Cursor + Node.Nat > Length then
5802 Cursor := Cursor + Node.Nat;
5806 -- Len (Integer function case)
5808 when PC_Len_NF => declare
5809 N : constant Natural := Node.NF.all;
5812 Dout (Img (Node) & "matching Len
", N);
5814 if Cursor + N > Length then
5817 Cursor := Cursor + N;
5822 -- Len (integer pointer case)
5825 Dout (Img (Node) & "matching Len
", Node.NP.all);
5827 if Cursor + Node.NP.all > Length then
5830 Cursor := Cursor + Node.NP.all;
5834 -- NotAny (one character case)
5836 when PC_NotAny_CH =>
5837 Dout (Img (Node) & "matching NotAny
", Node.Char);
5840 and then Subject (Cursor + 1) /= Node.Char
5842 Cursor := Cursor + 1;
5848 -- NotAny (character set case)
5850 when PC_NotAny_CS =>
5851 Dout (Img (Node) & "matching NotAny
", Node.CS);
5854 and then not Is_In (Subject (Cursor + 1), Node.CS)
5856 Cursor := Cursor + 1;
5862 -- NotAny (string function case)
5864 when PC_NotAny_VF => declare
5865 U : constant VString := Node.VF.all;
5866 S : Big_String_Access;
5870 Get_String (U, S, L);
5871 Dout (Img (Node) & "matching NotAny
", S (1 .. L));
5875 not Is_In (Subject (Cursor + 1), S (1 .. L))
5877 Cursor := Cursor + 1;
5884 -- NotAny (string pointer case)
5886 when PC_NotAny_VP => declare
5887 U : constant VString := Node.VP.all;
5888 S : Big_String_Access;
5892 Get_String (U, S, L);
5893 Dout (Img (Node) & "matching NotAny
", S (1 .. L));
5897 not Is_In (Subject (Cursor + 1), S (1 .. L))
5899 Cursor := Cursor + 1;
5906 -- NSpan (one character case)
5909 Dout (Img (Node) & "matching NSpan
", Node.Char);
5911 while Cursor < Length
5912 and then Subject (Cursor + 1) = Node.Char
5914 Cursor := Cursor + 1;
5919 -- NSpan (character set case)
5922 Dout (Img (Node) & "matching NSpan
", Node.CS);
5924 while Cursor < Length
5925 and then Is_In (Subject (Cursor + 1), Node.CS)
5927 Cursor := Cursor + 1;
5932 -- NSpan (string function case)
5934 when PC_NSpan_VF => declare
5935 U : constant VString := Node.VF.all;
5936 S : Big_String_Access;
5940 Get_String (U, S, L);
5941 Dout (Img (Node) & "matching NSpan
", S (1 .. L));
5943 while Cursor < Length
5944 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5946 Cursor := Cursor + 1;
5952 -- NSpan (string pointer case)
5954 when PC_NSpan_VP => declare
5955 U : constant VString := Node.VP.all;
5956 S : Big_String_Access;
5960 Get_String (U, S, L);
5961 Dout (Img (Node) & "matching NSpan
", S (1 .. L));
5963 while Cursor < Length
5964 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5966 Cursor := Cursor + 1;
5973 Dout (Img (Node) & "matching
null");
5976 -- Pos (integer case)
5979 Dout (Img (Node) & "matching Pos
", Node.Nat);
5981 if Cursor = Node.Nat then
5987 -- Pos (Integer function case)
5989 when PC_Pos_NF => declare
5990 N : constant Natural := Node.NF.all;
5993 Dout (Img (Node) & "matching Pos
", N);
6002 -- Pos (integer pointer case)
6005 Dout (Img (Node) & "matching Pos
", Node.NP.all);
6007 if Cursor = Node.NP.all then
6013 -- Predicate function
6015 when PC_Pred_Func =>
6016 Dout (Img (Node) & "matching predicate
function");
6024 -- Region Enter. Initiate new pattern history stack region
6027 Dout (Img (Node) & "starting match
of nested pattern
");
6028 Stack (Stack_Ptr + 1).Cursor := Cursor;
6032 -- Region Remove node. This is the node stacked by an R_Enter.
6033 -- It removes the special format stack entry right underneath, and
6034 -- then restores the outer level stack base and signals failure.
6036 -- Note: the cursor value at this stage is actually the (negative)
6037 -- stack base value for the outer level.
6040 Dout ("failure
, match
of nested pattern terminated
");
6041 Stack_Base := Cursor;
6042 Region_Level := Region_Level - 1;
6043 Stack_Ptr := Stack_Ptr - 1;
6046 -- Region restore node. This is the node stacked at the end of an
6047 -- inner level match. Its function is to restore the inner level
6048 -- region, so that alternatives in this region can be sought.
6050 -- Note: the Cursor at this stage is actually the negative of the
6051 -- inner stack base value, which we use to restore the inner region.
6053 when PC_R_Restore =>
6054 Dout ("failure
, search
for alternatives
in nested pattern
");
6055 Region_Level := Region_Level + 1;
6056 Stack_Base := Cursor;
6062 Dout (Img (Node) & "matching Rest
");
6066 -- Initiate recursive match (pattern pointer case)
6069 Stack (Stack_Ptr + 1).Node := Node.Pthen;
6071 Dout (Img (Node) & "initiating recursive match
");
6073 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
6074 raise Pattern_Stack_Overflow;
6076 Node := Node.PP.all.P;
6080 -- RPos (integer case)
6083 Dout (Img (Node) & "matching RPos
", Node.Nat);
6085 if Cursor = (Length - Node.Nat) then
6091 -- RPos (integer function case)
6093 when PC_RPos_NF => declare
6094 N : constant Natural := Node.NF.all;
6097 Dout (Img (Node) & "matching RPos
", N);
6099 if Length - Cursor = N then
6106 -- RPos (integer pointer case)
6109 Dout (Img (Node) & "matching RPos
", Node.NP.all);
6111 if Cursor = (Length - Node.NP.all) then
6117 -- RTab (integer case)
6120 Dout (Img (Node) & "matching RTab
", Node.Nat);
6122 if Cursor <= (Length - Node.Nat) then
6123 Cursor := Length - Node.Nat;
6129 -- RTab (integer function case)
6131 when PC_RTab_NF => declare
6132 N : constant Natural := Node.NF.all;
6135 Dout (Img (Node) & "matching RPos
", N);
6137 if Length - Cursor >= N then
6138 Cursor := Length - N;
6145 -- RTab (integer pointer case)
6148 Dout (Img (Node) & "matching RPos
", Node.NP.all);
6150 if Cursor <= (Length - Node.NP.all) then
6151 Cursor := Length - Node.NP.all;
6157 -- Cursor assignment
6160 Dout (Img (Node) & "matching Setcur
");
6161 Node.Var.all := Cursor;
6164 -- Span (one character case)
6166 when PC_Span_CH => declare
6167 P : Natural := Cursor;
6170 Dout (Img (Node) & "matching Span
", Node.Char);
6173 and then Subject (P + 1) = Node.Char
6186 -- Span (character set case)
6188 when PC_Span_CS => declare
6189 P : Natural := Cursor;
6192 Dout (Img (Node) & "matching Span
", Node.CS);
6195 and then Is_In (Subject (P + 1), Node.CS)
6208 -- Span (string function case)
6210 when PC_Span_VF => declare
6211 U : constant VString := Node.VF.all;
6212 S : Big_String_Access;
6217 Get_String (U, S, L);
6218 Dout (Img (Node) & "matching Span
", S (1 .. L));
6222 and then Is_In (Subject (P + 1), S (1 .. L))
6235 -- Span (string pointer case)
6237 when PC_Span_VP => declare
6238 U : constant VString := Node.VP.all;
6239 S : Big_String_Access;
6244 Get_String (U, S, L);
6245 Dout (Img (Node) & "matching Span
", S (1 .. L));
6249 and then Is_In (Subject (P + 1), S (1 .. L))
6262 -- String (two character case)
6265 Dout (Img (Node) & "matching
" & Image (Node.Str2));
6267 if (Length - Cursor) >= 2
6268 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
6270 Cursor := Cursor + 2;
6276 -- String (three character case)
6279 Dout (Img (Node) & "matching
" & Image (Node.Str3));
6281 if (Length - Cursor) >= 3
6282 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
6284 Cursor := Cursor + 3;
6290 -- String (four character case)
6293 Dout (Img (Node) & "matching
" & Image (Node.Str4));
6295 if (Length - Cursor) >= 4
6296 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
6298 Cursor := Cursor + 4;
6304 -- String (five character case)
6307 Dout (Img (Node) & "matching
" & Image (Node.Str5));
6309 if (Length - Cursor) >= 5
6310 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
6312 Cursor := Cursor + 5;
6318 -- String (six character case)
6321 Dout (Img (Node) & "matching
" & Image (Node.Str6));
6323 if (Length - Cursor) >= 6
6324 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
6326 Cursor := Cursor + 6;
6332 -- String (case of more than six characters)
6334 when PC_String => declare
6335 Len : constant Natural := Node.Str'Length;
6338 Dout (Img (Node) & "matching
" & Image (Node.Str.all));
6340 if (Length - Cursor) >= Len
6341 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
6343 Cursor := Cursor + Len;
6350 -- String (function case)
6352 when PC_String_VF => declare
6353 U : constant VString := Node.VF.all;
6354 S : Big_String_Access;
6358 Get_String (U, S, L);
6359 Dout (Img (Node) & "matching
" & Image (S (1 .. L)));
6361 if (Length - Cursor) >= L
6362 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6364 Cursor := Cursor + L;
6371 -- String (vstring pointer case)
6373 when PC_String_VP => declare
6374 U : constant VString := Node.VP.all;
6375 S : Big_String_Access;
6379 Get_String (U, S, L);
6380 Dout (Img (Node) & "matching
" & Image (S (1 .. L)));
6382 if (Length - Cursor) >= L
6383 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6385 Cursor := Cursor + L;
6395 Dout (Img (Node) & "matching Succeed
");
6399 -- Tab (integer case)
6402 Dout (Img (Node) & "matching Tab
", Node.Nat);
6404 if Cursor <= Node.Nat then
6411 -- Tab (integer function case)
6413 when PC_Tab_NF => declare
6414 N : constant Natural := Node.NF.all;
6417 Dout (Img (Node) & "matching Tab
", N);
6427 -- Tab (integer pointer case)
6430 Dout (Img (Node) & "matching Tab
", Node.NP.all);
6432 if Cursor <= Node.NP.all then
6433 Cursor := Node.NP.all;
6439 -- Unanchored movement
6441 when PC_Unanchored =>
6442 Dout ("attempting to move anchor point
");
6444 -- All done if we tried every position
6446 if Cursor > Length then
6449 -- Otherwise extend the anchor point, and restack ourself
6452 Cursor := Cursor + 1;
6457 -- Write immediate. This node performs the actual write
6459 when PC_Write_Imm =>
6460 Dout (Img (Node) & "executing immediate write
of " &
6461 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6465 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6469 -- Write on match. This node sets up for the eventual write
6471 when PC_Write_OnM =>
6472 Dout (Img (Node) & "registering deferred write
");
6473 Stack (Stack_Base - 1).Node := Node;
6474 Push (CP_Assign'Access);
6480 -- We are NOT allowed to fall though this case statement, since every
6481 -- match routine must end by executing a goto to the appropriate point
6482 -- in the finite state machine model.
6484 pragma Warnings (Off);
6486 pragma Warnings (On);
6489 end GNAT.Spitbol.Patterns;