fixing pr42337
[official-gcc.git] / gcc / ada / g-spipat.adb
blobc5c07f105e2c84cd0305f9c90d5b0b6dd05b08ee
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- G N A T . S P I T B O L . P A T T E R N S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2008, AdaCore --
10 -- --
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. --
21 -- --
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. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
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.
58 procedure New_LineD;
59 pragma Inline (New_LineD);
60 -- Output new blank line with New_Line if Internal_Debug is True
62 procedure PutD (Str : String);
63 pragma Inline (PutD);
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 -- +------------------------------------+
96 -- I Pcode I
97 -- +------------------------------------+
98 -- I Index I
99 -- +------------------------------------+
100 -- I Pthen I
101 -- +------------------------------------+
102 -- I parameter(s) I
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 (
122 PC_Arb_Y,
123 PC_Assign,
124 PC_Bal,
125 PC_BreakX_X,
126 PC_Cancel,
127 PC_EOP,
128 PC_Fail,
129 PC_Fence,
130 PC_Fence_X,
131 PC_Fence_Y,
132 PC_R_Enter,
133 PC_R_Remove,
134 PC_R_Restore,
135 PC_Rest,
136 PC_Succeed,
137 PC_Unanchored,
139 PC_Alt,
140 PC_Arb_X,
141 PC_Arbno_S,
142 PC_Arbno_X,
144 PC_Rpat,
146 PC_Pred_Func,
148 PC_Assign_Imm,
149 PC_Assign_OnM,
150 PC_Any_VP,
151 PC_Break_VP,
152 PC_BreakX_VP,
153 PC_NotAny_VP,
154 PC_NSpan_VP,
155 PC_Span_VP,
156 PC_String_VP,
158 PC_Write_Imm,
159 PC_Write_OnM,
161 PC_Null,
162 PC_String,
164 PC_String_2,
165 PC_String_3,
166 PC_String_4,
167 PC_String_5,
168 PC_String_6,
170 PC_Setcur,
172 PC_Any_CH,
173 PC_Break_CH,
174 PC_BreakX_CH,
175 PC_Char,
176 PC_NotAny_CH,
177 PC_NSpan_CH,
178 PC_Span_CH,
180 PC_Any_CS,
181 PC_Break_CS,
182 PC_BreakX_CS,
183 PC_NotAny_CS,
184 PC_NSpan_CS,
185 PC_Span_CS,
187 PC_Arbno_Y,
188 PC_Len_Nat,
189 PC_Pos_Nat,
190 PC_RPos_Nat,
191 PC_RTab_Nat,
192 PC_Tab_Nat,
194 PC_Pos_NF,
195 PC_Len_NF,
196 PC_RPos_NF,
197 PC_RTab_NF,
198 PC_Tab_NF,
200 PC_Pos_NP,
201 PC_Len_NP,
202 PC_RPos_NP,
203 PC_RTab_NP,
204 PC_Tab_NP,
206 PC_Any_VF,
207 PC_Break_VF,
208 PC_BreakX_VF,
209 PC_NotAny_VF,
210 PC_NSpan_VF,
211 PC_Span_VF,
212 PC_String_VF);
214 type IndexT is range 0 .. +(2 **15 - 1);
216 type PE (Pcode : Pattern_Code) is record
218 Index : IndexT;
219 -- Serial index number of pattern element within pattern
221 Pthen : PE_Ptr;
222 -- Successor element, to be matched after this one
224 case Pcode is
226 when PC_Arb_Y |
227 PC_Assign |
228 PC_Bal |
229 PC_BreakX_X |
230 PC_Cancel |
231 PC_EOP |
232 PC_Fail |
233 PC_Fence |
234 PC_Fence_X |
235 PC_Fence_Y |
236 PC_Null |
237 PC_R_Enter |
238 PC_R_Remove |
239 PC_R_Restore |
240 PC_Rest |
241 PC_Succeed |
242 PC_Unanchored => null;
244 when PC_Alt |
245 PC_Arb_X |
246 PC_Arbno_S |
247 PC_Arbno_X => Alt : PE_Ptr;
249 when PC_Rpat => PP : Pattern_Ptr;
251 when PC_Pred_Func => BF : Boolean_Func;
253 when PC_Assign_Imm |
254 PC_Assign_OnM |
255 PC_Any_VP |
256 PC_Break_VP |
257 PC_BreakX_VP |
258 PC_NotAny_VP |
259 PC_NSpan_VP |
260 PC_Span_VP |
261 PC_String_VP => VP : VString_Ptr;
263 when PC_Write_Imm |
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;
280 when PC_Any_CH |
281 PC_Break_CH |
282 PC_BreakX_CH |
283 PC_Char |
284 PC_NotAny_CH |
285 PC_NSpan_CH |
286 PC_Span_CH => Char : Character;
288 when PC_Any_CS |
289 PC_Break_CS |
290 PC_BreakX_CS |
291 PC_NotAny_CS |
292 PC_NSpan_CS |
293 PC_Span_CS => CS : Character_Set;
295 when PC_Arbno_Y |
296 PC_Len_Nat |
297 PC_Pos_Nat |
298 PC_RPos_Nat |
299 PC_RTab_Nat |
300 PC_Tab_Nat => Nat : Natural;
302 when PC_Pos_NF |
303 PC_Len_NF |
304 PC_RPos_NF |
305 PC_RTab_NF |
306 PC_Tab_NF => NF : Natural_Func;
308 when PC_Pos_NP |
309 PC_Len_NP |
310 PC_RPos_NP |
311 PC_RTab_NP |
312 PC_Tab_NP => NP : Natural_Ptr;
314 when PC_Any_VF |
315 PC_Break_VF |
316 PC_BreakX_VF |
317 PC_NotAny_VF |
318 PC_NSpan_VF |
319 PC_Span_VF |
320 PC_String_VF => VF : VString_Func;
322 end case;
323 end record;
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 :=
345 (PC_Any_CS |
346 PC_Any_CH |
347 PC_Any_VF |
348 PC_Any_VP |
349 PC_Char |
350 PC_Len_Nat |
351 PC_NotAny_CS |
352 PC_NotAny_CH |
353 PC_NotAny_VF |
354 PC_NotAny_VP |
355 PC_Span_CS |
356 PC_Span_CH |
357 PC_Span_VF |
358 PC_Span_VP |
359 PC_String |
360 PC_String_2 |
361 PC_String_3 |
362 PC_String_4 |
363 PC_String_5 |
364 PC_String_6 => True,
365 others => False);
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
382 Cursor : Integer;
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.
389 Node : PE_Ptr;
390 -- This pattern element reference is reestablished as the current
391 -- Node to be matched (which will attempt an appropriate rematch).
393 end record;
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
427 -- this purpose.
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
463 -- maximum element,
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.
598 -------------------
599 -- Concatenation --
600 -------------------
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).
626 -----------------
627 -- Alternation --
628 -----------------
630 -- A pattern (L or R) constructs the structure:
632 -- +---+ +---+
633 -- | A |---->| L |---->
634 -- +---+ +---+
635 -- .
636 -- .
637 -- +---+
638 -- | R |---->
639 -- +---+
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
667 -- for the pattern:
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 +---+ +---+
676 -- . I .
677 -- . I .
678 -- +---+ +---+ I +---+
679 -- I A I---->I W I-->I I Z I---->
680 -- +---+ +---+ I +---+
681 -- . I
682 -- . I
683 -- +---+ I
684 -- I X I------------>+
685 -- +---+
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 +---+ +---+
692 -- . I .
693 -- . I .
694 -- +---+ +---+ I +---+
695 -- I 6 I---->I 5 I-->I I 1 I---->
696 -- +---+ +---+ I +---+
697 -- . I
698 -- . I
699 -- +---+ I
700 -- I 4 I------------>+
701 -- +---+
703 -- Note: The above structure actually corresponds to
705 -- (A or (B or C)) (D or E)
707 -- rather than
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.
716 ---------
717 -- Arb --
718 ---------
720 -- An Arb pattern builds the structure
722 -- +---+
723 -- | X |---->
724 -- +---+
725 -- .
726 -- .
727 -- +---+
728 -- | Y |---->
729 -- +---+
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:
746 -- +-------------+
747 -- | ^
748 -- V |
749 -- +---+ |
750 -- | S |----> |
751 -- +---+ |
752 -- . |
753 -- . |
754 -- +---+ |
755 -- | P |---------->+
756 -- +---+
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 -- +--------------------------+
775 -- | ^
776 -- V |
777 -- +---+ |
778 -- | X |----> |
779 -- +---+ |
780 -- . |
781 -- . |
782 -- +---+ +---+ +---+ |
783 -- | E |---->| P |---->| Y |--->+
784 -- +---+ +---+ +---+
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
798 -- looks like:
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
863 -- +---+ +---+ +---+
864 -- | E |---->| P |---->| A |---->
865 -- +---+ +---+ +---+
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
876 -- looks like:
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
917 -- of the pattern P.
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:
931 -- +---+ +---+ +---+
932 -- | E |---->| P |---->| A |---->
933 -- +---+ +---+ +---+
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
941 -- described below.
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.
988 ---------
989 -- Bal --
990 ---------
992 -- Bal builds a single node:
994 -- +---+
995 -- | B |---->
996 -- +---+
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).
1007 ------------
1008 -- BreakX --
1009 ------------
1011 -- BreakX builds the structure
1013 -- +---+ +---+
1014 -- | B |---->| A |---->
1015 -- +---+ +---+
1016 -- ^ .
1017 -- | .
1018 -- | +---+
1019 -- +<------| X |
1020 -- +---+
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
1029 -- node is 2.
1031 -----------
1032 -- Fence --
1033 -----------
1035 -- Fence builds a single node:
1037 -- +---+
1038 -- | F |---->
1039 -- +---+
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
1067 -- looks like:
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.
1115 -------------
1116 -- Succeed --
1117 -------------
1119 -- Succeed builds a single node:
1121 -- +---+
1122 -- | S |---->
1123 -- +---+
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.
1270 procedure XMatch
1271 (Subject : String;
1272 Pat_P : PE_Ptr;
1273 Pat_S : Natural;
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.
1300 procedure XMatchD
1301 (Subject : String;
1302 Pat_P : PE_Ptr;
1303 Pat_S : Natural;
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.
1310 ---------
1311 -- "&" --
1312 ---------
1314 function "&" (L : PString; R : Pattern) return Pattern is
1315 begin
1316 return (AFC with R.Stk, Concat (S_To_PE (L), Copy (R.P), R.Stk));
1317 end "&";
1319 function "&" (L : Pattern; R : PString) return Pattern is
1320 begin
1321 return (AFC with L.Stk, Concat (Copy (L.P), S_To_PE (R), 0));
1322 end "&";
1324 function "&" (L : PChar; R : Pattern) return Pattern is
1325 begin
1326 return (AFC with R.Stk, Concat (C_To_PE (L), Copy (R.P), R.Stk));
1327 end "&";
1329 function "&" (L : Pattern; R : PChar) return Pattern is
1330 begin
1331 return (AFC with L.Stk, Concat (Copy (L.P), C_To_PE (R), 0));
1332 end "&";
1334 function "&" (L : Pattern; R : Pattern) return Pattern is
1335 begin
1336 return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk));
1337 end "&";
1339 ---------
1340 -- "*" --
1341 ---------
1343 -- Assign immediate
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);
1358 begin
1359 return (AFC with P.Stk + 3, Bracket (E, Pat, A));
1360 end "*";
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);
1367 begin
1368 return (AFC with 3, Bracket (E, Pat, A));
1369 end "*";
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);
1376 begin
1377 return (AFC with 3, Bracket (E, Pat, A));
1378 end "*";
1380 -- Write immediate
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);
1394 begin
1395 return (AFC with 3, Bracket (E, Pat, W));
1396 end "*";
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);
1402 begin
1403 return (AFC with 3, Bracket (E, Pat, W));
1404 end "*";
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);
1410 begin
1411 return (AFC with 3, Bracket (E, Pat, W));
1412 end "*";
1414 ----------
1415 -- "**" --
1416 ----------
1418 -- Assign on match
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);
1433 begin
1434 return (AFC with P.Stk + 3, Bracket (E, Pat, A));
1435 end "**";
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);
1442 begin
1443 return (AFC with 3, Bracket (E, Pat, A));
1444 end "**";
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);
1451 begin
1452 return (AFC with 3, Bracket (E, Pat, A));
1453 end "**";
1455 -- Write on match
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);
1469 begin
1470 return (AFC with P.Stk + 3, Bracket (E, Pat, W));
1471 end "**";
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);
1477 begin
1478 return (AFC with 3, Bracket (E, Pat, W));
1479 end "**";
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);
1485 begin
1486 return (AFC with 3, Bracket (E, Pat, W));
1487 end "**";
1489 ---------
1490 -- "+" --
1491 ---------
1493 function "+" (Str : VString_Var) return Pattern is
1494 begin
1495 return
1496 (AFC with 0,
1497 new PE'(PC_String_VP, 1, EOP, Str'Unrestricted_Access));
1498 end "+";
1500 function "+" (Str : VString_Func) return Pattern is
1501 begin
1502 return (AFC with 0, new PE'(PC_String_VF, 1, EOP, Str));
1503 end "+";
1505 function "+" (P : Pattern_Var) return Pattern is
1506 begin
1507 return
1508 (AFC with 3,
1509 new PE'(PC_Rpat, 1, EOP, P'Unrestricted_Access));
1510 end "+";
1512 function "+" (P : Boolean_Func) return Pattern is
1513 begin
1514 return (AFC with 3, new PE'(PC_Pred_Func, 1, EOP, P));
1515 end "+";
1517 ----------
1518 -- "or" --
1519 ----------
1521 function "or" (L : PString; R : Pattern) return Pattern is
1522 begin
1523 return (AFC with R.Stk + 1, S_To_PE (L) or Copy (R.P));
1524 end "or";
1526 function "or" (L : Pattern; R : PString) return Pattern is
1527 begin
1528 return (AFC with L.Stk + 1, Copy (L.P) or S_To_PE (R));
1529 end "or";
1531 function "or" (L : PString; R : PString) return Pattern is
1532 begin
1533 return (AFC with 1, S_To_PE (L) or S_To_PE (R));
1534 end "or";
1536 function "or" (L : Pattern; R : Pattern) return Pattern is
1537 begin
1538 return (AFC with
1539 Natural'Max (L.Stk, R.Stk) + 1, Copy (L.P) or Copy (R.P));
1540 end "or";
1542 function "or" (L : PChar; R : Pattern) return Pattern is
1543 begin
1544 return (AFC with 1, C_To_PE (L) or Copy (R.P));
1545 end "or";
1547 function "or" (L : Pattern; R : PChar) return Pattern is
1548 begin
1549 return (AFC with 1, Copy (L.P) or C_To_PE (R));
1550 end "or";
1552 function "or" (L : PChar; R : PChar) return Pattern is
1553 begin
1554 return (AFC with 1, C_To_PE (L) or C_To_PE (R));
1555 end "or";
1557 function "or" (L : PString; R : PChar) return Pattern is
1558 begin
1559 return (AFC with 1, S_To_PE (L) or C_To_PE (R));
1560 end "or";
1562 function "or" (L : PChar; R : PString) return Pattern is
1563 begin
1564 return (AFC with 1, C_To_PE (L) or S_To_PE (R));
1565 end "or";
1567 ------------
1568 -- Adjust --
1569 ------------
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
1576 begin
1577 Object.P := Copy (Object.P);
1578 end Adjust;
1580 ---------------
1581 -- Alternate --
1582 ---------------
1584 function Alternate (L, R : PE_Ptr) return PE_Ptr is
1585 begin
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.
1589 if L = EOP then
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.
1596 else
1597 declare
1598 Refs : Ref_Array (1 .. L.Index);
1600 begin
1601 Build_Ref_Array (L, Refs);
1603 for J in Refs'Range loop
1604 Refs (J).Index := Refs (J).Index + R.Index;
1605 end loop;
1606 end;
1608 return new PE'(PC_Alt, L.Index + 1, L, R);
1609 end if;
1610 end Alternate;
1612 ---------
1613 -- Any --
1614 ---------
1616 function Any (Str : String) return Pattern is
1617 begin
1618 return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, To_Set (Str)));
1619 end Any;
1621 function Any (Str : VString) return Pattern is
1622 begin
1623 return Any (S (Str));
1624 end Any;
1626 function Any (Str : Character) return Pattern is
1627 begin
1628 return (AFC with 0, new PE'(PC_Any_CH, 1, EOP, Str));
1629 end Any;
1631 function Any (Str : Character_Set) return Pattern is
1632 begin
1633 return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, Str));
1634 end Any;
1636 function Any (Str : not null access VString) return Pattern is
1637 begin
1638 return (AFC with 0, new PE'(PC_Any_VP, 1, EOP, VString_Ptr (Str)));
1639 end Any;
1641 function Any (Str : VString_Func) return Pattern is
1642 begin
1643 return (AFC with 0, new PE'(PC_Any_VF, 1, EOP, Str));
1644 end Any;
1646 ---------
1647 -- Arb --
1648 ---------
1650 -- +---+
1651 -- | X |---->
1652 -- +---+
1653 -- .
1654 -- .
1655 -- +---+
1656 -- | Y |---->
1657 -- +---+
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);
1664 begin
1665 return (AFC with 1, X);
1666 end Arb;
1668 -----------
1669 -- Arbno --
1670 -----------
1672 function Arbno (P : PString) return Pattern is
1673 begin
1674 if P'Length = 0 then
1675 return (AFC with 0, EOP);
1676 else
1677 return (AFC with 0, Arbno_Simple (S_To_PE (P)));
1678 end if;
1679 end Arbno;
1681 function Arbno (P : PChar) return Pattern is
1682 begin
1683 return (AFC with 0, Arbno_Simple (C_To_PE (P)));
1684 end Arbno;
1686 function Arbno (P : Pattern) return Pattern is
1687 Pat : constant PE_Ptr := Copy (P.P);
1689 begin
1690 if P.Stk = 0
1691 and then OK_For_Simple_Arbno (Pat.Pcode)
1692 then
1693 return (AFC with 0, Arbno_Simple (Pat));
1694 end if;
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 -- +--------------------------+
1701 -- | ^
1702 -- V |
1703 -- +---+ |
1704 -- | X |----> |
1705 -- +---+ |
1706 -- . |
1707 -- . |
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.
1716 declare
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);
1721 begin
1722 X.Alt := EPY;
1723 X.Index := EPY.Index + 1;
1724 return (AFC with P.Stk + 3, X);
1725 end;
1726 end Arbno;
1728 ------------------
1729 -- Arbno_Simple --
1730 ------------------
1732 -- +-------------+
1733 -- | ^
1734 -- V |
1735 -- +---+ |
1736 -- | S |----> |
1737 -- +---+ |
1738 -- . |
1739 -- . |
1740 -- +---+ |
1741 -- | P |---------->+
1742 -- +---+
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);
1752 begin
1753 Set_Successor (P, S);
1754 return S;
1755 end Arbno_Simple;
1757 ---------
1758 -- Bal --
1759 ---------
1761 function Bal return Pattern is
1762 begin
1763 return (AFC with 1, new PE'(PC_Bal, 1, EOP));
1764 end Bal;
1766 -------------
1767 -- Bracket --
1768 -------------
1770 function Bracket (E, P, A : PE_Ptr) return PE_Ptr is
1771 begin
1772 if P = EOP then
1773 E.Pthen := A;
1774 E.Index := 2;
1775 A.Index := 1;
1777 else
1778 E.Pthen := P;
1779 Set_Successor (P, A);
1780 E.Index := P.Index + 2;
1781 A.Index := P.Index + 1;
1782 end if;
1784 return E;
1785 end Bracket;
1787 -----------
1788 -- Break --
1789 -----------
1791 function Break (Str : String) return Pattern is
1792 begin
1793 return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, To_Set (Str)));
1794 end Break;
1796 function Break (Str : VString) return Pattern is
1797 begin
1798 return Break (S (Str));
1799 end Break;
1801 function Break (Str : Character) return Pattern is
1802 begin
1803 return (AFC with 0, new PE'(PC_Break_CH, 1, EOP, Str));
1804 end Break;
1806 function Break (Str : Character_Set) return Pattern is
1807 begin
1808 return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, Str));
1809 end Break;
1811 function Break (Str : not null access VString) return Pattern is
1812 begin
1813 return (AFC with 0,
1814 new PE'(PC_Break_VP, 1, EOP, Str.all'Unchecked_Access));
1815 end Break;
1817 function Break (Str : VString_Func) return Pattern is
1818 begin
1819 return (AFC with 0, new PE'(PC_Break_VF, 1, EOP, Str));
1820 end Break;
1822 ------------
1823 -- BreakX --
1824 ------------
1826 function BreakX (Str : String) return Pattern is
1827 begin
1828 return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, To_Set (Str)));
1829 end BreakX;
1831 function BreakX (Str : VString) return Pattern is
1832 begin
1833 return BreakX (S (Str));
1834 end BreakX;
1836 function BreakX (Str : Character) return Pattern is
1837 begin
1838 return BreakX_Make (new PE'(PC_BreakX_CH, 3, N, Str));
1839 end BreakX;
1841 function BreakX (Str : Character_Set) return Pattern is
1842 begin
1843 return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, Str));
1844 end BreakX;
1846 function BreakX (Str : not null access VString) return Pattern is
1847 begin
1848 return BreakX_Make (new PE'(PC_BreakX_VP, 3, N, VString_Ptr (Str)));
1849 end BreakX;
1851 function BreakX (Str : VString_Func) return Pattern is
1852 begin
1853 return BreakX_Make (new PE'(PC_BreakX_VF, 3, N, Str));
1854 end BreakX;
1856 -----------------
1857 -- BreakX_Make --
1858 -----------------
1860 -- +---+ +---+
1861 -- | B |---->| A |---->
1862 -- +---+ +---+
1863 -- ^ .
1864 -- | .
1865 -- | +---+
1866 -- +<------| X |
1867 -- +---+
1869 -- The B node is numbered 3, the alternative node is 1, and the X
1870 -- node is 2.
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);
1875 begin
1876 B.Pthen := A;
1877 return (AFC with 2, B);
1878 end BreakX_Make;
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.
1890 ---------------
1891 -- Record_PE --
1892 ---------------
1894 procedure Record_PE (E : PE_Ptr) is
1895 begin
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");
1900 return;
1902 else
1903 Put_LineD (", recording" & IndexT'Image (E.Index));
1904 RA (E.Index) := E;
1905 Record_PE (E.Pthen);
1907 if E.Pcode in PC_Has_Alt then
1908 Record_PE (E.Alt);
1909 end if;
1910 end if;
1911 end Record_PE;
1913 -- Start of processing for Build_Ref_Array
1915 begin
1916 New_LineD;
1917 Put_LineD ("Entering Build_Ref_Array");
1918 Record_PE (E);
1919 New_LineD;
1920 end Build_Ref_Array;
1922 -------------
1923 -- C_To_PE --
1924 -------------
1926 function C_To_PE (C : PChar) return PE_Ptr is
1927 begin
1928 return new PE'(PC_Char, 1, EOP, C);
1929 end C_To_PE;
1931 ------------
1932 -- Cancel --
1933 ------------
1935 function Cancel return Pattern is
1936 begin
1937 return (AFC with 0, new PE'(PC_Cancel, 1, EOP));
1938 end Cancel;
1940 ------------
1941 -- Concat --
1942 ------------
1944 -- Concat needs to traverse the left operand performing the following
1945 -- set of fixups:
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
1961 begin
1962 if L = EOP then
1963 return R;
1965 elsif R = EOP then
1966 return L;
1968 else
1969 declare
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.
1974 P : PE_Ptr;
1976 begin
1977 Build_Ref_Array (L, Refs);
1979 for J in Refs'Range loop
1980 P := Refs (J);
1982 P.Index := P.Index + R.Index;
1984 if P.Pcode = PC_Arbno_Y then
1985 P.Nat := P.Nat + Incr;
1986 end if;
1988 if P.Pthen = EOP then
1989 P.Pthen := R;
1990 end if;
1992 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
1993 P.Alt := R;
1994 end if;
1995 end loop;
1996 end;
1998 return L;
1999 end if;
2000 end Concat;
2002 ----------
2003 -- Copy --
2004 ----------
2006 function Copy (P : PE_Ptr) return PE_Ptr is
2007 begin
2008 if P = null then
2009 Uninitialized_Pattern;
2011 else
2012 declare
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
2019 E : PE_Ptr;
2021 begin
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);
2028 end loop;
2030 -- Adjust all internal references
2032 for J in Copy'Range loop
2033 E := Copy (J);
2035 -- Adjust successor pointer to point to copy
2037 if E.Pthen /= EOP then
2038 E.Pthen := Copy (E.Pthen.Index);
2039 end if;
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);
2045 end if;
2047 -- Copy referenced string
2049 if E.Pcode = PC_String then
2050 E.Str := new String'(E.Str.all);
2051 end if;
2052 end loop;
2054 return Copy (P.Index);
2055 end;
2056 end if;
2057 end Copy;
2059 ----------
2060 -- Dump --
2061 ----------
2063 procedure Dump (P : Pattern) is
2065 subtype Count is Ada.Text_IO.Count;
2066 Scol : 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
2076 E : PE_Ptr;
2078 procedure Write_Node_Id (E : PE_Ptr);
2079 -- Writes out a string identifying the given pattern element
2081 -------------------
2082 -- Write_Node_Id --
2083 -------------------
2085 procedure Write_Node_Id (E : PE_Ptr) is
2086 begin
2087 if E = EOP then
2088 Put ("EOP");
2090 for J in 4 .. Cols loop
2091 Put (' ');
2092 end loop;
2094 else
2095 declare
2096 Str : String (1 .. Cols);
2097 N : Natural := Natural (E.Index);
2099 begin
2100 Put ("#");
2102 for J in reverse Str'Range loop
2103 Str (J) := Character'Val (48 + N mod 10);
2104 N := N / 10;
2105 end loop;
2107 Put (Str);
2108 end;
2109 end if;
2110 end Write_Node_Id;
2112 -- Start of processing for Dump
2114 begin
2115 New_Line;
2116 Put ("Pattern Dump Output (pattern at " &
2117 Image (P'Address) &
2118 ", S = " & Natural'Image (P.Stk) & ')');
2120 Scol := Col;
2121 New_Line;
2123 while Col < Scol loop
2124 Put ('-');
2125 end loop;
2127 New_Line;
2129 -- If uninitialized pattern, dump line and we are done
2131 if P.P = null then
2132 Put_Line ("Uninitialized pattern value");
2133 return;
2134 end if;
2136 -- If null pattern, just dump it and we are all done
2138 if P.P = EOP then
2139 Put_Line ("EOP (null pattern)");
2140 return;
2141 end if;
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
2148 Cols := Cols + 1;
2149 end 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
2156 E := Refs (J);
2157 Write_Node_Id (E);
2158 Set_Col (Count (Cols) + 4);
2159 Put (Image (E));
2160 Put (" ");
2161 Put (Pattern_Code'Image (E.Pcode));
2162 Put (" ");
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);
2167 case E.Pcode is
2169 when PC_Alt |
2170 PC_Arb_X |
2171 PC_Arbno_S |
2172 PC_Arbno_X =>
2173 Write_Node_Id (E.Alt);
2175 when PC_Rpat =>
2176 Put (Str_PP (E.PP));
2178 when PC_Pred_Func =>
2179 Put (Str_BF (E.BF));
2181 when PC_Assign_Imm |
2182 PC_Assign_OnM |
2183 PC_Any_VP |
2184 PC_Break_VP |
2185 PC_BreakX_VP |
2186 PC_NotAny_VP |
2187 PC_NSpan_VP |
2188 PC_Span_VP |
2189 PC_String_VP =>
2190 Put (Str_VP (E.VP));
2192 when PC_Write_Imm |
2193 PC_Write_OnM =>
2194 Put (Str_FP (E.FP));
2196 when PC_String =>
2197 Put (Image (E.Str.all));
2199 when PC_String_2 =>
2200 Put (Image (E.Str2));
2202 when PC_String_3 =>
2203 Put (Image (E.Str3));
2205 when PC_String_4 =>
2206 Put (Image (E.Str4));
2208 when PC_String_5 =>
2209 Put (Image (E.Str5));
2211 when PC_String_6 =>
2212 Put (Image (E.Str6));
2214 when PC_Setcur =>
2215 Put (Str_NP (E.Var));
2217 when PC_Any_CH |
2218 PC_Break_CH |
2219 PC_BreakX_CH |
2220 PC_Char |
2221 PC_NotAny_CH |
2222 PC_NSpan_CH |
2223 PC_Span_CH =>
2224 Put (''' & E.Char & ''');
2226 when PC_Any_CS |
2227 PC_Break_CS |
2228 PC_BreakX_CS |
2229 PC_NotAny_CS |
2230 PC_NSpan_CS |
2231 PC_Span_CS =>
2232 Put ('"' & To_Sequence (E.CS) & '"');
2234 when PC_Arbno_Y |
2235 PC_Len_Nat |
2236 PC_Pos_Nat |
2237 PC_RPos_Nat |
2238 PC_RTab_Nat |
2239 PC_Tab_Nat =>
2240 Put (S (E.Nat));
2242 when PC_Pos_NF |
2243 PC_Len_NF |
2244 PC_RPos_NF |
2245 PC_RTab_NF |
2246 PC_Tab_NF =>
2247 Put (Str_NF (E.NF));
2249 when PC_Pos_NP |
2250 PC_Len_NP |
2251 PC_RPos_NP |
2252 PC_RTab_NP |
2253 PC_Tab_NP =>
2254 Put (Str_NP (E.NP));
2256 when PC_Any_VF |
2257 PC_Break_VF |
2258 PC_BreakX_VF |
2259 PC_NotAny_VF |
2260 PC_NSpan_VF |
2261 PC_Span_VF |
2262 PC_String_VF =>
2263 Put (Str_VF (E.VF));
2265 when others => null;
2267 end case;
2269 New_Line;
2270 end loop;
2272 New_Line;
2273 end Dump;
2275 ----------
2276 -- Fail --
2277 ----------
2279 function Fail return Pattern is
2280 begin
2281 return (AFC with 0, new PE'(PC_Fail, 1, EOP));
2282 end Fail;
2284 -----------
2285 -- Fence --
2286 -----------
2288 -- Simple case
2290 function Fence return Pattern is
2291 begin
2292 return (AFC with 1, new PE'(PC_Fence, 1, EOP));
2293 end Fence;
2295 -- Function case
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);
2309 begin
2310 return (AFC with P.Stk + 1, Bracket (E, Pat, X));
2311 end Fence;
2313 --------------
2314 -- Finalize --
2315 --------------
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);
2322 begin
2323 -- Nothing to do if already freed
2325 if Object.P = null then
2326 return;
2328 -- Otherwise we must free all elements
2330 else
2331 declare
2332 Refs : Ref_Array (1 .. Object.P.Index);
2333 -- References to elements in pattern to be finalized
2335 begin
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);
2341 end if;
2343 Free (Refs (J));
2344 end loop;
2346 Object.P := null;
2347 end;
2348 end if;
2349 end Finalize;
2351 -----------
2352 -- Image --
2353 -----------
2355 function Image (P : PE_Ptr) return String is
2356 begin
2357 return Image (To_Address (P));
2358 end Image;
2360 function Image (P : Pattern) return String is
2361 begin
2362 return S (Image (P));
2363 end Image;
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);
2397 begin
2398 if L > 2 then
2399 Delete (Result, L - 1, L);
2400 end if;
2401 end Delete_Ampersand;
2403 ---------------
2404 -- Image_One --
2405 ---------------
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
2412 begin
2413 case E.Pcode is
2415 when PC_Cancel =>
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
2426 E1 : PE_Ptr;
2428 begin
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.
2433 while ER /= EOP
2434 and then ER.Index >= Lowest_In_L
2435 and then ER.Index < E.Index
2436 loop
2437 ER := ER.Pthen;
2438 end loop;
2440 Append (Result, '(');
2442 E1 := E;
2443 loop
2444 Image_Seq (E1.Pthen, ER, False);
2445 Append (Result, " or ");
2446 E1 := E1.Alt;
2447 exit when E1.Pcode /= PC_Alt;
2448 end loop;
2450 Image_Seq (E1, ER, False);
2451 Append (Result, ')');
2452 end Alt;
2454 when PC_Any_CS =>
2455 Append (Result, "Any (" & Image (To_Sequence (E.CS)) & ')');
2457 when PC_Any_VF =>
2458 Append (Result, "Any (" & Str_VF (E.VF) & ')');
2460 when PC_Any_VP =>
2461 Append (Result, "Any (" & Str_VP (E.VP) & ')');
2463 when PC_Arb_X =>
2464 Append (Result, "Arb");
2466 when PC_Arbno_S =>
2467 Append (Result, "Arbno (");
2468 Image_Seq (E.Alt, E, False);
2469 Append (Result, ')');
2471 when PC_Arbno_X =>
2472 Append (Result, "Arbno (");
2473 Image_Seq (E.Alt.Pthen, Refs (E.Index - 2), False);
2474 Append (Result, ')');
2476 when PC_Assign_Imm =>
2477 Delete_Ampersand;
2478 Append (Result, "* " & Str_VP (Refs (E.Index).VP));
2480 when PC_Assign_OnM =>
2481 Delete_Ampersand;
2482 Append (Result, "** " & Str_VP (Refs (E.Index).VP));
2484 when PC_Any_CH =>
2485 Append (Result, "Any ('" & E.Char & "')");
2487 when PC_Bal =>
2488 Append (Result, "Bal");
2490 when PC_Break_CH =>
2491 Append (Result, "Break ('" & E.Char & "')");
2493 when PC_Break_CS =>
2494 Append (Result, "Break (" & Image (To_Sequence (E.CS)) & ')');
2496 when PC_Break_VF =>
2497 Append (Result, "Break (" & Str_VF (E.VF) & ')');
2499 when PC_Break_VP =>
2500 Append (Result, "Break (" & Str_VP (E.VP) & ')');
2502 when PC_BreakX_CH =>
2503 Append (Result, "BreakX ('" & E.Char & "')");
2504 ER := ER.Pthen;
2506 when PC_BreakX_CS =>
2507 Append (Result, "BreakX (" & Image (To_Sequence (E.CS)) & ')');
2508 ER := ER.Pthen;
2510 when PC_BreakX_VF =>
2511 Append (Result, "BreakX (" & Str_VF (E.VF) & ')');
2512 ER := ER.Pthen;
2514 when PC_BreakX_VP =>
2515 Append (Result, "BreakX (" & Str_VP (E.VP) & ')');
2516 ER := ER.Pthen;
2518 when PC_Char =>
2519 Append (Result, ''' & E.Char & ''');
2521 when PC_Fail =>
2522 Append (Result, "Fail");
2524 when PC_Fence =>
2525 Append (Result, "Fence");
2527 when PC_Fence_X =>
2528 Append (Result, "Fence (");
2529 Image_Seq (E.Pthen, Refs (E.Index - 1), False);
2530 Append (Result, ")");
2531 ER := Refs (E.Index - 1).Pthen;
2533 when PC_Len_Nat =>
2534 Append (Result, "Len (" & E.Nat & ')');
2536 when PC_Len_NF =>
2537 Append (Result, "Len (" & Str_NF (E.NF) & ')');
2539 when PC_Len_NP =>
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) & ')');
2554 when PC_NSpan_CH =>
2555 Append (Result, "NSpan ('" & E.Char & "')");
2557 when PC_NSpan_CS =>
2558 Append (Result, "NSpan (" & Image (To_Sequence (E.CS)) & ')');
2560 when PC_NSpan_VF =>
2561 Append (Result, "NSpan (" & Str_VF (E.VF) & ')');
2563 when PC_NSpan_VP =>
2564 Append (Result, "NSpan (" & Str_VP (E.VP) & ')');
2566 when PC_Null =>
2567 Append (Result, """""");
2569 when PC_Pos_Nat =>
2570 Append (Result, "Pos (" & E.Nat & ')');
2572 when PC_Pos_NF =>
2573 Append (Result, "Pos (" & Str_NF (E.NF) & ')');
2575 when PC_Pos_NP =>
2576 Append (Result, "Pos (" & Str_NP (E.NP) & ')');
2578 when PC_R_Enter =>
2579 Kill_Ampersand := True;
2581 when PC_Rest =>
2582 Append (Result, "Rest");
2584 when PC_Rpat =>
2585 Append (Result, "(+ " & Str_PP (E.PP) & ')');
2587 when PC_Pred_Func =>
2588 Append (Result, "(+ " & Str_BF (E.BF) & ')');
2590 when PC_RPos_Nat =>
2591 Append (Result, "RPos (" & E.Nat & ')');
2593 when PC_RPos_NF =>
2594 Append (Result, "RPos (" & Str_NF (E.NF) & ')');
2596 when PC_RPos_NP =>
2597 Append (Result, "RPos (" & Str_NP (E.NP) & ')');
2599 when PC_RTab_Nat =>
2600 Append (Result, "RTab (" & E.Nat & ')');
2602 when PC_RTab_NF =>
2603 Append (Result, "RTab (" & Str_NF (E.NF) & ')');
2605 when PC_RTab_NP =>
2606 Append (Result, "RTab (" & Str_NP (E.NP) & ')');
2608 when PC_Setcur =>
2609 Append (Result, "Setcur (" & Str_NP (E.Var) & ')');
2611 when PC_Span_CH =>
2612 Append (Result, "Span ('" & E.Char & "')");
2614 when PC_Span_CS =>
2615 Append (Result, "Span (" & Image (To_Sequence (E.CS)) & ')');
2617 when PC_Span_VF =>
2618 Append (Result, "Span (" & Str_VF (E.VF) & ')');
2620 when PC_Span_VP =>
2621 Append (Result, "Span (" & Str_VP (E.VP) & ')');
2623 when PC_String =>
2624 Append (Result, Image (E.Str.all));
2626 when PC_String_2 =>
2627 Append (Result, Image (E.Str2));
2629 when PC_String_3 =>
2630 Append (Result, Image (E.Str3));
2632 when PC_String_4 =>
2633 Append (Result, Image (E.Str4));
2635 when PC_String_5 =>
2636 Append (Result, Image (E.Str5));
2638 when PC_String_6 =>
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) & ')');
2647 when PC_Succeed =>
2648 Append (Result, "Succeed");
2650 when PC_Tab_Nat =>
2651 Append (Result, "Tab (" & E.Nat & ')');
2653 when PC_Tab_NF =>
2654 Append (Result, "Tab (" & Str_NF (E.NF) & ')');
2656 when PC_Tab_NP =>
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
2673 when PC_Arb_Y |
2674 PC_Arbno_Y |
2675 PC_Assign |
2676 PC_BreakX_X |
2677 PC_EOP |
2678 PC_Fence_Y |
2679 PC_R_Remove |
2680 PC_R_Restore |
2681 PC_Unanchored =>
2682 Append (Result, "???");
2684 end case;
2686 E := ER;
2687 end Image_One;
2689 ---------------
2690 -- Image_Seq --
2691 ---------------
2693 procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is
2694 Indx : constant Natural := Length (Result);
2695 E1 : PE_Ptr := E;
2696 Mult : Boolean := False;
2698 begin
2699 -- The image of EOP is "" (the null string)
2701 if E = EOP then
2702 Append (Result, """""");
2704 -- Else generate appropriate concatenation sequence
2706 else
2707 loop
2708 Image_One (E1);
2709 exit when E1 = Succ;
2710 exit when E1 = EOP;
2711 Mult := True;
2713 if Kill_Ampersand then
2714 Kill_Ampersand := False;
2715 else
2716 Append (Result, " & ");
2717 end if;
2718 end loop;
2719 end if;
2721 if Mult and Paren then
2722 Insert (Result, Indx + 1, "(");
2723 Append (Result, ")");
2724 end if;
2725 end Image_Seq;
2727 -- Start of processing for Image
2729 begin
2730 Build_Ref_Array (P.P, Refs);
2731 Image_Seq (P.P, EOP, False);
2732 return Result;
2733 end Image;
2735 -----------
2736 -- Is_In --
2737 -----------
2739 function Is_In (C : Character; Str : String) return Boolean is
2740 begin
2741 for J in Str'Range loop
2742 if Str (J) = C then
2743 return True;
2744 end if;
2745 end loop;
2747 return False;
2748 end Is_In;
2750 ---------
2751 -- Len --
2752 ---------
2754 function Len (Count : Natural) return Pattern is
2755 begin
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).
2760 if Count = 0 then
2761 return (AFC with 0, new PE'(PC_Null, 1, EOP));
2763 else
2764 return (AFC with 0, new PE'(PC_Len_Nat, 1, EOP, Count));
2765 end if;
2766 end Len;
2768 function Len (Count : Natural_Func) return Pattern is
2769 begin
2770 return (AFC with 0, new PE'(PC_Len_NF, 1, EOP, Count));
2771 end Len;
2773 function Len (Count : not null access Natural) return Pattern is
2774 begin
2775 return (AFC with 0, new PE'(PC_Len_NP, 1, EOP, Natural_Ptr (Count)));
2776 end Len;
2778 -----------------
2779 -- Logic_Error --
2780 -----------------
2782 procedure Logic_Error is
2783 begin
2784 raise Program_Error with
2785 "Internal logic error in GNAT.Spitbol.Patterns";
2786 end Logic_Error;
2788 -----------
2789 -- Match --
2790 -----------
2792 function Match
2793 (Subject : VString;
2794 Pat : Pattern) return Boolean
2796 S : String_Access;
2797 L : Natural;
2799 Start : Natural;
2800 Stop : Natural;
2801 pragma Unreferenced (Stop);
2803 begin
2804 Get_String (Subject, S, L);
2806 if Debug_Mode then
2807 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2808 else
2809 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2810 end if;
2812 return Start /= 0;
2813 end Match;
2815 function Match
2816 (Subject : String;
2817 Pat : Pattern) return Boolean
2819 Start, Stop : Natural;
2820 pragma Unreferenced (Stop);
2822 subtype String1 is String (1 .. Subject'Length);
2824 begin
2825 if Debug_Mode then
2826 XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2827 else
2828 XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2829 end if;
2831 return Start /= 0;
2832 end Match;
2834 function Match
2835 (Subject : VString_Var;
2836 Pat : Pattern;
2837 Replace : VString) return Boolean
2839 Start : Natural;
2840 Stop : Natural;
2841 S : String_Access;
2842 L : Natural;
2844 begin
2845 Get_String (Subject, S, L);
2847 if Debug_Mode then
2848 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2849 else
2850 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2851 end if;
2853 if Start = 0 then
2854 return False;
2855 else
2856 Get_String (Replace, S, L);
2857 Replace_Slice
2858 (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
2859 return True;
2860 end if;
2861 end Match;
2863 function Match
2864 (Subject : VString_Var;
2865 Pat : Pattern;
2866 Replace : String) return Boolean
2868 Start : Natural;
2869 Stop : Natural;
2870 S : String_Access;
2871 L : Natural;
2873 begin
2874 Get_String (Subject, S, L);
2876 if Debug_Mode then
2877 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2878 else
2879 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2880 end if;
2882 if Start = 0 then
2883 return False;
2884 else
2885 Replace_Slice
2886 (Subject'Unrestricted_Access.all, Start, Stop, Replace);
2887 return True;
2888 end if;
2889 end Match;
2891 procedure Match
2892 (Subject : VString;
2893 Pat : Pattern)
2895 S : String_Access;
2896 L : Natural;
2898 Start : Natural;
2899 Stop : Natural;
2900 pragma Unreferenced (Start, Stop);
2902 begin
2903 Get_String (Subject, S, L);
2905 if Debug_Mode then
2906 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2907 else
2908 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2909 end if;
2910 end Match;
2912 procedure Match
2913 (Subject : String;
2914 Pat : Pattern)
2916 Start, Stop : Natural;
2917 pragma Unreferenced (Start, Stop);
2919 subtype String1 is String (1 .. Subject'Length);
2921 begin
2922 if Debug_Mode then
2923 XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2924 else
2925 XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2926 end if;
2927 end Match;
2929 procedure Match
2930 (Subject : in out VString;
2931 Pat : Pattern;
2932 Replace : VString)
2934 Start : Natural;
2935 Stop : Natural;
2936 S : String_Access;
2937 L : Natural;
2939 begin
2940 Get_String (Subject, S, L);
2942 if Debug_Mode then
2943 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2944 else
2945 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2946 end if;
2948 if Start /= 0 then
2949 Get_String (Replace, S, L);
2950 Replace_Slice (Subject, Start, Stop, S (1 .. L));
2951 end if;
2952 end Match;
2954 procedure Match
2955 (Subject : in out VString;
2956 Pat : Pattern;
2957 Replace : String)
2959 Start : Natural;
2960 Stop : Natural;
2961 S : String_Access;
2962 L : Natural;
2964 begin
2965 Get_String (Subject, S, L);
2967 if Debug_Mode then
2968 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2969 else
2970 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2971 end if;
2973 if Start /= 0 then
2974 Replace_Slice (Subject, Start, Stop, Replace);
2975 end if;
2976 end Match;
2978 function Match
2979 (Subject : VString;
2980 Pat : PString) return Boolean
2982 Pat_Len : constant Natural := Pat'Length;
2983 S : String_Access;
2984 L : Natural;
2986 begin
2987 Get_String (Subject, S, L);
2989 if Anchored_Mode then
2990 if Pat_Len > L then
2991 return False;
2992 else
2993 return Pat = S (1 .. Pat_Len);
2994 end if;
2996 else
2997 for J in 1 .. L - Pat_Len + 1 loop
2998 if Pat = S (J .. J + (Pat_Len - 1)) then
2999 return True;
3000 end if;
3001 end loop;
3003 return False;
3004 end if;
3005 end Match;
3007 function Match
3008 (Subject : String;
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;
3015 begin
3016 if Anchored_Mode then
3017 if Pat_Len > Sub_Len then
3018 return False;
3019 else
3020 return Pat = Subject (SFirst .. SFirst + Pat_Len - 1);
3021 end if;
3023 else
3024 for J in SFirst .. SFirst + Sub_Len - Pat_Len loop
3025 if Pat = Subject (J .. J + (Pat_Len - 1)) then
3026 return True;
3027 end if;
3028 end loop;
3030 return False;
3031 end if;
3032 end Match;
3034 function Match
3035 (Subject : VString_Var;
3036 Pat : PString;
3037 Replace : VString) return Boolean
3039 Start : Natural;
3040 Stop : Natural;
3041 S : String_Access;
3042 L : Natural;
3044 begin
3045 Get_String (Subject, S, L);
3047 if Debug_Mode then
3048 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3049 else
3050 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3051 end if;
3053 if Start = 0 then
3054 return False;
3055 else
3056 Get_String (Replace, S, L);
3057 Replace_Slice
3058 (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
3059 return True;
3060 end if;
3061 end Match;
3063 function Match
3064 (Subject : VString_Var;
3065 Pat : PString;
3066 Replace : String) return Boolean
3068 Start : Natural;
3069 Stop : Natural;
3070 S : String_Access;
3071 L : Natural;
3073 begin
3074 Get_String (Subject, S, L);
3076 if Debug_Mode then
3077 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3078 else
3079 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3080 end if;
3082 if Start = 0 then
3083 return False;
3084 else
3085 Replace_Slice
3086 (Subject'Unrestricted_Access.all, Start, Stop, Replace);
3087 return True;
3088 end if;
3089 end Match;
3091 procedure Match
3092 (Subject : VString;
3093 Pat : PString)
3095 S : String_Access;
3096 L : Natural;
3098 Start : Natural;
3099 Stop : Natural;
3100 pragma Unreferenced (Start, Stop);
3102 begin
3103 Get_String (Subject, S, L);
3105 if Debug_Mode then
3106 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3107 else
3108 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3109 end if;
3110 end Match;
3112 procedure Match
3113 (Subject : String;
3114 Pat : PString)
3116 Start, Stop : Natural;
3117 pragma Unreferenced (Start, Stop);
3119 subtype String1 is String (1 .. Subject'Length);
3121 begin
3122 if Debug_Mode then
3123 XMatchD (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
3124 else
3125 XMatch (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
3126 end if;
3127 end Match;
3129 procedure Match
3130 (Subject : in out VString;
3131 Pat : PString;
3132 Replace : VString)
3134 Start : Natural;
3135 Stop : Natural;
3136 S : String_Access;
3137 L : Natural;
3139 begin
3140 Get_String (Subject, S, L);
3142 if Debug_Mode then
3143 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3144 else
3145 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3146 end if;
3148 if Start /= 0 then
3149 Get_String (Replace, S, L);
3150 Replace_Slice (Subject, Start, Stop, S (1 .. L));
3151 end if;
3152 end Match;
3154 procedure Match
3155 (Subject : in out VString;
3156 Pat : PString;
3157 Replace : String)
3159 Start : Natural;
3160 Stop : Natural;
3161 S : String_Access;
3162 L : Natural;
3164 begin
3165 Get_String (Subject, S, L);
3167 if Debug_Mode then
3168 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3169 else
3170 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3171 end if;
3173 if Start /= 0 then
3174 Replace_Slice (Subject, Start, Stop, Replace);
3175 end if;
3176 end Match;
3178 function Match
3179 (Subject : VString_Var;
3180 Pat : Pattern;
3181 Result : Match_Result_Var) return Boolean
3183 Start : Natural;
3184 Stop : Natural;
3185 S : String_Access;
3186 L : Natural;
3188 begin
3189 Get_String (Subject, S, L);
3191 if Debug_Mode then
3192 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3193 else
3194 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3195 end if;
3197 if Start = 0 then
3198 Result'Unrestricted_Access.all.Var := null;
3199 return False;
3201 else
3202 Result'Unrestricted_Access.all.Var := Subject'Unrestricted_Access;
3203 Result'Unrestricted_Access.all.Start := Start;
3204 Result'Unrestricted_Access.all.Stop := Stop;
3205 return True;
3206 end if;
3207 end Match;
3209 procedure Match
3210 (Subject : in out VString;
3211 Pat : Pattern;
3212 Result : out Match_Result)
3214 Start : Natural;
3215 Stop : Natural;
3216 S : String_Access;
3217 L : Natural;
3219 begin
3220 Get_String (Subject, S, L);
3222 if Debug_Mode then
3223 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3224 else
3225 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3226 end if;
3228 if Start = 0 then
3229 Result.Var := null;
3230 else
3231 Result.Var := Subject'Unrestricted_Access;
3232 Result.Start := Start;
3233 Result.Stop := Stop;
3234 end if;
3235 end Match;
3237 ---------------
3238 -- New_LineD --
3239 ---------------
3241 procedure New_LineD is
3242 begin
3243 if Internal_Debug then
3244 New_Line;
3245 end if;
3246 end New_LineD;
3248 ------------
3249 -- NotAny --
3250 ------------
3252 function NotAny (Str : String) return Pattern is
3253 begin
3254 return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, To_Set (Str)));
3255 end NotAny;
3257 function NotAny (Str : VString) return Pattern is
3258 begin
3259 return NotAny (S (Str));
3260 end NotAny;
3262 function NotAny (Str : Character) return Pattern is
3263 begin
3264 return (AFC with 0, new PE'(PC_NotAny_CH, 1, EOP, Str));
3265 end NotAny;
3267 function NotAny (Str : Character_Set) return Pattern is
3268 begin
3269 return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str));
3270 end NotAny;
3272 function NotAny (Str : not null access VString) return Pattern is
3273 begin
3274 return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str)));
3275 end NotAny;
3277 function NotAny (Str : VString_Func) return Pattern is
3278 begin
3279 return (AFC with 0, new PE'(PC_NotAny_VF, 1, EOP, Str));
3280 end NotAny;
3282 -----------
3283 -- NSpan --
3284 -----------
3286 function NSpan (Str : String) return Pattern is
3287 begin
3288 return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, To_Set (Str)));
3289 end NSpan;
3291 function NSpan (Str : VString) return Pattern is
3292 begin
3293 return NSpan (S (Str));
3294 end NSpan;
3296 function NSpan (Str : Character) return Pattern is
3297 begin
3298 return (AFC with 0, new PE'(PC_NSpan_CH, 1, EOP, Str));
3299 end NSpan;
3301 function NSpan (Str : Character_Set) return Pattern is
3302 begin
3303 return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str));
3304 end NSpan;
3306 function NSpan (Str : not null access VString) return Pattern is
3307 begin
3308 return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str)));
3309 end NSpan;
3311 function NSpan (Str : VString_Func) return Pattern is
3312 begin
3313 return (AFC with 0, new PE'(PC_NSpan_VF, 1, EOP, Str));
3314 end NSpan;
3316 ---------
3317 -- Pos --
3318 ---------
3320 function Pos (Count : Natural) return Pattern is
3321 begin
3322 return (AFC with 0, new PE'(PC_Pos_Nat, 1, EOP, Count));
3323 end Pos;
3325 function Pos (Count : Natural_Func) return Pattern is
3326 begin
3327 return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count));
3328 end Pos;
3330 function Pos (Count : not null access Natural) return Pattern is
3331 begin
3332 return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count)));
3333 end Pos;
3335 ----------
3336 -- PutD --
3337 ----------
3339 procedure PutD (Str : String) is
3340 begin
3341 if Internal_Debug then
3342 Put (Str);
3343 end if;
3344 end PutD;
3346 ---------------
3347 -- Put_LineD --
3348 ---------------
3350 procedure Put_LineD (Str : String) is
3351 begin
3352 if Internal_Debug then
3353 Put_Line (Str);
3354 end if;
3355 end Put_LineD;
3357 -------------
3358 -- Replace --
3359 -------------
3361 procedure Replace
3362 (Result : in out Match_Result;
3363 Replace : VString)
3365 S : String_Access;
3366 L : Natural;
3368 begin
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));
3373 Result.Var := null;
3374 end if;
3375 end Replace;
3377 ----------
3378 -- Rest --
3379 ----------
3381 function Rest return Pattern is
3382 begin
3383 return (AFC with 0, new PE'(PC_Rest, 1, EOP));
3384 end Rest;
3386 ----------
3387 -- Rpos --
3388 ----------
3390 function Rpos (Count : Natural) return Pattern is
3391 begin
3392 return (AFC with 0, new PE'(PC_RPos_Nat, 1, EOP, Count));
3393 end Rpos;
3395 function Rpos (Count : Natural_Func) return Pattern is
3396 begin
3397 return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count));
3398 end Rpos;
3400 function Rpos (Count : not null access Natural) return Pattern is
3401 begin
3402 return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count)));
3403 end Rpos;
3405 ----------
3406 -- Rtab --
3407 ----------
3409 function Rtab (Count : Natural) return Pattern is
3410 begin
3411 return (AFC with 0, new PE'(PC_RTab_Nat, 1, EOP, Count));
3412 end Rtab;
3414 function Rtab (Count : Natural_Func) return Pattern is
3415 begin
3416 return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count));
3417 end Rtab;
3419 function Rtab (Count : not null access Natural) return Pattern is
3420 begin
3421 return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count)));
3422 end Rtab;
3424 -------------
3425 -- S_To_PE --
3426 -------------
3428 function S_To_PE (Str : PString) return PE_Ptr is
3429 Len : constant Natural := Str'Length;
3431 begin
3432 case Len is
3433 when 0 =>
3434 return new PE'(PC_Null, 1, EOP);
3436 when 1 =>
3437 return new PE'(PC_Char, 1, EOP, Str (Str'First));
3439 when 2 =>
3440 return new PE'(PC_String_2, 1, EOP, Str);
3442 when 3 =>
3443 return new PE'(PC_String_3, 1, EOP, Str);
3445 when 4 =>
3446 return new PE'(PC_String_4, 1, EOP, Str);
3448 when 5 =>
3449 return new PE'(PC_String_5, 1, EOP, Str);
3451 when 6 =>
3452 return new PE'(PC_String_6, 1, EOP, Str);
3454 when others =>
3455 return new PE'(PC_String, 1, EOP, new String'(Str));
3457 end case;
3458 end S_To_PE;
3460 -------------------
3461 -- Set_Successor --
3462 -------------------
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
3469 begin
3470 if Pat = null then
3471 Uninitialized_Pattern;
3473 elsif Pat = EOP then
3474 Logic_Error;
3476 else
3477 declare
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.
3482 P : PE_Ptr;
3484 begin
3485 Build_Ref_Array (Pat, Refs);
3487 for J in Refs'Range loop
3488 P := Refs (J);
3490 if P.Pthen = EOP then
3491 P.Pthen := Succ;
3492 end if;
3494 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
3495 P.Alt := Succ;
3496 end if;
3497 end loop;
3498 end;
3499 end if;
3500 end Set_Successor;
3502 ------------
3503 -- Setcur --
3504 ------------
3506 function Setcur (Var : not null access Natural) return Pattern is
3507 begin
3508 return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var)));
3509 end Setcur;
3511 ----------
3512 -- Span --
3513 ----------
3515 function Span (Str : String) return Pattern is
3516 begin
3517 return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, To_Set (Str)));
3518 end Span;
3520 function Span (Str : VString) return Pattern is
3521 begin
3522 return Span (S (Str));
3523 end Span;
3525 function Span (Str : Character) return Pattern is
3526 begin
3527 return (AFC with 0, new PE'(PC_Span_CH, 1, EOP, Str));
3528 end Span;
3530 function Span (Str : Character_Set) return Pattern is
3531 begin
3532 return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str));
3533 end Span;
3535 function Span (Str : not null access VString) return Pattern is
3536 begin
3537 return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str)));
3538 end Span;
3540 function Span (Str : VString_Func) return Pattern is
3541 begin
3542 return (AFC with 0, new PE'(PC_Span_VF, 1, EOP, Str));
3543 end Span;
3545 ------------
3546 -- Str_BF --
3547 ------------
3549 function Str_BF (A : Boolean_Func) return String is
3550 function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address);
3551 begin
3552 return "BF(" & Image (To_A (A)) & ')';
3553 end Str_BF;
3555 ------------
3556 -- Str_FP --
3557 ------------
3559 function Str_FP (A : File_Ptr) return String is
3560 begin
3561 return "FP(" & Image (A.all'Address) & ')';
3562 end Str_FP;
3564 ------------
3565 -- Str_NF --
3566 ------------
3568 function Str_NF (A : Natural_Func) return String is
3569 function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address);
3570 begin
3571 return "NF(" & Image (To_A (A)) & ')';
3572 end Str_NF;
3574 ------------
3575 -- Str_NP --
3576 ------------
3578 function Str_NP (A : Natural_Ptr) return String is
3579 begin
3580 return "NP(" & Image (A.all'Address) & ')';
3581 end Str_NP;
3583 ------------
3584 -- Str_PP --
3585 ------------
3587 function Str_PP (A : Pattern_Ptr) return String is
3588 begin
3589 return "PP(" & Image (A.all'Address) & ')';
3590 end Str_PP;
3592 ------------
3593 -- Str_VF --
3594 ------------
3596 function Str_VF (A : VString_Func) return String is
3597 function To_A is new Ada.Unchecked_Conversion (VString_Func, Address);
3598 begin
3599 return "VF(" & Image (To_A (A)) & ')';
3600 end Str_VF;
3602 ------------
3603 -- Str_VP --
3604 ------------
3606 function Str_VP (A : VString_Ptr) return String is
3607 begin
3608 return "VP(" & Image (A.all'Address) & ')';
3609 end Str_VP;
3611 -------------
3612 -- Succeed --
3613 -------------
3615 function Succeed return Pattern is
3616 begin
3617 return (AFC with 1, new PE'(PC_Succeed, 1, EOP));
3618 end Succeed;
3620 ---------
3621 -- Tab --
3622 ---------
3624 function Tab (Count : Natural) return Pattern is
3625 begin
3626 return (AFC with 0, new PE'(PC_Tab_Nat, 1, EOP, Count));
3627 end Tab;
3629 function Tab (Count : Natural_Func) return Pattern is
3630 begin
3631 return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count));
3632 end Tab;
3634 function Tab (Count : not null access Natural) return Pattern is
3635 begin
3636 return (AFC with 0, new PE'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count)));
3637 end Tab;
3639 ---------------------------
3640 -- Uninitialized_Pattern --
3641 ---------------------------
3643 procedure Uninitialized_Pattern is
3644 begin
3645 raise Program_Error with
3646 "uninitialized value of type GNAT.Spitbol.Patterns.Pattern";
3647 end Uninitialized_Pattern;
3649 ------------
3650 -- XMatch --
3651 ------------
3653 procedure XMatch
3654 (Subject : String;
3655 Pat_P : PE_Ptr;
3656 Pat_S : Natural;
3657 Start : out Natural;
3658 Stop : out Natural)
3660 Node : PE_Ptr;
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
3685 Stack : Stack_Type;
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.
3729 ----------------
3730 -- Pop_Region --
3731 ----------------
3733 procedure Pop_Region is
3734 begin
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.
3746 else
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;
3751 end if;
3752 end Pop_Region;
3754 ----------
3755 -- Push --
3756 ----------
3758 procedure Push (Node : PE_Ptr) is
3759 begin
3760 Stack_Ptr := Stack_Ptr + 1;
3761 Stack (Stack_Ptr).Cursor := Cursor;
3762 Stack (Stack_Ptr).Node := Node;
3763 end Push;
3765 -----------------
3766 -- Push_Region --
3767 -----------------
3769 procedure Push_Region is
3770 begin
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;
3775 end Push_Region;
3777 -- Start of processing for XMatch
3779 begin
3780 if Pat_P = null then
3781 Uninitialized_Pattern;
3782 end if;
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;
3790 end if;
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.
3803 else
3804 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
3805 Stack (Stack_Init).Cursor := 0;
3806 end if;
3808 Stack_Ptr := Stack_Init;
3809 Stack_Base := Stack_Ptr;
3810 Cursor := 0;
3811 Node := Pat_P;
3812 goto Match;
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
3826 <<Match_Fail>>
3827 Start := 0;
3828 Stop := 0;
3829 return;
3831 -- Come here if entire match succeeds
3833 -- Cursor current position in subject string
3835 <<Match_Succeed>>
3836 Start := Stack (Stack_Init).Cursor + 1;
3837 Stop := Cursor;
3839 -- Scan history stack for deferred assignments or writes
3841 if Assign_OnM then
3842 for S in Stack_Init .. Stack_Ptr loop
3843 if Stack (S).Node = CP_Assign'Access then
3844 declare
3845 Inner_Base : constant Stack_Range :=
3846 Stack (S + 1).Cursor;
3847 Special_Entry : constant Stack_Range :=
3848 Inner_Base - 1;
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;
3855 begin
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));
3862 else
3863 Logic_Error;
3864 end if;
3865 end;
3866 end if;
3867 end loop;
3868 end if;
3870 return;
3872 -- Come here if attempt to match current element fails
3874 -- Stack_Base current stack base
3875 -- Stack_Ptr current stack pointer
3877 <<Fail>>
3878 Cursor := Stack (Stack_Ptr).Cursor;
3879 Node := Stack (Stack_Ptr).Node;
3880 Stack_Ptr := Stack_Ptr - 1;
3881 goto Match;
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
3890 <<Succeed>>
3891 Node := Node.Pthen;
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
3900 <<Match>>
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
3916 case Node.Pcode is
3918 -- Cancel
3920 when PC_Cancel =>
3921 goto Match_Fail;
3923 -- Alternation
3925 when PC_Alt =>
3926 Push (Node.Alt);
3927 Node := Node.Pthen;
3928 goto Match;
3930 -- Any (one character case)
3932 when PC_Any_CH =>
3933 if Cursor < Length
3934 and then Subject (Cursor + 1) = Node.Char
3935 then
3936 Cursor := Cursor + 1;
3937 goto Succeed;
3938 else
3939 goto Fail;
3940 end if;
3942 -- Any (character set case)
3944 when PC_Any_CS =>
3945 if Cursor < Length
3946 and then Is_In (Subject (Cursor + 1), Node.CS)
3947 then
3948 Cursor := Cursor + 1;
3949 goto Succeed;
3950 else
3951 goto Fail;
3952 end if;
3954 -- Any (string function case)
3956 when PC_Any_VF => declare
3957 U : constant VString := Node.VF.all;
3958 S : String_Access;
3959 L : Natural;
3961 begin
3962 Get_String (U, S, L);
3964 if Cursor < Length
3965 and then Is_In (Subject (Cursor + 1), S (1 .. L))
3966 then
3967 Cursor := Cursor + 1;
3968 goto Succeed;
3969 else
3970 goto Fail;
3971 end if;
3972 end;
3974 -- Any (string pointer case)
3976 when PC_Any_VP => declare
3977 U : constant VString := Node.VP.all;
3978 S : String_Access;
3979 L : Natural;
3981 begin
3982 Get_String (U, S, L);
3984 if Cursor < Length
3985 and then Is_In (Subject (Cursor + 1), S (1 .. L))
3986 then
3987 Cursor := Cursor + 1;
3988 goto Succeed;
3989 else
3990 goto Fail;
3991 end if;
3992 end;
3994 -- Arb (initial match)
3996 when PC_Arb_X =>
3997 Push (Node.Alt);
3998 Node := Node.Pthen;
3999 goto Match;
4001 -- Arb (extension)
4003 when PC_Arb_Y =>
4004 if Cursor < Length then
4005 Cursor := Cursor + 1;
4006 Push (Node);
4007 goto Succeed;
4008 else
4009 goto Fail;
4010 end if;
4012 -- Arbno_S (simple Arbno initialize). This is the node that
4013 -- initiates the match of a simple Arbno structure.
4015 when PC_Arbno_S =>
4016 Push (Node.Alt);
4017 Node := Node.Pthen;
4018 goto Match;
4020 -- Arbno_X (Arbno initialize). This is the node that initiates
4021 -- the match of a complex Arbno structure.
4023 when PC_Arbno_X =>
4024 Push (Node.Alt);
4025 Node := Node.Pthen;
4026 goto Match;
4028 -- Arbno_Y (Arbno rematch). This is the node that is executed
4029 -- following successful matching of one instance of a complex
4030 -- Arbno pattern.
4032 when PC_Arbno_Y => declare
4033 Null_Match : constant Boolean :=
4034 Cursor = Stack (Stack_Base - 1).Cursor;
4036 begin
4037 Pop_Region;
4039 -- If arbno extension matched null, then immediately fail
4041 if Null_Match then
4042 goto Fail;
4043 end if;
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;
4053 end if;
4055 goto Succeed;
4056 end;
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.
4062 when PC_Assign =>
4063 goto Fail;
4065 -- Assign immediate. This node performs the actual assignment
4067 when PC_Assign_Imm =>
4068 Set_String
4069 (Node.VP.all,
4070 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4071 Pop_Region;
4072 goto Succeed;
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);
4079 Pop_Region;
4080 Assign_OnM := True;
4081 goto Succeed;
4083 -- Bal
4085 when PC_Bal =>
4086 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
4087 goto Fail;
4089 elsif Subject (Cursor + 1) = '(' then
4090 declare
4091 Paren_Count : Natural := 1;
4093 begin
4094 loop
4095 Cursor := Cursor + 1;
4097 if Cursor >= Length then
4098 goto Fail;
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;
4106 end if;
4107 end loop;
4108 end;
4109 end if;
4111 Cursor := Cursor + 1;
4112 Push (Node);
4113 goto Succeed;
4115 -- Break (one character case)
4117 when PC_Break_CH =>
4118 while Cursor < Length loop
4119 if Subject (Cursor + 1) = Node.Char then
4120 goto Succeed;
4121 else
4122 Cursor := Cursor + 1;
4123 end if;
4124 end loop;
4126 goto Fail;
4128 -- Break (character set case)
4130 when PC_Break_CS =>
4131 while Cursor < Length loop
4132 if Is_In (Subject (Cursor + 1), Node.CS) then
4133 goto Succeed;
4134 else
4135 Cursor := Cursor + 1;
4136 end if;
4137 end loop;
4139 goto Fail;
4141 -- Break (string function case)
4143 when PC_Break_VF => declare
4144 U : constant VString := Node.VF.all;
4145 S : String_Access;
4146 L : Natural;
4148 begin
4149 Get_String (U, S, L);
4151 while Cursor < Length loop
4152 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4153 goto Succeed;
4154 else
4155 Cursor := Cursor + 1;
4156 end if;
4157 end loop;
4159 goto Fail;
4160 end;
4162 -- Break (string pointer case)
4164 when PC_Break_VP => declare
4165 U : constant VString := Node.VP.all;
4166 S : String_Access;
4167 L : Natural;
4169 begin
4170 Get_String (U, S, L);
4172 while Cursor < Length loop
4173 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4174 goto Succeed;
4175 else
4176 Cursor := Cursor + 1;
4177 end if;
4178 end loop;
4180 goto Fail;
4181 end;
4183 -- BreakX (one character case)
4185 when PC_BreakX_CH =>
4186 while Cursor < Length loop
4187 if Subject (Cursor + 1) = Node.Char then
4188 goto Succeed;
4189 else
4190 Cursor := Cursor + 1;
4191 end if;
4192 end loop;
4194 goto Fail;
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
4201 goto Succeed;
4202 else
4203 Cursor := Cursor + 1;
4204 end if;
4205 end loop;
4207 goto Fail;
4209 -- BreakX (string function case)
4211 when PC_BreakX_VF => declare
4212 U : constant VString := Node.VF.all;
4213 S : String_Access;
4214 L : Natural;
4216 begin
4217 Get_String (U, S, L);
4219 while Cursor < Length loop
4220 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4221 goto Succeed;
4222 else
4223 Cursor := Cursor + 1;
4224 end if;
4225 end loop;
4227 goto Fail;
4228 end;
4230 -- BreakX (string pointer case)
4232 when PC_BreakX_VP => declare
4233 U : constant VString := Node.VP.all;
4234 S : String_Access;
4235 L : Natural;
4237 begin
4238 Get_String (U, S, L);
4240 while Cursor < Length loop
4241 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4242 goto Succeed;
4243 else
4244 Cursor := Cursor + 1;
4245 end if;
4246 end loop;
4248 goto Fail;
4249 end;
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.
4255 when PC_BreakX_X =>
4256 Cursor := Cursor + 1;
4257 goto Succeed;
4259 -- Character (one character string)
4261 when PC_Char =>
4262 if Cursor < Length
4263 and then Subject (Cursor + 1) = Node.Char
4264 then
4265 Cursor := Cursor + 1;
4266 goto Succeed;
4267 else
4268 goto Fail;
4269 end if;
4271 -- End of Pattern
4273 when PC_EOP =>
4274 if Stack_Base = Stack_Init then
4275 goto Match_Succeed;
4277 -- End of recursive inner match. See separate section on
4278 -- handing of recursive pattern matches for details.
4280 else
4281 Node := Stack (Stack_Base - 1).Node;
4282 Pop_Region;
4283 goto Match;
4284 end if;
4286 -- Fail
4288 when PC_Fail =>
4289 goto Fail;
4291 -- Fence (built in pattern)
4293 when PC_Fence =>
4294 Push (CP_Cancel'Access);
4295 goto Succeed;
4297 -- Fence function node X. This is the node that gets control
4298 -- after a successful match of the fenced pattern.
4300 when PC_Fence_X =>
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;
4305 goto Succeed;
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.
4314 when PC_Fence_Y =>
4315 Stack_Ptr := Cursor - 2;
4316 goto Fail;
4318 -- Len (integer case)
4320 when PC_Len_Nat =>
4321 if Cursor + Node.Nat > Length then
4322 goto Fail;
4323 else
4324 Cursor := Cursor + Node.Nat;
4325 goto Succeed;
4326 end if;
4328 -- Len (Integer function case)
4330 when PC_Len_NF => declare
4331 N : constant Natural := Node.NF.all;
4332 begin
4333 if Cursor + N > Length then
4334 goto Fail;
4335 else
4336 Cursor := Cursor + N;
4337 goto Succeed;
4338 end if;
4339 end;
4341 -- Len (integer pointer case)
4343 when PC_Len_NP =>
4344 if Cursor + Node.NP.all > Length then
4345 goto Fail;
4346 else
4347 Cursor := Cursor + Node.NP.all;
4348 goto Succeed;
4349 end if;
4351 -- NotAny (one character case)
4353 when PC_NotAny_CH =>
4354 if Cursor < Length
4355 and then Subject (Cursor + 1) /= Node.Char
4356 then
4357 Cursor := Cursor + 1;
4358 goto Succeed;
4359 else
4360 goto Fail;
4361 end if;
4363 -- NotAny (character set case)
4365 when PC_NotAny_CS =>
4366 if Cursor < Length
4367 and then not Is_In (Subject (Cursor + 1), Node.CS)
4368 then
4369 Cursor := Cursor + 1;
4370 goto Succeed;
4371 else
4372 goto Fail;
4373 end if;
4375 -- NotAny (string function case)
4377 when PC_NotAny_VF => declare
4378 U : constant VString := Node.VF.all;
4379 S : String_Access;
4380 L : Natural;
4382 begin
4383 Get_String (U, S, L);
4385 if Cursor < Length
4386 and then
4387 not Is_In (Subject (Cursor + 1), S (1 .. L))
4388 then
4389 Cursor := Cursor + 1;
4390 goto Succeed;
4391 else
4392 goto Fail;
4393 end if;
4394 end;
4396 -- NotAny (string pointer case)
4398 when PC_NotAny_VP => declare
4399 U : constant VString := Node.VP.all;
4400 S : String_Access;
4401 L : Natural;
4403 begin
4404 Get_String (U, S, L);
4406 if Cursor < Length
4407 and then
4408 not Is_In (Subject (Cursor + 1), S (1 .. L))
4409 then
4410 Cursor := Cursor + 1;
4411 goto Succeed;
4412 else
4413 goto Fail;
4414 end if;
4415 end;
4417 -- NSpan (one character case)
4419 when PC_NSpan_CH =>
4420 while Cursor < Length
4421 and then Subject (Cursor + 1) = Node.Char
4422 loop
4423 Cursor := Cursor + 1;
4424 end loop;
4426 goto Succeed;
4428 -- NSpan (character set case)
4430 when PC_NSpan_CS =>
4431 while Cursor < Length
4432 and then Is_In (Subject (Cursor + 1), Node.CS)
4433 loop
4434 Cursor := Cursor + 1;
4435 end loop;
4437 goto Succeed;
4439 -- NSpan (string function case)
4441 when PC_NSpan_VF => declare
4442 U : constant VString := Node.VF.all;
4443 S : String_Access;
4444 L : Natural;
4446 begin
4447 Get_String (U, S, L);
4449 while Cursor < Length
4450 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4451 loop
4452 Cursor := Cursor + 1;
4453 end loop;
4455 goto Succeed;
4456 end;
4458 -- NSpan (string pointer case)
4460 when PC_NSpan_VP => declare
4461 U : constant VString := Node.VP.all;
4462 S : String_Access;
4463 L : Natural;
4465 begin
4466 Get_String (U, S, L);
4468 while Cursor < Length
4469 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4470 loop
4471 Cursor := Cursor + 1;
4472 end loop;
4474 goto Succeed;
4475 end;
4477 -- Null string
4479 when PC_Null =>
4480 goto Succeed;
4482 -- Pos (integer case)
4484 when PC_Pos_Nat =>
4485 if Cursor = Node.Nat then
4486 goto Succeed;
4487 else
4488 goto Fail;
4489 end if;
4491 -- Pos (Integer function case)
4493 when PC_Pos_NF => declare
4494 N : constant Natural := Node.NF.all;
4495 begin
4496 if Cursor = N then
4497 goto Succeed;
4498 else
4499 goto Fail;
4500 end if;
4501 end;
4503 -- Pos (integer pointer case)
4505 when PC_Pos_NP =>
4506 if Cursor = Node.NP.all then
4507 goto Succeed;
4508 else
4509 goto Fail;
4510 end if;
4512 -- Predicate function
4514 when PC_Pred_Func =>
4515 if Node.BF.all then
4516 goto Succeed;
4517 else
4518 goto Fail;
4519 end if;
4521 -- Region Enter. Initiate new pattern history stack region
4523 when PC_R_Enter =>
4524 Stack (Stack_Ptr + 1).Cursor := Cursor;
4525 Push_Region;
4526 goto Succeed;
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.
4535 when PC_R_Remove =>
4536 Stack_Base := Cursor;
4537 Stack_Ptr := Stack_Ptr - 1;
4538 goto Fail;
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;
4549 goto Fail;
4551 -- Rest
4553 when PC_Rest =>
4554 Cursor := Length;
4555 goto Succeed;
4557 -- Initiate recursive match (pattern pointer case)
4559 when PC_Rpat =>
4560 Stack (Stack_Ptr + 1).Node := Node.Pthen;
4561 Push_Region;
4563 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
4564 raise Pattern_Stack_Overflow;
4565 else
4566 Node := Node.PP.all.P;
4567 goto Match;
4568 end if;
4570 -- RPos (integer case)
4572 when PC_RPos_Nat =>
4573 if Cursor = (Length - Node.Nat) then
4574 goto Succeed;
4575 else
4576 goto Fail;
4577 end if;
4579 -- RPos (integer function case)
4581 when PC_RPos_NF => declare
4582 N : constant Natural := Node.NF.all;
4583 begin
4584 if Length - Cursor = N then
4585 goto Succeed;
4586 else
4587 goto Fail;
4588 end if;
4589 end;
4591 -- RPos (integer pointer case)
4593 when PC_RPos_NP =>
4594 if Cursor = (Length - Node.NP.all) then
4595 goto Succeed;
4596 else
4597 goto Fail;
4598 end if;
4600 -- RTab (integer case)
4602 when PC_RTab_Nat =>
4603 if Cursor <= (Length - Node.Nat) then
4604 Cursor := Length - Node.Nat;
4605 goto Succeed;
4606 else
4607 goto Fail;
4608 end if;
4610 -- RTab (integer function case)
4612 when PC_RTab_NF => declare
4613 N : constant Natural := Node.NF.all;
4614 begin
4615 if Length - Cursor >= N then
4616 Cursor := Length - N;
4617 goto Succeed;
4618 else
4619 goto Fail;
4620 end if;
4621 end;
4623 -- RTab (integer pointer case)
4625 when PC_RTab_NP =>
4626 if Cursor <= (Length - Node.NP.all) then
4627 Cursor := Length - Node.NP.all;
4628 goto Succeed;
4629 else
4630 goto Fail;
4631 end if;
4633 -- Cursor assignment
4635 when PC_Setcur =>
4636 Node.Var.all := Cursor;
4637 goto Succeed;
4639 -- Span (one character case)
4641 when PC_Span_CH => declare
4642 P : Natural;
4644 begin
4645 P := Cursor;
4646 while P < Length
4647 and then Subject (P + 1) = Node.Char
4648 loop
4649 P := P + 1;
4650 end loop;
4652 if P /= Cursor then
4653 Cursor := P;
4654 goto Succeed;
4655 else
4656 goto Fail;
4657 end if;
4658 end;
4660 -- Span (character set case)
4662 when PC_Span_CS => declare
4663 P : Natural;
4665 begin
4666 P := Cursor;
4667 while P < Length
4668 and then Is_In (Subject (P + 1), Node.CS)
4669 loop
4670 P := P + 1;
4671 end loop;
4673 if P /= Cursor then
4674 Cursor := P;
4675 goto Succeed;
4676 else
4677 goto Fail;
4678 end if;
4679 end;
4681 -- Span (string function case)
4683 when PC_Span_VF => declare
4684 U : constant VString := Node.VF.all;
4685 S : String_Access;
4686 L : Natural;
4687 P : Natural;
4689 begin
4690 Get_String (U, S, L);
4692 P := Cursor;
4693 while P < Length
4694 and then Is_In (Subject (P + 1), S (1 .. L))
4695 loop
4696 P := P + 1;
4697 end loop;
4699 if P /= Cursor then
4700 Cursor := P;
4701 goto Succeed;
4702 else
4703 goto Fail;
4704 end if;
4705 end;
4707 -- Span (string pointer case)
4709 when PC_Span_VP => declare
4710 U : constant VString := Node.VP.all;
4711 S : String_Access;
4712 L : Natural;
4713 P : Natural;
4715 begin
4716 Get_String (U, S, L);
4718 P := Cursor;
4719 while P < Length
4720 and then Is_In (Subject (P + 1), S (1 .. L))
4721 loop
4722 P := P + 1;
4723 end loop;
4725 if P /= Cursor then
4726 Cursor := P;
4727 goto Succeed;
4728 else
4729 goto Fail;
4730 end if;
4731 end;
4733 -- String (two character case)
4735 when PC_String_2 =>
4736 if (Length - Cursor) >= 2
4737 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
4738 then
4739 Cursor := Cursor + 2;
4740 goto Succeed;
4741 else
4742 goto Fail;
4743 end if;
4745 -- String (three character case)
4747 when PC_String_3 =>
4748 if (Length - Cursor) >= 3
4749 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
4750 then
4751 Cursor := Cursor + 3;
4752 goto Succeed;
4753 else
4754 goto Fail;
4755 end if;
4757 -- String (four character case)
4759 when PC_String_4 =>
4760 if (Length - Cursor) >= 4
4761 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
4762 then
4763 Cursor := Cursor + 4;
4764 goto Succeed;
4765 else
4766 goto Fail;
4767 end if;
4769 -- String (five character case)
4771 when PC_String_5 =>
4772 if (Length - Cursor) >= 5
4773 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
4774 then
4775 Cursor := Cursor + 5;
4776 goto Succeed;
4777 else
4778 goto Fail;
4779 end if;
4781 -- String (six character case)
4783 when PC_String_6 =>
4784 if (Length - Cursor) >= 6
4785 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
4786 then
4787 Cursor := Cursor + 6;
4788 goto Succeed;
4789 else
4790 goto Fail;
4791 end if;
4793 -- String (case of more than six characters)
4795 when PC_String => declare
4796 Len : constant Natural := Node.Str'Length;
4797 begin
4798 if (Length - Cursor) >= Len
4799 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
4800 then
4801 Cursor := Cursor + Len;
4802 goto Succeed;
4803 else
4804 goto Fail;
4805 end if;
4806 end;
4808 -- String (function case)
4810 when PC_String_VF => declare
4811 U : constant VString := Node.VF.all;
4812 S : String_Access;
4813 L : Natural;
4815 begin
4816 Get_String (U, S, L);
4818 if (Length - Cursor) >= L
4819 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4820 then
4821 Cursor := Cursor + L;
4822 goto Succeed;
4823 else
4824 goto Fail;
4825 end if;
4826 end;
4828 -- String (pointer case)
4830 when PC_String_VP => declare
4831 U : constant VString := Node.VP.all;
4832 S : String_Access;
4833 L : Natural;
4835 begin
4836 Get_String (U, S, L);
4838 if (Length - Cursor) >= L
4839 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4840 then
4841 Cursor := Cursor + L;
4842 goto Succeed;
4843 else
4844 goto Fail;
4845 end if;
4846 end;
4848 -- Succeed
4850 when PC_Succeed =>
4851 Push (Node);
4852 goto Succeed;
4854 -- Tab (integer case)
4856 when PC_Tab_Nat =>
4857 if Cursor <= Node.Nat then
4858 Cursor := Node.Nat;
4859 goto Succeed;
4860 else
4861 goto Fail;
4862 end if;
4864 -- Tab (integer function case)
4866 when PC_Tab_NF => declare
4867 N : constant Natural := Node.NF.all;
4868 begin
4869 if Cursor <= N then
4870 Cursor := N;
4871 goto Succeed;
4872 else
4873 goto Fail;
4874 end if;
4875 end;
4877 -- Tab (integer pointer case)
4879 when PC_Tab_NP =>
4880 if Cursor <= Node.NP.all then
4881 Cursor := Node.NP.all;
4882 goto Succeed;
4883 else
4884 goto Fail;
4885 end if;
4887 -- Unanchored movement
4889 when PC_Unanchored =>
4891 -- All done if we tried every position
4893 if Cursor > Length then
4894 goto Match_Fail;
4896 -- Otherwise extend the anchor point, and restack ourself
4898 else
4899 Cursor := Cursor + 1;
4900 Push (Node);
4901 goto Succeed;
4902 end if;
4904 -- Write immediate. This node performs the actual write
4906 when PC_Write_Imm =>
4907 Put_Line
4908 (Node.FP.all,
4909 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4910 Pop_Region;
4911 goto Succeed;
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);
4918 Pop_Region;
4919 Assign_OnM := True;
4920 goto Succeed;
4922 end case;
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);
4929 Logic_Error;
4930 pragma Warnings (On);
4931 end XMatch;
4933 -------------
4934 -- XMatchD --
4935 -------------
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
4944 -- the new XMatch.
4946 procedure XMatchD
4947 (Subject : String;
4948 Pat_P : PE_Ptr;
4949 Pat_S : Natural;
4950 Start : out Natural;
4951 Stop : out Natural)
4953 Node : PE_Ptr;
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.
4982 Stack : Stack_Type;
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.
5044 ----------
5045 -- Dout --
5046 ----------
5048 procedure Dout (Str : String) is
5049 begin
5050 for J in 1 .. Region_Level loop
5051 Put ("| ");
5052 end loop;
5054 Put_Line (Str);
5055 end Dout;
5057 procedure Dout (Str : String; A : Character) is
5058 begin
5059 Dout (Str & " ('" & A & "')");
5060 end Dout;
5062 procedure Dout (Str : String; A : Character_Set) is
5063 begin
5064 Dout (Str & " (" & Image (To_Sequence (A)) & ')');
5065 end Dout;
5067 procedure Dout (Str : String; A : Natural) is
5068 begin
5069 Dout (Str & " (" & A & ')');
5070 end Dout;
5072 procedure Dout (Str : String; A : String) is
5073 begin
5074 Dout (Str & " (" & Image (A) & ')');
5075 end Dout;
5077 ---------
5078 -- Img --
5079 ---------
5081 function Img (P : PE_Ptr) return String is
5082 begin
5083 return "#" & Integer (P.Index) & " ";
5084 end Img;
5086 ----------------
5087 -- Pop_Region --
5088 ----------------
5090 procedure Pop_Region is
5091 begin
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.
5105 else
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;
5110 end if;
5111 end Pop_Region;
5113 ----------
5114 -- Push --
5115 ----------
5117 procedure Push (Node : PE_Ptr) is
5118 begin
5119 Stack_Ptr := Stack_Ptr + 1;
5120 Stack (Stack_Ptr).Cursor := Cursor;
5121 Stack (Stack_Ptr).Node := Node;
5122 end Push;
5124 -----------------
5125 -- Push_Region --
5126 -----------------
5128 procedure Push_Region is
5129 begin
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;
5135 end Push_Region;
5137 -- Start of processing for XMatchD
5139 begin
5140 New_Line;
5141 Put_Line ("Initiating pattern match, subject = " & Image (Subject));
5142 Put ("--------------------------------------");
5144 for J in 1 .. Length loop
5145 Put ('-');
5146 end loop;
5148 New_Line;
5149 Put_Line ("subject length = " & Length);
5151 if Pat_P = null then
5152 Uninitialized_Pattern;
5153 end if;
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;
5161 end if;
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.
5174 else
5175 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
5176 Stack (Stack_Init).Cursor := 0;
5177 end if;
5179 Stack_Ptr := Stack_Init;
5180 Stack_Base := Stack_Ptr;
5181 Cursor := 0;
5182 Node := Pat_P;
5183 goto Match;
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
5197 <<Match_Fail>>
5198 Dout ("match fails");
5199 New_Line;
5200 Start := 0;
5201 Stop := 0;
5202 return;
5204 -- Come here if entire match succeeds
5206 -- Cursor current position in subject string
5208 <<Match_Succeed>>
5209 Dout ("match succeeds");
5210 Start := Stack (Stack_Init).Cursor + 1;
5211 Stop := Cursor;
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
5218 if Assign_OnM then
5219 for S in Stack'First .. Stack_Ptr loop
5220 if Stack (S).Node = CP_Assign'Access then
5221 declare
5222 Inner_Base : constant Stack_Range :=
5223 Stack (S + 1).Cursor;
5224 Special_Entry : constant Stack_Range :=
5225 Inner_Base - 1;
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;
5232 begin
5233 if Node_OnM.Pcode = PC_Assign_OnM then
5234 Set_String (Node_OnM.VP.all, Subject (Start .. Stop));
5235 Dout
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));
5242 Dout
5243 (Img (Stack (S).Node) &
5244 "deferred write of " &
5245 Image (Subject (Start .. Stop)));
5247 else
5248 Logic_Error;
5249 end if;
5250 end;
5251 end if;
5252 end loop;
5253 end if;
5255 New_Line;
5256 return;
5258 -- Come here if attempt to match current element fails
5260 -- Stack_Base current stack base
5261 -- Stack_Ptr current stack pointer
5263 <<Fail>>
5264 Cursor := Stack (Stack_Ptr).Cursor;
5265 Node := Stack (Stack_Ptr).Node;
5266 Stack_Ptr := Stack_Ptr - 1;
5268 if Cursor >= 0 then
5269 Dout ("failure, cursor reset to " & Cursor);
5270 end if;
5272 goto Match;
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
5281 <<Succeed>>
5282 Dout ("success, cursor = " & Cursor);
5283 Node := Node.Pthen;
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
5292 <<Match>>
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
5308 case Node.Pcode is
5310 -- Cancel
5312 when PC_Cancel =>
5313 Dout (Img (Node) & "matching Cancel");
5314 goto Match_Fail;
5316 -- Alternation
5318 when PC_Alt =>
5319 Dout
5320 (Img (Node) & "setting up alternative " & Img (Node.Alt));
5321 Push (Node.Alt);
5322 Node := Node.Pthen;
5323 goto Match;
5325 -- Any (one character case)
5327 when PC_Any_CH =>
5328 Dout (Img (Node) & "matching Any", Node.Char);
5330 if Cursor < Length
5331 and then Subject (Cursor + 1) = Node.Char
5332 then
5333 Cursor := Cursor + 1;
5334 goto Succeed;
5335 else
5336 goto Fail;
5337 end if;
5339 -- Any (character set case)
5341 when PC_Any_CS =>
5342 Dout (Img (Node) & "matching Any", Node.CS);
5344 if Cursor < Length
5345 and then Is_In (Subject (Cursor + 1), Node.CS)
5346 then
5347 Cursor := Cursor + 1;
5348 goto Succeed;
5349 else
5350 goto Fail;
5351 end if;
5353 -- Any (string function case)
5355 when PC_Any_VF => declare
5356 U : constant VString := Node.VF.all;
5357 S : String_Access;
5358 L : Natural;
5360 begin
5361 Get_String (U, S, L);
5363 Dout (Img (Node) & "matching Any", S (1 .. L));
5365 if Cursor < Length
5366 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5367 then
5368 Cursor := Cursor + 1;
5369 goto Succeed;
5370 else
5371 goto Fail;
5372 end if;
5373 end;
5375 -- Any (string pointer case)
5377 when PC_Any_VP => declare
5378 U : constant VString := Node.VP.all;
5379 S : String_Access;
5380 L : Natural;
5382 begin
5383 Get_String (U, S, L);
5384 Dout (Img (Node) & "matching Any", S (1 .. L));
5386 if Cursor < Length
5387 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5388 then
5389 Cursor := Cursor + 1;
5390 goto Succeed;
5391 else
5392 goto Fail;
5393 end if;
5394 end;
5396 -- Arb (initial match)
5398 when PC_Arb_X =>
5399 Dout (Img (Node) & "matching Arb");
5400 Push (Node.Alt);
5401 Node := Node.Pthen;
5402 goto Match;
5404 -- Arb (extension)
5406 when PC_Arb_Y =>
5407 Dout (Img (Node) & "extending Arb");
5409 if Cursor < Length then
5410 Cursor := Cursor + 1;
5411 Push (Node);
5412 goto Succeed;
5413 else
5414 goto Fail;
5415 end if;
5417 -- Arbno_S (simple Arbno initialize). This is the node that
5418 -- initiates the match of a simple Arbno structure.
5420 when PC_Arbno_S =>
5421 Dout (Img (Node) &
5422 "setting up Arbno alternative " & Img (Node.Alt));
5423 Push (Node.Alt);
5424 Node := Node.Pthen;
5425 goto Match;
5427 -- Arbno_X (Arbno initialize). This is the node that initiates
5428 -- the match of a complex Arbno structure.
5430 when PC_Arbno_X =>
5431 Dout (Img (Node) &
5432 "setting up Arbno alternative " & Img (Node.Alt));
5433 Push (Node.Alt);
5434 Node := Node.Pthen;
5435 goto Match;
5437 -- Arbno_Y (Arbno rematch). This is the node that is executed
5438 -- following successful matching of one instance of a complex
5439 -- Arbno pattern.
5441 when PC_Arbno_Y => declare
5442 Null_Match : constant Boolean :=
5443 Cursor = Stack (Stack_Base - 1).Cursor;
5445 begin
5446 Dout (Img (Node) & "extending Arbno");
5447 Pop_Region;
5449 -- If arbno extension matched null, then immediately fail
5451 if Null_Match then
5452 Dout ("Arbno extension matched null, so fails");
5453 goto Fail;
5454 end if;
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;
5464 end if;
5466 goto Succeed;
5467 end;
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.
5473 when PC_Assign =>
5474 Dout (Img (Node) & "deferred assign/write cancelled");
5475 goto Fail;
5477 -- Assign immediate. This node performs the actual assignment
5479 when PC_Assign_Imm =>
5480 Dout
5481 (Img (Node) & "executing immediate assignment of " &
5482 Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)));
5483 Set_String
5484 (Node.VP.all,
5485 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
5486 Pop_Region;
5487 goto Succeed;
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);
5495 Pop_Region;
5496 Assign_OnM := True;
5497 goto Succeed;
5499 -- Bal
5501 when PC_Bal =>
5502 Dout (Img (Node) & "matching or extending Bal");
5503 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
5504 goto Fail;
5506 elsif Subject (Cursor + 1) = '(' then
5507 declare
5508 Paren_Count : Natural := 1;
5510 begin
5511 loop
5512 Cursor := Cursor + 1;
5514 if Cursor >= Length then
5515 goto Fail;
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;
5523 end if;
5524 end loop;
5525 end;
5526 end if;
5528 Cursor := Cursor + 1;
5529 Push (Node);
5530 goto Succeed;
5532 -- Break (one character case)
5534 when PC_Break_CH =>
5535 Dout (Img (Node) & "matching Break", Node.Char);
5537 while Cursor < Length loop
5538 if Subject (Cursor + 1) = Node.Char then
5539 goto Succeed;
5540 else
5541 Cursor := Cursor + 1;
5542 end if;
5543 end loop;
5545 goto Fail;
5547 -- Break (character set case)
5549 when PC_Break_CS =>
5550 Dout (Img (Node) & "matching Break", Node.CS);
5552 while Cursor < Length loop
5553 if Is_In (Subject (Cursor + 1), Node.CS) then
5554 goto Succeed;
5555 else
5556 Cursor := Cursor + 1;
5557 end if;
5558 end loop;
5560 goto Fail;
5562 -- Break (string function case)
5564 when PC_Break_VF => declare
5565 U : constant VString := Node.VF.all;
5566 S : String_Access;
5567 L : Natural;
5569 begin
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
5575 goto Succeed;
5576 else
5577 Cursor := Cursor + 1;
5578 end if;
5579 end loop;
5581 goto Fail;
5582 end;
5584 -- Break (string pointer case)
5586 when PC_Break_VP => declare
5587 U : constant VString := Node.VP.all;
5588 S : String_Access;
5589 L : Natural;
5591 begin
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
5597 goto Succeed;
5598 else
5599 Cursor := Cursor + 1;
5600 end if;
5601 end loop;
5603 goto Fail;
5604 end;
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
5613 goto Succeed;
5614 else
5615 Cursor := Cursor + 1;
5616 end if;
5617 end loop;
5619 goto Fail;
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
5628 goto Succeed;
5629 else
5630 Cursor := Cursor + 1;
5631 end if;
5632 end loop;
5634 goto Fail;
5636 -- BreakX (string function case)
5638 when PC_BreakX_VF => declare
5639 U : constant VString := Node.VF.all;
5640 S : String_Access;
5641 L : Natural;
5643 begin
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
5649 goto Succeed;
5650 else
5651 Cursor := Cursor + 1;
5652 end if;
5653 end loop;
5655 goto Fail;
5656 end;
5658 -- BreakX (string pointer case)
5660 when PC_BreakX_VP => declare
5661 U : constant VString := Node.VP.all;
5662 S : String_Access;
5663 L : Natural;
5665 begin
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
5671 goto Succeed;
5672 else
5673 Cursor := Cursor + 1;
5674 end if;
5675 end loop;
5677 goto Fail;
5678 end;
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.
5684 when PC_BreakX_X =>
5685 Dout (Img (Node) & "extending BreakX");
5686 Cursor := Cursor + 1;
5687 goto Succeed;
5689 -- Character (one character string)
5691 when PC_Char =>
5692 Dout (Img (Node) & "matching '" & Node.Char & ''');
5694 if Cursor < Length
5695 and then Subject (Cursor + 1) = Node.Char
5696 then
5697 Cursor := Cursor + 1;
5698 goto Succeed;
5699 else
5700 goto Fail;
5701 end if;
5703 -- End of Pattern
5705 when PC_EOP =>
5706 if Stack_Base = Stack_Init then
5707 Dout ("end of pattern");
5708 goto Match_Succeed;
5710 -- End of recursive inner match. See separate section on
5711 -- handing of recursive pattern matches for details.
5713 else
5714 Dout ("terminating recursive match");
5715 Node := Stack (Stack_Base - 1).Node;
5716 Pop_Region;
5717 goto Match;
5718 end if;
5720 -- Fail
5722 when PC_Fail =>
5723 Dout (Img (Node) & "matching Fail");
5724 goto Fail;
5726 -- Fence (built in pattern)
5728 when PC_Fence =>
5729 Dout (Img (Node) & "matching Fence");
5730 Push (CP_Cancel'Access);
5731 goto Succeed;
5733 -- Fence function node X. This is the node that gets control
5734 -- after a successful match of the fenced pattern.
5736 when PC_Fence_X =>
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;
5743 goto Succeed;
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.
5752 when PC_Fence_Y =>
5753 Dout (Img (Node) & "pattern matched by Fence caused failure");
5754 Stack_Ptr := Cursor - 2;
5755 goto Fail;
5757 -- Len (integer case)
5759 when PC_Len_Nat =>
5760 Dout (Img (Node) & "matching Len", Node.Nat);
5762 if Cursor + Node.Nat > Length then
5763 goto Fail;
5764 else
5765 Cursor := Cursor + Node.Nat;
5766 goto Succeed;
5767 end if;
5769 -- Len (Integer function case)
5771 when PC_Len_NF => declare
5772 N : constant Natural := Node.NF.all;
5774 begin
5775 Dout (Img (Node) & "matching Len", N);
5777 if Cursor + N > Length then
5778 goto Fail;
5779 else
5780 Cursor := Cursor + N;
5781 goto Succeed;
5782 end if;
5783 end;
5785 -- Len (integer pointer case)
5787 when PC_Len_NP =>
5788 Dout (Img (Node) & "matching Len", Node.NP.all);
5790 if Cursor + Node.NP.all > Length then
5791 goto Fail;
5792 else
5793 Cursor := Cursor + Node.NP.all;
5794 goto Succeed;
5795 end if;
5797 -- NotAny (one character case)
5799 when PC_NotAny_CH =>
5800 Dout (Img (Node) & "matching NotAny", Node.Char);
5802 if Cursor < Length
5803 and then Subject (Cursor + 1) /= Node.Char
5804 then
5805 Cursor := Cursor + 1;
5806 goto Succeed;
5807 else
5808 goto Fail;
5809 end if;
5811 -- NotAny (character set case)
5813 when PC_NotAny_CS =>
5814 Dout (Img (Node) & "matching NotAny", Node.CS);
5816 if Cursor < Length
5817 and then not Is_In (Subject (Cursor + 1), Node.CS)
5818 then
5819 Cursor := Cursor + 1;
5820 goto Succeed;
5821 else
5822 goto Fail;
5823 end if;
5825 -- NotAny (string function case)
5827 when PC_NotAny_VF => declare
5828 U : constant VString := Node.VF.all;
5829 S : String_Access;
5830 L : Natural;
5832 begin
5833 Get_String (U, S, L);
5834 Dout (Img (Node) & "matching NotAny", S (1 .. L));
5836 if Cursor < Length
5837 and then
5838 not Is_In (Subject (Cursor + 1), S (1 .. L))
5839 then
5840 Cursor := Cursor + 1;
5841 goto Succeed;
5842 else
5843 goto Fail;
5844 end if;
5845 end;
5847 -- NotAny (string pointer case)
5849 when PC_NotAny_VP => declare
5850 U : constant VString := Node.VP.all;
5851 S : String_Access;
5852 L : Natural;
5854 begin
5855 Get_String (U, S, L);
5856 Dout (Img (Node) & "matching NotAny", S (1 .. L));
5858 if Cursor < Length
5859 and then
5860 not Is_In (Subject (Cursor + 1), S (1 .. L))
5861 then
5862 Cursor := Cursor + 1;
5863 goto Succeed;
5864 else
5865 goto Fail;
5866 end if;
5867 end;
5869 -- NSpan (one character case)
5871 when PC_NSpan_CH =>
5872 Dout (Img (Node) & "matching NSpan", Node.Char);
5874 while Cursor < Length
5875 and then Subject (Cursor + 1) = Node.Char
5876 loop
5877 Cursor := Cursor + 1;
5878 end loop;
5880 goto Succeed;
5882 -- NSpan (character set case)
5884 when PC_NSpan_CS =>
5885 Dout (Img (Node) & "matching NSpan", Node.CS);
5887 while Cursor < Length
5888 and then Is_In (Subject (Cursor + 1), Node.CS)
5889 loop
5890 Cursor := Cursor + 1;
5891 end loop;
5893 goto Succeed;
5895 -- NSpan (string function case)
5897 when PC_NSpan_VF => declare
5898 U : constant VString := Node.VF.all;
5899 S : String_Access;
5900 L : Natural;
5902 begin
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))
5908 loop
5909 Cursor := Cursor + 1;
5910 end loop;
5912 goto Succeed;
5913 end;
5915 -- NSpan (string pointer case)
5917 when PC_NSpan_VP => declare
5918 U : constant VString := Node.VP.all;
5919 S : String_Access;
5920 L : Natural;
5922 begin
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))
5928 loop
5929 Cursor := Cursor + 1;
5930 end loop;
5932 goto Succeed;
5933 end;
5935 when PC_Null =>
5936 Dout (Img (Node) & "matching null");
5937 goto Succeed;
5939 -- Pos (integer case)
5941 when PC_Pos_Nat =>
5942 Dout (Img (Node) & "matching Pos", Node.Nat);
5944 if Cursor = Node.Nat then
5945 goto Succeed;
5946 else
5947 goto Fail;
5948 end if;
5950 -- Pos (Integer function case)
5952 when PC_Pos_NF => declare
5953 N : constant Natural := Node.NF.all;
5955 begin
5956 Dout (Img (Node) & "matching Pos", N);
5958 if Cursor = N then
5959 goto Succeed;
5960 else
5961 goto Fail;
5962 end if;
5963 end;
5965 -- Pos (integer pointer case)
5967 when PC_Pos_NP =>
5968 Dout (Img (Node) & "matching Pos", Node.NP.all);
5970 if Cursor = Node.NP.all then
5971 goto Succeed;
5972 else
5973 goto Fail;
5974 end if;
5976 -- Predicate function
5978 when PC_Pred_Func =>
5979 Dout (Img (Node) & "matching predicate function");
5981 if Node.BF.all then
5982 goto Succeed;
5983 else
5984 goto Fail;
5985 end if;
5987 -- Region Enter. Initiate new pattern history stack region
5989 when PC_R_Enter =>
5990 Dout (Img (Node) & "starting match of nested pattern");
5991 Stack (Stack_Ptr + 1).Cursor := Cursor;
5992 Push_Region;
5993 goto Succeed;
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.
6002 when PC_R_Remove =>
6003 Dout ("failure, match of nested pattern terminated");
6004 Stack_Base := Cursor;
6005 Region_Level := Region_Level - 1;
6006 Stack_Ptr := Stack_Ptr - 1;
6007 goto Fail;
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;
6020 goto Fail;
6022 -- Rest
6024 when PC_Rest =>
6025 Dout (Img (Node) & "matching Rest");
6026 Cursor := Length;
6027 goto Succeed;
6029 -- Initiate recursive match (pattern pointer case)
6031 when PC_Rpat =>
6032 Stack (Stack_Ptr + 1).Node := Node.Pthen;
6033 Push_Region;
6034 Dout (Img (Node) & "initiating recursive match");
6036 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
6037 raise Pattern_Stack_Overflow;
6038 else
6039 Node := Node.PP.all.P;
6040 goto Match;
6041 end if;
6043 -- RPos (integer case)
6045 when PC_RPos_Nat =>
6046 Dout (Img (Node) & "matching RPos", Node.Nat);
6048 if Cursor = (Length - Node.Nat) then
6049 goto Succeed;
6050 else
6051 goto Fail;
6052 end if;
6054 -- RPos (integer function case)
6056 when PC_RPos_NF => declare
6057 N : constant Natural := Node.NF.all;
6059 begin
6060 Dout (Img (Node) & "matching RPos", N);
6062 if Length - Cursor = N then
6063 goto Succeed;
6064 else
6065 goto Fail;
6066 end if;
6067 end;
6069 -- RPos (integer pointer case)
6071 when PC_RPos_NP =>
6072 Dout (Img (Node) & "matching RPos", Node.NP.all);
6074 if Cursor = (Length - Node.NP.all) then
6075 goto Succeed;
6076 else
6077 goto Fail;
6078 end if;
6080 -- RTab (integer case)
6082 when PC_RTab_Nat =>
6083 Dout (Img (Node) & "matching RTab", Node.Nat);
6085 if Cursor <= (Length - Node.Nat) then
6086 Cursor := Length - Node.Nat;
6087 goto Succeed;
6088 else
6089 goto Fail;
6090 end if;
6092 -- RTab (integer function case)
6094 when PC_RTab_NF => declare
6095 N : constant Natural := Node.NF.all;
6097 begin
6098 Dout (Img (Node) & "matching RPos", N);
6100 if Length - Cursor >= N then
6101 Cursor := Length - N;
6102 goto Succeed;
6103 else
6104 goto Fail;
6105 end if;
6106 end;
6108 -- RTab (integer pointer case)
6110 when PC_RTab_NP =>
6111 Dout (Img (Node) & "matching RPos", Node.NP.all);
6113 if Cursor <= (Length - Node.NP.all) then
6114 Cursor := Length - Node.NP.all;
6115 goto Succeed;
6116 else
6117 goto Fail;
6118 end if;
6120 -- Cursor assignment
6122 when PC_Setcur =>
6123 Dout (Img (Node) & "matching Setcur");
6124 Node.Var.all := Cursor;
6125 goto Succeed;
6127 -- Span (one character case)
6129 when PC_Span_CH => declare
6130 P : Natural := Cursor;
6132 begin
6133 Dout (Img (Node) & "matching Span", Node.Char);
6135 while P < Length
6136 and then Subject (P + 1) = Node.Char
6137 loop
6138 P := P + 1;
6139 end loop;
6141 if P /= Cursor then
6142 Cursor := P;
6143 goto Succeed;
6144 else
6145 goto Fail;
6146 end if;
6147 end;
6149 -- Span (character set case)
6151 when PC_Span_CS => declare
6152 P : Natural := Cursor;
6154 begin
6155 Dout (Img (Node) & "matching Span", Node.CS);
6157 while P < Length
6158 and then Is_In (Subject (P + 1), Node.CS)
6159 loop
6160 P := P + 1;
6161 end loop;
6163 if P /= Cursor then
6164 Cursor := P;
6165 goto Succeed;
6166 else
6167 goto Fail;
6168 end if;
6169 end;
6171 -- Span (string function case)
6173 when PC_Span_VF => declare
6174 U : constant VString := Node.VF.all;
6175 S : String_Access;
6176 L : Natural;
6177 P : Natural;
6179 begin
6180 Get_String (U, S, L);
6181 Dout (Img (Node) & "matching Span", S (1 .. L));
6183 P := Cursor;
6184 while P < Length
6185 and then Is_In (Subject (P + 1), S (1 .. L))
6186 loop
6187 P := P + 1;
6188 end loop;
6190 if P /= Cursor then
6191 Cursor := P;
6192 goto Succeed;
6193 else
6194 goto Fail;
6195 end if;
6196 end;
6198 -- Span (string pointer case)
6200 when PC_Span_VP => declare
6201 U : constant VString := Node.VP.all;
6202 S : String_Access;
6203 L : Natural;
6204 P : Natural;
6206 begin
6207 Get_String (U, S, L);
6208 Dout (Img (Node) & "matching Span", S (1 .. L));
6210 P := Cursor;
6211 while P < Length
6212 and then Is_In (Subject (P + 1), S (1 .. L))
6213 loop
6214 P := P + 1;
6215 end loop;
6217 if P /= Cursor then
6218 Cursor := P;
6219 goto Succeed;
6220 else
6221 goto Fail;
6222 end if;
6223 end;
6225 -- String (two character case)
6227 when PC_String_2 =>
6228 Dout (Img (Node) & "matching " & Image (Node.Str2));
6230 if (Length - Cursor) >= 2
6231 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
6232 then
6233 Cursor := Cursor + 2;
6234 goto Succeed;
6235 else
6236 goto Fail;
6237 end if;
6239 -- String (three character case)
6241 when PC_String_3 =>
6242 Dout (Img (Node) & "matching " & Image (Node.Str3));
6244 if (Length - Cursor) >= 3
6245 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
6246 then
6247 Cursor := Cursor + 3;
6248 goto Succeed;
6249 else
6250 goto Fail;
6251 end if;
6253 -- String (four character case)
6255 when PC_String_4 =>
6256 Dout (Img (Node) & "matching " & Image (Node.Str4));
6258 if (Length - Cursor) >= 4
6259 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
6260 then
6261 Cursor := Cursor + 4;
6262 goto Succeed;
6263 else
6264 goto Fail;
6265 end if;
6267 -- String (five character case)
6269 when PC_String_5 =>
6270 Dout (Img (Node) & "matching " & Image (Node.Str5));
6272 if (Length - Cursor) >= 5
6273 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
6274 then
6275 Cursor := Cursor + 5;
6276 goto Succeed;
6277 else
6278 goto Fail;
6279 end if;
6281 -- String (six character case)
6283 when PC_String_6 =>
6284 Dout (Img (Node) & "matching " & Image (Node.Str6));
6286 if (Length - Cursor) >= 6
6287 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
6288 then
6289 Cursor := Cursor + 6;
6290 goto Succeed;
6291 else
6292 goto Fail;
6293 end if;
6295 -- String (case of more than six characters)
6297 when PC_String => declare
6298 Len : constant Natural := Node.Str'Length;
6300 begin
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)
6305 then
6306 Cursor := Cursor + Len;
6307 goto Succeed;
6308 else
6309 goto Fail;
6310 end if;
6311 end;
6313 -- String (function case)
6315 when PC_String_VF => declare
6316 U : constant VString := Node.VF.all;
6317 S : String_Access;
6318 L : Natural;
6320 begin
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)
6326 then
6327 Cursor := Cursor + L;
6328 goto Succeed;
6329 else
6330 goto Fail;
6331 end if;
6332 end;
6334 -- String (vstring pointer case)
6336 when PC_String_VP => declare
6337 U : constant VString := Node.VP.all;
6338 S : String_Access;
6339 L : Natural;
6341 begin
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)
6347 then
6348 Cursor := Cursor + L;
6349 goto Succeed;
6350 else
6351 goto Fail;
6352 end if;
6353 end;
6355 -- Succeed
6357 when PC_Succeed =>
6358 Dout (Img (Node) & "matching Succeed");
6359 Push (Node);
6360 goto Succeed;
6362 -- Tab (integer case)
6364 when PC_Tab_Nat =>
6365 Dout (Img (Node) & "matching Tab", Node.Nat);
6367 if Cursor <= Node.Nat then
6368 Cursor := Node.Nat;
6369 goto Succeed;
6370 else
6371 goto Fail;
6372 end if;
6374 -- Tab (integer function case)
6376 when PC_Tab_NF => declare
6377 N : constant Natural := Node.NF.all;
6379 begin
6380 Dout (Img (Node) & "matching Tab ", N);
6382 if Cursor <= N then
6383 Cursor := N;
6384 goto Succeed;
6385 else
6386 goto Fail;
6387 end if;
6388 end;
6390 -- Tab (integer pointer case)
6392 when PC_Tab_NP =>
6393 Dout (Img (Node) & "matching Tab ", Node.NP.all);
6395 if Cursor <= Node.NP.all then
6396 Cursor := Node.NP.all;
6397 goto Succeed;
6398 else
6399 goto Fail;
6400 end if;
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
6410 goto Match_Fail;
6412 -- Otherwise extend the anchor point, and restack ourself
6414 else
6415 Cursor := Cursor + 1;
6416 Push (Node);
6417 goto Succeed;
6418 end if;
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));
6426 Put_Line
6427 (Node.FP.all,
6428 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6429 Pop_Region;
6430 goto Succeed;
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);
6438 Pop_Region;
6439 Assign_OnM := True;
6440 goto Succeed;
6442 end case;
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);
6449 Logic_Error;
6450 pragma Warnings (On);
6451 end XMatchD;
6453 end GNAT.Spitbol.Patterns;