1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . S P I T B O L . P A T T E R N S --
9 -- Copyright (C) 1998-2009, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
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.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
41 with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
43 with System; use System;
45 with Ada.Unchecked_Conversion;
46 with Ada.Unchecked_Deallocation;
48 package body GNAT.Spitbol.Patterns is
50 ------------------------
51 -- Internal Debugging --
52 ------------------------
54 Internal_Debug : constant Boolean := False;
55 -- Set this flag to True to activate some built-in debugging traceback
56 -- These are all lines output with PutD and Put_LineD.
59 pragma Inline (New_LineD);
60 -- Output new blank line with New_Line if Internal_Debug is True
62 procedure PutD (Str : String);
64 -- Output string with Put if Internal_Debug is True
66 procedure Put_LineD (Str : String);
67 pragma Inline (Put_LineD);
68 -- Output string with Put_Line if Internal_Debug is True
70 -----------------------------
71 -- Local Type Declarations --
72 -----------------------------
74 subtype String_Ptr is Ada.Strings.Unbounded.String_Access;
75 subtype File_Ptr is Ada.Text_IO.File_Access;
77 function To_Address is new Ada.Unchecked_Conversion (PE_Ptr, Address);
78 -- Used only for debugging output purposes
80 subtype AFC is Ada.Finalization.Controlled;
82 N : constant PE_Ptr := null;
83 -- Shorthand used to initialize Copy fields to null
85 type Natural_Ptr is access all Natural;
86 type Pattern_Ptr is access all Pattern;
88 --------------------------------------------------
89 -- Description of Algorithm and Data Structures --
90 --------------------------------------------------
92 -- A pattern structure is represented as a linked graph of nodes
93 -- with the following structure:
95 -- +------------------------------------+
97 -- +------------------------------------+
99 -- +------------------------------------+
101 -- +------------------------------------+
103 -- +------------------------------------+
105 -- Pcode is a code value indicating the type of the pattern node. This
106 -- code is used both as the discriminant value for the record, and as
107 -- the case index in the main match routine that branches to the proper
108 -- match code for the given element.
110 -- Index is a serial index number. The use of these serial index
111 -- numbers is described in a separate section.
113 -- Pthen is a pointer to the successor node, i.e the node to be matched
114 -- if the attempt to match the node succeeds. If this is the last node
115 -- of the pattern to be matched, then Pthen points to a dummy node
116 -- of kind PC_EOP (end of pattern), which initializes pattern exit.
118 -- The parameter or parameters are present for certain node types,
119 -- and the type varies with the pattern code.
121 type Pattern_Code is (
214 type IndexT is range 0 .. +(2 **15 - 1);
216 type PE (Pcode : Pattern_Code) is record
219 -- Serial index number of pattern element within pattern
222 -- Successor element, to be matched after this one
242 PC_Unanchored => null;
247 PC_Arbno_X => Alt : PE_Ptr;
249 when PC_Rpat => PP : Pattern_Ptr;
251 when PC_Pred_Func => BF : Boolean_Func;
261 PC_String_VP => VP : VString_Ptr;
264 PC_Write_OnM => FP : File_Ptr;
266 when PC_String => Str : String_Ptr;
268 when PC_String_2 => Str2 : String (1 .. 2);
270 when PC_String_3 => Str3 : String (1 .. 3);
272 when PC_String_4 => Str4 : String (1 .. 4);
274 when PC_String_5 => Str5 : String (1 .. 5);
276 when PC_String_6 => Str6 : String (1 .. 6);
278 when PC_Setcur => Var : Natural_Ptr;
286 PC_Span_CH => Char : Character;
293 PC_Span_CS => CS : Character_Set;
300 PC_Tab_Nat => Nat : Natural;
306 PC_Tab_NF => NF : Natural_Func;
312 PC_Tab_NP => NP : Natural_Ptr;
320 PC_String_VF => VF : VString_Func;
325 subtype PC_Has_Alt is Pattern_Code range PC_Alt .. PC_Arbno_X;
326 -- Range of pattern codes that has an Alt field. This is used in the
327 -- recursive traversals, since these links must be followed.
329 EOP_Element : aliased constant PE := (PC_EOP, 0, N);
330 -- This is the end of pattern element, and is thus the representation of
331 -- a null pattern. It has a zero index element since it is never placed
332 -- inside a pattern. Furthermore it does not need a successor, since it
333 -- marks the end of the pattern, so that no more successors are needed.
335 EOP : constant PE_Ptr := EOP_Element'Unrestricted_Access;
336 -- This is the end of pattern pointer, that is used in the Pthen pointer
337 -- of other nodes to signal end of pattern.
339 -- The following array is used to determine if a pattern used as an
340 -- argument for Arbno is eligible for treatment using the simple Arbno
341 -- structure (i.e. it is a pattern that is guaranteed to match at least
342 -- one character on success, and not to make any entries on the stack.
344 OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean :=
367 -------------------------------
368 -- The Pattern History Stack --
369 -------------------------------
371 -- The pattern history stack is used for controlling backtracking when
372 -- a match fails. The idea is to stack entries that give a cursor value
373 -- to be restored, and a node to be reestablished as the current node to
374 -- attempt an appropriate rematch operation. The processing for a pattern
375 -- element that has rematch alternatives pushes an appropriate entry or
376 -- entry on to the stack, and the proceeds. If a match fails at any point,
377 -- the top element of the stack is popped off, resetting the cursor and
378 -- the match continues by accessing the node stored with this entry.
380 type Stack_Entry is record
383 -- Saved cursor value that is restored when this entry is popped
384 -- from the stack if a match attempt fails. Occasionally, this
385 -- field is used to store a history stack pointer instead of a
386 -- cursor. Such cases are noted in the documentation and the value
387 -- stored is negative since stack pointer values are always negative.
390 -- This pattern element reference is reestablished as the current
391 -- Node to be matched (which will attempt an appropriate rematch).
395 subtype Stack_Range is Integer range -Stack_Size .. -1;
397 type Stack_Type is array (Stack_Range) of Stack_Entry;
398 -- The type used for a history stack. The actual instance of the stack
399 -- is declared as a local variable in the Match routine, to properly
400 -- handle recursive calls to Match. All stack pointer values are negative
401 -- to distinguish them from normal cursor values.
403 -- Note: the pattern matching stack is used only to handle backtracking.
404 -- If no backtracking occurs, its entries are never accessed, and never
405 -- popped off, and in particular it is normal for a successful match
406 -- to terminate with entries on the stack that are simply discarded.
408 -- Note: in subsequent diagrams of the stack, we always place element
409 -- zero (the deepest element) at the top of the page, then build the
410 -- stack down on the page with the most recent (top of stack) element
411 -- being the bottom-most entry on the page.
413 -- Stack checking is handled by labeling every pattern with the maximum
414 -- number of stack entries that are required, so a single check at the
415 -- start of matching the pattern suffices. There are two exceptions.
417 -- First, the count does not include entries for recursive pattern
418 -- references. Such recursions must therefore perform a specific
419 -- stack check with respect to the number of stack entries required
420 -- by the recursive pattern that is accessed and the amount of stack
421 -- that remains unused.
423 -- Second, the count includes only one iteration of an Arbno pattern,
424 -- so a specific check must be made on subsequent iterations that there
425 -- is still enough stack space left. The Arbno node has a field that
426 -- records the number of stack entries required by its argument for
429 ---------------------------------------------------
430 -- Use of Serial Index Field in Pattern Elements --
431 ---------------------------------------------------
433 -- The serial index numbers for the pattern elements are assigned as
434 -- a pattern is constructed from its constituent elements. Note that there
435 -- is never any sharing of pattern elements between patterns (copies are
436 -- always made), so the serial index numbers are unique to a particular
437 -- pattern as referenced from the P field of a value of type Pattern.
439 -- The index numbers meet three separate invariants, which are used for
440 -- various purposes as described in this section.
442 -- First, the numbers uniquely identify the pattern elements within a
443 -- pattern. If Num is the number of elements in a given pattern, then
444 -- the serial index numbers for the elements of this pattern will range
445 -- from 1 .. Num, so that each element has a separate value.
447 -- The purpose of this assignment is to provide a convenient auxiliary
448 -- data structure mechanism during operations which must traverse a
449 -- pattern (e.g. copy and finalization processing). Once constructed
450 -- patterns are strictly read only. This is necessary to allow sharing
451 -- of patterns between tasks. This means that we cannot go marking the
452 -- pattern (e.g. with a visited bit). Instead we construct a separate
453 -- vector that contains the necessary information indexed by the Index
454 -- values in the pattern elements. For this purpose the only requirement
455 -- is that they be uniquely assigned.
457 -- Second, the pattern element referenced directly, i.e. the leading
458 -- pattern element, is always the maximum numbered element and therefore
459 -- indicates the total number of elements in the pattern. More precisely,
460 -- the element referenced by the P field of a pattern value, or the
461 -- element returned by any of the internal pattern construction routines
462 -- in the body (that return a value of type PE_Ptr) always is this
465 -- The purpose of this requirement is to allow an immediate determination
466 -- of the number of pattern elements within a pattern. This is used to
467 -- properly size the vectors used to contain auxiliary information for
468 -- traversal as described above.
470 -- Third, as compound pattern structures are constructed, the way in which
471 -- constituent parts of the pattern are constructed is stylized. This is
472 -- an automatic consequence of the way that these compound structures
473 -- are constructed, and basically what we are doing is simply documenting
474 -- and specifying the natural result of the pattern construction. The
475 -- section describing compound pattern structures gives details of the
476 -- numbering of each compound pattern structure.
478 -- The purpose of specifying the stylized numbering structures for the
479 -- compound patterns is to help simplify the processing in the Image
480 -- function, since it eases the task of retrieving the original recursive
481 -- structure of the pattern from the flat graph structure of elements.
482 -- This use in the Image function is the only point at which the code
483 -- makes use of the stylized structures.
485 type Ref_Array is array (IndexT range <>) of PE_Ptr;
486 -- This type is used to build an array whose N'th entry references the
487 -- element in a pattern whose Index value is N. See Build_Ref_Array.
489 procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array);
490 -- Given a pattern element which is the leading element of a pattern
491 -- structure, and a Ref_Array with bounds 1 .. E.Index, fills in the
492 -- Ref_Array so that its N'th entry references the element of the
493 -- referenced pattern whose Index value is N.
495 -------------------------------
496 -- Recursive Pattern Matches --
497 -------------------------------
499 -- The pattern primitive (+P) where P is a Pattern_Ptr or Pattern_Func
500 -- causes a recursive pattern match. This cannot be handled by an actual
501 -- recursive call to the outer level Match routine, since this would not
502 -- allow for possible backtracking into the region matched by the inner
503 -- pattern. Indeed this is the classical clash between recursion and
504 -- backtracking, and a simple recursive stack structure does not suffice.
506 -- This section describes how this recursion and the possible associated
507 -- backtracking is handled. We still use a single stack, but we establish
508 -- the concept of nested regions on this stack, each of which has a stack
509 -- base value pointing to the deepest stack entry of the region. The base
510 -- value for the outer level is zero.
512 -- When a recursive match is established, two special stack entries are
513 -- made. The first entry is used to save the original node that starts
514 -- the recursive match. This is saved so that the successor field of
515 -- this node is accessible at the end of the match, but it is never
516 -- popped and executed.
518 -- The second entry corresponds to a standard new region action. A
519 -- PC_R_Remove node is stacked, whose cursor field is used to store
520 -- the outer stack base, and the stack base is reset to point to
521 -- this PC_R_Remove node. Then the recursive pattern is matched and
522 -- it can make history stack entries in the normal matter, so now
523 -- the stack looks like:
525 -- (stack entries made by outer level)
527 -- (Special entry, node is (+P) successor
528 -- cursor entry is not used)
530 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack base
531 -- saved base value for the enclosing region)
533 -- (stack entries made by inner level)
535 -- If a subsequent failure occurs and pops the PC_R_Remove node, it
536 -- removes itself and the special entry immediately underneath it,
537 -- restores the stack base value for the enclosing region, and then
538 -- again signals failure to look for alternatives that were stacked
539 -- before the recursion was initiated.
541 -- Now we need to consider what happens if the inner pattern succeeds, as
542 -- signalled by accessing the special PC_EOP pattern primitive. First we
543 -- recognize the nested case by looking at the Base value. If this Base
544 -- value is Stack'First, then the entire match has succeeded, but if the
545 -- base value is greater than Stack'First, then we have successfully
546 -- matched an inner pattern, and processing continues at the outer level.
548 -- There are two cases. The simple case is when the inner pattern has made
549 -- no stack entries, as recognized by the fact that the current stack
550 -- pointer is equal to the current base value. In this case it is fine to
551 -- remove all trace of the recursion by restoring the outer base value and
552 -- using the special entry to find the appropriate successor node.
554 -- The more complex case arises when the inner match does make stack
555 -- entries. In this case, the PC_EOP processing stacks a special entry
556 -- whose cursor value saves the saved inner base value (the one that
557 -- references the corresponding PC_R_Remove value), and whose node
558 -- pointer references a PC_R_Restore node, so the stack looks like:
560 -- (stack entries made by outer level)
562 -- (Special entry, node is (+P) successor,
563 -- cursor entry is not used)
565 -- (PC_R_Remove entry, "cursor" value is (negative)
566 -- saved base value for the enclosing region)
568 -- (stack entries made by inner level)
570 -- (PC_Region_Replace entry, "cursor" value is (negative)
571 -- stack pointer value referencing the PC_R_Remove entry).
573 -- If the entire match succeeds, then these stack entries are, as usual,
574 -- ignored and abandoned. If on the other hand a subsequent failure
575 -- causes the PC_Region_Replace entry to be popped, it restores the
576 -- inner base value from its saved "cursor" value and then fails again.
577 -- Note that it is OK that the cursor is temporarily clobbered by this
578 -- pop, since the second failure will reestablish a proper cursor value.
580 ---------------------------------
581 -- Compound Pattern Structures --
582 ---------------------------------
584 -- This section discusses the compound structures used to represent
585 -- constructed patterns. It shows the graph structures of pattern
586 -- elements that are constructed, and in the case of patterns that
587 -- provide backtracking possibilities, describes how the history
588 -- stack is used to control the backtracking. Finally, it notes the
589 -- way in which the Index numbers are assigned to the structure.
591 -- In all diagrams, solid lines (built with minus signs or vertical
592 -- bars, represent successor pointers (Pthen fields) with > or V used
593 -- to indicate the direction of the pointer. The initial node of the
594 -- structure is in the upper left of the diagram. A dotted line is an
595 -- alternative pointer from the element above it to the element below
596 -- it. See individual sections for details on how alternatives are used.
602 -- In the pattern structures listed in this section, a line that looks
603 -- like ----> with nothing to the right indicates an end of pattern
604 -- (EOP) pointer that represents the end of the match.
606 -- When a pattern concatenation (L & R) occurs, the resulting structure
607 -- is obtained by finding all such EOP pointers in L, and replacing
608 -- them to point to R. This is the most important flattening that
609 -- occurs in constructing a pattern, and it means that the pattern
610 -- matching circuitry does not have to keep track of the structure
611 -- of a pattern with respect to concatenation, since the appropriate
612 -- successor is always at hand.
614 -- Concatenation itself generates no additional possibilities for
615 -- backtracking, but the constituent patterns of the concatenated
616 -- structure will make stack entries as usual. The maximum amount
617 -- of stack required by the structure is thus simply the sum of the
618 -- maximums required by L and R.
620 -- The index numbering of a concatenation structure works by leaving
621 -- the numbering of the right hand pattern, R, unchanged and adjusting
622 -- the numbers in the left hand pattern, L up by the count of elements
623 -- in R. This ensures that the maximum numbered element is the leading
624 -- element as required (given that it was the leading element in L).
630 -- A pattern (L or R) constructs the structure:
633 -- | A |---->| L |---->
641 -- The A element here is a PC_Alt node, and the dotted line represents
642 -- the contents of the Alt field. When the PC_Alt element is matched,
643 -- it stacks a pointer to the leading element of R on the history stack
644 -- so that on subsequent failure, a match of R is attempted.
646 -- The A node is the highest numbered element in the pattern. The
647 -- original index numbers of R are unchanged, but the index numbers
648 -- of the L pattern are adjusted up by the count of elements in R.
650 -- Note that the difference between the index of the L leading element
651 -- the index of the R leading element (after building the alt structure)
652 -- indicates the number of nodes in L, and this is true even after the
653 -- structure is incorporated into some larger structure. For example,
654 -- if the A node has index 16, and L has index 15 and R has index
655 -- 5, then we know that L has 10 (15-5) elements in it.
657 -- Suppose that we now concatenate this structure to another pattern
658 -- with 9 elements in it. We will now have the A node with an index
659 -- of 25, L with an index of 24 and R with an index of 14. We still
660 -- know that L has 10 (24-14) elements in it, numbered 15-24, and
661 -- consequently the successor of the alternation structure has an
662 -- index with a value less than 15. This is used in Image to figure
663 -- out the original recursive structure of a pattern.
665 -- To clarify the interaction of the alternation and concatenation
666 -- structures, here is a more complex example of the structure built
669 -- (V or W or X) (Y or Z)
671 -- where A,B,C,D,E are all single element patterns:
673 -- +---+ +---+ +---+ +---+
674 -- I A I---->I V I---+-->I A I---->I Y I---->
675 -- +---+ +---+ I +---+ +---+
678 -- +---+ +---+ I +---+
679 -- I A I---->I W I-->I I Z I---->
680 -- +---+ +---+ I +---+
684 -- I X I------------>+
687 -- The numbering of the nodes would be as follows:
689 -- +---+ +---+ +---+ +---+
690 -- I 8 I---->I 7 I---+-->I 3 I---->I 2 I---->
691 -- +---+ +---+ I +---+ +---+
694 -- +---+ +---+ I +---+
695 -- I 6 I---->I 5 I-->I I 1 I---->
696 -- +---+ +---+ I +---+
700 -- I 4 I------------>+
703 -- Note: The above structure actually corresponds to
705 -- (A or (B or C)) (D or E)
709 -- ((A or B) or C) (D or E)
711 -- which is the more natural interpretation, but in fact alternation
712 -- is associative, and the construction of an alternative changes the
713 -- left grouped pattern to the right grouped pattern in any case, so
714 -- that the Image function produces a more natural looking output.
720 -- An Arb pattern builds the structure
731 -- The X node is a PC_Arb_X node, which matches null, and stacks a
732 -- pointer to Y node, which is the PC_Arb_Y node that matches one
733 -- extra character and restacks itself.
735 -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1
737 -------------------------
738 -- Arbno (simple case) --
739 -------------------------
741 -- The simple form of Arbno can be used where the pattern always
742 -- matches at least one character if it succeeds, and it is known
743 -- not to make any history stack entries. In this case, Arbno (P)
744 -- can construct the following structure:
758 -- The S (PC_Arbno_S) node matches null stacking a pointer to the
759 -- pattern P. If a subsequent failure causes P to be matched and
760 -- this match succeeds, then node A gets restacked to try another
761 -- instance if needed by a subsequent failure.
763 -- The node numbering of the constituent pattern P is not affected.
764 -- The S node has a node number of P.Index + 1.
766 --------------------------
767 -- Arbno (complex case) --
768 --------------------------
770 -- A call to Arbno (P), where P can match null (or at least is not
771 -- known to require a non-null string) and/or P requires pattern stack
772 -- entries, constructs the following structure:
774 -- +--------------------------+
782 -- +---+ +---+ +---+ |
783 -- | E |---->| P |---->| Y |--->+
786 -- The node X (PC_Arbno_X) matches null, stacking a pointer to the
787 -- E-P-X structure used to match one Arbno instance.
789 -- Here E is the PC_R_Enter node which matches null and creates two
790 -- stack entries. The first is a special entry whose node field is
791 -- not used at all, and whose cursor field has the initial cursor.
793 -- The second entry corresponds to a standard new region action. A
794 -- PC_R_Remove node is stacked, whose cursor field is used to store
795 -- the outer stack base, and the stack base is reset to point to
796 -- this PC_R_Remove node. Then the pattern P is matched, and it can
797 -- make history stack entries in the normal manner, so now the stack
800 -- (stack entries made before assign pattern)
802 -- (Special entry, node field not used,
803 -- used only to save initial cursor)
805 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
806 -- saved base value for the enclosing region)
808 -- (stack entries made by matching P)
810 -- If the match of P fails, then the PC_R_Remove entry is popped and
811 -- it removes both itself and the special entry underneath it,
812 -- restores the outer stack base, and signals failure.
814 -- If the match of P succeeds, then node Y, the PC_Arbno_Y node, pops
815 -- the inner region. There are two possibilities. If matching P left
816 -- no stack entries, then all traces of the inner region can be removed.
817 -- If there are stack entries, then we push an PC_Region_Replace stack
818 -- entry whose "cursor" value is the inner stack base value, and then
819 -- restore the outer stack base value, so the stack looks like:
821 -- (stack entries made before assign pattern)
823 -- (Special entry, node field not used,
824 -- used only to save initial cursor)
826 -- (PC_R_Remove entry, "cursor" value is (negative)
827 -- saved base value for the enclosing region)
829 -- (stack entries made by matching P)
831 -- (PC_Region_Replace entry, "cursor" value is (negative)
832 -- stack pointer value referencing the PC_R_Remove entry).
834 -- Now that we have matched another instance of the Arbno pattern,
835 -- we need to move to the successor. There are two cases. If the
836 -- Arbno pattern matched null, then there is no point in seeking
837 -- alternatives, since we would just match a whole bunch of nulls.
838 -- In this case we look through the alternative node, and move
839 -- directly to its successor (i.e. the successor of the Arbno
840 -- pattern). If on the other hand a non-null string was matched,
841 -- we simply follow the successor to the alternative node, which
842 -- sets up for another possible match of the Arbno pattern.
844 -- As noted in the section on stack checking, the stack count (and
845 -- hence the stack check) for a pattern includes only one iteration
846 -- of the Arbno pattern. To make sure that multiple iterations do not
847 -- overflow the stack, the Arbno node saves the stack count required
848 -- by a single iteration, and the Concat function increments this to
849 -- include stack entries required by any successor. The PC_Arbno_Y
850 -- node uses this count to ensure that sufficient stack remains
851 -- before proceeding after matching each new instance.
853 -- The node numbering of the constituent pattern P is not affected.
854 -- Where N is the number of nodes in P, the Y node is numbered N + 1,
855 -- the E node is N + 2, and the X node is N + 3.
857 ----------------------
858 -- Assign Immediate --
859 ----------------------
861 -- Immediate assignment (P * V) constructs the following structure
864 -- | E |---->| P |---->| A |---->
867 -- Here E is the PC_R_Enter node which matches null and creates two
868 -- stack entries. The first is a special entry whose node field is
869 -- not used at all, and whose cursor field has the initial cursor.
871 -- The second entry corresponds to a standard new region action. A
872 -- PC_R_Remove node is stacked, whose cursor field is used to store
873 -- the outer stack base, and the stack base is reset to point to
874 -- this PC_R_Remove node. Then the pattern P is matched, and it can
875 -- make history stack entries in the normal manner, so now the stack
878 -- (stack entries made before assign pattern)
880 -- (Special entry, node field not used,
881 -- used only to save initial cursor)
883 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
884 -- saved base value for the enclosing region)
886 -- (stack entries made by matching P)
888 -- If the match of P fails, then the PC_R_Remove entry is popped
889 -- and it removes both itself and the special entry underneath it,
890 -- restores the outer stack base, and signals failure.
892 -- If the match of P succeeds, then node A, which is the actual
893 -- PC_Assign_Imm node, executes the assignment (using the stack
894 -- base to locate the entry with the saved starting cursor value),
895 -- and the pops the inner region. There are two possibilities, if
896 -- matching P left no stack entries, then all traces of the inner
897 -- region can be removed. If there are stack entries, then we push
898 -- an PC_Region_Replace stack entry whose "cursor" value is the
899 -- inner stack base value, and then restore the outer stack base
900 -- value, so the stack looks like:
902 -- (stack entries made before assign pattern)
904 -- (Special entry, node field not used,
905 -- used only to save initial cursor)
907 -- (PC_R_Remove entry, "cursor" value is (negative)
908 -- saved base value for the enclosing region)
910 -- (stack entries made by matching P)
912 -- (PC_Region_Replace entry, "cursor" value is the (negative)
913 -- stack pointer value referencing the PC_R_Remove entry).
915 -- If a subsequent failure occurs, the PC_Region_Replace node restores
916 -- the inner stack base value and signals failure to explore rematches
919 -- The node numbering of the constituent pattern P is not affected.
920 -- Where N is the number of nodes in P, the A node is numbered N + 1,
921 -- and the E node is N + 2.
923 ---------------------
924 -- Assign On Match --
925 ---------------------
927 -- The assign on match (**) pattern is quite similar to the assign
928 -- immediate pattern, except that the actual assignment has to be
929 -- delayed. The following structure is constructed:
932 -- | E |---->| P |---->| A |---->
935 -- The operation of this pattern is identical to that described above
936 -- for deferred assignment, up to the point where P has been matched.
938 -- The A node, which is the PC_Assign_OnM node first pushes a
939 -- PC_Assign node onto the history stack. This node saves the ending
940 -- cursor and acts as a flag for the final assignment, as further
943 -- It then stores a pointer to itself in the special entry node field.
944 -- This was otherwise unused, and is now used to retrieve the address
945 -- of the variable to be assigned at the end of the pattern.
947 -- After that the inner region is terminated in the usual manner,
948 -- by stacking a PC_R_Restore entry as described for the assign
949 -- immediate case. Note that the optimization of completely
950 -- removing the inner region does not happen in this case, since
951 -- we have at least one stack entry (the PC_Assign one we just made).
952 -- The stack now looks like:
954 -- (stack entries made before assign pattern)
956 -- (Special entry, node points to copy of
957 -- the PC_Assign_OnM node, and the
958 -- cursor field saves the initial cursor).
960 -- (PC_R_Remove entry, "cursor" value is (negative)
961 -- saved base value for the enclosing region)
963 -- (stack entries made by matching P)
965 -- (PC_Assign entry, saves final cursor)
967 -- (PC_Region_Replace entry, "cursor" value is (negative)
968 -- stack pointer value referencing the PC_R_Remove entry).
970 -- If a subsequent failure causes the PC_Assign node to execute it
971 -- simply removes itself and propagates the failure.
973 -- If the match succeeds, then the history stack is scanned for
974 -- PC_Assign nodes, and the assignments are executed (examination
975 -- of the above diagram will show that all the necessary data is
976 -- at hand for the assignment).
978 -- To optimize the common case where no assign-on-match operations
979 -- are present, a global flag Assign_OnM is maintained which is
980 -- initialize to False, and gets set True as part of the execution
981 -- of the PC_Assign_OnM node. The scan of the history stack for
982 -- PC_Assign entries is done only if this flag is set.
984 -- The node numbering of the constituent pattern P is not affected.
985 -- Where N is the number of nodes in P, the A node is numbered N + 1,
986 -- and the E node is N + 2.
992 -- Bal builds a single node:
998 -- The node B is the PC_Bal node which matches a parentheses balanced
999 -- string, starting at the current cursor position. It then updates
1000 -- the cursor past this matched string, and stacks a pointer to itself
1001 -- with this updated cursor value on the history stack, to extend the
1002 -- matched string on a subsequent failure.
1004 -- Since this is a single node it is numbered 1 (the reason we include
1005 -- it in the compound patterns section is that it backtracks).
1011 -- BreakX builds the structure
1014 -- | B |---->| A |---->
1022 -- Here the B node is the BreakX_xx node that performs a normal Break
1023 -- function. The A node is an alternative (PC_Alt) node that matches
1024 -- null, but stacks a pointer to node X (the PC_BreakX_X node) which
1025 -- extends the match one character (to eat up the previously detected
1026 -- break character), and then rematches the break.
1028 -- The B node is numbered 3, the alternative node is 1, and the X
1035 -- Fence builds a single node:
1041 -- The element F, PC_Fence, matches null, and stacks a pointer to a
1042 -- PC_Cancel element which will abort the match on a subsequent failure.
1044 -- Since this is a single element it is numbered 1 (the reason we
1045 -- include it in the compound patterns section is that it backtracks).
1047 --------------------
1048 -- Fence Function --
1049 --------------------
1051 -- A call to the Fence function builds the structure:
1053 -- +---+ +---+ +---+
1054 -- | E |---->| P |---->| X |---->
1055 -- +---+ +---+ +---+
1057 -- Here E is the PC_R_Enter node which matches null and creates two
1058 -- stack entries. The first is a special entry which is not used at
1059 -- all in the fence case (it is present merely for uniformity with
1060 -- other cases of region enter operations).
1062 -- The second entry corresponds to a standard new region action. A
1063 -- PC_R_Remove node is stacked, whose cursor field is used to store
1064 -- the outer stack base, and the stack base is reset to point to
1065 -- this PC_R_Remove node. Then the pattern P is matched, and it can
1066 -- make history stack entries in the normal manner, so now the stack
1069 -- (stack entries made before fence pattern)
1071 -- (Special entry, not used at all)
1073 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
1074 -- saved base value for the enclosing region)
1076 -- (stack entries made by matching P)
1078 -- If the match of P fails, then the PC_R_Remove entry is popped
1079 -- and it removes both itself and the special entry underneath it,
1080 -- restores the outer stack base, and signals failure.
1082 -- If the match of P succeeds, then node X, the PC_Fence_X node, gets
1083 -- control. One might be tempted to think that at this point, the
1084 -- history stack entries made by matching P can just be removed since
1085 -- they certainly are not going to be used for rematching (that is
1086 -- whole point of Fence after all!) However, this is wrong, because
1087 -- it would result in the loss of possible assign-on-match entries
1088 -- for deferred pattern assignments.
1090 -- Instead what we do is to make a special entry whose node references
1091 -- PC_Fence_Y, and whose cursor saves the inner stack base value, i.e.
1092 -- the pointer to the PC_R_Remove entry. Then the outer stack base
1093 -- pointer is restored, so the stack looks like:
1095 -- (stack entries made before assign pattern)
1097 -- (Special entry, not used at all)
1099 -- (PC_R_Remove entry, "cursor" value is (negative)
1100 -- saved base value for the enclosing region)
1102 -- (stack entries made by matching P)
1104 -- (PC_Fence_Y entry, "cursor" value is (negative) stack
1105 -- pointer value referencing the PC_R_Remove entry).
1107 -- If a subsequent failure occurs, then the PC_Fence_Y entry removes
1108 -- the entire inner region, including all entries made by matching P,
1109 -- and alternatives prior to the Fence pattern are sought.
1111 -- The node numbering of the constituent pattern P is not affected.
1112 -- Where N is the number of nodes in P, the X node is numbered N + 1,
1113 -- and the E node is N + 2.
1119 -- Succeed builds a single node:
1125 -- The node S is the PC_Succeed node which matches null, and stacks
1126 -- a pointer to itself on the history stack, so that a subsequent
1127 -- failure repeats the same match.
1129 -- Since this is a single node it is numbered 1 (the reason we include
1130 -- it in the compound patterns section is that it backtracks).
1132 ---------------------
1133 -- Write Immediate --
1134 ---------------------
1136 -- The structure built for a write immediate operation (P * F, where
1137 -- F is a file access value) is:
1139 -- +---+ +---+ +---+
1140 -- | E |---->| P |---->| W |---->
1141 -- +---+ +---+ +---+
1143 -- Here E is the PC_R_Enter node and W is the PC_Write_Imm node. The
1144 -- handling is identical to that described above for Assign Immediate,
1145 -- except that at the point where a successful match occurs, the matched
1146 -- substring is written to the referenced file.
1148 -- The node numbering of the constituent pattern P is not affected.
1149 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1150 -- and the E node is N + 2.
1152 --------------------
1153 -- Write On Match --
1154 --------------------
1156 -- The structure built for a write on match operation (P ** F, where
1157 -- F is a file access value) is:
1159 -- +---+ +---+ +---+
1160 -- | E |---->| P |---->| W |---->
1161 -- +---+ +---+ +---+
1163 -- Here E is the PC_R_Enter node and W is the PC_Write_OnM node. The
1164 -- handling is identical to that described above for Assign On Match,
1165 -- except that at the point where a successful match has completed,
1166 -- the matched substring is written to the referenced file.
1168 -- The node numbering of the constituent pattern P is not affected.
1169 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1170 -- and the E node is N + 2.
1171 -----------------------
1172 -- Constant Patterns --
1173 -----------------------
1175 -- The following pattern elements are referenced only from the pattern
1176 -- history stack. In each case the processing for the pattern element
1177 -- results in pattern match abort, or further failure, so there is no
1178 -- need for a successor and no need for a node number
1180 CP_Assign : aliased PE := (PC_Assign, 0, N);
1181 CP_Cancel : aliased PE := (PC_Cancel, 0, N);
1182 CP_Fence_Y : aliased PE := (PC_Fence_Y, 0, N);
1183 CP_R_Remove : aliased PE := (PC_R_Remove, 0, N);
1184 CP_R_Restore : aliased PE := (PC_R_Restore, 0, N);
1186 -----------------------
1187 -- Local Subprograms --
1188 -----------------------
1190 function Alternate (L, R : PE_Ptr) return PE_Ptr;
1191 function "or" (L, R : PE_Ptr) return PE_Ptr renames Alternate;
1192 -- Build pattern structure corresponding to the alternation of L, R.
1193 -- (i.e. try to match L, and if that fails, try to match R).
1195 function Arbno_Simple (P : PE_Ptr) return PE_Ptr;
1196 -- Build simple Arbno pattern, P is a pattern that is guaranteed to
1197 -- match at least one character if it succeeds and to require no
1198 -- stack entries under all circumstances. The result returned is
1199 -- a simple Arbno structure as previously described.
1201 function Bracket (E, P, A : PE_Ptr) return PE_Ptr;
1202 -- Given two single node pattern elements E and A, and a (possible
1203 -- complex) pattern P, construct the concatenation E-->P-->A and
1204 -- return a pointer to E. The concatenation does not affect the
1205 -- node numbering in P. A has a number one higher than the maximum
1206 -- number in P, and E has a number two higher than the maximum
1207 -- number in P (see for example the Assign_Immediate structure to
1208 -- understand a typical use of this function).
1210 function BreakX_Make (B : PE_Ptr) return Pattern;
1211 -- Given a pattern element for a Break pattern, returns the
1212 -- corresponding BreakX compound pattern structure.
1214 function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr;
1215 -- Creates a pattern element that represents a concatenation of the
1216 -- two given pattern elements (i.e. the pattern L followed by R).
1217 -- The result returned is always the same as L, but the pattern
1218 -- referenced by L is modified to have R as a successor. This
1219 -- procedure does not copy L or R, so if a copy is required, it
1220 -- is the responsibility of the caller. The Incr parameter is an
1221 -- amount to be added to the Nat field of any P_Arbno_Y node that is
1222 -- in the left operand, it represents the additional stack space
1223 -- required by the right operand.
1225 function C_To_PE (C : PChar) return PE_Ptr;
1226 -- Given a character, constructs a pattern element that matches
1227 -- the single character.
1229 function Copy (P : PE_Ptr) return PE_Ptr;
1230 -- Creates a copy of the pattern element referenced by the given
1231 -- pattern element reference. This is a deep copy, which means that
1232 -- it follows the Next and Alt pointers.
1234 function Image (P : PE_Ptr) return String;
1235 -- Returns the image of the address of the referenced pattern element.
1236 -- This is equivalent to Image (To_Address (P));
1238 function Is_In (C : Character; Str : String) return Boolean;
1239 pragma Inline (Is_In);
1240 -- Determines if the character C is in string Str
1242 procedure Logic_Error;
1243 -- Called to raise Program_Error with an appropriate message if an
1244 -- internal logic error is detected.
1246 function Str_BF (A : Boolean_Func) return String;
1247 function Str_FP (A : File_Ptr) return String;
1248 function Str_NF (A : Natural_Func) return String;
1249 function Str_NP (A : Natural_Ptr) return String;
1250 function Str_PP (A : Pattern_Ptr) return String;
1251 function Str_VF (A : VString_Func) return String;
1252 function Str_VP (A : VString_Ptr) return String;
1253 -- These are debugging routines, which return a representation of the
1254 -- given access value (they are called only by Image and Dump)
1256 procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr);
1257 -- Adjusts all EOP pointers in Pat to point to Succ. No other changes
1258 -- are made. In particular, Succ is unchanged, and no index numbers
1259 -- are modified. Note that Pat may not be equal to EOP on entry.
1261 function S_To_PE (Str : PString) return PE_Ptr;
1262 -- Given a string, constructs a pattern element that matches the string
1264 procedure Uninitialized_Pattern;
1265 pragma No_Return (Uninitialized_Pattern);
1266 -- Called to raise Program_Error with an appropriate error message if
1267 -- an uninitialized pattern is used in any pattern construction or
1268 -- pattern matching operation.
1274 Start : out Natural;
1275 Stop : out Natural);
1276 -- This is the common pattern match routine. It is passed a string and
1277 -- a pattern, and it indicates success or failure, and on success the
1278 -- section of the string matched. It does not perform any assignments
1279 -- to the subject string, so pattern replacement is for the caller.
1281 -- Subject The subject string. The lower bound is always one. In the
1282 -- Match procedures, it is fine to use strings whose lower bound
1283 -- is not one, but we perform a one time conversion before the
1284 -- call to XMatch, so that XMatch does not have to be bothered
1285 -- with strange lower bounds.
1287 -- Pat_P Points to initial pattern element of pattern to be matched
1289 -- Pat_S Maximum required stack entries for pattern to be matched
1291 -- Start If match is successful, starting index of matched section.
1292 -- This value is always non-zero. A value of zero is used to
1293 -- indicate a failed match.
1295 -- Stop If match is successful, ending index of matched section.
1296 -- This can be zero if we match the null string at the start,
1297 -- in which case Start is set to zero, and Stop to one. If the
1298 -- Match fails, then the contents of Stop is undefined.
1304 Start : out Natural;
1305 Stop : out Natural);
1306 -- Identical in all respects to XMatch, except that trace information is
1307 -- output on Standard_Output during execution of the match. This is the
1308 -- version that is called if the original Match call has Debug => True.
1314 function "&" (L : PString; R : Pattern) return Pattern is
1316 return (AFC with R.Stk, Concat (S_To_PE (L), Copy (R.P), R.Stk));
1319 function "&" (L : Pattern; R : PString) return Pattern is
1321 return (AFC with L.Stk, Concat (Copy (L.P), S_To_PE (R), 0));
1324 function "&" (L : PChar; R : Pattern) return Pattern is
1326 return (AFC with R.Stk, Concat (C_To_PE (L), Copy (R.P), R.Stk));
1329 function "&" (L : Pattern; R : PChar) return Pattern is
1331 return (AFC with L.Stk, Concat (Copy (L.P), C_To_PE (R), 0));
1334 function "&" (L : Pattern; R : Pattern) return Pattern is
1336 return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk));
1345 -- +---+ +---+ +---+
1346 -- | E |---->| P |---->| A |---->
1347 -- +---+ +---+ +---+
1349 -- The node numbering of the constituent pattern P is not affected.
1350 -- Where N is the number of nodes in P, the A node is numbered N + 1,
1351 -- and the E node is N + 2.
1353 function "*" (P : Pattern; Var : VString_Var) return Pattern is
1354 Pat : constant PE_Ptr := Copy (P.P);
1355 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1356 A : constant PE_Ptr :=
1357 new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access);
1359 return (AFC with P.Stk + 3, Bracket (E, Pat, A));
1362 function "*" (P : PString; Var : VString_Var) return Pattern is
1363 Pat : constant PE_Ptr := S_To_PE (P);
1364 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1365 A : constant PE_Ptr :=
1366 new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access);
1368 return (AFC with 3, Bracket (E, Pat, A));
1371 function "*" (P : PChar; Var : VString_Var) return Pattern is
1372 Pat : constant PE_Ptr := C_To_PE (P);
1373 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1374 A : constant PE_Ptr :=
1375 new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access);
1377 return (AFC with 3, Bracket (E, Pat, A));
1382 -- +---+ +---+ +---+
1383 -- | E |---->| P |---->| W |---->
1384 -- +---+ +---+ +---+
1386 -- The node numbering of the constituent pattern P is not affected.
1387 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1388 -- and the E node is N + 2.
1390 function "*" (P : Pattern; Fil : File_Access) return Pattern is
1391 Pat : constant PE_Ptr := Copy (P.P);
1392 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1393 W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil);
1395 return (AFC with 3, Bracket (E, Pat, W));
1398 function "*" (P : PString; Fil : File_Access) return Pattern is
1399 Pat : constant PE_Ptr := S_To_PE (P);
1400 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1401 W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil);
1403 return (AFC with 3, Bracket (E, Pat, W));
1406 function "*" (P : PChar; Fil : File_Access) return Pattern is
1407 Pat : constant PE_Ptr := C_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);
1411 return (AFC with 3, Bracket (E, Pat, W));
1420 -- +---+ +---+ +---+
1421 -- | E |---->| P |---->| A |---->
1422 -- +---+ +---+ +---+
1424 -- The node numbering of the constituent pattern P is not affected.
1425 -- Where N is the number of nodes in P, the A node is numbered N + 1,
1426 -- and the E node is N + 2.
1428 function "**" (P : Pattern; Var : VString_Var) return Pattern is
1429 Pat : constant PE_Ptr := Copy (P.P);
1430 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1431 A : constant PE_Ptr :=
1432 new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access);
1434 return (AFC with P.Stk + 3, Bracket (E, Pat, A));
1437 function "**" (P : PString; Var : VString_Var) return Pattern is
1438 Pat : constant PE_Ptr := S_To_PE (P);
1439 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1440 A : constant PE_Ptr :=
1441 new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access);
1443 return (AFC with 3, Bracket (E, Pat, A));
1446 function "**" (P : PChar; Var : VString_Var) return Pattern is
1447 Pat : constant PE_Ptr := C_To_PE (P);
1448 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1449 A : constant PE_Ptr :=
1450 new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access);
1452 return (AFC with 3, Bracket (E, Pat, A));
1457 -- +---+ +---+ +---+
1458 -- | E |---->| P |---->| W |---->
1459 -- +---+ +---+ +---+
1461 -- The node numbering of the constituent pattern P is not affected.
1462 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1463 -- and the E node is N + 2.
1465 function "**" (P : Pattern; Fil : File_Access) return Pattern is
1466 Pat : constant PE_Ptr := Copy (P.P);
1467 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1468 W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil);
1470 return (AFC with P.Stk + 3, Bracket (E, Pat, W));
1473 function "**" (P : PString; Fil : File_Access) return Pattern is
1474 Pat : constant PE_Ptr := S_To_PE (P);
1475 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1476 W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil);
1478 return (AFC with 3, Bracket (E, Pat, W));
1481 function "**" (P : PChar; Fil : File_Access) return Pattern is
1482 Pat : constant PE_Ptr := C_To_PE (P);
1483 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1484 W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil);
1486 return (AFC with 3, Bracket (E, Pat, W));
1493 function "+" (Str : VString_Var) return Pattern is
1497 new PE'(PC_String_VP, 1, EOP, Str'Unrestricted_Access));
1500 function "+" (Str : VString_Func) return Pattern is
1502 return (AFC with 0, new PE'(PC_String_VF, 1, EOP, Str));
1505 function "+" (P : Pattern_Var) return Pattern is
1509 new PE'(PC_Rpat, 1, EOP, P'Unrestricted_Access));
1512 function "+" (P : Boolean_Func) return Pattern is
1514 return (AFC with 3, new PE'(PC_Pred_Func, 1, EOP, P));
1521 function "or" (L : PString; R : Pattern) return Pattern is
1523 return (AFC with R.Stk + 1, S_To_PE (L) or Copy (R.P));
1526 function "or" (L : Pattern; R : PString) return Pattern is
1528 return (AFC with L.Stk + 1, Copy (L.P) or S_To_PE (R));
1531 function "or" (L : PString; R : PString) return Pattern is
1533 return (AFC with 1, S_To_PE (L) or S_To_PE (R));
1536 function "or" (L : Pattern; R : Pattern) return Pattern is
1539 Natural'Max (L.Stk, R.Stk) + 1, Copy (L.P) or Copy (R.P));
1542 function "or" (L : PChar; R : Pattern) return Pattern is
1544 return (AFC with 1, C_To_PE (L) or Copy (R.P));
1547 function "or" (L : Pattern; R : PChar) return Pattern is
1549 return (AFC with 1, Copy (L.P) or C_To_PE (R));
1552 function "or" (L : PChar; R : PChar) return Pattern is
1554 return (AFC with 1, C_To_PE (L) or C_To_PE (R));
1557 function "or" (L : PString; R : PChar) return Pattern is
1559 return (AFC with 1, S_To_PE (L) or C_To_PE (R));
1562 function "or" (L : PChar; R : PString) return Pattern is
1564 return (AFC with 1, C_To_PE (L) or S_To_PE (R));
1571 -- No two patterns share the same pattern elements, so the adjust
1572 -- procedure for a Pattern assignment must do a deep copy of the
1573 -- pattern element structure.
1575 procedure Adjust (Object : in out Pattern) is
1577 Object.P := Copy (Object.P);
1584 function Alternate (L, R : PE_Ptr) return PE_Ptr is
1586 -- If the left pattern is null, then we just add the alternation
1587 -- node with an index one greater than the right hand pattern.
1590 return new PE'(PC_Alt, R.Index + 1, EOP, R);
1592 -- If the left pattern is non-null, then build a reference vector
1593 -- for its elements, and adjust their index values to accommodate
1594 -- the right hand elements. Then add the alternation node.
1598 Refs : Ref_Array (1 .. L.Index);
1601 Build_Ref_Array (L, Refs);
1603 for J in Refs'Range loop
1604 Refs (J).Index := Refs (J).Index + R.Index;
1608 return new PE'(PC_Alt, L.Index + 1, L, R);
1616 function Any (Str : String) return Pattern is
1618 return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, To_Set (Str)));
1621 function Any (Str : VString) return Pattern is
1623 return Any (S (Str));
1626 function Any (Str : Character) return Pattern is
1628 return (AFC with 0, new PE'(PC_Any_CH, 1, EOP, Str));
1631 function Any (Str : Character_Set) return Pattern is
1633 return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, Str));
1636 function Any (Str : not null access VString) return Pattern is
1638 return (AFC with 0, new PE'(PC_Any_VP, 1, EOP, VString_Ptr (Str)));
1641 function Any (Str : VString_Func) return Pattern is
1643 return (AFC with 0, new PE'(PC_Any_VF, 1, EOP, Str));
1659 -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1
1661 function Arb return Pattern is
1662 Y : constant PE_Ptr := new PE'(PC_Arb_Y, 1, EOP);
1663 X : constant PE_Ptr := new PE'(PC_Arb_X, 2, EOP, Y);
1665 return (AFC with 1, X);
1672 function Arbno (P : PString) return Pattern is
1674 if P'Length = 0 then
1675 return (AFC with 0, EOP);
1677 return (AFC with 0, Arbno_Simple (S_To_PE (P)));
1681 function Arbno (P : PChar) return Pattern is
1683 return (AFC with 0, Arbno_Simple (C_To_PE (P)));
1686 function Arbno (P : Pattern) return Pattern is
1687 Pat : constant PE_Ptr := Copy (P.P);
1691 and then OK_For_Simple_Arbno (Pat.Pcode)
1693 return (AFC with 0, Arbno_Simple (Pat));
1696 -- This is the complex case, either the pattern makes stack entries
1697 -- or it is possible for the pattern to match the null string (more
1698 -- accurately, we don't know that this is not the case).
1700 -- +--------------------------+
1708 -- +---+ +---+ +---+ |
1709 -- | E |---->| P |---->| Y |--->+
1710 -- +---+ +---+ +---+
1712 -- The node numbering of the constituent pattern P is not affected.
1713 -- Where N is the number of nodes in P, the Y node is numbered N + 1,
1714 -- the E node is N + 2, and the X node is N + 3.
1717 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1718 X : constant PE_Ptr := new PE'(PC_Arbno_X, 0, EOP, E);
1719 Y : constant PE_Ptr := new PE'(PC_Arbno_Y, 0, X, P.Stk + 3);
1720 EPY : constant PE_Ptr := Bracket (E, Pat, Y);
1723 X.Index := EPY.Index + 1;
1724 return (AFC with P.Stk + 3, X);
1741 -- | P |---------->+
1744 -- The node numbering of the constituent pattern P is not affected.
1745 -- The S node has a node number of P.Index + 1.
1747 -- Note that we know that P cannot be EOP, because a null pattern
1748 -- does not meet the requirements for simple Arbno.
1750 function Arbno_Simple (P : PE_Ptr) return PE_Ptr is
1751 S : constant PE_Ptr := new PE'(PC_Arbno_S, P.Index + 1, EOP, P);
1753 Set_Successor (P, S);
1761 function Bal return Pattern is
1763 return (AFC with 1, new PE'(PC_Bal, 1, EOP));
1770 function Bracket (E, P, A : PE_Ptr) return PE_Ptr is
1779 Set_Successor (P, A);
1780 E.Index := P.Index + 2;
1781 A.Index := P.Index + 1;
1791 function Break (Str : String) return Pattern is
1793 return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, To_Set (Str)));
1796 function Break (Str : VString) return Pattern is
1798 return Break (S (Str));
1801 function Break (Str : Character) return Pattern is
1803 return (AFC with 0, new PE'(PC_Break_CH, 1, EOP, Str));
1806 function Break (Str : Character_Set) return Pattern is
1808 return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, Str));
1811 function Break (Str : not null access VString) return Pattern is
1814 new PE'(PC_Break_VP, 1, EOP, Str.all'Unchecked_Access));
1817 function Break (Str : VString_Func) return Pattern is
1819 return (AFC with 0, new PE'(PC_Break_VF, 1, EOP, Str));
1826 function BreakX (Str : String) return Pattern is
1828 return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, To_Set (Str)));
1831 function BreakX (Str : VString) return Pattern is
1833 return BreakX (S (Str));
1836 function BreakX (Str : Character) return Pattern is
1838 return BreakX_Make (new PE'(PC_BreakX_CH, 3, N, Str));
1841 function BreakX (Str : Character_Set) return Pattern is
1843 return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, Str));
1846 function BreakX (Str : not null access VString) return Pattern is
1848 return BreakX_Make (new PE'(PC_BreakX_VP, 3, N, VString_Ptr (Str)));
1851 function BreakX (Str : VString_Func) return Pattern is
1853 return BreakX_Make (new PE'(PC_BreakX_VF, 3, N, Str));
1861 -- | B |---->| A |---->
1869 -- The B node is numbered 3, the alternative node is 1, and the X
1872 function BreakX_Make (B : PE_Ptr) return Pattern is
1873 X : constant PE_Ptr := new PE'(PC_BreakX_X, 2, B);
1874 A : constant PE_Ptr := new PE'(PC_Alt, 1, EOP, X);
1877 return (AFC with 2, B);
1880 ---------------------
1881 -- Build_Ref_Array --
1882 ---------------------
1884 procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array) is
1886 procedure Record_PE (E : PE_Ptr);
1887 -- Record given pattern element if not already recorded in RA,
1888 -- and also record any referenced pattern elements recursively.
1894 procedure Record_PE (E : PE_Ptr) is
1896 PutD (" Record_PE called with PE_Ptr = " & Image (E));
1898 if E = EOP or else RA (E.Index) /= null then
1899 Put_LineD (", nothing to do");
1903 Put_LineD (", recording" & IndexT'Image (E.Index));
1905 Record_PE (E.Pthen);
1907 if E.Pcode in PC_Has_Alt then
1913 -- Start of processing for Build_Ref_Array
1917 Put_LineD ("Entering Build_Ref_Array");
1920 end Build_Ref_Array;
1926 function C_To_PE (C : PChar) return PE_Ptr is
1928 return new PE'(PC_Char, 1, EOP, C);
1935 function Cancel return Pattern is
1937 return (AFC with 0, new PE'(PC_Cancel, 1, EOP));
1944 -- Concat needs to traverse the left operand performing the following
1947 -- a) Any successor pointers (Pthen fields) that are set to EOP are
1948 -- reset to point to the second operand.
1950 -- b) Any PC_Arbno_Y node has its stack count field incremented
1951 -- by the parameter Incr provided for this purpose.
1953 -- d) Num fields of all pattern elements in the left operand are
1954 -- adjusted to include the elements of the right operand.
1956 -- Note: we do not use Set_Successor in the processing for Concat, since
1957 -- there is no point in doing two traversals, we may as well do everything
1958 -- at the same time.
1960 function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr is
1970 Refs : Ref_Array (1 .. L.Index);
1971 -- We build a reference array for L whose N'th element points to
1972 -- the pattern element of L whose original Index value is N.
1977 Build_Ref_Array (L, Refs);
1979 for J in Refs'Range loop
1982 P.Index := P.Index + R.Index;
1984 if P.Pcode = PC_Arbno_Y then
1985 P.Nat := P.Nat + Incr;
1988 if P.Pthen = EOP then
1992 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
2006 function Copy (P : PE_Ptr) return PE_Ptr is
2009 Uninitialized_Pattern;
2013 Refs : Ref_Array (1 .. P.Index);
2014 -- References to elements in P, indexed by Index field
2016 Copy : Ref_Array (1 .. P.Index);
2017 -- Holds copies of elements of P, indexed by Index field
2022 Build_Ref_Array (P, Refs);
2024 -- Now copy all nodes
2026 for J in Refs'Range loop
2027 Copy (J) := new PE'(Refs (J).all);
2030 -- Adjust all internal references
2032 for J in Copy'Range loop
2035 -- Adjust successor pointer to point to copy
2037 if E.Pthen /= EOP then
2038 E.Pthen := Copy (E.Pthen.Index);
2041 -- Adjust Alt pointer if there is one to point to copy
2043 if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then
2044 E.Alt := Copy (E.Alt.Index);
2047 -- Copy referenced string
2049 if E.Pcode = PC_String then
2050 E.Str := new String'(E.Str.all);
2054 return Copy (P.Index);
2063 procedure Dump (P : Pattern) is
2065 subtype Count is Ada.Text_IO.Count;
2067 -- Used to keep track of column in dump output
2069 Refs : Ref_Array (1 .. P.P.Index);
2070 -- We build a reference array whose N'th element points to the
2071 -- pattern element whose Index value is N.
2073 Cols : Natural := 2;
2074 -- Number of columns used for pattern numbers, minimum is 2
2078 procedure Write_Node_Id (E : PE_Ptr);
2079 -- Writes out a string identifying the given pattern element
2085 procedure Write_Node_Id (E : PE_Ptr) is
2090 for J in 4 .. Cols loop
2096 Str : String (1 .. Cols);
2097 N : Natural := Natural (E.Index);
2102 for J in reverse Str'Range loop
2103 Str (J) := Character'Val (48 + N mod 10);
2112 -- Start of processing for Dump
2116 Put ("Pattern Dump Output (pattern at " &
2118 ", S = " & Natural'Image (P.Stk) & ')');
2123 while Col < Scol loop
2129 -- If uninitialized pattern, dump line and we are done
2132 Put_Line ("Uninitialized pattern value");
2136 -- If null pattern, just dump it and we are all done
2139 Put_Line ("EOP (null pattern)");
2143 Build_Ref_Array (P.P, Refs);
2145 -- Set number of columns required for node numbers
2147 while 10 ** Cols - 1 < Integer (P.P.Index) loop
2151 -- Now dump the nodes in reverse sequence. We output them in reverse
2152 -- sequence since this corresponds to the natural order used to
2153 -- construct the patterns.
2155 for J in reverse Refs'Range loop
2158 Set_Col (Count (Cols) + 4);
2161 Put (Pattern_Code'Image (E.Pcode));
2163 Set_Col (21 + Count (Cols) + Address_Image_Length);
2164 Write_Node_Id (E.Pthen);
2165 Set_Col (24 + 2 * Count (Cols) + Address_Image_Length);
2173 Write_Node_Id (E.Alt);
2176 Put (Str_PP (E.PP));
2178 when PC_Pred_Func =>
2179 Put (Str_BF (E.BF));
2181 when PC_Assign_Imm |
2190 Put (Str_VP (E.VP));
2194 Put (Str_FP (E.FP));
2197 Put (Image (E.Str.all));
2200 Put (Image (E.Str2));
2203 Put (Image (E.Str3));
2206 Put (Image (E.Str4));
2209 Put (Image (E.Str5));
2212 Put (Image (E.Str6));
2215 Put (Str_NP (E.Var));
2224 Put (''' & E.Char & ''');
2232 Put ('"' & To_Sequence (E.CS) & '"');
2247 Put (Str_NF (E.NF));
2254 Put (Str_NP (E.NP));
2263 Put (Str_VF (E.VF));
2265 when others => null;
2279 function Fail return Pattern is
2281 return (AFC with 0, new PE'(PC_Fail, 1, EOP));
2290 function Fence return Pattern is
2292 return (AFC with 1, new PE'(PC_Fence, 1, EOP));
2297 -- +---+ +---+ +---+
2298 -- | E |---->| P |---->| X |---->
2299 -- +---+ +---+ +---+
2301 -- The node numbering of the constituent pattern P is not affected.
2302 -- Where N is the number of nodes in P, the X node is numbered N + 1,
2303 -- and the E node is N + 2.
2305 function Fence (P : Pattern) return Pattern is
2306 Pat : constant PE_Ptr := Copy (P.P);
2307 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
2308 X : constant PE_Ptr := new PE'(PC_Fence_X, 0, EOP);
2310 return (AFC with P.Stk + 1, Bracket (E, Pat, X));
2317 procedure Finalize (Object : in out Pattern) is
2319 procedure Free is new Ada.Unchecked_Deallocation (PE, PE_Ptr);
2320 procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr);
2323 -- Nothing to do if already freed
2325 if Object.P = null then
2328 -- Otherwise we must free all elements
2332 Refs : Ref_Array (1 .. Object.P.Index);
2333 -- References to elements in pattern to be finalized
2336 Build_Ref_Array (Object.P, Refs);
2338 for J in Refs'Range loop
2339 if Refs (J).Pcode = PC_String then
2340 Free (Refs (J).Str);
2355 function Image (P : PE_Ptr) return String is
2357 return Image (To_Address (P));
2360 function Image (P : Pattern) return String is
2362 return S (Image (P));
2365 function Image (P : Pattern) return VString is
2367 Kill_Ampersand : Boolean := False;
2368 -- Set True to delete next & to be output to Result
2370 Result : VString := Nul;
2371 -- The result is accumulated here, using Append
2373 Refs : Ref_Array (1 .. P.P.Index);
2374 -- We build a reference array whose N'th element points to the
2375 -- pattern element whose Index value is N.
2377 procedure Delete_Ampersand;
2378 -- Deletes the ampersand at the end of Result
2380 procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean);
2381 -- E refers to a pattern structure whose successor is given by Succ.
2382 -- This procedure appends to Result a representation of this pattern.
2383 -- The Paren parameter indicates whether parentheses are required if
2384 -- the output is more than one element.
2386 procedure Image_One (E : in out PE_Ptr);
2387 -- E refers to a pattern structure. This procedure appends to Result
2388 -- a representation of the single simple or compound pattern structure
2389 -- at the start of E and updates E to point to its successor.
2391 ----------------------
2392 -- Delete_Ampersand --
2393 ----------------------
2395 procedure Delete_Ampersand is
2396 L : constant Natural := Length (Result);
2399 Delete (Result, L - 1, L);
2401 end Delete_Ampersand;
2407 procedure Image_One (E : in out PE_Ptr) is
2409 ER : PE_Ptr := E.Pthen;
2410 -- Successor set as result in E unless reset
2416 Append (Result, "Cancel");
2418 when PC_Alt => Alt : declare
2420 Elmts_In_L : constant IndexT := E.Pthen.Index - E.Alt.Index;
2421 -- Number of elements in left pattern of alternation
2423 Lowest_In_L : constant IndexT := E.Index - Elmts_In_L;
2424 -- Number of lowest index in elements of left pattern
2429 -- The successor of the alternation node must have a lower
2430 -- index than any node that is in the left pattern or a
2431 -- higher index than the alternation node itself.
2434 and then ER.Index >= Lowest_In_L
2435 and then ER.Index < E.Index
2440 Append (Result, '(');
2444 Image_Seq (E1.Pthen, ER, False);
2445 Append (Result, " or ");
2447 exit when E1.Pcode /= PC_Alt;
2450 Image_Seq (E1, ER, False);
2451 Append (Result, ')');
2455 Append (Result, "Any (" & Image (To_Sequence (E.CS)) & ')');
2458 Append (Result, "Any (" & Str_VF (E.VF) & ')');
2461 Append (Result, "Any (" & Str_VP (E.VP) & ')');
2464 Append (Result, "Arb");
2467 Append (Result, "Arbno (");
2468 Image_Seq (E.Alt, E, False);
2469 Append (Result, ')');
2472 Append (Result, "Arbno (");
2473 Image_Seq (E.Alt.Pthen, Refs (E.Index - 2), False);
2474 Append (Result, ')');
2476 when PC_Assign_Imm =>
2478 Append (Result, "* " & Str_VP (Refs (E.Index).VP));
2480 when PC_Assign_OnM =>
2482 Append (Result, "** " & Str_VP (Refs (E.Index).VP));
2485 Append (Result, "Any ('" & E.Char & "')");
2488 Append (Result, "Bal");
2491 Append (Result, "Break ('" & E.Char & "')");
2494 Append (Result, "Break (" & Image (To_Sequence (E.CS)) & ')');
2497 Append (Result, "Break (" & Str_VF (E.VF) & ')');
2500 Append (Result, "Break (" & Str_VP (E.VP) & ')');
2502 when PC_BreakX_CH =>
2503 Append (Result, "BreakX ('" & E.Char & "')");
2506 when PC_BreakX_CS =>
2507 Append (Result, "BreakX (" & Image (To_Sequence (E.CS)) & ')');
2510 when PC_BreakX_VF =>
2511 Append (Result, "BreakX (" & Str_VF (E.VF) & ')');
2514 when PC_BreakX_VP =>
2515 Append (Result, "BreakX (" & Str_VP (E.VP) & ')');
2519 Append (Result, ''' & E.Char & ''');
2522 Append (Result, "Fail");
2525 Append (Result, "Fence");
2528 Append (Result, "Fence (");
2529 Image_Seq (E.Pthen, Refs (E.Index - 1), False);
2530 Append (Result, ")");
2531 ER := Refs (E.Index - 1).Pthen;
2534 Append (Result, "Len (" & E.Nat & ')');
2537 Append (Result, "Len (" & Str_NF (E.NF) & ')');
2540 Append (Result, "Len (" & Str_NP (E.NP) & ')');
2542 when PC_NotAny_CH =>
2543 Append (Result, "NotAny ('" & E.Char & "')");
2545 when PC_NotAny_CS =>
2546 Append (Result, "NotAny (" & Image (To_Sequence (E.CS)) & ')');
2548 when PC_NotAny_VF =>
2549 Append (Result, "NotAny (" & Str_VF (E.VF) & ')');
2551 when PC_NotAny_VP =>
2552 Append (Result, "NotAny (" & Str_VP (E.VP) & ')');
2555 Append (Result, "NSpan ('" & E.Char & "')");
2558 Append (Result, "NSpan (" & Image (To_Sequence (E.CS)) & ')');
2561 Append (Result, "NSpan (" & Str_VF (E.VF) & ')');
2564 Append (Result, "NSpan (" & Str_VP (E.VP) & ')');
2567 Append (Result, """""");
2570 Append (Result, "Pos (" & E.Nat & ')');
2573 Append (Result, "Pos (" & Str_NF (E.NF) & ')');
2576 Append (Result, "Pos (" & Str_NP (E.NP) & ')');
2579 Kill_Ampersand := True;
2582 Append (Result, "Rest");
2585 Append (Result, "(+ " & Str_PP (E.PP) & ')');
2587 when PC_Pred_Func =>
2588 Append (Result, "(+ " & Str_BF (E.BF) & ')');
2591 Append (Result, "RPos (" & E.Nat & ')');
2594 Append (Result, "RPos (" & Str_NF (E.NF) & ')');
2597 Append (Result, "RPos (" & Str_NP (E.NP) & ')');
2600 Append (Result, "RTab (" & E.Nat & ')');
2603 Append (Result, "RTab (" & Str_NF (E.NF) & ')');
2606 Append (Result, "RTab (" & Str_NP (E.NP) & ')');
2609 Append (Result, "Setcur (" & Str_NP (E.Var) & ')');
2612 Append (Result, "Span ('" & E.Char & "')");
2615 Append (Result, "Span (" & Image (To_Sequence (E.CS)) & ')');
2618 Append (Result, "Span (" & Str_VF (E.VF) & ')');
2621 Append (Result, "Span (" & Str_VP (E.VP) & ')');
2624 Append (Result, Image (E.Str.all));
2627 Append (Result, Image (E.Str2));
2630 Append (Result, Image (E.Str3));
2633 Append (Result, Image (E.Str4));
2636 Append (Result, Image (E.Str5));
2639 Append (Result, Image (E.Str6));
2641 when PC_String_VF =>
2642 Append (Result, "(+" & Str_VF (E.VF) & ')');
2644 when PC_String_VP =>
2645 Append (Result, "(+" & Str_VP (E.VP) & ')');
2648 Append (Result, "Succeed");
2651 Append (Result, "Tab (" & E.Nat & ')');
2654 Append (Result, "Tab (" & Str_NF (E.NF) & ')');
2657 Append (Result, "Tab (" & Str_NP (E.NP) & ')');
2659 when PC_Write_Imm =>
2660 Append (Result, '(');
2661 Image_Seq (E, Refs (E.Index - 1), True);
2662 Append (Result, " * " & Str_FP (Refs (E.Index - 1).FP));
2663 ER := Refs (E.Index - 1).Pthen;
2665 when PC_Write_OnM =>
2666 Append (Result, '(');
2667 Image_Seq (E.Pthen, Refs (E.Index - 1), True);
2668 Append (Result, " ** " & Str_FP (Refs (E.Index - 1).FP));
2669 ER := Refs (E.Index - 1).Pthen;
2671 -- Other pattern codes should not appear as leading elements
2682 Append (Result, "???");
2693 procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is
2694 Indx : constant Natural := Length (Result);
2696 Mult : Boolean := False;
2699 -- The image of EOP is "" (the null string)
2702 Append (Result, """""");
2704 -- Else generate appropriate concatenation sequence
2709 exit when E1 = Succ;
2713 if Kill_Ampersand then
2714 Kill_Ampersand := False;
2716 Append (Result, " & ");
2721 if Mult and Paren then
2722 Insert (Result, Indx + 1, "(");
2723 Append (Result, ")");
2727 -- Start of processing for Image
2730 Build_Ref_Array (P.P, Refs);
2731 Image_Seq (P.P, EOP, False);
2739 function Is_In (C : Character; Str : String) return Boolean is
2741 for J in Str'Range loop
2754 function Len (Count : Natural) return Pattern is
2756 -- Note, the following is not just an optimization, it is needed
2757 -- to ensure that Arbno (Len (0)) does not generate an infinite
2758 -- matching loop (since PC_Len_Nat is OK_For_Simple_Arbno).
2761 return (AFC with 0, new PE'(PC_Null, 1, EOP));
2764 return (AFC with 0, new PE'(PC_Len_Nat, 1, EOP, Count));
2768 function Len (Count : Natural_Func) return Pattern is
2770 return (AFC with 0, new PE'(PC_Len_NF, 1, EOP, Count));
2773 function Len (Count : not null access Natural) return Pattern is
2775 return (AFC with 0, new PE'(PC_Len_NP, 1, EOP, Natural_Ptr (Count)));
2782 procedure Logic_Error is
2784 raise Program_Error with
2785 "Internal logic error in GNAT.Spitbol.Patterns";
2794 Pat : Pattern) return Boolean
2796 S : Big_String_Access;
2800 pragma Unreferenced (Stop);
2803 Get_String (Subject, S, L);
2806 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2808 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2816 Pat : Pattern) return Boolean
2818 Start, Stop : Natural;
2819 pragma Unreferenced (Stop);
2821 subtype String1 is String (1 .. Subject'Length);
2825 XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2827 XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2834 (Subject : VString_Var;
2836 Replace : VString) return Boolean
2840 S : Big_String_Access;
2844 Get_String (Subject, S, L);
2847 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2849 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2855 Get_String (Replace, S, L);
2857 (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
2863 (Subject : VString_Var;
2865 Replace : String) return Boolean
2869 S : Big_String_Access;
2873 Get_String (Subject, S, L);
2876 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2878 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2885 (Subject'Unrestricted_Access.all, Start, Stop, Replace);
2894 S : Big_String_Access;
2899 pragma Unreferenced (Start, Stop);
2902 Get_String (Subject, S, L);
2905 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2907 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2915 Start, Stop : Natural;
2916 pragma Unreferenced (Start, Stop);
2918 subtype String1 is String (1 .. Subject'Length);
2922 XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2924 XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2929 (Subject : in out VString;
2935 S : Big_String_Access;
2939 Get_String (Subject, S, L);
2942 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2944 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2948 Get_String (Replace, S, L);
2949 Replace_Slice (Subject, Start, Stop, S (1 .. L));
2954 (Subject : in out VString;
2960 S : Big_String_Access;
2964 Get_String (Subject, S, L);
2967 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2969 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2973 Replace_Slice (Subject, Start, Stop, Replace);
2979 Pat : PString) return Boolean
2981 Pat_Len : constant Natural := Pat'Length;
2982 S : Big_String_Access;
2986 Get_String (Subject, S, L);
2988 if Anchored_Mode then
2992 return Pat = S (1 .. Pat_Len);
2996 for J in 1 .. L - Pat_Len + 1 loop
2997 if Pat = S (J .. J + (Pat_Len - 1)) then
3008 Pat : PString) return Boolean
3010 Pat_Len : constant Natural := Pat'Length;
3011 Sub_Len : constant Natural := Subject'Length;
3012 SFirst : constant Natural := Subject'First;
3015 if Anchored_Mode then
3016 if Pat_Len > Sub_Len then
3019 return Pat = Subject (SFirst .. SFirst + Pat_Len - 1);
3023 for J in SFirst .. SFirst + Sub_Len - Pat_Len loop
3024 if Pat = Subject (J .. J + (Pat_Len - 1)) then
3034 (Subject : VString_Var;
3036 Replace : VString) return Boolean
3040 S : Big_String_Access;
3044 Get_String (Subject, S, L);
3047 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3049 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3055 Get_String (Replace, S, L);
3057 (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
3063 (Subject : VString_Var;
3065 Replace : String) return Boolean
3069 S : Big_String_Access;
3073 Get_String (Subject, S, L);
3076 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3078 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3085 (Subject'Unrestricted_Access.all, Start, Stop, Replace);
3094 S : Big_String_Access;
3099 pragma Unreferenced (Start, Stop);
3102 Get_String (Subject, S, L);
3105 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3107 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3115 Start, Stop : Natural;
3116 pragma Unreferenced (Start, Stop);
3118 subtype String1 is String (1 .. Subject'Length);
3122 XMatchD (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
3124 XMatch (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
3129 (Subject : in out VString;
3135 S : Big_String_Access;
3139 Get_String (Subject, S, L);
3142 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3144 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3148 Get_String (Replace, S, L);
3149 Replace_Slice (Subject, Start, Stop, S (1 .. L));
3154 (Subject : in out VString;
3160 S : Big_String_Access;
3164 Get_String (Subject, S, L);
3167 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3169 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3173 Replace_Slice (Subject, Start, Stop, Replace);
3178 (Subject : VString_Var;
3180 Result : Match_Result_Var) return Boolean
3184 S : Big_String_Access;
3188 Get_String (Subject, S, L);
3191 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3193 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3197 Result'Unrestricted_Access.all.Var := null;
3201 Result'Unrestricted_Access.all.Var := Subject'Unrestricted_Access;
3202 Result'Unrestricted_Access.all.Start := Start;
3203 Result'Unrestricted_Access.all.Stop := Stop;
3209 (Subject : in out VString;
3211 Result : out Match_Result)
3215 S : Big_String_Access;
3219 Get_String (Subject, S, L);
3222 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3224 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3230 Result.Var := Subject'Unrestricted_Access;
3231 Result.Start := Start;
3232 Result.Stop := Stop;
3240 procedure New_LineD is
3242 if Internal_Debug then
3251 function NotAny (Str : String) return Pattern is
3253 return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, To_Set (Str)));
3256 function NotAny (Str : VString) return Pattern is
3258 return NotAny (S (Str));
3261 function NotAny (Str : Character) return Pattern is
3263 return (AFC with 0, new PE'(PC_NotAny_CH, 1, EOP, Str));
3266 function NotAny (Str : Character_Set) return Pattern is
3268 return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str));
3271 function NotAny (Str : not null access VString) return Pattern is
3273 return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str)));
3276 function NotAny (Str : VString_Func) return Pattern is
3278 return (AFC with 0, new PE'(PC_NotAny_VF, 1, EOP, Str));
3285 function NSpan (Str : String) return Pattern is
3287 return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, To_Set (Str)));
3290 function NSpan (Str : VString) return Pattern is
3292 return NSpan (S (Str));
3295 function NSpan (Str : Character) return Pattern is
3297 return (AFC with 0, new PE'(PC_NSpan_CH, 1, EOP, Str));
3300 function NSpan (Str : Character_Set) return Pattern is
3302 return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str));
3305 function NSpan (Str : not null access VString) return Pattern is
3307 return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str)));
3310 function NSpan (Str : VString_Func) return Pattern is
3312 return (AFC with 0, new PE'(PC_NSpan_VF, 1, EOP, Str));
3319 function Pos (Count : Natural) return Pattern is
3321 return (AFC with 0, new PE'(PC_Pos_Nat, 1, EOP, Count));
3324 function Pos (Count : Natural_Func) return Pattern is
3326 return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count));
3329 function Pos (Count : not null access Natural) return Pattern is
3331 return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count)));
3338 procedure PutD (Str : String) is
3340 if Internal_Debug then
3349 procedure Put_LineD (Str : String) is
3351 if Internal_Debug then
3361 (Result : in out Match_Result;
3364 S : Big_String_Access;
3368 Get_String (Replace, S, L);
3370 if Result.Var /= null then
3371 Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L));
3380 function Rest return Pattern is
3382 return (AFC with 0, new PE'(PC_Rest, 1, EOP));
3389 function Rpos (Count : Natural) return Pattern is
3391 return (AFC with 0, new PE'(PC_RPos_Nat, 1, EOP, Count));
3394 function Rpos (Count : Natural_Func) return Pattern is
3396 return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count));
3399 function Rpos (Count : not null access Natural) return Pattern is
3401 return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count)));
3408 function Rtab (Count : Natural) return Pattern is
3410 return (AFC with 0, new PE'(PC_RTab_Nat, 1, EOP, Count));
3413 function Rtab (Count : Natural_Func) return Pattern is
3415 return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count));
3418 function Rtab (Count : not null access Natural) return Pattern is
3420 return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count)));
3427 function S_To_PE (Str : PString) return PE_Ptr is
3428 Len : constant Natural := Str'Length;
3433 return new PE'(PC_Null, 1, EOP);
3436 return new PE'(PC_Char, 1, EOP, Str (Str'First));
3439 return new PE'(PC_String_2, 1, EOP, Str);
3442 return new PE'(PC_String_3, 1, EOP, Str);
3445 return new PE'(PC_String_4, 1, EOP, Str);
3448 return new PE'(PC_String_5, 1, EOP, Str);
3451 return new PE'(PC_String_6, 1, EOP, Str);
3454 return new PE'(PC_String, 1, EOP, new String'(Str));
3463 -- Note: this procedure is not used by the normal concatenation circuit,
3464 -- since other fixups are required on the left operand in this case, and
3465 -- they might as well be done all together.
3467 procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is
3470 Uninitialized_Pattern;
3472 elsif Pat = EOP then
3477 Refs : Ref_Array (1 .. Pat.Index);
3478 -- We build a reference array for L whose N'th element points to
3479 -- the pattern element of L whose original Index value is N.
3484 Build_Ref_Array (Pat, Refs);
3486 for J in Refs'Range loop
3489 if P.Pthen = EOP then
3493 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
3505 function Setcur (Var : not null access Natural) return Pattern is
3507 return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var)));
3514 function Span (Str : String) return Pattern is
3516 return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, To_Set (Str)));
3519 function Span (Str : VString) return Pattern is
3521 return Span (S (Str));
3524 function Span (Str : Character) return Pattern is
3526 return (AFC with 0, new PE'(PC_Span_CH, 1, EOP, Str));
3529 function Span (Str : Character_Set) return Pattern is
3531 return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str));
3534 function Span (Str : not null access VString) return Pattern is
3536 return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str)));
3539 function Span (Str : VString_Func) return Pattern is
3541 return (AFC with 0, new PE'(PC_Span_VF, 1, EOP, Str));
3548 function Str_BF (A : Boolean_Func) return String is
3549 function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address);
3551 return "BF(" & Image (To_A (A)) & ')';
3558 function Str_FP (A : File_Ptr) return String is
3560 return "FP(" & Image (A.all'Address) & ')';
3567 function Str_NF (A : Natural_Func) return String is
3568 function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address);
3570 return "NF(" & Image (To_A (A)) & ')';
3577 function Str_NP (A : Natural_Ptr) return String is
3579 return "NP(" & Image (A.all'Address) & ')';
3586 function Str_PP (A : Pattern_Ptr) return String is
3588 return "PP(" & Image (A.all'Address) & ')';
3595 function Str_VF (A : VString_Func) return String is
3596 function To_A is new Ada.Unchecked_Conversion (VString_Func, Address);
3598 return "VF(" & Image (To_A (A)) & ')';
3605 function Str_VP (A : VString_Ptr) return String is
3607 return "VP(" & Image (A.all'Address) & ')';
3614 function Succeed return Pattern is
3616 return (AFC with 1, new PE'(PC_Succeed, 1, EOP));
3623 function Tab (Count : Natural) return Pattern is
3625 return (AFC with 0, new PE'(PC_Tab_Nat, 1, EOP, Count));
3628 function Tab (Count : Natural_Func) return Pattern is
3630 return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count));
3633 function Tab (Count : not null access Natural) return Pattern is
3635 return (AFC with 0, new PE'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count)));
3638 ---------------------------
3639 -- Uninitialized_Pattern --
3640 ---------------------------
3642 procedure Uninitialized_Pattern is
3644 raise Program_Error with
3645 "uninitialized value of type GNAT.Spitbol.Patterns.Pattern";
3646 end Uninitialized_Pattern;
3656 Start : out Natural;
3660 -- Pointer to current pattern node. Initialized from Pat_P, and then
3661 -- updated as the match proceeds through its constituent elements.
3663 Length : constant Natural := Subject'Length;
3664 -- Length of string (= Subject'Last, since Subject'First is always 1)
3666 Cursor : Integer := 0;
3667 -- If the value is non-negative, then this value is the index showing
3668 -- the current position of the match in the subject string. The next
3669 -- character to be matched is at Subject (Cursor + 1). Note that since
3670 -- our view of the subject string in XMatch always has a lower bound
3671 -- of one, regardless of original bounds, that this definition exactly
3672 -- corresponds to the cursor value as referenced by functions like Pos.
3674 -- If the value is negative, then this is a saved stack pointer,
3675 -- typically a base pointer of an inner or outer region. Cursor
3676 -- temporarily holds such a value when it is popped from the stack
3677 -- by Fail. In all cases, Cursor is reset to a proper non-negative
3678 -- cursor value before the match proceeds (e.g. by propagating the
3679 -- failure and popping a "real" cursor value from the stack.
3681 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
3682 -- Dummy pattern element used in the unanchored case
3685 -- The pattern matching failure stack for this call to Match
3687 Stack_Ptr : Stack_Range;
3688 -- Current stack pointer. This points to the top element of the stack
3689 -- that is currently in use. At the outer level this is the special
3690 -- entry placed on the stack according to the anchor mode.
3692 Stack_Init : constant Stack_Range := Stack'First + 1;
3693 -- This is the initial value of the Stack_Ptr and Stack_Base. The
3694 -- initial (Stack'First) element of the stack is not used so that
3695 -- when we pop the last element off, Stack_Ptr is still in range.
3697 Stack_Base : Stack_Range;
3698 -- This value is the stack base value, i.e. the stack pointer for the
3699 -- first history stack entry in the current stack region. See separate
3700 -- section on handling of recursive pattern matches.
3702 Assign_OnM : Boolean := False;
3703 -- Set True if assign-on-match or write-on-match operations may be
3704 -- present in the history stack, which must then be scanned on a
3705 -- successful match.
3707 procedure Pop_Region;
3708 pragma Inline (Pop_Region);
3709 -- Used at the end of processing of an inner region. If the inner
3710 -- region left no stack entries, then all trace of it is removed.
3711 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
3712 -- handling of alternatives in the inner region.
3714 procedure Push (Node : PE_Ptr);
3715 pragma Inline (Push);
3716 -- Make entry in pattern matching stack with current cursor value
3718 procedure Push_Region;
3719 pragma Inline (Push_Region);
3720 -- This procedure makes a new region on the history stack. The
3721 -- caller first establishes the special entry on the stack, but
3722 -- does not push the stack pointer. Then this call stacks a
3723 -- PC_Remove_Region node, on top of this entry, using the cursor
3724 -- field of the PC_Remove_Region entry to save the outer level
3725 -- stack base value, and resets the stack base to point to this
3726 -- PC_Remove_Region node.
3732 procedure Pop_Region is
3734 -- If nothing was pushed in the inner region, we can just get
3735 -- rid of it entirely, leaving no traces that it was ever there
3737 if Stack_Ptr = Stack_Base then
3738 Stack_Ptr := Stack_Base - 2;
3739 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
3741 -- If stuff was pushed in the inner region, then we have to
3742 -- push a PC_R_Restore node so that we properly handle possible
3743 -- rematches within the region.
3746 Stack_Ptr := Stack_Ptr + 1;
3747 Stack (Stack_Ptr).Cursor := Stack_Base;
3748 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
3749 Stack_Base := Stack (Stack_Base).Cursor;
3757 procedure Push (Node : PE_Ptr) is
3759 Stack_Ptr := Stack_Ptr + 1;
3760 Stack (Stack_Ptr).Cursor := Cursor;
3761 Stack (Stack_Ptr).Node := Node;
3768 procedure Push_Region is
3770 Stack_Ptr := Stack_Ptr + 2;
3771 Stack (Stack_Ptr).Cursor := Stack_Base;
3772 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
3773 Stack_Base := Stack_Ptr;
3776 -- Start of processing for XMatch
3779 if Pat_P = null then
3780 Uninitialized_Pattern;
3783 -- Check we have enough stack for this pattern. This check deals with
3784 -- every possibility except a match of a recursive pattern, where we
3785 -- make a check at each recursion level.
3787 if Pat_S >= Stack_Size - 1 then
3788 raise Pattern_Stack_Overflow;
3791 -- In anchored mode, the bottom entry on the stack is an abort entry
3793 if Anchored_Mode then
3794 Stack (Stack_Init).Node := CP_Cancel'Access;
3795 Stack (Stack_Init).Cursor := 0;
3797 -- In unanchored more, the bottom entry on the stack references
3798 -- the special pattern element PE_Unanchored, whose Pthen field
3799 -- points to the initial pattern element. The cursor value in this
3800 -- entry is the number of anchor moves so far.
3803 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
3804 Stack (Stack_Init).Cursor := 0;
3807 Stack_Ptr := Stack_Init;
3808 Stack_Base := Stack_Ptr;
3813 -----------------------------------------
3814 -- Main Pattern Matching State Control --
3815 -----------------------------------------
3817 -- This is a state machine which uses gotos to change state. The
3818 -- initial state is Match, to initiate the matching of the first
3819 -- element, so the goto Match above starts the match. In the
3820 -- following descriptions, we indicate the global values that
3821 -- are relevant for the state transition.
3823 -- Come here if entire match fails
3830 -- Come here if entire match succeeds
3832 -- Cursor current position in subject string
3835 Start := Stack (Stack_Init).Cursor + 1;
3838 -- Scan history stack for deferred assignments or writes
3841 for S in Stack_Init .. Stack_Ptr loop
3842 if Stack (S).Node = CP_Assign'Access then
3844 Inner_Base : constant Stack_Range :=
3845 Stack (S + 1).Cursor;
3846 Special_Entry : constant Stack_Range :=
3848 Node_OnM : constant PE_Ptr :=
3849 Stack (Special_Entry).Node;
3850 Start : constant Natural :=
3851 Stack (Special_Entry).Cursor + 1;
3852 Stop : constant Natural := Stack (S).Cursor;
3855 if Node_OnM.Pcode = PC_Assign_OnM then
3856 Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
3858 elsif Node_OnM.Pcode = PC_Write_OnM then
3859 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
3871 -- Come here if attempt to match current element fails
3873 -- Stack_Base current stack base
3874 -- Stack_Ptr current stack pointer
3877 Cursor := Stack (Stack_Ptr).Cursor;
3878 Node := Stack (Stack_Ptr).Node;
3879 Stack_Ptr := Stack_Ptr - 1;
3882 -- Come here if attempt to match current element succeeds
3884 -- Cursor current position in subject string
3885 -- Node pointer to node successfully matched
3886 -- Stack_Base current stack base
3887 -- Stack_Ptr current stack pointer
3892 -- Come here to match the next pattern element
3894 -- Cursor current position in subject string
3895 -- Node pointer to node to be matched
3896 -- Stack_Base current stack base
3897 -- Stack_Ptr current stack pointer
3901 --------------------------------------------------
3902 -- Main Pattern Match Element Matching Routines --
3903 --------------------------------------------------
3905 -- Here is the case statement that processes the current node. The
3906 -- processing for each element does one of five things:
3908 -- goto Succeed to move to the successor
3909 -- goto Match_Succeed if the entire match succeeds
3910 -- goto Match_Fail if the entire match fails
3911 -- goto Fail to signal failure of current match
3913 -- Processing is NOT allowed to fall through
3929 -- Any (one character case)
3933 and then Subject (Cursor + 1) = Node.Char
3935 Cursor := Cursor + 1;
3941 -- Any (character set case)
3945 and then Is_In (Subject (Cursor + 1), Node.CS)
3947 Cursor := Cursor + 1;
3953 -- Any (string function case)
3955 when PC_Any_VF => declare
3956 U : constant VString := Node.VF.all;
3957 S : Big_String_Access;
3961 Get_String (U, S, L);
3964 and then Is_In (Subject (Cursor + 1), S (1 .. L))
3966 Cursor := Cursor + 1;
3973 -- Any (string pointer case)
3975 when PC_Any_VP => declare
3976 U : constant VString := Node.VP.all;
3977 S : Big_String_Access;
3981 Get_String (U, S, L);
3984 and then Is_In (Subject (Cursor + 1), S (1 .. L))
3986 Cursor := Cursor + 1;
3993 -- Arb (initial match)
4003 if Cursor < Length then
4004 Cursor := Cursor + 1;
4011 -- Arbno_S (simple Arbno initialize). This is the node that
4012 -- initiates the match of a simple Arbno structure.
4019 -- Arbno_X (Arbno initialize). This is the node that initiates
4020 -- the match of a complex Arbno structure.
4027 -- Arbno_Y (Arbno rematch). This is the node that is executed
4028 -- following successful matching of one instance of a complex
4031 when PC_Arbno_Y => declare
4032 Null_Match : constant Boolean :=
4033 Cursor = Stack (Stack_Base - 1).Cursor;
4038 -- If arbno extension matched null, then immediately fail
4044 -- Here we must do a stack check to make sure enough stack
4045 -- is left. This check will happen once for each instance of
4046 -- the Arbno pattern that is matched. The Nat field of a
4047 -- PC_Arbno pattern contains the maximum stack entries needed
4048 -- for the Arbno with one instance and the successor pattern
4050 if Stack_Ptr + Node.Nat >= Stack'Last then
4051 raise Pattern_Stack_Overflow;
4057 -- Assign. If this node is executed, it means the assign-on-match
4058 -- or write-on-match operation will not happen after all, so we
4059 -- is propagate the failure, removing the PC_Assign node.
4064 -- Assign immediate. This node performs the actual assignment
4066 when PC_Assign_Imm =>
4069 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4073 -- Assign on match. This node sets up for the eventual assignment
4075 when PC_Assign_OnM =>
4076 Stack (Stack_Base - 1).Node := Node;
4077 Push (CP_Assign'Access);
4085 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
4088 elsif Subject (Cursor + 1) = '(' then
4090 Paren_Count : Natural := 1;
4094 Cursor := Cursor + 1;
4096 if Cursor >= Length then
4099 elsif Subject (Cursor + 1) = '(' then
4100 Paren_Count := Paren_Count + 1;
4102 elsif Subject (Cursor + 1) = ')' then
4103 Paren_Count := Paren_Count - 1;
4104 exit when Paren_Count = 0;
4110 Cursor := Cursor + 1;
4114 -- Break (one character case)
4117 while Cursor < Length loop
4118 if Subject (Cursor + 1) = Node.Char then
4121 Cursor := Cursor + 1;
4127 -- Break (character set case)
4130 while Cursor < Length loop
4131 if Is_In (Subject (Cursor + 1), Node.CS) then
4134 Cursor := Cursor + 1;
4140 -- Break (string function case)
4142 when PC_Break_VF => declare
4143 U : constant VString := Node.VF.all;
4144 S : Big_String_Access;
4148 Get_String (U, S, L);
4150 while Cursor < Length loop
4151 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4154 Cursor := Cursor + 1;
4161 -- Break (string pointer case)
4163 when PC_Break_VP => declare
4164 U : constant VString := Node.VP.all;
4165 S : Big_String_Access;
4169 Get_String (U, S, L);
4171 while Cursor < Length loop
4172 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4175 Cursor := Cursor + 1;
4182 -- BreakX (one character case)
4184 when PC_BreakX_CH =>
4185 while Cursor < Length loop
4186 if Subject (Cursor + 1) = Node.Char then
4189 Cursor := Cursor + 1;
4195 -- BreakX (character set case)
4197 when PC_BreakX_CS =>
4198 while Cursor < Length loop
4199 if Is_In (Subject (Cursor + 1), Node.CS) then
4202 Cursor := Cursor + 1;
4208 -- BreakX (string function case)
4210 when PC_BreakX_VF => declare
4211 U : constant VString := Node.VF.all;
4212 S : Big_String_Access;
4216 Get_String (U, S, L);
4218 while Cursor < Length loop
4219 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4222 Cursor := Cursor + 1;
4229 -- BreakX (string pointer case)
4231 when PC_BreakX_VP => declare
4232 U : constant VString := Node.VP.all;
4233 S : Big_String_Access;
4237 Get_String (U, S, L);
4239 while Cursor < Length loop
4240 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4243 Cursor := Cursor + 1;
4250 -- BreakX_X (BreakX extension). See section on "Compound Pattern
4251 -- Structures". This node is the alternative that is stacked to
4252 -- skip past the break character and extend the break.
4255 Cursor := Cursor + 1;
4258 -- Character (one character string)
4262 and then Subject (Cursor + 1) = Node.Char
4264 Cursor := Cursor + 1;
4273 if Stack_Base = Stack_Init then
4276 -- End of recursive inner match. See separate section on
4277 -- handing of recursive pattern matches for details.
4280 Node := Stack (Stack_Base - 1).Node;
4290 -- Fence (built in pattern)
4293 Push (CP_Cancel'Access);
4296 -- Fence function node X. This is the node that gets control
4297 -- after a successful match of the fenced pattern.
4300 Stack_Ptr := Stack_Ptr + 1;
4301 Stack (Stack_Ptr).Cursor := Stack_Base;
4302 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
4303 Stack_Base := Stack (Stack_Base).Cursor;
4306 -- Fence function node Y. This is the node that gets control on
4307 -- a failure that occurs after the fenced pattern has matched.
4309 -- Note: the Cursor at this stage is actually the inner stack
4310 -- base value. We don't reset this, but we do use it to strip
4311 -- off all the entries made by the fenced pattern.
4314 Stack_Ptr := Cursor - 2;
4317 -- Len (integer case)
4320 if Cursor + Node.Nat > Length then
4323 Cursor := Cursor + Node.Nat;
4327 -- Len (Integer function case)
4329 when PC_Len_NF => declare
4330 N : constant Natural := Node.NF.all;
4332 if Cursor + N > Length then
4335 Cursor := Cursor + N;
4340 -- Len (integer pointer case)
4343 if Cursor + Node.NP.all > Length then
4346 Cursor := Cursor + Node.NP.all;
4350 -- NotAny (one character case)
4352 when PC_NotAny_CH =>
4354 and then Subject (Cursor + 1) /= Node.Char
4356 Cursor := Cursor + 1;
4362 -- NotAny (character set case)
4364 when PC_NotAny_CS =>
4366 and then not Is_In (Subject (Cursor + 1), Node.CS)
4368 Cursor := Cursor + 1;
4374 -- NotAny (string function case)
4376 when PC_NotAny_VF => declare
4377 U : constant VString := Node.VF.all;
4378 S : Big_String_Access;
4382 Get_String (U, S, L);
4386 not Is_In (Subject (Cursor + 1), S (1 .. L))
4388 Cursor := Cursor + 1;
4395 -- NotAny (string pointer case)
4397 when PC_NotAny_VP => declare
4398 U : constant VString := Node.VP.all;
4399 S : Big_String_Access;
4403 Get_String (U, S, L);
4407 not Is_In (Subject (Cursor + 1), S (1 .. L))
4409 Cursor := Cursor + 1;
4416 -- NSpan (one character case)
4419 while Cursor < Length
4420 and then Subject (Cursor + 1) = Node.Char
4422 Cursor := Cursor + 1;
4427 -- NSpan (character set case)
4430 while Cursor < Length
4431 and then Is_In (Subject (Cursor + 1), Node.CS)
4433 Cursor := Cursor + 1;
4438 -- NSpan (string function case)
4440 when PC_NSpan_VF => declare
4441 U : constant VString := Node.VF.all;
4442 S : Big_String_Access;
4446 Get_String (U, S, L);
4448 while Cursor < Length
4449 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4451 Cursor := Cursor + 1;
4457 -- NSpan (string pointer case)
4459 when PC_NSpan_VP => declare
4460 U : constant VString := Node.VP.all;
4461 S : Big_String_Access;
4465 Get_String (U, S, L);
4467 while Cursor < Length
4468 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4470 Cursor := Cursor + 1;
4481 -- Pos (integer case)
4484 if Cursor = Node.Nat then
4490 -- Pos (Integer function case)
4492 when PC_Pos_NF => declare
4493 N : constant Natural := Node.NF.all;
4502 -- Pos (integer pointer case)
4505 if Cursor = Node.NP.all then
4511 -- Predicate function
4513 when PC_Pred_Func =>
4520 -- Region Enter. Initiate new pattern history stack region
4523 Stack (Stack_Ptr + 1).Cursor := Cursor;
4527 -- Region Remove node. This is the node stacked by an R_Enter.
4528 -- It removes the special format stack entry right underneath, and
4529 -- then restores the outer level stack base and signals failure.
4531 -- Note: the cursor value at this stage is actually the (negative)
4532 -- stack base value for the outer level.
4535 Stack_Base := Cursor;
4536 Stack_Ptr := Stack_Ptr - 1;
4539 -- Region restore node. This is the node stacked at the end of an
4540 -- inner level match. Its function is to restore the inner level
4541 -- region, so that alternatives in this region can be sought.
4543 -- Note: the Cursor at this stage is actually the negative of the
4544 -- inner stack base value, which we use to restore the inner region.
4546 when PC_R_Restore =>
4547 Stack_Base := Cursor;
4556 -- Initiate recursive match (pattern pointer case)
4559 Stack (Stack_Ptr + 1).Node := Node.Pthen;
4562 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
4563 raise Pattern_Stack_Overflow;
4565 Node := Node.PP.all.P;
4569 -- RPos (integer case)
4572 if Cursor = (Length - Node.Nat) then
4578 -- RPos (integer function case)
4580 when PC_RPos_NF => declare
4581 N : constant Natural := Node.NF.all;
4583 if Length - Cursor = N then
4590 -- RPos (integer pointer case)
4593 if Cursor = (Length - Node.NP.all) then
4599 -- RTab (integer case)
4602 if Cursor <= (Length - Node.Nat) then
4603 Cursor := Length - Node.Nat;
4609 -- RTab (integer function case)
4611 when PC_RTab_NF => declare
4612 N : constant Natural := Node.NF.all;
4614 if Length - Cursor >= N then
4615 Cursor := Length - N;
4622 -- RTab (integer pointer case)
4625 if Cursor <= (Length - Node.NP.all) then
4626 Cursor := Length - Node.NP.all;
4632 -- Cursor assignment
4635 Node.Var.all := Cursor;
4638 -- Span (one character case)
4640 when PC_Span_CH => declare
4646 and then Subject (P + 1) = Node.Char
4659 -- Span (character set case)
4661 when PC_Span_CS => declare
4667 and then Is_In (Subject (P + 1), Node.CS)
4680 -- Span (string function case)
4682 when PC_Span_VF => declare
4683 U : constant VString := Node.VF.all;
4684 S : Big_String_Access;
4689 Get_String (U, S, L);
4693 and then Is_In (Subject (P + 1), S (1 .. L))
4706 -- Span (string pointer case)
4708 when PC_Span_VP => declare
4709 U : constant VString := Node.VP.all;
4710 S : Big_String_Access;
4715 Get_String (U, S, L);
4719 and then Is_In (Subject (P + 1), S (1 .. L))
4732 -- String (two character case)
4735 if (Length - Cursor) >= 2
4736 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
4738 Cursor := Cursor + 2;
4744 -- String (three character case)
4747 if (Length - Cursor) >= 3
4748 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
4750 Cursor := Cursor + 3;
4756 -- String (four character case)
4759 if (Length - Cursor) >= 4
4760 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
4762 Cursor := Cursor + 4;
4768 -- String (five character case)
4771 if (Length - Cursor) >= 5
4772 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
4774 Cursor := Cursor + 5;
4780 -- String (six character case)
4783 if (Length - Cursor) >= 6
4784 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
4786 Cursor := Cursor + 6;
4792 -- String (case of more than six characters)
4794 when PC_String => declare
4795 Len : constant Natural := Node.Str'Length;
4797 if (Length - Cursor) >= Len
4798 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
4800 Cursor := Cursor + Len;
4807 -- String (function case)
4809 when PC_String_VF => declare
4810 U : constant VString := Node.VF.all;
4811 S : Big_String_Access;
4815 Get_String (U, S, L);
4817 if (Length - Cursor) >= L
4818 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4820 Cursor := Cursor + L;
4827 -- String (pointer case)
4829 when PC_String_VP => declare
4830 U : constant VString := Node.VP.all;
4831 S : Big_String_Access;
4835 Get_String (U, S, L);
4837 if (Length - Cursor) >= L
4838 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4840 Cursor := Cursor + L;
4853 -- Tab (integer case)
4856 if Cursor <= Node.Nat then
4863 -- Tab (integer function case)
4865 when PC_Tab_NF => declare
4866 N : constant Natural := Node.NF.all;
4876 -- Tab (integer pointer case)
4879 if Cursor <= Node.NP.all then
4880 Cursor := Node.NP.all;
4886 -- Unanchored movement
4888 when PC_Unanchored =>
4890 -- All done if we tried every position
4892 if Cursor > Length then
4895 -- Otherwise extend the anchor point, and restack ourself
4898 Cursor := Cursor + 1;
4903 -- Write immediate. This node performs the actual write
4905 when PC_Write_Imm =>
4908 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4912 -- Write on match. This node sets up for the eventual write
4914 when PC_Write_OnM =>
4915 Stack (Stack_Base - 1).Node := Node;
4916 Push (CP_Assign'Access);
4923 -- We are NOT allowed to fall though this case statement, since every
4924 -- match routine must end by executing a goto to the appropriate point
4925 -- in the finite state machine model.
4927 pragma Warnings (Off);
4929 pragma Warnings (On);
4936 -- Maintenance note: There is a LOT of code duplication between XMatch
4937 -- and XMatchD. This is quite intentional, the point is to avoid any
4938 -- unnecessary debugging overhead in the XMatch case, but this does mean
4939 -- that any changes to XMatchD must be mirrored in XMatch. In case of
4940 -- any major changes, the proper approach is to delete XMatch, make the
4941 -- changes to XMatchD, and then make a copy of XMatchD, removing all
4942 -- calls to Dout, and all Put and Put_Line operations. This copy becomes
4949 Start : out Natural;
4953 -- Pointer to current pattern node. Initialized from Pat_P, and then
4954 -- updated as the match proceeds through its constituent elements.
4956 Length : constant Natural := Subject'Length;
4957 -- Length of string (= Subject'Last, since Subject'First is always 1)
4959 Cursor : Integer := 0;
4960 -- If the value is non-negative, then this value is the index showing
4961 -- the current position of the match in the subject string. The next
4962 -- character to be matched is at Subject (Cursor + 1). Note that since
4963 -- our view of the subject string in XMatch always has a lower bound
4964 -- of one, regardless of original bounds, that this definition exactly
4965 -- corresponds to the cursor value as referenced by functions like Pos.
4967 -- If the value is negative, then this is a saved stack pointer,
4968 -- typically a base pointer of an inner or outer region. Cursor
4969 -- temporarily holds such a value when it is popped from the stack
4970 -- by Fail. In all cases, Cursor is reset to a proper non-negative
4971 -- cursor value before the match proceeds (e.g. by propagating the
4972 -- failure and popping a "real" cursor value from the stack.
4974 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
4975 -- Dummy pattern element used in the unanchored case
4977 Region_Level : Natural := 0;
4978 -- Keeps track of recursive region level. This is used only for
4979 -- debugging, it is the number of saved history stack base values.
4982 -- The pattern matching failure stack for this call to Match
4984 Stack_Ptr : Stack_Range;
4985 -- Current stack pointer. This points to the top element of the stack
4986 -- that is currently in use. At the outer level this is the special
4987 -- entry placed on the stack according to the anchor mode.
4989 Stack_Init : constant Stack_Range := Stack'First + 1;
4990 -- This is the initial value of the Stack_Ptr and Stack_Base. The
4991 -- initial (Stack'First) element of the stack is not used so that
4992 -- when we pop the last element off, Stack_Ptr is still in range.
4994 Stack_Base : Stack_Range;
4995 -- This value is the stack base value, i.e. the stack pointer for the
4996 -- first history stack entry in the current stack region. See separate
4997 -- section on handling of recursive pattern matches.
4999 Assign_OnM : Boolean := False;
5000 -- Set True if assign-on-match or write-on-match operations may be
5001 -- present in the history stack, which must then be scanned on a
5002 -- successful match.
5004 procedure Dout (Str : String);
5005 -- Output string to standard error with bars indicating region level
5007 procedure Dout (Str : String; A : Character);
5008 -- Calls Dout with the string S ('A')
5010 procedure Dout (Str : String; A : Character_Set);
5011 -- Calls Dout with the string S ("A")
5013 procedure Dout (Str : String; A : Natural);
5014 -- Calls Dout with the string S (A)
5016 procedure Dout (Str : String; A : String);
5017 -- Calls Dout with the string S ("A")
5019 function Img (P : PE_Ptr) return String;
5020 -- Returns a string of the form #nnn where nnn is P.Index
5022 procedure Pop_Region;
5023 pragma Inline (Pop_Region);
5024 -- Used at the end of processing of an inner region. If the inner
5025 -- region left no stack entries, then all trace of it is removed.
5026 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
5027 -- handling of alternatives in the inner region.
5029 procedure Push (Node : PE_Ptr);
5030 pragma Inline (Push);
5031 -- Make entry in pattern matching stack with current cursor value
5033 procedure Push_Region;
5034 pragma Inline (Push_Region);
5035 -- This procedure makes a new region on the history stack. The
5036 -- caller first establishes the special entry on the stack, but
5037 -- does not push the stack pointer. Then this call stacks a
5038 -- PC_Remove_Region node, on top of this entry, using the cursor
5039 -- field of the PC_Remove_Region entry to save the outer level
5040 -- stack base value, and resets the stack base to point to this
5041 -- PC_Remove_Region node.
5047 procedure Dout (Str : String) is
5049 for J in 1 .. Region_Level loop
5056 procedure Dout (Str : String; A : Character) is
5058 Dout (Str & " ('" & A & "')");
5061 procedure Dout (Str : String; A : Character_Set) is
5063 Dout (Str & " (" & Image (To_Sequence (A)) & ')');
5066 procedure Dout (Str : String; A : Natural) is
5068 Dout (Str & " (" & A & ')');
5071 procedure Dout (Str : String; A : String) is
5073 Dout (Str & " (" & Image (A) & ')');
5080 function Img (P : PE_Ptr) return String is
5082 return "#" & Integer (P.Index) & " ";
5089 procedure Pop_Region is
5091 Region_Level := Region_Level - 1;
5093 -- If nothing was pushed in the inner region, we can just get
5094 -- rid of it entirely, leaving no traces that it was ever there
5096 if Stack_Ptr = Stack_Base then
5097 Stack_Ptr := Stack_Base - 2;
5098 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
5100 -- If stuff was pushed in the inner region, then we have to
5101 -- push a PC_R_Restore node so that we properly handle possible
5102 -- rematches within the region.
5105 Stack_Ptr := Stack_Ptr + 1;
5106 Stack (Stack_Ptr).Cursor := Stack_Base;
5107 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
5108 Stack_Base := Stack (Stack_Base).Cursor;
5116 procedure Push (Node : PE_Ptr) is
5118 Stack_Ptr := Stack_Ptr + 1;
5119 Stack (Stack_Ptr).Cursor := Cursor;
5120 Stack (Stack_Ptr).Node := Node;
5127 procedure Push_Region is
5129 Region_Level := Region_Level + 1;
5130 Stack_Ptr := Stack_Ptr + 2;
5131 Stack (Stack_Ptr).Cursor := Stack_Base;
5132 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
5133 Stack_Base := Stack_Ptr;
5136 -- Start of processing for XMatchD
5140 Put_Line ("Initiating pattern match, subject = " & Image (Subject));
5141 Put ("--------------------------------------");
5143 for J in 1 .. Length loop
5148 Put_Line ("subject length = " & Length);
5150 if Pat_P = null then
5151 Uninitialized_Pattern;
5154 -- Check we have enough stack for this pattern. This check deals with
5155 -- every possibility except a match of a recursive pattern, where we
5156 -- make a check at each recursion level.
5158 if Pat_S >= Stack_Size - 1 then
5159 raise Pattern_Stack_Overflow;
5162 -- In anchored mode, the bottom entry on the stack is an abort entry
5164 if Anchored_Mode then
5165 Stack (Stack_Init).Node := CP_Cancel'Access;
5166 Stack (Stack_Init).Cursor := 0;
5168 -- In unanchored more, the bottom entry on the stack references
5169 -- the special pattern element PE_Unanchored, whose Pthen field
5170 -- points to the initial pattern element. The cursor value in this
5171 -- entry is the number of anchor moves so far.
5174 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
5175 Stack (Stack_Init).Cursor := 0;
5178 Stack_Ptr := Stack_Init;
5179 Stack_Base := Stack_Ptr;
5184 -----------------------------------------
5185 -- Main Pattern Matching State Control --
5186 -----------------------------------------
5188 -- This is a state machine which uses gotos to change state. The
5189 -- initial state is Match, to initiate the matching of the first
5190 -- element, so the goto Match above starts the match. In the
5191 -- following descriptions, we indicate the global values that
5192 -- are relevant for the state transition.
5194 -- Come here if entire match fails
5197 Dout ("match fails");
5203 -- Come here if entire match succeeds
5205 -- Cursor current position in subject string
5208 Dout ("match succeeds");
5209 Start := Stack (Stack_Init).Cursor + 1;
5211 Dout ("first matched character index = " & Start);
5212 Dout ("last matched character index = " & Stop);
5213 Dout ("matched substring = " & Image (Subject (Start .. Stop)));
5215 -- Scan history stack for deferred assignments or writes
5218 for S in Stack'First .. Stack_Ptr loop
5219 if Stack (S).Node = CP_Assign'Access then
5221 Inner_Base : constant Stack_Range :=
5222 Stack (S + 1).Cursor;
5223 Special_Entry : constant Stack_Range :=
5225 Node_OnM : constant PE_Ptr :=
5226 Stack (Special_Entry).Node;
5227 Start : constant Natural :=
5228 Stack (Special_Entry).Cursor + 1;
5229 Stop : constant Natural := Stack (S).Cursor;
5232 if Node_OnM.Pcode = PC_Assign_OnM then
5233 Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
5235 (Img (Stack (S).Node) &
5236 "deferred assignment of " &
5237 Image (Subject (Start .. Stop)));
5239 elsif Node_OnM.Pcode = PC_Write_OnM then
5240 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
5242 (Img (Stack (S).Node) &
5243 "deferred write of " &
5244 Image (Subject (Start .. Stop)));
5257 -- Come here if attempt to match current element fails
5259 -- Stack_Base current stack base
5260 -- Stack_Ptr current stack pointer
5263 Cursor := Stack (Stack_Ptr).Cursor;
5264 Node := Stack (Stack_Ptr).Node;
5265 Stack_Ptr := Stack_Ptr - 1;
5268 Dout ("failure, cursor reset to " & Cursor);
5273 -- Come here if attempt to match current element succeeds
5275 -- Cursor current position in subject string
5276 -- Node pointer to node successfully matched
5277 -- Stack_Base current stack base
5278 -- Stack_Ptr current stack pointer
5281 Dout ("success, cursor = " & Cursor);
5284 -- Come here to match the next pattern element
5286 -- Cursor current position in subject string
5287 -- Node pointer to node to be matched
5288 -- Stack_Base current stack base
5289 -- Stack_Ptr current stack pointer
5293 --------------------------------------------------
5294 -- Main Pattern Match Element Matching Routines --
5295 --------------------------------------------------
5297 -- Here is the case statement that processes the current node. The
5298 -- processing for each element does one of five things:
5300 -- goto Succeed to move to the successor
5301 -- goto Match_Succeed if the entire match succeeds
5302 -- goto Match_Fail if the entire match fails
5303 -- goto Fail to signal failure of current match
5305 -- Processing is NOT allowed to fall through
5312 Dout (Img (Node) & "matching Cancel");
5319 (Img (Node) & "setting up alternative " & Img (Node.Alt));
5324 -- Any (one character case)
5327 Dout (Img (Node) & "matching Any", Node.Char);
5330 and then Subject (Cursor + 1) = Node.Char
5332 Cursor := Cursor + 1;
5338 -- Any (character set case)
5341 Dout (Img (Node) & "matching Any", Node.CS);
5344 and then Is_In (Subject (Cursor + 1), Node.CS)
5346 Cursor := Cursor + 1;
5352 -- Any (string function case)
5354 when PC_Any_VF => declare
5355 U : constant VString := Node.VF.all;
5356 S : Big_String_Access;
5360 Get_String (U, S, L);
5362 Dout (Img (Node) & "matching Any", S (1 .. L));
5365 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5367 Cursor := Cursor + 1;
5374 -- Any (string pointer case)
5376 when PC_Any_VP => declare
5377 U : constant VString := Node.VP.all;
5378 S : Big_String_Access;
5382 Get_String (U, S, L);
5383 Dout (Img (Node) & "matching Any", S (1 .. L));
5386 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5388 Cursor := Cursor + 1;
5395 -- Arb (initial match)
5398 Dout (Img (Node) & "matching Arb");
5406 Dout (Img (Node) & "extending Arb");
5408 if Cursor < Length then
5409 Cursor := Cursor + 1;
5416 -- Arbno_S (simple Arbno initialize). This is the node that
5417 -- initiates the match of a simple Arbno structure.
5421 "setting up Arbno alternative " & Img (Node.Alt));
5426 -- Arbno_X (Arbno initialize). This is the node that initiates
5427 -- the match of a complex Arbno structure.
5431 "setting up Arbno alternative " & Img (Node.Alt));
5436 -- Arbno_Y (Arbno rematch). This is the node that is executed
5437 -- following successful matching of one instance of a complex
5440 when PC_Arbno_Y => declare
5441 Null_Match : constant Boolean :=
5442 Cursor = Stack (Stack_Base - 1).Cursor;
5445 Dout (Img (Node) & "extending Arbno");
5448 -- If arbno extension matched null, then immediately fail
5451 Dout ("Arbno extension matched null, so fails");
5455 -- Here we must do a stack check to make sure enough stack
5456 -- is left. This check will happen once for each instance of
5457 -- the Arbno pattern that is matched. The Nat field of a
5458 -- PC_Arbno pattern contains the maximum stack entries needed
5459 -- for the Arbno with one instance and the successor pattern
5461 if Stack_Ptr + Node.Nat >= Stack'Last then
5462 raise Pattern_Stack_Overflow;
5468 -- Assign. If this node is executed, it means the assign-on-match
5469 -- or write-on-match operation will not happen after all, so we
5470 -- is propagate the failure, removing the PC_Assign node.
5473 Dout (Img (Node) & "deferred assign/write cancelled");
5476 -- Assign immediate. This node performs the actual assignment
5478 when PC_Assign_Imm =>
5480 (Img (Node) & "executing immediate assignment of " &
5481 Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)));
5484 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
5488 -- Assign on match. This node sets up for the eventual assignment
5490 when PC_Assign_OnM =>
5491 Dout (Img (Node) & "registering deferred assignment");
5492 Stack (Stack_Base - 1).Node := Node;
5493 Push (CP_Assign'Access);
5501 Dout (Img (Node) & "matching or extending Bal");
5502 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
5505 elsif Subject (Cursor + 1) = '(' then
5507 Paren_Count : Natural := 1;
5511 Cursor := Cursor + 1;
5513 if Cursor >= Length then
5516 elsif Subject (Cursor + 1) = '(' then
5517 Paren_Count := Paren_Count + 1;
5519 elsif Subject (Cursor + 1) = ')' then
5520 Paren_Count := Paren_Count - 1;
5521 exit when Paren_Count = 0;
5527 Cursor := Cursor + 1;
5531 -- Break (one character case)
5534 Dout (Img (Node) & "matching Break", Node.Char);
5536 while Cursor < Length loop
5537 if Subject (Cursor + 1) = Node.Char then
5540 Cursor := Cursor + 1;
5546 -- Break (character set case)
5549 Dout (Img (Node) & "matching Break", Node.CS);
5551 while Cursor < Length loop
5552 if Is_In (Subject (Cursor + 1), Node.CS) then
5555 Cursor := Cursor + 1;
5561 -- Break (string function case)
5563 when PC_Break_VF => declare
5564 U : constant VString := Node.VF.all;
5565 S : Big_String_Access;
5569 Get_String (U, S, L);
5570 Dout (Img (Node) & "matching Break", S (1 .. L));
5572 while Cursor < Length loop
5573 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5576 Cursor := Cursor + 1;
5583 -- Break (string pointer case)
5585 when PC_Break_VP => declare
5586 U : constant VString := Node.VP.all;
5587 S : Big_String_Access;
5591 Get_String (U, S, L);
5592 Dout (Img (Node) & "matching Break", S (1 .. L));
5594 while Cursor < Length loop
5595 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5598 Cursor := Cursor + 1;
5605 -- BreakX (one character case)
5607 when PC_BreakX_CH =>
5608 Dout (Img (Node) & "matching BreakX", Node.Char);
5610 while Cursor < Length loop
5611 if Subject (Cursor + 1) = Node.Char then
5614 Cursor := Cursor + 1;
5620 -- BreakX (character set case)
5622 when PC_BreakX_CS =>
5623 Dout (Img (Node) & "matching BreakX", Node.CS);
5625 while Cursor < Length loop
5626 if Is_In (Subject (Cursor + 1), Node.CS) then
5629 Cursor := Cursor + 1;
5635 -- BreakX (string function case)
5637 when PC_BreakX_VF => declare
5638 U : constant VString := Node.VF.all;
5639 S : Big_String_Access;
5643 Get_String (U, S, L);
5644 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5646 while Cursor < Length loop
5647 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5650 Cursor := Cursor + 1;
5657 -- BreakX (string pointer case)
5659 when PC_BreakX_VP => declare
5660 U : constant VString := Node.VP.all;
5661 S : Big_String_Access;
5665 Get_String (U, S, L);
5666 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5668 while Cursor < Length loop
5669 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5672 Cursor := Cursor + 1;
5679 -- BreakX_X (BreakX extension). See section on "Compound Pattern
5680 -- Structures". This node is the alternative that is stacked
5681 -- to skip past the break character and extend the break.
5684 Dout (Img (Node) & "extending BreakX");
5685 Cursor := Cursor + 1;
5688 -- Character (one character string)
5691 Dout (Img (Node) & "matching '" & Node.Char & ''');
5694 and then Subject (Cursor + 1) = Node.Char
5696 Cursor := Cursor + 1;
5705 if Stack_Base = Stack_Init then
5706 Dout ("end of pattern");
5709 -- End of recursive inner match. See separate section on
5710 -- handing of recursive pattern matches for details.
5713 Dout ("terminating recursive match");
5714 Node := Stack (Stack_Base - 1).Node;
5722 Dout (Img (Node) & "matching Fail");
5725 -- Fence (built in pattern)
5728 Dout (Img (Node) & "matching Fence");
5729 Push (CP_Cancel'Access);
5732 -- Fence function node X. This is the node that gets control
5733 -- after a successful match of the fenced pattern.
5736 Dout (Img (Node) & "matching Fence function");
5737 Stack_Ptr := Stack_Ptr + 1;
5738 Stack (Stack_Ptr).Cursor := Stack_Base;
5739 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
5740 Stack_Base := Stack (Stack_Base).Cursor;
5741 Region_Level := Region_Level - 1;
5744 -- Fence function node Y. This is the node that gets control on
5745 -- a failure that occurs after the fenced pattern has matched.
5747 -- Note: the Cursor at this stage is actually the inner stack
5748 -- base value. We don't reset this, but we do use it to strip
5749 -- off all the entries made by the fenced pattern.
5752 Dout (Img (Node) & "pattern matched by Fence caused failure");
5753 Stack_Ptr := Cursor - 2;
5756 -- Len (integer case)
5759 Dout (Img (Node) & "matching Len", Node.Nat);
5761 if Cursor + Node.Nat > Length then
5764 Cursor := Cursor + Node.Nat;
5768 -- Len (Integer function case)
5770 when PC_Len_NF => declare
5771 N : constant Natural := Node.NF.all;
5774 Dout (Img (Node) & "matching Len", N);
5776 if Cursor + N > Length then
5779 Cursor := Cursor + N;
5784 -- Len (integer pointer case)
5787 Dout (Img (Node) & "matching Len", Node.NP.all);
5789 if Cursor + Node.NP.all > Length then
5792 Cursor := Cursor + Node.NP.all;
5796 -- NotAny (one character case)
5798 when PC_NotAny_CH =>
5799 Dout (Img (Node) & "matching NotAny", Node.Char);
5802 and then Subject (Cursor + 1) /= Node.Char
5804 Cursor := Cursor + 1;
5810 -- NotAny (character set case)
5812 when PC_NotAny_CS =>
5813 Dout (Img (Node) & "matching NotAny", Node.CS);
5816 and then not Is_In (Subject (Cursor + 1), Node.CS)
5818 Cursor := Cursor + 1;
5824 -- NotAny (string function case)
5826 when PC_NotAny_VF => declare
5827 U : constant VString := Node.VF.all;
5828 S : Big_String_Access;
5832 Get_String (U, S, L);
5833 Dout (Img (Node) & "matching NotAny", S (1 .. L));
5837 not Is_In (Subject (Cursor + 1), S (1 .. L))
5839 Cursor := Cursor + 1;
5846 -- NotAny (string pointer case)
5848 when PC_NotAny_VP => declare
5849 U : constant VString := Node.VP.all;
5850 S : Big_String_Access;
5854 Get_String (U, S, L);
5855 Dout (Img (Node) & "matching NotAny", S (1 .. L));
5859 not Is_In (Subject (Cursor + 1), S (1 .. L))
5861 Cursor := Cursor + 1;
5868 -- NSpan (one character case)
5871 Dout (Img (Node) & "matching NSpan", Node.Char);
5873 while Cursor < Length
5874 and then Subject (Cursor + 1) = Node.Char
5876 Cursor := Cursor + 1;
5881 -- NSpan (character set case)
5884 Dout (Img (Node) & "matching NSpan", Node.CS);
5886 while Cursor < Length
5887 and then Is_In (Subject (Cursor + 1), Node.CS)
5889 Cursor := Cursor + 1;
5894 -- NSpan (string function case)
5896 when PC_NSpan_VF => declare
5897 U : constant VString := Node.VF.all;
5898 S : Big_String_Access;
5902 Get_String (U, S, L);
5903 Dout (Img (Node) & "matching NSpan", S (1 .. L));
5905 while Cursor < Length
5906 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5908 Cursor := Cursor + 1;
5914 -- NSpan (string pointer case)
5916 when PC_NSpan_VP => declare
5917 U : constant VString := Node.VP.all;
5918 S : Big_String_Access;
5922 Get_String (U, S, L);
5923 Dout (Img (Node) & "matching NSpan", S (1 .. L));
5925 while Cursor < Length
5926 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5928 Cursor := Cursor + 1;
5935 Dout (Img (Node) & "matching null");
5938 -- Pos (integer case)
5941 Dout (Img (Node) & "matching Pos", Node.Nat);
5943 if Cursor = Node.Nat then
5949 -- Pos (Integer function case)
5951 when PC_Pos_NF => declare
5952 N : constant Natural := Node.NF.all;
5955 Dout (Img (Node) & "matching Pos", N);
5964 -- Pos (integer pointer case)
5967 Dout (Img (Node) & "matching Pos", Node.NP.all);
5969 if Cursor = Node.NP.all then
5975 -- Predicate function
5977 when PC_Pred_Func =>
5978 Dout (Img (Node) & "matching predicate function");
5986 -- Region Enter. Initiate new pattern history stack region
5989 Dout (Img (Node) & "starting match of nested pattern");
5990 Stack (Stack_Ptr + 1).Cursor := Cursor;
5994 -- Region Remove node. This is the node stacked by an R_Enter.
5995 -- It removes the special format stack entry right underneath, and
5996 -- then restores the outer level stack base and signals failure.
5998 -- Note: the cursor value at this stage is actually the (negative)
5999 -- stack base value for the outer level.
6002 Dout ("failure, match of nested pattern terminated");
6003 Stack_Base := Cursor;
6004 Region_Level := Region_Level - 1;
6005 Stack_Ptr := Stack_Ptr - 1;
6008 -- Region restore node. This is the node stacked at the end of an
6009 -- inner level match. Its function is to restore the inner level
6010 -- region, so that alternatives in this region can be sought.
6012 -- Note: the Cursor at this stage is actually the negative of the
6013 -- inner stack base value, which we use to restore the inner region.
6015 when PC_R_Restore =>
6016 Dout ("failure, search for alternatives in nested pattern");
6017 Region_Level := Region_Level + 1;
6018 Stack_Base := Cursor;
6024 Dout (Img (Node) & "matching Rest");
6028 -- Initiate recursive match (pattern pointer case)
6031 Stack (Stack_Ptr + 1).Node := Node.Pthen;
6033 Dout (Img (Node) & "initiating recursive match");
6035 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
6036 raise Pattern_Stack_Overflow;
6038 Node := Node.PP.all.P;
6042 -- RPos (integer case)
6045 Dout (Img (Node) & "matching RPos", Node.Nat);
6047 if Cursor = (Length - Node.Nat) then
6053 -- RPos (integer function case)
6055 when PC_RPos_NF => declare
6056 N : constant Natural := Node.NF.all;
6059 Dout (Img (Node) & "matching RPos", N);
6061 if Length - Cursor = N then
6068 -- RPos (integer pointer case)
6071 Dout (Img (Node) & "matching RPos", Node.NP.all);
6073 if Cursor = (Length - Node.NP.all) then
6079 -- RTab (integer case)
6082 Dout (Img (Node) & "matching RTab", Node.Nat);
6084 if Cursor <= (Length - Node.Nat) then
6085 Cursor := Length - Node.Nat;
6091 -- RTab (integer function case)
6093 when PC_RTab_NF => declare
6094 N : constant Natural := Node.NF.all;
6097 Dout (Img (Node) & "matching RPos", N);
6099 if Length - Cursor >= N then
6100 Cursor := Length - N;
6107 -- RTab (integer pointer case)
6110 Dout (Img (Node) & "matching RPos", Node.NP.all);
6112 if Cursor <= (Length - Node.NP.all) then
6113 Cursor := Length - Node.NP.all;
6119 -- Cursor assignment
6122 Dout (Img (Node) & "matching Setcur");
6123 Node.Var.all := Cursor;
6126 -- Span (one character case)
6128 when PC_Span_CH => declare
6129 P : Natural := Cursor;
6132 Dout (Img (Node) & "matching Span", Node.Char);
6135 and then Subject (P + 1) = Node.Char
6148 -- Span (character set case)
6150 when PC_Span_CS => declare
6151 P : Natural := Cursor;
6154 Dout (Img (Node) & "matching Span", Node.CS);
6157 and then Is_In (Subject (P + 1), Node.CS)
6170 -- Span (string function case)
6172 when PC_Span_VF => declare
6173 U : constant VString := Node.VF.all;
6174 S : Big_String_Access;
6179 Get_String (U, S, L);
6180 Dout (Img (Node) & "matching Span", S (1 .. L));
6184 and then Is_In (Subject (P + 1), S (1 .. L))
6197 -- Span (string pointer case)
6199 when PC_Span_VP => declare
6200 U : constant VString := Node.VP.all;
6201 S : Big_String_Access;
6206 Get_String (U, S, L);
6207 Dout (Img (Node) & "matching Span", S (1 .. L));
6211 and then Is_In (Subject (P + 1), S (1 .. L))
6224 -- String (two character case)
6227 Dout (Img (Node) & "matching " & Image (Node.Str2));
6229 if (Length - Cursor) >= 2
6230 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
6232 Cursor := Cursor + 2;
6238 -- String (three character case)
6241 Dout (Img (Node) & "matching " & Image (Node.Str3));
6243 if (Length - Cursor) >= 3
6244 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
6246 Cursor := Cursor + 3;
6252 -- String (four character case)
6255 Dout (Img (Node) & "matching " & Image (Node.Str4));
6257 if (Length - Cursor) >= 4
6258 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
6260 Cursor := Cursor + 4;
6266 -- String (five character case)
6269 Dout (Img (Node) & "matching " & Image (Node.Str5));
6271 if (Length - Cursor) >= 5
6272 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
6274 Cursor := Cursor + 5;
6280 -- String (six character case)
6283 Dout (Img (Node) & "matching " & Image (Node.Str6));
6285 if (Length - Cursor) >= 6
6286 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
6288 Cursor := Cursor + 6;
6294 -- String (case of more than six characters)
6296 when PC_String => declare
6297 Len : constant Natural := Node.Str'Length;
6300 Dout (Img (Node) & "matching " & Image (Node.Str.all));
6302 if (Length - Cursor) >= Len
6303 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
6305 Cursor := Cursor + Len;
6312 -- String (function case)
6314 when PC_String_VF => declare
6315 U : constant VString := Node.VF.all;
6316 S : Big_String_Access;
6320 Get_String (U, S, L);
6321 Dout (Img (Node) & "matching " & Image (S (1 .. L)));
6323 if (Length - Cursor) >= L
6324 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6326 Cursor := Cursor + L;
6333 -- String (vstring pointer case)
6335 when PC_String_VP => declare
6336 U : constant VString := Node.VP.all;
6337 S : Big_String_Access;
6341 Get_String (U, S, L);
6342 Dout (Img (Node) & "matching " & Image (S (1 .. L)));
6344 if (Length - Cursor) >= L
6345 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6347 Cursor := Cursor + L;
6357 Dout (Img (Node) & "matching Succeed");
6361 -- Tab (integer case)
6364 Dout (Img (Node) & "matching Tab", Node.Nat);
6366 if Cursor <= Node.Nat then
6373 -- Tab (integer function case)
6375 when PC_Tab_NF => declare
6376 N : constant Natural := Node.NF.all;
6379 Dout (Img (Node) & "matching Tab ", N);
6389 -- Tab (integer pointer case)
6392 Dout (Img (Node) & "matching Tab ", Node.NP.all);
6394 if Cursor <= Node.NP.all then
6395 Cursor := Node.NP.all;
6401 -- Unanchored movement
6403 when PC_Unanchored =>
6404 Dout ("attempting to move anchor point");
6406 -- All done if we tried every position
6408 if Cursor > Length then
6411 -- Otherwise extend the anchor point, and restack ourself
6414 Cursor := Cursor + 1;
6419 -- Write immediate. This node performs the actual write
6421 when PC_Write_Imm =>
6422 Dout (Img (Node) & "executing immediate write of " &
6423 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6427 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6431 -- Write on match. This node sets up for the eventual write
6433 when PC_Write_OnM =>
6434 Dout (Img (Node) & "registering deferred write");
6435 Stack (Stack_Base - 1).Node := Node;
6436 Push (CP_Assign'Access);
6443 -- We are NOT allowed to fall though this case statement, since every
6444 -- match routine must end by executing a goto to the appropriate point
6445 -- in the finite state machine model.
6447 pragma Warnings (Off);
6449 pragma Warnings (On);
6452 end GNAT.Spitbol.Patterns;
OSDN Git Service
