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 --
10 -- Copyright (C) 1998-2002, Ada Core Technologies, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
32 ------------------------------------------------------------------------------
34 -- Note: the data structures and general approach used in this implementation
35 -- are derived from the original MINIMAL sources for SPITBOL. The code is not
36 -- a direct translation, but the approach is followed closely. In particular,
37 -- we use the one stack approach developed in the SPITBOL implementation.
39 with Ada
.Exceptions
; use Ada
.Exceptions
;
40 with Ada
.Strings
.Maps
; use Ada
.Strings
.Maps
;
41 with Ada
.Strings
.Unbounded
.Aux
; use Ada
.Strings
.Unbounded
.Aux
;
43 with GNAT
.Debug_Utilities
; use GNAT
.Debug_Utilities
;
45 with System
; use System
;
47 with Unchecked_Conversion
;
48 with Unchecked_Deallocation
;
50 package body GNAT
.Spitbol
.Patterns
is
52 ------------------------
53 -- Internal Debugging --
54 ------------------------
56 Internal_Debug
: constant Boolean := False;
57 -- Set this flag to True to activate some built-in debugging traceback
58 -- These are all lines output with PutD and Put_LineD.
61 pragma Inline
(New_LineD
);
62 -- Output new blank line with New_Line if Internal_Debug is True
64 procedure PutD
(Str
: String);
66 -- Output string with Put if Internal_Debug is True
68 procedure Put_LineD
(Str
: String);
69 pragma Inline
(Put_LineD
);
70 -- Output string with Put_Line if Internal_Debug is True
72 -----------------------------
73 -- Local Type Declarations --
74 -----------------------------
76 subtype String_Ptr
is Ada
.Strings
.Unbounded
.String_Access
;
77 subtype File_Ptr
is Ada
.Text_IO
.File_Access
;
79 function To_Address
is new Unchecked_Conversion
(PE_Ptr
, Address
);
80 -- Used only for debugging output purposes
82 subtype AFC
is Ada
.Finalization
.Controlled
;
84 N
: constant PE_Ptr
:= null;
85 -- Shorthand used to initialize Copy fields to null
87 type Natural_Ptr
is access all Natural;
88 type Pattern_Ptr
is access all Pattern
;
90 --------------------------------------------------
91 -- Description of Algorithm and Data Structures --
92 --------------------------------------------------
94 -- A pattern structure is represented as a linked graph of nodes
95 -- with the following structure:
97 -- +------------------------------------+
99 -- +------------------------------------+
101 -- +------------------------------------+
103 -- +------------------------------------+
105 -- +------------------------------------+
107 -- Pcode is a code value indicating the type of the patterm node. This
108 -- code is used both as the discriminant value for the record, and as
109 -- the case index in the main match routine that branches to the proper
110 -- match code for the given element.
112 -- Index is a serial index number. The use of these serial index
113 -- numbers is described in a separate section.
115 -- Pthen is a pointer to the successor node, i.e the node to be matched
116 -- if the attempt to match the node succeeds. If this is the last node
117 -- of the pattern to be matched, then Pthen points to a dummy node
118 -- of kind PC_EOP (end of pattern), which initiales pattern exit.
120 -- The parameter or parameters are present for certain node types,
121 -- and the type varies with the pattern code.
123 type Pattern_Code
is (
216 type IndexT
is range 0 .. +(2 **15 - 1);
218 type PE
(Pcode
: Pattern_Code
) is record
221 -- Serial index number of pattern element within pattern.
224 -- Successor element, to be matched after this one
244 PC_Unanchored
=> null;
249 PC_Arbno_X
=> Alt
: PE_Ptr
;
251 when PC_Rpat
=> PP
: Pattern_Ptr
;
253 when PC_Pred_Func
=> BF
: Boolean_Func
;
263 PC_String_VP
=> VP
: VString_Ptr
;
266 PC_Write_OnM
=> FP
: File_Ptr
;
268 when PC_String
=> Str
: String_Ptr
;
270 when PC_String_2
=> Str2
: String (1 .. 2);
272 when PC_String_3
=> Str3
: String (1 .. 3);
274 when PC_String_4
=> Str4
: String (1 .. 4);
276 when PC_String_5
=> Str5
: String (1 .. 5);
278 when PC_String_6
=> Str6
: String (1 .. 6);
280 when PC_Setcur
=> Var
: Natural_Ptr
;
288 PC_Span_CH
=> Char
: Character;
295 PC_Span_CS
=> CS
: Character_Set
;
302 PC_Tab_Nat
=> Nat
: Natural;
308 PC_Tab_NF
=> NF
: Natural_Func
;
314 PC_Tab_NP
=> NP
: Natural_Ptr
;
322 PC_String_VF
=> VF
: VString_Func
;
327 subtype PC_Has_Alt
is Pattern_Code
range PC_Alt
.. PC_Arbno_X
;
328 -- Range of pattern codes that has an Alt field. This is used in the
329 -- recursive traversals, since these links must be followed.
331 EOP_Element
: aliased constant PE
:= (PC_EOP
, 0, N
);
332 -- This is the end of pattern element, and is thus the representation of
333 -- a null pattern. It has a zero index element since it is never placed
334 -- inside a pattern. Furthermore it does not need a successor, since it
335 -- marks the end of the pattern, so that no more successors are needed.
337 EOP
: constant PE_Ptr
:= EOP_Element
'Unrestricted_Access;
338 -- This is the end of pattern pointer, that is used in the Pthen pointer
339 -- of other nodes to signal end of pattern.
341 -- The following array is used to determine if a pattern used as an
342 -- argument for Arbno is eligible for treatment using the simple Arbno
343 -- structure (i.e. it is a pattern that is guaranteed to match at least
344 -- one character on success, and not to make any entries on the stack.
346 OK_For_Simple_Arbno
:
347 array (Pattern_Code
) of Boolean := (
371 -------------------------------
372 -- The Pattern History Stack --
373 -------------------------------
375 -- The pattern history stack is used for controlling backtracking when
376 -- a match fails. The idea is to stack entries that give a cursor value
377 -- to be restored, and a node to be reestablished as the current node to
378 -- attempt an appropriate rematch operation. The processing for a pattern
379 -- element that has rematch alternatives pushes an appropriate entry or
380 -- entry on to the stack, and the proceeds. If a match fails at any point,
381 -- the top element of the stack is popped off, resetting the cursor and
382 -- the match continues by accessing the node stored with this entry.
384 type Stack_Entry
is record
387 -- Saved cursor value that is restored when this entry is popped
388 -- from the stack if a match attempt fails. Occasionally, this
389 -- field is used to store a history stack pointer instead of a
390 -- cursor. Such cases are noted in the documentation and the value
391 -- stored is negative since stack pointer values are always negative.
394 -- This pattern element reference is reestablished as the current
395 -- Node to be matched (which will attempt an appropriate rematch).
399 subtype Stack_Range
is Integer range -Stack_Size
.. -1;
401 type Stack_Type
is array (Stack_Range
) of Stack_Entry
;
402 -- The type used for a history stack. The actual instance of the stack
403 -- is declared as a local variable in the Match routine, to properly
404 -- handle recursive calls to Match. All stack pointer values are negative
405 -- to distinguish them from normal cursor values.
407 -- Note: the pattern matching stack is used only to handle backtracking.
408 -- If no backtracking occurs, its entries are never accessed, and never
409 -- popped off, and in particular it is normal for a successful match
410 -- to terminate with entries on the stack that are simply discarded.
412 -- Note: in subsequent diagrams of the stack, we always place element
413 -- zero (the deepest element) at the top of the page, then build the
414 -- stack down on the page with the most recent (top of stack) element
415 -- being the bottom-most entry on the page.
417 -- Stack checking is handled by labeling every pattern with the maximum
418 -- number of stack entries that are required, so a single check at the
419 -- start of matching the pattern suffices. There are two exceptions.
421 -- First, the count does not include entries for recursive pattern
422 -- references. Such recursions must therefore perform a specific
423 -- stack check with respect to the number of stack entries required
424 -- by the recursive pattern that is accessed and the amount of stack
425 -- that remains unused.
427 -- Second, the count includes only one iteration of an Arbno pattern,
428 -- so a specific check must be made on subsequent iterations that there
429 -- is still enough stack space left. The Arbno node has a field that
430 -- records the number of stack entries required by its argument for
433 ---------------------------------------------------
434 -- Use of Serial Index Field in Pattern Elements --
435 ---------------------------------------------------
437 -- The serial index numbers for the pattern elements are assigned as
438 -- a pattern is consructed from its constituent elements. Note that there
439 -- is never any sharing of pattern elements between patterns (copies are
440 -- always made), so the serial index numbers are unique to a particular
441 -- pattern as referenced from the P field of a value of type Pattern.
443 -- The index numbers meet three separate invariants, which are used for
444 -- various purposes as described in this section.
446 -- First, the numbers uniquely identify the pattern elements within a
447 -- pattern. If Num is the number of elements in a given pattern, then
448 -- the serial index numbers for the elements of this pattern will range
449 -- from 1 .. Num, so that each element has a separate value.
451 -- The purpose of this assignment is to provide a convenient auxiliary
452 -- data structure mechanism during operations which must traverse a
453 -- pattern (e.g. copy and finalization processing). Once constructed
454 -- patterns are strictly read only. This is necessary to allow sharing
455 -- of patterns between tasks. This means that we cannot go marking the
456 -- pattern (e.g. with a visited bit). Instead we cosntuct a separate
457 -- vector that contains the necessary information indexed by the Index
458 -- values in the pattern elements. For this purpose the only requirement
459 -- is that they be uniquely assigned.
461 -- Second, the pattern element referenced directly, i.e. the leading
462 -- pattern element, is always the maximum numbered element and therefore
463 -- indicates the total number of elements in the pattern. More precisely,
464 -- the element referenced by the P field of a pattern value, or the
465 -- element returned by any of the internal pattern construction routines
466 -- in the body (that return a value of type PE_Ptr) always is this
469 -- The purpose of this requirement is to allow an immediate determination
470 -- of the number of pattern elements within a pattern. This is used to
471 -- properly size the vectors used to contain auxiliary information for
472 -- traversal as described above.
474 -- Third, as compound pattern structures are constructed, the way in which
475 -- constituent parts of the pattern are constructed is stylized. This is
476 -- an automatic consequence of the way that these compounjd structures
477 -- are constructed, and basically what we are doing is simply documenting
478 -- and specifying the natural result of the pattern construction. The
479 -- section describing compound pattern structures gives details of the
480 -- numbering of each compound pattern structure.
482 -- The purpose of specifying the stylized numbering structures for the
483 -- compound patterns is to help simplify the processing in the Image
484 -- function, since it eases the task of retrieving the original recursive
485 -- structure of the pattern from the flat graph structure of elements.
486 -- This use in the Image function is the only point at which the code
487 -- makes use of the stylized structures.
489 type Ref_Array
is array (IndexT
range <>) of PE_Ptr
;
490 -- This type is used to build an array whose N'th entry references the
491 -- element in a pattern whose Index value is N. See Build_Ref_Array.
493 procedure Build_Ref_Array
(E
: PE_Ptr
; RA
: out Ref_Array
);
494 -- Given a pattern element which is the leading element of a pattern
495 -- structure, and a Ref_Array with bounds 1 .. E.Index, fills in the
496 -- Ref_Array so that its N'th entry references the element of the
497 -- referenced pattern whose Index value is N.
499 -------------------------------
500 -- Recursive Pattern Matches --
501 -------------------------------
503 -- The pattern primitive (+P) where P is a Pattern_Ptr or Pattern_Func
504 -- causes a recursive pattern match. This cannot be handled by an actual
505 -- recursive call to the outer level Match routine, since this would not
506 -- allow for possible backtracking into the region matched by the inner
507 -- pattern. Indeed this is the classical clash between recursion and
508 -- backtracking, and a simple recursive stack structure does not suffice.
510 -- This section describes how this recursion and the possible associated
511 -- backtracking is handled. We still use a single stack, but we establish
512 -- the concept of nested regions on this stack, each of which has a stack
513 -- base value pointing to the deepest stack entry of the region. The base
514 -- value for the outer level is zero.
516 -- When a recursive match is established, two special stack entries are
517 -- made. The first entry is used to save the original node that starts
518 -- the recursive match. This is saved so that the successor field of
519 -- this node is accessible at the end of the match, but it is never
520 -- popped and executed.
522 -- The second entry corresponds to a standard new region action. A
523 -- PC_R_Remove node is stacked, whose cursor field is used to store
524 -- the outer stack base, and the stack base is reset to point to
525 -- this PC_R_Remove node. Then the recursive pattern is matched and
526 -- it can make history stack entries in the normal matter, so now
527 -- the stack looks like:
529 -- (stack entries made by outer level)
531 -- (Special entry, node is (+P) successor
532 -- cursor entry is not used)
534 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack base
535 -- saved base value for the enclosing region)
537 -- (stack entries made by inner level)
539 -- If a subsequent failure occurs and pops the PC_R_Remove node, it
540 -- removes itself and the special entry immediately underneath it,
541 -- restores the stack base value for the enclosing region, and then
542 -- again signals failure to look for alternatives that were stacked
543 -- before the recursion was initiated.
545 -- Now we need to consider what happens if the inner pattern succeeds, as
546 -- signalled by accessing the special PC_EOP pattern primitive. First we
547 -- recognize the nested case by looking at the Base value. If this Base
548 -- value is Stack'First, then the entire match has succeeded, but if the
549 -- base value is greater than Stack'First, then we have successfully
550 -- matched an inner pattern, and processing continues at the outer level.
552 -- There are two cases. The simple case is when the inner pattern has made
553 -- no stack entries, as recognized by the fact that the current stack
554 -- pointer is equal to the current base value. In this case it is fine to
555 -- remove all trace of the recursion by restoring the outer base value and
556 -- using the special entry to find the appropriate successor node.
558 -- The more complex case arises when the inner match does make stack
559 -- entries. In this case, the PC_EOP processing stacks a special entry
560 -- whose cursor value saves the saved inner base value (the one that
561 -- references the corresponding PC_R_Remove value), and whose node
562 -- pointer references a PC_R_Restore node, so the stack looks like:
564 -- (stack entries made by outer level)
566 -- (Special entry, node is (+P) successor,
567 -- cursor entry is not used)
569 -- (PC_R_Remove entry, "cursor" value is (negative)
570 -- saved base value for the enclosing region)
572 -- (stack entries made by inner level)
574 -- (PC_Region_Replace entry, "cursor" value is (negative)
575 -- stack pointer value referencing the PC_R_Remove entry).
577 -- If the entire match succeeds, then these stack entries are, as usual,
578 -- ignored and abandoned. If on the other hand a subsequent failure
579 -- causes the PC_Region_Replace entry to be popped, it restores the
580 -- inner base value from its saved "cursor" value and then fails again.
581 -- Note that it is OK that the cursor is temporarily clobbered by this
582 -- pop, since the second failure will reestablish a proper cursor value.
584 ---------------------------------
585 -- Compound Pattern Structures --
586 ---------------------------------
588 -- This section discusses the compound structures used to represent
589 -- constructed patterns. It shows the graph structures of pattern
590 -- elements that are constructed, and in the case of patterns that
591 -- provide backtracking possibilities, describes how the history
592 -- stack is used to control the backtracking. Finally, it notes the
593 -- way in which the Index numbers are assigned to the structure.
595 -- In all diagrams, solid lines (built witth minus signs or vertical
596 -- bars, represent successor pointers (Pthen fields) with > or V used
597 -- to indicate the direction of the pointer. The initial node of the
598 -- structure is in the upper left of the diagram. A dotted line is an
599 -- alternative pointer from the element above it to the element below
600 -- it. See individual sections for details on how alternatives are used.
606 -- In the pattern structures listed in this section, a line that looks
607 -- lile ----> with nothing to the right indicates an end of pattern
608 -- (EOP) pointer that represents the end of the match.
610 -- When a pattern concatenation (L & R) occurs, the resulting structure
611 -- is obtained by finding all such EOP pointers in L, and replacing
612 -- them to point to R. This is the most important flattening that
613 -- occurs in constructing a pattern, and it means that the pattern
614 -- matching circuitry does not have to keep track of the structure
615 -- of a pattern with respect to concatenation, since the appropriate
616 -- successor is always at hand.
618 -- Concatenation itself generates no additional possibilities for
619 -- backtracking, but the constituent patterns of the concatenated
620 -- structure will make stack entries as usual. The maximum amount
621 -- of stack required by the structure is thus simply the sum of the
622 -- maximums required by L and R.
624 -- The index numbering of a concatenation structure works by leaving
625 -- the numbering of the right hand pattern, R, unchanged and adjusting
626 -- the numbers in the left hand pattern, L up by the count of elements
627 -- in R. This ensures that the maximum numbered element is the leading
628 -- element as required (given that it was the leading element in L).
634 -- A pattern (L or R) constructs the structure:
637 -- | A |---->| L |---->
645 -- The A element here is a PC_Alt node, and the dotted line represents
646 -- the contents of the Alt field. When the PC_Alt element is matched,
647 -- it stacks a pointer to the leading element of R on the history stack
648 -- so that on subsequent failure, a match of R is attempted.
650 -- The A node is the higest numbered element in the pattern. The
651 -- original index numbers of R are unchanged, but the index numbers
652 -- of the L pattern are adjusted up by the count of elements in R.
654 -- Note that the difference between the index of the L leading element
655 -- the index of the R leading element (after building the alt structure)
656 -- indicates the number of nodes in L, and this is true even after the
657 -- structure is incorporated into some larger structure. For example,
658 -- if the A node has index 16, and L has index 15 and R has index
659 -- 5, then we know that L has 10 (15-5) elements in it.
661 -- Suppose that we now concatenate this structure to another pattern
662 -- with 9 elements in it. We will now have the A node with an index
663 -- of 25, L with an index of 24 and R with an index of 14. We still
664 -- know that L has 10 (24-14) elements in it, numbered 15-24, and
665 -- consequently the successor of the alternation structure has an
666 -- index with a value less than 15. This is used in Image to figure
667 -- out the original recursive structure of a pattern.
669 -- To clarify the interaction of the alternation and concatenation
670 -- structures, here is a more complex example of the structure built
673 -- (V or W or X) (Y or Z)
675 -- where A,B,C,D,E are all single element patterns:
677 -- +---+ +---+ +---+ +---+
678 -- I A I---->I V I---+-->I A I---->I Y I---->
679 -- +---+ +---+ I +---+ +---+
682 -- +---+ +---+ I +---+
683 -- I A I---->I W I-->I I Z I---->
684 -- +---+ +---+ I +---+
688 -- I X I------------>+
691 -- The numbering of the nodes would be as follows:
693 -- +---+ +---+ +---+ +---+
694 -- I 8 I---->I 7 I---+-->I 3 I---->I 2 I---->
695 -- +---+ +---+ I +---+ +---+
698 -- +---+ +---+ I +---+
699 -- I 6 I---->I 5 I-->I I 1 I---->
700 -- +---+ +---+ I +---+
704 -- I 4 I------------>+
707 -- Note: The above structure actually corresponds to
709 -- (A or (B or C)) (D or E)
713 -- ((A or B) or C) (D or E)
715 -- which is the more natural interpretation, but in fact alternation
716 -- is associative, and the construction of an alternative changes the
717 -- left grouped pattern to the right grouped pattern in any case, so
718 -- that the Image function produces a more natural looking output.
724 -- An Arb pattern builds the structure
735 -- The X node is a PC_Arb_X node, which matches null, and stacks a
736 -- pointer to Y node, which is the PC_Arb_Y node that matches one
737 -- extra character and restacks itself.
739 -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1.
741 -------------------------
742 -- Arbno (simple case) --
743 -------------------------
745 -- The simple form of Arbno can be used where the pattern always
746 -- matches at least one character if it succeeds, and it is known
747 -- not to make any history stack entries. In this case, Arbno (P)
748 -- can construct the following structure:
762 -- The S (PC_Arbno_S) node matches null stacking a pointer to the
763 -- pattern P. If a subsequent failure causes P to be matched and
764 -- this match succeeds, then node A gets restacked to try another
765 -- instance if needed by a subsequent failure.
767 -- The node numbering of the constituent pattern P is not affected.
768 -- The S node has a node number of P.Index + 1.
770 --------------------------
771 -- Arbno (complex case) --
772 --------------------------
774 -- A call to Arbno (P), where P can match null (or at least is not
775 -- known to require a non-null string) and/or P requires pattern stack
776 -- entries, constructs the following structure:
778 -- +--------------------------+
786 -- +---+ +---+ +---+ |
787 -- | E |---->| P |---->| Y |--->+
790 -- The node X (PC_Arbno_X) matches null, stacking a pointer to the
791 -- E-P-X structure used to match one Arbno instance.
793 -- Here E is the PC_R_Enter node which matches null and creates two
794 -- stack entries. The first is a special entry whose node field is
795 -- not used at all, and whose cursor field has the initial cursor.
797 -- The second entry corresponds to a standard new region action. A
798 -- PC_R_Remove node is stacked, whose cursor field is used to store
799 -- the outer stack base, and the stack base is reset to point to
800 -- this PC_R_Remove node. Then the pattern P is matched, and it can
801 -- make history stack entries in the normal manner, so now the stack
804 -- (stack entries made before assign pattern)
806 -- (Special entry, node field not used,
807 -- used only to save initial cursor)
809 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
810 -- saved base value for the enclosing region)
812 -- (stack entries made by matching P)
814 -- If the match of P fails, then the PC_R_Remove entry is popped and
815 -- it removes both itself and the special entry underneath it,
816 -- restores the outer stack base, and signals failure.
818 -- If the match of P succeeds, then node Y, the PC_Arbno_Y node, pops
819 -- the inner region. There are two possibilities. If matching P left
820 -- no stack entries, then all traces of the inner region can be removed.
821 -- If there are stack entries, then we push an PC_Region_Replace stack
822 -- entry whose "cursor" value is the inner stack base value, and then
823 -- restore the outer stack base value, so the stack looks like:
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)
831 -- saved base value for the enclosing region)
833 -- (stack entries made by matching P)
835 -- (PC_Region_Replace entry, "cursor" value is (negative)
836 -- stack pointer value referencing the PC_R_Remove entry).
838 -- Now that we have matched another instance of the Arbno pattern,
839 -- we need to move to the successor. There are two cases. If the
840 -- Arbno pattern matched null, then there is no point in seeking
841 -- alternatives, since we would just match a whole bunch of nulls.
842 -- In this case we look through the alternative node, and move
843 -- directly to its successor (i.e. the successor of the Arbno
844 -- pattern). If on the other hand a non-null string was matched,
845 -- we simply follow the successor to the alternative node, which
846 -- sets up for another possible match of the Arbno pattern.
848 -- As noted in the section on stack checking, the stack count (and
849 -- hence the stack check) for a pattern includes only one iteration
850 -- of the Arbno pattern. To make sure that multiple iterations do not
851 -- overflow the stack, the Arbno node saves the stack count required
852 -- by a single iteration, and the Concat function increments this to
853 -- include stack entries required by any successor. The PC_Arbno_Y
854 -- node uses this count to ensure that sufficient stack remains
855 -- before proceeding after matching each new instance.
857 -- The node numbering of the constituent pattern P is not affected.
858 -- Where N is the number of nodes in P, the Y node is numbered N + 1,
859 -- the E node is N + 2, and the X node is N + 3.
861 ----------------------
862 -- Assign Immediate --
863 ----------------------
865 -- Immediate assignment (P * V) constructs the following structure
868 -- | E |---->| P |---->| A |---->
871 -- Here E is the PC_R_Enter node which matches null and creates two
872 -- stack entries. The first is a special entry whose node field is
873 -- not used at all, and whose cursor field has the initial cursor.
875 -- The second entry corresponds to a standard new region action. A
876 -- PC_R_Remove node is stacked, whose cursor field is used to store
877 -- the outer stack base, and the stack base is reset to point to
878 -- this PC_R_Remove node. Then the pattern P is matched, and it can
879 -- make history stack entries in the normal manner, so now the stack
882 -- (stack entries made before assign pattern)
884 -- (Special entry, node field not used,
885 -- used only to save initial cursor)
887 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
888 -- saved base value for the enclosing region)
890 -- (stack entries made by matching P)
892 -- If the match of P fails, then the PC_R_Remove entry is popped
893 -- and it removes both itself and the special entry underneath it,
894 -- restores the outer stack base, and signals failure.
896 -- If the match of P succeeds, then node A, which is the actual
897 -- PC_Assign_Imm node, executes the assignment (using the stack
898 -- base to locate the entry with the saved starting cursor value),
899 -- and the pops the inner region. There are two possibilities, if
900 -- matching P left no stack entries, then all traces of the inner
901 -- region can be removed. If there are stack entries, then we push
902 -- an PC_Region_Replace stack entry whose "cursor" value is the
903 -- inner stack base value, and then restore the outer stack base
904 -- value, so the stack looks like:
906 -- (stack entries made before assign pattern)
908 -- (Special entry, node field not used,
909 -- used only to save initial cursor)
911 -- (PC_R_Remove entry, "cursor" value is (negative)
912 -- saved base value for the enclosing region)
914 -- (stack entries made by matching P)
916 -- (PC_Region_Replace entry, "cursor" value is the (negative)
917 -- stack pointer value referencing the PC_R_Remove entry).
919 -- If a subsequent failure occurs, the PC_Region_Replace node restores
920 -- the inner stack base value and signals failure to explore rematches
923 -- The node numbering of the constituent pattern P is not affected.
924 -- Where N is the number of nodes in P, the A node is numbered N + 1,
925 -- and the E node is N + 2.
927 ---------------------
928 -- Assign On Match --
929 ---------------------
931 -- The assign on match (**) pattern is quite similar to the assign
932 -- immediate pattern, except that the actual assignment has to be
933 -- delayed. The following structure is constructed:
936 -- | E |---->| P |---->| A |---->
939 -- The operation of this pattern is identical to that described above
940 -- for deferred assignment, up to the point where P has been matched.
942 -- The A node, which is the PC_Assign_OnM node first pushes a
943 -- PC_Assign node onto the history stack. This node saves the ending
944 -- cursor and acts as a flag for the final assignment, as further
947 -- It then stores a pointer to itself in the special entry node field.
948 -- This was otherwise unused, and is now used to retrive the address
949 -- of the variable to be assigned at the end of the pattern.
951 -- After that the inner region is terminated in the usual manner,
952 -- by stacking a PC_R_Restore entry as described for the assign
953 -- immediate case. Note that the optimization of completely
954 -- removing the inner region does not happen in this case, since
955 -- we have at least one stack entry (the PC_Assign one we just made).
956 -- The stack now looks like:
958 -- (stack entries made before assign pattern)
960 -- (Special entry, node points to copy of
961 -- the PC_Assign_OnM node, and the
962 -- cursor field saves the initial cursor).
964 -- (PC_R_Remove entry, "cursor" value is (negative)
965 -- saved base value for the enclosing region)
967 -- (stack entries made by matching P)
969 -- (PC_Assign entry, saves final cursor)
971 -- (PC_Region_Replace entry, "cursor" value is (negative)
972 -- stack pointer value referencing the PC_R_Remove entry).
974 -- If a subsequent failure causes the PC_Assign node to execute it
975 -- simply removes itself and propagates the failure.
977 -- If the match succeeds, then the history stack is scanned for
978 -- PC_Assign nodes, and the assignments are executed (examination
979 -- of the above diagram will show that all the necessary data is
980 -- at hand for the assignment).
982 -- To optimize the common case where no assign-on-match operations
983 -- are present, a global flag Assign_OnM is maintained which is
984 -- initialize to False, and gets set True as part of the execution
985 -- of the PC_Assign_OnM node. The scan of the history stack for
986 -- PC_Assign entries is done only if this flag is set.
988 -- The node numbering of the constituent pattern P is not affected.
989 -- Where N is the number of nodes in P, the A node is numbered N + 1,
990 -- and the E node is N + 2.
996 -- Bal builds a single node:
1002 -- The node B is the PC_Bal node which matches a parentheses balanced
1003 -- string, starting at the current cursor position. It then updates
1004 -- the cursor past this matched string, and stacks a pointer to itself
1005 -- with this updated cursor value on the history stack, to extend the
1006 -- matched string on a subequent failure.
1008 -- Since this is a single node it is numbered 1 (the reason we include
1009 -- it in the compound patterns section is that it backtracks).
1015 -- BreakX builds the structure
1018 -- | B |---->| A |---->
1026 -- Here the B node is the BreakX_xx node that performs a normal Break
1027 -- function. The A node is an alternative (PC_Alt) node that matches
1028 -- null, but stacks a pointer to node X (the PC_BreakX_X node) which
1029 -- extends the match one character (to eat up the previously detected
1030 -- break character), and then rematches the break.
1032 -- The B node is numbered 3, the alternative node is 1, and the X
1039 -- Fence builds a single node:
1045 -- The element F, PC_Fence, matches null, and stacks a pointer to a
1046 -- PC_Cancel element which will abort the match on a subsequent failure.
1048 -- Since this is a single element it is numbered 1 (the reason we
1049 -- include it in the compound patterns section is that it backtracks).
1051 --------------------
1052 -- Fence Function --
1053 --------------------
1055 -- A call to the Fence function builds the structure:
1057 -- +---+ +---+ +---+
1058 -- | E |---->| P |---->| X |---->
1059 -- +---+ +---+ +---+
1061 -- Here E is the PC_R_Enter node which matches null and creates two
1062 -- stack entries. The first is a special entry which is not used at
1063 -- all in the fence case (it is present merely for uniformity with
1064 -- other cases of region enter operations).
1066 -- The second entry corresponds to a standard new region action. A
1067 -- PC_R_Remove node is stacked, whose cursor field is used to store
1068 -- the outer stack base, and the stack base is reset to point to
1069 -- this PC_R_Remove node. Then the pattern P is matched, and it can
1070 -- make history stack entries in the normal manner, so now the stack
1073 -- (stack entries made before fence pattern)
1075 -- (Special entry, not used at all)
1077 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
1078 -- saved base value for the enclosing region)
1080 -- (stack entries made by matching P)
1082 -- If the match of P fails, then the PC_R_Remove entry is popped
1083 -- and it removes both itself and the special entry underneath it,
1084 -- restores the outer stack base, and signals failure.
1086 -- If the match of P succeeds, then node X, the PC_Fence_X node, gets
1087 -- control. One might be tempted to think that at this point, the
1088 -- history stack entries made by matching P can just be removed since
1089 -- they certainly are not going to be used for rematching (that is
1090 -- whole point of Fence after all!) However, this is wrong, because
1091 -- it would result in the loss of possible assign-on-match entries
1092 -- for deferred pattern assignments.
1094 -- Instead what we do is to make a special entry whose node references
1095 -- PC_Fence_Y, and whose cursor saves the inner stack base value, i.e.
1096 -- the pointer to the PC_R_Remove entry. Then the outer stack base
1097 -- pointer is restored, so the stack looks like:
1099 -- (stack entries made before assign pattern)
1101 -- (Special entry, not used at all)
1103 -- (PC_R_Remove entry, "cursor" value is (negative)
1104 -- saved base value for the enclosing region)
1106 -- (stack entries made by matching P)
1108 -- (PC_Fence_Y entry, "cursor" value is (negative) stack
1109 -- pointer value referencing the PC_R_Remove entry).
1111 -- If a subsequent failure occurs, then the PC_Fence_Y entry removes
1112 -- the entire inner region, including all entries made by matching P,
1113 -- and alternatives prior to the Fence pattern are sought.
1115 -- The node numbering of the constituent pattern P is not affected.
1116 -- Where N is the number of nodes in P, the X node is numbered N + 1,
1117 -- and the E node is N + 2.
1123 -- Succeed builds a single node:
1129 -- The node S is the PC_Succeed node which matches null, and stacks
1130 -- a pointer to itself on the history stack, so that a subsequent
1131 -- failure repeats the same match.
1133 -- Since this is a single node it is numbered 1 (the reason we include
1134 -- it in the compound patterns section is that it backtracks).
1136 ---------------------
1137 -- Write Immediate --
1138 ---------------------
1140 -- The structure built for a write immediate operation (P * F, where
1141 -- F is a file access value) is:
1143 -- +---+ +---+ +---+
1144 -- | E |---->| P |---->| W |---->
1145 -- +---+ +---+ +---+
1147 -- Here E is the PC_R_Enter node and W is the PC_Write_Imm node. The
1148 -- handling is identical to that described above for Assign Immediate,
1149 -- except that at the point where a successful match occurs, the matched
1150 -- substring is written to the referenced file.
1152 -- The node numbering of the constituent pattern P is not affected.
1153 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1154 -- and the E node is N + 2.
1156 --------------------
1157 -- Write On Match --
1158 --------------------
1160 -- The structure built for a write on match operation (P ** F, where
1161 -- F is a file access value) is:
1163 -- +---+ +---+ +---+
1164 -- | E |---->| P |---->| W |---->
1165 -- +---+ +---+ +---+
1167 -- Here E is the PC_R_Enter node and W is the PC_Write_OnM node. The
1168 -- handling is identical to that described above for Assign On Match,
1169 -- except that at the point where a successful match has completed,
1170 -- the matched substring is written to the referenced file.
1172 -- The node numbering of the constituent pattern P is not affected.
1173 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1174 -- and the E node is N + 2.
1175 -----------------------
1176 -- Constant Patterns --
1177 -----------------------
1179 -- The following pattern elements are referenced only from the pattern
1180 -- history stack. In each case the processing for the pattern element
1181 -- results in pattern match abort, or futher failure, so there is no
1182 -- need for a successor and no need for a node number
1184 CP_Assign
: aliased PE
:= (PC_Assign
, 0, N
);
1185 CP_Cancel
: aliased PE
:= (PC_Cancel
, 0, N
);
1186 CP_Fence_Y
: aliased PE
:= (PC_Fence_Y
, 0, N
);
1187 CP_R_Remove
: aliased PE
:= (PC_R_Remove
, 0, N
);
1188 CP_R_Restore
: aliased PE
:= (PC_R_Restore
, 0, N
);
1190 -----------------------
1191 -- Local Subprograms --
1192 -----------------------
1194 function Alternate
(L
, R
: PE_Ptr
) return PE_Ptr
;
1195 function "or" (L
, R
: PE_Ptr
) return PE_Ptr
renames Alternate
;
1196 -- Build pattern structure corresponding to the alternation of L, R.
1197 -- (i.e. try to match L, and if that fails, try to match R).
1199 function Arbno_Simple
(P
: PE_Ptr
) return PE_Ptr
;
1200 -- Build simple Arbno pattern, P is a pattern that is guaranteed to
1201 -- match at least one character if it succeeds and to require no
1202 -- stack entries under all circumstances. The result returned is
1203 -- a simple Arbno structure as previously described.
1205 function Bracket
(E
, P
, A
: PE_Ptr
) return PE_Ptr
;
1206 -- Given two single node pattern elements E and A, and a (possible
1207 -- complex) pattern P, construct the concatenation E-->P-->A and
1208 -- return a pointer to E. The concatenation does not affect the
1209 -- node numbering in P. A has a number one higher than the maximum
1210 -- number in P, and E has a number two higher than the maximum
1211 -- number in P (see for example the Assign_Immediate structure to
1212 -- understand a typical use of this function).
1214 function BreakX_Make
(B
: PE_Ptr
) return Pattern
;
1215 -- Given a pattern element for a Break patternx, returns the
1216 -- corresponding BreakX compound pattern structure.
1218 function Concat
(L
, R
: PE_Ptr
; Incr
: Natural) return PE_Ptr
;
1219 -- Creates a pattern eelement that represents a concatenation of the
1220 -- two given pattern elements (i.e. the pattern L followed by R).
1221 -- The result returned is always the same as L, but the pattern
1222 -- referenced by L is modified to have R as a successor. This
1223 -- procedure does not copy L or R, so if a copy is required, it
1224 -- is the responsibility of the caller. The Incr parameter is an
1225 -- amount to be added to the Nat field of any P_Arbno_Y node that is
1226 -- in the left operand, it represents the additional stack space
1227 -- required by the right operand.
1229 function C_To_PE
(C
: PChar
) return PE_Ptr
;
1230 -- Given a character, constructs a pattern element that matches
1231 -- the single character.
1233 function Copy
(P
: PE_Ptr
) return PE_Ptr
;
1234 -- Creates a copy of the pattern element referenced by the given
1235 -- pattern element reference. This is a deep copy, which means that
1236 -- it follows the Next and Alt pointers.
1238 function Image
(P
: PE_Ptr
) return String;
1239 -- Returns the image of the address of the referenced pattern element.
1240 -- This is equivalent to Image (To_Address (P));
1242 function Is_In
(C
: Character; Str
: String) return Boolean;
1243 pragma Inline
(Is_In
);
1244 -- Determines if the character C is in string Str.
1246 procedure Logic_Error
;
1247 -- Called to raise Program_Error with an appropriate message if an
1248 -- internal logic error is detected.
1250 function Str_BF
(A
: Boolean_Func
) return String;
1251 function Str_FP
(A
: File_Ptr
) return String;
1252 function Str_NF
(A
: Natural_Func
) return String;
1253 function Str_NP
(A
: Natural_Ptr
) return String;
1254 function Str_PP
(A
: Pattern_Ptr
) return String;
1255 function Str_VF
(A
: VString_Func
) return String;
1256 function Str_VP
(A
: VString_Ptr
) return String;
1257 -- These are debugging routines, which return a representation of the
1258 -- given access value (they are called only by Image and Dump)
1260 procedure Set_Successor
(Pat
: PE_Ptr
; Succ
: PE_Ptr
);
1261 -- Adjusts all EOP pointers in Pat to point to Succ. No other changes
1262 -- are made. In particular, Succ is unchanged, and no index numbers
1263 -- are modified. Note that Pat may not be equal to EOP on entry.
1265 function S_To_PE
(Str
: PString
) return PE_Ptr
;
1266 -- Given a string, constructs a pattern element that matches the string
1268 procedure Uninitialized_Pattern
;
1269 pragma No_Return
(Uninitialized_Pattern
);
1270 -- Called to raise Program_Error with an appropriate error message if
1271 -- an uninitialized pattern is used in any pattern construction or
1272 -- pattern matching operation.
1278 Start
: out Natural;
1279 Stop
: out Natural);
1280 -- This is the common pattern match routine. It is passed a string and
1281 -- a pattern, and it indicates success or failure, and on success the
1282 -- section of the string matched. It does not perform any assignments
1283 -- to the subject string, so pattern replacement is for the caller.
1285 -- Subject The subject string. The lower bound is always one. In the
1286 -- Match procedures, it is fine to use strings whose lower bound
1287 -- is not one, but we perform a one time conversion before the
1288 -- call to XMatch, so that XMatch does not have to be bothered
1289 -- with strange lower bounds.
1291 -- Pat_P Points to initial pattern element of pattern to be matched
1293 -- Pat_S Maximum required stack entries for pattern to be matched
1295 -- Start If match is successful, starting index of matched section.
1296 -- This value is always non-zero. A value of zero is used to
1297 -- indicate a failed match.
1299 -- Stop If match is successful, ending index of matched section.
1300 -- This can be zero if we match the null string at the start,
1301 -- in which case Start is set to zero, and Stop to one. If the
1302 -- Match fails, then the contents of Stop is undefined.
1308 Start
: out Natural;
1309 Stop
: out Natural);
1310 -- Identical in all respects to XMatch, except that trace information is
1311 -- output on Standard_Output during execution of the match. This is the
1312 -- version that is called if the original Match call has Debug => True.
1318 function "&" (L
: PString
; R
: Pattern
) return Pattern
is
1320 return (AFC
with R
.Stk
, Concat
(S_To_PE
(L
), Copy
(R
.P
), R
.Stk
));
1323 function "&" (L
: Pattern
; R
: PString
) return Pattern
is
1325 return (AFC
with L
.Stk
, Concat
(Copy
(L
.P
), S_To_PE
(R
), 0));
1328 function "&" (L
: PChar
; R
: Pattern
) return Pattern
is
1330 return (AFC
with R
.Stk
, Concat
(C_To_PE
(L
), Copy
(R
.P
), R
.Stk
));
1333 function "&" (L
: Pattern
; R
: PChar
) return Pattern
is
1335 return (AFC
with L
.Stk
, Concat
(Copy
(L
.P
), C_To_PE
(R
), 0));
1338 function "&" (L
: Pattern
; R
: Pattern
) return Pattern
is
1340 return (AFC
with L
.Stk
+ R
.Stk
, Concat
(Copy
(L
.P
), Copy
(R
.P
), R
.Stk
));
1349 -- +---+ +---+ +---+
1350 -- | E |---->| P |---->| A |---->
1351 -- +---+ +---+ +---+
1353 -- The node numbering of the constituent pattern P is not affected.
1354 -- Where N is the number of nodes in P, the A node is numbered N + 1,
1355 -- and the E node is N + 2.
1357 function "*" (P
: Pattern
; Var
: VString_Var
) return Pattern
is
1358 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
1359 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1360 A : constant PE_Ptr :=
1361 new PE'(PC_Assign_Imm
, 0, EOP
, Var
'Unrestricted_Access);
1364 return (AFC
with P
.Stk
+ 3, Bracket
(E
, Pat
, A
));
1367 function "*" (P
: PString
; Var
: VString_Var
) return Pattern
is
1368 Pat
: constant PE_Ptr
:= S_To_PE
(P
);
1369 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1370 A : constant PE_Ptr :=
1371 new PE'(PC_Assign_Imm
, 0, EOP
, Var
'Unrestricted_Access);
1374 return (AFC
with 3, Bracket
(E
, Pat
, A
));
1377 function "*" (P
: PChar
; Var
: VString_Var
) return Pattern
is
1378 Pat
: constant PE_Ptr
:= C_To_PE
(P
);
1379 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1380 A : constant PE_Ptr :=
1381 new PE'(PC_Assign_Imm
, 0, EOP
, Var
'Unrestricted_Access);
1384 return (AFC
with 3, Bracket
(E
, Pat
, A
));
1389 -- +---+ +---+ +---+
1390 -- | E |---->| P |---->| W |---->
1391 -- +---+ +---+ +---+
1393 -- The node numbering of the constituent pattern P is not affected.
1394 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1395 -- and the E node is N + 2.
1397 function "*" (P
: Pattern
; Fil
: File_Access
) return Pattern
is
1398 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
1399 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1400 W : constant PE_Ptr := new PE'(PC_Write_Imm
, 0, EOP
, Fil
);
1403 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1406 function "*" (P
: PString
; Fil
: File_Access
) return Pattern
is
1407 Pat
: constant PE_Ptr
:= S_To_PE
(P
);
1408 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1409 W : constant PE_Ptr := new PE'(PC_Write_Imm
, 0, EOP
, Fil
);
1412 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1415 function "*" (P
: PChar
; Fil
: File_Access
) return Pattern
is
1416 Pat
: constant PE_Ptr
:= C_To_PE
(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
);
1421 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1430 -- +---+ +---+ +---+
1431 -- | E |---->| P |---->| A |---->
1432 -- +---+ +---+ +---+
1434 -- The node numbering of the constituent pattern P is not affected.
1435 -- Where N is the number of nodes in P, the A node is numbered N + 1,
1436 -- and the E node is N + 2.
1438 function "**" (P
: Pattern
; Var
: VString_Var
) return Pattern
is
1439 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
1440 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1441 A : constant PE_Ptr :=
1442 new PE'(PC_Assign_OnM
, 0, EOP
, Var
'Unrestricted_Access);
1445 return (AFC
with P
.Stk
+ 3, Bracket
(E
, Pat
, A
));
1448 function "**" (P
: PString
; Var
: VString_Var
) return Pattern
is
1449 Pat
: constant PE_Ptr
:= S_To_PE
(P
);
1450 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1451 A : constant PE_Ptr :=
1452 new PE'(PC_Assign_OnM
, 0, EOP
, Var
'Unrestricted_Access);
1455 return (AFC
with 3, Bracket
(E
, Pat
, A
));
1458 function "**" (P
: PChar
; Var
: VString_Var
) return Pattern
is
1459 Pat
: constant PE_Ptr
:= C_To_PE
(P
);
1460 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1461 A : constant PE_Ptr :=
1462 new PE'(PC_Assign_OnM
, 0, EOP
, Var
'Unrestricted_Access);
1465 return (AFC
with 3, Bracket
(E
, Pat
, A
));
1470 -- +---+ +---+ +---+
1471 -- | E |---->| P |---->| W |---->
1472 -- +---+ +---+ +---+
1474 -- The node numbering of the constituent pattern P is not affected.
1475 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1476 -- and the E node is N + 2.
1478 function "**" (P
: Pattern
; Fil
: File_Access
) return Pattern
is
1479 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
1480 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1481 W : constant PE_Ptr := new PE'(PC_Write_OnM
, 0, EOP
, Fil
);
1484 return (AFC
with P
.Stk
+ 3, Bracket
(E
, Pat
, W
));
1487 function "**" (P
: PString
; Fil
: File_Access
) return Pattern
is
1488 Pat
: constant PE_Ptr
:= S_To_PE
(P
);
1489 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1490 W : constant PE_Ptr := new PE'(PC_Write_OnM
, 0, EOP
, Fil
);
1493 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1496 function "**" (P
: PChar
; Fil
: File_Access
) return Pattern
is
1497 Pat
: constant PE_Ptr
:= C_To_PE
(P
);
1498 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
1499 W : constant PE_Ptr := new PE'(PC_Write_OnM
, 0, EOP
, Fil
);
1502 return (AFC
with 3, Bracket
(E
, Pat
, W
));
1509 function "+" (Str
: VString_Var
) return Pattern
is
1513 new PE
'(PC_String_VP, 1, EOP, Str'Unrestricted_Access));
1516 function "+" (Str : VString_Func) return Pattern is
1518 return (AFC with 0, new PE'(PC_String_VF
, 1, EOP
, Str
));
1521 function "+" (P
: Pattern_Var
) return Pattern
is
1525 new PE
'(PC_Rpat, 1, EOP, P'Unrestricted_Access));
1528 function "+" (P : Boolean_Func) return Pattern is
1530 return (AFC with 3, new PE'(PC_Pred_Func
, 1, EOP
, P
));
1537 function "or" (L
: PString
; R
: Pattern
) return Pattern
is
1539 return (AFC
with R
.Stk
+ 1, S_To_PE
(L
) or Copy
(R
.P
));
1542 function "or" (L
: Pattern
; R
: PString
) return Pattern
is
1544 return (AFC
with L
.Stk
+ 1, Copy
(L
.P
) or S_To_PE
(R
));
1547 function "or" (L
: PString
; R
: PString
) return Pattern
is
1549 return (AFC
with 1, S_To_PE
(L
) or S_To_PE
(R
));
1552 function "or" (L
: Pattern
; R
: Pattern
) return Pattern
is
1555 Natural'Max (L
.Stk
, R
.Stk
) + 1, Copy
(L
.P
) or Copy
(R
.P
));
1558 function "or" (L
: PChar
; R
: Pattern
) return Pattern
is
1560 return (AFC
with 1, C_To_PE
(L
) or Copy
(R
.P
));
1563 function "or" (L
: Pattern
; R
: PChar
) return Pattern
is
1565 return (AFC
with 1, Copy
(L
.P
) or C_To_PE
(R
));
1568 function "or" (L
: PChar
; R
: PChar
) return Pattern
is
1570 return (AFC
with 1, C_To_PE
(L
) or C_To_PE
(R
));
1573 function "or" (L
: PString
; R
: PChar
) return Pattern
is
1575 return (AFC
with 1, S_To_PE
(L
) or C_To_PE
(R
));
1578 function "or" (L
: PChar
; R
: PString
) return Pattern
is
1580 return (AFC
with 1, C_To_PE
(L
) or S_To_PE
(R
));
1587 -- No two patterns share the same pattern elements, so the adjust
1588 -- procedure for a Pattern assignment must do a deep copy of the
1589 -- pattern element structure.
1591 procedure Adjust
(Object
: in out Pattern
) is
1593 Object
.P
:= Copy
(Object
.P
);
1600 function Alternate
(L
, R
: PE_Ptr
) return PE_Ptr
is
1602 -- If the left pattern is null, then we just add the alternation
1603 -- node with an index one greater than the right hand pattern.
1606 return new PE
'(PC_Alt, R.Index + 1, EOP, R);
1608 -- If the left pattern is non-null, then build a reference vector
1609 -- for its elements, and adjust their index values to acccomodate
1610 -- the right hand elements. Then add the alternation node.
1614 Refs : Ref_Array (1 .. L.Index);
1617 Build_Ref_Array (L, Refs);
1619 for J in Refs'Range loop
1620 Refs (J).Index := Refs (J).Index + R.Index;
1624 return new PE'(PC_Alt
, L
.Index
+ 1, L
, R
);
1632 function Any
(Str
: String) return Pattern
is
1634 return (AFC
with 0, new PE
'(PC_Any_CS, 1, EOP, To_Set (Str)));
1637 function Any (Str : VString) return Pattern is
1639 return Any (S (Str));
1642 function Any (Str : Character) return Pattern is
1644 return (AFC with 0, new PE'(PC_Any_CH
, 1, EOP
, Str
));
1647 function Any
(Str
: Character_Set
) return Pattern
is
1649 return (AFC
with 0, new PE
'(PC_Any_CS, 1, EOP, Str));
1652 function Any (Str : access VString) return Pattern is
1654 return (AFC with 0, new PE'(PC_Any_VP
, 1, EOP
, VString_Ptr
(Str
)));
1657 function Any
(Str
: VString_Func
) return Pattern
is
1659 return (AFC
with 0, new PE
'(PC_Any_VF, 1, EOP, Str));
1675 -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1.
1677 function Arb return Pattern is
1678 Y : constant PE_Ptr := new PE'(PC_Arb_Y
, 1, EOP
);
1679 X
: constant PE_Ptr
:= new PE
'(PC_Arb_X, 2, EOP, Y);
1682 return (AFC with 1, X);
1689 function Arbno (P : PString) return Pattern is
1691 if P'Length = 0 then
1692 return (AFC with 0, EOP);
1695 return (AFC with 0, Arbno_Simple (S_To_PE (P)));
1699 function Arbno (P : PChar) return Pattern is
1701 return (AFC with 0, Arbno_Simple (C_To_PE (P)));
1704 function Arbno (P : Pattern) return Pattern is
1705 Pat : constant PE_Ptr := Copy (P.P);
1709 and then OK_For_Simple_Arbno (Pat.Pcode)
1711 return (AFC with 0, Arbno_Simple (Pat));
1714 -- This is the complex case, either the pattern makes stack entries
1715 -- or it is possible for the pattern to match the null string (more
1716 -- accurately, we don't know that this is not the case).
1718 -- +--------------------------+
1726 -- +---+ +---+ +---+ |
1727 -- | E |---->| P |---->| Y |--->+
1728 -- +---+ +---+ +---+
1730 -- The node numbering of the constituent pattern P is not affected.
1731 -- Where N is the number of nodes in P, the Y node is numbered N + 1,
1732 -- the E node is N + 2, and the X node is N + 3.
1735 E : constant PE_Ptr := new PE'(PC_R_Enter
, 0, EOP
);
1736 X
: constant PE_Ptr
:= new PE
'(PC_Arbno_X, 0, EOP, E);
1737 Y : constant PE_Ptr := new PE'(PC_Arbno_Y
, 0, X
, P
.Stk
+ 3);
1738 EPY
: constant PE_Ptr
:= Bracket
(E
, Pat
, Y
);
1742 X
.Index
:= EPY
.Index
+ 1;
1743 return (AFC
with P
.Stk
+ 3, X
);
1760 -- | P |---------->+
1763 -- The node numbering of the constituent pattern P is not affected.
1764 -- The S node has a node number of P.Index + 1.
1766 -- Note that we know that P cannot be EOP, because a null pattern
1767 -- does not meet the requirements for simple Arbno.
1769 function Arbno_Simple
(P
: PE_Ptr
) return PE_Ptr
is
1770 S
: constant PE_Ptr
:= new PE
'(PC_Arbno_S, P.Index + 1, EOP, P);
1773 Set_Successor (P, S);
1781 function Bal return Pattern is
1783 return (AFC with 1, new PE'(PC_Bal
, 1, EOP
));
1790 function Bracket
(E
, P
, A
: PE_Ptr
) return PE_Ptr
is
1799 Set_Successor
(P
, A
);
1800 E
.Index
:= P
.Index
+ 2;
1801 A
.Index
:= P
.Index
+ 1;
1811 function Break
(Str
: String) return Pattern
is
1813 return (AFC
with 0, new PE
'(PC_Break_CS, 1, EOP, To_Set (Str)));
1816 function Break (Str : VString) return Pattern is
1818 return Break (S (Str));
1821 function Break (Str : Character) return Pattern is
1823 return (AFC with 0, new PE'(PC_Break_CH
, 1, EOP
, Str
));
1826 function Break
(Str
: Character_Set
) return Pattern
is
1828 return (AFC
with 0, new PE
'(PC_Break_CS, 1, EOP, Str));
1831 function Break (Str : access VString) return Pattern is
1833 return (AFC with 0, new PE'(PC_Break_VP
, 1, EOP
, VString_Ptr
(Str
)));
1836 function Break
(Str
: VString_Func
) return Pattern
is
1838 return (AFC
with 0, new PE
'(PC_Break_VF, 1, EOP, Str));
1845 function BreakX (Str : String) return Pattern is
1847 return BreakX_Make (new PE'(PC_BreakX_CS
, 3, N
, To_Set
(Str
)));
1850 function BreakX
(Str
: VString
) return Pattern
is
1852 return BreakX
(S
(Str
));
1855 function BreakX
(Str
: Character) return Pattern
is
1857 return BreakX_Make
(new PE
'(PC_BreakX_CH, 3, N, Str));
1860 function BreakX (Str : Character_Set) return Pattern is
1862 return BreakX_Make (new PE'(PC_BreakX_CS
, 3, N
, Str
));
1865 function BreakX
(Str
: access VString
) return Pattern
is
1867 return BreakX_Make
(new PE
'(PC_BreakX_VP, 3, N, VString_Ptr (Str)));
1870 function BreakX (Str : VString_Func) return Pattern is
1872 return BreakX_Make (new PE'(PC_BreakX_VF
, 3, N
, Str
));
1880 -- | B |---->| A |---->
1888 -- The B node is numbered 3, the alternative node is 1, and the X
1891 function BreakX_Make
(B
: PE_Ptr
) return Pattern
is
1892 X
: constant PE_Ptr
:= new PE
'(PC_BreakX_X, 2, B);
1893 A : constant PE_Ptr := new PE'(PC_Alt
, 1, EOP
, X
);
1897 return (AFC
with 2, B
);
1900 ---------------------
1901 -- Build_Ref_Array --
1902 ---------------------
1904 procedure Build_Ref_Array
(E
: PE_Ptr
; RA
: out Ref_Array
) is
1906 procedure Record_PE
(E
: PE_Ptr
);
1907 -- Record given pattern element if not already recorded in RA,
1908 -- and also record any referenced pattern elements recursively.
1910 procedure Record_PE
(E
: PE_Ptr
) is
1912 PutD
(" Record_PE called with PE_Ptr = " & Image
(E
));
1914 if E
= EOP
or else RA
(E
.Index
) /= null then
1915 Put_LineD
(", nothing to do");
1919 Put_LineD
(", recording" & IndexT
'Image (E
.Index
));
1921 Record_PE
(E
.Pthen
);
1923 if E
.Pcode
in PC_Has_Alt
then
1929 -- Start of processing for Build_Ref_Array
1933 Put_LineD
("Entering Build_Ref_Array");
1936 end Build_Ref_Array
;
1942 function C_To_PE
(C
: PChar
) return PE_Ptr
is
1944 return new PE
'(PC_Char, 1, EOP, C);
1951 function Cancel return Pattern is
1953 return (AFC with 0, new PE'(PC_Cancel
, 1, EOP
));
1960 -- Concat needs to traverse the left operand performing the following
1963 -- a) Any successor pointers (Pthen fields) that are set to EOP are
1964 -- reset to point to the second operand.
1966 -- b) Any PC_Arbno_Y node has its stack count field incremented
1967 -- by the parameter Incr provided for this purpose.
1969 -- d) Num fields of all pattern elements in the left operand are
1970 -- adjusted to include the elements of the right operand.
1972 -- Note: we do not use Set_Successor in the processing for Concat, since
1973 -- there is no point in doing two traversals, we may as well do everything
1974 -- at the same time.
1976 function Concat
(L
, R
: PE_Ptr
; Incr
: Natural) return PE_Ptr
is
1986 Refs
: Ref_Array
(1 .. L
.Index
);
1987 -- We build a reference array for L whose N'th element points to
1988 -- the pattern element of L whose original Index value is N.
1993 Build_Ref_Array
(L
, Refs
);
1995 for J
in Refs
'Range loop
1998 P
.Index
:= P
.Index
+ R
.Index
;
2000 if P
.Pcode
= PC_Arbno_Y
then
2001 P
.Nat
:= P
.Nat
+ Incr
;
2004 if P
.Pthen
= EOP
then
2008 if P
.Pcode
in PC_Has_Alt
and then P
.Alt
= EOP
then
2022 function Copy
(P
: PE_Ptr
) return PE_Ptr
is
2025 Uninitialized_Pattern
;
2029 Refs
: Ref_Array
(1 .. P
.Index
);
2030 -- References to elements in P, indexed by Index field
2032 Copy
: Ref_Array
(1 .. P
.Index
);
2033 -- Holds copies of elements of P, indexed by Index field.
2038 Build_Ref_Array
(P
, Refs
);
2040 -- Now copy all nodes
2042 for J
in Refs
'Range loop
2043 Copy
(J
) := new PE
'(Refs (J).all);
2046 -- Adjust all internal references
2048 for J in Copy'Range loop
2051 -- Adjust successor pointer to point to copy
2053 if E.Pthen /= EOP then
2054 E.Pthen := Copy (E.Pthen.Index);
2057 -- Adjust Alt pointer if there is one to point to copy
2059 if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then
2060 E.Alt := Copy (E.Alt.Index);
2063 -- Copy referenced string
2065 if E.Pcode = PC_String then
2066 E.Str := new String'(E
.Str
.all);
2070 return Copy
(P
.Index
);
2079 procedure Dump
(P
: Pattern
) is
2081 subtype Count
is Ada
.Text_IO
.Count
;
2083 -- Used to keep track of column in dump output
2085 Refs
: Ref_Array
(1 .. P
.P
.Index
);
2086 -- We build a reference array whose N'th element points to the
2087 -- pattern element whose Index value is N.
2089 Cols
: Natural := 2;
2090 -- Number of columns used for pattern numbers, minimum is 2
2094 procedure Write_Node_Id
(E
: PE_Ptr
);
2095 -- Writes out a string identifying the given pattern element.
2097 procedure Write_Node_Id
(E
: PE_Ptr
) 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 Put
("Pattern Dump Output (pattern at " &
2128 ", S = " & Natural'Image (P
.Stk
) & ')');
2133 while Col
< Scol
loop
2139 -- If uninitialized pattern, dump line and we are done
2142 Put_Line
("Uninitialized pattern value");
2146 -- If null pattern, just dump it and we are all done
2149 Put_Line
("EOP (null pattern)");
2153 Build_Ref_Array
(P
.P
, Refs
);
2155 -- Set number of columns required for node numbers
2157 while 10 ** Cols
- 1 < Integer (P
.P
.Index
) loop
2161 -- Now dump the nodes in reverse sequence. We output them in reverse
2162 -- sequence since this corresponds to the natural order used to
2163 -- construct the patterns.
2165 for J
in reverse Refs
'Range loop
2168 Set_Col
(Count
(Cols
) + 4);
2171 Put
(Pattern_Code
'Image (E
.Pcode
));
2173 Set_Col
(21 + Count
(Cols
) + Address_Image_Length
);
2174 Write_Node_Id
(E
.Pthen
);
2175 Set_Col
(24 + 2 * Count
(Cols
) + Address_Image_Length
);
2183 Write_Node_Id
(E
.Alt
);
2186 Put
(Str_PP
(E
.PP
));
2188 when PC_Pred_Func
=>
2189 Put
(Str_BF
(E
.BF
));
2191 when PC_Assign_Imm |
2200 Put
(Str_VP
(E
.VP
));
2204 Put
(Str_FP
(E
.FP
));
2207 Put
(Image
(E
.Str
.all));
2210 Put
(Image
(E
.Str2
));
2213 Put
(Image
(E
.Str3
));
2216 Put
(Image
(E
.Str4
));
2219 Put
(Image
(E
.Str5
));
2222 Put
(Image
(E
.Str6
));
2225 Put
(Str_NP
(E
.Var
));
2234 Put
(''' & E
.Char
& ''');
2242 Put
('"' & To_Sequence
(E
.CS
) & '"');
2257 Put
(Str_NF
(E
.NF
));
2264 Put
(Str_NP
(E
.NP
));
2273 Put
(Str_VF
(E
.VF
));
2275 when others => null;
2289 function Fail
return Pattern
is
2291 return (AFC
with 0, new PE
'(PC_Fail, 1, EOP));
2300 function Fence return Pattern is
2302 return (AFC with 1, new PE'(PC_Fence
, 1, EOP
));
2307 -- +---+ +---+ +---+
2308 -- | E |---->| P |---->| X |---->
2309 -- +---+ +---+ +---+
2311 -- The node numbering of the constituent pattern P is not affected.
2312 -- Where N is the number of nodes in P, the X node is numbered N + 1,
2313 -- and the E node is N + 2.
2315 function Fence
(P
: Pattern
) return Pattern
is
2316 Pat
: constant PE_Ptr
:= Copy
(P
.P
);
2317 E
: constant PE_Ptr
:= new PE
'(PC_R_Enter, 0, EOP);
2318 X : constant PE_Ptr := new PE'(PC_Fence_X
, 0, EOP
);
2321 return (AFC
with P
.Stk
+ 1, Bracket
(E
, Pat
, X
));
2328 procedure Finalize
(Object
: in out Pattern
) is
2330 procedure Free
is new Unchecked_Deallocation
(PE
, PE_Ptr
);
2331 procedure Free
is new Unchecked_Deallocation
(String, String_Ptr
);
2334 -- Nothing to do if already freed
2336 if Object
.P
= null then
2339 -- Otherwise we must free all elements
2343 Refs
: Ref_Array
(1 .. Object
.P
.Index
);
2344 -- References to elements in pattern to be finalized
2347 Build_Ref_Array
(Object
.P
, Refs
);
2349 for J
in Refs
'Range loop
2350 if Refs
(J
).Pcode
= PC_String
then
2351 Free
(Refs
(J
).Str
);
2366 function Image
(P
: PE_Ptr
) return String is
2368 return Image
(To_Address
(P
));
2371 function Image
(P
: Pattern
) return String is
2373 return S
(Image
(P
));
2376 function Image
(P
: Pattern
) return VString
is
2378 Kill_Ampersand
: Boolean := False;
2379 -- Set True to delete next & to be output to Result
2381 Result
: VString
:= Nul
;
2382 -- The result is accumulated here, using Append
2384 Refs
: Ref_Array
(1 .. P
.P
.Index
);
2385 -- We build a reference array whose N'th element points to the
2386 -- pattern element whose Index value is N.
2388 procedure Delete_Ampersand
;
2389 -- Deletes the ampersand at the end of Result
2391 procedure Image_Seq
(E
: PE_Ptr
; Succ
: PE_Ptr
; Paren
: Boolean);
2392 -- E refers to a pattern structure whose successor is given by Succ.
2393 -- This procedure appends to Result a representation of this pattern.
2394 -- The Paren parameter indicates whether parentheses are required if
2395 -- the output is more than one element.
2397 procedure Image_One
(E
: in out PE_Ptr
);
2398 -- E refers to a pattern structure. This procedure appends to Result
2399 -- a representation of the single simple or compound pattern structure
2400 -- at the start of E and updates E to point to its successor.
2402 ----------------------
2403 -- Delete_Ampersand --
2404 ----------------------
2406 procedure Delete_Ampersand
is
2407 L
: Natural := Length
(Result
);
2411 Delete
(Result
, L
- 1, L
);
2413 end Delete_Ampersand
;
2419 procedure Image_One
(E
: in out PE_Ptr
) is
2421 ER
: PE_Ptr
:= E
.Pthen
;
2422 -- Successor set as result in E unless reset
2428 Append
(Result
, "Cancel");
2430 when PC_Alt
=> Alt
: declare
2432 Elmts_In_L
: constant IndexT
:= E
.Pthen
.Index
- E
.Alt
.Index
;
2433 -- Number of elements in left pattern of alternation.
2435 Lowest_In_L
: constant IndexT
:= E
.Index
- Elmts_In_L
;
2436 -- Number of lowest index in elements of left pattern
2441 -- The successor of the alternation node must have a lower
2442 -- index than any node that is in the left pattern or a
2443 -- higher index than the alternation node itself.
2446 and then ER
.Index
>= Lowest_In_L
2447 and then ER
.Index
< E
.Index
2452 Append
(Result
, '(');
2456 Image_Seq
(E1
.Pthen
, ER
, False);
2457 Append
(Result
, " or ");
2459 exit when E1
.Pcode
/= PC_Alt
;
2462 Image_Seq
(E1
, ER
, False);
2463 Append
(Result
, ')');
2467 Append
(Result
, "Any (" & Image
(To_Sequence
(E
.CS
)) & ')');
2470 Append
(Result
, "Any (" & Str_VF
(E
.VF
) & ')');
2473 Append
(Result
, "Any (" & Str_VP
(E
.VP
) & ')');
2476 Append
(Result
, "Arb");
2479 Append
(Result
, "Arbno (");
2480 Image_Seq
(E
.Alt
, E
, False);
2481 Append
(Result
, ')');
2484 Append
(Result
, "Arbno (");
2485 Image_Seq
(E
.Alt
.Pthen
, Refs
(E
.Index
- 2), False);
2486 Append
(Result
, ')');
2488 when PC_Assign_Imm
=>
2490 Append
(Result
, "* " & Str_VP
(Refs
(E
.Index
- 1).VP
));
2492 when PC_Assign_OnM
=>
2494 Append
(Result
, "** " & Str_VP
(Refs
(E
.Index
- 1).VP
));
2497 Append
(Result
, "Any ('" & E
.Char
& "')");
2500 Append
(Result
, "Bal");
2503 Append
(Result
, "Break ('" & E
.Char
& "')");
2506 Append
(Result
, "Break (" & Image
(To_Sequence
(E
.CS
)) & ')');
2509 Append
(Result
, "Break (" & Str_VF
(E
.VF
) & ')');
2512 Append
(Result
, "Break (" & Str_VP
(E
.VP
) & ')');
2514 when PC_BreakX_CH
=>
2515 Append
(Result
, "BreakX ('" & E
.Char
& "')");
2518 when PC_BreakX_CS
=>
2519 Append
(Result
, "BreakX (" & Image
(To_Sequence
(E
.CS
)) & ')');
2522 when PC_BreakX_VF
=>
2523 Append
(Result
, "BreakX (" & Str_VF
(E
.VF
) & ')');
2526 when PC_BreakX_VP
=>
2527 Append
(Result
, "BreakX (" & Str_VP
(E
.VP
) & ')');
2531 Append
(Result
, ''' & E
.Char
& ''');
2534 Append
(Result
, "Fail");
2537 Append
(Result
, "Fence");
2540 Append
(Result
, "Fence (");
2541 Image_Seq
(E
.Pthen
, Refs
(E
.Index
- 1), False);
2542 Append
(Result
, ")");
2543 ER
:= Refs
(E
.Index
- 1).Pthen
;
2546 Append
(Result
, "Len (" & E
.Nat
& ')');
2549 Append
(Result
, "Len (" & Str_NF
(E
.NF
) & ')');
2552 Append
(Result
, "Len (" & Str_NP
(E
.NP
) & ')');
2554 when PC_NotAny_CH
=>
2555 Append
(Result
, "NotAny ('" & E
.Char
& "')");
2557 when PC_NotAny_CS
=>
2558 Append
(Result
, "NotAny (" & Image
(To_Sequence
(E
.CS
)) & ')');
2560 when PC_NotAny_VF
=>
2561 Append
(Result
, "NotAny (" & Str_VF
(E
.VF
) & ')');
2563 when PC_NotAny_VP
=>
2564 Append
(Result
, "NotAny (" & Str_VP
(E
.VP
) & ')');
2567 Append
(Result
, "NSpan ('" & E
.Char
& "')");
2570 Append
(Result
, "NSpan (" & Image
(To_Sequence
(E
.CS
)) & ')');
2573 Append
(Result
, "NSpan (" & Str_VF
(E
.VF
) & ')');
2576 Append
(Result
, "NSpan (" & Str_VP
(E
.VP
) & ')');
2579 Append
(Result
, """""");
2582 Append
(Result
, "Pos (" & E
.Nat
& ')');
2585 Append
(Result
, "Pos (" & Str_NF
(E
.NF
) & ')');
2588 Append
(Result
, "Pos (" & Str_NP
(E
.NP
) & ')');
2591 Kill_Ampersand
:= True;
2594 Append
(Result
, "Rest");
2597 Append
(Result
, "(+ " & Str_PP
(E
.PP
) & ')');
2599 when PC_Pred_Func
=>
2600 Append
(Result
, "(+ " & Str_BF
(E
.BF
) & ')');
2603 Append
(Result
, "RPos (" & E
.Nat
& ')');
2606 Append
(Result
, "RPos (" & Str_NF
(E
.NF
) & ')');
2609 Append
(Result
, "RPos (" & Str_NP
(E
.NP
) & ')');
2612 Append
(Result
, "RTab (" & E
.Nat
& ')');
2615 Append
(Result
, "RTab (" & Str_NF
(E
.NF
) & ')');
2618 Append
(Result
, "RTab (" & Str_NP
(E
.NP
) & ')');
2621 Append
(Result
, "Setcur (" & Str_NP
(E
.Var
) & ')');
2624 Append
(Result
, "Span ('" & E
.Char
& "')");
2627 Append
(Result
, "Span (" & Image
(To_Sequence
(E
.CS
)) & ')');
2630 Append
(Result
, "Span (" & Str_VF
(E
.VF
) & ')');
2633 Append
(Result
, "Span (" & Str_VP
(E
.VP
) & ')');
2636 Append
(Result
, Image
(E
.Str
.all));
2639 Append
(Result
, Image
(E
.Str2
));
2642 Append
(Result
, Image
(E
.Str3
));
2645 Append
(Result
, Image
(E
.Str4
));
2648 Append
(Result
, Image
(E
.Str5
));
2651 Append
(Result
, Image
(E
.Str6
));
2653 when PC_String_VF
=>
2654 Append
(Result
, "(+" & Str_VF
(E
.VF
) & ')');
2656 when PC_String_VP
=>
2657 Append
(Result
, "(+" & Str_VP
(E
.VP
) & ')');
2660 Append
(Result
, "Succeed");
2663 Append
(Result
, "Tab (" & E
.Nat
& ')');
2666 Append
(Result
, "Tab (" & Str_NF
(E
.NF
) & ')');
2669 Append
(Result
, "Tab (" & Str_NP
(E
.NP
) & ')');
2671 when PC_Write_Imm
=>
2672 Append
(Result
, '(');
2673 Image_Seq
(E
, Refs
(E
.Index
- 1), True);
2674 Append
(Result
, " * " & Str_FP
(Refs
(E
.Index
- 1).FP
));
2675 ER
:= Refs
(E
.Index
- 1).Pthen
;
2677 when PC_Write_OnM
=>
2678 Append
(Result
, '(');
2679 Image_Seq
(E
.Pthen
, Refs
(E
.Index
- 1), True);
2680 Append
(Result
, " ** " & Str_FP
(Refs
(E
.Index
- 1).FP
));
2681 ER
:= Refs
(E
.Index
- 1).Pthen
;
2683 -- Other pattern codes should not appear as leading elements
2694 Append
(Result
, "???");
2705 procedure Image_Seq
(E
: PE_Ptr
; Succ
: PE_Ptr
; Paren
: Boolean) is
2707 Mult
: Boolean := False;
2708 Indx
: Natural := Length
(Result
);
2711 -- The image of EOP is "" (the null string)
2714 Append
(Result
, """""");
2716 -- Else generate appropriate concatenation sequence
2721 exit when E1
= Succ
;
2725 if Kill_Ampersand
then
2726 Kill_Ampersand
:= False;
2728 Append
(Result
, " & ");
2733 if Mult
and Paren
then
2734 Insert
(Result
, Indx
+ 1, "(");
2735 Append
(Result
, ")");
2739 -- Start of processing for Image
2742 Build_Ref_Array
(P
.P
, Refs
);
2743 Image_Seq
(P
.P
, EOP
, False);
2751 function Is_In
(C
: Character; Str
: String) return Boolean is
2753 for J
in Str
'Range loop
2766 function Len
(Count
: Natural) return Pattern
is
2768 -- Note, the following is not just an optimization, it is needed
2769 -- to ensure that Arbno (Len (0)) does not generate an infinite
2770 -- matching loop (since PC_Len_Nat is OK_For_Simple_Arbno).
2773 return (AFC
with 0, new PE
'(PC_Null, 1, EOP));
2776 return (AFC with 0, new PE'(PC_Len_Nat
, 1, EOP
, Count
));
2780 function Len
(Count
: Natural_Func
) return Pattern
is
2782 return (AFC
with 0, new PE
'(PC_Len_NF, 1, EOP, Count));
2785 function Len (Count : access Natural) return Pattern is
2787 return (AFC with 0, new PE'(PC_Len_NP
, 1, EOP
, Natural_Ptr
(Count
)));
2794 procedure Logic_Error
is
2797 (Program_Error
'Identity,
2798 "Internal logic error in GNAT.Spitbol.Patterns");
2810 Start
, Stop
: Natural;
2814 XMatchD
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2816 XMatch
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2827 Start
, Stop
: Natural;
2828 subtype String1
is String (1 .. Subject
'Length);
2832 XMatchD
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2834 XMatch
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2841 (Subject
: VString_Var
;
2846 Start
, Stop
: Natural;
2850 XMatchD
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2852 XMatch
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2859 (Subject
'Unrestricted_Access.all,
2860 Start
, Stop
, Get_String
(Replace
).all);
2866 (Subject
: VString_Var
;
2871 Start
, Stop
: Natural;
2875 XMatchD
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2877 XMatch
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2884 (Subject
'Unrestricted_Access.all, Start
, Stop
, Replace
);
2893 Start
, Stop
: Natural;
2897 XMatchD
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2899 XMatch
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2908 Start
, Stop
: Natural;
2909 subtype String1
is String (1 .. Subject
'Length);
2912 XMatchD
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2914 XMatch
(String1
(Subject
), Pat
.P
, Pat
.Stk
, Start
, Stop
);
2919 (Subject
: in out VString
;
2923 Start
, Stop
: Natural;
2927 XMatchD
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2929 XMatch
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2933 Replace_Slice
(Subject
, Start
, Stop
, Get_String
(Replace
).all);
2938 (Subject
: in out VString
;
2942 Start
, Stop
: Natural;
2946 XMatchD
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2948 XMatch
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
2952 Replace_Slice
(Subject
, Start
, Stop
, Replace
);
2961 Pat_Len
: constant Natural := Pat
'Length;
2962 Sub_Len
: constant Natural := Length
(Subject
);
2963 Sub_Str
: constant String_Access
:= Get_String
(Subject
);
2966 if Anchored_Mode
then
2967 if Pat_Len
> Sub_Len
then
2970 return Pat
= Sub_Str
.all (1 .. Pat_Len
);
2974 for J
in 1 .. Sub_Len
- Pat_Len
+ 1 loop
2975 if Pat
= Sub_Str
.all (J
.. J
+ (Pat_Len
- 1)) then
2989 Pat_Len
: constant Natural := Pat
'Length;
2990 Sub_Len
: constant Natural := Subject
'Length;
2991 SFirst
: constant Natural := Subject
'First;
2994 if Anchored_Mode
then
2995 if Pat_Len
> Sub_Len
then
2998 return Pat
= Subject
(SFirst
.. SFirst
+ Pat_Len
- 1);
3002 for J
in SFirst
.. SFirst
+ Sub_Len
- Pat_Len
loop
3003 if Pat
= Subject
(J
.. J
+ (Pat_Len
- 1)) then
3013 (Subject
: VString_Var
;
3018 Start
, Stop
: Natural;
3022 XMatchD
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3024 XMatch
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3031 (Subject
'Unrestricted_Access.all,
3032 Start
, Stop
, Get_String
(Replace
).all);
3038 (Subject
: VString_Var
;
3043 Start
, Stop
: Natural;
3047 XMatchD
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3049 XMatch
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3056 (Subject
'Unrestricted_Access.all, Start
, Stop
, Replace
);
3065 Start
, Stop
: Natural;
3069 XMatchD
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3071 XMatch
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3079 Start
, Stop
: Natural;
3080 subtype String1
is String (1 .. Subject
'Length);
3084 XMatchD
(String1
(Subject
), S_To_PE
(Pat
), 0, Start
, Stop
);
3086 XMatch
(String1
(Subject
), S_To_PE
(Pat
), 0, Start
, Stop
);
3091 (Subject
: in out VString
;
3095 Start
, Stop
: Natural;
3099 XMatchD
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3101 XMatch
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3105 Replace_Slice
(Subject
, Start
, Stop
, Get_String
(Replace
).all);
3110 (Subject
: in out VString
;
3114 Start
, Stop
: Natural;
3118 XMatchD
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3120 XMatch
(Get_String
(Subject
).all, S_To_PE
(Pat
), 0, Start
, Stop
);
3124 Replace_Slice
(Subject
, Start
, Stop
, Replace
);
3129 (Subject
: VString_Var
;
3131 Result
: Match_Result_Var
)
3134 Start
, Stop
: Natural;
3138 XMatchD
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
3140 XMatch
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
3144 Result
'Unrestricted_Access.all.Var
:= null;
3148 Result
'Unrestricted_Access.all.Var
:= Subject
'Unrestricted_Access;
3149 Result
'Unrestricted_Access.all.Start
:= Start
;
3150 Result
'Unrestricted_Access.all.Stop
:= Stop
;
3156 (Subject
: in out VString
;
3158 Result
: out Match_Result
)
3160 Start
, Stop
: Natural;
3164 XMatchD
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
3166 XMatch
(Get_String
(Subject
).all, Pat
.P
, Pat
.Stk
, Start
, Stop
);
3173 Result
.Var
:= Subject
'Unrestricted_Access;
3174 Result
.Start
:= Start
;
3175 Result
.Stop
:= Stop
;
3183 procedure New_LineD
is
3185 if Internal_Debug
then
3194 function NotAny
(Str
: String) return Pattern
is
3196 return (AFC
with 0, new PE
'(PC_NotAny_CS, 1, EOP, To_Set (Str)));
3199 function NotAny (Str : VString) return Pattern is
3201 return NotAny (S (Str));
3204 function NotAny (Str : Character) return Pattern is
3206 return (AFC with 0, new PE'(PC_NotAny_CH
, 1, EOP
, Str
));
3209 function NotAny
(Str
: Character_Set
) return Pattern
is
3211 return (AFC
with 0, new PE
'(PC_NotAny_CS, 1, EOP, Str));
3214 function NotAny (Str : access VString) return Pattern is
3216 return (AFC with 0, new PE'(PC_NotAny_VP
, 1, EOP
, VString_Ptr
(Str
)));
3219 function NotAny
(Str
: VString_Func
) return Pattern
is
3221 return (AFC
with 0, new PE
'(PC_NotAny_VF, 1, EOP, Str));
3228 function NSpan (Str : String) return Pattern is
3230 return (AFC with 0, new PE'(PC_NSpan_CS
, 1, EOP
, To_Set
(Str
)));
3233 function NSpan
(Str
: VString
) return Pattern
is
3235 return NSpan
(S
(Str
));
3238 function NSpan
(Str
: Character) return Pattern
is
3240 return (AFC
with 0, new PE
'(PC_NSpan_CH, 1, EOP, Str));
3243 function NSpan (Str : Character_Set) return Pattern is
3245 return (AFC with 0, new PE'(PC_NSpan_CS
, 1, EOP
, Str
));
3248 function NSpan
(Str
: access VString
) return Pattern
is
3250 return (AFC
with 0, new PE
'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str)));
3253 function NSpan (Str : VString_Func) return Pattern is
3255 return (AFC with 0, new PE'(PC_NSpan_VF
, 1, EOP
, Str
));
3262 function Pos
(Count
: Natural) return Pattern
is
3264 return (AFC
with 0, new PE
'(PC_Pos_Nat, 1, EOP, Count));
3267 function Pos (Count : Natural_Func) return Pattern is
3269 return (AFC with 0, new PE'(PC_Pos_NF
, 1, EOP
, Count
));
3272 function Pos
(Count
: access Natural) return Pattern
is
3274 return (AFC
with 0, new PE
'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count)));
3281 procedure PutD (Str : String) is
3283 if Internal_Debug then
3292 procedure Put_LineD (Str : String) is
3294 if Internal_Debug then
3304 (Result : in out Match_Result;
3308 if Result.Var /= null then
3313 Get_String (Replace).all);
3322 function Rest return Pattern is
3324 return (AFC with 0, new PE'(PC_Rest
, 1, EOP
));
3331 function Rpos
(Count
: Natural) return Pattern
is
3333 return (AFC
with 0, new PE
'(PC_RPos_Nat, 1, EOP, Count));
3336 function Rpos (Count : Natural_Func) return Pattern is
3338 return (AFC with 0, new PE'(PC_RPos_NF
, 1, EOP
, Count
));
3341 function Rpos
(Count
: access Natural) return Pattern
is
3343 return (AFC
with 0, new PE
'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count)));
3350 function Rtab (Count : Natural) return Pattern is
3352 return (AFC with 0, new PE'(PC_RTab_Nat
, 1, EOP
, Count
));
3355 function Rtab
(Count
: Natural_Func
) return Pattern
is
3357 return (AFC
with 0, new PE
'(PC_RTab_NF, 1, EOP, Count));
3360 function Rtab (Count : access Natural) return Pattern is
3362 return (AFC with 0, new PE'(PC_RTab_NP
, 1, EOP
, Natural_Ptr
(Count
)));
3369 function S_To_PE
(Str
: PString
) return PE_Ptr
is
3370 Len
: constant Natural := Str
'Length;
3375 return new PE
'(PC_Null, 1, EOP);
3378 return new PE'(PC_Char
, 1, EOP
, Str
(1));
3381 return new PE
'(PC_String_2, 1, EOP, Str);
3384 return new PE'(PC_String_3
, 1, EOP
, Str
);
3387 return new PE
'(PC_String_4, 1, EOP, Str);
3390 return new PE'(PC_String_5
, 1, EOP
, Str
);
3393 return new PE
'(PC_String_6, 1, EOP, Str);
3396 return new PE'(PC_String
, 1, EOP
, new String'(Str));
3405 -- Note: this procedure is not used by the normal concatenation circuit,
3406 -- since other fixups are required on the left operand in this case, and
3407 -- they might as well be done all together.
3409 procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is
3412 Uninitialized_Pattern;
3414 elsif Pat = EOP then
3419 Refs : Ref_Array (1 .. Pat.Index);
3420 -- We build a reference array for L whose N'th element points to
3421 -- the pattern element of L whose original Index value is N.
3426 Build_Ref_Array (Pat, Refs);
3428 for J in Refs'Range loop
3431 if P.Pthen = EOP then
3435 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
3447 function Setcur (Var : access Natural) return Pattern is
3449 return (AFC with 0, new PE'(PC_Setcur
, 1, EOP
, Natural_Ptr
(Var
)));
3456 function Span
(Str
: String) return Pattern
is
3458 return (AFC
with 0, new PE
'(PC_Span_CS, 1, EOP, To_Set (Str)));
3461 function Span (Str : VString) return Pattern is
3463 return Span (S (Str));
3466 function Span (Str : Character) return Pattern is
3468 return (AFC with 0, new PE'(PC_Span_CH
, 1, EOP
, Str
));
3471 function Span
(Str
: Character_Set
) return Pattern
is
3473 return (AFC
with 0, new PE
'(PC_Span_CS, 1, EOP, Str));
3476 function Span (Str : access VString) return Pattern is
3478 return (AFC with 0, new PE'(PC_Span_VP
, 1, EOP
, VString_Ptr
(Str
)));
3481 function Span
(Str
: VString_Func
) return Pattern
is
3483 return (AFC
with 0, new PE
'(PC_Span_VF, 1, EOP, Str));
3490 function Str_BF (A : Boolean_Func) return String is
3491 function To_A is new Unchecked_Conversion (Boolean_Func, Address);
3494 return "BF(" & Image (To_A (A)) & ')';
3501 function Str_FP (A : File_Ptr) return String is
3503 return "FP(" & Image (A.all'Address) & ')';
3510 function Str_NF (A : Natural_Func) return String is
3511 function To_A is new Unchecked_Conversion (Natural_Func, Address);
3514 return "NF(" & Image (To_A (A)) & ')';
3521 function Str_NP (A : Natural_Ptr) return String is
3523 return "NP(" & Image (A.all'Address) & ')';
3530 function Str_PP (A : Pattern_Ptr) return String is
3532 return "PP(" & Image (A.all'Address) & ')';
3539 function Str_VF (A : VString_Func) return String is
3540 function To_A is new Unchecked_Conversion (VString_Func, Address);
3543 return "VF(" & Image (To_A (A)) & ')';
3550 function Str_VP (A : VString_Ptr) return String is
3552 return "VP(" & Image (A.all'Address) & ')';
3559 function Succeed return Pattern is
3561 return (AFC with 1, new PE'(PC_Succeed
, 1, EOP
));
3568 function Tab
(Count
: Natural) return Pattern
is
3570 return (AFC
with 0, new PE
'(PC_Tab_Nat, 1, EOP, Count));
3573 function Tab (Count : Natural_Func) return Pattern is
3575 return (AFC with 0, new PE'(PC_Tab_NF
, 1, EOP
, Count
));
3578 function Tab
(Count
: access Natural) return Pattern
is
3580 return (AFC
with 0, new PE
'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count)));
3583 ---------------------------
3584 -- Uninitialized_Pattern --
3585 ---------------------------
3587 procedure Uninitialized_Pattern is
3590 (Program_Error'Identity,
3591 "uninitialized value of type GNAT.Spitbol.Patterns.Pattern");
3592 end Uninitialized_Pattern;
3602 Start : out Natural;
3606 -- Pointer to current pattern node. Initialized from Pat_P, and then
3607 -- updated as the match proceeds through its constituent elements.
3609 Length : constant Natural := Subject'Length;
3610 -- Length of string (= Subject'Last, since Subject'First is always 1)
3612 Cursor : Integer := 0;
3613 -- If the value is non-negative, then this value is the index showing
3614 -- the current position of the match in the subject string. The next
3615 -- character to be matched is at Subject (Cursor + 1). Note that since
3616 -- our view of the subject string in XMatch always has a lower bound
3617 -- of one, regardless of original bounds, that this definition exactly
3618 -- corresponds to the cursor value as referenced by functions like Pos.
3620 -- If the value is negative, then this is a saved stack pointer,
3621 -- typically a base pointer of an inner or outer region. Cursor
3622 -- temporarily holds such a value when it is popped from the stack
3623 -- by Fail. In all cases, Cursor is reset to a proper non-negative
3624 -- cursor value before the match proceeds (e.g. by propagating the
3625 -- failure and popping a "real" cursor value from the stack.
3627 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
3628 -- Dummy pattern element used in the unanchored case.
3631 -- The pattern matching failure stack for this call to Match
3633 Stack_Ptr : Stack_Range;
3634 -- Current stack pointer. This points to the top element of the stack
3635 -- that is currently in use. At the outer level this is the special
3636 -- entry placed on the stack according to the anchor mode.
3638 Stack_Init : constant Stack_Range := Stack'First + 1;
3639 -- This is the initial value of the Stack_Ptr and Stack_Base. The
3640 -- initial (Stack'First) element of the stack is not used so that
3641 -- when we pop the last element off, Stack_Ptr is still in range.
3643 Stack_Base : Stack_Range;
3644 -- This value is the stack base value, i.e. the stack pointer for the
3645 -- first history stack entry in the current stack region. See separate
3646 -- section on handling of recursive pattern matches.
3648 Assign_OnM : Boolean := False;
3649 -- Set True if assign-on-match or write-on-match operations may be
3650 -- present in the history stack, which must then be scanned on a
3651 -- successful match.
3653 procedure Pop_Region;
3654 pragma Inline (Pop_Region);
3655 -- Used at the end of processing of an inner region. if the inner
3656 -- region left no stack entries, then all trace of it is removed.
3657 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
3658 -- handling of alternatives in the inner region.
3660 procedure Push (Node : PE_Ptr);
3661 pragma Inline (Push);
3662 -- Make entry in pattern matching stack with current cursor valeu
3664 procedure Push_Region;
3665 pragma Inline (Push_Region);
3666 -- This procedure makes a new region on the history stack. The
3667 -- caller first establishes the special entry on the stack, but
3668 -- does not push the stack pointer. Then this call stacks a
3669 -- PC_Remove_Region node, on top of this entry, using the cursor
3670 -- field of the PC_Remove_Region entry to save the outer level
3671 -- stack base value, and resets the stack base to point to this
3672 -- PC_Remove_Region node.
3678 procedure Pop_Region is
3680 -- If nothing was pushed in the inner region, we can just get
3681 -- rid of it entirely, leaving no traces that it was ever there
3683 if Stack_Ptr = Stack_Base then
3684 Stack_Ptr := Stack_Base - 2;
3685 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
3687 -- If stuff was pushed in the inner region, then we have to
3688 -- push a PC_R_Restore node so that we properly handle possible
3689 -- rematches within the region.
3692 Stack_Ptr := Stack_Ptr + 1;
3693 Stack (Stack_Ptr).Cursor := Stack_Base;
3694 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
3695 Stack_Base := Stack (Stack_Base).Cursor;
3703 procedure Push (Node : PE_Ptr) is
3705 Stack_Ptr := Stack_Ptr + 1;
3706 Stack (Stack_Ptr).Cursor := Cursor;
3707 Stack (Stack_Ptr).Node := Node;
3714 procedure Push_Region is
3716 Stack_Ptr := Stack_Ptr + 2;
3717 Stack (Stack_Ptr).Cursor := Stack_Base;
3718 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
3719 Stack_Base := Stack_Ptr;
3722 -- Start of processing for XMatch
3725 if Pat_P = null then
3726 Uninitialized_Pattern;
3729 -- Check we have enough stack for this pattern. This check deals with
3730 -- every possibility except a match of a recursive pattern, where we
3731 -- make a check at each recursion level.
3733 if Pat_S >= Stack_Size - 1 then
3734 raise Pattern_Stack_Overflow;
3737 -- In anchored mode, the bottom entry on the stack is an abort entry
3739 if Anchored_Mode then
3740 Stack (Stack_Init).Node := CP_Cancel'Access;
3741 Stack (Stack_Init).Cursor := 0;
3743 -- In unanchored more, the bottom entry on the stack references
3744 -- the special pattern element PE_Unanchored, whose Pthen field
3745 -- points to the initial pattern element. The cursor value in this
3746 -- entry is the number of anchor moves so far.
3749 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
3750 Stack (Stack_Init).Cursor := 0;
3753 Stack_Ptr := Stack_Init;
3754 Stack_Base := Stack_Ptr;
3759 -----------------------------------------
3760 -- Main Pattern Matching State Control --
3761 -----------------------------------------
3763 -- This is a state machine which uses gotos to change state. The
3764 -- initial state is Match, to initiate the matching of the first
3765 -- element, so the goto Match above starts the match. In the
3766 -- following descriptions, we indicate the global values that
3767 -- are relevant for the state transition.
3769 -- Come here if entire match fails
3776 -- Come here if entire match succeeds
3778 -- Cursor current position in subject string
3781 Start := Stack (Stack_Init).Cursor + 1;
3784 -- Scan history stack for deferred assignments or writes
3787 for S in Stack_Init .. Stack_Ptr loop
3788 if Stack (S).Node = CP_Assign'Access then
3790 Inner_Base : constant Stack_Range :=
3791 Stack (S + 1).Cursor;
3792 Special_Entry : constant Stack_Range :=
3794 Node_OnM : constant PE_Ptr :=
3795 Stack (Special_Entry).Node;
3796 Start : constant Natural :=
3797 Stack (Special_Entry).Cursor + 1;
3798 Stop : constant Natural := Stack (S).Cursor;
3801 if Node_OnM.Pcode = PC_Assign_OnM then
3802 Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
3804 elsif Node_OnM.Pcode = PC_Write_OnM then
3805 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
3817 -- Come here if attempt to match current element fails
3819 -- Stack_Base current stack base
3820 -- Stack_Ptr current stack pointer
3823 Cursor := Stack (Stack_Ptr).Cursor;
3824 Node := Stack (Stack_Ptr).Node;
3825 Stack_Ptr := Stack_Ptr - 1;
3828 -- Come here if attempt to match current element succeeds
3830 -- Cursor current position in subject string
3831 -- Node pointer to node successfully matched
3832 -- Stack_Base current stack base
3833 -- Stack_Ptr current stack pointer
3838 -- Come here to match the next pattern element
3840 -- Cursor current position in subject string
3841 -- Node pointer to node to be matched
3842 -- Stack_Base current stack base
3843 -- Stack_Ptr current stack pointer
3847 --------------------------------------------------
3848 -- Main Pattern Match Element Matching Routines --
3849 --------------------------------------------------
3851 -- Here is the case statement that processes the current node. The
3852 -- processing for each element does one of five things:
3854 -- goto Succeed to move to the successor
3855 -- goto Match_Succeed if the entire match succeeds
3856 -- goto Match_Fail if the entire match fails
3857 -- goto Fail to signal failure of current match
3859 -- Processing is NOT allowed to fall through
3875 -- Any (one character case)
3879 and then Subject (Cursor + 1) = Node.Char
3881 Cursor := Cursor + 1;
3887 -- Any (character set case)
3891 and then Is_In (Subject (Cursor + 1), Node.CS)
3893 Cursor := Cursor + 1;
3899 -- Any (string function case)
3901 when PC_Any_VF => declare
3902 U : constant VString := Node.VF.all;
3903 Str : constant String_Access := Get_String (U);
3907 and then Is_In (Subject (Cursor + 1), Str.all)
3909 Cursor := Cursor + 1;
3916 -- Any (string pointer case)
3918 when PC_Any_VP => declare
3919 Str : constant String_Access := Get_String (Node.VP.all);
3923 and then Is_In (Subject (Cursor + 1), Str.all)
3925 Cursor := Cursor + 1;
3932 -- Arb (initial match)
3942 if Cursor < Length then
3943 Cursor := Cursor + 1;
3950 -- Arbno_S (simple Arbno initialize). This is the node that
3951 -- initiates the match of a simple Arbno structure.
3958 -- Arbno_X (Arbno initialize). This is the node that initiates
3959 -- the match of a complex Arbno structure.
3966 -- Arbno_Y (Arbno rematch). This is the node that is executed
3967 -- following successful matching of one instance of a complex
3970 when PC_Arbno_Y => declare
3971 Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor);
3976 -- If arbno extension matched null, then immediately fail
3982 -- Here we must do a stack check to make sure enough stack
3983 -- is left. This check will happen once for each instance of
3984 -- the Arbno pattern that is matched. The Nat field of a
3985 -- PC_Arbno pattern contains the maximum stack entries needed
3986 -- for the Arbno with one instance and the successor pattern
3988 if Stack_Ptr + Node.Nat >= Stack'Last then
3989 raise Pattern_Stack_Overflow;
3995 -- Assign. If this node is executed, it means the assign-on-match
3996 -- or write-on-match operation will not happen after all, so we
3997 -- is propagate the failure, removing the PC_Assign node.
4002 -- Assign immediate. This node performs the actual assignment.
4004 when PC_Assign_Imm =>
4007 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4011 -- Assign on match. This node sets up for the eventual assignment
4013 when PC_Assign_OnM =>
4014 Stack (Stack_Base - 1).Node := Node;
4015 Push (CP_Assign'Access);
4023 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
4026 elsif Subject (Cursor + 1) = '(' then
4028 Paren_Count : Natural := 1;
4032 Cursor := Cursor + 1;
4034 if Cursor >= Length then
4037 elsif Subject (Cursor + 1) = '(' then
4038 Paren_Count := Paren_Count + 1;
4040 elsif Subject (Cursor + 1) = ')' then
4041 Paren_Count := Paren_Count - 1;
4042 exit when Paren_Count = 0;
4048 Cursor := Cursor + 1;
4052 -- Break (one character case)
4055 while Cursor < Length loop
4056 if Subject (Cursor + 1) = Node.Char then
4059 Cursor := Cursor + 1;
4065 -- Break (character set case)
4068 while Cursor < Length loop
4069 if Is_In (Subject (Cursor + 1), Node.CS) then
4072 Cursor := Cursor + 1;
4078 -- Break (string function case)
4080 when PC_Break_VF => declare
4081 U : constant VString := Node.VF.all;
4082 Str : constant String_Access := Get_String (U);
4085 while Cursor < Length loop
4086 if Is_In (Subject (Cursor + 1), Str.all) then
4089 Cursor := Cursor + 1;
4096 -- Break (string pointer case)
4098 when PC_Break_VP => declare
4099 Str : String_Access := Get_String (Node.VP.all);
4102 while Cursor < Length loop
4103 if Is_In (Subject (Cursor + 1), Str.all) then
4106 Cursor := Cursor + 1;
4113 -- BreakX (one character case)
4115 when PC_BreakX_CH =>
4116 while Cursor < Length loop
4117 if Subject (Cursor + 1) = Node.Char then
4120 Cursor := Cursor + 1;
4126 -- BreakX (character set case)
4128 when PC_BreakX_CS =>
4129 while Cursor < Length loop
4130 if Is_In (Subject (Cursor + 1), Node.CS) then
4133 Cursor := Cursor + 1;
4139 -- BreakX (string function case)
4141 when PC_BreakX_VF => declare
4142 U : constant VString := Node.VF.all;
4143 Str : constant String_Access := Get_String (U);
4146 while Cursor < Length loop
4147 if Is_In (Subject (Cursor + 1), Str.all) then
4150 Cursor := Cursor + 1;
4157 -- BreakX (string pointer case)
4159 when PC_BreakX_VP => declare
4160 Str : String_Access := Get_String (Node.VP.all);
4163 while Cursor < Length loop
4164 if Is_In (Subject (Cursor + 1), Str.all) then
4167 Cursor := Cursor + 1;
4174 -- BreakX_X (BreakX extension). See section on "Compound Pattern
4175 -- Structures". This node is the alternative that is stacked to
4176 -- skip past the break character and extend the break.
4179 Cursor := Cursor + 1;
4182 -- Character (one character string)
4186 and then Subject (Cursor + 1) = Node.Char
4188 Cursor := Cursor + 1;
4197 if Stack_Base = Stack_Init then
4200 -- End of recursive inner match. See separate section on
4201 -- handing of recursive pattern matches for details.
4204 Node := Stack (Stack_Base - 1).Node;
4214 -- Fence (built in pattern)
4217 Push (CP_Cancel'Access);
4220 -- Fence function node X. This is the node that gets control
4221 -- after a successful match of the fenced pattern.
4224 Stack_Ptr := Stack_Ptr + 1;
4225 Stack (Stack_Ptr).Cursor := Stack_Base;
4226 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
4227 Stack_Base := Stack (Stack_Base).Cursor;
4230 -- Fence function node Y. This is the node that gets control on
4231 -- a failure that occurs after the fenced pattern has matched.
4233 -- Note: the Cursor at this stage is actually the inner stack
4234 -- base value. We don't reset this, but we do use it to strip
4235 -- off all the entries made by the fenced pattern.
4238 Stack_Ptr := Cursor - 2;
4241 -- Len (integer case)
4244 if Cursor + Node.Nat > Length then
4247 Cursor := Cursor + Node.Nat;
4251 -- Len (Integer function case)
4253 when PC_Len_NF => declare
4254 N : constant Natural := Node.NF.all;
4257 if Cursor + N > Length then
4260 Cursor := Cursor + N;
4265 -- Len (integer pointer case)
4268 if Cursor + Node.NP.all > Length then
4271 Cursor := Cursor + Node.NP.all;
4275 -- NotAny (one character case)
4277 when PC_NotAny_CH =>
4279 and then Subject (Cursor + 1) /= Node.Char
4281 Cursor := Cursor + 1;
4287 -- NotAny (character set case)
4289 when PC_NotAny_CS =>
4291 and then not Is_In (Subject (Cursor + 1), Node.CS)
4293 Cursor := Cursor + 1;
4299 -- NotAny (string function case)
4301 when PC_NotAny_VF => declare
4302 U : constant VString := Node.VF.all;
4303 Str : constant String_Access := Get_String (U);
4308 not Is_In (Subject (Cursor + 1), Str.all)
4310 Cursor := Cursor + 1;
4317 -- NotAny (string pointer case)
4319 when PC_NotAny_VP => declare
4320 Str : String_Access := Get_String (Node.VP.all);
4325 not Is_In (Subject (Cursor + 1), Str.all)
4327 Cursor := Cursor + 1;
4334 -- NSpan (one character case)
4337 while Cursor < Length
4338 and then Subject (Cursor + 1) = Node.Char
4340 Cursor := Cursor + 1;
4345 -- NSpan (character set case)
4348 while Cursor < Length
4349 and then Is_In (Subject (Cursor + 1), Node.CS)
4351 Cursor := Cursor + 1;
4356 -- NSpan (string function case)
4358 when PC_NSpan_VF => declare
4359 U : constant VString := Node.VF.all;
4360 Str : constant String_Access := Get_String (U);
4363 while Cursor < Length
4364 and then Is_In (Subject (Cursor + 1), Str.all)
4366 Cursor := Cursor + 1;
4372 -- NSpan (string pointer case)
4374 when PC_NSpan_VP => declare
4375 Str : String_Access := Get_String (Node.VP.all);
4378 while Cursor < Length
4379 and then Is_In (Subject (Cursor + 1), Str.all)
4381 Cursor := Cursor + 1;
4392 -- Pos (integer case)
4395 if Cursor = Node.Nat then
4401 -- Pos (Integer function case)
4403 when PC_Pos_NF => declare
4404 N : constant Natural := Node.NF.all;
4414 -- Pos (integer pointer case)
4417 if Cursor = Node.NP.all then
4423 -- Predicate function
4425 when PC_Pred_Func =>
4432 -- Region Enter. Initiate new pattern history stack region
4435 Stack (Stack_Ptr + 1).Cursor := Cursor;
4439 -- Region Remove node. This is the node stacked by an R_Enter.
4440 -- It removes the special format stack entry right underneath, and
4441 -- then restores the outer level stack base and signals failure.
4443 -- Note: the cursor value at this stage is actually the (negative)
4444 -- stack base value for the outer level.
4447 Stack_Base := Cursor;
4448 Stack_Ptr := Stack_Ptr - 1;
4451 -- Region restore node. This is the node stacked at the end of an
4452 -- inner level match. Its function is to restore the inner level
4453 -- region, so that alternatives in this region can be sought.
4455 -- Note: the Cursor at this stage is actually the negative of the
4456 -- inner stack base value, which we use to restore the inner region.
4458 when PC_R_Restore =>
4459 Stack_Base := Cursor;
4468 -- Initiate recursive match (pattern pointer case)
4471 Stack (Stack_Ptr + 1).Node := Node.Pthen;
4474 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
4475 raise Pattern_Stack_Overflow;
4477 Node := Node.PP.all.P;
4481 -- RPos (integer case)
4484 if Cursor = (Length - Node.Nat) then
4490 -- RPos (integer function case)
4492 when PC_RPos_NF => declare
4493 N : constant Natural := Node.NF.all;
4496 if Length - Cursor = N then
4503 -- RPos (integer pointer case)
4506 if Cursor = (Length - Node.NP.all) then
4512 -- RTab (integer case)
4515 if Cursor <= (Length - Node.Nat) then
4516 Cursor := Length - Node.Nat;
4522 -- RTab (integer function case)
4524 when PC_RTab_NF => declare
4525 N : constant Natural := Node.NF.all;
4528 if Length - Cursor >= N then
4529 Cursor := Length - N;
4536 -- RTab (integer pointer case)
4539 if Cursor <= (Length - Node.NP.all) then
4540 Cursor := Length - Node.NP.all;
4546 -- Cursor assignment
4549 Node.Var.all := Cursor;
4552 -- Span (one character case)
4554 when PC_Span_CH => declare
4555 P : Natural := Cursor;
4559 and then Subject (P + 1) = Node.Char
4572 -- Span (character set case)
4574 when PC_Span_CS => declare
4575 P : Natural := Cursor;
4579 and then Is_In (Subject (P + 1), Node.CS)
4592 -- Span (string function case)
4594 when PC_Span_VF => declare
4595 U : constant VString := Node.VF.all;
4596 Str : constant String_Access := Get_String (U);
4597 P : Natural := Cursor;
4601 and then Is_In (Subject (P + 1), Str.all)
4614 -- Span (string pointer case)
4616 when PC_Span_VP => declare
4617 Str : String_Access := Get_String (Node.VP.all);
4618 P : Natural := Cursor;
4622 and then Is_In (Subject (P + 1), Str.all)
4635 -- String (two character case)
4638 if (Length - Cursor) >= 2
4639 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
4641 Cursor := Cursor + 2;
4647 -- String (three character case)
4650 if (Length - Cursor) >= 3
4651 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
4653 Cursor := Cursor + 3;
4659 -- String (four character case)
4662 if (Length - Cursor) >= 4
4663 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
4665 Cursor := Cursor + 4;
4671 -- String (five character case)
4674 if (Length - Cursor) >= 5
4675 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
4677 Cursor := Cursor + 5;
4683 -- String (six character case)
4686 if (Length - Cursor) >= 6
4687 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
4689 Cursor := Cursor + 6;
4695 -- String (case of more than six characters)
4697 when PC_String => declare
4698 Len : constant Natural := Node.Str'Length;
4701 if (Length - Cursor) >= Len
4702 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
4704 Cursor := Cursor + Len;
4711 -- String (function case)
4713 when PC_String_VF => declare
4714 U : constant VString := Node.VF.all;
4715 Str : constant String_Access := Get_String (U);
4716 Len : constant Natural := Str'Length;
4719 if (Length - Cursor) >= Len
4720 and then Str.all = Subject (Cursor + 1 .. Cursor + Len)
4722 Cursor := Cursor + Len;
4729 -- String (pointer case)
4731 when PC_String_VP => declare
4732 S : String_Access := Get_String (Node.VP.all);
4733 Len : constant Natural := S'Length;
4736 if (Length - Cursor) >= Len
4737 and then S.all = Subject (Cursor + 1 .. Cursor + Len)
4739 Cursor := Cursor + Len;
4752 -- Tab (integer case)
4755 if Cursor <= Node.Nat then
4762 -- Tab (integer function case)
4764 when PC_Tab_NF => declare
4765 N : constant Natural := Node.NF.all;
4776 -- Tab (integer pointer case)
4779 if Cursor <= Node.NP.all then
4780 Cursor := Node.NP.all;
4786 -- Unanchored movement
4788 when PC_Unanchored =>
4790 -- All done if we tried every position
4792 if Cursor > Length then
4795 -- Otherwise extend the anchor point, and restack ourself
4798 Cursor := Cursor + 1;
4803 -- Write immediate. This node performs the actual write
4805 when PC_Write_Imm =>
4808 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4812 -- Write on match. This node sets up for the eventual write
4814 when PC_Write_OnM =>
4815 Stack (Stack_Base - 1).Node := Node;
4816 Push (CP_Assign'Access);
4823 -- We are NOT allowed to fall though this case statement, since every
4824 -- match routine must end by executing a goto to the appropriate point
4825 -- in the finite state machine model.
4835 -- Maintenance note: There is a LOT of code duplication between XMatch
4836 -- and XMatchD. This is quite intentional, the point is to avoid any
4837 -- unnecessary debugging overhead in the XMatch case, but this does mean
4838 -- that any changes to XMatchD must be mirrored in XMatch. In case of
4839 -- any major changes, the proper approach is to delete XMatch, make the
4840 -- changes to XMatchD, and then make a copy of XMatchD, removing all
4841 -- calls to Dout, and all Put and Put_Line operations. This copy becomes
4848 Start : out Natural;
4852 -- Pointer to current pattern node. Initialized from Pat_P, and then
4853 -- updated as the match proceeds through its constituent elements.
4855 Length : constant Natural := Subject'Length;
4856 -- Length of string (= Subject'Last, since Subject'First is always 1)
4858 Cursor : Integer := 0;
4859 -- If the value is non-negative, then this value is the index showing
4860 -- the current position of the match in the subject string. The next
4861 -- character to be matched is at Subject (Cursor + 1). Note that since
4862 -- our view of the subject string in XMatch always has a lower bound
4863 -- of one, regardless of original bounds, that this definition exactly
4864 -- corresponds to the cursor value as referenced by functions like Pos.
4866 -- If the value is negative, then this is a saved stack pointer,
4867 -- typically a base pointer of an inner or outer region. Cursor
4868 -- temporarily holds such a value when it is popped from the stack
4869 -- by Fail. In all cases, Cursor is reset to a proper non-negative
4870 -- cursor value before the match proceeds (e.g. by propagating the
4871 -- failure and popping a "real" cursor value from the stack.
4873 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
4874 -- Dummy pattern element used in the unanchored case.
4876 Region_Level : Natural := 0;
4877 -- Keeps track of recursive region level. This is used only for
4878 -- debugging, it is the number of saved history stack base values.
4881 -- The pattern matching failure stack for this call to Match
4883 Stack_Ptr : Stack_Range;
4884 -- Current stack pointer. This points to the top element of the stack
4885 -- that is currently in use. At the outer level this is the special
4886 -- entry placed on the stack according to the anchor mode.
4888 Stack_Init : constant Stack_Range := Stack'First + 1;
4889 -- This is the initial value of the Stack_Ptr and Stack_Base. The
4890 -- initial (Stack'First) element of the stack is not used so that
4891 -- when we pop the last element off, Stack_Ptr is still in range.
4893 Stack_Base : Stack_Range;
4894 -- This value is the stack base value, i.e. the stack pointer for the
4895 -- first history stack entry in the current stack region. See separate
4896 -- section on handling of recursive pattern matches.
4898 Assign_OnM : Boolean := False;
4899 -- Set True if assign-on-match or write-on-match operations may be
4900 -- present in the history stack, which must then be scanned on a
4901 -- successful match.
4903 procedure Dout (Str : String);
4904 -- Output string to standard error with bars indicating region level.
4906 procedure Dout (Str : String; A : Character);
4907 -- Calls Dout with the string S ('A
')
4909 procedure Dout (Str : String; A : Character_Set);
4910 -- Calls Dout with the string S ("A")
4912 procedure Dout (Str : String; A : Natural);
4913 -- Calls Dout with the string S (A)
4915 procedure Dout (Str : String; A : String);
4916 -- Calls Dout with the string S ("A")
4918 function Img (P : PE_Ptr) return String;
4919 -- Returns a string of the form #nnn where nnn is P.Index
4921 procedure Pop_Region;
4922 pragma Inline (Pop_Region);
4923 -- Used at the end of processing of an inner region. if the inner
4924 -- region left no stack entries, then all trace of it is removed.
4925 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
4926 -- handling of alternatives in the inner region.
4928 procedure Push (Node : PE_Ptr);
4929 pragma Inline (Push);
4930 -- Make entry in pattern matching stack with current cursor valeu
4932 procedure Push_Region;
4933 pragma Inline (Push_Region);
4934 -- This procedure makes a new region on the history stack. The
4935 -- caller first establishes the special entry on the stack, but
4936 -- does not push the stack pointer. Then this call stacks a
4937 -- PC_Remove_Region node, on top of this entry, using the cursor
4938 -- field of the PC_Remove_Region entry to save the outer level
4939 -- stack base value, and resets the stack base to point to this
4940 -- PC_Remove_Region node.
4946 procedure Dout (Str : String) is
4948 for J in 1 .. Region_Level loop
4955 procedure Dout (Str : String; A : Character) is
4957 Dout (Str & " ('" & A & "')");
4960 procedure Dout (Str : String; A : Character_Set) is
4962 Dout (Str & " (" & Image (To_Sequence (A)) & ')');
4965 procedure Dout (Str : String; A : Natural) is
4967 Dout (Str & " (" & A & ')');
4970 procedure Dout (Str : String; A : String) is
4972 Dout (Str & " (" & Image (A) & ')');
4979 function Img (P : PE_Ptr) return String is
4981 return "#" & Integer (P.Index) & " ";
4988 procedure Pop_Region is
4990 Region_Level := Region_Level - 1;
4992 -- If nothing was pushed in the inner region, we can just get
4993 -- rid of it entirely, leaving no traces that it was ever there
4995 if Stack_Ptr = Stack_Base then
4996 Stack_Ptr := Stack_Base - 2;
4997 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
4999 -- If stuff was pushed in the inner region, then we have to
5000 -- push a PC_R_Restore node so that we properly handle possible
5001 -- rematches within the region.
5004 Stack_Ptr := Stack_Ptr + 1;
5005 Stack (Stack_Ptr).Cursor := Stack_Base;
5006 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
5007 Stack_Base := Stack (Stack_Base).Cursor;
5015 procedure Push (Node : PE_Ptr) is
5017 Stack_Ptr := Stack_Ptr + 1;
5018 Stack (Stack_Ptr).Cursor := Cursor;
5019 Stack (Stack_Ptr).Node := Node;
5026 procedure Push_Region is
5028 Region_Level := Region_Level + 1;
5029 Stack_Ptr := Stack_Ptr + 2;
5030 Stack (Stack_Ptr).Cursor := Stack_Base;
5031 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
5032 Stack_Base := Stack_Ptr;
5035 -- Start of processing for XMatchD
5039 Put_Line ("Initiating pattern match, subject = " & Image (Subject));
5040 Put ("--------------------------------------");
5042 for J in 1 .. Length loop
5047 Put_Line ("subject length = " & Length);
5049 if Pat_P = null then
5050 Uninitialized_Pattern;
5053 -- Check we have enough stack for this pattern. This check deals with
5054 -- every possibility except a match of a recursive pattern, where we
5055 -- make a check at each recursion level.
5057 if Pat_S >= Stack_Size - 1 then
5058 raise Pattern_Stack_Overflow;
5061 -- In anchored mode, the bottom entry on the stack is an abort entry
5063 if Anchored_Mode then
5064 Stack (Stack_Init).Node := CP_Cancel'Access;
5065 Stack (Stack_Init).Cursor := 0;
5067 -- In unanchored more, the bottom entry on the stack references
5068 -- the special pattern element PE_Unanchored, whose Pthen field
5069 -- points to the initial pattern element. The cursor value in this
5070 -- entry is the number of anchor moves so far.
5073 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
5074 Stack (Stack_Init).Cursor := 0;
5077 Stack_Ptr := Stack_Init;
5078 Stack_Base := Stack_Ptr;
5083 -----------------------------------------
5084 -- Main Pattern Matching State Control --
5085 -----------------------------------------
5087 -- This is a state machine which uses gotos to change state. The
5088 -- initial state is Match, to initiate the matching of the first
5089 -- element, so the goto Match above starts the match. In the
5090 -- following descriptions, we indicate the global values that
5091 -- are relevant for the state transition.
5093 -- Come here if entire match fails
5096 Dout ("match fails");
5102 -- Come here if entire match succeeds
5104 -- Cursor current position in subject string
5107 Dout ("match succeeds");
5108 Start := Stack (Stack_Init).Cursor + 1;
5110 Dout ("first matched character index = " & Start);
5111 Dout ("last matched character index = " & Stop);
5112 Dout ("matched substring = " & Image (Subject (Start .. Stop)));
5114 -- Scan history stack for deferred assignments or writes
5117 for S in Stack'First .. Stack_Ptr loop
5118 if Stack (S).Node = CP_Assign'Access then
5120 Inner_Base : constant Stack_Range :=
5121 Stack (S + 1).Cursor;
5122 Special_Entry : constant Stack_Range :=
5124 Node_OnM : constant PE_Ptr :=
5125 Stack (Special_Entry).Node;
5126 Start : constant Natural :=
5127 Stack (Special_Entry).Cursor + 1;
5128 Stop : constant Natural := Stack (S).Cursor;
5131 if Node_OnM.Pcode = PC_Assign_OnM then
5132 Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
5134 (Img (Stack (S).Node) &
5135 "deferred assignment of " &
5136 Image (Subject (Start .. Stop)));
5138 elsif Node_OnM.Pcode = PC_Write_OnM then
5139 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
5141 (Img (Stack (S).Node) &
5142 "deferred write of " &
5143 Image (Subject (Start .. Stop)));
5156 -- Come here if attempt to match current element fails
5158 -- Stack_Base current stack base
5159 -- Stack_Ptr current stack pointer
5162 Cursor := Stack (Stack_Ptr).Cursor;
5163 Node := Stack (Stack_Ptr).Node;
5164 Stack_Ptr := Stack_Ptr - 1;
5167 Dout ("failure, cursor reset to " & Cursor);
5172 -- Come here if attempt to match current element succeeds
5174 -- Cursor current position in subject string
5175 -- Node pointer to node successfully matched
5176 -- Stack_Base current stack base
5177 -- Stack_Ptr current stack pointer
5180 Dout ("success, cursor = " & Cursor);
5183 -- Come here to match the next pattern element
5185 -- Cursor current position in subject string
5186 -- Node pointer to node to be matched
5187 -- Stack_Base current stack base
5188 -- Stack_Ptr current stack pointer
5192 --------------------------------------------------
5193 -- Main Pattern Match Element Matching Routines --
5194 --------------------------------------------------
5196 -- Here is the case statement that processes the current node. The
5197 -- processing for each element does one of five things:
5199 -- goto Succeed to move to the successor
5200 -- goto Match_Succeed if the entire match succeeds
5201 -- goto Match_Fail if the entire match fails
5202 -- goto Fail to signal failure of current match
5204 -- Processing is NOT allowed to fall through
5211 Dout (Img (Node) & "matching Cancel");
5218 (Img (Node) & "setting up alternative " & Img (Node.Alt));
5223 -- Any (one character case)
5226 Dout (Img (Node) & "matching Any", Node.Char);
5229 and then Subject (Cursor + 1) = Node.Char
5231 Cursor := Cursor + 1;
5237 -- Any (character set case)
5240 Dout (Img (Node) & "matching Any", Node.CS);
5243 and then Is_In (Subject (Cursor + 1), Node.CS)
5245 Cursor := Cursor + 1;
5251 -- Any (string function case)
5253 when PC_Any_VF => declare
5254 U : constant VString := Node.VF.all;
5255 Str : constant String_Access := Get_String (U);
5258 Dout (Img (Node) & "matching Any", Str.all);
5261 and then Is_In (Subject (Cursor + 1), Str.all)
5263 Cursor := Cursor + 1;
5270 -- Any (string pointer case)
5272 when PC_Any_VP => declare
5273 Str : String_Access := Get_String (Node.VP.all);
5276 Dout (Img (Node) & "matching Any", Str.all);
5279 and then Is_In (Subject (Cursor + 1), Str.all)
5281 Cursor := Cursor + 1;
5288 -- Arb (initial match)
5291 Dout (Img (Node) & "matching Arb");
5299 Dout (Img (Node) & "extending Arb");
5301 if Cursor < Length then
5302 Cursor := Cursor + 1;
5309 -- Arbno_S (simple Arbno initialize). This is the node that
5310 -- initiates the match of a simple Arbno structure.
5314 "setting up Arbno alternative " & Img (Node.Alt));
5319 -- Arbno_X (Arbno initialize). This is the node that initiates
5320 -- the match of a complex Arbno structure.
5324 "setting up Arbno alternative " & Img (Node.Alt));
5329 -- Arbno_Y (Arbno rematch). This is the node that is executed
5330 -- following successful matching of one instance of a complex
5333 when PC_Arbno_Y => declare
5334 Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor);
5337 Dout (Img (Node) & "extending Arbno");
5340 -- If arbno extension matched null, then immediately fail
5343 Dout ("Arbno extension matched null, so fails");
5347 -- Here we must do a stack check to make sure enough stack
5348 -- is left. This check will happen once for each instance of
5349 -- the Arbno pattern that is matched. The Nat field of a
5350 -- PC_Arbno pattern contains the maximum stack entries needed
5351 -- for the Arbno with one instance and the successor pattern
5353 if Stack_Ptr + Node.Nat >= Stack'Last then
5354 raise Pattern_Stack_Overflow;
5360 -- Assign. If this node is executed, it means the assign-on-match
5361 -- or write-on-match operation will not happen after all, so we
5362 -- is propagate the failure, removing the PC_Assign node.
5365 Dout (Img (Node) & "deferred assign/write cancelled");
5368 -- Assign immediate. This node performs the actual assignment.
5370 when PC_Assign_Imm =>
5372 (Img (Node) & "executing immediate assignment of " &
5373 Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)));
5376 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
5380 -- Assign on match. This node sets up for the eventual assignment
5382 when PC_Assign_OnM =>
5383 Dout (Img (Node) & "registering deferred assignment");
5384 Stack (Stack_Base - 1).Node := Node;
5385 Push (CP_Assign'Access);
5393 Dout (Img (Node) & "matching or extending Bal");
5394 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
5397 elsif Subject (Cursor + 1) = '(' then
5399 Paren_Count : Natural := 1;
5403 Cursor := Cursor + 1;
5405 if Cursor >= Length then
5408 elsif Subject (Cursor + 1) = '(' then
5409 Paren_Count := Paren_Count + 1;
5411 elsif Subject (Cursor + 1) = ')' then
5412 Paren_Count := Paren_Count - 1;
5413 exit when Paren_Count = 0;
5419 Cursor := Cursor + 1;
5423 -- Break (one character case)
5426 Dout (Img (Node) & "matching Break", Node.Char);
5428 while Cursor < Length loop
5429 if Subject (Cursor + 1) = Node.Char then
5432 Cursor := Cursor + 1;
5438 -- Break (character set case)
5441 Dout (Img (Node) & "matching Break", Node.CS);
5443 while Cursor < Length loop
5444 if Is_In (Subject (Cursor + 1), Node.CS) then
5447 Cursor := Cursor + 1;
5453 -- Break (string function case)
5455 when PC_Break_VF => declare
5456 U : constant VString := Node.VF.all;
5457 Str : constant String_Access := Get_String (U);
5460 Dout (Img (Node) & "matching Break", Str.all);
5462 while Cursor < Length loop
5463 if Is_In (Subject (Cursor + 1), Str.all) then
5466 Cursor := Cursor + 1;
5473 -- Break (string pointer case)
5475 when PC_Break_VP => declare
5476 Str : String_Access := Get_String (Node.VP.all);
5479 Dout (Img (Node) & "matching Break", Str.all);
5481 while Cursor < Length loop
5482 if Is_In (Subject (Cursor + 1), Str.all) then
5485 Cursor := Cursor + 1;
5492 -- BreakX (one character case)
5494 when PC_BreakX_CH =>
5495 Dout (Img (Node) & "matching BreakX", Node.Char);
5497 while Cursor < Length loop
5498 if Subject (Cursor + 1) = Node.Char then
5501 Cursor := Cursor + 1;
5507 -- BreakX (character set case)
5509 when PC_BreakX_CS =>
5510 Dout (Img (Node) & "matching BreakX", Node.CS);
5512 while Cursor < Length loop
5513 if Is_In (Subject (Cursor + 1), Node.CS) then
5516 Cursor := Cursor + 1;
5522 -- BreakX (string function case)
5524 when PC_BreakX_VF => declare
5525 U : constant VString := Node.VF.all;
5526 Str : constant String_Access := Get_String (U);
5529 Dout (Img (Node) & "matching BreakX", Str.all);
5531 while Cursor < Length loop
5532 if Is_In (Subject (Cursor + 1), Str.all) then
5535 Cursor := Cursor + 1;
5542 -- BreakX (string pointer case)
5544 when PC_BreakX_VP => declare
5545 Str : String_Access := Get_String (Node.VP.all);
5548 Dout (Img (Node) & "matching BreakX", Str.all);
5550 while Cursor < Length loop
5551 if Is_In (Subject (Cursor + 1), Str.all) then
5554 Cursor := Cursor + 1;
5561 -- BreakX_X (BreakX extension). See section on "Compound Pattern
5562 -- Structures". This node is the alternative that is stacked
5563 -- to skip past the break character and extend the break.
5566 Dout (Img (Node) & "extending BreakX");
5568 Cursor := Cursor + 1;
5571 -- Character (one character string)
5574 Dout (Img (Node) & "matching '" & Node.Char & ''');
5577 and then Subject (Cursor + 1) = Node.Char
5579 Cursor := Cursor + 1;
5588 if Stack_Base = Stack_Init then
5589 Dout ("end of pattern
");
5592 -- End of recursive inner match. See separate section on
5593 -- handing of recursive pattern matches for details.
5596 Dout ("terminating recursive match
");
5597 Node := Stack (Stack_Base - 1).Node;
5605 Dout (Img (Node) & "matching Fail
");
5608 -- Fence (built in pattern)
5611 Dout (Img (Node) & "matching Fence
");
5612 Push (CP_Cancel'Access);
5615 -- Fence function node X. This is the node that gets control
5616 -- after a successful match of the fenced pattern.
5619 Dout (Img (Node) & "matching Fence
function");
5620 Stack_Ptr := Stack_Ptr + 1;
5621 Stack (Stack_Ptr).Cursor := Stack_Base;
5622 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
5623 Stack_Base := Stack (Stack_Base).Cursor;
5624 Region_Level := Region_Level - 1;
5627 -- Fence function node Y. This is the node that gets control on
5628 -- a failure that occurs after the fenced pattern has matched.
5630 -- Note: the Cursor at this stage is actually the inner stack
5631 -- base value. We don't reset this, but we do use it to strip
5632 -- off all the entries made by the fenced pattern.
5635 Dout (Img (Node) & "pattern matched by Fence caused failure
");
5636 Stack_Ptr := Cursor - 2;
5639 -- Len (integer case)
5642 Dout (Img (Node) & "matching Len
", Node.Nat);
5644 if Cursor + Node.Nat > Length then
5647 Cursor := Cursor + Node.Nat;
5651 -- Len (Integer function case)
5653 when PC_Len_NF => declare
5654 N : constant Natural := Node.NF.all;
5657 Dout (Img (Node) & "matching Len
", N);
5659 if Cursor + N > Length then
5662 Cursor := Cursor + N;
5667 -- Len (integer pointer case)
5670 Dout (Img (Node) & "matching Len
", Node.NP.all);
5672 if Cursor + Node.NP.all > Length then
5675 Cursor := Cursor + Node.NP.all;
5679 -- NotAny (one character case)
5681 when PC_NotAny_CH =>
5682 Dout (Img (Node) & "matching NotAny
", Node.Char);
5685 and then Subject (Cursor + 1) /= Node.Char
5687 Cursor := Cursor + 1;
5693 -- NotAny (character set case)
5695 when PC_NotAny_CS =>
5696 Dout (Img (Node) & "matching NotAny
", Node.CS);
5699 and then not Is_In (Subject (Cursor + 1), Node.CS)
5701 Cursor := Cursor + 1;
5707 -- NotAny (string function case)
5709 when PC_NotAny_VF => declare
5710 U : constant VString := Node.VF.all;
5711 Str : constant String_Access := Get_String (U);
5714 Dout (Img (Node) & "matching NotAny
", Str.all);
5718 not Is_In (Subject (Cursor + 1), Str.all)
5720 Cursor := Cursor + 1;
5727 -- NotAny (string pointer case)
5729 when PC_NotAny_VP => declare
5730 Str : String_Access := Get_String (Node.VP.all);
5733 Dout (Img (Node) & "matching NotAny
", Str.all);
5737 not Is_In (Subject (Cursor + 1), Str.all)
5739 Cursor := Cursor + 1;
5746 -- NSpan (one character case)
5749 Dout (Img (Node) & "matching NSpan
", Node.Char);
5751 while Cursor < Length
5752 and then Subject (Cursor + 1) = Node.Char
5754 Cursor := Cursor + 1;
5759 -- NSpan (character set case)
5762 Dout (Img (Node) & "matching NSpan
", Node.CS);
5764 while Cursor < Length
5765 and then Is_In (Subject (Cursor + 1), Node.CS)
5767 Cursor := Cursor + 1;
5772 -- NSpan (string function case)
5774 when PC_NSpan_VF => declare
5775 U : constant VString := Node.VF.all;
5776 Str : constant String_Access := Get_String (U);
5779 Dout (Img (Node) & "matching NSpan
", Str.all);
5781 while Cursor < Length
5782 and then Is_In (Subject (Cursor + 1), Str.all)
5784 Cursor := Cursor + 1;
5790 -- NSpan (string pointer case)
5792 when PC_NSpan_VP => declare
5793 Str : String_Access := Get_String (Node.VP.all);
5796 Dout (Img (Node) & "matching NSpan
", Str.all);
5798 while Cursor < Length
5799 and then Is_In (Subject (Cursor + 1), Str.all)
5801 Cursor := Cursor + 1;
5808 Dout (Img (Node) & "matching
null");
5811 -- Pos (integer case)
5814 Dout (Img (Node) & "matching Pos
", Node.Nat);
5816 if Cursor = Node.Nat then
5822 -- Pos (Integer function case)
5824 when PC_Pos_NF => declare
5825 N : constant Natural := Node.NF.all;
5828 Dout (Img (Node) & "matching Pos
", N);
5837 -- Pos (integer pointer case)
5840 Dout (Img (Node) & "matching Pos
", Node.NP.all);
5842 if Cursor = Node.NP.all then
5848 -- Predicate function
5850 when PC_Pred_Func =>
5851 Dout (Img (Node) & "matching predicate
function");
5859 -- Region Enter. Initiate new pattern history stack region
5862 Dout (Img (Node) & "starting match
of nested pattern
");
5863 Stack (Stack_Ptr + 1).Cursor := Cursor;
5867 -- Region Remove node. This is the node stacked by an R_Enter.
5868 -- It removes the special format stack entry right underneath, and
5869 -- then restores the outer level stack base and signals failure.
5871 -- Note: the cursor value at this stage is actually the (negative)
5872 -- stack base value for the outer level.
5875 Dout ("failure
, match
of nested pattern terminated
");
5876 Stack_Base := Cursor;
5877 Region_Level := Region_Level - 1;
5878 Stack_Ptr := Stack_Ptr - 1;
5881 -- Region restore node. This is the node stacked at the end of an
5882 -- inner level match. Its function is to restore the inner level
5883 -- region, so that alternatives in this region can be sought.
5885 -- Note: the Cursor at this stage is actually the negative of the
5886 -- inner stack base value, which we use to restore the inner region.
5888 when PC_R_Restore =>
5889 Dout ("failure
, search
for alternatives
in nested pattern
");
5890 Region_Level := Region_Level + 1;
5891 Stack_Base := Cursor;
5897 Dout (Img (Node) & "matching Rest
");
5901 -- Initiate recursive match (pattern pointer case)
5904 Stack (Stack_Ptr + 1).Node := Node.Pthen;
5906 Dout (Img (Node) & "initiating recursive match
");
5908 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
5909 raise Pattern_Stack_Overflow;
5911 Node := Node.PP.all.P;
5915 -- RPos (integer case)
5918 Dout (Img (Node) & "matching RPos
", Node.Nat);
5920 if Cursor = (Length - Node.Nat) then
5926 -- RPos (integer function case)
5928 when PC_RPos_NF => declare
5929 N : constant Natural := Node.NF.all;
5932 Dout (Img (Node) & "matching RPos
", N);
5934 if Length - Cursor = N then
5941 -- RPos (integer pointer case)
5944 Dout (Img (Node) & "matching RPos
", Node.NP.all);
5946 if Cursor = (Length - Node.NP.all) then
5952 -- RTab (integer case)
5955 Dout (Img (Node) & "matching RTab
", Node.Nat);
5957 if Cursor <= (Length - Node.Nat) then
5958 Cursor := Length - Node.Nat;
5964 -- RTab (integer function case)
5966 when PC_RTab_NF => declare
5967 N : constant Natural := Node.NF.all;
5970 Dout (Img (Node) & "matching RPos
", N);
5972 if Length - Cursor >= N then
5973 Cursor := Length - N;
5980 -- RTab (integer pointer case)
5983 Dout (Img (Node) & "matching RPos
", Node.NP.all);
5985 if Cursor <= (Length - Node.NP.all) then
5986 Cursor := Length - Node.NP.all;
5992 -- Cursor assignment
5995 Dout (Img (Node) & "matching Setcur
");
5996 Node.Var.all := Cursor;
5999 -- Span (one character case)
6001 when PC_Span_CH => declare
6002 P : Natural := Cursor;
6005 Dout (Img (Node) & "matching Span
", Node.Char);
6008 and then Subject (P + 1) = Node.Char
6021 -- Span (character set case)
6023 when PC_Span_CS => declare
6024 P : Natural := Cursor;
6027 Dout (Img (Node) & "matching Span
", Node.CS);
6030 and then Is_In (Subject (P + 1), Node.CS)
6043 -- Span (string function case)
6045 when PC_Span_VF => declare
6046 U : constant VString := Node.VF.all;
6047 Str : constant String_Access := Get_String (U);
6048 P : Natural := Cursor;
6051 Dout (Img (Node) & "matching Span
", Str.all);
6054 and then Is_In (Subject (P + 1), Str.all)
6067 -- Span (string pointer case)
6069 when PC_Span_VP => declare
6070 Str : String_Access := Get_String (Node.VP.all);
6071 P : Natural := Cursor;
6074 Dout (Img (Node) & "matching Span
", Str.all);
6077 and then Is_In (Subject (P + 1), Str.all)
6090 -- String (two character case)
6093 Dout (Img (Node) & "matching
" & Image (Node.Str2));
6095 if (Length - Cursor) >= 2
6096 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
6098 Cursor := Cursor + 2;
6104 -- String (three character case)
6107 Dout (Img (Node) & "matching
" & Image (Node.Str3));
6109 if (Length - Cursor) >= 3
6110 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
6112 Cursor := Cursor + 3;
6118 -- String (four character case)
6121 Dout (Img (Node) & "matching
" & Image (Node.Str4));
6123 if (Length - Cursor) >= 4
6124 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
6126 Cursor := Cursor + 4;
6132 -- String (five character case)
6135 Dout (Img (Node) & "matching
" & Image (Node.Str5));
6137 if (Length - Cursor) >= 5
6138 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
6140 Cursor := Cursor + 5;
6146 -- String (six character case)
6149 Dout (Img (Node) & "matching
" & Image (Node.Str6));
6151 if (Length - Cursor) >= 6
6152 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
6154 Cursor := Cursor + 6;
6160 -- String (case of more than six characters)
6162 when PC_String => declare
6163 Len : constant Natural := Node.Str'Length;
6166 Dout (Img (Node) & "matching
" & Image (Node.Str.all));
6168 if (Length - Cursor) >= Len
6169 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
6171 Cursor := Cursor + Len;
6178 -- String (function case)
6180 when PC_String_VF => declare
6181 U : constant VString := Node.VF.all;
6182 Str : constant String_Access := Get_String (U);
6183 Len : constant Natural := Str'Length;
6186 Dout (Img (Node) & "matching
" & Image (Str.all));
6188 if (Length - Cursor) >= Len
6189 and then Str.all = Subject (Cursor + 1 .. Cursor + Len)
6191 Cursor := Cursor + Len;
6198 -- String (vstring pointer case)
6200 when PC_String_VP => declare
6201 S : String_Access := Get_String (Node.VP.all);
6202 Len : constant Natural :=
6203 Ada.Strings.Unbounded.Length (Node.VP.all);
6207 (Img (Node) & "matching
" & Image (S.all));
6209 if (Length - Cursor) >= Len
6210 and then S.all = Subject (Cursor + 1 .. Cursor + Len)
6212 Cursor := Cursor + Len;
6222 Dout (Img (Node) & "matching Succeed
");
6226 -- Tab (integer case)
6229 Dout (Img (Node) & "matching Tab
", Node.Nat);
6231 if Cursor <= Node.Nat then
6238 -- Tab (integer function case)
6240 when PC_Tab_NF => declare
6241 N : constant Natural := Node.NF.all;
6244 Dout (Img (Node) & "matching Tab
", N);
6254 -- Tab (integer pointer case)
6257 Dout (Img (Node) & "matching Tab
", Node.NP.all);
6259 if Cursor <= Node.NP.all then
6260 Cursor := Node.NP.all;
6266 -- Unanchored movement
6268 when PC_Unanchored =>
6269 Dout ("attempting to move anchor point
");
6271 -- All done if we tried every position
6273 if Cursor > Length then
6276 -- Otherwise extend the anchor point, and restack ourself
6279 Cursor := Cursor + 1;
6284 -- Write immediate. This node performs the actual write
6286 when PC_Write_Imm =>
6287 Dout (Img (Node) & "executing immediate write
of " &
6288 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6292 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6296 -- Write on match. This node sets up for the eventual write
6298 when PC_Write_OnM =>
6299 Dout (Img (Node) & "registering deferred write
");
6300 Stack (Stack_Base - 1).Node := Node;
6301 Push (CP_Assign'Access);
6308 -- We are NOT allowed to fall though this case statement, since every
6309 -- match routine must end by executing a goto to the appropriate point
6310 -- in the finite state machine model.
6316 end GNAT.Spitbol.Patterns;