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-2024, 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
;
2841 Get_String
(Subject
, S
, L
);
2844 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2846 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2854 Pat
: Pattern
) return Boolean
2856 Start
, Stop
: Natural;
2858 subtype String1
is String (1 .. Subject
'Length);
2862 XMatchD
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2864 XMatch
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2871 (Subject
: VString_Var
;
2873 Replace
: VString
) return Boolean
2877 S
: Big_String_Access
;
2881 Get_String
(Subject
, S
, L
);
2884 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2886 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2892 Get_String
(Replace
, S
, L
);
2894 (Subject
'Unrestricted_Access.all, Start
, Stop
, S
(1 .. L
));
2900 (Subject
: VString_Var
;
2902 Replace
: String) return Boolean
2906 S
: Big_String_Access
;
2910 Get_String
(Subject
, S
, L
);
2913 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2915 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2922 (Subject
'Unrestricted_Access.all, Start
, Stop
, Replace
);
2931 S
: Big_String_Access
;
2938 Get_String
(Subject
, S
, L
);
2941 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2943 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2951 Start
, Stop
: Natural;
2953 subtype String1
is String (1 .. Subject
'Length);
2957 XMatchD
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2959 XMatch
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2964 (Subject
: in out VString
;
2970 S
: Big_String_Access
;
2974 Get_String
(Subject
, S
, L
);
2977 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2979 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2983 Get_String
(Replace
, S
, L
);
2984 Replace_Slice
(Subject
, Start
, Stop
, S
(1 .. L
));
2989 (Subject
: in out VString
;
2995 S
: Big_String_Access
;
2999 Get_String
(Subject
, S
, L
);
3002 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3004 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3008 Replace_Slice
(Subject
, Start
, Stop
, Replace
);
3014 Pat
: PString
) return Boolean
3016 Pat_Len
: constant Natural := Pat
'Length;
3017 S
: Big_String_Access
;
3021 Get_String
(Subject
, S
, L
);
3023 if Anchored_Mode
then
3027 return Pat
= S
(1 .. Pat_Len
);
3031 for J
in 1 .. L
- Pat_Len
+ 1 loop
3032 if Pat
= S
(J
.. J
+ (Pat_Len
- 1)) then
3043 Pat
: PString
) return Boolean
3045 Pat_Len
: constant Natural := Pat
'Length;
3046 Sub_Len
: constant Natural := Subject
'Length;
3047 SFirst
: constant Natural := Subject
'First;
3050 if Anchored_Mode
then
3051 if Pat_Len
> Sub_Len
then
3054 return Pat
= Subject
(SFirst
.. SFirst
+ Pat_Len
- 1);
3058 for J
in SFirst
.. SFirst
+ Sub_Len
- Pat_Len
loop
3059 if Pat
= Subject
(J
.. J
+ (Pat_Len
- 1)) then
3069 (Subject
: VString_Var
;
3071 Replace
: VString
) return Boolean
3075 S
: Big_String_Access
;
3079 Get_String
(Subject
, S
, L
);
3082 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3084 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3090 Get_String
(Replace
, S
, L
);
3092 (Subject
'Unrestricted_Access.all, Start
, Stop
, S
(1 .. L
));
3098 (Subject
: VString_Var
;
3100 Replace
: String) return Boolean
3104 S
: Big_String_Access
;
3108 Get_String
(Subject
, S
, L
);
3111 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3113 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3120 (Subject
'Unrestricted_Access.all, Start
, Stop
, Replace
);
3129 S
: Big_String_Access
;
3136 Get_String
(Subject
, S
, L
);
3139 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3141 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3149 Start
, Stop
: Natural;
3151 subtype String1
is String (1 .. Subject
'Length);
3155 XMatchD
(String1
(Subject
), S_To_PE
(Pat
), 0, Start
, Stop
);
3157 XMatch
(String1
(Subject
), S_To_PE
(Pat
), 0, Start
, Stop
);
3162 (Subject
: in out VString
;
3168 S
: Big_String_Access
;
3172 Get_String
(Subject
, S
, L
);
3175 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3177 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3181 Get_String
(Replace
, S
, L
);
3182 Replace_Slice
(Subject
, Start
, Stop
, S
(1 .. L
));
3187 (Subject
: in out VString
;
3193 S
: Big_String_Access
;
3197 Get_String
(Subject
, S
, L
);
3200 XMatchD
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3202 XMatch
(S
(1 .. L
), S_To_PE
(Pat
), 0, Start
, Stop
);
3206 Replace_Slice
(Subject
, Start
, Stop
, Replace
);
3211 (Subject
: VString_Var
;
3213 Result
: Match_Result_Var
) return Boolean
3217 S
: Big_String_Access
;
3221 Get_String
(Subject
, S
, L
);
3224 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3226 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3230 Result
'Unrestricted_Access.all.Var
:= null;
3234 Result
'Unrestricted_Access.all.Var
:= Subject
'Unrestricted_Access;
3235 Result
'Unrestricted_Access.all.Start
:= Start
;
3236 Result
'Unrestricted_Access.all.Stop
:= Stop
;
3242 (Subject
: in out VString
;
3244 Result
: out Match_Result
)
3248 S
: Big_String_Access
;
3252 Get_String
(Subject
, S
, L
);
3255 XMatchD
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3257 XMatch
(S
(1 .. L
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
3263 Result
.Var
:= Subject
'Unrestricted_Access;
3264 Result
.Start
:= Start
;
3265 Result
.Stop
:= Stop
;
3273 procedure New_LineD
is
3275 if Internal_Debug
then
3284 function NotAny
(Str
: String) return Pattern
is
3286 return (AFC
with 0, new PE
'(PC_NotAny_CS, 1, EOP, To_Set (Str)));
3289 function NotAny (Str : VString) return Pattern is
3291 return NotAny (S (Str));
3294 function NotAny (Str : Character) return Pattern is
3296 return (AFC with 0, new PE'(PC_NotAny_CH
, 1, EOP
, Str
));
3299 function NotAny
(Str
: Character_Set
) return Pattern
is
3301 return (AFC
with 0, new PE
'(PC_NotAny_CS, 1, EOP, Str));
3304 function NotAny (Str : not null access VString) return Pattern is
3306 return (AFC with 0, new PE'(PC_NotAny_VP
, 1, EOP
, VString_Ptr
(Str
)));
3309 function NotAny
(Str
: VString_Func
) return Pattern
is
3311 return (AFC
with 0, new PE
'(PC_NotAny_VF, 1, EOP, Str));
3318 function NSpan (Str : String) return Pattern is
3320 return (AFC with 0, new PE'(PC_NSpan_CS
, 1, EOP
, To_Set
(Str
)));
3323 function NSpan
(Str
: VString
) return Pattern
is
3325 return NSpan
(S
(Str
));
3328 function NSpan
(Str
: Character) return Pattern
is
3330 return (AFC
with 0, new PE
'(PC_NSpan_CH, 1, EOP, Str));
3333 function NSpan (Str : Character_Set) return Pattern is
3335 return (AFC with 0, new PE'(PC_NSpan_CS
, 1, EOP
, Str
));
3338 function NSpan
(Str
: not null access VString
) return Pattern
is
3340 return (AFC
with 0, new PE
'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str)));
3343 function NSpan (Str : VString_Func) return Pattern is
3345 return (AFC with 0, new PE'(PC_NSpan_VF
, 1, EOP
, Str
));
3352 function Pos
(Count
: Natural) return Pattern
is
3354 return (AFC
with 0, new PE
'(PC_Pos_Nat, 1, EOP, Count));
3357 function Pos (Count : Natural_Func) return Pattern is
3359 return (AFC with 0, new PE'(PC_Pos_NF
, 1, EOP
, Count
));
3362 function Pos
(Count
: not null access Natural) return Pattern
is
3364 return (AFC
with 0, new PE
'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count)));
3371 procedure PutD (Str : String) is
3373 if Internal_Debug then
3382 procedure Put_LineD (Str : String) is
3384 if Internal_Debug then
3394 (Result : in out Match_Result;
3397 S : Big_String_Access;
3401 Get_String (Replace, S, L);
3403 if Result.Var /= null then
3404 Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L));
3413 function Rest return Pattern is
3415 return (AFC with 0, new PE'(PC_Rest
, 1, EOP
));
3422 function Rpos
(Count
: Natural) return Pattern
is
3424 return (AFC
with 0, new PE
'(PC_RPos_Nat, 1, EOP, Count));
3427 function Rpos (Count : Natural_Func) return Pattern is
3429 return (AFC with 0, new PE'(PC_RPos_NF
, 1, EOP
, Count
));
3432 function Rpos
(Count
: not null access Natural) return Pattern
is
3434 return (AFC
with 0, new PE
'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count)));
3441 function Rtab (Count : Natural) return Pattern is
3443 return (AFC with 0, new PE'(PC_RTab_Nat
, 1, EOP
, Count
));
3446 function Rtab
(Count
: Natural_Func
) return Pattern
is
3448 return (AFC
with 0, new PE
'(PC_RTab_NF, 1, EOP, Count));
3451 function Rtab (Count : not null access Natural) return Pattern is
3453 return (AFC with 0, new PE'(PC_RTab_NP
, 1, EOP
, Natural_Ptr
(Count
)));
3460 function S_To_PE
(Str
: PString
) return PE_Ptr
is
3461 Len
: constant Natural := Str
'Length;
3466 return new PE
'(PC_Null, 1, EOP);
3469 return new PE'(PC_Char
, 1, EOP
, Str
(Str
'First));
3472 return new PE
'(PC_String_2, 1, EOP, Str);
3475 return new PE'(PC_String_3
, 1, EOP
, Str
);
3478 return new PE
'(PC_String_4, 1, EOP, Str);
3481 return new PE'(PC_String_5
, 1, EOP
, Str
);
3484 return new PE
'(PC_String_6, 1, EOP, Str);
3487 return new PE'(PC_String
, 1, EOP
, new String'(Str));
3495 -- Note: this procedure is not used by the normal concatenation circuit,
3496 -- since other fixups are required on the left operand in this case, and
3497 -- they might as well be done all together.
3499 procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is
3502 Uninitialized_Pattern;
3504 elsif Pat = EOP then
3509 Refs : Ref_Array (1 .. Pat.Index);
3510 -- We build a reference array for L whose N'th element points to
3511 -- the pattern element of L whose original Index value is N.
3516 Build_Ref_Array (Pat, Refs);
3518 for J in Refs'Range loop
3521 if P.Pthen = EOP then
3525 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
3537 function Setcur (Var : not null access Natural) return Pattern is
3539 return (AFC with 0, new PE'(PC_Setcur
, 1, EOP
, Natural_Ptr
(Var
)));
3546 function Span
(Str
: String) return Pattern
is
3548 return (AFC
with 0, new PE
'(PC_Span_CS, 1, EOP, To_Set (Str)));
3551 function Span (Str : VString) return Pattern is
3553 return Span (S (Str));
3556 function Span (Str : Character) return Pattern is
3558 return (AFC with 0, new PE'(PC_Span_CH
, 1, EOP
, Str
));
3561 function Span
(Str
: Character_Set
) return Pattern
is
3563 return (AFC
with 0, new PE
'(PC_Span_CS, 1, EOP, Str));
3566 function Span (Str : not null access VString) return Pattern is
3568 return (AFC with 0, new PE'(PC_Span_VP
, 1, EOP
, VString_Ptr
(Str
)));
3571 function Span
(Str
: VString_Func
) return Pattern
is
3573 return (AFC
with 0, new PE
'(PC_Span_VF, 1, EOP, Str));
3580 function Str_BF (A : Boolean_Func) return String is
3581 function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address);
3583 return "BF(" & Image (To_A (A)) & ')';
3590 function Str_FP (A : File_Ptr) return String is
3592 return "FP(" & Image (A.all'Address) & ')';
3599 function Str_NF (A : Natural_Func) return String is
3600 function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address);
3602 return "NF(" & Image (To_A (A)) & ')';
3609 function Str_NP (A : Natural_Ptr) return String is
3611 return "NP(" & Image (A.all'Address) & ')';
3618 function Str_PP (A : Pattern_Ptr) return String is
3620 return "PP(" & Image (A.all'Address) & ')';
3627 function Str_VF (A : VString_Func) return String is
3628 function To_A is new Ada.Unchecked_Conversion (VString_Func, Address);
3630 return "VF(" & Image (To_A (A)) & ')';
3637 function Str_VP (A : VString_Ptr) return String is
3639 return "VP(" & Image (A.all'Address) & ')';
3646 function Succeed return Pattern is
3648 return (AFC with 1, new PE'(PC_Succeed
, 1, EOP
));
3655 function Tab
(Count
: Natural) return Pattern
is
3657 return (AFC
with 0, new PE
'(PC_Tab_Nat, 1, EOP, Count));
3660 function Tab (Count : Natural_Func) return Pattern is
3662 return (AFC with 0, new PE'(PC_Tab_NF
, 1, EOP
, Count
));
3665 function Tab
(Count
: not null access Natural) return Pattern
is
3667 return (AFC
with 0, new PE
'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count)));
3670 ---------------------------
3671 -- Uninitialized_Pattern --
3672 ---------------------------
3674 procedure Uninitialized_Pattern is
3676 raise Program_Error with
3677 "uninitialized value of type GNAT.Spitbol.Patterns.Pattern";
3678 end Uninitialized_Pattern;
3688 Start : out Natural;
3692 -- Pointer to current pattern node. Initialized from Pat_P, and then
3693 -- updated as the match proceeds through its constituent elements.
3695 Length : constant Natural := Subject'Length;
3696 -- Length of string (= Subject'Last, since Subject'First is always 1)
3698 Cursor : Integer := 0;
3699 -- If the value is non-negative, then this value is the index showing
3700 -- the current position of the match in the subject string. The next
3701 -- character to be matched is at Subject (Cursor + 1). Note that since
3702 -- our view of the subject string in XMatch always has a lower bound
3703 -- of one, regardless of original bounds, that this definition exactly
3704 -- corresponds to the cursor value as referenced by functions like Pos.
3706 -- If the value is negative, then this is a saved stack pointer,
3707 -- typically a base pointer of an inner or outer region. Cursor
3708 -- temporarily holds such a value when it is popped from the stack
3709 -- by Fail. In all cases, Cursor is reset to a proper non-negative
3710 -- cursor value before the match proceeds (e.g. by propagating the
3711 -- failure and popping a "real" cursor value from the stack.
3713 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
3714 -- Dummy pattern element used in the unanchored case
3717 -- The pattern matching failure stack for this call to Match
3719 Stack_Ptr : Stack_Range;
3720 -- Current stack pointer. This points to the top element of the stack
3721 -- that is currently in use. At the outer level this is the special
3722 -- entry placed on the stack according to the anchor mode.
3724 Stack_Init : constant Stack_Range := Stack'First + 1;
3725 -- This is the initial value of the Stack_Ptr and Stack_Base. The
3726 -- initial (Stack'First) element of the stack is not used so that
3727 -- when we pop the last element off, Stack_Ptr is still in range.
3729 Stack_Base : Stack_Range;
3730 -- This value is the stack base value, i.e. the stack pointer for the
3731 -- first history stack entry in the current stack region. See separate
3732 -- section on handling of recursive pattern matches.
3734 Assign_OnM : Boolean := False;
3735 -- Set True if assign-on-match or write-on-match operations may be
3736 -- present in the history stack, which must then be scanned on a
3737 -- successful match.
3739 procedure Pop_Region;
3740 pragma Inline (Pop_Region);
3741 -- Used at the end of processing of an inner region. If the inner
3742 -- region left no stack entries, then all trace of it is removed.
3743 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
3744 -- handling of alternatives in the inner region.
3746 procedure Push (Node : PE_Ptr);
3747 pragma Inline (Push);
3748 -- Make entry in pattern matching stack with current cursor value
3750 procedure Push_Region;
3751 pragma Inline (Push_Region);
3752 -- This procedure makes a new region on the history stack. The
3753 -- caller first establishes the special entry on the stack, but
3754 -- does not push the stack pointer. Then this call stacks a
3755 -- PC_Remove_Region node, on top of this entry, using the cursor
3756 -- field of the PC_Remove_Region entry to save the outer level
3757 -- stack base value, and resets the stack base to point to this
3758 -- PC_Remove_Region node.
3764 procedure Pop_Region is
3766 -- If nothing was pushed in the inner region, we can just get
3767 -- rid of it entirely, leaving no traces that it was ever there
3769 if Stack_Ptr = Stack_Base then
3770 Stack_Ptr := Stack_Base - 2;
3771 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
3773 -- If stuff was pushed in the inner region, then we have to
3774 -- push a PC_R_Restore node so that we properly handle possible
3775 -- rematches within the region.
3778 Stack_Ptr := Stack_Ptr + 1;
3779 Stack (Stack_Ptr).Cursor := Stack_Base;
3780 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
3781 Stack_Base := Stack (Stack_Base).Cursor;
3789 procedure Push (Node : PE_Ptr) is
3791 Stack_Ptr := Stack_Ptr + 1;
3792 Stack (Stack_Ptr).Cursor := Cursor;
3793 Stack (Stack_Ptr).Node := Node;
3800 procedure Push_Region is
3802 Stack_Ptr := Stack_Ptr + 2;
3803 Stack (Stack_Ptr).Cursor := Stack_Base;
3804 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
3805 Stack_Base := Stack_Ptr;
3808 -- Start of processing for XMatch
3811 if Pat_P = null then
3812 Uninitialized_Pattern;
3815 -- Check we have enough stack for this pattern. This check deals with
3816 -- every possibility except a match of a recursive pattern, where we
3817 -- make a check at each recursion level.
3819 if Pat_S >= Stack_Size - 1 then
3820 raise Pattern_Stack_Overflow;
3823 -- In anchored mode, the bottom entry on the stack is an abort entry
3825 if Anchored_Mode then
3826 Stack (Stack_Init).Node := CP_Cancel'Access;
3827 Stack (Stack_Init).Cursor := 0;
3829 -- In unanchored more, the bottom entry on the stack references
3830 -- the special pattern element PE_Unanchored, whose Pthen field
3831 -- points to the initial pattern element. The cursor value in this
3832 -- entry is the number of anchor moves so far.
3835 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
3836 Stack (Stack_Init).Cursor := 0;
3839 Stack_Ptr := Stack_Init;
3840 Stack_Base := Stack_Ptr;
3845 -----------------------------------------
3846 -- Main Pattern Matching State Control --
3847 -----------------------------------------
3849 -- This is a state machine which uses gotos to change state. The
3850 -- initial state is Match, to initiate the matching of the first
3851 -- element, so the goto Match above starts the match. In the
3852 -- following descriptions, we indicate the global values that
3853 -- are relevant for the state transition.
3855 -- Come here if entire match fails
3862 -- Come here if entire match succeeds
3864 -- Cursor current position in subject string
3867 Start := Stack (Stack_Init).Cursor + 1;
3870 -- Scan history stack for deferred assignments or writes
3873 for S in Stack_Init .. Stack_Ptr loop
3874 if Stack (S).Node = CP_Assign'Access then
3876 Inner_Base : constant Stack_Range :=
3877 Stack (S + 1).Cursor;
3878 Special_Entry : constant Stack_Range :=
3880 Node_OnM : constant PE_Ptr :=
3881 Stack (Special_Entry).Node;
3882 Start : constant Natural :=
3883 Stack (Special_Entry).Cursor + 1;
3884 Stop : constant Natural := Stack (S).Cursor;
3887 if Node_OnM.Pcode = PC_Assign_OnM then
3888 Set_Unbounded_String
3889 (Node_OnM.VP.all, Subject (Start .. Stop));
3891 elsif Node_OnM.Pcode = PC_Write_OnM then
3892 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
3904 -- Come here if attempt to match current element fails
3906 -- Stack_Base current stack base
3907 -- Stack_Ptr current stack pointer
3910 Cursor := Stack (Stack_Ptr).Cursor;
3911 Node := Stack (Stack_Ptr).Node;
3912 Stack_Ptr := Stack_Ptr - 1;
3915 -- Come here if attempt to match current element succeeds
3917 -- Cursor current position in subject string
3918 -- Node pointer to node successfully matched
3919 -- Stack_Base current stack base
3920 -- Stack_Ptr current stack pointer
3925 -- Come here to match the next pattern element
3927 -- Cursor current position in subject string
3928 -- Node pointer to node to be matched
3929 -- Stack_Base current stack base
3930 -- Stack_Ptr current stack pointer
3934 --------------------------------------------------
3935 -- Main Pattern Match Element Matching Routines --
3936 --------------------------------------------------
3938 -- Here is the case statement that processes the current node. The
3939 -- processing for each element does one of five things:
3941 -- goto Succeed to move to the successor
3942 -- goto Match_Succeed if the entire match succeeds
3943 -- goto Match_Fail if the entire match fails
3944 -- goto Fail to signal failure of current match
3946 -- Processing is NOT allowed to fall through
3962 -- Any (one character case)
3964 when PC_Any_CH | PC_Char =>
3966 and then Subject (Cursor + 1) = Node.Char
3968 Cursor := Cursor + 1;
3974 -- Any (character set case)
3978 and then Is_In (Subject (Cursor + 1), Node.CS)
3980 Cursor := Cursor + 1;
3986 -- Any (string function case)
3988 when PC_Any_VF => declare
3989 U : constant VString := Node.VF.all;
3990 S : Big_String_Access;
3994 Get_String (U, S, L);
3997 and then Is_In (Subject (Cursor + 1), S (1 .. L))
3999 Cursor := Cursor + 1;
4006 -- Any (string pointer case)
4008 when PC_Any_VP => declare
4009 U : constant VString := Node.VP.all;
4010 S : Big_String_Access;
4014 Get_String (U, S, L);
4017 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4019 Cursor := Cursor + 1;
4026 -- Arb (initial match)
4036 if Cursor < Length then
4037 Cursor := Cursor + 1;
4044 -- Arbno_S (simple Arbno initialize). This is the node that
4045 -- initiates the match of a simple Arbno structure.
4052 -- Arbno_X (Arbno initialize). This is the node that initiates
4053 -- the match of a complex Arbno structure.
4060 -- Arbno_Y (Arbno rematch). This is the node that is executed
4061 -- following successful matching of one instance of a complex
4064 when PC_Arbno_Y => declare
4065 Null_Match : constant Boolean :=
4066 Cursor = Stack (Stack_Base - 1).Cursor;
4071 -- If arbno extension matched null, then immediately fail
4077 -- Here we must do a stack check to make sure enough stack
4078 -- is left. This check will happen once for each instance of
4079 -- the Arbno pattern that is matched. The Nat field of a
4080 -- PC_Arbno pattern contains the maximum stack entries needed
4081 -- for the Arbno with one instance and the successor pattern
4083 if Stack_Ptr + Node.Nat >= Stack'Last then
4084 raise Pattern_Stack_Overflow;
4090 -- Assign. If this node is executed, it means the assign-on-match
4091 -- or write-on-match operation will not happen after all, so we
4092 -- is propagate the failure, removing the PC_Assign node.
4097 -- Assign immediate. This node performs the actual assignment
4099 when PC_Assign_Imm =>
4100 Set_Unbounded_String
4102 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4106 -- Write/assign on match. This node sets up for the eventual write
4109 when PC_Assign_OnM | PC_Write_OnM =>
4110 Stack (Stack_Base - 1).Node := Node;
4111 Push (CP_Assign'Access);
4119 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
4122 elsif Subject (Cursor + 1) = '(' then
4124 Paren_Count : Natural := 1;
4128 Cursor := Cursor + 1;
4130 if Cursor >= Length then
4133 elsif Subject (Cursor + 1) = '(' then
4134 Paren_Count := Paren_Count + 1;
4136 elsif Subject (Cursor + 1) = ')' then
4137 Paren_Count := Paren_Count - 1;
4138 exit when Paren_Count = 0;
4144 Cursor := Cursor + 1;
4148 -- Break & BreakX (one character case)
4150 when PC_Break_CH | PC_BreakX_CH =>
4151 while Cursor < Length loop
4152 if Subject (Cursor + 1) = Node.Char then
4155 Cursor := Cursor + 1;
4161 -- Break & BreakX (character set case)
4163 when PC_Break_CS | PC_BreakX_CS =>
4164 while Cursor < Length loop
4165 if Is_In (Subject (Cursor + 1), Node.CS) then
4168 Cursor := Cursor + 1;
4174 -- Break & BreakX (string function case)
4176 when PC_Break_VF | PC_BreakX_VF => declare
4177 U : constant VString := Node.VF.all;
4178 S : Big_String_Access;
4182 Get_String (U, S, L);
4184 while Cursor < Length loop
4185 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4188 Cursor := Cursor + 1;
4195 -- Break & BreakX (string pointer case)
4197 when PC_Break_VP | PC_BreakX_VP => declare
4198 U : constant VString := Node.VP.all;
4199 S : Big_String_Access;
4203 Get_String (U, S, L);
4205 while Cursor < Length loop
4206 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4209 Cursor := Cursor + 1;
4216 -- BreakX_X (BreakX extension). See section on "Compound Pattern
4217 -- Structures". This node is the alternative that is stacked to
4218 -- skip past the break character and extend the break.
4221 Cursor := Cursor + 1;
4227 if Stack_Base = Stack_Init then
4230 -- End of recursive inner match. See separate section on
4231 -- handing of recursive pattern matches for details.
4234 Node := Stack (Stack_Base - 1).Node;
4244 -- Fence (built in pattern)
4247 Push (CP_Cancel'Access);
4250 -- Fence function node X. This is the node that gets control
4251 -- after a successful match of the fenced pattern.
4254 Stack_Ptr := Stack_Ptr + 1;
4255 Stack (Stack_Ptr).Cursor := Stack_Base;
4256 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
4257 Stack_Base := Stack (Stack_Base).Cursor;
4260 -- Fence function node Y. This is the node that gets control on
4261 -- a failure that occurs after the fenced pattern has matched.
4263 -- Note: the Cursor at this stage is actually the inner stack
4264 -- base value. We don't reset this, but we do use it to strip
4265 -- off all the entries made by the fenced pattern.
4268 Stack_Ptr := Cursor - 2;
4271 -- Len (integer case)
4274 if Cursor + Node.Nat > Length then
4277 Cursor := Cursor + Node.Nat;
4281 -- Len (Integer function case)
4283 when PC_Len_NF => declare
4284 N : constant Natural := Node.NF.all;
4286 if Cursor + N > Length then
4289 Cursor := Cursor + N;
4294 -- Len (integer pointer case)
4297 if Cursor + Node.NP.all > Length then
4300 Cursor := Cursor + Node.NP.all;
4304 -- NotAny (one character case)
4306 when PC_NotAny_CH =>
4308 and then Subject (Cursor + 1) /= Node.Char
4310 Cursor := Cursor + 1;
4316 -- NotAny (character set case)
4318 when PC_NotAny_CS =>
4320 and then not Is_In (Subject (Cursor + 1), Node.CS)
4322 Cursor := Cursor + 1;
4328 -- NotAny (string function case)
4330 when PC_NotAny_VF => declare
4331 U : constant VString := Node.VF.all;
4332 S : Big_String_Access;
4336 Get_String (U, S, L);
4340 not Is_In (Subject (Cursor + 1), S (1 .. L))
4342 Cursor := Cursor + 1;
4349 -- NotAny (string pointer case)
4351 when PC_NotAny_VP => declare
4352 U : constant VString := Node.VP.all;
4353 S : Big_String_Access;
4357 Get_String (U, S, L);
4361 not Is_In (Subject (Cursor + 1), S (1 .. L))
4363 Cursor := Cursor + 1;
4370 -- NSpan (one character case)
4373 while Cursor < Length
4374 and then Subject (Cursor + 1) = Node.Char
4376 Cursor := Cursor + 1;
4381 -- NSpan (character set case)
4384 while Cursor < Length
4385 and then Is_In (Subject (Cursor + 1), Node.CS)
4387 Cursor := Cursor + 1;
4392 -- NSpan (string function case)
4394 when PC_NSpan_VF => declare
4395 U : constant VString := Node.VF.all;
4396 S : Big_String_Access;
4400 Get_String (U, S, L);
4402 while Cursor < Length
4403 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4405 Cursor := Cursor + 1;
4411 -- NSpan (string pointer case)
4413 when PC_NSpan_VP => declare
4414 U : constant VString := Node.VP.all;
4415 S : Big_String_Access;
4419 Get_String (U, S, L);
4421 while Cursor < Length
4422 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4424 Cursor := Cursor + 1;
4435 -- Pos (integer case)
4438 if Cursor = Node.Nat then
4444 -- Pos (Integer function case)
4446 when PC_Pos_NF => declare
4447 N : constant Natural := Node.NF.all;
4456 -- Pos (integer pointer case)
4459 if Cursor = Node.NP.all then
4465 -- Predicate function
4467 when PC_Pred_Func =>
4474 -- Region Enter. Initiate new pattern history stack region
4477 Stack (Stack_Ptr + 1).Cursor := Cursor;
4481 -- Region Remove node. This is the node stacked by an R_Enter.
4482 -- It removes the special format stack entry right underneath, and
4483 -- then restores the outer level stack base and signals failure.
4485 -- Note: the cursor value at this stage is actually the (negative)
4486 -- stack base value for the outer level.
4489 Stack_Base := Cursor;
4490 Stack_Ptr := Stack_Ptr - 1;
4493 -- Region restore node. This is the node stacked at the end of an
4494 -- inner level match. Its function is to restore the inner level
4495 -- region, so that alternatives in this region can be sought.
4497 -- Note: the Cursor at this stage is actually the negative of the
4498 -- inner stack base value, which we use to restore the inner region.
4500 when PC_R_Restore =>
4501 Stack_Base := Cursor;
4510 -- Initiate recursive match (pattern pointer case)
4513 Stack (Stack_Ptr + 1).Node := Node.Pthen;
4516 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
4517 raise Pattern_Stack_Overflow;
4519 Node := Node.PP.all.P;
4523 -- RPos (integer case)
4526 if Cursor = (Length - Node.Nat) then
4532 -- RPos (integer function case)
4534 when PC_RPos_NF => declare
4535 N : constant Natural := Node.NF.all;
4537 if Length - Cursor = N then
4544 -- RPos (integer pointer case)
4547 if Cursor = (Length - Node.NP.all) then
4553 -- RTab (integer case)
4556 if Cursor <= (Length - Node.Nat) then
4557 Cursor := Length - Node.Nat;
4563 -- RTab (integer function case)
4565 when PC_RTab_NF => declare
4566 N : constant Natural := Node.NF.all;
4568 if Length - Cursor >= N then
4569 Cursor := Length - N;
4576 -- RTab (integer pointer case)
4579 if Cursor <= (Length - Node.NP.all) then
4580 Cursor := Length - Node.NP.all;
4586 -- Cursor assignment
4589 Node.Var.all := Cursor;
4592 -- Span (one character case)
4594 when PC_Span_CH => declare
4600 and then Subject (P + 1) = Node.Char
4613 -- Span (character set case)
4615 when PC_Span_CS => declare
4621 and then Is_In (Subject (P + 1), Node.CS)
4634 -- Span (string function case)
4636 when PC_Span_VF => declare
4637 U : constant VString := Node.VF.all;
4638 S : Big_String_Access;
4643 Get_String (U, S, L);
4647 and then Is_In (Subject (P + 1), S (1 .. L))
4660 -- Span (string pointer case)
4662 when PC_Span_VP => declare
4663 U : constant VString := Node.VP.all;
4664 S : Big_String_Access;
4669 Get_String (U, S, L);
4673 and then Is_In (Subject (P + 1), S (1 .. L))
4686 -- String (two character case)
4689 if (Length - Cursor) >= 2
4690 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
4692 Cursor := Cursor + 2;
4698 -- String (three character case)
4701 if (Length - Cursor) >= 3
4702 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
4704 Cursor := Cursor + 3;
4710 -- String (four character case)
4713 if (Length - Cursor) >= 4
4714 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
4716 Cursor := Cursor + 4;
4722 -- String (five character case)
4725 if (Length - Cursor) >= 5
4726 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
4728 Cursor := Cursor + 5;
4734 -- String (six character case)
4737 if (Length - Cursor) >= 6
4738 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
4740 Cursor := Cursor + 6;
4746 -- String (case of more than six characters)
4748 when PC_String => declare
4749 Len : constant Natural := Node.Str'Length;
4751 if (Length - Cursor) >= Len
4752 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
4754 Cursor := Cursor + Len;
4761 -- String (function case)
4763 when PC_String_VF => declare
4764 U : constant VString := Node.VF.all;
4765 S : Big_String_Access;
4769 Get_String (U, S, L);
4771 if (Length - Cursor) >= L
4772 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4774 Cursor := Cursor + L;
4781 -- String (pointer case)
4783 when PC_String_VP => declare
4784 U : constant VString := Node.VP.all;
4785 S : Big_String_Access;
4789 Get_String (U, S, L);
4791 if (Length - Cursor) >= L
4792 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4794 Cursor := Cursor + L;
4807 -- Tab (integer case)
4810 if Cursor <= Node.Nat then
4817 -- Tab (integer function case)
4819 when PC_Tab_NF => declare
4820 N : constant Natural := Node.NF.all;
4830 -- Tab (integer pointer case)
4833 if Cursor <= Node.NP.all then
4834 Cursor := Node.NP.all;
4840 -- Unanchored movement
4842 when PC_Unanchored =>
4844 -- All done if we tried every position
4846 if Cursor > Length then
4849 -- Otherwise extend the anchor point, and restack ourself
4852 Cursor := Cursor + 1;
4857 -- Write immediate. This node performs the actual write
4859 when PC_Write_Imm =>
4862 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4867 -- We are NOT allowed to fall though this case statement, since every
4868 -- match routine must end by executing a goto to the appropriate point
4869 -- in the finite state machine model.
4871 pragma Warnings (Off);
4873 pragma Warnings (On);
4880 -- Maintenance note: There is a LOT of code duplication between XMatch
4881 -- and XMatchD. This is quite intentional, the point is to avoid any
4882 -- unnecessary debugging overhead in the XMatch case, but this does mean
4883 -- that any changes to XMatchD must be mirrored in XMatch. In case of
4884 -- any major changes, the proper approach is to delete XMatch, make the
4885 -- changes to XMatchD, and then make a copy of XMatchD, removing all
4886 -- calls to Dout, and all Put and Put_Line operations. This copy becomes
4893 Start : out Natural;
4897 -- Pointer to current pattern node. Initialized from Pat_P, and then
4898 -- updated as the match proceeds through its constituent elements.
4900 Length : constant Natural := Subject'Length;
4901 -- Length of string (= Subject'Last, since Subject'First is always 1)
4903 Cursor : Integer := 0;
4904 -- If the value is non-negative, then this value is the index showing
4905 -- the current position of the match in the subject string. The next
4906 -- character to be matched is at Subject (Cursor + 1). Note that since
4907 -- our view of the subject string in XMatch always has a lower bound
4908 -- of one, regardless of original bounds, that this definition exactly
4909 -- corresponds to the cursor value as referenced by functions like Pos.
4911 -- If the value is negative, then this is a saved stack pointer,
4912 -- typically a base pointer of an inner or outer region. Cursor
4913 -- temporarily holds such a value when it is popped from the stack
4914 -- by Fail. In all cases, Cursor is reset to a proper non-negative
4915 -- cursor value before the match proceeds (e.g. by propagating the
4916 -- failure and popping a "real" cursor value from the stack.
4918 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
4919 -- Dummy pattern element used in the unanchored case
4921 Region_Level : Natural := 0;
4922 -- Keeps track of recursive region level. This is used only for
4923 -- debugging, it is the number of saved history stack base values.
4926 -- The pattern matching failure stack for this call to Match
4928 Stack_Ptr : Stack_Range;
4929 -- Current stack pointer. This points to the top element of the stack
4930 -- that is currently in use. At the outer level this is the special
4931 -- entry placed on the stack according to the anchor mode.
4933 Stack_Init : constant Stack_Range := Stack'First + 1;
4934 -- This is the initial value of the Stack_Ptr and Stack_Base. The
4935 -- initial (Stack'First) element of the stack is not used so that
4936 -- when we pop the last element off, Stack_Ptr is still in range.
4938 Stack_Base : Stack_Range;
4939 -- This value is the stack base value, i.e. the stack pointer for the
4940 -- first history stack entry in the current stack region. See separate
4941 -- section on handling of recursive pattern matches.
4943 Assign_OnM : Boolean := False;
4944 -- Set True if assign-on-match or write-on-match operations may be
4945 -- present in the history stack, which must then be scanned on a
4946 -- successful match.
4948 procedure Dout (Str : String);
4949 -- Output string to standard error with bars indicating region level
4951 procedure Dout (Str : String; A : Character);
4952 -- Calls Dout with the string S ('A
')
4954 procedure Dout (Str : String; A : Character_Set);
4955 -- Calls Dout with the string S ("A")
4957 procedure Dout (Str : String; A : Natural);
4958 -- Calls Dout with the string S (A)
4960 procedure Dout (Str : String; A : String);
4961 -- Calls Dout with the string S ("A")
4963 function Img (P : PE_Ptr) return String;
4964 -- Returns a string of the form #nnn where nnn is P.Index
4966 procedure Pop_Region;
4967 pragma Inline (Pop_Region);
4968 -- Used at the end of processing of an inner region. If the inner
4969 -- region left no stack entries, then all trace of it is removed.
4970 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
4971 -- handling of alternatives in the inner region.
4973 procedure Push (Node : PE_Ptr);
4974 pragma Inline (Push);
4975 -- Make entry in pattern matching stack with current cursor value
4977 procedure Push_Region;
4978 pragma Inline (Push_Region);
4979 -- This procedure makes a new region on the history stack. The
4980 -- caller first establishes the special entry on the stack, but
4981 -- does not push the stack pointer. Then this call stacks a
4982 -- PC_Remove_Region node, on top of this entry, using the cursor
4983 -- field of the PC_Remove_Region entry to save the outer level
4984 -- stack base value, and resets the stack base to point to this
4985 -- PC_Remove_Region node.
4991 procedure Dout (Str : String) is
4993 for J in 1 .. Region_Level loop
5000 procedure Dout (Str : String; A : Character) is
5002 Dout (Str & " ('" & A & "')");
5005 procedure Dout (Str : String; A : Character_Set) is
5007 Dout (Str & " (" & Image (To_Sequence (A)) & ')');
5010 procedure Dout (Str : String; A : Natural) is
5012 Dout (Str & " (" & A & ')');
5015 procedure Dout (Str : String; A : String) is
5017 Dout (Str & " (" & Image (A) & ')');
5024 function Img (P : PE_Ptr) return String is
5026 return "#" & Integer (P.Index) & " ";
5033 procedure Pop_Region is
5035 Region_Level := Region_Level - 1;
5037 -- If nothing was pushed in the inner region, we can just get
5038 -- rid of it entirely, leaving no traces that it was ever there
5040 if Stack_Ptr = Stack_Base then
5041 Stack_Ptr := Stack_Base - 2;
5042 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
5044 -- If stuff was pushed in the inner region, then we have to
5045 -- push a PC_R_Restore node so that we properly handle possible
5046 -- rematches within the region.
5049 Stack_Ptr := Stack_Ptr + 1;
5050 Stack (Stack_Ptr).Cursor := Stack_Base;
5051 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
5052 Stack_Base := Stack (Stack_Base).Cursor;
5060 procedure Push (Node : PE_Ptr) is
5062 Stack_Ptr := Stack_Ptr + 1;
5063 Stack (Stack_Ptr).Cursor := Cursor;
5064 Stack (Stack_Ptr).Node := Node;
5071 procedure Push_Region is
5073 Region_Level := Region_Level + 1;
5074 Stack_Ptr := Stack_Ptr + 2;
5075 Stack (Stack_Ptr).Cursor := Stack_Base;
5076 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
5077 Stack_Base := Stack_Ptr;
5080 -- Start of processing for XMatchD
5084 Put_Line ("Initiating pattern match, subject = " & Image (Subject));
5085 Put ("--------------------------------------");
5087 for J in 1 .. Length loop
5092 Put_Line ("subject length = " & Length);
5094 if Pat_P = null then
5095 Uninitialized_Pattern;
5098 -- Check we have enough stack for this pattern. This check deals with
5099 -- every possibility except a match of a recursive pattern, where we
5100 -- make a check at each recursion level.
5102 if Pat_S >= Stack_Size - 1 then
5103 raise Pattern_Stack_Overflow;
5106 -- In anchored mode, the bottom entry on the stack is an abort entry
5108 if Anchored_Mode then
5109 Stack (Stack_Init).Node := CP_Cancel'Access;
5110 Stack (Stack_Init).Cursor := 0;
5112 -- In unanchored more, the bottom entry on the stack references
5113 -- the special pattern element PE_Unanchored, whose Pthen field
5114 -- points to the initial pattern element. The cursor value in this
5115 -- entry is the number of anchor moves so far.
5118 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
5119 Stack (Stack_Init).Cursor := 0;
5122 Stack_Ptr := Stack_Init;
5123 Stack_Base := Stack_Ptr;
5128 -----------------------------------------
5129 -- Main Pattern Matching State Control --
5130 -----------------------------------------
5132 -- This is a state machine which uses gotos to change state. The
5133 -- initial state is Match, to initiate the matching of the first
5134 -- element, so the goto Match above starts the match. In the
5135 -- following descriptions, we indicate the global values that
5136 -- are relevant for the state transition.
5138 -- Come here if entire match fails
5141 Dout ("match fails");
5147 -- Come here if entire match succeeds
5149 -- Cursor current position in subject string
5152 Dout ("match succeeds");
5153 Start := Stack (Stack_Init).Cursor + 1;
5155 Dout ("first matched character index = " & Start);
5156 Dout ("last matched character index = " & Stop);
5157 Dout ("matched substring = " & Image (Subject (Start .. Stop)));
5159 -- Scan history stack for deferred assignments or writes
5162 for S in Stack'First .. Stack_Ptr loop
5163 if Stack (S).Node = CP_Assign'Access then
5165 Inner_Base : constant Stack_Range :=
5166 Stack (S + 1).Cursor;
5167 Special_Entry : constant Stack_Range :=
5169 Node_OnM : constant PE_Ptr :=
5170 Stack (Special_Entry).Node;
5171 Start : constant Natural :=
5172 Stack (Special_Entry).Cursor + 1;
5173 Stop : constant Natural := Stack (S).Cursor;
5176 if Node_OnM.Pcode = PC_Assign_OnM then
5177 Set_Unbounded_String
5178 (Node_OnM.VP.all, Subject (Start .. Stop));
5180 (Img (Stack (S).Node) &
5181 "deferred assignment of " &
5182 Image (Subject (Start .. Stop)));
5184 elsif Node_OnM.Pcode = PC_Write_OnM then
5185 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
5187 (Img (Stack (S).Node) &
5188 "deferred write of " &
5189 Image (Subject (Start .. Stop)));
5202 -- Come here if attempt to match current element fails
5204 -- Stack_Base current stack base
5205 -- Stack_Ptr current stack pointer
5208 Cursor := Stack (Stack_Ptr).Cursor;
5209 Node := Stack (Stack_Ptr).Node;
5210 Stack_Ptr := Stack_Ptr - 1;
5213 Dout ("failure, cursor reset to " & Cursor);
5218 -- Come here if attempt to match current element succeeds
5220 -- Cursor current position in subject string
5221 -- Node pointer to node successfully matched
5222 -- Stack_Base current stack base
5223 -- Stack_Ptr current stack pointer
5226 Dout ("success, cursor = " & Cursor);
5229 -- Come here to match the next pattern element
5231 -- Cursor current position in subject string
5232 -- Node pointer to node to be matched
5233 -- Stack_Base current stack base
5234 -- Stack_Ptr current stack pointer
5238 --------------------------------------------------
5239 -- Main Pattern Match Element Matching Routines --
5240 --------------------------------------------------
5242 -- Here is the case statement that processes the current node. The
5243 -- processing for each element does one of five things:
5245 -- goto Succeed to move to the successor
5246 -- goto Match_Succeed if the entire match succeeds
5247 -- goto Match_Fail if the entire match fails
5248 -- goto Fail to signal failure of current match
5250 -- Processing is NOT allowed to fall through
5257 Dout (Img (Node) & "matching Cancel");
5263 Dout (Img (Node) & "setting up alternative " & Img (Node.Alt));
5268 -- Any (one character case)
5271 Dout (Img (Node) & "matching Any", Node.Char);
5274 and then Subject (Cursor + 1) = Node.Char
5276 Cursor := Cursor + 1;
5282 -- Any (character set case)
5285 Dout (Img (Node) & "matching Any", Node.CS);
5288 and then Is_In (Subject (Cursor + 1), Node.CS)
5290 Cursor := Cursor + 1;
5296 -- Any (string function case)
5298 when PC_Any_VF => declare
5299 U : constant VString := Node.VF.all;
5300 S : Big_String_Access;
5304 Get_String (U, S, L);
5306 Dout (Img (Node) & "matching Any", S (1 .. L));
5309 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5311 Cursor := Cursor + 1;
5318 -- Any (string pointer case)
5320 when PC_Any_VP => declare
5321 U : constant VString := Node.VP.all;
5322 S : Big_String_Access;
5326 Get_String (U, S, L);
5327 Dout (Img (Node) & "matching Any", S (1 .. L));
5330 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5332 Cursor := Cursor + 1;
5339 -- Arb (initial match)
5342 Dout (Img (Node) & "matching Arb");
5350 Dout (Img (Node) & "extending Arb");
5352 if Cursor < Length then
5353 Cursor := Cursor + 1;
5360 -- Arbno_S/X (simple and complex Arbno initialize). This is the node
5361 -- that initiates the match of a simple or complex Arbno structure.
5363 when PC_Arbno_S | PC_Arbno_X =>
5365 "setting up Arbno alternative " & Img (Node.Alt));
5370 -- Arbno_Y (Arbno rematch). This is the node that is executed
5371 -- following successful matching of one instance of a complex
5374 when PC_Arbno_Y => declare
5375 Null_Match : constant Boolean :=
5376 Cursor = Stack (Stack_Base - 1).Cursor;
5379 Dout (Img (Node) & "extending Arbno");
5382 -- If arbno extension matched null, then immediately fail
5385 Dout ("Arbno extension matched null, so fails");
5389 -- Here we must do a stack check to make sure enough stack
5390 -- is left. This check will happen once for each instance of
5391 -- the Arbno pattern that is matched. The Nat field of a
5392 -- PC_Arbno pattern contains the maximum stack entries needed
5393 -- for the Arbno with one instance and the successor pattern
5395 if Stack_Ptr + Node.Nat >= Stack'Last then
5396 raise Pattern_Stack_Overflow;
5402 -- Assign. If this node is executed, it means the assign-on-match
5403 -- or write-on-match operation will not happen after all, so we
5404 -- is propagate the failure, removing the PC_Assign node.
5407 Dout (Img (Node) & "deferred assign/write cancelled");
5410 -- Assign immediate. This node performs the actual assignment
5412 when PC_Assign_Imm =>
5414 (Img (Node) & "executing immediate assignment of " &
5415 Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)));
5416 Set_Unbounded_String
5418 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
5422 -- Assign on match. This node sets up for the eventual assignment
5424 when PC_Assign_OnM =>
5425 Dout (Img (Node) & "registering deferred assignment");
5426 Stack (Stack_Base - 1).Node := Node;
5427 Push (CP_Assign'Access);
5435 Dout (Img (Node) & "matching or extending Bal");
5436 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
5439 elsif Subject (Cursor + 1) = '(' then
5441 Paren_Count : Natural := 1;
5445 Cursor := Cursor + 1;
5447 if Cursor >= Length then
5450 elsif Subject (Cursor + 1) = '(' then
5451 Paren_Count := Paren_Count + 1;
5453 elsif Subject (Cursor + 1) = ')' then
5454 Paren_Count := Paren_Count - 1;
5455 exit when Paren_Count = 0;
5461 Cursor := Cursor + 1;
5465 -- Break (one character case)
5468 Dout (Img (Node) & "matching Break", Node.Char);
5470 while Cursor < Length loop
5471 if Subject (Cursor + 1) = Node.Char then
5474 Cursor := Cursor + 1;
5480 -- Break (character set case)
5483 Dout (Img (Node) & "matching Break", Node.CS);
5485 while Cursor < Length loop
5486 if Is_In (Subject (Cursor + 1), Node.CS) then
5489 Cursor := Cursor + 1;
5495 -- Break (string function case)
5497 when PC_Break_VF => declare
5498 U : constant VString := Node.VF.all;
5499 S : Big_String_Access;
5503 Get_String (U, S, L);
5504 Dout (Img (Node) & "matching Break", S (1 .. L));
5506 while Cursor < Length loop
5507 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5510 Cursor := Cursor + 1;
5517 -- Break (string pointer case)
5519 when PC_Break_VP => declare
5520 U : constant VString := Node.VP.all;
5521 S : Big_String_Access;
5525 Get_String (U, S, L);
5526 Dout (Img (Node) & "matching Break", S (1 .. L));
5528 while Cursor < Length loop
5529 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5532 Cursor := Cursor + 1;
5539 -- BreakX (one character case)
5541 when PC_BreakX_CH =>
5542 Dout (Img (Node) & "matching BreakX", Node.Char);
5544 while Cursor < Length loop
5545 if Subject (Cursor + 1) = Node.Char then
5548 Cursor := Cursor + 1;
5554 -- BreakX (character set case)
5556 when PC_BreakX_CS =>
5557 Dout (Img (Node) & "matching BreakX", Node.CS);
5559 while Cursor < Length loop
5560 if Is_In (Subject (Cursor + 1), Node.CS) then
5563 Cursor := Cursor + 1;
5569 -- BreakX (string function case)
5571 when PC_BreakX_VF => declare
5572 U : constant VString := Node.VF.all;
5573 S : Big_String_Access;
5577 Get_String (U, S, L);
5578 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5580 while Cursor < Length loop
5581 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5584 Cursor := Cursor + 1;
5591 -- BreakX (string pointer case)
5593 when PC_BreakX_VP => declare
5594 U : constant VString := Node.VP.all;
5595 S : Big_String_Access;
5599 Get_String (U, S, L);
5600 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5602 while Cursor < Length loop
5603 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5606 Cursor := Cursor + 1;
5613 -- BreakX_X (BreakX extension). See section on "Compound Pattern
5614 -- Structures". This node is the alternative that is stacked
5615 -- to skip past the break character and extend the break.
5618 Dout (Img (Node) & "extending BreakX");
5619 Cursor := Cursor + 1;
5622 -- Character (one character string)
5625 Dout (Img (Node) & "matching '" & Node.Char & ''');
5628 and then Subject (Cursor + 1) = Node.Char
5630 Cursor := Cursor + 1;
5639 if Stack_Base = Stack_Init then
5640 Dout ("end of pattern
");
5643 -- End of recursive inner match. See separate section on
5644 -- handing of recursive pattern matches for details.
5647 Dout ("terminating recursive match
");
5648 Node := Stack (Stack_Base - 1).Node;
5656 Dout (Img (Node) & "matching Fail
");
5659 -- Fence (built in pattern)
5662 Dout (Img (Node) & "matching Fence
");
5663 Push (CP_Cancel'Access);
5666 -- Fence function node X. This is the node that gets control
5667 -- after a successful match of the fenced pattern.
5670 Dout (Img (Node) & "matching Fence
function");
5671 Stack_Ptr := Stack_Ptr + 1;
5672 Stack (Stack_Ptr).Cursor := Stack_Base;
5673 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
5674 Stack_Base := Stack (Stack_Base).Cursor;
5675 Region_Level := Region_Level - 1;
5678 -- Fence function node Y. This is the node that gets control on
5679 -- a failure that occurs after the fenced pattern has matched.
5681 -- Note: the Cursor at this stage is actually the inner stack
5682 -- base value. We don't reset this, but we do use it to strip
5683 -- off all the entries made by the fenced pattern.
5686 Dout (Img (Node) & "pattern matched by Fence caused failure
");
5687 Stack_Ptr := Cursor - 2;
5690 -- Len (integer case)
5693 Dout (Img (Node) & "matching Len
", Node.Nat);
5695 if Cursor + Node.Nat > Length then
5698 Cursor := Cursor + Node.Nat;
5702 -- Len (Integer function case)
5704 when PC_Len_NF => declare
5705 N : constant Natural := Node.NF.all;
5708 Dout (Img (Node) & "matching Len
", N);
5710 if Cursor + N > Length then
5713 Cursor := Cursor + N;
5718 -- Len (integer pointer case)
5721 Dout (Img (Node) & "matching Len
", Node.NP.all);
5723 if Cursor + Node.NP.all > Length then
5726 Cursor := Cursor + Node.NP.all;
5730 -- NotAny (one character case)
5732 when PC_NotAny_CH =>
5733 Dout (Img (Node) & "matching NotAny
", Node.Char);
5736 and then Subject (Cursor + 1) /= Node.Char
5738 Cursor := Cursor + 1;
5744 -- NotAny (character set case)
5746 when PC_NotAny_CS =>
5747 Dout (Img (Node) & "matching NotAny
", Node.CS);
5750 and then not Is_In (Subject (Cursor + 1), Node.CS)
5752 Cursor := Cursor + 1;
5758 -- NotAny (string function case)
5760 when PC_NotAny_VF => declare
5761 U : constant VString := Node.VF.all;
5762 S : Big_String_Access;
5766 Get_String (U, S, L);
5767 Dout (Img (Node) & "matching NotAny
", S (1 .. L));
5771 not Is_In (Subject (Cursor + 1), S (1 .. L))
5773 Cursor := Cursor + 1;
5780 -- NotAny (string pointer case)
5782 when PC_NotAny_VP => declare
5783 U : constant VString := Node.VP.all;
5784 S : Big_String_Access;
5788 Get_String (U, S, L);
5789 Dout (Img (Node) & "matching NotAny
", S (1 .. L));
5793 not Is_In (Subject (Cursor + 1), S (1 .. L))
5795 Cursor := Cursor + 1;
5802 -- NSpan (one character case)
5805 Dout (Img (Node) & "matching NSpan
", Node.Char);
5807 while Cursor < Length
5808 and then Subject (Cursor + 1) = Node.Char
5810 Cursor := Cursor + 1;
5815 -- NSpan (character set case)
5818 Dout (Img (Node) & "matching NSpan
", Node.CS);
5820 while Cursor < Length
5821 and then Is_In (Subject (Cursor + 1), Node.CS)
5823 Cursor := Cursor + 1;
5828 -- NSpan (string function case)
5830 when PC_NSpan_VF => declare
5831 U : constant VString := Node.VF.all;
5832 S : Big_String_Access;
5836 Get_String (U, S, L);
5837 Dout (Img (Node) & "matching NSpan
", S (1 .. L));
5839 while Cursor < Length
5840 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5842 Cursor := Cursor + 1;
5848 -- NSpan (string pointer case)
5850 when PC_NSpan_VP => declare
5851 U : constant VString := Node.VP.all;
5852 S : Big_String_Access;
5856 Get_String (U, S, L);
5857 Dout (Img (Node) & "matching NSpan
", S (1 .. L));
5859 while Cursor < Length
5860 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5862 Cursor := Cursor + 1;
5869 Dout (Img (Node) & "matching
null");
5872 -- Pos (integer case)
5875 Dout (Img (Node) & "matching Pos
", Node.Nat);
5877 if Cursor = Node.Nat then
5883 -- Pos (Integer function case)
5885 when PC_Pos_NF => declare
5886 N : constant Natural := Node.NF.all;
5889 Dout (Img (Node) & "matching Pos
", N);
5898 -- Pos (integer pointer case)
5901 Dout (Img (Node) & "matching Pos
", Node.NP.all);
5903 if Cursor = Node.NP.all then
5909 -- Predicate function
5911 when PC_Pred_Func =>
5912 Dout (Img (Node) & "matching predicate
function");
5920 -- Region Enter. Initiate new pattern history stack region
5923 Dout (Img (Node) & "starting match
of nested pattern
");
5924 Stack (Stack_Ptr + 1).Cursor := Cursor;
5928 -- Region Remove node. This is the node stacked by an R_Enter.
5929 -- It removes the special format stack entry right underneath, and
5930 -- then restores the outer level stack base and signals failure.
5932 -- Note: the cursor value at this stage is actually the (negative)
5933 -- stack base value for the outer level.
5936 Dout ("failure
, match
of nested pattern terminated
");
5937 Stack_Base := Cursor;
5938 Region_Level := Region_Level - 1;
5939 Stack_Ptr := Stack_Ptr - 1;
5942 -- Region restore node. This is the node stacked at the end of an
5943 -- inner level match. Its function is to restore the inner level
5944 -- region, so that alternatives in this region can be sought.
5946 -- Note: the Cursor at this stage is actually the negative of the
5947 -- inner stack base value, which we use to restore the inner region.
5949 when PC_R_Restore =>
5950 Dout ("failure
, search
for alternatives
in nested pattern
");
5951 Region_Level := Region_Level + 1;
5952 Stack_Base := Cursor;
5958 Dout (Img (Node) & "matching Rest
");
5962 -- Initiate recursive match (pattern pointer case)
5965 Stack (Stack_Ptr + 1).Node := Node.Pthen;
5967 Dout (Img (Node) & "initiating recursive match
");
5969 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
5970 raise Pattern_Stack_Overflow;
5972 Node := Node.PP.all.P;
5976 -- RPos (integer case)
5979 Dout (Img (Node) & "matching RPos
", Node.Nat);
5981 if Cursor = (Length - Node.Nat) then
5987 -- RPos (integer function case)
5989 when PC_RPos_NF => declare
5990 N : constant Natural := Node.NF.all;
5993 Dout (Img (Node) & "matching RPos
", N);
5995 if Length - Cursor = N then
6002 -- RPos (integer pointer case)
6005 Dout (Img (Node) & "matching RPos
", Node.NP.all);
6007 if Cursor = (Length - Node.NP.all) then
6013 -- RTab (integer case)
6016 Dout (Img (Node) & "matching RTab
", Node.Nat);
6018 if Cursor <= (Length - Node.Nat) then
6019 Cursor := Length - Node.Nat;
6025 -- RTab (integer function case)
6027 when PC_RTab_NF => declare
6028 N : constant Natural := Node.NF.all;
6031 Dout (Img (Node) & "matching RPos
", N);
6033 if Length - Cursor >= N then
6034 Cursor := Length - N;
6041 -- RTab (integer pointer case)
6044 Dout (Img (Node) & "matching RPos
", Node.NP.all);
6046 if Cursor <= (Length - Node.NP.all) then
6047 Cursor := Length - Node.NP.all;
6053 -- Cursor assignment
6056 Dout (Img (Node) & "matching Setcur
");
6057 Node.Var.all := Cursor;
6060 -- Span (one character case)
6062 when PC_Span_CH => declare
6063 P : Natural := Cursor;
6066 Dout (Img (Node) & "matching Span
", Node.Char);
6069 and then Subject (P + 1) = Node.Char
6082 -- Span (character set case)
6084 when PC_Span_CS => declare
6085 P : Natural := Cursor;
6088 Dout (Img (Node) & "matching Span
", Node.CS);
6091 and then Is_In (Subject (P + 1), Node.CS)
6104 -- Span (string function case)
6106 when PC_Span_VF => declare
6107 U : constant VString := Node.VF.all;
6108 S : Big_String_Access;
6113 Get_String (U, S, L);
6114 Dout (Img (Node) & "matching Span
", S (1 .. L));
6118 and then Is_In (Subject (P + 1), S (1 .. L))
6131 -- Span (string pointer case)
6133 when PC_Span_VP => declare
6134 U : constant VString := Node.VP.all;
6135 S : Big_String_Access;
6140 Get_String (U, S, L);
6141 Dout (Img (Node) & "matching Span
", S (1 .. L));
6145 and then Is_In (Subject (P + 1), S (1 .. L))
6158 -- String (two character case)
6161 Dout (Img (Node) & "matching
" & Image (Node.Str2));
6163 if (Length - Cursor) >= 2
6164 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
6166 Cursor := Cursor + 2;
6172 -- String (three character case)
6175 Dout (Img (Node) & "matching
" & Image (Node.Str3));
6177 if (Length - Cursor) >= 3
6178 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
6180 Cursor := Cursor + 3;
6186 -- String (four character case)
6189 Dout (Img (Node) & "matching
" & Image (Node.Str4));
6191 if (Length - Cursor) >= 4
6192 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
6194 Cursor := Cursor + 4;
6200 -- String (five character case)
6203 Dout (Img (Node) & "matching
" & Image (Node.Str5));
6205 if (Length - Cursor) >= 5
6206 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
6208 Cursor := Cursor + 5;
6214 -- String (six character case)
6217 Dout (Img (Node) & "matching
" & Image (Node.Str6));
6219 if (Length - Cursor) >= 6
6220 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
6222 Cursor := Cursor + 6;
6228 -- String (case of more than six characters)
6230 when PC_String => declare
6231 Len : constant Natural := Node.Str'Length;
6234 Dout (Img (Node) & "matching
" & Image (Node.Str.all));
6236 if (Length - Cursor) >= Len
6237 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
6239 Cursor := Cursor + Len;
6246 -- String (function case)
6248 when PC_String_VF => declare
6249 U : constant VString := Node.VF.all;
6250 S : Big_String_Access;
6254 Get_String (U, S, L);
6255 Dout (Img (Node) & "matching
" & Image (S (1 .. L)));
6257 if (Length - Cursor) >= L
6258 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6260 Cursor := Cursor + L;
6267 -- String (vstring pointer case)
6269 when PC_String_VP => declare
6270 U : constant VString := Node.VP.all;
6271 S : Big_String_Access;
6275 Get_String (U, S, L);
6276 Dout (Img (Node) & "matching
" & Image (S (1 .. L)));
6278 if (Length - Cursor) >= L
6279 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6281 Cursor := Cursor + L;
6291 Dout (Img (Node) & "matching Succeed
");
6295 -- Tab (integer case)
6298 Dout (Img (Node) & "matching Tab
", Node.Nat);
6300 if Cursor <= Node.Nat then
6307 -- Tab (integer function case)
6309 when PC_Tab_NF => declare
6310 N : constant Natural := Node.NF.all;
6313 Dout (Img (Node) & "matching Tab
", N);
6323 -- Tab (integer pointer case)
6326 Dout (Img (Node) & "matching Tab
", Node.NP.all);
6328 if Cursor <= Node.NP.all then
6329 Cursor := Node.NP.all;
6335 -- Unanchored movement
6337 when PC_Unanchored =>
6338 Dout ("attempting to move anchor point
");
6340 -- All done if we tried every position
6342 if Cursor > Length then
6345 -- Otherwise extend the anchor point, and restack ourself
6348 Cursor := Cursor + 1;
6353 -- Write immediate. This node performs the actual write
6355 when PC_Write_Imm =>
6356 Dout (Img (Node) & "executing immediate write
of " &
6357 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6361 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6365 -- Write on match. This node sets up for the eventual write
6367 when PC_Write_OnM =>
6368 Dout (Img (Node) & "registering deferred write
");
6369 Stack (Stack_Base - 1).Node := Node;
6370 Push (CP_Assign'Access);
6376 -- We are NOT allowed to fall though this case statement, since every
6377 -- match routine must end by executing a goto to the appropriate point
6378 -- in the finite state machine model.
6380 pragma Warnings (Off);
6382 pragma Warnings (On);
6385 end GNAT.Spitbol.Patterns;