File : g-spipat.adb
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-2015, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- Note: the data structures and general approach used in this implementation
33 -- are derived from the original MINIMAL sources for SPITBOL. The code is not
34 -- a direct translation, but the approach is followed closely. In particular,
35 -- we use the one stack approach developed in the SPITBOL implementation.
36
37 with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
38
39 with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
40
41 with System; use System;
42
43 with Ada.Unchecked_Conversion;
44 with Ada.Unchecked_Deallocation;
45
46 package body GNAT.Spitbol.Patterns is
47
48 ------------------------
49 -- Internal Debugging --
50 ------------------------
51
52 Internal_Debug : constant Boolean := False;
53 -- Set this flag to True to activate some built-in debugging traceback
54 -- These are all lines output with PutD and Put_LineD.
55
56 procedure New_LineD;
57 pragma Inline (New_LineD);
58 -- Output new blank line with New_Line if Internal_Debug is True
59
60 procedure PutD (Str : String);
61 pragma Inline (PutD);
62 -- Output string with Put if Internal_Debug is True
63
64 procedure Put_LineD (Str : String);
65 pragma Inline (Put_LineD);
66 -- Output string with Put_Line if Internal_Debug is True
67
68 -----------------------------
69 -- Local Type Declarations --
70 -----------------------------
71
72 subtype String_Ptr is Ada.Strings.Unbounded.String_Access;
73 subtype File_Ptr is Ada.Text_IO.File_Access;
74
75 function To_Address is new Ada.Unchecked_Conversion (PE_Ptr, Address);
76 -- Used only for debugging output purposes
77
78 subtype AFC is Ada.Finalization.Controlled;
79
80 N : constant PE_Ptr := null;
81 -- Shorthand used to initialize Copy fields to null
82
83 type Natural_Ptr is access all Natural;
84 type Pattern_Ptr is access all Pattern;
85
86 --------------------------------------------------
87 -- Description of Algorithm and Data Structures --
88 --------------------------------------------------
89
90 -- A pattern structure is represented as a linked graph of nodes
91 -- with the following structure:
92
93 -- +------------------------------------+
94 -- I Pcode I
95 -- +------------------------------------+
96 -- I Index I
97 -- +------------------------------------+
98 -- I Pthen I
99 -- +------------------------------------+
100 -- I parameter(s) I
101 -- +------------------------------------+
102
103 -- Pcode is a code value indicating the type of the pattern node. This
104 -- code is used both as the discriminant value for the record, and as
105 -- the case index in the main match routine that branches to the proper
106 -- match code for the given element.
107
108 -- Index is a serial index number. The use of these serial index
109 -- numbers is described in a separate section.
110
111 -- Pthen is a pointer to the successor node, i.e the node to be matched
112 -- if the attempt to match the node succeeds. If this is the last node
113 -- of the pattern to be matched, then Pthen points to a dummy node
114 -- of kind PC_EOP (end of pattern), which initializes pattern exit.
115
116 -- The parameter or parameters are present for certain node types,
117 -- and the type varies with the pattern code.
118
119 type Pattern_Code is (
120 PC_Arb_Y,
121 PC_Assign,
122 PC_Bal,
123 PC_BreakX_X,
124 PC_Cancel,
125 PC_EOP,
126 PC_Fail,
127 PC_Fence,
128 PC_Fence_X,
129 PC_Fence_Y,
130 PC_R_Enter,
131 PC_R_Remove,
132 PC_R_Restore,
133 PC_Rest,
134 PC_Succeed,
135 PC_Unanchored,
136
137 PC_Alt,
138 PC_Arb_X,
139 PC_Arbno_S,
140 PC_Arbno_X,
141
142 PC_Rpat,
143
144 PC_Pred_Func,
145
146 PC_Assign_Imm,
147 PC_Assign_OnM,
148 PC_Any_VP,
149 PC_Break_VP,
150 PC_BreakX_VP,
151 PC_NotAny_VP,
152 PC_NSpan_VP,
153 PC_Span_VP,
154 PC_String_VP,
155
156 PC_Write_Imm,
157 PC_Write_OnM,
158
159 PC_Null,
160 PC_String,
161
162 PC_String_2,
163 PC_String_3,
164 PC_String_4,
165 PC_String_5,
166 PC_String_6,
167
168 PC_Setcur,
169
170 PC_Any_CH,
171 PC_Break_CH,
172 PC_BreakX_CH,
173 PC_Char,
174 PC_NotAny_CH,
175 PC_NSpan_CH,
176 PC_Span_CH,
177
178 PC_Any_CS,
179 PC_Break_CS,
180 PC_BreakX_CS,
181 PC_NotAny_CS,
182 PC_NSpan_CS,
183 PC_Span_CS,
184
185 PC_Arbno_Y,
186 PC_Len_Nat,
187 PC_Pos_Nat,
188 PC_RPos_Nat,
189 PC_RTab_Nat,
190 PC_Tab_Nat,
191
192 PC_Pos_NF,
193 PC_Len_NF,
194 PC_RPos_NF,
195 PC_RTab_NF,
196 PC_Tab_NF,
197
198 PC_Pos_NP,
199 PC_Len_NP,
200 PC_RPos_NP,
201 PC_RTab_NP,
202 PC_Tab_NP,
203
204 PC_Any_VF,
205 PC_Break_VF,
206 PC_BreakX_VF,
207 PC_NotAny_VF,
208 PC_NSpan_VF,
209 PC_Span_VF,
210 PC_String_VF);
211
212 type IndexT is range 0 .. +(2 **15 - 1);
213
214 type PE (Pcode : Pattern_Code) is record
215
216 Index : IndexT;
217 -- Serial index number of pattern element within pattern
218
219 Pthen : PE_Ptr;
220 -- Successor element, to be matched after this one
221
222 case Pcode is
223
224 when PC_Arb_Y |
225 PC_Assign |
226 PC_Bal |
227 PC_BreakX_X |
228 PC_Cancel |
229 PC_EOP |
230 PC_Fail |
231 PC_Fence |
232 PC_Fence_X |
233 PC_Fence_Y |
234 PC_Null |
235 PC_R_Enter |
236 PC_R_Remove |
237 PC_R_Restore |
238 PC_Rest |
239 PC_Succeed |
240 PC_Unanchored => null;
241
242 when PC_Alt |
243 PC_Arb_X |
244 PC_Arbno_S |
245 PC_Arbno_X => Alt : PE_Ptr;
246
247 when PC_Rpat => PP : Pattern_Ptr;
248
249 when PC_Pred_Func => BF : Boolean_Func;
250
251 when PC_Assign_Imm |
252 PC_Assign_OnM |
253 PC_Any_VP |
254 PC_Break_VP |
255 PC_BreakX_VP |
256 PC_NotAny_VP |
257 PC_NSpan_VP |
258 PC_Span_VP |
259 PC_String_VP => VP : VString_Ptr;
260
261 when PC_Write_Imm |
262 PC_Write_OnM => FP : File_Ptr;
263
264 when PC_String => Str : String_Ptr;
265
266 when PC_String_2 => Str2 : String (1 .. 2);
267
268 when PC_String_3 => Str3 : String (1 .. 3);
269
270 when PC_String_4 => Str4 : String (1 .. 4);
271
272 when PC_String_5 => Str5 : String (1 .. 5);
273
274 when PC_String_6 => Str6 : String (1 .. 6);
275
276 when PC_Setcur => Var : Natural_Ptr;
277
278 when PC_Any_CH |
279 PC_Break_CH |
280 PC_BreakX_CH |
281 PC_Char |
282 PC_NotAny_CH |
283 PC_NSpan_CH |
284 PC_Span_CH => Char : Character;
285
286 when PC_Any_CS |
287 PC_Break_CS |
288 PC_BreakX_CS |
289 PC_NotAny_CS |
290 PC_NSpan_CS |
291 PC_Span_CS => CS : Character_Set;
292
293 when PC_Arbno_Y |
294 PC_Len_Nat |
295 PC_Pos_Nat |
296 PC_RPos_Nat |
297 PC_RTab_Nat |
298 PC_Tab_Nat => Nat : Natural;
299
300 when PC_Pos_NF |
301 PC_Len_NF |
302 PC_RPos_NF |
303 PC_RTab_NF |
304 PC_Tab_NF => NF : Natural_Func;
305
306 when PC_Pos_NP |
307 PC_Len_NP |
308 PC_RPos_NP |
309 PC_RTab_NP |
310 PC_Tab_NP => NP : Natural_Ptr;
311
312 when PC_Any_VF |
313 PC_Break_VF |
314 PC_BreakX_VF |
315 PC_NotAny_VF |
316 PC_NSpan_VF |
317 PC_Span_VF |
318 PC_String_VF => VF : VString_Func;
319
320 end case;
321 end record;
322
323 subtype PC_Has_Alt is Pattern_Code range PC_Alt .. PC_Arbno_X;
324 -- Range of pattern codes that has an Alt field. This is used in the
325 -- recursive traversals, since these links must be followed.
326
327 EOP_Element : aliased constant PE := (PC_EOP, 0, N);
328 -- This is the end of pattern element, and is thus the representation of
329 -- a null pattern. It has a zero index element since it is never placed
330 -- inside a pattern. Furthermore it does not need a successor, since it
331 -- marks the end of the pattern, so that no more successors are needed.
332
333 EOP : constant PE_Ptr := EOP_Element'Unrestricted_Access;
334 -- This is the end of pattern pointer, that is used in the Pthen pointer
335 -- of other nodes to signal end of pattern.
336
337 -- The following array is used to determine if a pattern used as an
338 -- argument for Arbno is eligible for treatment using the simple Arbno
339 -- structure (i.e. it is a pattern that is guaranteed to match at least
340 -- one character on success, and not to make any entries on the stack.
341
342 OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean :=
343 (PC_Any_CS |
344 PC_Any_CH |
345 PC_Any_VF |
346 PC_Any_VP |
347 PC_Char |
348 PC_Len_Nat |
349 PC_NotAny_CS |
350 PC_NotAny_CH |
351 PC_NotAny_VF |
352 PC_NotAny_VP |
353 PC_Span_CS |
354 PC_Span_CH |
355 PC_Span_VF |
356 PC_Span_VP |
357 PC_String |
358 PC_String_2 |
359 PC_String_3 |
360 PC_String_4 |
361 PC_String_5 |
362 PC_String_6 => True,
363 others => False);
364
365 -------------------------------
366 -- The Pattern History Stack --
367 -------------------------------
368
369 -- The pattern history stack is used for controlling backtracking when
370 -- a match fails. The idea is to stack entries that give a cursor value
371 -- to be restored, and a node to be reestablished as the current node to
372 -- attempt an appropriate rematch operation. The processing for a pattern
373 -- element that has rematch alternatives pushes an appropriate entry or
374 -- entry on to the stack, and the proceeds. If a match fails at any point,
375 -- the top element of the stack is popped off, resetting the cursor and
376 -- the match continues by accessing the node stored with this entry.
377
378 type Stack_Entry is record
379
380 Cursor : Integer;
381 -- Saved cursor value that is restored when this entry is popped
382 -- from the stack if a match attempt fails. Occasionally, this
383 -- field is used to store a history stack pointer instead of a
384 -- cursor. Such cases are noted in the documentation and the value
385 -- stored is negative since stack pointer values are always negative.
386
387 Node : PE_Ptr;
388 -- This pattern element reference is reestablished as the current
389 -- Node to be matched (which will attempt an appropriate rematch).
390
391 end record;
392
393 subtype Stack_Range is Integer range -Stack_Size .. -1;
394
395 type Stack_Type is array (Stack_Range) of Stack_Entry;
396 -- The type used for a history stack. The actual instance of the stack
397 -- is declared as a local variable in the Match routine, to properly
398 -- handle recursive calls to Match. All stack pointer values are negative
399 -- to distinguish them from normal cursor values.
400
401 -- Note: the pattern matching stack is used only to handle backtracking.
402 -- If no backtracking occurs, its entries are never accessed, and never
403 -- popped off, and in particular it is normal for a successful match
404 -- to terminate with entries on the stack that are simply discarded.
405
406 -- Note: in subsequent diagrams of the stack, we always place element
407 -- zero (the deepest element) at the top of the page, then build the
408 -- stack down on the page with the most recent (top of stack) element
409 -- being the bottom-most entry on the page.
410
411 -- Stack checking is handled by labeling every pattern with the maximum
412 -- number of stack entries that are required, so a single check at the
413 -- start of matching the pattern suffices. There are two exceptions.
414
415 -- First, the count does not include entries for recursive pattern
416 -- references. Such recursions must therefore perform a specific
417 -- stack check with respect to the number of stack entries required
418 -- by the recursive pattern that is accessed and the amount of stack
419 -- that remains unused.
420
421 -- Second, the count includes only one iteration of an Arbno pattern,
422 -- so a specific check must be made on subsequent iterations that there
423 -- is still enough stack space left. The Arbno node has a field that
424 -- records the number of stack entries required by its argument for
425 -- this purpose.
426
427 ---------------------------------------------------
428 -- Use of Serial Index Field in Pattern Elements --
429 ---------------------------------------------------
430
431 -- The serial index numbers for the pattern elements are assigned as
432 -- a pattern is constructed from its constituent elements. Note that there
433 -- is never any sharing of pattern elements between patterns (copies are
434 -- always made), so the serial index numbers are unique to a particular
435 -- pattern as referenced from the P field of a value of type Pattern.
436
437 -- The index numbers meet three separate invariants, which are used for
438 -- various purposes as described in this section.
439
440 -- First, the numbers uniquely identify the pattern elements within a
441 -- pattern. If Num is the number of elements in a given pattern, then
442 -- the serial index numbers for the elements of this pattern will range
443 -- from 1 .. Num, so that each element has a separate value.
444
445 -- The purpose of this assignment is to provide a convenient auxiliary
446 -- data structure mechanism during operations which must traverse a
447 -- pattern (e.g. copy and finalization processing). Once constructed
448 -- patterns are strictly read only. This is necessary to allow sharing
449 -- of patterns between tasks. This means that we cannot go marking the
450 -- pattern (e.g. with a visited bit). Instead we construct a separate
451 -- vector that contains the necessary information indexed by the Index
452 -- values in the pattern elements. For this purpose the only requirement
453 -- is that they be uniquely assigned.
454
455 -- Second, the pattern element referenced directly, i.e. the leading
456 -- pattern element, is always the maximum numbered element and therefore
457 -- indicates the total number of elements in the pattern. More precisely,
458 -- the element referenced by the P field of a pattern value, or the
459 -- element returned by any of the internal pattern construction routines
460 -- in the body (that return a value of type PE_Ptr) always is this
461 -- maximum element,
462
463 -- The purpose of this requirement is to allow an immediate determination
464 -- of the number of pattern elements within a pattern. This is used to
465 -- properly size the vectors used to contain auxiliary information for
466 -- traversal as described above.
467
468 -- Third, as compound pattern structures are constructed, the way in which
469 -- constituent parts of the pattern are constructed is stylized. This is
470 -- an automatic consequence of the way that these compound structures
471 -- are constructed, and basically what we are doing is simply documenting
472 -- and specifying the natural result of the pattern construction. The
473 -- section describing compound pattern structures gives details of the
474 -- numbering of each compound pattern structure.
475
476 -- The purpose of specifying the stylized numbering structures for the
477 -- compound patterns is to help simplify the processing in the Image
478 -- function, since it eases the task of retrieving the original recursive
479 -- structure of the pattern from the flat graph structure of elements.
480 -- This use in the Image function is the only point at which the code
481 -- makes use of the stylized structures.
482
483 type Ref_Array is array (IndexT range <>) of PE_Ptr;
484 -- This type is used to build an array whose N'th entry references the
485 -- element in a pattern whose Index value is N. See Build_Ref_Array.
486
487 procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array);
488 -- Given a pattern element which is the leading element of a pattern
489 -- structure, and a Ref_Array with bounds 1 .. E.Index, fills in the
490 -- Ref_Array so that its N'th entry references the element of the
491 -- referenced pattern whose Index value is N.
492
493 -------------------------------
494 -- Recursive Pattern Matches --
495 -------------------------------
496
497 -- The pattern primitive (+P) where P is a Pattern_Ptr or Pattern_Func
498 -- causes a recursive pattern match. This cannot be handled by an actual
499 -- recursive call to the outer level Match routine, since this would not
500 -- allow for possible backtracking into the region matched by the inner
501 -- pattern. Indeed this is the classical clash between recursion and
502 -- backtracking, and a simple recursive stack structure does not suffice.
503
504 -- This section describes how this recursion and the possible associated
505 -- backtracking is handled. We still use a single stack, but we establish
506 -- the concept of nested regions on this stack, each of which has a stack
507 -- base value pointing to the deepest stack entry of the region. The base
508 -- value for the outer level is zero.
509
510 -- When a recursive match is established, two special stack entries are
511 -- made. The first entry is used to save the original node that starts
512 -- the recursive match. This is saved so that the successor field of
513 -- this node is accessible at the end of the match, but it is never
514 -- popped and executed.
515
516 -- The second entry corresponds to a standard new region action. A
517 -- PC_R_Remove node is stacked, whose cursor field is used to store
518 -- the outer stack base, and the stack base is reset to point to
519 -- this PC_R_Remove node. Then the recursive pattern is matched and
520 -- it can make history stack entries in the normal matter, so now
521 -- the stack looks like:
522
523 -- (stack entries made by outer level)
524
525 -- (Special entry, node is (+P) successor
526 -- cursor entry is not used)
527
528 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack base
529 -- saved base value for the enclosing region)
530
531 -- (stack entries made by inner level)
532
533 -- If a subsequent failure occurs and pops the PC_R_Remove node, it
534 -- removes itself and the special entry immediately underneath it,
535 -- restores the stack base value for the enclosing region, and then
536 -- again signals failure to look for alternatives that were stacked
537 -- before the recursion was initiated.
538
539 -- Now we need to consider what happens if the inner pattern succeeds, as
540 -- signalled by accessing the special PC_EOP pattern primitive. First we
541 -- recognize the nested case by looking at the Base value. If this Base
542 -- value is Stack'First, then the entire match has succeeded, but if the
543 -- base value is greater than Stack'First, then we have successfully
544 -- matched an inner pattern, and processing continues at the outer level.
545
546 -- There are two cases. The simple case is when the inner pattern has made
547 -- no stack entries, as recognized by the fact that the current stack
548 -- pointer is equal to the current base value. In this case it is fine to
549 -- remove all trace of the recursion by restoring the outer base value and
550 -- using the special entry to find the appropriate successor node.
551
552 -- The more complex case arises when the inner match does make stack
553 -- entries. In this case, the PC_EOP processing stacks a special entry
554 -- whose cursor value saves the saved inner base value (the one that
555 -- references the corresponding PC_R_Remove value), and whose node
556 -- pointer references a PC_R_Restore node, so the stack looks like:
557
558 -- (stack entries made by outer level)
559
560 -- (Special entry, node is (+P) successor,
561 -- cursor entry is not used)
562
563 -- (PC_R_Remove entry, "cursor" value is (negative)
564 -- saved base value for the enclosing region)
565
566 -- (stack entries made by inner level)
567
568 -- (PC_Region_Replace entry, "cursor" value is (negative)
569 -- stack pointer value referencing the PC_R_Remove entry).
570
571 -- If the entire match succeeds, then these stack entries are, as usual,
572 -- ignored and abandoned. If on the other hand a subsequent failure
573 -- causes the PC_Region_Replace entry to be popped, it restores the
574 -- inner base value from its saved "cursor" value and then fails again.
575 -- Note that it is OK that the cursor is temporarily clobbered by this
576 -- pop, since the second failure will reestablish a proper cursor value.
577
578 ---------------------------------
579 -- Compound Pattern Structures --
580 ---------------------------------
581
582 -- This section discusses the compound structures used to represent
583 -- constructed patterns. It shows the graph structures of pattern
584 -- elements that are constructed, and in the case of patterns that
585 -- provide backtracking possibilities, describes how the history
586 -- stack is used to control the backtracking. Finally, it notes the
587 -- way in which the Index numbers are assigned to the structure.
588
589 -- In all diagrams, solid lines (built with minus signs or vertical
590 -- bars, represent successor pointers (Pthen fields) with > or V used
591 -- to indicate the direction of the pointer. The initial node of the
592 -- structure is in the upper left of the diagram. A dotted line is an
593 -- alternative pointer from the element above it to the element below
594 -- it. See individual sections for details on how alternatives are used.
595
596 -------------------
597 -- Concatenation --
598 -------------------
599
600 -- In the pattern structures listed in this section, a line that looks
601 -- like ----> with nothing to the right indicates an end of pattern
602 -- (EOP) pointer that represents the end of the match.
603
604 -- When a pattern concatenation (L & R) occurs, the resulting structure
605 -- is obtained by finding all such EOP pointers in L, and replacing
606 -- them to point to R. This is the most important flattening that
607 -- occurs in constructing a pattern, and it means that the pattern
608 -- matching circuitry does not have to keep track of the structure
609 -- of a pattern with respect to concatenation, since the appropriate
610 -- successor is always at hand.
611
612 -- Concatenation itself generates no additional possibilities for
613 -- backtracking, but the constituent patterns of the concatenated
614 -- structure will make stack entries as usual. The maximum amount
615 -- of stack required by the structure is thus simply the sum of the
616 -- maximums required by L and R.
617
618 -- The index numbering of a concatenation structure works by leaving
619 -- the numbering of the right hand pattern, R, unchanged and adjusting
620 -- the numbers in the left hand pattern, L up by the count of elements
621 -- in R. This ensures that the maximum numbered element is the leading
622 -- element as required (given that it was the leading element in L).
623
624 -----------------
625 -- Alternation --
626 -----------------
627
628 -- A pattern (L or R) constructs the structure:
629
630 -- +---+ +---+
631 -- | A |---->| L |---->
632 -- +---+ +---+
633 -- .
634 -- .
635 -- +---+
636 -- | R |---->
637 -- +---+
638
639 -- The A element here is a PC_Alt node, and the dotted line represents
640 -- the contents of the Alt field. When the PC_Alt element is matched,
641 -- it stacks a pointer to the leading element of R on the history stack
642 -- so that on subsequent failure, a match of R is attempted.
643
644 -- The A node is the highest numbered element in the pattern. The
645 -- original index numbers of R are unchanged, but the index numbers
646 -- of the L pattern are adjusted up by the count of elements in R.
647
648 -- Note that the difference between the index of the L leading element
649 -- the index of the R leading element (after building the alt structure)
650 -- indicates the number of nodes in L, and this is true even after the
651 -- structure is incorporated into some larger structure. For example,
652 -- if the A node has index 16, and L has index 15 and R has index
653 -- 5, then we know that L has 10 (15-5) elements in it.
654
655 -- Suppose that we now concatenate this structure to another pattern
656 -- with 9 elements in it. We will now have the A node with an index
657 -- of 25, L with an index of 24 and R with an index of 14. We still
658 -- know that L has 10 (24-14) elements in it, numbered 15-24, and
659 -- consequently the successor of the alternation structure has an
660 -- index with a value less than 15. This is used in Image to figure
661 -- out the original recursive structure of a pattern.
662
663 -- To clarify the interaction of the alternation and concatenation
664 -- structures, here is a more complex example of the structure built
665 -- for the pattern:
666
667 -- (V or W or X) (Y or Z)
668
669 -- where A,B,C,D,E are all single element patterns:
670
671 -- +---+ +---+ +---+ +---+
672 -- I A I---->I V I---+-->I A I---->I Y I---->
673 -- +---+ +---+ I +---+ +---+
674 -- . I .
675 -- . I .
676 -- +---+ +---+ I +---+
677 -- I A I---->I W I-->I I Z I---->
678 -- +---+ +---+ I +---+
679 -- . I
680 -- . I
681 -- +---+ I
682 -- I X I------------>+
683 -- +---+
684
685 -- The numbering of the nodes would be as follows:
686
687 -- +---+ +---+ +---+ +---+
688 -- I 8 I---->I 7 I---+-->I 3 I---->I 2 I---->
689 -- +---+ +---+ I +---+ +---+
690 -- . I .
691 -- . I .
692 -- +---+ +---+ I +---+
693 -- I 6 I---->I 5 I-->I I 1 I---->
694 -- +---+ +---+ I +---+
695 -- . I
696 -- . I
697 -- +---+ I
698 -- I 4 I------------>+
699 -- +---+
700
701 -- Note: The above structure actually corresponds to
702
703 -- (A or (B or C)) (D or E)
704
705 -- rather than
706
707 -- ((A or B) or C) (D or E)
708
709 -- which is the more natural interpretation, but in fact alternation
710 -- is associative, and the construction of an alternative changes the
711 -- left grouped pattern to the right grouped pattern in any case, so
712 -- that the Image function produces a more natural looking output.
713
714 ---------
715 -- Arb --
716 ---------
717
718 -- An Arb pattern builds the structure
719
720 -- +---+
721 -- | X |---->
722 -- +---+
723 -- .
724 -- .
725 -- +---+
726 -- | Y |---->
727 -- +---+
728
729 -- The X node is a PC_Arb_X node, which matches null, and stacks a
730 -- pointer to Y node, which is the PC_Arb_Y node that matches one
731 -- extra character and restacks itself.
732
733 -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1
734
735 -------------------------
736 -- Arbno (simple case) --
737 -------------------------
738
739 -- The simple form of Arbno can be used where the pattern always
740 -- matches at least one character if it succeeds, and it is known
741 -- not to make any history stack entries. In this case, Arbno (P)
742 -- can construct the following structure:
743
744 -- +-------------+
745 -- | ^
746 -- V |
747 -- +---+ |
748 -- | S |----> |
749 -- +---+ |
750 -- . |
751 -- . |
752 -- +---+ |
753 -- | P |---------->+
754 -- +---+
755
756 -- The S (PC_Arbno_S) node matches null stacking a pointer to the
757 -- pattern P. If a subsequent failure causes P to be matched and
758 -- this match succeeds, then node A gets restacked to try another
759 -- instance if needed by a subsequent failure.
760
761 -- The node numbering of the constituent pattern P is not affected.
762 -- The S node has a node number of P.Index + 1.
763
764 --------------------------
765 -- Arbno (complex case) --
766 --------------------------
767
768 -- A call to Arbno (P), where P can match null (or at least is not
769 -- known to require a non-null string) and/or P requires pattern stack
770 -- entries, constructs the following structure:
771
772 -- +--------------------------+
773 -- | ^
774 -- V |
775 -- +---+ |
776 -- | X |----> |
777 -- +---+ |
778 -- . |
779 -- . |
780 -- +---+ +---+ +---+ |
781 -- | E |---->| P |---->| Y |--->+
782 -- +---+ +---+ +---+
783
784 -- The node X (PC_Arbno_X) matches null, stacking a pointer to the
785 -- E-P-X structure used to match one Arbno instance.
786
787 -- Here E is the PC_R_Enter node which matches null and creates two
788 -- stack entries. The first is a special entry whose node field is
789 -- not used at all, and whose cursor field has the initial cursor.
790
791 -- The second entry corresponds to a standard new region action. A
792 -- PC_R_Remove node is stacked, whose cursor field is used to store
793 -- the outer stack base, and the stack base is reset to point to
794 -- this PC_R_Remove node. Then the pattern P is matched, and it can
795 -- make history stack entries in the normal manner, so now the stack
796 -- looks like:
797
798 -- (stack entries made before assign pattern)
799
800 -- (Special entry, node field not used,
801 -- used only to save initial cursor)
802
803 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
804 -- saved base value for the enclosing region)
805
806 -- (stack entries made by matching P)
807
808 -- If the match of P fails, then the PC_R_Remove entry is popped and
809 -- it removes both itself and the special entry underneath it,
810 -- restores the outer stack base, and signals failure.
811
812 -- If the match of P succeeds, then node Y, the PC_Arbno_Y node, pops
813 -- the inner region. There are two possibilities. If matching P left
814 -- no stack entries, then all traces of the inner region can be removed.
815 -- If there are stack entries, then we push an PC_Region_Replace stack
816 -- entry whose "cursor" value is the inner stack base value, and then
817 -- restore the outer stack base value, so the stack looks like:
818
819 -- (stack entries made before assign pattern)
820
821 -- (Special entry, node field not used,
822 -- used only to save initial cursor)
823
824 -- (PC_R_Remove entry, "cursor" value is (negative)
825 -- saved base value for the enclosing region)
826
827 -- (stack entries made by matching P)
828
829 -- (PC_Region_Replace entry, "cursor" value is (negative)
830 -- stack pointer value referencing the PC_R_Remove entry).
831
832 -- Now that we have matched another instance of the Arbno pattern,
833 -- we need to move to the successor. There are two cases. If the
834 -- Arbno pattern matched null, then there is no point in seeking
835 -- alternatives, since we would just match a whole bunch of nulls.
836 -- In this case we look through the alternative node, and move
837 -- directly to its successor (i.e. the successor of the Arbno
838 -- pattern). If on the other hand a non-null string was matched,
839 -- we simply follow the successor to the alternative node, which
840 -- sets up for another possible match of the Arbno pattern.
841
842 -- As noted in the section on stack checking, the stack count (and
843 -- hence the stack check) for a pattern includes only one iteration
844 -- of the Arbno pattern. To make sure that multiple iterations do not
845 -- overflow the stack, the Arbno node saves the stack count required
846 -- by a single iteration, and the Concat function increments this to
847 -- include stack entries required by any successor. The PC_Arbno_Y
848 -- node uses this count to ensure that sufficient stack remains
849 -- before proceeding after matching each new instance.
850
851 -- The node numbering of the constituent pattern P is not affected.
852 -- Where N is the number of nodes in P, the Y node is numbered N + 1,
853 -- the E node is N + 2, and the X node is N + 3.
854
855 ----------------------
856 -- Assign Immediate --
857 ----------------------
858
859 -- Immediate assignment (P * V) constructs the following structure
860
861 -- +---+ +---+ +---+
862 -- | E |---->| P |---->| A |---->
863 -- +---+ +---+ +---+
864
865 -- Here E is the PC_R_Enter node which matches null and creates two
866 -- stack entries. The first is a special entry whose node field is
867 -- not used at all, and whose cursor field has the initial cursor.
868
869 -- The second entry corresponds to a standard new region action. A
870 -- PC_R_Remove node is stacked, whose cursor field is used to store
871 -- the outer stack base, and the stack base is reset to point to
872 -- this PC_R_Remove node. Then the pattern P is matched, and it can
873 -- make history stack entries in the normal manner, so now the stack
874 -- looks like:
875
876 -- (stack entries made before assign pattern)
877
878 -- (Special entry, node field not used,
879 -- used only to save initial cursor)
880
881 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
882 -- saved base value for the enclosing region)
883
884 -- (stack entries made by matching P)
885
886 -- If the match of P fails, then the PC_R_Remove entry is popped
887 -- and it removes both itself and the special entry underneath it,
888 -- restores the outer stack base, and signals failure.
889
890 -- If the match of P succeeds, then node A, which is the actual
891 -- PC_Assign_Imm node, executes the assignment (using the stack
892 -- base to locate the entry with the saved starting cursor value),
893 -- and the pops the inner region. There are two possibilities, if
894 -- matching P left no stack entries, then all traces of the inner
895 -- region can be removed. If there are stack entries, then we push
896 -- an PC_Region_Replace stack entry whose "cursor" value is the
897 -- inner stack base value, and then restore the outer stack base
898 -- value, so the stack looks like:
899
900 -- (stack entries made before assign pattern)
901
902 -- (Special entry, node field not used,
903 -- used only to save initial cursor)
904
905 -- (PC_R_Remove entry, "cursor" value is (negative)
906 -- saved base value for the enclosing region)
907
908 -- (stack entries made by matching P)
909
910 -- (PC_Region_Replace entry, "cursor" value is the (negative)
911 -- stack pointer value referencing the PC_R_Remove entry).
912
913 -- If a subsequent failure occurs, the PC_Region_Replace node restores
914 -- the inner stack base value and signals failure to explore rematches
915 -- of the pattern P.
916
917 -- The node numbering of the constituent pattern P is not affected.
918 -- Where N is the number of nodes in P, the A node is numbered N + 1,
919 -- and the E node is N + 2.
920
921 ---------------------
922 -- Assign On Match --
923 ---------------------
924
925 -- The assign on match (**) pattern is quite similar to the assign
926 -- immediate pattern, except that the actual assignment has to be
927 -- delayed. The following structure is constructed:
928
929 -- +---+ +---+ +---+
930 -- | E |---->| P |---->| A |---->
931 -- +---+ +---+ +---+
932
933 -- The operation of this pattern is identical to that described above
934 -- for deferred assignment, up to the point where P has been matched.
935
936 -- The A node, which is the PC_Assign_OnM node first pushes a
937 -- PC_Assign node onto the history stack. This node saves the ending
938 -- cursor and acts as a flag for the final assignment, as further
939 -- described below.
940
941 -- It then stores a pointer to itself in the special entry node field.
942 -- This was otherwise unused, and is now used to retrieve the address
943 -- of the variable to be assigned at the end of the pattern.
944
945 -- After that the inner region is terminated in the usual manner,
946 -- by stacking a PC_R_Restore entry as described for the assign
947 -- immediate case. Note that the optimization of completely
948 -- removing the inner region does not happen in this case, since
949 -- we have at least one stack entry (the PC_Assign one we just made).
950 -- The stack now looks like:
951
952 -- (stack entries made before assign pattern)
953
954 -- (Special entry, node points to copy of
955 -- the PC_Assign_OnM node, and the
956 -- cursor field saves the initial cursor).
957
958 -- (PC_R_Remove entry, "cursor" value is (negative)
959 -- saved base value for the enclosing region)
960
961 -- (stack entries made by matching P)
962
963 -- (PC_Assign entry, saves final cursor)
964
965 -- (PC_Region_Replace entry, "cursor" value is (negative)
966 -- stack pointer value referencing the PC_R_Remove entry).
967
968 -- If a subsequent failure causes the PC_Assign node to execute it
969 -- simply removes itself and propagates the failure.
970
971 -- If the match succeeds, then the history stack is scanned for
972 -- PC_Assign nodes, and the assignments are executed (examination
973 -- of the above diagram will show that all the necessary data is
974 -- at hand for the assignment).
975
976 -- To optimize the common case where no assign-on-match operations
977 -- are present, a global flag Assign_OnM is maintained which is
978 -- initialize to False, and gets set True as part of the execution
979 -- of the PC_Assign_OnM node. The scan of the history stack for
980 -- PC_Assign entries is done only if this flag is set.
981
982 -- The node numbering of the constituent pattern P is not affected.
983 -- Where N is the number of nodes in P, the A node is numbered N + 1,
984 -- and the E node is N + 2.
985
986 ---------
987 -- Bal --
988 ---------
989
990 -- Bal builds a single node:
991
992 -- +---+
993 -- | B |---->
994 -- +---+
995
996 -- The node B is the PC_Bal node which matches a parentheses balanced
997 -- string, starting at the current cursor position. It then updates
998 -- the cursor past this matched string, and stacks a pointer to itself
999 -- with this updated cursor value on the history stack, to extend the
1000 -- matched string on a subsequent failure.
1001
1002 -- Since this is a single node it is numbered 1 (the reason we include
1003 -- it in the compound patterns section is that it backtracks).
1004
1005 ------------
1006 -- BreakX --
1007 ------------
1008
1009 -- BreakX builds the structure
1010
1011 -- +---+ +---+
1012 -- | B |---->| A |---->
1013 -- +---+ +---+
1014 -- ^ .
1015 -- | .
1016 -- | +---+
1017 -- +<------| X |
1018 -- +---+
1019
1020 -- Here the B node is the BreakX_xx node that performs a normal Break
1021 -- function. The A node is an alternative (PC_Alt) node that matches
1022 -- null, but stacks a pointer to node X (the PC_BreakX_X node) which
1023 -- extends the match one character (to eat up the previously detected
1024 -- break character), and then rematches the break.
1025
1026 -- The B node is numbered 3, the alternative node is 1, and the X
1027 -- node is 2.
1028
1029 -----------
1030 -- Fence --
1031 -----------
1032
1033 -- Fence builds a single node:
1034
1035 -- +---+
1036 -- | F |---->
1037 -- +---+
1038
1039 -- The element F, PC_Fence, matches null, and stacks a pointer to a
1040 -- PC_Cancel element which will abort the match on a subsequent failure.
1041
1042 -- Since this is a single element it is numbered 1 (the reason we
1043 -- include it in the compound patterns section is that it backtracks).
1044
1045 --------------------
1046 -- Fence Function --
1047 --------------------
1048
1049 -- A call to the Fence function builds the structure:
1050
1051 -- +---+ +---+ +---+
1052 -- | E |---->| P |---->| X |---->
1053 -- +---+ +---+ +---+
1054
1055 -- Here E is the PC_R_Enter node which matches null and creates two
1056 -- stack entries. The first is a special entry which is not used at
1057 -- all in the fence case (it is present merely for uniformity with
1058 -- other cases of region enter operations).
1059
1060 -- The second entry corresponds to a standard new region action. A
1061 -- PC_R_Remove node is stacked, whose cursor field is used to store
1062 -- the outer stack base, and the stack base is reset to point to
1063 -- this PC_R_Remove node. Then the pattern P is matched, and it can
1064 -- make history stack entries in the normal manner, so now the stack
1065 -- looks like:
1066
1067 -- (stack entries made before fence pattern)
1068
1069 -- (Special entry, not used at all)
1070
1071 -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base
1072 -- saved base value for the enclosing region)
1073
1074 -- (stack entries made by matching P)
1075
1076 -- If the match of P fails, then the PC_R_Remove entry is popped
1077 -- and it removes both itself and the special entry underneath it,
1078 -- restores the outer stack base, and signals failure.
1079
1080 -- If the match of P succeeds, then node X, the PC_Fence_X node, gets
1081 -- control. One might be tempted to think that at this point, the
1082 -- history stack entries made by matching P can just be removed since
1083 -- they certainly are not going to be used for rematching (that is
1084 -- whole point of Fence after all). However, this is wrong, because
1085 -- it would result in the loss of possible assign-on-match entries
1086 -- for deferred pattern assignments.
1087
1088 -- Instead what we do is to make a special entry whose node references
1089 -- PC_Fence_Y, and whose cursor saves the inner stack base value, i.e.
1090 -- the pointer to the PC_R_Remove entry. Then the outer stack base
1091 -- pointer is restored, so the stack looks like:
1092
1093 -- (stack entries made before assign pattern)
1094
1095 -- (Special entry, not used at all)
1096
1097 -- (PC_R_Remove entry, "cursor" value is (negative)
1098 -- saved base value for the enclosing region)
1099
1100 -- (stack entries made by matching P)
1101
1102 -- (PC_Fence_Y entry, "cursor" value is (negative) stack
1103 -- pointer value referencing the PC_R_Remove entry).
1104
1105 -- If a subsequent failure occurs, then the PC_Fence_Y entry removes
1106 -- the entire inner region, including all entries made by matching P,
1107 -- and alternatives prior to the Fence pattern are sought.
1108
1109 -- The node numbering of the constituent pattern P is not affected.
1110 -- Where N is the number of nodes in P, the X node is numbered N + 1,
1111 -- and the E node is N + 2.
1112
1113 -------------
1114 -- Succeed --
1115 -------------
1116
1117 -- Succeed builds a single node:
1118
1119 -- +---+
1120 -- | S |---->
1121 -- +---+
1122
1123 -- The node S is the PC_Succeed node which matches null, and stacks
1124 -- a pointer to itself on the history stack, so that a subsequent
1125 -- failure repeats the same match.
1126
1127 -- Since this is a single node it is numbered 1 (the reason we include
1128 -- it in the compound patterns section is that it backtracks).
1129
1130 ---------------------
1131 -- Write Immediate --
1132 ---------------------
1133
1134 -- The structure built for a write immediate operation (P * F, where
1135 -- F is a file access value) is:
1136
1137 -- +---+ +---+ +---+
1138 -- | E |---->| P |---->| W |---->
1139 -- +---+ +---+ +---+
1140
1141 -- Here E is the PC_R_Enter node and W is the PC_Write_Imm node. The
1142 -- handling is identical to that described above for Assign Immediate,
1143 -- except that at the point where a successful match occurs, the matched
1144 -- substring is written to the referenced file.
1145
1146 -- The node numbering of the constituent pattern P is not affected.
1147 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1148 -- and the E node is N + 2.
1149
1150 --------------------
1151 -- Write On Match --
1152 --------------------
1153
1154 -- The structure built for a write on match operation (P ** F, where
1155 -- F is a file access value) is:
1156
1157 -- +---+ +---+ +---+
1158 -- | E |---->| P |---->| W |---->
1159 -- +---+ +---+ +---+
1160
1161 -- Here E is the PC_R_Enter node and W is the PC_Write_OnM node. The
1162 -- handling is identical to that described above for Assign On Match,
1163 -- except that at the point where a successful match has completed,
1164 -- the matched substring is written to the referenced file.
1165
1166 -- The node numbering of the constituent pattern P is not affected.
1167 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1168 -- and the E node is N + 2.
1169 -----------------------
1170 -- Constant Patterns --
1171 -----------------------
1172
1173 -- The following pattern elements are referenced only from the pattern
1174 -- history stack. In each case the processing for the pattern element
1175 -- results in pattern match abort, or further failure, so there is no
1176 -- need for a successor and no need for a node number
1177
1178 CP_Assign : aliased PE := (PC_Assign, 0, N);
1179 CP_Cancel : aliased PE := (PC_Cancel, 0, N);
1180 CP_Fence_Y : aliased PE := (PC_Fence_Y, 0, N);
1181 CP_R_Remove : aliased PE := (PC_R_Remove, 0, N);
1182 CP_R_Restore : aliased PE := (PC_R_Restore, 0, N);
1183
1184 -----------------------
1185 -- Local Subprograms --
1186 -----------------------
1187
1188 function Alternate (L, R : PE_Ptr) return PE_Ptr;
1189 function "or" (L, R : PE_Ptr) return PE_Ptr renames Alternate;
1190 -- Build pattern structure corresponding to the alternation of L, R.
1191 -- (i.e. try to match L, and if that fails, try to match R).
1192
1193 function Arbno_Simple (P : PE_Ptr) return PE_Ptr;
1194 -- Build simple Arbno pattern, P is a pattern that is guaranteed to
1195 -- match at least one character if it succeeds and to require no
1196 -- stack entries under all circumstances. The result returned is
1197 -- a simple Arbno structure as previously described.
1198
1199 function Bracket (E, P, A : PE_Ptr) return PE_Ptr;
1200 -- Given two single node pattern elements E and A, and a (possible
1201 -- complex) pattern P, construct the concatenation E-->P-->A and
1202 -- return a pointer to E. The concatenation does not affect the
1203 -- node numbering in P. A has a number one higher than the maximum
1204 -- number in P, and E has a number two higher than the maximum
1205 -- number in P (see for example the Assign_Immediate structure to
1206 -- understand a typical use of this function).
1207
1208 function BreakX_Make (B : PE_Ptr) return Pattern;
1209 -- Given a pattern element for a Break pattern, returns the
1210 -- corresponding BreakX compound pattern structure.
1211
1212 function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr;
1213 -- Creates a pattern element that represents a concatenation of the
1214 -- two given pattern elements (i.e. the pattern L followed by R).
1215 -- The result returned is always the same as L, but the pattern
1216 -- referenced by L is modified to have R as a successor. This
1217 -- procedure does not copy L or R, so if a copy is required, it
1218 -- is the responsibility of the caller. The Incr parameter is an
1219 -- amount to be added to the Nat field of any P_Arbno_Y node that is
1220 -- in the left operand, it represents the additional stack space
1221 -- required by the right operand.
1222
1223 function C_To_PE (C : PChar) return PE_Ptr;
1224 -- Given a character, constructs a pattern element that matches
1225 -- the single character.
1226
1227 function Copy (P : PE_Ptr) return PE_Ptr;
1228 -- Creates a copy of the pattern element referenced by the given
1229 -- pattern element reference. This is a deep copy, which means that
1230 -- it follows the Next and Alt pointers.
1231
1232 function Image (P : PE_Ptr) return String;
1233 -- Returns the image of the address of the referenced pattern element.
1234 -- This is equivalent to Image (To_Address (P));
1235
1236 function Is_In (C : Character; Str : String) return Boolean;
1237 pragma Inline (Is_In);
1238 -- Determines if the character C is in string Str
1239
1240 procedure Logic_Error;
1241 -- Called to raise Program_Error with an appropriate message if an
1242 -- internal logic error is detected.
1243
1244 function Str_BF (A : Boolean_Func) return String;
1245 function Str_FP (A : File_Ptr) return String;
1246 function Str_NF (A : Natural_Func) return String;
1247 function Str_NP (A : Natural_Ptr) return String;
1248 function Str_PP (A : Pattern_Ptr) return String;
1249 function Str_VF (A : VString_Func) return String;
1250 function Str_VP (A : VString_Ptr) return String;
1251 -- These are debugging routines, which return a representation of the
1252 -- given access value (they are called only by Image and Dump)
1253
1254 procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr);
1255 -- Adjusts all EOP pointers in Pat to point to Succ. No other changes
1256 -- are made. In particular, Succ is unchanged, and no index numbers
1257 -- are modified. Note that Pat may not be equal to EOP on entry.
1258
1259 function S_To_PE (Str : PString) return PE_Ptr;
1260 -- Given a string, constructs a pattern element that matches the string
1261
1262 procedure Uninitialized_Pattern;
1263 pragma No_Return (Uninitialized_Pattern);
1264 -- Called to raise Program_Error with an appropriate error message if
1265 -- an uninitialized pattern is used in any pattern construction or
1266 -- pattern matching operation.
1267
1268 procedure XMatch
1269 (Subject : String;
1270 Pat_P : PE_Ptr;
1271 Pat_S : Natural;
1272 Start : out Natural;
1273 Stop : out Natural);
1274 -- This is the common pattern match routine. It is passed a string and
1275 -- a pattern, and it indicates success or failure, and on success the
1276 -- section of the string matched. It does not perform any assignments
1277 -- to the subject string, so pattern replacement is for the caller.
1278 --
1279 -- Subject The subject string. The lower bound is always one. In the
1280 -- Match procedures, it is fine to use strings whose lower bound
1281 -- is not one, but we perform a one time conversion before the
1282 -- call to XMatch, so that XMatch does not have to be bothered
1283 -- with strange lower bounds.
1284 --
1285 -- Pat_P Points to initial pattern element of pattern to be matched
1286 --
1287 -- Pat_S Maximum required stack entries for pattern to be matched
1288 --
1289 -- Start If match is successful, starting index of matched section.
1290 -- This value is always non-zero. A value of zero is used to
1291 -- indicate a failed match.
1292 --
1293 -- Stop If match is successful, ending index of matched section.
1294 -- This can be zero if we match the null string at the start,
1295 -- in which case Start is set to zero, and Stop to one. If the
1296 -- Match fails, then the contents of Stop is undefined.
1297
1298 procedure XMatchD
1299 (Subject : String;
1300 Pat_P : PE_Ptr;
1301 Pat_S : Natural;
1302 Start : out Natural;
1303 Stop : out Natural);
1304 -- Identical in all respects to XMatch, except that trace information is
1305 -- output on Standard_Output during execution of the match. This is the
1306 -- version that is called if the original Match call has Debug => True.
1307
1308 ---------
1309 -- "&" --
1310 ---------
1311
1312 function "&" (L : PString; R : Pattern) return Pattern is
1313 begin
1314 return (AFC with R.Stk, Concat (S_To_PE (L), Copy (R.P), R.Stk));
1315 end "&";
1316
1317 function "&" (L : Pattern; R : PString) return Pattern is
1318 begin
1319 return (AFC with L.Stk, Concat (Copy (L.P), S_To_PE (R), 0));
1320 end "&";
1321
1322 function "&" (L : PChar; R : Pattern) return Pattern is
1323 begin
1324 return (AFC with R.Stk, Concat (C_To_PE (L), Copy (R.P), R.Stk));
1325 end "&";
1326
1327 function "&" (L : Pattern; R : PChar) return Pattern is
1328 begin
1329 return (AFC with L.Stk, Concat (Copy (L.P), C_To_PE (R), 0));
1330 end "&";
1331
1332 function "&" (L : Pattern; R : Pattern) return Pattern is
1333 begin
1334 return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk));
1335 end "&";
1336
1337 ---------
1338 -- "*" --
1339 ---------
1340
1341 -- Assign immediate
1342
1343 -- +---+ +---+ +---+
1344 -- | E |---->| P |---->| A |---->
1345 -- +---+ +---+ +---+
1346
1347 -- The node numbering of the constituent pattern P is not affected.
1348 -- Where N is the number of nodes in P, the A node is numbered N + 1,
1349 -- and the E node is N + 2.
1350
1351 function "*" (P : Pattern; Var : VString_Var) return Pattern is
1352 Pat : constant PE_Ptr := Copy (P.P);
1353 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1354 A : constant PE_Ptr :=
1355 new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access);
1356 begin
1357 return (AFC with P.Stk + 3, Bracket (E, Pat, A));
1358 end "*";
1359
1360 function "*" (P : PString; Var : VString_Var) return Pattern is
1361 Pat : constant PE_Ptr := S_To_PE (P);
1362 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1363 A : constant PE_Ptr :=
1364 new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access);
1365 begin
1366 return (AFC with 3, Bracket (E, Pat, A));
1367 end "*";
1368
1369 function "*" (P : PChar; Var : VString_Var) return Pattern is
1370 Pat : constant PE_Ptr := C_To_PE (P);
1371 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1372 A : constant PE_Ptr :=
1373 new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access);
1374 begin
1375 return (AFC with 3, Bracket (E, Pat, A));
1376 end "*";
1377
1378 -- Write immediate
1379
1380 -- +---+ +---+ +---+
1381 -- | E |---->| P |---->| W |---->
1382 -- +---+ +---+ +---+
1383
1384 -- The node numbering of the constituent pattern P is not affected.
1385 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1386 -- and the E node is N + 2.
1387
1388 function "*" (P : Pattern; Fil : File_Access) return Pattern is
1389 Pat : constant PE_Ptr := Copy (P.P);
1390 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1391 W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil);
1392 begin
1393 return (AFC with 3, Bracket (E, Pat, W));
1394 end "*";
1395
1396 function "*" (P : PString; Fil : File_Access) return Pattern is
1397 Pat : constant PE_Ptr := S_To_PE (P);
1398 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1399 W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil);
1400 begin
1401 return (AFC with 3, Bracket (E, Pat, W));
1402 end "*";
1403
1404 function "*" (P : PChar; Fil : File_Access) return Pattern is
1405 Pat : constant PE_Ptr := C_To_PE (P);
1406 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1407 W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil);
1408 begin
1409 return (AFC with 3, Bracket (E, Pat, W));
1410 end "*";
1411
1412 ----------
1413 -- "**" --
1414 ----------
1415
1416 -- Assign on match
1417
1418 -- +---+ +---+ +---+
1419 -- | E |---->| P |---->| A |---->
1420 -- +---+ +---+ +---+
1421
1422 -- The node numbering of the constituent pattern P is not affected.
1423 -- Where N is the number of nodes in P, the A node is numbered N + 1,
1424 -- and the E node is N + 2.
1425
1426 function "**" (P : Pattern; Var : VString_Var) return Pattern is
1427 Pat : constant PE_Ptr := Copy (P.P);
1428 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1429 A : constant PE_Ptr :=
1430 new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access);
1431 begin
1432 return (AFC with P.Stk + 3, Bracket (E, Pat, A));
1433 end "**";
1434
1435 function "**" (P : PString; Var : VString_Var) return Pattern is
1436 Pat : constant PE_Ptr := S_To_PE (P);
1437 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1438 A : constant PE_Ptr :=
1439 new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access);
1440 begin
1441 return (AFC with 3, Bracket (E, Pat, A));
1442 end "**";
1443
1444 function "**" (P : PChar; Var : VString_Var) return Pattern is
1445 Pat : constant PE_Ptr := C_To_PE (P);
1446 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1447 A : constant PE_Ptr :=
1448 new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access);
1449 begin
1450 return (AFC with 3, Bracket (E, Pat, A));
1451 end "**";
1452
1453 -- Write on match
1454
1455 -- +---+ +---+ +---+
1456 -- | E |---->| P |---->| W |---->
1457 -- +---+ +---+ +---+
1458
1459 -- The node numbering of the constituent pattern P is not affected.
1460 -- Where N is the number of nodes in P, the W node is numbered N + 1,
1461 -- and the E node is N + 2.
1462
1463 function "**" (P : Pattern; Fil : File_Access) return Pattern is
1464 Pat : constant PE_Ptr := Copy (P.P);
1465 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1466 W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil);
1467 begin
1468 return (AFC with P.Stk + 3, Bracket (E, Pat, W));
1469 end "**";
1470
1471 function "**" (P : PString; Fil : File_Access) return Pattern is
1472 Pat : constant PE_Ptr := S_To_PE (P);
1473 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1474 W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil);
1475 begin
1476 return (AFC with 3, Bracket (E, Pat, W));
1477 end "**";
1478
1479 function "**" (P : PChar; Fil : File_Access) return Pattern is
1480 Pat : constant PE_Ptr := C_To_PE (P);
1481 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1482 W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil);
1483 begin
1484 return (AFC with 3, Bracket (E, Pat, W));
1485 end "**";
1486
1487 ---------
1488 -- "+" --
1489 ---------
1490
1491 function "+" (Str : VString_Var) return Pattern is
1492 begin
1493 return
1494 (AFC with 0,
1495 new PE'(PC_String_VP, 1, EOP, Str'Unrestricted_Access));
1496 end "+";
1497
1498 function "+" (Str : VString_Func) return Pattern is
1499 begin
1500 return (AFC with 0, new PE'(PC_String_VF, 1, EOP, Str));
1501 end "+";
1502
1503 function "+" (P : Pattern_Var) return Pattern is
1504 begin
1505 return
1506 (AFC with 3,
1507 new PE'(PC_Rpat, 1, EOP, P'Unrestricted_Access));
1508 end "+";
1509
1510 function "+" (P : Boolean_Func) return Pattern is
1511 begin
1512 return (AFC with 3, new PE'(PC_Pred_Func, 1, EOP, P));
1513 end "+";
1514
1515 ----------
1516 -- "or" --
1517 ----------
1518
1519 function "or" (L : PString; R : Pattern) return Pattern is
1520 begin
1521 return (AFC with R.Stk + 1, S_To_PE (L) or Copy (R.P));
1522 end "or";
1523
1524 function "or" (L : Pattern; R : PString) return Pattern is
1525 begin
1526 return (AFC with L.Stk + 1, Copy (L.P) or S_To_PE (R));
1527 end "or";
1528
1529 function "or" (L : PString; R : PString) return Pattern is
1530 begin
1531 return (AFC with 1, S_To_PE (L) or S_To_PE (R));
1532 end "or";
1533
1534 function "or" (L : Pattern; R : Pattern) return Pattern is
1535 begin
1536 return (AFC with
1537 Natural'Max (L.Stk, R.Stk) + 1, Copy (L.P) or Copy (R.P));
1538 end "or";
1539
1540 function "or" (L : PChar; R : Pattern) return Pattern is
1541 begin
1542 return (AFC with 1, C_To_PE (L) or Copy (R.P));
1543 end "or";
1544
1545 function "or" (L : Pattern; R : PChar) return Pattern is
1546 begin
1547 return (AFC with 1, Copy (L.P) or C_To_PE (R));
1548 end "or";
1549
1550 function "or" (L : PChar; R : PChar) return Pattern is
1551 begin
1552 return (AFC with 1, C_To_PE (L) or C_To_PE (R));
1553 end "or";
1554
1555 function "or" (L : PString; R : PChar) return Pattern is
1556 begin
1557 return (AFC with 1, S_To_PE (L) or C_To_PE (R));
1558 end "or";
1559
1560 function "or" (L : PChar; R : PString) return Pattern is
1561 begin
1562 return (AFC with 1, C_To_PE (L) or S_To_PE (R));
1563 end "or";
1564
1565 ------------
1566 -- Adjust --
1567 ------------
1568
1569 -- No two patterns share the same pattern elements, so the adjust
1570 -- procedure for a Pattern assignment must do a deep copy of the
1571 -- pattern element structure.
1572
1573 procedure Adjust (Object : in out Pattern) is
1574 begin
1575 Object.P := Copy (Object.P);
1576 end Adjust;
1577
1578 ---------------
1579 -- Alternate --
1580 ---------------
1581
1582 function Alternate (L, R : PE_Ptr) return PE_Ptr is
1583 begin
1584 -- If the left pattern is null, then we just add the alternation
1585 -- node with an index one greater than the right hand pattern.
1586
1587 if L = EOP then
1588 return new PE'(PC_Alt, R.Index + 1, EOP, R);
1589
1590 -- If the left pattern is non-null, then build a reference vector
1591 -- for its elements, and adjust their index values to accommodate
1592 -- the right hand elements. Then add the alternation node.
1593
1594 else
1595 declare
1596 Refs : Ref_Array (1 .. L.Index);
1597
1598 begin
1599 Build_Ref_Array (L, Refs);
1600
1601 for J in Refs'Range loop
1602 Refs (J).Index := Refs (J).Index + R.Index;
1603 end loop;
1604 end;
1605
1606 return new PE'(PC_Alt, L.Index + 1, L, R);
1607 end if;
1608 end Alternate;
1609
1610 ---------
1611 -- Any --
1612 ---------
1613
1614 function Any (Str : String) return Pattern is
1615 begin
1616 return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, To_Set (Str)));
1617 end Any;
1618
1619 function Any (Str : VString) return Pattern is
1620 begin
1621 return Any (S (Str));
1622 end Any;
1623
1624 function Any (Str : Character) return Pattern is
1625 begin
1626 return (AFC with 0, new PE'(PC_Any_CH, 1, EOP, Str));
1627 end Any;
1628
1629 function Any (Str : Character_Set) return Pattern is
1630 begin
1631 return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, Str));
1632 end Any;
1633
1634 function Any (Str : not null access VString) return Pattern is
1635 begin
1636 return (AFC with 0, new PE'(PC_Any_VP, 1, EOP, VString_Ptr (Str)));
1637 end Any;
1638
1639 function Any (Str : VString_Func) return Pattern is
1640 begin
1641 return (AFC with 0, new PE'(PC_Any_VF, 1, EOP, Str));
1642 end Any;
1643
1644 ---------
1645 -- Arb --
1646 ---------
1647
1648 -- +---+
1649 -- | X |---->
1650 -- +---+
1651 -- .
1652 -- .
1653 -- +---+
1654 -- | Y |---->
1655 -- +---+
1656
1657 -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1
1658
1659 function Arb return Pattern is
1660 Y : constant PE_Ptr := new PE'(PC_Arb_Y, 1, EOP);
1661 X : constant PE_Ptr := new PE'(PC_Arb_X, 2, EOP, Y);
1662 begin
1663 return (AFC with 1, X);
1664 end Arb;
1665
1666 -----------
1667 -- Arbno --
1668 -----------
1669
1670 function Arbno (P : PString) return Pattern is
1671 begin
1672 if P'Length = 0 then
1673 return (AFC with 0, EOP);
1674 else
1675 return (AFC with 0, Arbno_Simple (S_To_PE (P)));
1676 end if;
1677 end Arbno;
1678
1679 function Arbno (P : PChar) return Pattern is
1680 begin
1681 return (AFC with 0, Arbno_Simple (C_To_PE (P)));
1682 end Arbno;
1683
1684 function Arbno (P : Pattern) return Pattern is
1685 Pat : constant PE_Ptr := Copy (P.P);
1686
1687 begin
1688 if P.Stk = 0
1689 and then OK_For_Simple_Arbno (Pat.Pcode)
1690 then
1691 return (AFC with 0, Arbno_Simple (Pat));
1692 end if;
1693
1694 -- This is the complex case, either the pattern makes stack entries
1695 -- or it is possible for the pattern to match the null string (more
1696 -- accurately, we don't know that this is not the case).
1697
1698 -- +--------------------------+
1699 -- | ^
1700 -- V |
1701 -- +---+ |
1702 -- | X |----> |
1703 -- +---+ |
1704 -- . |
1705 -- . |
1706 -- +---+ +---+ +---+ |
1707 -- | E |---->| P |---->| Y |--->+
1708 -- +---+ +---+ +---+
1709
1710 -- The node numbering of the constituent pattern P is not affected.
1711 -- Where N is the number of nodes in P, the Y node is numbered N + 1,
1712 -- the E node is N + 2, and the X node is N + 3.
1713
1714 declare
1715 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
1716 X : constant PE_Ptr := new PE'(PC_Arbno_X, 0, EOP, E);
1717 Y : constant PE_Ptr := new PE'(PC_Arbno_Y, 0, X, P.Stk + 3);
1718 EPY : constant PE_Ptr := Bracket (E, Pat, Y);
1719 begin
1720 X.Alt := EPY;
1721 X.Index := EPY.Index + 1;
1722 return (AFC with P.Stk + 3, X);
1723 end;
1724 end Arbno;
1725
1726 ------------------
1727 -- Arbno_Simple --
1728 ------------------
1729
1730 -- +-------------+
1731 -- | ^
1732 -- V |
1733 -- +---+ |
1734 -- | S |----> |
1735 -- +---+ |
1736 -- . |
1737 -- . |
1738 -- +---+ |
1739 -- | P |---------->+
1740 -- +---+
1741
1742 -- The node numbering of the constituent pattern P is not affected.
1743 -- The S node has a node number of P.Index + 1.
1744
1745 -- Note that we know that P cannot be EOP, because a null pattern
1746 -- does not meet the requirements for simple Arbno.
1747
1748 function Arbno_Simple (P : PE_Ptr) return PE_Ptr is
1749 S : constant PE_Ptr := new PE'(PC_Arbno_S, P.Index + 1, EOP, P);
1750 begin
1751 Set_Successor (P, S);
1752 return S;
1753 end Arbno_Simple;
1754
1755 ---------
1756 -- Bal --
1757 ---------
1758
1759 function Bal return Pattern is
1760 begin
1761 return (AFC with 1, new PE'(PC_Bal, 1, EOP));
1762 end Bal;
1763
1764 -------------
1765 -- Bracket --
1766 -------------
1767
1768 function Bracket (E, P, A : PE_Ptr) return PE_Ptr is
1769 begin
1770 if P = EOP then
1771 E.Pthen := A;
1772 E.Index := 2;
1773 A.Index := 1;
1774
1775 else
1776 E.Pthen := P;
1777 Set_Successor (P, A);
1778 E.Index := P.Index + 2;
1779 A.Index := P.Index + 1;
1780 end if;
1781
1782 return E;
1783 end Bracket;
1784
1785 -----------
1786 -- Break --
1787 -----------
1788
1789 function Break (Str : String) return Pattern is
1790 begin
1791 return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, To_Set (Str)));
1792 end Break;
1793
1794 function Break (Str : VString) return Pattern is
1795 begin
1796 return Break (S (Str));
1797 end Break;
1798
1799 function Break (Str : Character) return Pattern is
1800 begin
1801 return (AFC with 0, new PE'(PC_Break_CH, 1, EOP, Str));
1802 end Break;
1803
1804 function Break (Str : Character_Set) return Pattern is
1805 begin
1806 return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, Str));
1807 end Break;
1808
1809 function Break (Str : not null access VString) return Pattern is
1810 begin
1811 return (AFC with 0,
1812 new PE'(PC_Break_VP, 1, EOP, Str.all'Unchecked_Access));
1813 end Break;
1814
1815 function Break (Str : VString_Func) return Pattern is
1816 begin
1817 return (AFC with 0, new PE'(PC_Break_VF, 1, EOP, Str));
1818 end Break;
1819
1820 ------------
1821 -- BreakX --
1822 ------------
1823
1824 function BreakX (Str : String) return Pattern is
1825 begin
1826 return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, To_Set (Str)));
1827 end BreakX;
1828
1829 function BreakX (Str : VString) return Pattern is
1830 begin
1831 return BreakX (S (Str));
1832 end BreakX;
1833
1834 function BreakX (Str : Character) return Pattern is
1835 begin
1836 return BreakX_Make (new PE'(PC_BreakX_CH, 3, N, Str));
1837 end BreakX;
1838
1839 function BreakX (Str : Character_Set) return Pattern is
1840 begin
1841 return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, Str));
1842 end BreakX;
1843
1844 function BreakX (Str : not null access VString) return Pattern is
1845 begin
1846 return BreakX_Make (new PE'(PC_BreakX_VP, 3, N, VString_Ptr (Str)));
1847 end BreakX;
1848
1849 function BreakX (Str : VString_Func) return Pattern is
1850 begin
1851 return BreakX_Make (new PE'(PC_BreakX_VF, 3, N, Str));
1852 end BreakX;
1853
1854 -----------------
1855 -- BreakX_Make --
1856 -----------------
1857
1858 -- +---+ +---+
1859 -- | B |---->| A |---->
1860 -- +---+ +---+
1861 -- ^ .
1862 -- | .
1863 -- | +---+
1864 -- +<------| X |
1865 -- +---+
1866
1867 -- The B node is numbered 3, the alternative node is 1, and the X
1868 -- node is 2.
1869
1870 function BreakX_Make (B : PE_Ptr) return Pattern is
1871 X : constant PE_Ptr := new PE'(PC_BreakX_X, 2, B);
1872 A : constant PE_Ptr := new PE'(PC_Alt, 1, EOP, X);
1873 begin
1874 B.Pthen := A;
1875 return (AFC with 2, B);
1876 end BreakX_Make;
1877
1878 ---------------------
1879 -- Build_Ref_Array --
1880 ---------------------
1881
1882 procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array) is
1883
1884 procedure Record_PE (E : PE_Ptr);
1885 -- Record given pattern element if not already recorded in RA,
1886 -- and also record any referenced pattern elements recursively.
1887
1888 ---------------
1889 -- Record_PE --
1890 ---------------
1891
1892 procedure Record_PE (E : PE_Ptr) is
1893 begin
1894 PutD (" Record_PE called with PE_Ptr = " & Image (E));
1895
1896 if E = EOP or else RA (E.Index) /= null then
1897 Put_LineD (", nothing to do");
1898 return;
1899
1900 else
1901 Put_LineD (", recording" & IndexT'Image (E.Index));
1902 RA (E.Index) := E;
1903 Record_PE (E.Pthen);
1904
1905 if E.Pcode in PC_Has_Alt then
1906 Record_PE (E.Alt);
1907 end if;
1908 end if;
1909 end Record_PE;
1910
1911 -- Start of processing for Build_Ref_Array
1912
1913 begin
1914 New_LineD;
1915 Put_LineD ("Entering Build_Ref_Array");
1916 Record_PE (E);
1917 New_LineD;
1918 end Build_Ref_Array;
1919
1920 -------------
1921 -- C_To_PE --
1922 -------------
1923
1924 function C_To_PE (C : PChar) return PE_Ptr is
1925 begin
1926 return new PE'(PC_Char, 1, EOP, C);
1927 end C_To_PE;
1928
1929 ------------
1930 -- Cancel --
1931 ------------
1932
1933 function Cancel return Pattern is
1934 begin
1935 return (AFC with 0, new PE'(PC_Cancel, 1, EOP));
1936 end Cancel;
1937
1938 ------------
1939 -- Concat --
1940 ------------
1941
1942 -- Concat needs to traverse the left operand performing the following
1943 -- set of fixups:
1944
1945 -- a) Any successor pointers (Pthen fields) that are set to EOP are
1946 -- reset to point to the second operand.
1947
1948 -- b) Any PC_Arbno_Y node has its stack count field incremented
1949 -- by the parameter Incr provided for this purpose.
1950
1951 -- d) Num fields of all pattern elements in the left operand are
1952 -- adjusted to include the elements of the right operand.
1953
1954 -- Note: we do not use Set_Successor in the processing for Concat, since
1955 -- there is no point in doing two traversals, we may as well do everything
1956 -- at the same time.
1957
1958 function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr is
1959 begin
1960 if L = EOP then
1961 return R;
1962
1963 elsif R = EOP then
1964 return L;
1965
1966 else
1967 declare
1968 Refs : Ref_Array (1 .. L.Index);
1969 -- We build a reference array for L whose N'th element points to
1970 -- the pattern element of L whose original Index value is N.
1971
1972 P : PE_Ptr;
1973
1974 begin
1975 Build_Ref_Array (L, Refs);
1976
1977 for J in Refs'Range loop
1978 P := Refs (J);
1979
1980 P.Index := P.Index + R.Index;
1981
1982 if P.Pcode = PC_Arbno_Y then
1983 P.Nat := P.Nat + Incr;
1984 end if;
1985
1986 if P.Pthen = EOP then
1987 P.Pthen := R;
1988 end if;
1989
1990 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
1991 P.Alt := R;
1992 end if;
1993 end loop;
1994 end;
1995
1996 return L;
1997 end if;
1998 end Concat;
1999
2000 ----------
2001 -- Copy --
2002 ----------
2003
2004 function Copy (P : PE_Ptr) return PE_Ptr is
2005 begin
2006 if P = null then
2007 Uninitialized_Pattern;
2008
2009 else
2010 declare
2011 Refs : Ref_Array (1 .. P.Index);
2012 -- References to elements in P, indexed by Index field
2013
2014 Copy : Ref_Array (1 .. P.Index);
2015 -- Holds copies of elements of P, indexed by Index field
2016
2017 E : PE_Ptr;
2018
2019 begin
2020 Build_Ref_Array (P, Refs);
2021
2022 -- Now copy all nodes
2023
2024 for J in Refs'Range loop
2025 Copy (J) := new PE'(Refs (J).all);
2026 end loop;
2027
2028 -- Adjust all internal references
2029
2030 for J in Copy'Range loop
2031 E := Copy (J);
2032
2033 -- Adjust successor pointer to point to copy
2034
2035 if E.Pthen /= EOP then
2036 E.Pthen := Copy (E.Pthen.Index);
2037 end if;
2038
2039 -- Adjust Alt pointer if there is one to point to copy
2040
2041 if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then
2042 E.Alt := Copy (E.Alt.Index);
2043 end if;
2044
2045 -- Copy referenced string
2046
2047 if E.Pcode = PC_String then
2048 E.Str := new String'(E.Str.all);
2049 end if;
2050 end loop;
2051
2052 return Copy (P.Index);
2053 end;
2054 end if;
2055 end Copy;
2056
2057 ----------
2058 -- Dump --
2059 ----------
2060
2061 procedure Dump (P : Pattern) is
2062
2063 subtype Count is Ada.Text_IO.Count;
2064 Scol : Count;
2065 -- Used to keep track of column in dump output
2066
2067 Refs : Ref_Array (1 .. P.P.Index);
2068 -- We build a reference array whose N'th element points to the
2069 -- pattern element whose Index value is N.
2070
2071 Cols : Natural := 2;
2072 -- Number of columns used for pattern numbers, minimum is 2
2073
2074 E : PE_Ptr;
2075
2076 procedure Write_Node_Id (E : PE_Ptr);
2077 -- Writes out a string identifying the given pattern element
2078
2079 -------------------
2080 -- Write_Node_Id --
2081 -------------------
2082
2083 procedure Write_Node_Id (E : PE_Ptr) is
2084 begin
2085 if E = EOP then
2086 Put ("EOP");
2087
2088 for J in 4 .. Cols loop
2089 Put (' ');
2090 end loop;
2091
2092 else
2093 declare
2094 Str : String (1 .. Cols);
2095 N : Natural := Natural (E.Index);
2096
2097 begin
2098 Put ("#");
2099
2100 for J in reverse Str'Range loop
2101 Str (J) := Character'Val (48 + N mod 10);
2102 N := N / 10;
2103 end loop;
2104
2105 Put (Str);
2106 end;
2107 end if;
2108 end Write_Node_Id;
2109
2110 -- Start of processing for Dump
2111
2112 begin
2113 New_Line;
2114 Put ("Pattern Dump Output (pattern at " &
2115 Image (P'Address) &
2116 ", S = " & Natural'Image (P.Stk) & ')');
2117
2118 Scol := Col;
2119 New_Line;
2120
2121 while Col < Scol loop
2122 Put ('-');
2123 end loop;
2124
2125 New_Line;
2126
2127 -- If uninitialized pattern, dump line and we are done
2128
2129 if P.P = null then
2130 Put_Line ("Uninitialized pattern value");
2131 return;
2132 end if;
2133
2134 -- If null pattern, just dump it and we are all done
2135
2136 if P.P = EOP then
2137 Put_Line ("EOP (null pattern)");
2138 return;
2139 end if;
2140
2141 Build_Ref_Array (P.P, Refs);
2142
2143 -- Set number of columns required for node numbers
2144
2145 while 10 ** Cols - 1 < Integer (P.P.Index) loop
2146 Cols := Cols + 1;
2147 end loop;
2148
2149 -- Now dump the nodes in reverse sequence. We output them in reverse
2150 -- sequence since this corresponds to the natural order used to
2151 -- construct the patterns.
2152
2153 for J in reverse Refs'Range loop
2154 E := Refs (J);
2155 Write_Node_Id (E);
2156 Set_Col (Count (Cols) + 4);
2157 Put (Image (E));
2158 Put (" ");
2159 Put (Pattern_Code'Image (E.Pcode));
2160 Put (" ");
2161 Set_Col (21 + Count (Cols) + Address_Image_Length);
2162 Write_Node_Id (E.Pthen);
2163 Set_Col (24 + 2 * Count (Cols) + Address_Image_Length);
2164
2165 case E.Pcode is
2166
2167 when PC_Alt |
2168 PC_Arb_X |
2169 PC_Arbno_S |
2170 PC_Arbno_X =>
2171 Write_Node_Id (E.Alt);
2172
2173 when PC_Rpat =>
2174 Put (Str_PP (E.PP));
2175
2176 when PC_Pred_Func =>
2177 Put (Str_BF (E.BF));
2178
2179 when PC_Assign_Imm |
2180 PC_Assign_OnM |
2181 PC_Any_VP |
2182 PC_Break_VP |
2183 PC_BreakX_VP |
2184 PC_NotAny_VP |
2185 PC_NSpan_VP |
2186 PC_Span_VP |
2187 PC_String_VP =>
2188 Put (Str_VP (E.VP));
2189
2190 when PC_Write_Imm |
2191 PC_Write_OnM =>
2192 Put (Str_FP (E.FP));
2193
2194 when PC_String =>
2195 Put (Image (E.Str.all));
2196
2197 when PC_String_2 =>
2198 Put (Image (E.Str2));
2199
2200 when PC_String_3 =>
2201 Put (Image (E.Str3));
2202
2203 when PC_String_4 =>
2204 Put (Image (E.Str4));
2205
2206 when PC_String_5 =>
2207 Put (Image (E.Str5));
2208
2209 when PC_String_6 =>
2210 Put (Image (E.Str6));
2211
2212 when PC_Setcur =>
2213 Put (Str_NP (E.Var));
2214
2215 when PC_Any_CH |
2216 PC_Break_CH |
2217 PC_BreakX_CH |
2218 PC_Char |
2219 PC_NotAny_CH |
2220 PC_NSpan_CH |
2221 PC_Span_CH =>
2222 Put (''' & E.Char & ''');
2223
2224 when PC_Any_CS |
2225 PC_Break_CS |
2226 PC_BreakX_CS |
2227 PC_NotAny_CS |
2228 PC_NSpan_CS |
2229 PC_Span_CS =>
2230 Put ('"' & To_Sequence (E.CS) & '"');
2231
2232 when PC_Arbno_Y |
2233 PC_Len_Nat |
2234 PC_Pos_Nat |
2235 PC_RPos_Nat |
2236 PC_RTab_Nat |
2237 PC_Tab_Nat =>
2238 Put (S (E.Nat));
2239
2240 when PC_Pos_NF |
2241 PC_Len_NF |
2242 PC_RPos_NF |
2243 PC_RTab_NF |
2244 PC_Tab_NF =>
2245 Put (Str_NF (E.NF));
2246
2247 when PC_Pos_NP |
2248 PC_Len_NP |
2249 PC_RPos_NP |
2250 PC_RTab_NP |
2251 PC_Tab_NP =>
2252 Put (Str_NP (E.NP));
2253
2254 when PC_Any_VF |
2255 PC_Break_VF |
2256 PC_BreakX_VF |
2257 PC_NotAny_VF |
2258 PC_NSpan_VF |
2259 PC_Span_VF |
2260 PC_String_VF =>
2261 Put (Str_VF (E.VF));
2262
2263 when others => null;
2264
2265 end case;
2266
2267 New_Line;
2268 end loop;
2269
2270 New_Line;
2271 end Dump;
2272
2273 ----------
2274 -- Fail --
2275 ----------
2276
2277 function Fail return Pattern is
2278 begin
2279 return (AFC with 0, new PE'(PC_Fail, 1, EOP));
2280 end Fail;
2281
2282 -----------
2283 -- Fence --
2284 -----------
2285
2286 -- Simple case
2287
2288 function Fence return Pattern is
2289 begin
2290 return (AFC with 1, new PE'(PC_Fence, 1, EOP));
2291 end Fence;
2292
2293 -- Function case
2294
2295 -- +---+ +---+ +---+
2296 -- | E |---->| P |---->| X |---->
2297 -- +---+ +---+ +---+
2298
2299 -- The node numbering of the constituent pattern P is not affected.
2300 -- Where N is the number of nodes in P, the X node is numbered N + 1,
2301 -- and the E node is N + 2.
2302
2303 function Fence (P : Pattern) return Pattern is
2304 Pat : constant PE_Ptr := Copy (P.P);
2305 E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP);
2306 X : constant PE_Ptr := new PE'(PC_Fence_X, 0, EOP);
2307 begin
2308 return (AFC with P.Stk + 1, Bracket (E, Pat, X));
2309 end Fence;
2310
2311 --------------
2312 -- Finalize --
2313 --------------
2314
2315 procedure Finalize (Object : in out Pattern) is
2316
2317 procedure Free is new Ada.Unchecked_Deallocation (PE, PE_Ptr);
2318 procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr);
2319
2320 begin
2321 -- Nothing to do if already freed
2322
2323 if Object.P = null then
2324 return;
2325
2326 -- Otherwise we must free all elements
2327
2328 else
2329 declare
2330 Refs : Ref_Array (1 .. Object.P.Index);
2331 -- References to elements in pattern to be finalized
2332
2333 begin
2334 Build_Ref_Array (Object.P, Refs);
2335
2336 for J in Refs'Range loop
2337 if Refs (J).Pcode = PC_String then
2338 Free (Refs (J).Str);
2339 end if;
2340
2341 Free (Refs (J));
2342 end loop;
2343
2344 Object.P := null;
2345 end;
2346 end if;
2347 end Finalize;
2348
2349 -----------
2350 -- Image --
2351 -----------
2352
2353 function Image (P : PE_Ptr) return String is
2354 begin
2355 return Image (To_Address (P));
2356 end Image;
2357
2358 function Image (P : Pattern) return String is
2359 begin
2360 return S (Image (P));
2361 end Image;
2362
2363 function Image (P : Pattern) return VString is
2364
2365 Kill_Ampersand : Boolean := False;
2366 -- Set True to delete next & to be output to Result
2367
2368 Result : VString := Nul;
2369 -- The result is accumulated here, using Append
2370
2371 Refs : Ref_Array (1 .. P.P.Index);
2372 -- We build a reference array whose N'th element points to the
2373 -- pattern element whose Index value is N.
2374
2375 procedure Delete_Ampersand;
2376 -- Deletes the ampersand at the end of Result
2377
2378 procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean);
2379 -- E refers to a pattern structure whose successor is given by Succ.
2380 -- This procedure appends to Result a representation of this pattern.
2381 -- The Paren parameter indicates whether parentheses are required if
2382 -- the output is more than one element.
2383
2384 procedure Image_One (E : in out PE_Ptr);
2385 -- E refers to a pattern structure. This procedure appends to Result
2386 -- a representation of the single simple or compound pattern structure
2387 -- at the start of E and updates E to point to its successor.
2388
2389 ----------------------
2390 -- Delete_Ampersand --
2391 ----------------------
2392
2393 procedure Delete_Ampersand is
2394 L : constant Natural := Length (Result);
2395 begin
2396 if L > 2 then
2397 Delete (Result, L - 1, L);
2398 end if;
2399 end Delete_Ampersand;
2400
2401 ---------------
2402 -- Image_One --
2403 ---------------
2404
2405 procedure Image_One (E : in out PE_Ptr) is
2406
2407 ER : PE_Ptr := E.Pthen;
2408 -- Successor set as result in E unless reset
2409
2410 begin
2411 case E.Pcode is
2412
2413 when PC_Cancel =>
2414 Append (Result, "Cancel");
2415
2416 when PC_Alt => Alt : declare
2417
2418 Elmts_In_L : constant IndexT := E.Pthen.Index - E.Alt.Index;
2419 -- Number of elements in left pattern of alternation
2420
2421 Lowest_In_L : constant IndexT := E.Index - Elmts_In_L;
2422 -- Number of lowest index in elements of left pattern
2423
2424 E1 : PE_Ptr;
2425
2426 begin
2427 -- The successor of the alternation node must have a lower
2428 -- index than any node that is in the left pattern or a
2429 -- higher index than the alternation node itself.
2430
2431 while ER /= EOP
2432 and then ER.Index >= Lowest_In_L
2433 and then ER.Index < E.Index
2434 loop
2435 ER := ER.Pthen;
2436 end loop;
2437
2438 Append (Result, '(');
2439
2440 E1 := E;
2441 loop
2442 Image_Seq (E1.Pthen, ER, False);
2443 Append (Result, " or ");
2444 E1 := E1.Alt;
2445 exit when E1.Pcode /= PC_Alt;
2446 end loop;
2447
2448 Image_Seq (E1, ER, False);
2449 Append (Result, ')');
2450 end Alt;
2451
2452 when PC_Any_CS =>
2453 Append (Result, "Any (" & Image (To_Sequence (E.CS)) & ')');
2454
2455 when PC_Any_VF =>
2456 Append (Result, "Any (" & Str_VF (E.VF) & ')');
2457
2458 when PC_Any_VP =>
2459 Append (Result, "Any (" & Str_VP (E.VP) & ')');
2460
2461 when PC_Arb_X =>
2462 Append (Result, "Arb");
2463
2464 when PC_Arbno_S =>
2465 Append (Result, "Arbno (");
2466 Image_Seq (E.Alt, E, False);
2467 Append (Result, ')');
2468
2469 when PC_Arbno_X =>
2470 Append (Result, "Arbno (");
2471 Image_Seq (E.Alt.Pthen, Refs (E.Index - 2), False);
2472 Append (Result, ')');
2473
2474 when PC_Assign_Imm =>
2475 Delete_Ampersand;
2476 Append (Result, "* " & Str_VP (Refs (E.Index).VP));
2477
2478 when PC_Assign_OnM =>
2479 Delete_Ampersand;
2480 Append (Result, "** " & Str_VP (Refs (E.Index).VP));
2481
2482 when PC_Any_CH =>
2483 Append (Result, "Any ('" & E.Char & "')");
2484
2485 when PC_Bal =>
2486 Append (Result, "Bal");
2487
2488 when PC_Break_CH =>
2489 Append (Result, "Break ('" & E.Char & "')");
2490
2491 when PC_Break_CS =>
2492 Append (Result, "Break (" & Image (To_Sequence (E.CS)) & ')');
2493
2494 when PC_Break_VF =>
2495 Append (Result, "Break (" & Str_VF (E.VF) & ')');
2496
2497 when PC_Break_VP =>
2498 Append (Result, "Break (" & Str_VP (E.VP) & ')');
2499
2500 when PC_BreakX_CH =>
2501 Append (Result, "BreakX ('" & E.Char & "')");
2502 ER := ER.Pthen;
2503
2504 when PC_BreakX_CS =>
2505 Append (Result, "BreakX (" & Image (To_Sequence (E.CS)) & ')');
2506 ER := ER.Pthen;
2507
2508 when PC_BreakX_VF =>
2509 Append (Result, "BreakX (" & Str_VF (E.VF) & ')');
2510 ER := ER.Pthen;
2511
2512 when PC_BreakX_VP =>
2513 Append (Result, "BreakX (" & Str_VP (E.VP) & ')');
2514 ER := ER.Pthen;
2515
2516 when PC_Char =>
2517 Append (Result, ''' & E.Char & ''');
2518
2519 when PC_Fail =>
2520 Append (Result, "Fail");
2521
2522 when PC_Fence =>
2523 Append (Result, "Fence");
2524
2525 when PC_Fence_X =>
2526 Append (Result, "Fence (");
2527 Image_Seq (E.Pthen, Refs (E.Index - 1), False);
2528 Append (Result, ")");
2529 ER := Refs (E.Index - 1).Pthen;
2530
2531 when PC_Len_Nat =>
2532 Append (Result, "Len (" & E.Nat & ')');
2533
2534 when PC_Len_NF =>
2535 Append (Result, "Len (" & Str_NF (E.NF) & ')');
2536
2537 when PC_Len_NP =>
2538 Append (Result, "Len (" & Str_NP (E.NP) & ')');
2539
2540 when PC_NotAny_CH =>
2541 Append (Result, "NotAny ('" & E.Char & "')");
2542
2543 when PC_NotAny_CS =>
2544 Append (Result, "NotAny (" & Image (To_Sequence (E.CS)) & ')');
2545
2546 when PC_NotAny_VF =>
2547 Append (Result, "NotAny (" & Str_VF (E.VF) & ')');
2548
2549 when PC_NotAny_VP =>
2550 Append (Result, "NotAny (" & Str_VP (E.VP) & ')');
2551
2552 when PC_NSpan_CH =>
2553 Append (Result, "NSpan ('" & E.Char & "')");
2554
2555 when PC_NSpan_CS =>
2556 Append (Result, "NSpan (" & Image (To_Sequence (E.CS)) & ')');
2557
2558 when PC_NSpan_VF =>
2559 Append (Result, "NSpan (" & Str_VF (E.VF) & ')');
2560
2561 when PC_NSpan_VP =>
2562 Append (Result, "NSpan (" & Str_VP (E.VP) & ')');
2563
2564 when PC_Null =>
2565 Append (Result, """""");
2566
2567 when PC_Pos_Nat =>
2568 Append (Result, "Pos (" & E.Nat & ')');
2569
2570 when PC_Pos_NF =>
2571 Append (Result, "Pos (" & Str_NF (E.NF) & ')');
2572
2573 when PC_Pos_NP =>
2574 Append (Result, "Pos (" & Str_NP (E.NP) & ')');
2575
2576 when PC_R_Enter =>
2577 Kill_Ampersand := True;
2578
2579 when PC_Rest =>
2580 Append (Result, "Rest");
2581
2582 when PC_Rpat =>
2583 Append (Result, "(+ " & Str_PP (E.PP) & ')');
2584
2585 when PC_Pred_Func =>
2586 Append (Result, "(+ " & Str_BF (E.BF) & ')');
2587
2588 when PC_RPos_Nat =>
2589 Append (Result, "RPos (" & E.Nat & ')');
2590
2591 when PC_RPos_NF =>
2592 Append (Result, "RPos (" & Str_NF (E.NF) & ')');
2593
2594 when PC_RPos_NP =>
2595 Append (Result, "RPos (" & Str_NP (E.NP) & ')');
2596
2597 when PC_RTab_Nat =>
2598 Append (Result, "RTab (" & E.Nat & ')');
2599
2600 when PC_RTab_NF =>
2601 Append (Result, "RTab (" & Str_NF (E.NF) & ')');
2602
2603 when PC_RTab_NP =>
2604 Append (Result, "RTab (" & Str_NP (E.NP) & ')');
2605
2606 when PC_Setcur =>
2607 Append (Result, "Setcur (" & Str_NP (E.Var) & ')');
2608
2609 when PC_Span_CH =>
2610 Append (Result, "Span ('" & E.Char & "')");
2611
2612 when PC_Span_CS =>
2613 Append (Result, "Span (" & Image (To_Sequence (E.CS)) & ')');
2614
2615 when PC_Span_VF =>
2616 Append (Result, "Span (" & Str_VF (E.VF) & ')');
2617
2618 when PC_Span_VP =>
2619 Append (Result, "Span (" & Str_VP (E.VP) & ')');
2620
2621 when PC_String =>
2622 Append (Result, Image (E.Str.all));
2623
2624 when PC_String_2 =>
2625 Append (Result, Image (E.Str2));
2626
2627 when PC_String_3 =>
2628 Append (Result, Image (E.Str3));
2629
2630 when PC_String_4 =>
2631 Append (Result, Image (E.Str4));
2632
2633 when PC_String_5 =>
2634 Append (Result, Image (E.Str5));
2635
2636 when PC_String_6 =>
2637 Append (Result, Image (E.Str6));
2638
2639 when PC_String_VF =>
2640 Append (Result, "(+" & Str_VF (E.VF) & ')');
2641
2642 when PC_String_VP =>
2643 Append (Result, "(+" & Str_VP (E.VP) & ')');
2644
2645 when PC_Succeed =>
2646 Append (Result, "Succeed");
2647
2648 when PC_Tab_Nat =>
2649 Append (Result, "Tab (" & E.Nat & ')');
2650
2651 when PC_Tab_NF =>
2652 Append (Result, "Tab (" & Str_NF (E.NF) & ')');
2653
2654 when PC_Tab_NP =>
2655 Append (Result, "Tab (" & Str_NP (E.NP) & ')');
2656
2657 when PC_Write_Imm =>
2658 Append (Result, '(');
2659 Image_Seq (E, Refs (E.Index - 1), True);
2660 Append (Result, " * " & Str_FP (Refs (E.Index - 1).FP));
2661 ER := Refs (E.Index - 1).Pthen;
2662
2663 when PC_Write_OnM =>
2664 Append (Result, '(');
2665 Image_Seq (E.Pthen, Refs (E.Index - 1), True);
2666 Append (Result, " ** " & Str_FP (Refs (E.Index - 1).FP));
2667 ER := Refs (E.Index - 1).Pthen;
2668
2669 -- Other pattern codes should not appear as leading elements
2670
2671 when PC_Arb_Y |
2672 PC_Arbno_Y |
2673 PC_Assign |
2674 PC_BreakX_X |
2675 PC_EOP |
2676 PC_Fence_Y |
2677 PC_R_Remove |
2678 PC_R_Restore |
2679 PC_Unanchored =>
2680 Append (Result, "???");
2681
2682 end case;
2683
2684 E := ER;
2685 end Image_One;
2686
2687 ---------------
2688 -- Image_Seq --
2689 ---------------
2690
2691 procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is
2692 Indx : constant Natural := Length (Result);
2693 E1 : PE_Ptr := E;
2694 Mult : Boolean := False;
2695
2696 begin
2697 -- The image of EOP is "" (the null string)
2698
2699 if E = EOP then
2700 Append (Result, """""");
2701
2702 -- Else generate appropriate concatenation sequence
2703
2704 else
2705 loop
2706 Image_One (E1);
2707 exit when E1 = Succ;
2708 exit when E1 = EOP;
2709 Mult := True;
2710
2711 if Kill_Ampersand then
2712 Kill_Ampersand := False;
2713 else
2714 Append (Result, " & ");
2715 end if;
2716 end loop;
2717 end if;
2718
2719 if Mult and Paren then
2720 Insert (Result, Indx + 1, "(");
2721 Append (Result, ")");
2722 end if;
2723 end Image_Seq;
2724
2725 -- Start of processing for Image
2726
2727 begin
2728 Build_Ref_Array (P.P, Refs);
2729 Image_Seq (P.P, EOP, False);
2730 return Result;
2731 end Image;
2732
2733 -----------
2734 -- Is_In --
2735 -----------
2736
2737 function Is_In (C : Character; Str : String) return Boolean is
2738 begin
2739 for J in Str'Range loop
2740 if Str (J) = C then
2741 return True;
2742 end if;
2743 end loop;
2744
2745 return False;
2746 end Is_In;
2747
2748 ---------
2749 -- Len --
2750 ---------
2751
2752 function Len (Count : Natural) return Pattern is
2753 begin
2754 -- Note, the following is not just an optimization, it is needed
2755 -- to ensure that Arbno (Len (0)) does not generate an infinite
2756 -- matching loop (since PC_Len_Nat is OK_For_Simple_Arbno).
2757
2758 if Count = 0 then
2759 return (AFC with 0, new PE'(PC_Null, 1, EOP));
2760
2761 else
2762 return (AFC with 0, new PE'(PC_Len_Nat, 1, EOP, Count));
2763 end if;
2764 end Len;
2765
2766 function Len (Count : Natural_Func) return Pattern is
2767 begin
2768 return (AFC with 0, new PE'(PC_Len_NF, 1, EOP, Count));
2769 end Len;
2770
2771 function Len (Count : not null access Natural) return Pattern is
2772 begin
2773 return (AFC with 0, new PE'(PC_Len_NP, 1, EOP, Natural_Ptr (Count)));
2774 end Len;
2775
2776 -----------------
2777 -- Logic_Error --
2778 -----------------
2779
2780 procedure Logic_Error is
2781 begin
2782 raise Program_Error with
2783 "Internal logic error in GNAT.Spitbol.Patterns";
2784 end Logic_Error;
2785
2786 -----------
2787 -- Match --
2788 -----------
2789
2790 function Match
2791 (Subject : VString;
2792 Pat : Pattern) return Boolean
2793 is
2794 S : Big_String_Access;
2795 L : Natural;
2796 Start : Natural;
2797 Stop : Natural;
2798 pragma Unreferenced (Stop);
2799
2800 begin
2801 Get_String (Subject, S, L);
2802
2803 if Debug_Mode then
2804 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2805 else
2806 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2807 end if;
2808
2809 return Start /= 0;
2810 end Match;
2811
2812 function Match
2813 (Subject : String;
2814 Pat : Pattern) return Boolean
2815 is
2816 Start, Stop : Natural;
2817 pragma Unreferenced (Stop);
2818
2819 subtype String1 is String (1 .. Subject'Length);
2820
2821 begin
2822 if Debug_Mode then
2823 XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2824 else
2825 XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2826 end if;
2827
2828 return Start /= 0;
2829 end Match;
2830
2831 function Match
2832 (Subject : VString_Var;
2833 Pat : Pattern;
2834 Replace : VString) return Boolean
2835 is
2836 Start : Natural;
2837 Stop : Natural;
2838 S : Big_String_Access;
2839 L : Natural;
2840
2841 begin
2842 Get_String (Subject, S, L);
2843
2844 if Debug_Mode then
2845 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2846 else
2847 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2848 end if;
2849
2850 if Start = 0 then
2851 return False;
2852 else
2853 Get_String (Replace, S, L);
2854 Replace_Slice
2855 (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
2856 return True;
2857 end if;
2858 end Match;
2859
2860 function Match
2861 (Subject : VString_Var;
2862 Pat : Pattern;
2863 Replace : String) return Boolean
2864 is
2865 Start : Natural;
2866 Stop : Natural;
2867 S : Big_String_Access;
2868 L : Natural;
2869
2870 begin
2871 Get_String (Subject, S, L);
2872
2873 if Debug_Mode then
2874 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2875 else
2876 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2877 end if;
2878
2879 if Start = 0 then
2880 return False;
2881 else
2882 Replace_Slice
2883 (Subject'Unrestricted_Access.all, Start, Stop, Replace);
2884 return True;
2885 end if;
2886 end Match;
2887
2888 procedure Match
2889 (Subject : VString;
2890 Pat : Pattern)
2891 is
2892 S : Big_String_Access;
2893 L : Natural;
2894
2895 Start : Natural;
2896 Stop : Natural;
2897 pragma Unreferenced (Start, Stop);
2898
2899 begin
2900 Get_String (Subject, S, L);
2901
2902 if Debug_Mode then
2903 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2904 else
2905 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2906 end if;
2907 end Match;
2908
2909 procedure Match
2910 (Subject : String;
2911 Pat : Pattern)
2912 is
2913 Start, Stop : Natural;
2914 pragma Unreferenced (Start, Stop);
2915
2916 subtype String1 is String (1 .. Subject'Length);
2917
2918 begin
2919 if Debug_Mode then
2920 XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2921 else
2922 XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop);
2923 end if;
2924 end Match;
2925
2926 procedure Match
2927 (Subject : in out VString;
2928 Pat : Pattern;
2929 Replace : VString)
2930 is
2931 Start : Natural;
2932 Stop : Natural;
2933 S : Big_String_Access;
2934 L : Natural;
2935
2936 begin
2937 Get_String (Subject, S, L);
2938
2939 if Debug_Mode then
2940 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2941 else
2942 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2943 end if;
2944
2945 if Start /= 0 then
2946 Get_String (Replace, S, L);
2947 Replace_Slice (Subject, Start, Stop, S (1 .. L));
2948 end if;
2949 end Match;
2950
2951 procedure Match
2952 (Subject : in out VString;
2953 Pat : Pattern;
2954 Replace : String)
2955 is
2956 Start : Natural;
2957 Stop : Natural;
2958 S : Big_String_Access;
2959 L : Natural;
2960
2961 begin
2962 Get_String (Subject, S, L);
2963
2964 if Debug_Mode then
2965 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2966 else
2967 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
2968 end if;
2969
2970 if Start /= 0 then
2971 Replace_Slice (Subject, Start, Stop, Replace);
2972 end if;
2973 end Match;
2974
2975 function Match
2976 (Subject : VString;
2977 Pat : PString) return Boolean
2978 is
2979 Pat_Len : constant Natural := Pat'Length;
2980 S : Big_String_Access;
2981 L : Natural;
2982
2983 begin
2984 Get_String (Subject, S, L);
2985
2986 if Anchored_Mode then
2987 if Pat_Len > L then
2988 return False;
2989 else
2990 return Pat = S (1 .. Pat_Len);
2991 end if;
2992
2993 else
2994 for J in 1 .. L - Pat_Len + 1 loop
2995 if Pat = S (J .. J + (Pat_Len - 1)) then
2996 return True;
2997 end if;
2998 end loop;
2999
3000 return False;
3001 end if;
3002 end Match;
3003
3004 function Match
3005 (Subject : String;
3006 Pat : PString) return Boolean
3007 is
3008 Pat_Len : constant Natural := Pat'Length;
3009 Sub_Len : constant Natural := Subject'Length;
3010 SFirst : constant Natural := Subject'First;
3011
3012 begin
3013 if Anchored_Mode then
3014 if Pat_Len > Sub_Len then
3015 return False;
3016 else
3017 return Pat = Subject (SFirst .. SFirst + Pat_Len - 1);
3018 end if;
3019
3020 else
3021 for J in SFirst .. SFirst + Sub_Len - Pat_Len loop
3022 if Pat = Subject (J .. J + (Pat_Len - 1)) then
3023 return True;
3024 end if;
3025 end loop;
3026
3027 return False;
3028 end if;
3029 end Match;
3030
3031 function Match
3032 (Subject : VString_Var;
3033 Pat : PString;
3034 Replace : VString) return Boolean
3035 is
3036 Start : Natural;
3037 Stop : Natural;
3038 S : Big_String_Access;
3039 L : Natural;
3040
3041 begin
3042 Get_String (Subject, S, L);
3043
3044 if Debug_Mode then
3045 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3046 else
3047 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3048 end if;
3049
3050 if Start = 0 then
3051 return False;
3052 else
3053 Get_String (Replace, S, L);
3054 Replace_Slice
3055 (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
3056 return True;
3057 end if;
3058 end Match;
3059
3060 function Match
3061 (Subject : VString_Var;
3062 Pat : PString;
3063 Replace : String) return Boolean
3064 is
3065 Start : Natural;
3066 Stop : Natural;
3067 S : Big_String_Access;
3068 L : Natural;
3069
3070 begin
3071 Get_String (Subject, S, L);
3072
3073 if Debug_Mode then
3074 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3075 else
3076 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3077 end if;
3078
3079 if Start = 0 then
3080 return False;
3081 else
3082 Replace_Slice
3083 (Subject'Unrestricted_Access.all, Start, Stop, Replace);
3084 return True;
3085 end if;
3086 end Match;
3087
3088 procedure Match
3089 (Subject : VString;
3090 Pat : PString)
3091 is
3092 S : Big_String_Access;
3093 L : Natural;
3094
3095 Start : Natural;
3096 Stop : Natural;
3097 pragma Unreferenced (Start, Stop);
3098
3099 begin
3100 Get_String (Subject, S, L);
3101
3102 if Debug_Mode then
3103 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3104 else
3105 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3106 end if;
3107 end Match;
3108
3109 procedure Match
3110 (Subject : String;
3111 Pat : PString)
3112 is
3113 Start, Stop : Natural;
3114 pragma Unreferenced (Start, Stop);
3115
3116 subtype String1 is String (1 .. Subject'Length);
3117
3118 begin
3119 if Debug_Mode then
3120 XMatchD (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
3121 else
3122 XMatch (String1 (Subject), S_To_PE (Pat), 0, Start, Stop);
3123 end if;
3124 end Match;
3125
3126 procedure Match
3127 (Subject : in out VString;
3128 Pat : PString;
3129 Replace : VString)
3130 is
3131 Start : Natural;
3132 Stop : Natural;
3133 S : Big_String_Access;
3134 L : Natural;
3135
3136 begin
3137 Get_String (Subject, S, L);
3138
3139 if Debug_Mode then
3140 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3141 else
3142 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3143 end if;
3144
3145 if Start /= 0 then
3146 Get_String (Replace, S, L);
3147 Replace_Slice (Subject, Start, Stop, S (1 .. L));
3148 end if;
3149 end Match;
3150
3151 procedure Match
3152 (Subject : in out VString;
3153 Pat : PString;
3154 Replace : String)
3155 is
3156 Start : Natural;
3157 Stop : Natural;
3158 S : Big_String_Access;
3159 L : Natural;
3160
3161 begin
3162 Get_String (Subject, S, L);
3163
3164 if Debug_Mode then
3165 XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3166 else
3167 XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
3168 end if;
3169
3170 if Start /= 0 then
3171 Replace_Slice (Subject, Start, Stop, Replace);
3172 end if;
3173 end Match;
3174
3175 function Match
3176 (Subject : VString_Var;
3177 Pat : Pattern;
3178 Result : Match_Result_Var) return Boolean
3179 is
3180 Start : Natural;
3181 Stop : Natural;
3182 S : Big_String_Access;
3183 L : Natural;
3184
3185 begin
3186 Get_String (Subject, S, L);
3187
3188 if Debug_Mode then
3189 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3190 else
3191 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3192 end if;
3193
3194 if Start = 0 then
3195 Result'Unrestricted_Access.all.Var := null;
3196 return False;
3197
3198 else
3199 Result'Unrestricted_Access.all.Var := Subject'Unrestricted_Access;
3200 Result'Unrestricted_Access.all.Start := Start;
3201 Result'Unrestricted_Access.all.Stop := Stop;
3202 return True;
3203 end if;
3204 end Match;
3205
3206 procedure Match
3207 (Subject : in out VString;
3208 Pat : Pattern;
3209 Result : out Match_Result)
3210 is
3211 Start : Natural;
3212 Stop : Natural;
3213 S : Big_String_Access;
3214 L : Natural;
3215
3216 begin
3217 Get_String (Subject, S, L);
3218
3219 if Debug_Mode then
3220 XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3221 else
3222 XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
3223 end if;
3224
3225 if Start = 0 then
3226 Result.Var := null;
3227 else
3228 Result.Var := Subject'Unrestricted_Access;
3229 Result.Start := Start;
3230 Result.Stop := Stop;
3231 end if;
3232 end Match;
3233
3234 ---------------
3235 -- New_LineD --
3236 ---------------
3237
3238 procedure New_LineD is
3239 begin
3240 if Internal_Debug then
3241 New_Line;
3242 end if;
3243 end New_LineD;
3244
3245 ------------
3246 -- NotAny --
3247 ------------
3248
3249 function NotAny (Str : String) return Pattern is
3250 begin
3251 return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, To_Set (Str)));
3252 end NotAny;
3253
3254 function NotAny (Str : VString) return Pattern is
3255 begin
3256 return NotAny (S (Str));
3257 end NotAny;
3258
3259 function NotAny (Str : Character) return Pattern is
3260 begin
3261 return (AFC with 0, new PE'(PC_NotAny_CH, 1, EOP, Str));
3262 end NotAny;
3263
3264 function NotAny (Str : Character_Set) return Pattern is
3265 begin
3266 return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str));
3267 end NotAny;
3268
3269 function NotAny (Str : not null access VString) return Pattern is
3270 begin
3271 return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str)));
3272 end NotAny;
3273
3274 function NotAny (Str : VString_Func) return Pattern is
3275 begin
3276 return (AFC with 0, new PE'(PC_NotAny_VF, 1, EOP, Str));
3277 end NotAny;
3278
3279 -----------
3280 -- NSpan --
3281 -----------
3282
3283 function NSpan (Str : String) return Pattern is
3284 begin
3285 return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, To_Set (Str)));
3286 end NSpan;
3287
3288 function NSpan (Str : VString) return Pattern is
3289 begin
3290 return NSpan (S (Str));
3291 end NSpan;
3292
3293 function NSpan (Str : Character) return Pattern is
3294 begin
3295 return (AFC with 0, new PE'(PC_NSpan_CH, 1, EOP, Str));
3296 end NSpan;
3297
3298 function NSpan (Str : Character_Set) return Pattern is
3299 begin
3300 return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str));
3301 end NSpan;
3302
3303 function NSpan (Str : not null access VString) return Pattern is
3304 begin
3305 return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str)));
3306 end NSpan;
3307
3308 function NSpan (Str : VString_Func) return Pattern is
3309 begin
3310 return (AFC with 0, new PE'(PC_NSpan_VF, 1, EOP, Str));
3311 end NSpan;
3312
3313 ---------
3314 -- Pos --
3315 ---------
3316
3317 function Pos (Count : Natural) return Pattern is
3318 begin
3319 return (AFC with 0, new PE'(PC_Pos_Nat, 1, EOP, Count));
3320 end Pos;
3321
3322 function Pos (Count : Natural_Func) return Pattern is
3323 begin
3324 return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count));
3325 end Pos;
3326
3327 function Pos (Count : not null access Natural) return Pattern is
3328 begin
3329 return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count)));
3330 end Pos;
3331
3332 ----------
3333 -- PutD --
3334 ----------
3335
3336 procedure PutD (Str : String) is
3337 begin
3338 if Internal_Debug then
3339 Put (Str);
3340 end if;
3341 end PutD;
3342
3343 ---------------
3344 -- Put_LineD --
3345 ---------------
3346
3347 procedure Put_LineD (Str : String) is
3348 begin
3349 if Internal_Debug then
3350 Put_Line (Str);
3351 end if;
3352 end Put_LineD;
3353
3354 -------------
3355 -- Replace --
3356 -------------
3357
3358 procedure Replace
3359 (Result : in out Match_Result;
3360 Replace : VString)
3361 is
3362 S : Big_String_Access;
3363 L : Natural;
3364
3365 begin
3366 Get_String (Replace, S, L);
3367
3368 if Result.Var /= null then
3369 Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L));
3370 Result.Var := null;
3371 end if;
3372 end Replace;
3373
3374 ----------
3375 -- Rest --
3376 ----------
3377
3378 function Rest return Pattern is
3379 begin
3380 return (AFC with 0, new PE'(PC_Rest, 1, EOP));
3381 end Rest;
3382
3383 ----------
3384 -- Rpos --
3385 ----------
3386
3387 function Rpos (Count : Natural) return Pattern is
3388 begin
3389 return (AFC with 0, new PE'(PC_RPos_Nat, 1, EOP, Count));
3390 end Rpos;
3391
3392 function Rpos (Count : Natural_Func) return Pattern is
3393 begin
3394 return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count));
3395 end Rpos;
3396
3397 function Rpos (Count : not null access Natural) return Pattern is
3398 begin
3399 return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count)));
3400 end Rpos;
3401
3402 ----------
3403 -- Rtab --
3404 ----------
3405
3406 function Rtab (Count : Natural) return Pattern is
3407 begin
3408 return (AFC with 0, new PE'(PC_RTab_Nat, 1, EOP, Count));
3409 end Rtab;
3410
3411 function Rtab (Count : Natural_Func) return Pattern is
3412 begin
3413 return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count));
3414 end Rtab;
3415
3416 function Rtab (Count : not null access Natural) return Pattern is
3417 begin
3418 return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count)));
3419 end Rtab;
3420
3421 -------------
3422 -- S_To_PE --
3423 -------------
3424
3425 function S_To_PE (Str : PString) return PE_Ptr is
3426 Len : constant Natural := Str'Length;
3427
3428 begin
3429 case Len is
3430 when 0 =>
3431 return new PE'(PC_Null, 1, EOP);
3432
3433 when 1 =>
3434 return new PE'(PC_Char, 1, EOP, Str (Str'First));
3435
3436 when 2 =>
3437 return new PE'(PC_String_2, 1, EOP, Str);
3438
3439 when 3 =>
3440 return new PE'(PC_String_3, 1, EOP, Str);
3441
3442 when 4 =>
3443 return new PE'(PC_String_4, 1, EOP, Str);
3444
3445 when 5 =>
3446 return new PE'(PC_String_5, 1, EOP, Str);
3447
3448 when 6 =>
3449 return new PE'(PC_String_6, 1, EOP, Str);
3450
3451 when others =>
3452 return new PE'(PC_String, 1, EOP, new String'(Str));
3453
3454 end case;
3455 end S_To_PE;
3456
3457 -------------------
3458 -- Set_Successor --
3459 -------------------
3460
3461 -- Note: this procedure is not used by the normal concatenation circuit,
3462 -- since other fixups are required on the left operand in this case, and
3463 -- they might as well be done all together.
3464
3465 procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is
3466 begin
3467 if Pat = null then
3468 Uninitialized_Pattern;
3469
3470 elsif Pat = EOP then
3471 Logic_Error;
3472
3473 else
3474 declare
3475 Refs : Ref_Array (1 .. Pat.Index);
3476 -- We build a reference array for L whose N'th element points to
3477 -- the pattern element of L whose original Index value is N.
3478
3479 P : PE_Ptr;
3480
3481 begin
3482 Build_Ref_Array (Pat, Refs);
3483
3484 for J in Refs'Range loop
3485 P := Refs (J);
3486
3487 if P.Pthen = EOP then
3488 P.Pthen := Succ;
3489 end if;
3490
3491 if P.Pcode in PC_Has_Alt and then P.Alt = EOP then
3492 P.Alt := Succ;
3493 end if;
3494 end loop;
3495 end;
3496 end if;
3497 end Set_Successor;
3498
3499 ------------
3500 -- Setcur --
3501 ------------
3502
3503 function Setcur (Var : not null access Natural) return Pattern is
3504 begin
3505 return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var)));
3506 end Setcur;
3507
3508 ----------
3509 -- Span --
3510 ----------
3511
3512 function Span (Str : String) return Pattern is
3513 begin
3514 return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, To_Set (Str)));
3515 end Span;
3516
3517 function Span (Str : VString) return Pattern is
3518 begin
3519 return Span (S (Str));
3520 end Span;
3521
3522 function Span (Str : Character) return Pattern is
3523 begin
3524 return (AFC with 0, new PE'(PC_Span_CH, 1, EOP, Str));
3525 end Span;
3526
3527 function Span (Str : Character_Set) return Pattern is
3528 begin
3529 return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str));
3530 end Span;
3531
3532 function Span (Str : not null access VString) return Pattern is
3533 begin
3534 return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str)));
3535 end Span;
3536
3537 function Span (Str : VString_Func) return Pattern is
3538 begin
3539 return (AFC with 0, new PE'(PC_Span_VF, 1, EOP, Str));
3540 end Span;
3541
3542 ------------
3543 -- Str_BF --
3544 ------------
3545
3546 function Str_BF (A : Boolean_Func) return String is
3547 function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address);
3548 begin
3549 return "BF(" & Image (To_A (A)) & ')';
3550 end Str_BF;
3551
3552 ------------
3553 -- Str_FP --
3554 ------------
3555
3556 function Str_FP (A : File_Ptr) return String is
3557 begin
3558 return "FP(" & Image (A.all'Address) & ')';
3559 end Str_FP;
3560
3561 ------------
3562 -- Str_NF --
3563 ------------
3564
3565 function Str_NF (A : Natural_Func) return String is
3566 function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address);
3567 begin
3568 return "NF(" & Image (To_A (A)) & ')';
3569 end Str_NF;
3570
3571 ------------
3572 -- Str_NP --
3573 ------------
3574
3575 function Str_NP (A : Natural_Ptr) return String is
3576 begin
3577 return "NP(" & Image (A.all'Address) & ')';
3578 end Str_NP;
3579
3580 ------------
3581 -- Str_PP --
3582 ------------
3583
3584 function Str_PP (A : Pattern_Ptr) return String is
3585 begin
3586 return "PP(" & Image (A.all'Address) & ')';
3587 end Str_PP;
3588
3589 ------------
3590 -- Str_VF --
3591 ------------
3592
3593 function Str_VF (A : VString_Func) return String is
3594 function To_A is new Ada.Unchecked_Conversion (VString_Func, Address);
3595 begin
3596 return "VF(" & Image (To_A (A)) & ')';
3597 end Str_VF;
3598
3599 ------------
3600 -- Str_VP --
3601 ------------
3602
3603 function Str_VP (A : VString_Ptr) return String is
3604 begin
3605 return "VP(" & Image (A.all'Address) & ')';
3606 end Str_VP;
3607
3608 -------------
3609 -- Succeed --
3610 -------------
3611
3612 function Succeed return Pattern is
3613 begin
3614 return (AFC with 1, new PE'(PC_Succeed, 1, EOP));
3615 end Succeed;
3616
3617 ---------
3618 -- Tab --
3619 ---------
3620
3621 function Tab (Count : Natural) return Pattern is
3622 begin
3623 return (AFC with 0, new PE'(PC_Tab_Nat, 1, EOP, Count));
3624 end Tab;
3625
3626 function Tab (Count : Natural_Func) return Pattern is
3627 begin
3628 return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count));
3629 end Tab;
3630
3631 function Tab (Count : not null access Natural) return Pattern is
3632 begin
3633 return (AFC with 0, new PE'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count)));
3634 end Tab;
3635
3636 ---------------------------
3637 -- Uninitialized_Pattern --
3638 ---------------------------
3639
3640 procedure Uninitialized_Pattern is
3641 begin
3642 raise Program_Error with
3643 "uninitialized value of type GNAT.Spitbol.Patterns.Pattern";
3644 end Uninitialized_Pattern;
3645
3646 ------------
3647 -- XMatch --
3648 ------------
3649
3650 procedure XMatch
3651 (Subject : String;
3652 Pat_P : PE_Ptr;
3653 Pat_S : Natural;
3654 Start : out Natural;
3655 Stop : out Natural)
3656 is
3657 Node : PE_Ptr;
3658 -- Pointer to current pattern node. Initialized from Pat_P, and then
3659 -- updated as the match proceeds through its constituent elements.
3660
3661 Length : constant Natural := Subject'Length;
3662 -- Length of string (= Subject'Last, since Subject'First is always 1)
3663
3664 Cursor : Integer := 0;
3665 -- If the value is non-negative, then this value is the index showing
3666 -- the current position of the match in the subject string. The next
3667 -- character to be matched is at Subject (Cursor + 1). Note that since
3668 -- our view of the subject string in XMatch always has a lower bound
3669 -- of one, regardless of original bounds, that this definition exactly
3670 -- corresponds to the cursor value as referenced by functions like Pos.
3671 --
3672 -- If the value is negative, then this is a saved stack pointer,
3673 -- typically a base pointer of an inner or outer region. Cursor
3674 -- temporarily holds such a value when it is popped from the stack
3675 -- by Fail. In all cases, Cursor is reset to a proper non-negative
3676 -- cursor value before the match proceeds (e.g. by propagating the
3677 -- failure and popping a "real" cursor value from the stack.
3678
3679 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
3680 -- Dummy pattern element used in the unanchored case
3681
3682 Stack : Stack_Type;
3683 -- The pattern matching failure stack for this call to Match
3684
3685 Stack_Ptr : Stack_Range;
3686 -- Current stack pointer. This points to the top element of the stack
3687 -- that is currently in use. At the outer level this is the special
3688 -- entry placed on the stack according to the anchor mode.
3689
3690 Stack_Init : constant Stack_Range := Stack'First + 1;
3691 -- This is the initial value of the Stack_Ptr and Stack_Base. The
3692 -- initial (Stack'First) element of the stack is not used so that
3693 -- when we pop the last element off, Stack_Ptr is still in range.
3694
3695 Stack_Base : Stack_Range;
3696 -- This value is the stack base value, i.e. the stack pointer for the
3697 -- first history stack entry in the current stack region. See separate
3698 -- section on handling of recursive pattern matches.
3699
3700 Assign_OnM : Boolean := False;
3701 -- Set True if assign-on-match or write-on-match operations may be
3702 -- present in the history stack, which must then be scanned on a
3703 -- successful match.
3704
3705 procedure Pop_Region;
3706 pragma Inline (Pop_Region);
3707 -- Used at the end of processing of an inner region. If the inner
3708 -- region left no stack entries, then all trace of it is removed.
3709 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
3710 -- handling of alternatives in the inner region.
3711
3712 procedure Push (Node : PE_Ptr);
3713 pragma Inline (Push);
3714 -- Make entry in pattern matching stack with current cursor value
3715
3716 procedure Push_Region;
3717 pragma Inline (Push_Region);
3718 -- This procedure makes a new region on the history stack. The
3719 -- caller first establishes the special entry on the stack, but
3720 -- does not push the stack pointer. Then this call stacks a
3721 -- PC_Remove_Region node, on top of this entry, using the cursor
3722 -- field of the PC_Remove_Region entry to save the outer level
3723 -- stack base value, and resets the stack base to point to this
3724 -- PC_Remove_Region node.
3725
3726 ----------------
3727 -- Pop_Region --
3728 ----------------
3729
3730 procedure Pop_Region is
3731 begin
3732 -- If nothing was pushed in the inner region, we can just get
3733 -- rid of it entirely, leaving no traces that it was ever there
3734
3735 if Stack_Ptr = Stack_Base then
3736 Stack_Ptr := Stack_Base - 2;
3737 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
3738
3739 -- If stuff was pushed in the inner region, then we have to
3740 -- push a PC_R_Restore node so that we properly handle possible
3741 -- rematches within the region.
3742
3743 else
3744 Stack_Ptr := Stack_Ptr + 1;
3745 Stack (Stack_Ptr).Cursor := Stack_Base;
3746 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
3747 Stack_Base := Stack (Stack_Base).Cursor;
3748 end if;
3749 end Pop_Region;
3750
3751 ----------
3752 -- Push --
3753 ----------
3754
3755 procedure Push (Node : PE_Ptr) is
3756 begin
3757 Stack_Ptr := Stack_Ptr + 1;
3758 Stack (Stack_Ptr).Cursor := Cursor;
3759 Stack (Stack_Ptr).Node := Node;
3760 end Push;
3761
3762 -----------------
3763 -- Push_Region --
3764 -----------------
3765
3766 procedure Push_Region is
3767 begin
3768 Stack_Ptr := Stack_Ptr + 2;
3769 Stack (Stack_Ptr).Cursor := Stack_Base;
3770 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
3771 Stack_Base := Stack_Ptr;
3772 end Push_Region;
3773
3774 -- Start of processing for XMatch
3775
3776 begin
3777 if Pat_P = null then
3778 Uninitialized_Pattern;
3779 end if;
3780
3781 -- Check we have enough stack for this pattern. This check deals with
3782 -- every possibility except a match of a recursive pattern, where we
3783 -- make a check at each recursion level.
3784
3785 if Pat_S >= Stack_Size - 1 then
3786 raise Pattern_Stack_Overflow;
3787 end if;
3788
3789 -- In anchored mode, the bottom entry on the stack is an abort entry
3790
3791 if Anchored_Mode then
3792 Stack (Stack_Init).Node := CP_Cancel'Access;
3793 Stack (Stack_Init).Cursor := 0;
3794
3795 -- In unanchored more, the bottom entry on the stack references
3796 -- the special pattern element PE_Unanchored, whose Pthen field
3797 -- points to the initial pattern element. The cursor value in this
3798 -- entry is the number of anchor moves so far.
3799
3800 else
3801 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
3802 Stack (Stack_Init).Cursor := 0;
3803 end if;
3804
3805 Stack_Ptr := Stack_Init;
3806 Stack_Base := Stack_Ptr;
3807 Cursor := 0;
3808 Node := Pat_P;
3809 goto Match;
3810
3811 -----------------------------------------
3812 -- Main Pattern Matching State Control --
3813 -----------------------------------------
3814
3815 -- This is a state machine which uses gotos to change state. The
3816 -- initial state is Match, to initiate the matching of the first
3817 -- element, so the goto Match above starts the match. In the
3818 -- following descriptions, we indicate the global values that
3819 -- are relevant for the state transition.
3820
3821 -- Come here if entire match fails
3822
3823 <<Match_Fail>>
3824 Start := 0;
3825 Stop := 0;
3826 return;
3827
3828 -- Come here if entire match succeeds
3829
3830 -- Cursor current position in subject string
3831
3832 <<Match_Succeed>>
3833 Start := Stack (Stack_Init).Cursor + 1;
3834 Stop := Cursor;
3835
3836 -- Scan history stack for deferred assignments or writes
3837
3838 if Assign_OnM then
3839 for S in Stack_Init .. Stack_Ptr loop
3840 if Stack (S).Node = CP_Assign'Access then
3841 declare
3842 Inner_Base : constant Stack_Range :=
3843 Stack (S + 1).Cursor;
3844 Special_Entry : constant Stack_Range :=
3845 Inner_Base - 1;
3846 Node_OnM : constant PE_Ptr :=
3847 Stack (Special_Entry).Node;
3848 Start : constant Natural :=
3849 Stack (Special_Entry).Cursor + 1;
3850 Stop : constant Natural := Stack (S).Cursor;
3851
3852 begin
3853 if Node_OnM.Pcode = PC_Assign_OnM then
3854 Set_Unbounded_String
3855 (Node_OnM.VP.all, Subject (Start .. Stop));
3856
3857 elsif Node_OnM.Pcode = PC_Write_OnM then
3858 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
3859
3860 else
3861 Logic_Error;
3862 end if;
3863 end;
3864 end if;
3865 end loop;
3866 end if;
3867
3868 return;
3869
3870 -- Come here if attempt to match current element fails
3871
3872 -- Stack_Base current stack base
3873 -- Stack_Ptr current stack pointer
3874
3875 <<Fail>>
3876 Cursor := Stack (Stack_Ptr).Cursor;
3877 Node := Stack (Stack_Ptr).Node;
3878 Stack_Ptr := Stack_Ptr - 1;
3879 goto Match;
3880
3881 -- Come here if attempt to match current element succeeds
3882
3883 -- Cursor current position in subject string
3884 -- Node pointer to node successfully matched
3885 -- Stack_Base current stack base
3886 -- Stack_Ptr current stack pointer
3887
3888 <<Succeed>>
3889 Node := Node.Pthen;
3890
3891 -- Come here to match the next pattern element
3892
3893 -- Cursor current position in subject string
3894 -- Node pointer to node to be matched
3895 -- Stack_Base current stack base
3896 -- Stack_Ptr current stack pointer
3897
3898 <<Match>>
3899
3900 --------------------------------------------------
3901 -- Main Pattern Match Element Matching Routines --
3902 --------------------------------------------------
3903
3904 -- Here is the case statement that processes the current node. The
3905 -- processing for each element does one of five things:
3906
3907 -- goto Succeed to move to the successor
3908 -- goto Match_Succeed if the entire match succeeds
3909 -- goto Match_Fail if the entire match fails
3910 -- goto Fail to signal failure of current match
3911
3912 -- Processing is NOT allowed to fall through
3913
3914 case Node.Pcode is
3915
3916 -- Cancel
3917
3918 when PC_Cancel =>
3919 goto Match_Fail;
3920
3921 -- Alternation
3922
3923 when PC_Alt =>
3924 Push (Node.Alt);
3925 Node := Node.Pthen;
3926 goto Match;
3927
3928 -- Any (one character case)
3929
3930 when PC_Any_CH =>
3931 if Cursor < Length
3932 and then Subject (Cursor + 1) = Node.Char
3933 then
3934 Cursor := Cursor + 1;
3935 goto Succeed;
3936 else
3937 goto Fail;
3938 end if;
3939
3940 -- Any (character set case)
3941
3942 when PC_Any_CS =>
3943 if Cursor < Length
3944 and then Is_In (Subject (Cursor + 1), Node.CS)
3945 then
3946 Cursor := Cursor + 1;
3947 goto Succeed;
3948 else
3949 goto Fail;
3950 end if;
3951
3952 -- Any (string function case)
3953
3954 when PC_Any_VF => declare
3955 U : constant VString := Node.VF.all;
3956 S : Big_String_Access;
3957 L : Natural;
3958
3959 begin
3960 Get_String (U, S, L);
3961
3962 if Cursor < Length
3963 and then Is_In (Subject (Cursor + 1), S (1 .. L))
3964 then
3965 Cursor := Cursor + 1;
3966 goto Succeed;
3967 else
3968 goto Fail;
3969 end if;
3970 end;
3971
3972 -- Any (string pointer case)
3973
3974 when PC_Any_VP => declare
3975 U : constant VString := Node.VP.all;
3976 S : Big_String_Access;
3977 L : Natural;
3978
3979 begin
3980 Get_String (U, S, L);
3981
3982 if Cursor < Length
3983 and then Is_In (Subject (Cursor + 1), S (1 .. L))
3984 then
3985 Cursor := Cursor + 1;
3986 goto Succeed;
3987 else
3988 goto Fail;
3989 end if;
3990 end;
3991
3992 -- Arb (initial match)
3993
3994 when PC_Arb_X =>
3995 Push (Node.Alt);
3996 Node := Node.Pthen;
3997 goto Match;
3998
3999 -- Arb (extension)
4000
4001 when PC_Arb_Y =>
4002 if Cursor < Length then
4003 Cursor := Cursor + 1;
4004 Push (Node);
4005 goto Succeed;
4006 else
4007 goto Fail;
4008 end if;
4009
4010 -- Arbno_S (simple Arbno initialize). This is the node that
4011 -- initiates the match of a simple Arbno structure.
4012
4013 when PC_Arbno_S =>
4014 Push (Node.Alt);
4015 Node := Node.Pthen;
4016 goto Match;
4017
4018 -- Arbno_X (Arbno initialize). This is the node that initiates
4019 -- the match of a complex Arbno structure.
4020
4021 when PC_Arbno_X =>
4022 Push (Node.Alt);
4023 Node := Node.Pthen;
4024 goto Match;
4025
4026 -- Arbno_Y (Arbno rematch). This is the node that is executed
4027 -- following successful matching of one instance of a complex
4028 -- Arbno pattern.
4029
4030 when PC_Arbno_Y => declare
4031 Null_Match : constant Boolean :=
4032 Cursor = Stack (Stack_Base - 1).Cursor;
4033
4034 begin
4035 Pop_Region;
4036
4037 -- If arbno extension matched null, then immediately fail
4038
4039 if Null_Match then
4040 goto Fail;
4041 end if;
4042
4043 -- Here we must do a stack check to make sure enough stack
4044 -- is left. This check will happen once for each instance of
4045 -- the Arbno pattern that is matched. The Nat field of a
4046 -- PC_Arbno pattern contains the maximum stack entries needed
4047 -- for the Arbno with one instance and the successor pattern
4048
4049 if Stack_Ptr + Node.Nat >= Stack'Last then
4050 raise Pattern_Stack_Overflow;
4051 end if;
4052
4053 goto Succeed;
4054 end;
4055
4056 -- Assign. If this node is executed, it means the assign-on-match
4057 -- or write-on-match operation will not happen after all, so we
4058 -- is propagate the failure, removing the PC_Assign node.
4059
4060 when PC_Assign =>
4061 goto Fail;
4062
4063 -- Assign immediate. This node performs the actual assignment
4064
4065 when PC_Assign_Imm =>
4066 Set_Unbounded_String
4067 (Node.VP.all,
4068 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4069 Pop_Region;
4070 goto Succeed;
4071
4072 -- Assign on match. This node sets up for the eventual assignment
4073
4074 when PC_Assign_OnM =>
4075 Stack (Stack_Base - 1).Node := Node;
4076 Push (CP_Assign'Access);
4077 Pop_Region;
4078 Assign_OnM := True;
4079 goto Succeed;
4080
4081 -- Bal
4082
4083 when PC_Bal =>
4084 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
4085 goto Fail;
4086
4087 elsif Subject (Cursor + 1) = '(' then
4088 declare
4089 Paren_Count : Natural := 1;
4090
4091 begin
4092 loop
4093 Cursor := Cursor + 1;
4094
4095 if Cursor >= Length then
4096 goto Fail;
4097
4098 elsif Subject (Cursor + 1) = '(' then
4099 Paren_Count := Paren_Count + 1;
4100
4101 elsif Subject (Cursor + 1) = ')' then
4102 Paren_Count := Paren_Count - 1;
4103 exit when Paren_Count = 0;
4104 end if;
4105 end loop;
4106 end;
4107 end if;
4108
4109 Cursor := Cursor + 1;
4110 Push (Node);
4111 goto Succeed;
4112
4113 -- Break (one character case)
4114
4115 when PC_Break_CH =>
4116 while Cursor < Length loop
4117 if Subject (Cursor + 1) = Node.Char then
4118 goto Succeed;
4119 else
4120 Cursor := Cursor + 1;
4121 end if;
4122 end loop;
4123
4124 goto Fail;
4125
4126 -- Break (character set case)
4127
4128 when PC_Break_CS =>
4129 while Cursor < Length loop
4130 if Is_In (Subject (Cursor + 1), Node.CS) then
4131 goto Succeed;
4132 else
4133 Cursor := Cursor + 1;
4134 end if;
4135 end loop;
4136
4137 goto Fail;
4138
4139 -- Break (string function case)
4140
4141 when PC_Break_VF => declare
4142 U : constant VString := Node.VF.all;
4143 S : Big_String_Access;
4144 L : Natural;
4145
4146 begin
4147 Get_String (U, S, L);
4148
4149 while Cursor < Length loop
4150 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4151 goto Succeed;
4152 else
4153 Cursor := Cursor + 1;
4154 end if;
4155 end loop;
4156
4157 goto Fail;
4158 end;
4159
4160 -- Break (string pointer case)
4161
4162 when PC_Break_VP => declare
4163 U : constant VString := Node.VP.all;
4164 S : Big_String_Access;
4165 L : Natural;
4166
4167 begin
4168 Get_String (U, S, L);
4169
4170 while Cursor < Length loop
4171 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4172 goto Succeed;
4173 else
4174 Cursor := Cursor + 1;
4175 end if;
4176 end loop;
4177
4178 goto Fail;
4179 end;
4180
4181 -- BreakX (one character case)
4182
4183 when PC_BreakX_CH =>
4184 while Cursor < Length loop
4185 if Subject (Cursor + 1) = Node.Char then
4186 goto Succeed;
4187 else
4188 Cursor := Cursor + 1;
4189 end if;
4190 end loop;
4191
4192 goto Fail;
4193
4194 -- BreakX (character set case)
4195
4196 when PC_BreakX_CS =>
4197 while Cursor < Length loop
4198 if Is_In (Subject (Cursor + 1), Node.CS) then
4199 goto Succeed;
4200 else
4201 Cursor := Cursor + 1;
4202 end if;
4203 end loop;
4204
4205 goto Fail;
4206
4207 -- BreakX (string function case)
4208
4209 when PC_BreakX_VF => declare
4210 U : constant VString := Node.VF.all;
4211 S : Big_String_Access;
4212 L : Natural;
4213
4214 begin
4215 Get_String (U, S, L);
4216
4217 while Cursor < Length loop
4218 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4219 goto Succeed;
4220 else
4221 Cursor := Cursor + 1;
4222 end if;
4223 end loop;
4224
4225 goto Fail;
4226 end;
4227
4228 -- BreakX (string pointer case)
4229
4230 when PC_BreakX_VP => declare
4231 U : constant VString := Node.VP.all;
4232 S : Big_String_Access;
4233 L : Natural;
4234
4235 begin
4236 Get_String (U, S, L);
4237
4238 while Cursor < Length loop
4239 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
4240 goto Succeed;
4241 else
4242 Cursor := Cursor + 1;
4243 end if;
4244 end loop;
4245
4246 goto Fail;
4247 end;
4248
4249 -- BreakX_X (BreakX extension). See section on "Compound Pattern
4250 -- Structures". This node is the alternative that is stacked to
4251 -- skip past the break character and extend the break.
4252
4253 when PC_BreakX_X =>
4254 Cursor := Cursor + 1;
4255 goto Succeed;
4256
4257 -- Character (one character string)
4258
4259 when PC_Char =>
4260 if Cursor < Length
4261 and then Subject (Cursor + 1) = Node.Char
4262 then
4263 Cursor := Cursor + 1;
4264 goto Succeed;
4265 else
4266 goto Fail;
4267 end if;
4268
4269 -- End of Pattern
4270
4271 when PC_EOP =>
4272 if Stack_Base = Stack_Init then
4273 goto Match_Succeed;
4274
4275 -- End of recursive inner match. See separate section on
4276 -- handing of recursive pattern matches for details.
4277
4278 else
4279 Node := Stack (Stack_Base - 1).Node;
4280 Pop_Region;
4281 goto Match;
4282 end if;
4283
4284 -- Fail
4285
4286 when PC_Fail =>
4287 goto Fail;
4288
4289 -- Fence (built in pattern)
4290
4291 when PC_Fence =>
4292 Push (CP_Cancel'Access);
4293 goto Succeed;
4294
4295 -- Fence function node X. This is the node that gets control
4296 -- after a successful match of the fenced pattern.
4297
4298 when PC_Fence_X =>
4299 Stack_Ptr := Stack_Ptr + 1;
4300 Stack (Stack_Ptr).Cursor := Stack_Base;
4301 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
4302 Stack_Base := Stack (Stack_Base).Cursor;
4303 goto Succeed;
4304
4305 -- Fence function node Y. This is the node that gets control on
4306 -- a failure that occurs after the fenced pattern has matched.
4307
4308 -- Note: the Cursor at this stage is actually the inner stack
4309 -- base value. We don't reset this, but we do use it to strip
4310 -- off all the entries made by the fenced pattern.
4311
4312 when PC_Fence_Y =>
4313 Stack_Ptr := Cursor - 2;
4314 goto Fail;
4315
4316 -- Len (integer case)
4317
4318 when PC_Len_Nat =>
4319 if Cursor + Node.Nat > Length then
4320 goto Fail;
4321 else
4322 Cursor := Cursor + Node.Nat;
4323 goto Succeed;
4324 end if;
4325
4326 -- Len (Integer function case)
4327
4328 when PC_Len_NF => declare
4329 N : constant Natural := Node.NF.all;
4330 begin
4331 if Cursor + N > Length then
4332 goto Fail;
4333 else
4334 Cursor := Cursor + N;
4335 goto Succeed;
4336 end if;
4337 end;
4338
4339 -- Len (integer pointer case)
4340
4341 when PC_Len_NP =>
4342 if Cursor + Node.NP.all > Length then
4343 goto Fail;
4344 else
4345 Cursor := Cursor + Node.NP.all;
4346 goto Succeed;
4347 end if;
4348
4349 -- NotAny (one character case)
4350
4351 when PC_NotAny_CH =>
4352 if Cursor < Length
4353 and then Subject (Cursor + 1) /= Node.Char
4354 then
4355 Cursor := Cursor + 1;
4356 goto Succeed;
4357 else
4358 goto Fail;
4359 end if;
4360
4361 -- NotAny (character set case)
4362
4363 when PC_NotAny_CS =>
4364 if Cursor < Length
4365 and then not Is_In (Subject (Cursor + 1), Node.CS)
4366 then
4367 Cursor := Cursor + 1;
4368 goto Succeed;
4369 else
4370 goto Fail;
4371 end if;
4372
4373 -- NotAny (string function case)
4374
4375 when PC_NotAny_VF => declare
4376 U : constant VString := Node.VF.all;
4377 S : Big_String_Access;
4378 L : Natural;
4379
4380 begin
4381 Get_String (U, S, L);
4382
4383 if Cursor < Length
4384 and then
4385 not Is_In (Subject (Cursor + 1), S (1 .. L))
4386 then
4387 Cursor := Cursor + 1;
4388 goto Succeed;
4389 else
4390 goto Fail;
4391 end if;
4392 end;
4393
4394 -- NotAny (string pointer case)
4395
4396 when PC_NotAny_VP => declare
4397 U : constant VString := Node.VP.all;
4398 S : Big_String_Access;
4399 L : Natural;
4400
4401 begin
4402 Get_String (U, S, L);
4403
4404 if Cursor < Length
4405 and then
4406 not Is_In (Subject (Cursor + 1), S (1 .. L))
4407 then
4408 Cursor := Cursor + 1;
4409 goto Succeed;
4410 else
4411 goto Fail;
4412 end if;
4413 end;
4414
4415 -- NSpan (one character case)
4416
4417 when PC_NSpan_CH =>
4418 while Cursor < Length
4419 and then Subject (Cursor + 1) = Node.Char
4420 loop
4421 Cursor := Cursor + 1;
4422 end loop;
4423
4424 goto Succeed;
4425
4426 -- NSpan (character set case)
4427
4428 when PC_NSpan_CS =>
4429 while Cursor < Length
4430 and then Is_In (Subject (Cursor + 1), Node.CS)
4431 loop
4432 Cursor := Cursor + 1;
4433 end loop;
4434
4435 goto Succeed;
4436
4437 -- NSpan (string function case)
4438
4439 when PC_NSpan_VF => declare
4440 U : constant VString := Node.VF.all;
4441 S : Big_String_Access;
4442 L : Natural;
4443
4444 begin
4445 Get_String (U, S, L);
4446
4447 while Cursor < Length
4448 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4449 loop
4450 Cursor := Cursor + 1;
4451 end loop;
4452
4453 goto Succeed;
4454 end;
4455
4456 -- NSpan (string pointer case)
4457
4458 when PC_NSpan_VP => declare
4459 U : constant VString := Node.VP.all;
4460 S : Big_String_Access;
4461 L : Natural;
4462
4463 begin
4464 Get_String (U, S, L);
4465
4466 while Cursor < Length
4467 and then Is_In (Subject (Cursor + 1), S (1 .. L))
4468 loop
4469 Cursor := Cursor + 1;
4470 end loop;
4471
4472 goto Succeed;
4473 end;
4474
4475 -- Null string
4476
4477 when PC_Null =>
4478 goto Succeed;
4479
4480 -- Pos (integer case)
4481
4482 when PC_Pos_Nat =>
4483 if Cursor = Node.Nat then
4484 goto Succeed;
4485 else
4486 goto Fail;
4487 end if;
4488
4489 -- Pos (Integer function case)
4490
4491 when PC_Pos_NF => declare
4492 N : constant Natural := Node.NF.all;
4493 begin
4494 if Cursor = N then
4495 goto Succeed;
4496 else
4497 goto Fail;
4498 end if;
4499 end;
4500
4501 -- Pos (integer pointer case)
4502
4503 when PC_Pos_NP =>
4504 if Cursor = Node.NP.all then
4505 goto Succeed;
4506 else
4507 goto Fail;
4508 end if;
4509
4510 -- Predicate function
4511
4512 when PC_Pred_Func =>
4513 if Node.BF.all then
4514 goto Succeed;
4515 else
4516 goto Fail;
4517 end if;
4518
4519 -- Region Enter. Initiate new pattern history stack region
4520
4521 when PC_R_Enter =>
4522 Stack (Stack_Ptr + 1).Cursor := Cursor;
4523 Push_Region;
4524 goto Succeed;
4525
4526 -- Region Remove node. This is the node stacked by an R_Enter.
4527 -- It removes the special format stack entry right underneath, and
4528 -- then restores the outer level stack base and signals failure.
4529
4530 -- Note: the cursor value at this stage is actually the (negative)
4531 -- stack base value for the outer level.
4532
4533 when PC_R_Remove =>
4534 Stack_Base := Cursor;
4535 Stack_Ptr := Stack_Ptr - 1;
4536 goto Fail;
4537
4538 -- Region restore node. This is the node stacked at the end of an
4539 -- inner level match. Its function is to restore the inner level
4540 -- region, so that alternatives in this region can be sought.
4541
4542 -- Note: the Cursor at this stage is actually the negative of the
4543 -- inner stack base value, which we use to restore the inner region.
4544
4545 when PC_R_Restore =>
4546 Stack_Base := Cursor;
4547 goto Fail;
4548
4549 -- Rest
4550
4551 when PC_Rest =>
4552 Cursor := Length;
4553 goto Succeed;
4554
4555 -- Initiate recursive match (pattern pointer case)
4556
4557 when PC_Rpat =>
4558 Stack (Stack_Ptr + 1).Node := Node.Pthen;
4559 Push_Region;
4560
4561 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
4562 raise Pattern_Stack_Overflow;
4563 else
4564 Node := Node.PP.all.P;
4565 goto Match;
4566 end if;
4567
4568 -- RPos (integer case)
4569
4570 when PC_RPos_Nat =>
4571 if Cursor = (Length - Node.Nat) then
4572 goto Succeed;
4573 else
4574 goto Fail;
4575 end if;
4576
4577 -- RPos (integer function case)
4578
4579 when PC_RPos_NF => declare
4580 N : constant Natural := Node.NF.all;
4581 begin
4582 if Length - Cursor = N then
4583 goto Succeed;
4584 else
4585 goto Fail;
4586 end if;
4587 end;
4588
4589 -- RPos (integer pointer case)
4590
4591 when PC_RPos_NP =>
4592 if Cursor = (Length - Node.NP.all) then
4593 goto Succeed;
4594 else
4595 goto Fail;
4596 end if;
4597
4598 -- RTab (integer case)
4599
4600 when PC_RTab_Nat =>
4601 if Cursor <= (Length - Node.Nat) then
4602 Cursor := Length - Node.Nat;
4603 goto Succeed;
4604 else
4605 goto Fail;
4606 end if;
4607
4608 -- RTab (integer function case)
4609
4610 when PC_RTab_NF => declare
4611 N : constant Natural := Node.NF.all;
4612 begin
4613 if Length - Cursor >= N then
4614 Cursor := Length - N;
4615 goto Succeed;
4616 else
4617 goto Fail;
4618 end if;
4619 end;
4620
4621 -- RTab (integer pointer case)
4622
4623 when PC_RTab_NP =>
4624 if Cursor <= (Length - Node.NP.all) then
4625 Cursor := Length - Node.NP.all;
4626 goto Succeed;
4627 else
4628 goto Fail;
4629 end if;
4630
4631 -- Cursor assignment
4632
4633 when PC_Setcur =>
4634 Node.Var.all := Cursor;
4635 goto Succeed;
4636
4637 -- Span (one character case)
4638
4639 when PC_Span_CH => declare
4640 P : Natural;
4641
4642 begin
4643 P := Cursor;
4644 while P < Length
4645 and then Subject (P + 1) = Node.Char
4646 loop
4647 P := P + 1;
4648 end loop;
4649
4650 if P /= Cursor then
4651 Cursor := P;
4652 goto Succeed;
4653 else
4654 goto Fail;
4655 end if;
4656 end;
4657
4658 -- Span (character set case)
4659
4660 when PC_Span_CS => declare
4661 P : Natural;
4662
4663 begin
4664 P := Cursor;
4665 while P < Length
4666 and then Is_In (Subject (P + 1), Node.CS)
4667 loop
4668 P := P + 1;
4669 end loop;
4670
4671 if P /= Cursor then
4672 Cursor := P;
4673 goto Succeed;
4674 else
4675 goto Fail;
4676 end if;
4677 end;
4678
4679 -- Span (string function case)
4680
4681 when PC_Span_VF => declare
4682 U : constant VString := Node.VF.all;
4683 S : Big_String_Access;
4684 L : Natural;
4685 P : Natural;
4686
4687 begin
4688 Get_String (U, S, L);
4689
4690 P := Cursor;
4691 while P < Length
4692 and then Is_In (Subject (P + 1), S (1 .. L))
4693 loop
4694 P := P + 1;
4695 end loop;
4696
4697 if P /= Cursor then
4698 Cursor := P;
4699 goto Succeed;
4700 else
4701 goto Fail;
4702 end if;
4703 end;
4704
4705 -- Span (string pointer case)
4706
4707 when PC_Span_VP => declare
4708 U : constant VString := Node.VP.all;
4709 S : Big_String_Access;
4710 L : Natural;
4711 P : Natural;
4712
4713 begin
4714 Get_String (U, S, L);
4715
4716 P := Cursor;
4717 while P < Length
4718 and then Is_In (Subject (P + 1), S (1 .. L))
4719 loop
4720 P := P + 1;
4721 end loop;
4722
4723 if P /= Cursor then
4724 Cursor := P;
4725 goto Succeed;
4726 else
4727 goto Fail;
4728 end if;
4729 end;
4730
4731 -- String (two character case)
4732
4733 when PC_String_2 =>
4734 if (Length - Cursor) >= 2
4735 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
4736 then
4737 Cursor := Cursor + 2;
4738 goto Succeed;
4739 else
4740 goto Fail;
4741 end if;
4742
4743 -- String (three character case)
4744
4745 when PC_String_3 =>
4746 if (Length - Cursor) >= 3
4747 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
4748 then
4749 Cursor := Cursor + 3;
4750 goto Succeed;
4751 else
4752 goto Fail;
4753 end if;
4754
4755 -- String (four character case)
4756
4757 when PC_String_4 =>
4758 if (Length - Cursor) >= 4
4759 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
4760 then
4761 Cursor := Cursor + 4;
4762 goto Succeed;
4763 else
4764 goto Fail;
4765 end if;
4766
4767 -- String (five character case)
4768
4769 when PC_String_5 =>
4770 if (Length - Cursor) >= 5
4771 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
4772 then
4773 Cursor := Cursor + 5;
4774 goto Succeed;
4775 else
4776 goto Fail;
4777 end if;
4778
4779 -- String (six character case)
4780
4781 when PC_String_6 =>
4782 if (Length - Cursor) >= 6
4783 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
4784 then
4785 Cursor := Cursor + 6;
4786 goto Succeed;
4787 else
4788 goto Fail;
4789 end if;
4790
4791 -- String (case of more than six characters)
4792
4793 when PC_String => declare
4794 Len : constant Natural := Node.Str'Length;
4795 begin
4796 if (Length - Cursor) >= Len
4797 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
4798 then
4799 Cursor := Cursor + Len;
4800 goto Succeed;
4801 else
4802 goto Fail;
4803 end if;
4804 end;
4805
4806 -- String (function case)
4807
4808 when PC_String_VF => declare
4809 U : constant VString := Node.VF.all;
4810 S : Big_String_Access;
4811 L : Natural;
4812
4813 begin
4814 Get_String (U, S, L);
4815
4816 if (Length - Cursor) >= L
4817 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4818 then
4819 Cursor := Cursor + L;
4820 goto Succeed;
4821 else
4822 goto Fail;
4823 end if;
4824 end;
4825
4826 -- String (pointer case)
4827
4828 when PC_String_VP => declare
4829 U : constant VString := Node.VP.all;
4830 S : Big_String_Access;
4831 L : Natural;
4832
4833 begin
4834 Get_String (U, S, L);
4835
4836 if (Length - Cursor) >= L
4837 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
4838 then
4839 Cursor := Cursor + L;
4840 goto Succeed;
4841 else
4842 goto Fail;
4843 end if;
4844 end;
4845
4846 -- Succeed
4847
4848 when PC_Succeed =>
4849 Push (Node);
4850 goto Succeed;
4851
4852 -- Tab (integer case)
4853
4854 when PC_Tab_Nat =>
4855 if Cursor <= Node.Nat then
4856 Cursor := Node.Nat;
4857 goto Succeed;
4858 else
4859 goto Fail;
4860 end if;
4861
4862 -- Tab (integer function case)
4863
4864 when PC_Tab_NF => declare
4865 N : constant Natural := Node.NF.all;
4866 begin
4867 if Cursor <= N then
4868 Cursor := N;
4869 goto Succeed;
4870 else
4871 goto Fail;
4872 end if;
4873 end;
4874
4875 -- Tab (integer pointer case)
4876
4877 when PC_Tab_NP =>
4878 if Cursor <= Node.NP.all then
4879 Cursor := Node.NP.all;
4880 goto Succeed;
4881 else
4882 goto Fail;
4883 end if;
4884
4885 -- Unanchored movement
4886
4887 when PC_Unanchored =>
4888
4889 -- All done if we tried every position
4890
4891 if Cursor > Length then
4892 goto Match_Fail;
4893
4894 -- Otherwise extend the anchor point, and restack ourself
4895
4896 else
4897 Cursor := Cursor + 1;
4898 Push (Node);
4899 goto Succeed;
4900 end if;
4901
4902 -- Write immediate. This node performs the actual write
4903
4904 when PC_Write_Imm =>
4905 Put_Line
4906 (Node.FP.all,
4907 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
4908 Pop_Region;
4909 goto Succeed;
4910
4911 -- Write on match. This node sets up for the eventual write
4912
4913 when PC_Write_OnM =>
4914 Stack (Stack_Base - 1).Node := Node;
4915 Push (CP_Assign'Access);
4916 Pop_Region;
4917 Assign_OnM := True;
4918 goto Succeed;
4919
4920 end case;
4921
4922 -- We are NOT allowed to fall though this case statement, since every
4923 -- match routine must end by executing a goto to the appropriate point
4924 -- in the finite state machine model.
4925
4926 pragma Warnings (Off);
4927 Logic_Error;
4928 pragma Warnings (On);
4929 end XMatch;
4930
4931 -------------
4932 -- XMatchD --
4933 -------------
4934
4935 -- Maintenance note: There is a LOT of code duplication between XMatch
4936 -- and XMatchD. This is quite intentional, the point is to avoid any
4937 -- unnecessary debugging overhead in the XMatch case, but this does mean
4938 -- that any changes to XMatchD must be mirrored in XMatch. In case of
4939 -- any major changes, the proper approach is to delete XMatch, make the
4940 -- changes to XMatchD, and then make a copy of XMatchD, removing all
4941 -- calls to Dout, and all Put and Put_Line operations. This copy becomes
4942 -- the new XMatch.
4943
4944 procedure XMatchD
4945 (Subject : String;
4946 Pat_P : PE_Ptr;
4947 Pat_S : Natural;
4948 Start : out Natural;
4949 Stop : out Natural)
4950 is
4951 Node : PE_Ptr;
4952 -- Pointer to current pattern node. Initialized from Pat_P, and then
4953 -- updated as the match proceeds through its constituent elements.
4954
4955 Length : constant Natural := Subject'Length;
4956 -- Length of string (= Subject'Last, since Subject'First is always 1)
4957
4958 Cursor : Integer := 0;
4959 -- If the value is non-negative, then this value is the index showing
4960 -- the current position of the match in the subject string. The next
4961 -- character to be matched is at Subject (Cursor + 1). Note that since
4962 -- our view of the subject string in XMatch always has a lower bound
4963 -- of one, regardless of original bounds, that this definition exactly
4964 -- corresponds to the cursor value as referenced by functions like Pos.
4965 --
4966 -- If the value is negative, then this is a saved stack pointer,
4967 -- typically a base pointer of an inner or outer region. Cursor
4968 -- temporarily holds such a value when it is popped from the stack
4969 -- by Fail. In all cases, Cursor is reset to a proper non-negative
4970 -- cursor value before the match proceeds (e.g. by propagating the
4971 -- failure and popping a "real" cursor value from the stack.
4972
4973 PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P);
4974 -- Dummy pattern element used in the unanchored case
4975
4976 Region_Level : Natural := 0;
4977 -- Keeps track of recursive region level. This is used only for
4978 -- debugging, it is the number of saved history stack base values.
4979
4980 Stack : Stack_Type;
4981 -- The pattern matching failure stack for this call to Match
4982
4983 Stack_Ptr : Stack_Range;
4984 -- Current stack pointer. This points to the top element of the stack
4985 -- that is currently in use. At the outer level this is the special
4986 -- entry placed on the stack according to the anchor mode.
4987
4988 Stack_Init : constant Stack_Range := Stack'First + 1;
4989 -- This is the initial value of the Stack_Ptr and Stack_Base. The
4990 -- initial (Stack'First) element of the stack is not used so that
4991 -- when we pop the last element off, Stack_Ptr is still in range.
4992
4993 Stack_Base : Stack_Range;
4994 -- This value is the stack base value, i.e. the stack pointer for the
4995 -- first history stack entry in the current stack region. See separate
4996 -- section on handling of recursive pattern matches.
4997
4998 Assign_OnM : Boolean := False;
4999 -- Set True if assign-on-match or write-on-match operations may be
5000 -- present in the history stack, which must then be scanned on a
5001 -- successful match.
5002
5003 procedure Dout (Str : String);
5004 -- Output string to standard error with bars indicating region level
5005
5006 procedure Dout (Str : String; A : Character);
5007 -- Calls Dout with the string S ('A')
5008
5009 procedure Dout (Str : String; A : Character_Set);
5010 -- Calls Dout with the string S ("A")
5011
5012 procedure Dout (Str : String; A : Natural);
5013 -- Calls Dout with the string S (A)
5014
5015 procedure Dout (Str : String; A : String);
5016 -- Calls Dout with the string S ("A")
5017
5018 function Img (P : PE_Ptr) return String;
5019 -- Returns a string of the form #nnn where nnn is P.Index
5020
5021 procedure Pop_Region;
5022 pragma Inline (Pop_Region);
5023 -- Used at the end of processing of an inner region. If the inner
5024 -- region left no stack entries, then all trace of it is removed.
5025 -- Otherwise a PC_Restore_Region entry is pushed to ensure proper
5026 -- handling of alternatives in the inner region.
5027
5028 procedure Push (Node : PE_Ptr);
5029 pragma Inline (Push);
5030 -- Make entry in pattern matching stack with current cursor value
5031
5032 procedure Push_Region;
5033 pragma Inline (Push_Region);
5034 -- This procedure makes a new region on the history stack. The
5035 -- caller first establishes the special entry on the stack, but
5036 -- does not push the stack pointer. Then this call stacks a
5037 -- PC_Remove_Region node, on top of this entry, using the cursor
5038 -- field of the PC_Remove_Region entry to save the outer level
5039 -- stack base value, and resets the stack base to point to this
5040 -- PC_Remove_Region node.
5041
5042 ----------
5043 -- Dout --
5044 ----------
5045
5046 procedure Dout (Str : String) is
5047 begin
5048 for J in 1 .. Region_Level loop
5049 Put ("| ");
5050 end loop;
5051
5052 Put_Line (Str);
5053 end Dout;
5054
5055 procedure Dout (Str : String; A : Character) is
5056 begin
5057 Dout (Str & " ('" & A & "')");
5058 end Dout;
5059
5060 procedure Dout (Str : String; A : Character_Set) is
5061 begin
5062 Dout (Str & " (" & Image (To_Sequence (A)) & ')');
5063 end Dout;
5064
5065 procedure Dout (Str : String; A : Natural) is
5066 begin
5067 Dout (Str & " (" & A & ')');
5068 end Dout;
5069
5070 procedure Dout (Str : String; A : String) is
5071 begin
5072 Dout (Str & " (" & Image (A) & ')');
5073 end Dout;
5074
5075 ---------
5076 -- Img --
5077 ---------
5078
5079 function Img (P : PE_Ptr) return String is
5080 begin
5081 return "#" & Integer (P.Index) & " ";
5082 end Img;
5083
5084 ----------------
5085 -- Pop_Region --
5086 ----------------
5087
5088 procedure Pop_Region is
5089 begin
5090 Region_Level := Region_Level - 1;
5091
5092 -- If nothing was pushed in the inner region, we can just get
5093 -- rid of it entirely, leaving no traces that it was ever there
5094
5095 if Stack_Ptr = Stack_Base then
5096 Stack_Ptr := Stack_Base - 2;
5097 Stack_Base := Stack (Stack_Ptr + 2).Cursor;
5098
5099 -- If stuff was pushed in the inner region, then we have to
5100 -- push a PC_R_Restore node so that we properly handle possible
5101 -- rematches within the region.
5102
5103 else
5104 Stack_Ptr := Stack_Ptr + 1;
5105 Stack (Stack_Ptr).Cursor := Stack_Base;
5106 Stack (Stack_Ptr).Node := CP_R_Restore'Access;
5107 Stack_Base := Stack (Stack_Base).Cursor;
5108 end if;
5109 end Pop_Region;
5110
5111 ----------
5112 -- Push --
5113 ----------
5114
5115 procedure Push (Node : PE_Ptr) is
5116 begin
5117 Stack_Ptr := Stack_Ptr + 1;
5118 Stack (Stack_Ptr).Cursor := Cursor;
5119 Stack (Stack_Ptr).Node := Node;
5120 end Push;
5121
5122 -----------------
5123 -- Push_Region --
5124 -----------------
5125
5126 procedure Push_Region is
5127 begin
5128 Region_Level := Region_Level + 1;
5129 Stack_Ptr := Stack_Ptr + 2;
5130 Stack (Stack_Ptr).Cursor := Stack_Base;
5131 Stack (Stack_Ptr).Node := CP_R_Remove'Access;
5132 Stack_Base := Stack_Ptr;
5133 end Push_Region;
5134
5135 -- Start of processing for XMatchD
5136
5137 begin
5138 New_Line;
5139 Put_Line ("Initiating pattern match, subject = " & Image (Subject));
5140 Put ("--------------------------------------");
5141
5142 for J in 1 .. Length loop
5143 Put ('-');
5144 end loop;
5145
5146 New_Line;
5147 Put_Line ("subject length = " & Length);
5148
5149 if Pat_P = null then
5150 Uninitialized_Pattern;
5151 end if;
5152
5153 -- Check we have enough stack for this pattern. This check deals with
5154 -- every possibility except a match of a recursive pattern, where we
5155 -- make a check at each recursion level.
5156
5157 if Pat_S >= Stack_Size - 1 then
5158 raise Pattern_Stack_Overflow;
5159 end if;
5160
5161 -- In anchored mode, the bottom entry on the stack is an abort entry
5162
5163 if Anchored_Mode then
5164 Stack (Stack_Init).Node := CP_Cancel'Access;
5165 Stack (Stack_Init).Cursor := 0;
5166
5167 -- In unanchored more, the bottom entry on the stack references
5168 -- the special pattern element PE_Unanchored, whose Pthen field
5169 -- points to the initial pattern element. The cursor value in this
5170 -- entry is the number of anchor moves so far.
5171
5172 else
5173 Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access;
5174 Stack (Stack_Init).Cursor := 0;
5175 end if;
5176
5177 Stack_Ptr := Stack_Init;
5178 Stack_Base := Stack_Ptr;
5179 Cursor := 0;
5180 Node := Pat_P;
5181 goto Match;
5182
5183 -----------------------------------------
5184 -- Main Pattern Matching State Control --
5185 -----------------------------------------
5186
5187 -- This is a state machine which uses gotos to change state. The
5188 -- initial state is Match, to initiate the matching of the first
5189 -- element, so the goto Match above starts the match. In the
5190 -- following descriptions, we indicate the global values that
5191 -- are relevant for the state transition.
5192
5193 -- Come here if entire match fails
5194
5195 <<Match_Fail>>
5196 Dout ("match fails");
5197 New_Line;
5198 Start := 0;
5199 Stop := 0;
5200 return;
5201
5202 -- Come here if entire match succeeds
5203
5204 -- Cursor current position in subject string
5205
5206 <<Match_Succeed>>
5207 Dout ("match succeeds");
5208 Start := Stack (Stack_Init).Cursor + 1;
5209 Stop := Cursor;
5210 Dout ("first matched character index = " & Start);
5211 Dout ("last matched character index = " & Stop);
5212 Dout ("matched substring = " & Image (Subject (Start .. Stop)));
5213
5214 -- Scan history stack for deferred assignments or writes
5215
5216 if Assign_OnM then
5217 for S in Stack'First .. Stack_Ptr loop
5218 if Stack (S).Node = CP_Assign'Access then
5219 declare
5220 Inner_Base : constant Stack_Range :=
5221 Stack (S + 1).Cursor;
5222 Special_Entry : constant Stack_Range :=
5223 Inner_Base - 1;
5224 Node_OnM : constant PE_Ptr :=
5225 Stack (Special_Entry).Node;
5226 Start : constant Natural :=
5227 Stack (Special_Entry).Cursor + 1;
5228 Stop : constant Natural := Stack (S).Cursor;
5229
5230 begin
5231 if Node_OnM.Pcode = PC_Assign_OnM then
5232 Set_Unbounded_String
5233 (Node_OnM.VP.all, Subject (Start .. Stop));
5234 Dout
5235 (Img (Stack (S).Node) &
5236 "deferred assignment of " &
5237 Image (Subject (Start .. Stop)));
5238
5239 elsif Node_OnM.Pcode = PC_Write_OnM then
5240 Put_Line (Node_OnM.FP.all, Subject (Start .. Stop));
5241 Dout
5242 (Img (Stack (S).Node) &
5243 "deferred write of " &
5244 Image (Subject (Start .. Stop)));
5245
5246 else
5247 Logic_Error;
5248 end if;
5249 end;
5250 end if;
5251 end loop;
5252 end if;
5253
5254 New_Line;
5255 return;
5256
5257 -- Come here if attempt to match current element fails
5258
5259 -- Stack_Base current stack base
5260 -- Stack_Ptr current stack pointer
5261
5262 <<Fail>>
5263 Cursor := Stack (Stack_Ptr).Cursor;
5264 Node := Stack (Stack_Ptr).Node;
5265 Stack_Ptr := Stack_Ptr - 1;
5266
5267 if Cursor >= 0 then
5268 Dout ("failure, cursor reset to " & Cursor);
5269 end if;
5270
5271 goto Match;
5272
5273 -- Come here if attempt to match current element succeeds
5274
5275 -- Cursor current position in subject string
5276 -- Node pointer to node successfully matched
5277 -- Stack_Base current stack base
5278 -- Stack_Ptr current stack pointer
5279
5280 <<Succeed>>
5281 Dout ("success, cursor = " & Cursor);
5282 Node := Node.Pthen;
5283
5284 -- Come here to match the next pattern element
5285
5286 -- Cursor current position in subject string
5287 -- Node pointer to node to be matched
5288 -- Stack_Base current stack base
5289 -- Stack_Ptr current stack pointer
5290
5291 <<Match>>
5292
5293 --------------------------------------------------
5294 -- Main Pattern Match Element Matching Routines --
5295 --------------------------------------------------
5296
5297 -- Here is the case statement that processes the current node. The
5298 -- processing for each element does one of five things:
5299
5300 -- goto Succeed to move to the successor
5301 -- goto Match_Succeed if the entire match succeeds
5302 -- goto Match_Fail if the entire match fails
5303 -- goto Fail to signal failure of current match
5304
5305 -- Processing is NOT allowed to fall through
5306
5307 case Node.Pcode is
5308
5309 -- Cancel
5310
5311 when PC_Cancel =>
5312 Dout (Img (Node) & "matching Cancel");
5313 goto Match_Fail;
5314
5315 -- Alternation
5316
5317 when PC_Alt =>
5318 Dout
5319 (Img (Node) & "setting up alternative " & Img (Node.Alt));
5320 Push (Node.Alt);
5321 Node := Node.Pthen;
5322 goto Match;
5323
5324 -- Any (one character case)
5325
5326 when PC_Any_CH =>
5327 Dout (Img (Node) & "matching Any", Node.Char);
5328
5329 if Cursor < Length
5330 and then Subject (Cursor + 1) = Node.Char
5331 then
5332 Cursor := Cursor + 1;
5333 goto Succeed;
5334 else
5335 goto Fail;
5336 end if;
5337
5338 -- Any (character set case)
5339
5340 when PC_Any_CS =>
5341 Dout (Img (Node) & "matching Any", Node.CS);
5342
5343 if Cursor < Length
5344 and then Is_In (Subject (Cursor + 1), Node.CS)
5345 then
5346 Cursor := Cursor + 1;
5347 goto Succeed;
5348 else
5349 goto Fail;
5350 end if;
5351
5352 -- Any (string function case)
5353
5354 when PC_Any_VF => declare
5355 U : constant VString := Node.VF.all;
5356 S : Big_String_Access;
5357 L : Natural;
5358
5359 begin
5360 Get_String (U, S, L);
5361
5362 Dout (Img (Node) & "matching Any", S (1 .. L));
5363
5364 if Cursor < Length
5365 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5366 then
5367 Cursor := Cursor + 1;
5368 goto Succeed;
5369 else
5370 goto Fail;
5371 end if;
5372 end;
5373
5374 -- Any (string pointer case)
5375
5376 when PC_Any_VP => declare
5377 U : constant VString := Node.VP.all;
5378 S : Big_String_Access;
5379 L : Natural;
5380
5381 begin
5382 Get_String (U, S, L);
5383 Dout (Img (Node) & "matching Any", S (1 .. L));
5384
5385 if Cursor < Length
5386 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5387 then
5388 Cursor := Cursor + 1;
5389 goto Succeed;
5390 else
5391 goto Fail;
5392 end if;
5393 end;
5394
5395 -- Arb (initial match)
5396
5397 when PC_Arb_X =>
5398 Dout (Img (Node) & "matching Arb");
5399 Push (Node.Alt);
5400 Node := Node.Pthen;
5401 goto Match;
5402
5403 -- Arb (extension)
5404
5405 when PC_Arb_Y =>
5406 Dout (Img (Node) & "extending Arb");
5407
5408 if Cursor < Length then
5409 Cursor := Cursor + 1;
5410 Push (Node);
5411 goto Succeed;
5412 else
5413 goto Fail;
5414 end if;
5415
5416 -- Arbno_S (simple Arbno initialize). This is the node that
5417 -- initiates the match of a simple Arbno structure.
5418
5419 when PC_Arbno_S =>
5420 Dout (Img (Node) &
5421 "setting up Arbno alternative " & Img (Node.Alt));
5422 Push (Node.Alt);
5423 Node := Node.Pthen;
5424 goto Match;
5425
5426 -- Arbno_X (Arbno initialize). This is the node that initiates
5427 -- the match of a complex Arbno structure.
5428
5429 when PC_Arbno_X =>
5430 Dout (Img (Node) &
5431 "setting up Arbno alternative " & Img (Node.Alt));
5432 Push (Node.Alt);
5433 Node := Node.Pthen;
5434 goto Match;
5435
5436 -- Arbno_Y (Arbno rematch). This is the node that is executed
5437 -- following successful matching of one instance of a complex
5438 -- Arbno pattern.
5439
5440 when PC_Arbno_Y => declare
5441 Null_Match : constant Boolean :=
5442 Cursor = Stack (Stack_Base - 1).Cursor;
5443
5444 begin
5445 Dout (Img (Node) & "extending Arbno");
5446 Pop_Region;
5447
5448 -- If arbno extension matched null, then immediately fail
5449
5450 if Null_Match then
5451 Dout ("Arbno extension matched null, so fails");
5452 goto Fail;
5453 end if;
5454
5455 -- Here we must do a stack check to make sure enough stack
5456 -- is left. This check will happen once for each instance of
5457 -- the Arbno pattern that is matched. The Nat field of a
5458 -- PC_Arbno pattern contains the maximum stack entries needed
5459 -- for the Arbno with one instance and the successor pattern
5460
5461 if Stack_Ptr + Node.Nat >= Stack'Last then
5462 raise Pattern_Stack_Overflow;
5463 end if;
5464
5465 goto Succeed;
5466 end;
5467
5468 -- Assign. If this node is executed, it means the assign-on-match
5469 -- or write-on-match operation will not happen after all, so we
5470 -- is propagate the failure, removing the PC_Assign node.
5471
5472 when PC_Assign =>
5473 Dout (Img (Node) & "deferred assign/write cancelled");
5474 goto Fail;
5475
5476 -- Assign immediate. This node performs the actual assignment
5477
5478 when PC_Assign_Imm =>
5479 Dout
5480 (Img (Node) & "executing immediate assignment of " &
5481 Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)));
5482 Set_Unbounded_String
5483 (Node.VP.all,
5484 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
5485 Pop_Region;
5486 goto Succeed;
5487
5488 -- Assign on match. This node sets up for the eventual assignment
5489
5490 when PC_Assign_OnM =>
5491 Dout (Img (Node) & "registering deferred assignment");
5492 Stack (Stack_Base - 1).Node := Node;
5493 Push (CP_Assign'Access);
5494 Pop_Region;
5495 Assign_OnM := True;
5496 goto Succeed;
5497
5498 -- Bal
5499
5500 when PC_Bal =>
5501 Dout (Img (Node) & "matching or extending Bal");
5502 if Cursor >= Length or else Subject (Cursor + 1) = ')' then
5503 goto Fail;
5504
5505 elsif Subject (Cursor + 1) = '(' then
5506 declare
5507 Paren_Count : Natural := 1;
5508
5509 begin
5510 loop
5511 Cursor := Cursor + 1;
5512
5513 if Cursor >= Length then
5514 goto Fail;
5515
5516 elsif Subject (Cursor + 1) = '(' then
5517 Paren_Count := Paren_Count + 1;
5518
5519 elsif Subject (Cursor + 1) = ')' then
5520 Paren_Count := Paren_Count - 1;
5521 exit when Paren_Count = 0;
5522 end if;
5523 end loop;
5524 end;
5525 end if;
5526
5527 Cursor := Cursor + 1;
5528 Push (Node);
5529 goto Succeed;
5530
5531 -- Break (one character case)
5532
5533 when PC_Break_CH =>
5534 Dout (Img (Node) & "matching Break", Node.Char);
5535
5536 while Cursor < Length loop
5537 if Subject (Cursor + 1) = Node.Char then
5538 goto Succeed;
5539 else
5540 Cursor := Cursor + 1;
5541 end if;
5542 end loop;
5543
5544 goto Fail;
5545
5546 -- Break (character set case)
5547
5548 when PC_Break_CS =>
5549 Dout (Img (Node) & "matching Break", Node.CS);
5550
5551 while Cursor < Length loop
5552 if Is_In (Subject (Cursor + 1), Node.CS) then
5553 goto Succeed;
5554 else
5555 Cursor := Cursor + 1;
5556 end if;
5557 end loop;
5558
5559 goto Fail;
5560
5561 -- Break (string function case)
5562
5563 when PC_Break_VF => declare
5564 U : constant VString := Node.VF.all;
5565 S : Big_String_Access;
5566 L : Natural;
5567
5568 begin
5569 Get_String (U, S, L);
5570 Dout (Img (Node) & "matching Break", S (1 .. L));
5571
5572 while Cursor < Length loop
5573 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5574 goto Succeed;
5575 else
5576 Cursor := Cursor + 1;
5577 end if;
5578 end loop;
5579
5580 goto Fail;
5581 end;
5582
5583 -- Break (string pointer case)
5584
5585 when PC_Break_VP => declare
5586 U : constant VString := Node.VP.all;
5587 S : Big_String_Access;
5588 L : Natural;
5589
5590 begin
5591 Get_String (U, S, L);
5592 Dout (Img (Node) & "matching Break", S (1 .. L));
5593
5594 while Cursor < Length loop
5595 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5596 goto Succeed;
5597 else
5598 Cursor := Cursor + 1;
5599 end if;
5600 end loop;
5601
5602 goto Fail;
5603 end;
5604
5605 -- BreakX (one character case)
5606
5607 when PC_BreakX_CH =>
5608 Dout (Img (Node) & "matching BreakX", Node.Char);
5609
5610 while Cursor < Length loop
5611 if Subject (Cursor + 1) = Node.Char then
5612 goto Succeed;
5613 else
5614 Cursor := Cursor + 1;
5615 end if;
5616 end loop;
5617
5618 goto Fail;
5619
5620 -- BreakX (character set case)
5621
5622 when PC_BreakX_CS =>
5623 Dout (Img (Node) & "matching BreakX", Node.CS);
5624
5625 while Cursor < Length loop
5626 if Is_In (Subject (Cursor + 1), Node.CS) then
5627 goto Succeed;
5628 else
5629 Cursor := Cursor + 1;
5630 end if;
5631 end loop;
5632
5633 goto Fail;
5634
5635 -- BreakX (string function case)
5636
5637 when PC_BreakX_VF => declare
5638 U : constant VString := Node.VF.all;
5639 S : Big_String_Access;
5640 L : Natural;
5641
5642 begin
5643 Get_String (U, S, L);
5644 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5645
5646 while Cursor < Length loop
5647 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5648 goto Succeed;
5649 else
5650 Cursor := Cursor + 1;
5651 end if;
5652 end loop;
5653
5654 goto Fail;
5655 end;
5656
5657 -- BreakX (string pointer case)
5658
5659 when PC_BreakX_VP => declare
5660 U : constant VString := Node.VP.all;
5661 S : Big_String_Access;
5662 L : Natural;
5663
5664 begin
5665 Get_String (U, S, L);
5666 Dout (Img (Node) & "matching BreakX", S (1 .. L));
5667
5668 while Cursor < Length loop
5669 if Is_In (Subject (Cursor + 1), S (1 .. L)) then
5670 goto Succeed;
5671 else
5672 Cursor := Cursor + 1;
5673 end if;
5674 end loop;
5675
5676 goto Fail;
5677 end;
5678
5679 -- BreakX_X (BreakX extension). See section on "Compound Pattern
5680 -- Structures". This node is the alternative that is stacked
5681 -- to skip past the break character and extend the break.
5682
5683 when PC_BreakX_X =>
5684 Dout (Img (Node) & "extending BreakX");
5685 Cursor := Cursor + 1;
5686 goto Succeed;
5687
5688 -- Character (one character string)
5689
5690 when PC_Char =>
5691 Dout (Img (Node) & "matching '" & Node.Char & ''');
5692
5693 if Cursor < Length
5694 and then Subject (Cursor + 1) = Node.Char
5695 then
5696 Cursor := Cursor + 1;
5697 goto Succeed;
5698 else
5699 goto Fail;
5700 end if;
5701
5702 -- End of Pattern
5703
5704 when PC_EOP =>
5705 if Stack_Base = Stack_Init then
5706 Dout ("end of pattern");
5707 goto Match_Succeed;
5708
5709 -- End of recursive inner match. See separate section on
5710 -- handing of recursive pattern matches for details.
5711
5712 else
5713 Dout ("terminating recursive match");
5714 Node := Stack (Stack_Base - 1).Node;
5715 Pop_Region;
5716 goto Match;
5717 end if;
5718
5719 -- Fail
5720
5721 when PC_Fail =>
5722 Dout (Img (Node) & "matching Fail");
5723 goto Fail;
5724
5725 -- Fence (built in pattern)
5726
5727 when PC_Fence =>
5728 Dout (Img (Node) & "matching Fence");
5729 Push (CP_Cancel'Access);
5730 goto Succeed;
5731
5732 -- Fence function node X. This is the node that gets control
5733 -- after a successful match of the fenced pattern.
5734
5735 when PC_Fence_X =>
5736 Dout (Img (Node) & "matching Fence function");
5737 Stack_Ptr := Stack_Ptr + 1;
5738 Stack (Stack_Ptr).Cursor := Stack_Base;
5739 Stack (Stack_Ptr).Node := CP_Fence_Y'Access;
5740 Stack_Base := Stack (Stack_Base).Cursor;
5741 Region_Level := Region_Level - 1;
5742 goto Succeed;
5743
5744 -- Fence function node Y. This is the node that gets control on
5745 -- a failure that occurs after the fenced pattern has matched.
5746
5747 -- Note: the Cursor at this stage is actually the inner stack
5748 -- base value. We don't reset this, but we do use it to strip
5749 -- off all the entries made by the fenced pattern.
5750
5751 when PC_Fence_Y =>
5752 Dout (Img (Node) & "pattern matched by Fence caused failure");
5753 Stack_Ptr := Cursor - 2;
5754 goto Fail;
5755
5756 -- Len (integer case)
5757
5758 when PC_Len_Nat =>
5759 Dout (Img (Node) & "matching Len", Node.Nat);
5760
5761 if Cursor + Node.Nat > Length then
5762 goto Fail;
5763 else
5764 Cursor := Cursor + Node.Nat;
5765 goto Succeed;
5766 end if;
5767
5768 -- Len (Integer function case)
5769
5770 when PC_Len_NF => declare
5771 N : constant Natural := Node.NF.all;
5772
5773 begin
5774 Dout (Img (Node) & "matching Len", N);
5775
5776 if Cursor + N > Length then
5777 goto Fail;
5778 else
5779 Cursor := Cursor + N;
5780 goto Succeed;
5781 end if;
5782 end;
5783
5784 -- Len (integer pointer case)
5785
5786 when PC_Len_NP =>
5787 Dout (Img (Node) & "matching Len", Node.NP.all);
5788
5789 if Cursor + Node.NP.all > Length then
5790 goto Fail;
5791 else
5792 Cursor := Cursor + Node.NP.all;
5793 goto Succeed;
5794 end if;
5795
5796 -- NotAny (one character case)
5797
5798 when PC_NotAny_CH =>
5799 Dout (Img (Node) & "matching NotAny", Node.Char);
5800
5801 if Cursor < Length
5802 and then Subject (Cursor + 1) /= Node.Char
5803 then
5804 Cursor := Cursor + 1;
5805 goto Succeed;
5806 else
5807 goto Fail;
5808 end if;
5809
5810 -- NotAny (character set case)
5811
5812 when PC_NotAny_CS =>
5813 Dout (Img (Node) & "matching NotAny", Node.CS);
5814
5815 if Cursor < Length
5816 and then not Is_In (Subject (Cursor + 1), Node.CS)
5817 then
5818 Cursor := Cursor + 1;
5819 goto Succeed;
5820 else
5821 goto Fail;
5822 end if;
5823
5824 -- NotAny (string function case)
5825
5826 when PC_NotAny_VF => declare
5827 U : constant VString := Node.VF.all;
5828 S : Big_String_Access;
5829 L : Natural;
5830
5831 begin
5832 Get_String (U, S, L);
5833 Dout (Img (Node) & "matching NotAny", S (1 .. L));
5834
5835 if Cursor < Length
5836 and then
5837 not Is_In (Subject (Cursor + 1), S (1 .. L))
5838 then
5839 Cursor := Cursor + 1;
5840 goto Succeed;
5841 else
5842 goto Fail;
5843 end if;
5844 end;
5845
5846 -- NotAny (string pointer case)
5847
5848 when PC_NotAny_VP => declare
5849 U : constant VString := Node.VP.all;
5850 S : Big_String_Access;
5851 L : Natural;
5852
5853 begin
5854 Get_String (U, S, L);
5855 Dout (Img (Node) & "matching NotAny", S (1 .. L));
5856
5857 if Cursor < Length
5858 and then
5859 not Is_In (Subject (Cursor + 1), S (1 .. L))
5860 then
5861 Cursor := Cursor + 1;
5862 goto Succeed;
5863 else
5864 goto Fail;
5865 end if;
5866 end;
5867
5868 -- NSpan (one character case)
5869
5870 when PC_NSpan_CH =>
5871 Dout (Img (Node) & "matching NSpan", Node.Char);
5872
5873 while Cursor < Length
5874 and then Subject (Cursor + 1) = Node.Char
5875 loop
5876 Cursor := Cursor + 1;
5877 end loop;
5878
5879 goto Succeed;
5880
5881 -- NSpan (character set case)
5882
5883 when PC_NSpan_CS =>
5884 Dout (Img (Node) & "matching NSpan", Node.CS);
5885
5886 while Cursor < Length
5887 and then Is_In (Subject (Cursor + 1), Node.CS)
5888 loop
5889 Cursor := Cursor + 1;
5890 end loop;
5891
5892 goto Succeed;
5893
5894 -- NSpan (string function case)
5895
5896 when PC_NSpan_VF => declare
5897 U : constant VString := Node.VF.all;
5898 S : Big_String_Access;
5899 L : Natural;
5900
5901 begin
5902 Get_String (U, S, L);
5903 Dout (Img (Node) & "matching NSpan", S (1 .. L));
5904
5905 while Cursor < Length
5906 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5907 loop
5908 Cursor := Cursor + 1;
5909 end loop;
5910
5911 goto Succeed;
5912 end;
5913
5914 -- NSpan (string pointer case)
5915
5916 when PC_NSpan_VP => declare
5917 U : constant VString := Node.VP.all;
5918 S : Big_String_Access;
5919 L : Natural;
5920
5921 begin
5922 Get_String (U, S, L);
5923 Dout (Img (Node) & "matching NSpan", S (1 .. L));
5924
5925 while Cursor < Length
5926 and then Is_In (Subject (Cursor + 1), S (1 .. L))
5927 loop
5928 Cursor := Cursor + 1;
5929 end loop;
5930
5931 goto Succeed;
5932 end;
5933
5934 when PC_Null =>
5935 Dout (Img (Node) & "matching null");
5936 goto Succeed;
5937
5938 -- Pos (integer case)
5939
5940 when PC_Pos_Nat =>
5941 Dout (Img (Node) & "matching Pos", Node.Nat);
5942
5943 if Cursor = Node.Nat then
5944 goto Succeed;
5945 else
5946 goto Fail;
5947 end if;
5948
5949 -- Pos (Integer function case)
5950
5951 when PC_Pos_NF => declare
5952 N : constant Natural := Node.NF.all;
5953
5954 begin
5955 Dout (Img (Node) & "matching Pos", N);
5956
5957 if Cursor = N then
5958 goto Succeed;
5959 else
5960 goto Fail;
5961 end if;
5962 end;
5963
5964 -- Pos (integer pointer case)
5965
5966 when PC_Pos_NP =>
5967 Dout (Img (Node) & "matching Pos", Node.NP.all);
5968
5969 if Cursor = Node.NP.all then
5970 goto Succeed;
5971 else
5972 goto Fail;
5973 end if;
5974
5975 -- Predicate function
5976
5977 when PC_Pred_Func =>
5978 Dout (Img (Node) & "matching predicate function");
5979
5980 if Node.BF.all then
5981 goto Succeed;
5982 else
5983 goto Fail;
5984 end if;
5985
5986 -- Region Enter. Initiate new pattern history stack region
5987
5988 when PC_R_Enter =>
5989 Dout (Img (Node) & "starting match of nested pattern");
5990 Stack (Stack_Ptr + 1).Cursor := Cursor;
5991 Push_Region;
5992 goto Succeed;
5993
5994 -- Region Remove node. This is the node stacked by an R_Enter.
5995 -- It removes the special format stack entry right underneath, and
5996 -- then restores the outer level stack base and signals failure.
5997
5998 -- Note: the cursor value at this stage is actually the (negative)
5999 -- stack base value for the outer level.
6000
6001 when PC_R_Remove =>
6002 Dout ("failure, match of nested pattern terminated");
6003 Stack_Base := Cursor;
6004 Region_Level := Region_Level - 1;
6005 Stack_Ptr := Stack_Ptr - 1;
6006 goto Fail;
6007
6008 -- Region restore node. This is the node stacked at the end of an
6009 -- inner level match. Its function is to restore the inner level
6010 -- region, so that alternatives in this region can be sought.
6011
6012 -- Note: the Cursor at this stage is actually the negative of the
6013 -- inner stack base value, which we use to restore the inner region.
6014
6015 when PC_R_Restore =>
6016 Dout ("failure, search for alternatives in nested pattern");
6017 Region_Level := Region_Level + 1;
6018 Stack_Base := Cursor;
6019 goto Fail;
6020
6021 -- Rest
6022
6023 when PC_Rest =>
6024 Dout (Img (Node) & "matching Rest");
6025 Cursor := Length;
6026 goto Succeed;
6027
6028 -- Initiate recursive match (pattern pointer case)
6029
6030 when PC_Rpat =>
6031 Stack (Stack_Ptr + 1).Node := Node.Pthen;
6032 Push_Region;
6033 Dout (Img (Node) & "initiating recursive match");
6034
6035 if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then
6036 raise Pattern_Stack_Overflow;
6037 else
6038 Node := Node.PP.all.P;
6039 goto Match;
6040 end if;
6041
6042 -- RPos (integer case)
6043
6044 when PC_RPos_Nat =>
6045 Dout (Img (Node) & "matching RPos", Node.Nat);
6046
6047 if Cursor = (Length - Node.Nat) then
6048 goto Succeed;
6049 else
6050 goto Fail;
6051 end if;
6052
6053 -- RPos (integer function case)
6054
6055 when PC_RPos_NF => declare
6056 N : constant Natural := Node.NF.all;
6057
6058 begin
6059 Dout (Img (Node) & "matching RPos", N);
6060
6061 if Length - Cursor = N then
6062 goto Succeed;
6063 else
6064 goto Fail;
6065 end if;
6066 end;
6067
6068 -- RPos (integer pointer case)
6069
6070 when PC_RPos_NP =>
6071 Dout (Img (Node) & "matching RPos", Node.NP.all);
6072
6073 if Cursor = (Length - Node.NP.all) then
6074 goto Succeed;
6075 else
6076 goto Fail;
6077 end if;
6078
6079 -- RTab (integer case)
6080
6081 when PC_RTab_Nat =>
6082 Dout (Img (Node) & "matching RTab", Node.Nat);
6083
6084 if Cursor <= (Length - Node.Nat) then
6085 Cursor := Length - Node.Nat;
6086 goto Succeed;
6087 else
6088 goto Fail;
6089 end if;
6090
6091 -- RTab (integer function case)
6092
6093 when PC_RTab_NF => declare
6094 N : constant Natural := Node.NF.all;
6095
6096 begin
6097 Dout (Img (Node) & "matching RPos", N);
6098
6099 if Length - Cursor >= N then
6100 Cursor := Length - N;
6101 goto Succeed;
6102 else
6103 goto Fail;
6104 end if;
6105 end;
6106
6107 -- RTab (integer pointer case)
6108
6109 when PC_RTab_NP =>
6110 Dout (Img (Node) & "matching RPos", Node.NP.all);
6111
6112 if Cursor <= (Length - Node.NP.all) then
6113 Cursor := Length - Node.NP.all;
6114 goto Succeed;
6115 else
6116 goto Fail;
6117 end if;
6118
6119 -- Cursor assignment
6120
6121 when PC_Setcur =>
6122 Dout (Img (Node) & "matching Setcur");
6123 Node.Var.all := Cursor;
6124 goto Succeed;
6125
6126 -- Span (one character case)
6127
6128 when PC_Span_CH => declare
6129 P : Natural := Cursor;
6130
6131 begin
6132 Dout (Img (Node) & "matching Span", Node.Char);
6133
6134 while P < Length
6135 and then Subject (P + 1) = Node.Char
6136 loop
6137 P := P + 1;
6138 end loop;
6139
6140 if P /= Cursor then
6141 Cursor := P;
6142 goto Succeed;
6143 else
6144 goto Fail;
6145 end if;
6146 end;
6147
6148 -- Span (character set case)
6149
6150 when PC_Span_CS => declare
6151 P : Natural := Cursor;
6152
6153 begin
6154 Dout (Img (Node) & "matching Span", Node.CS);
6155
6156 while P < Length
6157 and then Is_In (Subject (P + 1), Node.CS)
6158 loop
6159 P := P + 1;
6160 end loop;
6161
6162 if P /= Cursor then
6163 Cursor := P;
6164 goto Succeed;
6165 else
6166 goto Fail;
6167 end if;
6168 end;
6169
6170 -- Span (string function case)
6171
6172 when PC_Span_VF => declare
6173 U : constant VString := Node.VF.all;
6174 S : Big_String_Access;
6175 L : Natural;
6176 P : Natural;
6177
6178 begin
6179 Get_String (U, S, L);
6180 Dout (Img (Node) & "matching Span", S (1 .. L));
6181
6182 P := Cursor;
6183 while P < Length
6184 and then Is_In (Subject (P + 1), S (1 .. L))
6185 loop
6186 P := P + 1;
6187 end loop;
6188
6189 if P /= Cursor then
6190 Cursor := P;
6191 goto Succeed;
6192 else
6193 goto Fail;
6194 end if;
6195 end;
6196
6197 -- Span (string pointer case)
6198
6199 when PC_Span_VP => declare
6200 U : constant VString := Node.VP.all;
6201 S : Big_String_Access;
6202 L : Natural;
6203 P : Natural;
6204
6205 begin
6206 Get_String (U, S, L);
6207 Dout (Img (Node) & "matching Span", S (1 .. L));
6208
6209 P := Cursor;
6210 while P < Length
6211 and then Is_In (Subject (P + 1), S (1 .. L))
6212 loop
6213 P := P + 1;
6214 end loop;
6215
6216 if P /= Cursor then
6217 Cursor := P;
6218 goto Succeed;
6219 else
6220 goto Fail;
6221 end if;
6222 end;
6223
6224 -- String (two character case)
6225
6226 when PC_String_2 =>
6227 Dout (Img (Node) & "matching " & Image (Node.Str2));
6228
6229 if (Length - Cursor) >= 2
6230 and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2
6231 then
6232 Cursor := Cursor + 2;
6233 goto Succeed;
6234 else
6235 goto Fail;
6236 end if;
6237
6238 -- String (three character case)
6239
6240 when PC_String_3 =>
6241 Dout (Img (Node) & "matching " & Image (Node.Str3));
6242
6243 if (Length - Cursor) >= 3
6244 and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3
6245 then
6246 Cursor := Cursor + 3;
6247 goto Succeed;
6248 else
6249 goto Fail;
6250 end if;
6251
6252 -- String (four character case)
6253
6254 when PC_String_4 =>
6255 Dout (Img (Node) & "matching " & Image (Node.Str4));
6256
6257 if (Length - Cursor) >= 4
6258 and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4
6259 then
6260 Cursor := Cursor + 4;
6261 goto Succeed;
6262 else
6263 goto Fail;
6264 end if;
6265
6266 -- String (five character case)
6267
6268 when PC_String_5 =>
6269 Dout (Img (Node) & "matching " & Image (Node.Str5));
6270
6271 if (Length - Cursor) >= 5
6272 and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5
6273 then
6274 Cursor := Cursor + 5;
6275 goto Succeed;
6276 else
6277 goto Fail;
6278 end if;
6279
6280 -- String (six character case)
6281
6282 when PC_String_6 =>
6283 Dout (Img (Node) & "matching " & Image (Node.Str6));
6284
6285 if (Length - Cursor) >= 6
6286 and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6
6287 then
6288 Cursor := Cursor + 6;
6289 goto Succeed;
6290 else
6291 goto Fail;
6292 end if;
6293
6294 -- String (case of more than six characters)
6295
6296 when PC_String => declare
6297 Len : constant Natural := Node.Str'Length;
6298
6299 begin
6300 Dout (Img (Node) & "matching " & Image (Node.Str.all));
6301
6302 if (Length - Cursor) >= Len
6303 and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len)
6304 then
6305 Cursor := Cursor + Len;
6306 goto Succeed;
6307 else
6308 goto Fail;
6309 end if;
6310 end;
6311
6312 -- String (function case)
6313
6314 when PC_String_VF => declare
6315 U : constant VString := Node.VF.all;
6316 S : Big_String_Access;
6317 L : Natural;
6318
6319 begin
6320 Get_String (U, S, L);
6321 Dout (Img (Node) & "matching " & Image (S (1 .. L)));
6322
6323 if (Length - Cursor) >= L
6324 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6325 then
6326 Cursor := Cursor + L;
6327 goto Succeed;
6328 else
6329 goto Fail;
6330 end if;
6331 end;
6332
6333 -- String (vstring pointer case)
6334
6335 when PC_String_VP => declare
6336 U : constant VString := Node.VP.all;
6337 S : Big_String_Access;
6338 L : Natural;
6339
6340 begin
6341 Get_String (U, S, L);
6342 Dout (Img (Node) & "matching " & Image (S (1 .. L)));
6343
6344 if (Length - Cursor) >= L
6345 and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
6346 then
6347 Cursor := Cursor + L;
6348 goto Succeed;
6349 else
6350 goto Fail;
6351 end if;
6352 end;
6353
6354 -- Succeed
6355
6356 when PC_Succeed =>
6357 Dout (Img (Node) & "matching Succeed");
6358 Push (Node);
6359 goto Succeed;
6360
6361 -- Tab (integer case)
6362
6363 when PC_Tab_Nat =>
6364 Dout (Img (Node) & "matching Tab", Node.Nat);
6365
6366 if Cursor <= Node.Nat then
6367 Cursor := Node.Nat;
6368 goto Succeed;
6369 else
6370 goto Fail;
6371 end if;
6372
6373 -- Tab (integer function case)
6374
6375 when PC_Tab_NF => declare
6376 N : constant Natural := Node.NF.all;
6377
6378 begin
6379 Dout (Img (Node) & "matching Tab ", N);
6380
6381 if Cursor <= N then
6382 Cursor := N;
6383 goto Succeed;
6384 else
6385 goto Fail;
6386 end if;
6387 end;
6388
6389 -- Tab (integer pointer case)
6390
6391 when PC_Tab_NP =>
6392 Dout (Img (Node) & "matching Tab ", Node.NP.all);
6393
6394 if Cursor <= Node.NP.all then
6395 Cursor := Node.NP.all;
6396 goto Succeed;
6397 else
6398 goto Fail;
6399 end if;
6400
6401 -- Unanchored movement
6402
6403 when PC_Unanchored =>
6404 Dout ("attempting to move anchor point");
6405
6406 -- All done if we tried every position
6407
6408 if Cursor > Length then
6409 goto Match_Fail;
6410
6411 -- Otherwise extend the anchor point, and restack ourself
6412
6413 else
6414 Cursor := Cursor + 1;
6415 Push (Node);
6416 goto Succeed;
6417 end if;
6418
6419 -- Write immediate. This node performs the actual write
6420
6421 when PC_Write_Imm =>
6422 Dout (Img (Node) & "executing immediate write of " &
6423 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6424
6425 Put_Line
6426 (Node.FP.all,
6427 Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor));
6428 Pop_Region;
6429 goto Succeed;
6430
6431 -- Write on match. This node sets up for the eventual write
6432
6433 when PC_Write_OnM =>
6434 Dout (Img (Node) & "registering deferred write");
6435 Stack (Stack_Base - 1).Node := Node;
6436 Push (CP_Assign'Access);
6437 Pop_Region;
6438 Assign_OnM := True;
6439 goto Succeed;
6440
6441 end case;
6442
6443 -- We are NOT allowed to fall though this case statement, since every
6444 -- match routine must end by executing a goto to the appropriate point
6445 -- in the finite state machine model.
6446
6447 pragma Warnings (Off);
6448 Logic_Error;
6449 pragma Warnings (On);
6450 end XMatchD;
6451
6452 end GNAT.Spitbol.Patterns;