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-2008, 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
2801 pragma Unreferenced (Stop);
2804 Get_String (Subject, S, L);
2807 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2809 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2817 Pat : Pattern) return Boolean
2819 Start, Stop : Natural;
2820 pragma Unreferenced (Stop);
2822 subtype String1 is String (1 .. Subject'Length);
2826 XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2828 XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2835 (Subject : VString_Var;
2837 Replace : VString) return Boolean
2845 Get_String (Subject, S, L);
2848 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2850 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2856 Get_String (Replace, S, L);
2858 (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
2864 (Subject : VString_Var;
2866 Replace : String) return Boolean
2874 Get_String (Subject, S, L);
2877 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2879 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2886 (Subject'Unrestricted_Access.all, Start, Stop, Replace);
2900 pragma Unreferenced (Start, Stop);
2903 Get_String (Subject, S, L);
2906 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2908 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2916 Start, Stop : Natural;
2917 pragma Unreferenced (Start, Stop);
2919 subtype String1 is String (1 .. Subject'Length);
2923 XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2925 XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2930 (Subject : in out VString;
2940 Get_String (Subject, S, L);
2943 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2945 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2949 Get_String (Replace, S, L);
2950 Replace_Slice (Subject, Start, Stop, S (1 .. L));
2955 (Subject : in out VString;
2965 Get_String (Subject, S, L);
2968 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2970 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2974 Replace_Slice (Subject, Start, Stop, Replace);
2980 Pat : PString) return Boolean
2982 Pat_Len : constant Natural := Pat'Length;
2987 Get_String (Subject, S, L);
2989 if Anchored_Mode then
2993 return Pat = S (1 .. Pat_Len);
2997 for J in 1 .. L - Pat_Len + 1 loop
2998 if Pat = S (J .. J + (Pat_Len - 1)) then
3009 Pat : PString) return Boolean
3011 Pat_Len : constant Natural := Pat'Length;
3012 Sub_Len : constant Natural := Subject'Length;
3013 SFirst : constant Natural := Subject'First;
3016 if Anchored_Mode then
3017 if Pat_Len > Sub_Len then
3020 return Pat = Subject (SFirst .. SFirst + Pat_Len - 1);
3024 for J in SFirst .. SFirst + Sub_Len - Pat_Len loop
3025 if Pat = Subject (J .. J + (Pat_Len - 1)) then
3035 (Subject : VString_Var;
3037 Replace : VString) return Boolean
3045 Get_String (Subject, S, L);
3048 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3050 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3056 Get_String (Replace, S, L);
3058 (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
3064 (Subject : VString_Var;
3066 Replace : String) return Boolean
3074 Get_String (Subject, S, L);
3077 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3079 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3086 (Subject'Unrestricted_Access.all, Start, Stop, Replace);
3100 pragma Unreferenced (Start, Stop);
3103 Get_String (Subject, S, L);
3106 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3108 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3116 Start, Stop : Natural;
3117 pragma Unreferenced (Start, Stop);
3119 subtype String1 is String (1 .. Subject'Length);
3123 XMatchD (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
3125 XMatch (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
3130 (Subject : in out VString;
3140 Get_String (Subject, S, L);
3143 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3145 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3149 Get_String (Replace, S, L);
3150 Replace_Slice (Subject, Start, Stop, S (1 .. L));
3155 (Subject : in out VString;
3165 Get_String (Subject, S, L);
3168 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3170 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3174 Replace_Slice (Subject, Start, Stop, Replace);
3179 (Subject : VString_Var;
3181 Result : Match_Result_Var) return Boolean
3189 Get_String (Subject, S, L);
3192 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3194 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3198 Result'Unrestricted_Access.all.Var := null;
3202 Result'Unrestricted_Access.all.Var := Subject'Unrestricted_Access;
3203 Result'Unrestricted_Access.all.Start := Start;
3204 Result'Unrestricted_Access.all.Stop := Stop;
3210 (Subject : in out VString;
3212 Result : out Match_Result)
3220 Get_String (Subject, S, L);
3223 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3225 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3231 Result.Var := Subject'Unrestricted_Access;
3232 Result.Start := Start;
3233 Result.Stop := Stop;
3241 procedure New_LineD is
3243 if Internal_Debug then
3252 function NotAny (Str : String) return Pattern is
3254 return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, To_Set (Str)));
3257 function NotAny (Str : VString) return Pattern is
3259 return NotAny (S (Str));
3262 function NotAny (Str : Character) return Pattern is
3264 return (AFC with 0, new PE'(PC_NotAny_CH, 1, EOP, Str));
3267 function NotAny (Str : Character_Set) return Pattern is
3269 return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str));
3272 function NotAny (Str : not null access VString) return Pattern is
3274 return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str)));
3277 function NotAny (Str : VString_Func) return Pattern is
3279 return (AFC with 0, new PE'(PC_NotAny_VF, 1, EOP, Str));
3286 function NSpan (Str : String) return Pattern is
3288 return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, To_Set (Str)));
3291 function NSpan (Str : VString) return Pattern is
3293 return NSpan (S (Str));
3296 function NSpan (Str : Character) return Pattern is
3298 return (AFC with 0, new PE'(PC_NSpan_CH, 1, EOP, Str));
3301 function NSpan (Str : Character_Set) return Pattern is
3303 return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str));
3306 function NSpan (Str : not null access VString) return Pattern is
3308 return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str)));
3311 function NSpan (Str : VString_Func) return Pattern is
3313 return (AFC with 0, new PE'(PC_NSpan_VF, 1, EOP, Str));
3320 function Pos (Count : Natural) return Pattern is
3322 return (AFC with 0, new PE'(PC_Pos_Nat, 1, EOP, Count));
3325 function Pos (Count : Natural_Func) return Pattern is
3327 return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count));
3330 function Pos (Count : not null access Natural) return Pattern is
3332 return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count)));
3339 procedure PutD (Str : String) is
3341 if Internal_Debug then
3350 procedure Put_LineD (Str : String) is
3352 if Internal_Debug then
3362 (Result : in out Match_Result;
3369 Get_String (Replace, S, L);
3371 if Result.Var /= null then
3372 Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L));
3381 function Rest return Pattern is
3383 return (AFC with 0, new PE'(PC_Rest, 1, EOP));
3390 function Rpos (Count : Natural) return Pattern is
3392 return (AFC with 0, new PE'(PC_RPos_Nat, 1, EOP, Count));
3395 function Rpos (Count : Natural_Func) return Pattern is
3397 return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count));
3400 function Rpos (Count : not null access Natural) return Pattern is
3402 return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count)));
3409 function Rtab (Count : Natural) return Pattern is
3411 return (AFC with 0, new PE'(PC_RTab_Nat, 1, EOP, Count));
3414 function Rtab (Count : Natural_Func) return Pattern is
3416 return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count));
3419 function Rtab (Count : not null access Natural) return Pattern is
3421 return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count)));
3428 function S_To_PE (Str : PString) return PE_Ptr is
3429 Len : constant Natural := Str'Length;
3434 return new PE'(PC_Null, 1, EOP);
3437 return new PE'(PC_Char, 1, EOP, Str (Str'First));
3440 return new PE'(PC_String_2, 1, EOP, Str);
3443 return new PE'(PC_String_3, 1, EOP, Str);
3446 return new PE'(PC_String_4, 1, EOP, Str);
3449 return new PE'(PC_String_5, 1, EOP, Str);
3452 return new PE'(PC_String_6, 1, EOP, Str);
3455 return new PE'(PC_String, 1, EOP, new String'(Str));
3464 -- Note: this procedure is not used by the normal concatenation circuit,
3465 -- since other fixups are required on the left operand in this case, and
3466 -- they might as well be done all together.
3468 procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is
3471 Uninitialized_Pattern;
3473 elsif Pat = EOP then
3478 Refs : Ref_Array (1 .. Pat.Index);
3479 -- We build a reference array for L whose N'th element points to
3480 -- the pattern element of L whose original Index value is N.
3485 Build_Ref_Array (Pat, Refs);
3487 for J in Refs'Range loop
3490 if P.Pthen = EOP then
3494 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
3506 function Setcur (Var : not null access Natural) return Pattern is
3508 return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var)));
3515 function Span (Str : String) return Pattern is
3517 return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, To_Set (Str)));
3520 function Span (Str : VString) return Pattern is
3522 return Span (S (Str));
3525 function Span (Str : Character) return Pattern is
3527 return (AFC with 0, new PE'(PC_Span_CH, 1, EOP, Str));
3530 function Span (Str : Character_Set) return Pattern is
3532 return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str));
3535 function Span (Str : not null access VString) return Pattern is
3537 return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str)));
3540 function Span (Str : VString_Func) return Pattern is
3542 return (AFC with 0, new PE'(PC_Span_VF, 1, EOP, Str));
3549 function Str_BF (A : Boolean_Func) return String is
3550 function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address);
3552 return "BF(" & Image (To_A (A)) & ')';
3559 function Str_FP (A : File_Ptr) return String is
3561 return "FP(" & Image (A.all'Address) & ')';
3568 function Str_NF (A : Natural_Func) return String is
3569 function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address);
3571 return "NF(" & Image (To_A (A)) & ')';
3578 function Str_NP (A : Natural_Ptr) return String is
3580 return "NP(" & Image (A.all'Address) & ')';
3587 function Str_PP (A : Pattern_Ptr) return String is
3589 return "PP(" & Image (A.all'Address) & ')';
3596 function Str_VF (A : VString_Func) return String is
3597 function To_A is new Ada.Unchecked_Conversion (VString_Func, Address);
3599 return "VF(" & Image (To_A (A)) & ')';
3606 function Str_VP (A : VString_Ptr) return String is
3608 return "VP(" & Image (A.all'Address) & ')';
3615 function Succeed return Pattern is
3617 return (AFC with 1, new PE'(PC_Succeed, 1, EOP));
3624 function Tab (Count : Natural) return Pattern is
3626 return (AFC with 0, new PE'(PC_Tab_Nat, 1, EOP, Count));
3629 function Tab (Count : Natural_Func) return Pattern is
3631 return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count));
3634 function Tab (Count : not null access Natural) return Pattern is
3636 return (AFC with 0, new PE'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count)));
3639 ---------------------------
3640 -- Uninitialized_Pattern --
3641 ---------------------------
3643 procedure Uninitialized_Pattern is
3645 raise Program_Error with
3646 "uninitialized value of type GNAT.Spitbol.Patterns.Pattern";
3647 end Uninitialized_Pattern;
3657 Start : out Natural;
3661 -- Pointer to current pattern node. Initialized from Pat_P, and then
3662 -- updated as the match proceeds through its constituent elements.
3664 Length : constant Natural := Subject'Length;
3665 -- Length of string (= Subject'Last, since Subject'First is always 1)
3667 Cursor : Integer := 0;
3668 -- If the value is non-negative, then this value is the index showing
3669 -- the current position of the match in the subject string. The next
3670 -- character to be matched is at Subject (Cursor + 1). Note that since
3671 -- our view of the subject string in XMatch always has a lower bound
3672 -- of one, regardless of original bounds, that this definition exactly
3673 -- corresponds to the cursor value as referenced by functions like Pos.
3675 -- If the value is negative, then this is a saved stack pointer,
3676 -- typically a base pointer of an inner or outer region. Cursor
3677 -- temporarily holds such a value when it is popped from the stack
3678 -- by Fail. In all cases, Cursor is reset to a proper non-negative
3679 -- cursor value before the match proceeds (e.g. by propagating the
3680 -- failure and popping a "real" cursor value from the stack.
3682 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
3683 -- Dummy pattern element used in the unanchored case
3686 -- The pattern matching failure stack for this call to Match
3688 Stack_Ptr : Stack_Range;
3689 -- Current stack pointer. This points to the top element of the stack
3690 -- that is currently in use. At the outer level this is the special
3691 -- entry placed on the stack according to the anchor mode.
3693 Stack_Init : constant Stack_Range := Stack'First + 1;
3694 -- This is the initial value of the Stack_Ptr and Stack_Base. The
3695 -- initial (Stack'First) element of the stack is not used so that
3696 -- when we pop the last element off, Stack_Ptr is still in range.
3698 Stack_Base : Stack_Range;
3699 -- This value is the stack base value, i.e. the stack pointer for the
3700 -- first history stack entry in the current stack region. See separate
3701 -- section on handling of recursive pattern matches.
3703 Assign_OnM : Boolean := False;
3704 -- Set True if assign-on-match or write-on-match operations may be
3705 -- present in the history stack, which must then be scanned on a
3706 -- successful match.
3708 procedure Pop_Region;
3709 pragma Inline (Pop_Region);
3710 -- Used at the end of processing of an inner region. If the inner
3711 -- region left no stack entries, then all trace of it is removed.
3712 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
3713 -- handling of alternatives in the inner region.
3715 procedure Push (Node : PE_Ptr);
3716 pragma Inline (Push);
3717 -- Make entry in pattern matching stack with current cursor value
3719 procedure Push_Region;
3720 pragma Inline (Push_Region);
3721 -- This procedure makes a new region on the history stack. The
3722 -- caller first establishes the special entry on the stack, but
3723 -- does not push the stack pointer. Then this call stacks a
3724 -- PC_Remove_Region node, on top of this entry, using the cursor
3725 -- field of the PC_Remove_Region entry to save the outer level
3726 -- stack base value, and resets the stack base to point to this
3727 -- PC_Remove_Region node.
3733 procedure Pop_Region is
3735 -- If nothing was pushed in the inner region, we can just get
3736 -- rid of it entirely, leaving no traces that it was ever there
3738 if Stack_Ptr = Stack_Base then
3739 Stack_Ptr := Stack_Base - 2;
3740 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
3742 -- If stuff was pushed in the inner region, then we have to
3743 -- push a PC_R_Restore node so that we properly handle possible
3744 -- rematches within the region.
3747 Stack_Ptr := Stack_Ptr + 1;
3748 Stack (Stack_Ptr).Cursor := Stack_Base;
3749 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
3750 Stack_Base := Stack (Stack_Base).Cursor;
3758 procedure Push (Node : PE_Ptr) is
3760 Stack_Ptr := Stack_Ptr + 1;
3761 Stack (Stack_Ptr).Cursor := Cursor;
3762 Stack (Stack_Ptr).Node := Node;
3769 procedure Push_Region is
3771 Stack_Ptr := Stack_Ptr + 2;
3772 Stack (Stack_Ptr).Cursor := Stack_Base;
3773 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
3774 Stack_Base := Stack_Ptr;
3777 -- Start of processing for XMatch
3780 if Pat_P = null then
3781 Uninitialized_Pattern;
3784 -- Check we have enough stack for this pattern. This check deals with
3785 -- every possibility except a match of a recursive pattern, where we
3786 -- make a check at each recursion level.
3788 if Pat_S >= Stack_Size - 1 then
3789 raise Pattern_Stack_Overflow;
3792 -- In anchored mode, the bottom entry on the stack is an abort entry
3794 if Anchored_Mode then
3795 Stack (Stack_Init).Node := CP_Cancel'Access;
3796 Stack (Stack_Init).Cursor := 0;
3798 -- In unanchored more, the bottom entry on the stack references
3799 -- the special pattern element PE_Unanchored, whose Pthen field
3800 -- points to the initial pattern element. The cursor value in this
3801 -- entry is the number of anchor moves so far.
3804 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
3805 Stack (Stack_Init).Cursor := 0;
3808 Stack_Ptr := Stack_Init;
3809 Stack_Base := Stack_Ptr;
3814 -----------------------------------------
3815 -- Main Pattern Matching State Control --
3816 -----------------------------------------
3818 -- This is a state machine which uses gotos to change state. The
3819 -- initial state is Match, to initiate the matching of the first
3820 -- element, so the goto Match above starts the match. In the
3821 -- following descriptions, we indicate the global values that
3822 -- are relevant for the state transition.
3824 -- Come here if entire match fails
3831 -- Come here if entire match succeeds
3833 -- Cursor current position in subject string
3836 Start := Stack (Stack_Init).Cursor + 1;
3839 -- Scan history stack for deferred assignments or writes
3842 for S in Stack_Init .. Stack_Ptr loop
3843 if Stack (S).Node = CP_Assign'Access then
3845 Inner_Base : constant Stack_Range :=
3846 Stack (S + 1).Cursor;
3847 Special_Entry : constant Stack_Range :=
3849 Node_OnM : constant PE_Ptr :=
3850 Stack (Special_Entry).Node;
3851 Start : constant Natural :=
3852 Stack (Special_Entry).Cursor + 1;
3853 Stop : constant Natural := Stack (S).Cursor;
3856 if Node_OnM.Pcode = PC_Assign_OnM then
3857 Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
3859 elsif Node_OnM.Pcode = PC_Write_OnM then
3860 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
3872 -- Come here if attempt to match current element fails
3874 -- Stack_Base current stack base
3875 -- Stack_Ptr current stack pointer
3878 Cursor := Stack (Stack_Ptr).Cursor;
3879 Node := Stack (Stack_Ptr).Node;
3880 Stack_Ptr := Stack_Ptr - 1;
3883 -- Come here if attempt to match current element succeeds
3885 -- Cursor current position in subject string
3886 -- Node pointer to node successfully matched
3887 -- Stack_Base current stack base
3888 -- Stack_Ptr current stack pointer
3893 -- Come here to match the next pattern element
3895 -- Cursor current position in subject string
3896 -- Node pointer to node to be matched
3897 -- Stack_Base current stack base
3898 -- Stack_Ptr current stack pointer
3902 --------------------------------------------------
3903 -- Main Pattern Match Element Matching Routines --
3904 --------------------------------------------------
3906 -- Here is the case statement that processes the current node. The
3907 -- processing for each element does one of five things:
3909 -- goto Succeed to move to the successor
3910 -- goto Match_Succeed if the entire match succeeds
3911 -- goto Match_Fail if the entire match fails
3912 -- goto Fail to signal failure of current match
3914 -- Processing is NOT allowed to fall through
3930 -- Any (one character case)
3934 and then Subject (Cursor + 1) = Node.Char
3936 Cursor := Cursor + 1;
3942 -- Any (character set case)
3946 and then Is_In (Subject (Cursor + 1), Node.CS)
3948 Cursor := Cursor + 1;
3954 -- Any (string function case)
3956 when PC_Any_VF => declare
3957 U : constant VString := Node.VF.all;
3962 Get_String (U, S, L);
3965 and then Is_In (Subject (Cursor + 1), S (1 .. L))
3967 Cursor := Cursor + 1;
3974 -- Any (string pointer case)
3976 when PC_Any_VP => declare
3977 U : constant VString := Node.VP.all;
3982 Get_String (U, S, L);
3985 and then Is_In (Subject (Cursor + 1), S (1 .. L))
3987 Cursor := Cursor + 1;
3994 -- Arb (initial match)
4004 if Cursor < Length then
4005 Cursor := Cursor + 1;
4012 -- Arbno_S (simple Arbno initialize). This is the node that
4013 -- initiates the match of a simple Arbno structure.
4020 -- Arbno_X (Arbno initialize). This is the node that initiates
4021 -- the match of a complex Arbno structure.
4028 -- Arbno_Y (Arbno rematch). This is the node that is executed
4029 -- following successful matching of one instance of a complex
4032 when PC_Arbno_Y => declare
4033 Null_Match : constant Boolean :=
4034 Cursor = Stack (Stack_Base - 1).Cursor;
4039 -- If arbno extension matched null, then immediately fail
4045 -- Here we must do a stack check to make sure enough stack
4046 -- is left. This check will happen once for each instance of
4047 -- the Arbno pattern that is matched. The Nat field of a
4048 -- PC_Arbno pattern contains the maximum stack entries needed
4049 -- for the Arbno with one instance and the successor pattern
4051 if Stack_Ptr + Node.Nat >= Stack'Last then
4052 raise Pattern_Stack_Overflow;
4058 -- Assign. If this node is executed, it means the assign-on-match
4059 -- or write-on-match operation will not happen after all, so we
4060 -- is propagate the failure, removing the PC_Assign node.
4065 -- Assign immediate. This node performs the actual assignment
4067 when PC_Assign_Imm =>
4070 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4074 -- Assign on match. This node sets up for the eventual assignment
4076 when PC_Assign_OnM =>
4077 Stack (Stack_Base - 1).Node := Node;
4078 Push (CP_Assign'Access);
4086 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
4089 elsif Subject (Cursor + 1) = '(' then
4091 Paren_Count : Natural := 1;
4095 Cursor := Cursor + 1;
4097 if Cursor >= Length then
4100 elsif Subject (Cursor + 1) = '(' then
4101 Paren_Count := Paren_Count + 1;
4103 elsif Subject (Cursor + 1) = ')' then
4104 Paren_Count := Paren_Count - 1;
4105 exit when Paren_Count = 0;
4111 Cursor := Cursor + 1;
4115 -- Break (one character case)
4118 while Cursor < Length loop
4119 if Subject (Cursor + 1) = Node.Char then
4122 Cursor := Cursor + 1;
4128 -- Break (character set case)
4131 while Cursor < Length loop
4132 if Is_In (Subject (Cursor + 1), Node.CS) then
4135 Cursor := Cursor + 1;
4141 -- Break (string function case)
4143 when PC_Break_VF => declare
4144 U : constant VString := Node.VF.all;
4149 Get_String (U, S, L);
4151 while Cursor < Length loop
4152 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4155 Cursor := Cursor + 1;
4162 -- Break (string pointer case)
4164 when PC_Break_VP => declare
4165 U : constant VString := Node.VP.all;
4170 Get_String (U, S, L);
4172 while Cursor < Length loop
4173 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4176 Cursor := Cursor + 1;
4183 -- BreakX (one character case)
4185 when PC_BreakX_CH =>
4186 while Cursor < Length loop
4187 if Subject (Cursor + 1) = Node.Char then
4190 Cursor := Cursor + 1;
4196 -- BreakX (character set case)
4198 when PC_BreakX_CS =>
4199 while Cursor < Length loop
4200 if Is_In (Subject (Cursor + 1), Node.CS) then
4203 Cursor := Cursor + 1;
4209 -- BreakX (string function case)
4211 when PC_BreakX_VF => declare
4212 U : constant VString := Node.VF.all;
4217 Get_String (U, S, L);
4219 while Cursor < Length loop
4220 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4223 Cursor := Cursor + 1;
4230 -- BreakX (string pointer case)
4232 when PC_BreakX_VP => declare
4233 U : constant VString := Node.VP.all;
4238 Get_String (U, S, L);
4240 while Cursor < Length loop
4241 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4244 Cursor := Cursor + 1;
4251 -- BreakX_X (BreakX extension). See section on "Compound Pattern
4252 -- Structures". This node is the alternative that is stacked to
4253 -- skip past the break character and extend the break.
4256 Cursor := Cursor + 1;
4259 -- Character (one character string)
4263 and then Subject (Cursor + 1) = Node.Char
4265 Cursor := Cursor + 1;
4274 if Stack_Base = Stack_Init then
4277 -- End of recursive inner match. See separate section on
4278 -- handing of recursive pattern matches for details.
4281 Node := Stack (Stack_Base - 1).Node;
4291 -- Fence (built in pattern)
4294 Push (CP_Cancel'Access);
4297 -- Fence function node X. This is the node that gets control
4298 -- after a successful match of the fenced pattern.
4301 Stack_Ptr := Stack_Ptr + 1;
4302 Stack (Stack_Ptr).Cursor := Stack_Base;
4303 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
4304 Stack_Base := Stack (Stack_Base).Cursor;
4307 -- Fence function node Y. This is the node that gets control on
4308 -- a failure that occurs after the fenced pattern has matched.
4310 -- Note: the Cursor at this stage is actually the inner stack
4311 -- base value. We don't reset this, but we do use it to strip
4312 -- off all the entries made by the fenced pattern.
4315 Stack_Ptr := Cursor - 2;
4318 -- Len (integer case)
4321 if Cursor + Node.Nat > Length then
4324 Cursor := Cursor + Node.Nat;
4328 -- Len (Integer function case)
4330 when PC_Len_NF => declare
4331 N : constant Natural := Node.NF.all;
4333 if Cursor + N > Length then
4336 Cursor := Cursor + N;
4341 -- Len (integer pointer case)
4344 if Cursor + Node.NP.all > Length then
4347 Cursor := Cursor + Node.NP.all;
4351 -- NotAny (one character case)
4353 when PC_NotAny_CH =>
4355 and then Subject (Cursor + 1) /= Node.Char
4357 Cursor := Cursor + 1;
4363 -- NotAny (character set case)
4365 when PC_NotAny_CS =>
4367 and then not Is_In (Subject (Cursor + 1), Node.CS)
4369 Cursor := Cursor + 1;
4375 -- NotAny (string function case)
4377 when PC_NotAny_VF => declare
4378 U : constant VString := Node.VF.all;
4383 Get_String (U, S, L);
4387 not Is_In (Subject (Cursor + 1), S (1 .. L))
4389 Cursor := Cursor + 1;
4396 -- NotAny (string pointer case)
4398 when PC_NotAny_VP => declare
4399 U : constant VString := Node.VP.all;
4404 Get_String (U, S, L);
4408 not Is_In (Subject (Cursor + 1), S (1 .. L))
4410 Cursor := Cursor + 1;
4417 -- NSpan (one character case)
4420 while Cursor < Length
4421 and then Subject (Cursor + 1) = Node.Char
4423 Cursor := Cursor + 1;
4428 -- NSpan (character set case)
4431 while Cursor < Length
4432 and then Is_In (Subject (Cursor + 1), Node.CS)
4434 Cursor := Cursor + 1;
4439 -- NSpan (string function case)
4441 when PC_NSpan_VF => declare
4442 U : constant VString := Node.VF.all;
4447 Get_String (U, S, L);
4449 while Cursor < Length
4450 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4452 Cursor := Cursor + 1;
4458 -- NSpan (string pointer case)
4460 when PC_NSpan_VP => declare
4461 U : constant VString := Node.VP.all;
4466 Get_String (U, S, L);
4468 while Cursor < Length
4469 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4471 Cursor := Cursor + 1;
4482 -- Pos (integer case)
4485 if Cursor = Node.Nat then
4491 -- Pos (Integer function case)
4493 when PC_Pos_NF => declare
4494 N : constant Natural := Node.NF.all;
4503 -- Pos (integer pointer case)
4506 if Cursor = Node.NP.all then
4512 -- Predicate function
4514 when PC_Pred_Func =>
4521 -- Region Enter. Initiate new pattern history stack region
4524 Stack (Stack_Ptr + 1).Cursor := Cursor;
4528 -- Region Remove node. This is the node stacked by an R_Enter.
4529 -- It removes the special format stack entry right underneath, and
4530 -- then restores the outer level stack base and signals failure.
4532 -- Note: the cursor value at this stage is actually the (negative)
4533 -- stack base value for the outer level.
4536 Stack_Base := Cursor;
4537 Stack_Ptr := Stack_Ptr - 1;
4540 -- Region restore node. This is the node stacked at the end of an
4541 -- inner level match. Its function is to restore the inner level
4542 -- region, so that alternatives in this region can be sought.
4544 -- Note: the Cursor at this stage is actually the negative of the
4545 -- inner stack base value, which we use to restore the inner region.
4547 when PC_R_Restore =>
4548 Stack_Base := Cursor;
4557 -- Initiate recursive match (pattern pointer case)
4560 Stack (Stack_Ptr + 1).Node := Node.Pthen;
4563 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
4564 raise Pattern_Stack_Overflow;
4566 Node := Node.PP.all.P;
4570 -- RPos (integer case)
4573 if Cursor = (Length - Node.Nat) then
4579 -- RPos (integer function case)
4581 when PC_RPos_NF => declare
4582 N : constant Natural := Node.NF.all;
4584 if Length - Cursor = N then
4591 -- RPos (integer pointer case)
4594 if Cursor = (Length - Node.NP.all) then
4600 -- RTab (integer case)
4603 if Cursor <= (Length - Node.Nat) then
4604 Cursor := Length - Node.Nat;
4610 -- RTab (integer function case)
4612 when PC_RTab_NF => declare
4613 N : constant Natural := Node.NF.all;
4615 if Length - Cursor >= N then
4616 Cursor := Length - N;
4623 -- RTab (integer pointer case)
4626 if Cursor <= (Length - Node.NP.all) then
4627 Cursor := Length - Node.NP.all;
4633 -- Cursor assignment
4636 Node.Var.all := Cursor;
4639 -- Span (one character case)
4641 when PC_Span_CH => declare
4647 and then Subject (P + 1) = Node.Char
4660 -- Span (character set case)
4662 when PC_Span_CS => declare
4668 and then Is_In (Subject (P + 1), Node.CS)
4681 -- Span (string function case)
4683 when PC_Span_VF => declare
4684 U : constant VString := Node.VF.all;
4690 Get_String (U, S, L);
4694 and then Is_In (Subject (P + 1), S (1 .. L))
4707 -- Span (string pointer case)
4709 when PC_Span_VP => declare
4710 U : constant VString := Node.VP.all;
4716 Get_String (U, S, L);
4720 and then Is_In (Subject (P + 1), S (1 .. L))
4733 -- String (two character case)
4736 if (Length - Cursor) >= 2
4737 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
4739 Cursor := Cursor + 2;
4745 -- String (three character case)
4748 if (Length - Cursor) >= 3
4749 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
4751 Cursor := Cursor + 3;
4757 -- String (four character case)
4760 if (Length - Cursor) >= 4
4761 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
4763 Cursor := Cursor + 4;
4769 -- String (five character case)
4772 if (Length - Cursor) >= 5
4773 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
4775 Cursor := Cursor + 5;
4781 -- String (six character case)
4784 if (Length - Cursor) >= 6
4785 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
4787 Cursor := Cursor + 6;
4793 -- String (case of more than six characters)
4795 when PC_String => declare
4796 Len : constant Natural := Node.Str'Length;
4798 if (Length - Cursor) >= Len
4799 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
4801 Cursor := Cursor + Len;
4808 -- String (function case)
4810 when PC_String_VF => declare
4811 U : constant VString := Node.VF.all;
4816 Get_String (U, S, L);
4818 if (Length - Cursor) >= L
4819 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4821 Cursor := Cursor + L;
4828 -- String (pointer case)
4830 when PC_String_VP => declare
4831 U : constant VString := Node.VP.all;
4836 Get_String (U, S, L);
4838 if (Length - Cursor) >= L
4839 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4841 Cursor := Cursor + L;
4854 -- Tab (integer case)
4857 if Cursor <= Node.Nat then
4864 -- Tab (integer function case)
4866 when PC_Tab_NF => declare
4867 N : constant Natural := Node.NF.all;
4877 -- Tab (integer pointer case)
4880 if Cursor <= Node.NP.all then
4881 Cursor := Node.NP.all;
4887 -- Unanchored movement
4889 when PC_Unanchored =>
4891 -- All done if we tried every position
4893 if Cursor > Length then
4896 -- Otherwise extend the anchor point, and restack ourself
4899 Cursor := Cursor + 1;
4904 -- Write immediate. This node performs the actual write
4906 when PC_Write_Imm =>
4909 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4913 -- Write on match. This node sets up for the eventual write
4915 when PC_Write_OnM =>
4916 Stack (Stack_Base - 1).Node := Node;
4917 Push (CP_Assign'Access);
4924 -- We are NOT allowed to fall though this case statement, since every
4925 -- match routine must end by executing a goto to the appropriate point
4926 -- in the finite state machine model.
4928 pragma Warnings (Off);
4930 pragma Warnings (On);
4937 -- Maintenance note: There is a LOT of code duplication between XMatch
4938 -- and XMatchD. This is quite intentional, the point is to avoid any
4939 -- unnecessary debugging overhead in the XMatch case, but this does mean
4940 -- that any changes to XMatchD must be mirrored in XMatch. In case of
4941 -- any major changes, the proper approach is to delete XMatch, make the
4942 -- changes to XMatchD, and then make a copy of XMatchD, removing all
4943 -- calls to Dout, and all Put and Put_Line operations. This copy becomes
4950 Start : out Natural;
4954 -- Pointer to current pattern node. Initialized from Pat_P, and then
4955 -- updated as the match proceeds through its constituent elements.
4957 Length : constant Natural := Subject'Length;
4958 -- Length of string (= Subject'Last, since Subject'First is always 1)
4960 Cursor : Integer := 0;
4961 -- If the value is non-negative, then this value is the index showing
4962 -- the current position of the match in the subject string. The next
4963 -- character to be matched is at Subject (Cursor + 1). Note that since
4964 -- our view of the subject string in XMatch always has a lower bound
4965 -- of one, regardless of original bounds, that this definition exactly
4966 -- corresponds to the cursor value as referenced by functions like Pos.
4968 -- If the value is negative, then this is a saved stack pointer,
4969 -- typically a base pointer of an inner or outer region. Cursor
4970 -- temporarily holds such a value when it is popped from the stack
4971 -- by Fail. In all cases, Cursor is reset to a proper non-negative
4972 -- cursor value before the match proceeds (e.g. by propagating the
4973 -- failure and popping a "real" cursor value from the stack.
4975 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
4976 -- Dummy pattern element used in the unanchored case
4978 Region_Level : Natural := 0;
4979 -- Keeps track of recursive region level. This is used only for
4980 -- debugging, it is the number of saved history stack base values.
4983 -- The pattern matching failure stack for this call to Match
4985 Stack_Ptr : Stack_Range;
4986 -- Current stack pointer. This points to the top element of the stack
4987 -- that is currently in use. At the outer level this is the special
4988 -- entry placed on the stack according to the anchor mode.
4990 Stack_Init : constant Stack_Range := Stack'First + 1;
4991 -- This is the initial value of the Stack_Ptr and Stack_Base. The
4992 -- initial (Stack'First) element of the stack is not used so that
4993 -- when we pop the last element off, Stack_Ptr is still in range.
4995 Stack_Base : Stack_Range;
4996 -- This value is the stack base value, i.e. the stack pointer for the
4997 -- first history stack entry in the current stack region. See separate
4998 -- section on handling of recursive pattern matches.
5000 Assign_OnM : Boolean := False;
5001 -- Set True if assign-on-match or write-on-match operations may be
5002 -- present in the history stack, which must then be scanned on a
5003 -- successful match.
5005 procedure Dout (Str : String);
5006 -- Output string to standard error with bars indicating region level
5008 procedure Dout (Str : String; A : Character);
5009 -- Calls Dout with the string S ('A')
5011 procedure Dout (Str : String; A : Character_Set);
5012 -- Calls Dout with the string S ("A")
5014 procedure Dout (Str : String; A : Natural);
5015 -- Calls Dout with the string S (A)
5017 procedure Dout (Str : String; A : String);
5018 -- Calls Dout with the string S ("A")
5020 function Img (P : PE_Ptr) return String;
5021 -- Returns a string of the form #nnn where nnn is P.Index
5023 procedure Pop_Region;
5024 pragma Inline (Pop_Region);
5025 -- Used at the end of processing of an inner region. If the inner
5026 -- region left no stack entries, then all trace of it is removed.
5027 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
5028 -- handling of alternatives in the inner region.
5030 procedure Push (Node : PE_Ptr);
5031 pragma Inline (Push);
5032 -- Make entry in pattern matching stack with current cursor value
5034 procedure Push_Region;
5035 pragma Inline (Push_Region);
5036 -- This procedure makes a new region on the history stack. The
5037 -- caller first establishes the special entry on the stack, but
5038 -- does not push the stack pointer. Then this call stacks a
5039 -- PC_Remove_Region node, on top of this entry, using the cursor
5040 -- field of the PC_Remove_Region entry to save the outer level
5041 -- stack base value, and resets the stack base to point to this
5042 -- PC_Remove_Region node.
5048 procedure Dout (Str : String) is
5050 for J in 1 .. Region_Level loop
5057 procedure Dout (Str : String; A : Character) is
5059 Dout (Str & " ('" & A & "')");
5062 procedure Dout (Str : String; A : Character_Set) is
5064 Dout (Str & " (" & Image (To_Sequence (A)) & ')');
5067 procedure Dout (Str : String; A : Natural) is
5069 Dout (Str & " (" & A & ')');
5072 procedure Dout (Str : String; A : String) is
5074 Dout (Str & " (" & Image (A) & ')');
5081 function Img (P : PE_Ptr) return String is
5083 return "#" & Integer (P.Index) & " ";
5090 procedure Pop_Region is
5092 Region_Level := Region_Level - 1;
5094 -- If nothing was pushed in the inner region, we can just get
5095 -- rid of it entirely, leaving no traces that it was ever there
5097 if Stack_Ptr = Stack_Base then
5098 Stack_Ptr := Stack_Base - 2;
5099 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
5101 -- If stuff was pushed in the inner region, then we have to
5102 -- push a PC_R_Restore node so that we properly handle possible
5103 -- rematches within the region.
5106 Stack_Ptr := Stack_Ptr + 1;
5107 Stack (Stack_Ptr).Cursor := Stack_Base;
5108 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
5109 Stack_Base := Stack (Stack_Base).Cursor;
5117 procedure Push (Node : PE_Ptr) is
5119 Stack_Ptr := Stack_Ptr + 1;
5120 Stack (Stack_Ptr).Cursor := Cursor;
5121 Stack (Stack_Ptr).Node := Node;
5128 procedure Push_Region is
5130 Region_Level := Region_Level + 1;
5131 Stack_Ptr := Stack_Ptr + 2;
5132 Stack (Stack_Ptr).Cursor := Stack_Base;
5133 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
5134 Stack_Base := Stack_Ptr;
5137 -- Start of processing for XMatchD
5141 Put_Line ("Initiating pattern match, subject = " & Image (Subject));
5142 Put ("--------------------------------------");
5144 for J in 1 .. Length loop
5149 Put_Line ("subject length = " & Length);
5151 if Pat_P = null then
5152 Uninitialized_Pattern;
5155 -- Check we have enough stack for this pattern. This check deals with
5156 -- every possibility except a match of a recursive pattern, where we
5157 -- make a check at each recursion level.
5159 if Pat_S >= Stack_Size - 1 then
5160 raise Pattern_Stack_Overflow;
5163 -- In anchored mode, the bottom entry on the stack is an abort entry
5165 if Anchored_Mode then
5166 Stack (Stack_Init).Node := CP_Cancel'Access;
5167 Stack (Stack_Init).Cursor := 0;
5169 -- In unanchored more, the bottom entry on the stack references
5170 -- the special pattern element PE_Unanchored, whose Pthen field
5171 -- points to the initial pattern element. The cursor value in this
5172 -- entry is the number of anchor moves so far.
5175 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
5176 Stack (Stack_Init).Cursor := 0;
5179 Stack_Ptr := Stack_Init;
5180 Stack_Base := Stack_Ptr;
5185 -----------------------------------------
5186 -- Main Pattern Matching State Control --
5187 -----------------------------------------
5189 -- This is a state machine which uses gotos to change state. The
5190 -- initial state is Match, to initiate the matching of the first
5191 -- element, so the goto Match above starts the match. In the
5192 -- following descriptions, we indicate the global values that
5193 -- are relevant for the state transition.
5195 -- Come here if entire match fails
5198 Dout ("match fails");
5204 -- Come here if entire match succeeds
5206 -- Cursor current position in subject string
5209 Dout ("match succeeds");
5210 Start := Stack (Stack_Init).Cursor + 1;
5212 Dout ("first matched character index = " & Start);
5213 Dout ("last matched character index = " & Stop);
5214 Dout ("matched substring = " & Image (Subject (Start .. Stop)));
5216 -- Scan history stack for deferred assignments or writes
5219 for S in Stack'First .. Stack_Ptr loop
5220 if Stack (S).Node = CP_Assign'Access then
5222 Inner_Base : constant Stack_Range :=
5223 Stack (S + 1).Cursor;
5224 Special_Entry : constant Stack_Range :=
5226 Node_OnM : constant PE_Ptr :=
5227 Stack (Special_Entry).Node;
5228 Start : constant Natural :=
5229 Stack (Special_Entry).Cursor + 1;
5230 Stop : constant Natural := Stack (S).Cursor;
5233 if Node_OnM.Pcode = PC_Assign_OnM then
5234 Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
5236 (Img (Stack (S).Node) &
5237 "deferred assignment of " &
5238 Image (Subject (Start .. Stop)));
5240 elsif Node_OnM.Pcode = PC_Write_OnM then
5241 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
5243 (Img (Stack (S).Node) &
5244 "deferred write of " &
5245 Image (Subject (Start .. Stop)));
5258 -- Come here if attempt to match current element fails
5260 -- Stack_Base current stack base
5261 -- Stack_Ptr current stack pointer
5264 Cursor := Stack (Stack_Ptr).Cursor;
5265 Node := Stack (Stack_Ptr).Node;
5266 Stack_Ptr := Stack_Ptr - 1;
5269 Dout ("failure, cursor reset to " & Cursor);
5274 -- Come here if attempt to match current element succeeds
5276 -- Cursor current position in subject string
5277 -- Node pointer to node successfully matched
5278 -- Stack_Base current stack base
5279 -- Stack_Ptr current stack pointer
5282 Dout ("success, cursor = " & Cursor);
5285 -- Come here to match the next pattern element
5287 -- Cursor current position in subject string
5288 -- Node pointer to node to be matched
5289 -- Stack_Base current stack base
5290 -- Stack_Ptr current stack pointer
5294 --------------------------------------------------
5295 -- Main Pattern Match Element Matching Routines --
5296 --------------------------------------------------
5298 -- Here is the case statement that processes the current node. The
5299 -- processing for each element does one of five things:
5301 -- goto Succeed to move to the successor
5302 -- goto Match_Succeed if the entire match succeeds
5303 -- goto Match_Fail if the entire match fails
5304 -- goto Fail to signal failure of current match
5306 -- Processing is NOT allowed to fall through
5313 Dout (Img (Node) & "matching Cancel");
5320 (Img (Node) & "setting up alternative " & Img (Node.Alt));
5325 -- Any (one character case)
5328 Dout (Img (Node) & "matching Any", Node.Char);
5331 and then Subject (Cursor + 1) = Node.Char
5333 Cursor := Cursor + 1;
5339 -- Any (character set case)
5342 Dout (Img (Node) & "matching Any", Node.CS);
5345 and then Is_In (Subject (Cursor + 1), Node.CS)
5347 Cursor := Cursor + 1;
5353 -- Any (string function case)
5355 when PC_Any_VF => declare
5356 U : constant VString := Node.VF.all;
5361 Get_String (U, S, L);
5363 Dout (Img (Node) & "matching Any", S (1 .. L));
5366 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5368 Cursor := Cursor + 1;
5375 -- Any (string pointer case)
5377 when PC_Any_VP => declare
5378 U : constant VString := Node.VP.all;
5383 Get_String (U, S, L);
5384 Dout (Img (Node) & "matching Any", S (1 .. L));
5387 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5389 Cursor := Cursor + 1;
5396 -- Arb (initial match)
5399 Dout (Img (Node) & "matching Arb");
5407 Dout (Img (Node) & "extending Arb");
5409 if Cursor < Length then
5410 Cursor := Cursor + 1;
5417 -- Arbno_S (simple Arbno initialize). This is the node that
5418 -- initiates the match of a simple Arbno structure.
5422 "setting up Arbno alternative " & Img (Node.Alt));
5427 -- Arbno_X (Arbno initialize). This is the node that initiates
5428 -- the match of a complex Arbno structure.
5432 "setting up Arbno alternative " & Img (Node.Alt));
5437 -- Arbno_Y (Arbno rematch). This is the node that is executed
5438 -- following successful matching of one instance of a complex
5441 when PC_Arbno_Y => declare
5442 Null_Match : constant Boolean :=
5443 Cursor = Stack (Stack_Base - 1).Cursor;
5446 Dout (Img (Node) & "extending Arbno");
5449 -- If arbno extension matched null, then immediately fail
5452 Dout ("Arbno extension matched null, so fails");
5456 -- Here we must do a stack check to make sure enough stack
5457 -- is left. This check will happen once for each instance of
5458 -- the Arbno pattern that is matched. The Nat field of a
5459 -- PC_Arbno pattern contains the maximum stack entries needed
5460 -- for the Arbno with one instance and the successor pattern
5462 if Stack_Ptr + Node.Nat >= Stack'Last then
5463 raise Pattern_Stack_Overflow;
5469 -- Assign. If this node is executed, it means the assign-on-match
5470 -- or write-on-match operation will not happen after all, so we
5471 -- is propagate the failure, removing the PC_Assign node.
5474 Dout (Img (Node) & "deferred assign/write cancelled");
5477 -- Assign immediate. This node performs the actual assignment
5479 when PC_Assign_Imm =>
5481 (Img (Node) & "executing immediate assignment of " &
5482 Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)));
5485 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
5489 -- Assign on match. This node sets up for the eventual assignment
5491 when PC_Assign_OnM =>
5492 Dout (Img (Node) & "registering deferred assignment");
5493 Stack (Stack_Base - 1).Node := Node;
5494 Push (CP_Assign'Access);
5502 Dout (Img (Node) & "matching or extending Bal");
5503 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
5506 elsif Subject (Cursor + 1) = '(' then
5508 Paren_Count : Natural := 1;
5512 Cursor := Cursor + 1;
5514 if Cursor >= Length then
5517 elsif Subject (Cursor + 1) = '(' then
5518 Paren_Count := Paren_Count + 1;
5520 elsif Subject (Cursor + 1) = ')' then
5521 Paren_Count := Paren_Count - 1;
5522 exit when Paren_Count = 0;
5528 Cursor := Cursor + 1;
5532 -- Break (one character case)
5535 Dout (Img (Node) & "matching Break", Node.Char);
5537 while Cursor < Length loop
5538 if Subject (Cursor + 1) = Node.Char then
5541 Cursor := Cursor + 1;
5547 -- Break (character set case)
5550 Dout (Img (Node) & "matching Break", Node.CS);
5552 while Cursor < Length loop
5553 if Is_In (Subject (Cursor + 1), Node.CS) then
5556 Cursor := Cursor + 1;
5562 -- Break (string function case)
5564 when PC_Break_VF => declare
5565 U : constant VString := Node.VF.all;
5570 Get_String (U, S, L);
5571 Dout (Img (Node) & "matching Break", S (1 .. L));
5573 while Cursor < Length loop
5574 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5577 Cursor := Cursor + 1;
5584 -- Break (string pointer case)
5586 when PC_Break_VP => declare
5587 U : constant VString := Node.VP.all;
5592 Get_String (U, S, L);
5593 Dout (Img (Node) & "matching Break", S (1 .. L));
5595 while Cursor < Length loop
5596 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5599 Cursor := Cursor + 1;
5606 -- BreakX (one character case)
5608 when PC_BreakX_CH =>
5609 Dout (Img (Node) & "matching BreakX", Node.Char);
5611 while Cursor < Length loop
5612 if Subject (Cursor + 1) = Node.Char then
5615 Cursor := Cursor + 1;
5621 -- BreakX (character set case)
5623 when PC_BreakX_CS =>
5624 Dout (Img (Node) & "matching BreakX", Node.CS);
5626 while Cursor < Length loop
5627 if Is_In (Subject (Cursor + 1), Node.CS) then
5630 Cursor := Cursor + 1;
5636 -- BreakX (string function case)
5638 when PC_BreakX_VF => declare
5639 U : constant VString := Node.VF.all;
5644 Get_String (U, S, L);
5645 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5647 while Cursor < Length loop
5648 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5651 Cursor := Cursor + 1;
5658 -- BreakX (string pointer case)
5660 when PC_BreakX_VP => declare
5661 U : constant VString := Node.VP.all;
5666 Get_String (U, S, L);
5667 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5669 while Cursor < Length loop
5670 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5673 Cursor := Cursor + 1;
5680 -- BreakX_X (BreakX extension). See section on "Compound Pattern
5681 -- Structures". This node is the alternative that is stacked
5682 -- to skip past the break character and extend the break.
5685 Dout (Img (Node) & "extending BreakX");
5686 Cursor := Cursor + 1;
5689 -- Character (one character string)
5692 Dout (Img (Node) & "matching '" & Node.Char & ''');
5695 and then Subject (Cursor + 1) = Node.Char
5697 Cursor := Cursor + 1;
5706 if Stack_Base = Stack_Init then
5707 Dout ("end of pattern");
5710 -- End of recursive inner match. See separate section on
5711 -- handing of recursive pattern matches for details.
5714 Dout ("terminating recursive match");
5715 Node := Stack (Stack_Base - 1).Node;
5723 Dout (Img (Node) & "matching Fail");
5726 -- Fence (built in pattern)
5729 Dout (Img (Node) & "matching Fence");
5730 Push (CP_Cancel'Access);
5733 -- Fence function node X. This is the node that gets control
5734 -- after a successful match of the fenced pattern.
5737 Dout (Img (Node) & "matching Fence function");
5738 Stack_Ptr := Stack_Ptr + 1;
5739 Stack (Stack_Ptr).Cursor := Stack_Base;
5740 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
5741 Stack_Base := Stack (Stack_Base).Cursor;
5742 Region_Level := Region_Level - 1;
5745 -- Fence function node Y. This is the node that gets control on
5746 -- a failure that occurs after the fenced pattern has matched.
5748 -- Note: the Cursor at this stage is actually the inner stack
5749 -- base value. We don't reset this, but we do use it to strip
5750 -- off all the entries made by the fenced pattern.
5753 Dout (Img (Node) & "pattern matched by Fence caused failure");
5754 Stack_Ptr := Cursor - 2;
5757 -- Len (integer case)
5760 Dout (Img (Node) & "matching Len", Node.Nat);
5762 if Cursor + Node.Nat > Length then
5765 Cursor := Cursor + Node.Nat;
5769 -- Len (Integer function case)
5771 when PC_Len_NF => declare
5772 N : constant Natural := Node.NF.all;
5775 Dout (Img (Node) & "matching Len", N);
5777 if Cursor + N > Length then
5780 Cursor := Cursor + N;
5785 -- Len (integer pointer case)
5788 Dout (Img (Node) & "matching Len", Node.NP.all);
5790 if Cursor + Node.NP.all > Length then
5793 Cursor := Cursor + Node.NP.all;
5797 -- NotAny (one character case)
5799 when PC_NotAny_CH =>
5800 Dout (Img (Node) & "matching NotAny", Node.Char);
5803 and then Subject (Cursor + 1) /= Node.Char
5805 Cursor := Cursor + 1;
5811 -- NotAny (character set case)
5813 when PC_NotAny_CS =>
5814 Dout (Img (Node) & "matching NotAny", Node.CS);
5817 and then not Is_In (Subject (Cursor + 1), Node.CS)
5819 Cursor := Cursor + 1;
5825 -- NotAny (string function case)
5827 when PC_NotAny_VF => declare
5828 U : constant VString := Node.VF.all;
5833 Get_String (U, S, L);
5834 Dout (Img (Node) & "matching NotAny", S (1 .. L));
5838 not Is_In (Subject (Cursor + 1), S (1 .. L))
5840 Cursor := Cursor + 1;
5847 -- NotAny (string pointer case)
5849 when PC_NotAny_VP => declare
5850 U : constant VString := Node.VP.all;
5855 Get_String (U, S, L);
5856 Dout (Img (Node) & "matching NotAny", S (1 .. L));
5860 not Is_In (Subject (Cursor + 1), S (1 .. L))
5862 Cursor := Cursor + 1;
5869 -- NSpan (one character case)
5872 Dout (Img (Node) & "matching NSpan", Node.Char);
5874 while Cursor < Length
5875 and then Subject (Cursor + 1) = Node.Char
5877 Cursor := Cursor + 1;
5882 -- NSpan (character set case)
5885 Dout (Img (Node) & "matching NSpan", Node.CS);
5887 while Cursor < Length
5888 and then Is_In (Subject (Cursor + 1), Node.CS)
5890 Cursor := Cursor + 1;
5895 -- NSpan (string function case)
5897 when PC_NSpan_VF => declare
5898 U : constant VString := Node.VF.all;
5903 Get_String (U, S, L);
5904 Dout (Img (Node) & "matching NSpan", S (1 .. L));
5906 while Cursor < Length
5907 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5909 Cursor := Cursor + 1;
5915 -- NSpan (string pointer case)
5917 when PC_NSpan_VP => declare
5918 U : constant VString := Node.VP.all;
5923 Get_String (U, S, L);
5924 Dout (Img (Node) & "matching NSpan", S (1 .. L));
5926 while Cursor < Length
5927 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5929 Cursor := Cursor + 1;
5936 Dout (Img (Node) & "matching null");
5939 -- Pos (integer case)
5942 Dout (Img (Node) & "matching Pos", Node.Nat);
5944 if Cursor = Node.Nat then
5950 -- Pos (Integer function case)
5952 when PC_Pos_NF => declare
5953 N : constant Natural := Node.NF.all;
5956 Dout (Img (Node) & "matching Pos", N);
5965 -- Pos (integer pointer case)
5968 Dout (Img (Node) & "matching Pos", Node.NP.all);
5970 if Cursor = Node.NP.all then
5976 -- Predicate function
5978 when PC_Pred_Func =>
5979 Dout (Img (Node) & "matching predicate function");
5987 -- Region Enter. Initiate new pattern history stack region
5990 Dout (Img (Node) & "starting match of nested pattern");
5991 Stack (Stack_Ptr + 1).Cursor := Cursor;
5995 -- Region Remove node. This is the node stacked by an R_Enter.
5996 -- It removes the special format stack entry right underneath, and
5997 -- then restores the outer level stack base and signals failure.
5999 -- Note: the cursor value at this stage is actually the (negative)
6000 -- stack base value for the outer level.
6003 Dout ("failure, match of nested pattern terminated");
6004 Stack_Base := Cursor;
6005 Region_Level := Region_Level - 1;
6006 Stack_Ptr := Stack_Ptr - 1;
6009 -- Region restore node. This is the node stacked at the end of an
6010 -- inner level match. Its function is to restore the inner level
6011 -- region, so that alternatives in this region can be sought.
6013 -- Note: the Cursor at this stage is actually the negative of the
6014 -- inner stack base value, which we use to restore the inner region.
6016 when PC_R_Restore =>
6017 Dout ("failure, search for alternatives in nested pattern");
6018 Region_Level := Region_Level + 1;
6019 Stack_Base := Cursor;
6025 Dout (Img (Node) & "matching Rest");
6029 -- Initiate recursive match (pattern pointer case)
6032 Stack (Stack_Ptr + 1).Node := Node.Pthen;
6034 Dout (Img (Node) & "initiating recursive match");
6036 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
6037 raise Pattern_Stack_Overflow;
6039 Node := Node.PP.all.P;
6043 -- RPos (integer case)
6046 Dout (Img (Node) & "matching RPos", Node.Nat);
6048 if Cursor = (Length - Node.Nat) then
6054 -- RPos (integer function case)
6056 when PC_RPos_NF => declare
6057 N : constant Natural := Node.NF.all;
6060 Dout (Img (Node) & "matching RPos", N);
6062 if Length - Cursor = N then
6069 -- RPos (integer pointer case)
6072 Dout (Img (Node) & "matching RPos", Node.NP.all);
6074 if Cursor = (Length - Node.NP.all) then
6080 -- RTab (integer case)
6083 Dout (Img (Node) & "matching RTab", Node.Nat);
6085 if Cursor <= (Length - Node.Nat) then
6086 Cursor := Length - Node.Nat;
6092 -- RTab (integer function case)
6094 when PC_RTab_NF => declare
6095 N : constant Natural := Node.NF.all;
6098 Dout (Img (Node) & "matching RPos", N);
6100 if Length - Cursor >= N then
6101 Cursor := Length - N;
6108 -- RTab (integer pointer case)
6111 Dout (Img (Node) & "matching RPos", Node.NP.all);
6113 if Cursor <= (Length - Node.NP.all) then
6114 Cursor := Length - Node.NP.all;
6120 -- Cursor assignment
6123 Dout (Img (Node) & "matching Setcur");
6124 Node.Var.all := Cursor;
6127 -- Span (one character case)
6129 when PC_Span_CH => declare
6130 P : Natural := Cursor;
6133 Dout (Img (Node) & "matching Span", Node.Char);
6136 and then Subject (P + 1) = Node.Char
6149 -- Span (character set case)
6151 when PC_Span_CS => declare
6152 P : Natural := Cursor;
6155 Dout (Img (Node) & "matching Span", Node.CS);
6158 and then Is_In (Subject (P + 1), Node.CS)
6171 -- Span (string function case)
6173 when PC_Span_VF => declare
6174 U : constant VString := Node.VF.all;
6180 Get_String (U, S, L);
6181 Dout (Img (Node) & "matching Span", S (1 .. L));
6185 and then Is_In (Subject (P + 1), S (1 .. L))
6198 -- Span (string pointer case)
6200 when PC_Span_VP => declare
6201 U : constant VString := Node.VP.all;
6207 Get_String (U, S, L);
6208 Dout (Img (Node) & "matching Span", S (1 .. L));
6212 and then Is_In (Subject (P + 1), S (1 .. L))
6225 -- String (two character case)
6228 Dout (Img (Node) & "matching " & Image (Node.Str2));
6230 if (Length - Cursor) >= 2
6231 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
6233 Cursor := Cursor + 2;
6239 -- String (three character case)
6242 Dout (Img (Node) & "matching " & Image (Node.Str3));
6244 if (Length - Cursor) >= 3
6245 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
6247 Cursor := Cursor + 3;
6253 -- String (four character case)
6256 Dout (Img (Node) & "matching " & Image (Node.Str4));
6258 if (Length - Cursor) >= 4
6259 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
6261 Cursor := Cursor + 4;
6267 -- String (five character case)
6270 Dout (Img (Node) & "matching " & Image (Node.Str5));
6272 if (Length - Cursor) >= 5
6273 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
6275 Cursor := Cursor + 5;
6281 -- String (six character case)
6284 Dout (Img (Node) & "matching " & Image (Node.Str6));
6286 if (Length - Cursor) >= 6
6287 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
6289 Cursor := Cursor + 6;
6295 -- String (case of more than six characters)
6297 when PC_String => declare
6298 Len : constant Natural := Node.Str'Length;
6301 Dout (Img (Node) & "matching " & Image (Node.Str.all));
6303 if (Length - Cursor) >= Len
6304 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
6306 Cursor := Cursor + Len;
6313 -- String (function case)
6315 when PC_String_VF => declare
6316 U : constant VString := Node.VF.all;
6321 Get_String (U, S, L);
6322 Dout (Img (Node) & "matching " & Image (S (1 .. L)));
6324 if (Length - Cursor) >= L
6325 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6327 Cursor := Cursor + L;
6334 -- String (vstring pointer case)
6336 when PC_String_VP => declare
6337 U : constant VString := Node.VP.all;
6342 Get_String (U, S, L);
6343 Dout (Img (Node) & "matching " & Image (S (1 .. L)));
6345 if (Length - Cursor) >= L
6346 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6348 Cursor := Cursor + L;
6358 Dout (Img (Node) & "matching Succeed");
6362 -- Tab (integer case)
6365 Dout (Img (Node) & "matching Tab", Node.Nat);
6367 if Cursor <= Node.Nat then
6374 -- Tab (integer function case)
6376 when PC_Tab_NF => declare
6377 N : constant Natural := Node.NF.all;
6380 Dout (Img (Node) & "matching Tab ", N);
6390 -- Tab (integer pointer case)
6393 Dout (Img (Node) & "matching Tab ", Node.NP.all);
6395 if Cursor <= Node.NP.all then
6396 Cursor := Node.NP.all;
6402 -- Unanchored movement
6404 when PC_Unanchored =>
6405 Dout ("attempting to move anchor point");
6407 -- All done if we tried every position
6409 if Cursor > Length then
6412 -- Otherwise extend the anchor point, and restack ourself
6415 Cursor := Cursor + 1;
6420 -- Write immediate. This node performs the actual write
6422 when PC_Write_Imm =>
6423 Dout (Img (Node) & "executing immediate write of " &
6424 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6428 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6432 -- Write on match. This node sets up for the eventual write
6434 when PC_Write_OnM =>
6435 Dout (Img (Node) & "registering deferred write");
6436 Stack (Stack_Base - 1).Node := Node;
6437 Push (CP_Assign'Access);
6444 -- We are NOT allowed to fall though this case statement, since every
6445 -- match routine must end by executing a goto to the appropriate point
6446 -- in the finite state machine model.
6448 pragma Warnings (Off);
6450 pragma Warnings (On);
6453 end GNAT.Spitbol.Patterns;
OSDN Git Service
