[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/wisi c7f61e5 26/35: In ada-mode, wisi; release ada-mode
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] externals/wisi c7f61e5 26/35: In ada-mode, wisi; release ada-mode 6.1.1, wisi 2.1.1 |
|
Date: |
Sat, 28 Nov 2020 14:47:56 -0500 (EST) |
branch: externals/wisi
commit c7f61e51e53df391c9a239186ab5681bede6a299
Author: Stephen Leake <stephen_leake@stephe-leake.org>
Commit: Stephen Leake <stephen_leake@stephe-leake.org>
In ada-mode, wisi; release ada-mode 6.1.1, wisi 2.1.1
---
NEWS | 37 +-
README | 2 +-
...da_containers-gen_doubly_linked_lists_image.adb | 50 +
...da_containers-gen_doubly_linked_lists_image.ads | 17 +-
...ors-gen_image_aux.ads => sal-ada_containers.ads | 44 +-
sal-gen_bounded_definite_queues.adb | 154 +
sal-gen_bounded_definite_queues.ads | 99 +
sal-gen_bounded_definite_vectors-gen_sorted.adb | 15 +-
sal-gen_bounded_definite_vectors-gen_sorted.ads | 10 +-
sal-gen_graphs.adb | 718 +++++
sal-gen_graphs.ads | 190 ++
sal-gen_unbounded_definite_stacks.adb | 34 +-
sal-gen_unbounded_definite_stacks.ads | 37 +-
...en_unbounded_definite_vectors-gen_image_aux.adb | 11 +-
...en_unbounded_definite_vectors-gen_image_aux.ads | 9 +-
sal-gen_unbounded_definite_vectors.adb | 22 +
sal-gen_unbounded_definite_vectors.ads | 3 +
sal-generic_decimal_image.adb | 48 +
sal-generic_decimal_image.ads | 37 +
sal.adb | 2 +-
wisi-elisp-parse.el | 3407 ++++++++++----------
wisi-parse-common.el | 53 +-
wisi-process-parse.el | 107 +-
wisi-run-indent-test.el | 300 ++
wisi-tests.el | 146 +
wisi.adb | 383 ++-
wisi.ads | 99 +-
wisi.el | 3157 +++++++++---------
wisitoken-bnf-generate.adb | 239 +-
wisitoken-bnf-generate_grammar.adb | 172 +-
wisitoken-bnf-generate_utils.adb | 105 +-
wisitoken-bnf-generate_utils.ads | 32 +-
wisitoken-bnf-output_ada.adb | 117 +-
wisitoken-bnf-output_ada_common.adb | 187 +-
wisitoken-bnf-output_ada_emacs.adb | 739 ++++-
wisitoken-bnf-output_elisp.adb | 4 +-
wisitoken-bnf-output_elisp_common.adb | 19 +-
wisitoken-bnf.adb | 19 +-
wisitoken-bnf.ads | 112 +-
wisitoken-gen_token_enum.ads | 64 +-
wisitoken-generate-lr-lalr_generate.adb | 1207 +++----
wisitoken-generate-lr-lalr_generate.ads | 14 +-
wisitoken-generate-lr-lr1_generate.adb | 652 ++--
wisitoken-generate-lr-lr1_generate.ads | 14 +-
wisitoken-generate-lr.adb | 966 ++++--
wisitoken-generate-lr.ads | 59 +-
wisitoken-generate-lr1_items.adb | 3 +-
wisitoken-generate-lr1_items.ads | 2 +-
wisitoken-generate-packrat.adb | 494 +--
wisitoken-generate-packrat.ads | 150 +-
wisitoken-generate.adb | 977 +++---
wisitoken-generate.ads | 310 +-
wisitoken-lexer-re2c.adb | 2 +-
wisitoken-lexer-re2c.ads | 2 +-
wisitoken-lexer-regexp.adb | 6 +-
wisitoken-lexer-regexp.ads | 2 +-
wisitoken-lexer.ads | 4 +-
wisitoken-parse-lr-mckenzie_recover-base.adb | 875 ++---
wisitoken-parse-lr-mckenzie_recover-base.ads | 365 +--
wisitoken-parse-lr-mckenzie_recover-explore.adb | 3074 ++++++++++--------
wisitoken-parse-lr-mckenzie_recover-explore.ads | 56 +-
wisitoken-parse-lr-mckenzie_recover-parse.adb | 629 ++--
wisitoken-parse-lr-mckenzie_recover-parse.ads | 157 +-
wisitoken-parse-lr-mckenzie_recover.adb | 2389 +++++++-------
wisitoken-parse-lr-mckenzie_recover.ads | 500 +--
wisitoken-parse-lr-parser.adb | 2282 ++++++-------
wisitoken-parse-lr-parser.ads | 50 +-
wisitoken-parse-lr-parser_lists.adb | 18 +-
wisitoken-parse-lr-parser_lists.ads | 1 +
wisitoken-parse-lr-parser_no_recover.adb | 1060 +++---
wisitoken-parse-lr.adb | 1764 +++++-----
wisitoken-parse-lr.ads | 1310 ++++----
wisitoken-parse-packrat-procedural.adb | 512 +--
wisitoken-parse-packrat-procedural.ads | 166 +-
wisitoken-parse_table-mode.el | 3 +-
wisitoken-semantic_checks.adb | 304 +-
wisitoken-semantic_checks.ads | 204 +-
wisitoken-syntax_trees.adb | 2838 +++++++++-------
wisitoken-syntax_trees.ads | 998 +++---
wisitoken.adb | 30 +
wisitoken.ads | 922 +++---
wisitoken_grammar_actions.adb | 79 +-
wisitoken_grammar_actions.ads | 117 +-
wisitoken_grammar_main.adb | 656 +++-
wisitoken_grammar_main.ads | 2 +-
wisitoken_grammar_re2c.c | 2521 +++++++++++----
wisitoken_grammar_re2c_c.ads | 2 +-
wisitoken_grammar_runtime.adb | 2434 +++++++++++++-
wisitoken_grammar_runtime.ads | 67 +-
89 files changed, 25557 insertions(+), 16692 deletions(-)
diff --git a/NEWS b/NEWS
index 22fe4e4..28f737c 100644
--- a/NEWS
+++ b/NEWS
@@ -1,15 +1,48 @@
GNU Emacs wisi NEWS -- history of user-visible changes.
-Copyright (C) 2018 Free Software Foundation, Inc.
+Copyright (C) 2019 Free Software Foundation, Inc.
See the end of the file for license conditions.
Please send wisi bug reports to bug-gnu-emacs@gnu.org, with
'wisi' in the subject. If possible, use M-x report-emacs-bug.
+* wisi
+11 Jul 2019
+
+** parser process protocol version 3
+
+** User variable wisi-mckenzie-cost-limit is deleted; set
+ wisi-mckenzie-enqueue-limit instead, it gives better results.
+
+** `wisi-show-parse-errors' now shows errors in a dedicated window, so
+ it will not be resized or reused.
+
+** New grammar action `wisi-name-action'; sets a name that will be
+ fontified. This replaces the previous 'name' navigate class.
+
+** Support 'nil' as an indent argument; useful for the first token,
+ whose indent is typically unknown. Indent functions that do not
+ accumulate now only check for "nil", not "zero or nil".
+
+** New file wisi-xref.el provides a completion table built from tokens
+ marked by the new grammar action `wisi-name-action'.
+
+** The process parser checks the parser process protocol version, to
+ ensure the elisp code matches the process code.
+
+** The process parser supports passing data to a language-specific
+ elisp function, via the `language-action-table' field of the
+ `wisi-process--parser' struct.
+
+** New user option `wisi-parse-max-parallel' to set the number of
+ parallel parsers used; Java needs more than Ada.
+
* wisi 2.1.0
21 Mar 2019
+** parser process protocol version 2
+
** Add support for partial parsing; useful in very large files. Files
larger than wisi-partial-parse-threshold (default 100_001) will be
parsed partially.
@@ -23,6 +56,8 @@ Please send wisi bug reports to bug-gnu-emacs@gnu.org, with
* wisi 2.0.1
8 Dec 2018
+** parser process protocol version 1
+
** Assign copyright in Ada files to FSF
** Update user guide, include it in elpa package
diff --git a/README b/README
index db1af26..f7fc4eb 100644
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-Emacs wisi package 2.1.0
+Emacs wisi package 2.1.1
The wisi package provides utilities for using generalized LALR parsers
(in elisp or external processes) to do indentation, fontification, and
diff --git a/sal-ada_containers-gen_doubly_linked_lists_image.adb
b/sal-ada_containers-gen_doubly_linked_lists_image.adb
new file mode 100644
index 0000000..a5dd042
--- /dev/null
+++ b/sal-ada_containers-gen_doubly_linked_lists_image.adb
@@ -0,0 +1,50 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Unbounded;
+function SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
+ (Item : in Lists.List;
+ Strict : in Boolean := False)
+ return String
+is
+ use all type Ada.Containers.Count_Type;
+ use Ada.Strings;
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ Need_Comma : Boolean := False;
+begin
+ if Strict and Item.Length = 0 then
+ return "(1 .. 0 => <>)";
+
+ elsif Strict and Item.Length = 1 then
+ return "(1 => " & Element_Image (Lists.Element (Item.First)) & ")";
+
+ else
+ for El of Item loop
+ if Need_Comma then
+ Result := Result & ", ";
+ else
+ Need_Comma := True;
+ end if;
+ Result := Result & Element_Image (El);
+ end loop;
+ Result := Result & ")";
+ return To_String (Result);
+ end if;
+end SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image;
diff --git a/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
b/sal-ada_containers-gen_doubly_linked_lists_image.ads
similarity index 56%
copy from sal-gen_unbounded_definite_vectors-gen_image_aux.ads
copy to sal-ada_containers-gen_doubly_linked_lists_image.ads
index 0be7c41..39e9b9e 100644
--- a/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
+++ b/sal-ada_containers-gen_doubly_linked_lists_image.ads
@@ -1,8 +1,8 @@
-- Abstract :
--
--- Image with auxiliary data for instantiations of parent.
+-- Image for normal Ada array types
--
--- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+-- Copyright (C) 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -16,8 +16,13 @@
-- version 3.1, as published by the Free Software Foundation.
pragma License (Modified_GPL);
-
+with Ada.Containers.Doubly_Linked_Lists;
generic
- type Aux_Data (<>) is private;
- with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector;
Aux : in Aux_Data) return String;
+ type Element_Type is private;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+ with package Lists is new Ada.Containers.Doubly_Linked_Lists (Element_Type,
"=");
+ with function Element_Image (Item : in Element_Type) return String;
+function SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
+ (Item : in Lists.List;
+ Strict : in Boolean := False)
+ return String;
diff --git a/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
b/sal-ada_containers.ads
similarity index 64%
copy from sal-gen_unbounded_definite_vectors-gen_image_aux.ads
copy to sal-ada_containers.ads
index 0be7c41..4afad1e 100644
--- a/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
+++ b/sal-ada_containers.ads
@@ -1,23 +1,21 @@
--- Abstract :
---
--- Image with auxiliary data for instantiations of parent.
---
--- Copyright (C) 2018 Stephen Leake All Rights Reserved.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Aux_Data (<>) is private;
- with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector;
Aux : in Aux_Data) return String;
+-- Abstract :
+--
+-- Root of extensions to Ada.Containers.
+--
+-- Copyright (C) 2019 Free Software Foundation All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+package SAL.Ada_Containers is
+
+end SAL.Ada_Containers;
diff --git a/sal-gen_bounded_definite_queues.adb
b/sal-gen_bounded_definite_queues.adb
new file mode 100644
index 0000000..61e5c12
--- /dev/null
+++ b/sal-gen_bounded_definite_queues.adb
@@ -0,0 +1,154 @@
+-- Abstract:
+--
+-- See spec.
+--
+-- Copyright (C) 2004, 2008, 2009, 2011, 2017, 2019 Free Software Foundation
All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Bounded_Definite_Queues is
+
+ -- Local subprograms
+
+ function Wrap (Queue : in Queue_Type; I : in Integer) return Integer
+ is begin
+ if I > Queue.Size then
+ return I - Queue.Size;
+ elsif I < 1 then
+ return Queue.Size + I;
+ else
+ return I;
+ end if;
+ end Wrap;
+
+ ----------
+ -- Public subprograms
+
+ function Get_Overflow_Handling (Queue : in Queue_Type) return
Overflow_Action_Type
+ is begin
+ return Queue.Overflow_Handling;
+ end Get_Overflow_Handling;
+
+ procedure Set_Overflow_Handling (Queue : in out Queue_Type; Handling : in
Overflow_Action_Type)
+ is begin
+ Queue.Overflow_Handling := Handling;
+ end Set_Overflow_Handling;
+
+ procedure Clear (Queue : in out Queue_Type) is
+ begin
+ Queue.Count := 0;
+ end Clear;
+
+ function Count (Queue : in Queue_Type) return Natural is
+ begin
+ return Queue.Count;
+ end Count;
+
+ function Is_Empty (Queue : in Queue_Type) return Boolean is
+ begin
+ return Queue.Count = 0;
+ end Is_Empty;
+
+ function Is_Full (Queue : in Queue_Type) return Boolean is
+ begin
+ return Queue.Count = Queue.Size;
+ end Is_Full;
+
+ function Remove (Queue : in out Queue_Type) return Item_Type
+ is begin
+ if Queue.Count = 0 then
+ raise Container_Empty;
+ end if;
+
+ return Item : constant Item_Type := Queue.Data (Queue.Head)
+ do
+ Queue.Count := Queue.Count - 1;
+
+ if Queue.Count > 0 then
+ Queue.Head := Wrap (Queue, Queue.Head + 1);
+ end if;
+ end return;
+ end Remove;
+
+ procedure Drop (Queue : in out Queue_Type)
+ is begin
+ if Queue.Count = 0 then
+ raise Container_Empty;
+ end if;
+
+ Queue.Count := Queue.Count - 1;
+
+ if Queue.Count > 0 then
+ Queue.Head := Wrap (Queue, Queue.Head + 1);
+ end if;
+ end Drop;
+
+ function Peek (Queue : in Queue_Type; N : Integer := 0) return Item_Type
+ is begin
+ if Queue.Count = 0 then
+ raise Container_Empty;
+ end if;
+
+ return Queue.Data (Wrap (Queue, Queue.Head + N));
+ end Peek;
+
+ procedure Add (Queue : in out Queue_Type; Item : in Item_Type) is
+ begin
+ if Queue.Count = Queue.Size then
+ case Queue.Overflow_Handling is
+ when Error =>
+ raise Container_Full;
+ when Overwrite =>
+ Queue.Count := Queue.Count - 1;
+ Queue.Head := Wrap (Queue, Queue.Head + 1);
+ end case;
+ end if;
+
+ if Queue.Count = 0 then
+ Queue.Tail := 1;
+ Queue.Head := 1;
+ Queue.Count := 1;
+ Queue.Data (1) := Item;
+ else
+ Queue.Tail := Wrap (Queue, Queue.Tail + 1);
+ Queue.Data (Queue.Tail) := Item;
+ Queue.Count := Queue.Count + 1;
+ end if;
+ end Add;
+
+ procedure Add_To_Head (Queue : in out Queue_Type; Item : in Item_Type) is
+ begin
+ if Queue.Count = Queue.Size then
+ case Queue.Overflow_Handling is
+ when Error =>
+ raise Container_Full;
+ when Overwrite =>
+ Queue.Count := Queue.Count - 1;
+ Queue.Tail := Wrap (Queue, Queue.Tail + 1);
+ end case;
+ end if;
+
+ if Queue.Count = 0 then
+ Queue.Tail := 1;
+ Queue.Head := 1;
+ Queue.Count := 1;
+ Queue.Data (1) := Item;
+ else
+ Queue.Head := Wrap (Queue, Queue.Head - 1);
+ Queue.Data (Queue.Head) := Item;
+ Queue.Count := Queue.Count + 1;
+ end if;
+ end Add_To_Head;
+
+end SAL.Gen_Bounded_Definite_Queues;
diff --git a/sal-gen_bounded_definite_queues.ads
b/sal-gen_bounded_definite_queues.ads
new file mode 100644
index 0000000..0b286f8
--- /dev/null
+++ b/sal-gen_bounded_definite_queues.ads
@@ -0,0 +1,99 @@
+-- Abstract:
+--
+-- A generic queue, allowing definite non-limited item types.
+--
+-- Copyright (C) 2004, 2008, 2009, 2011, 2017, 2019 Free Software Foundation
All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Item_Type is private;
+package SAL.Gen_Bounded_Definite_Queues is
+ pragma Pure;
+
+ type Queue_Type (Size : Positive) is tagged private;
+ -- Size is maximum number of items in the queue.
+ -- Tagged to allow Object.Method syntax.
+
+ function Get_Overflow_Handling (Queue : in Queue_Type) return
Overflow_Action_Type;
+ procedure Set_Overflow_Handling (Queue : in out Queue_Type; Handling : in
Overflow_Action_Type);
+ -- See Add for meaning of Overflow_Handling. Default is Error.
+
+ procedure Clear (Queue : in out Queue_Type);
+ -- Empty Queue of all items.
+
+ function Count (Queue : in Queue_Type) return Natural;
+ -- Returns count of items in the Queue
+
+ function Is_Empty (Queue : in Queue_Type) return Boolean;
+ -- Returns true if no items are in Queue.
+
+ function Is_Full (Queue : in Queue_Type) return Boolean;
+ -- Returns true if Queue is full.
+
+ function Remove (Queue : in out Queue_Type) return Item_Type;
+ -- Remove head item from Queue, return it.
+ --
+ -- Raises Container_Empty if Is_Empty.
+
+ function Get (Queue : in out Queue_Type) return Item_Type renames Remove;
+
+ procedure Drop (Queue : in out Queue_Type);
+ -- Remove head item from Queue, discard it.
+ --
+ -- Raises Container_Empty if Is_Empty.
+
+ function Peek (Queue : in Queue_Type; N : Integer := 0) return Item_Type;
+ -- Return a copy of a queue item, without removing it. N = 0 is
+ -- the queue head.
+
+ procedure Add (Queue : in out Queue_Type; Item : in Item_Type);
+ -- Add Item to the tail of Queue.
+ --
+ -- If Queue is full, result depends on Queue.Overflow_Handling:
+ --
+ -- when Overwrite, an implicit Remove is done (and the data
+ -- discarded), then Add is done.
+ --
+ -- when Error, raises Container_Full.
+
+ procedure Put (Queue : in out Queue_Type; Item : in Item_Type) renames Add;
+
+ procedure Add_To_Head (Queue : in out Queue_Type; Item : in Item_Type);
+ -- Add Item to the head of Queue.
+ --
+ -- If Queue is full, result depends on Queue.Overflow_Handling:
+ --
+ -- when Overwrite, an implicit Remove is done (and the data
+ -- discarded), then Add is done.
+ --
+ -- when Error, raises Container_Full.
+
+private
+
+ type Item_Array_Type is array (Positive range <>) of Item_Type;
+
+ type Queue_Type (Size : Positive) is tagged record
+ Overflow_Handling : Overflow_Action_Type := Error;
+
+ Head : Natural := 0;
+ Tail : Natural := 0;
+ Count : Natural := 0;
+ Data : Item_Array_Type (1 .. Size);
+ -- Add at Tail + 1, remove at Head. Count is current count;
+ -- easier to keep track of that than to compute Is_Empty for
+ -- each Add and Remove.
+ end record;
+
+end SAL.Gen_Bounded_Definite_Queues;
diff --git a/sal-gen_bounded_definite_vectors-gen_sorted.adb
b/sal-gen_bounded_definite_vectors-gen_sorted.adb
index 5a8c550..b77f06c 100644
--- a/sal-gen_bounded_definite_vectors-gen_sorted.adb
+++ b/sal-gen_bounded_definite_vectors-gen_sorted.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -39,8 +39,9 @@ package body SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted is
end Insert;
procedure Insert
- (Container : in out Vector;
- New_Item : in Element_Type)
+ (Container : in out Vector;
+ New_Item : in Element_Type;
+ Ignore_If_Equal : in Boolean := False)
is
K : constant Base_Peek_Type := To_Peek_Index (Container.Last);
J : Base_Peek_Type := K;
@@ -62,8 +63,12 @@ package body SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted is
when Less =>
J := J - 1;
when Equal =>
- -- Insert after J
- exit;
+ if Ignore_If_Equal then
+ return;
+ else
+ -- Insert after J
+ exit;
+ end if;
when Greater =>
-- Insert after J
exit;
diff --git a/sal-gen_bounded_definite_vectors-gen_sorted.ads
b/sal-gen_bounded_definite_vectors-gen_sorted.ads
index 917a344..e6e101f 100644
--- a/sal-gen_bounded_definite_vectors-gen_sorted.ads
+++ b/sal-gen_bounded_definite_vectors-gen_sorted.ads
@@ -2,7 +2,7 @@
--
-- Add sorted behavior to parent.
--
--- Copyright (C) 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -41,10 +41,12 @@ package SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted is
not overriding
procedure Insert
- (Container : in out Vector;
- New_Item : in Element_Type);
+ (Container : in out Vector;
+ New_Item : in Element_Type;
+ Ignore_If_Equal : in Boolean := False);
-- Insert New_Item in sorted position. Items are sorted in increasing
-- order according to Element_Compare. New_Item is inserted after
- -- Equal items.
+ -- Equal items, unless Ignore_If_Equal is true, in which case
+ -- New_Item is not inserted.
end SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted;
diff --git a/sal-gen_graphs.adb b/sal-gen_graphs.adb
new file mode 100644
index 0000000..284b26c
--- /dev/null
+++ b/sal-gen_graphs.adb
@@ -0,0 +1,718 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2019 Free Software Foundation All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Unbounded;
+with Ada.Text_IO;
+with SAL.Gen_Bounded_Definite_Queues;
+with SAL.Gen_Unbounded_Definite_Stacks;
+package body SAL.Gen_Graphs is
+
+ package Vertex_Queues is new SAL.Gen_Bounded_Definite_Queues (Vertex_Index);
+ package Vertex_Stacks is new SAL.Gen_Unbounded_Definite_Stacks
(Vertex_Index);
+
+ function Find (Data : in Edge_Data; List : in Edge_Node_Lists.List) return
Edge_Node_Lists.Cursor
+ is begin
+ for I in List.Iterate loop
+ if Edge_Node_Lists.Element (I).Data = Data then
+ return I;
+ end if;
+ end loop;
+ return Edge_Node_Lists.No_Element;
+ end Find;
+
+ ----------
+ -- Visible subprograms
+
+ procedure Add_Edge
+ (Graph : in out Gen_Graphs.Graph;
+ Vertex_A : in Vertex_Index;
+ Vertex_B : in Vertex_Index;
+ Data : in Edge_Data)
+ is
+ Multigraph : Boolean := False;
+
+ procedure Update_First_Last (Vertex : in Vertex_Index)
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Graph.Vertices.Length = 0 then
+ Graph.Vertices.Set_First_Last (Vertex, Vertex);
+ else
+ if Vertex < Graph.Vertices.First_Index then
+ Graph.Vertices.Set_First (Vertex);
+ end if;
+ if Vertex > Graph.Vertices.Last_Index then
+ Graph.Vertices.Set_Last (Vertex);
+ end if;
+ end if;
+ end Update_First_Last;
+
+ begin
+ Update_First_Last (Vertex_A);
+ Update_First_Last (Vertex_B);
+
+ Graph.Last_Edge_ID := Graph.Last_Edge_ID + 1;
+ if (for some E of Graph.Vertices (Vertex_A) => E.Vertex_B = Vertex_B)
then
+ Multigraph := True;
+ Graph.Multigraph := True;
+ end if;
+
+ Graph.Vertices (Vertex_A).Append ((Graph.Last_Edge_ID, Vertex_B,
Multigraph, Data));
+ end Add_Edge;
+
+ function Count_Nodes (Graph : in Gen_Graphs.Graph) return
Ada.Containers.Count_Type
+ is begin
+ return Graph.Vertices.Length;
+ end Count_Nodes;
+
+ function Count_Edges (Graph : in Gen_Graphs.Graph) return
Ada.Containers.Count_Type
+ is
+ use Ada.Containers;
+ Result : Count_Type := 0;
+ begin
+ for Edges of Graph.Vertices loop
+ Result := Result + Edges.Length;
+ end loop;
+ return Result;
+ end Count_Edges;
+
+ function Multigraph (Graph : in Gen_Graphs.Graph) return Boolean
+ is begin
+ return Graph.Multigraph;
+ end Multigraph;
+
+ function "+" (Right : in Edge_Item) return Edge_Lists.List
+ is
+ use Edge_Lists;
+ begin
+ return Result : List do
+ Append (Result, Right);
+ end return;
+ end "+";
+
+ function Edges (Graph : in Gen_Graphs.Graph; Vertex : in Vertex_Index)
return Edge_Lists.List
+ is begin
+ return Result : Edge_Lists.List do
+ for E of Graph.Vertices (Vertex) loop
+ Result.Append ((E.ID, E.Data));
+ end loop;
+ end return;
+ end Edges;
+
+ function Image (Item : in Path) return String
+ is
+ use Ada.Strings.Unbounded;
+
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ begin
+ for I in Item'Range loop
+ Result := Result & Trimmed_Image (Item (I).Vertex) & " " &
+ Image ((if I = Item'Last then Item (Item'First).Edges else Item (I
+ 1).Edges)) & " -> ";
+ end loop;
+ Result := Result & ")";
+ return To_String (Result);
+ end Image;
+
+ function "<" (Left, Right : in Path) return Boolean
+ is begin
+ for I in Left'Range loop
+ if I > Right'Last then
+ return False;
+ elsif Left (I).Vertex < Right (I).Vertex then
+ return True;
+ elsif Left (I).Vertex > Right (I).Vertex then
+ return False;
+ else
+ -- =; check remaining elements
+ null;
+ end if;
+ end loop;
+
+ if Left'Last < Right'Last then
+ return True;
+ else
+ -- All =
+ return False;
+ end if;
+ end "<";
+
+ function Find_Paths
+ (Graph : in out Gen_Graphs.Graph;
+ From : in Vertex_Index;
+ To : in Edge_Data)
+ return Path_Arrays.Vector
+ is
+ Vertex_Queue : Vertex_Queues.Queue_Type
+ (Size => Integer (Graph.Vertices.Last_Index -
Graph.Vertices.First_Index + 1));
+
+ type Colors is (White, Gray, Black);
+
+ type Aux_Node is record
+ Color : Colors := Colors'First;
+ D : Natural := Natural'Last;
+ Parent : Vertex_Index'Base := Invalid_Vertex;
+ Parent_Set : Boolean := False;
+ Parent_Edge : Edge_Node_Lists.Cursor := Edge_Node_Lists.No_Element;
+ end record;
+
+ package Aux_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(Vertex_Index, Aux_Node, (others => <>));
+ Aux : Aux_Arrays.Vector;
+
+ function Build_Path
+ (Tail_Vertex : in Vertex_Index;
+ Tail_Edge : in Edge_Node_Lists.Cursor)
+ return Path
+ is
+ begin
+ return Result : Path (1 .. Aux (Tail_Vertex).D + 1)
+ do
+ declare
+ use Edge_Node_Lists;
+ V_Index : Vertex_Index := Tail_Vertex;
+ Last_Edge : Cursor := Tail_Edge;
+ begin
+ for I in reverse 1 .. Result'Length loop
+ declare
+ V : Aux_Node renames Aux (V_Index);
+ begin
+ if Last_Edge = No_Element then
+ Result (I) := (V_Index, Edge_Lists.Empty_List);
+ else
+ Result (I) := (V_Index, +(Element (Last_Edge).ID,
Element (Last_Edge).Data));
+ end if;
+
+ if V.Parent_Set then
+ Last_Edge := V.Parent_Edge;
+ V_Index := V.Parent;
+ end if;
+ end;
+ end loop;
+ end;
+ end return;
+ end Build_Path;
+
+ Result_List : Path_Arrays.Vector;
+ Result_Edge : Edge_Node_Lists.Cursor;
+ begin
+ -- [1] figure 22.3 breadth-first search; 'From' = s.
+
+ Aux.Set_First_Last (Graph.Vertices.First_Index,
Graph.Vertices.Last_Index);
+
+ for I in Aux.First_Index .. Aux.Last_Index loop
+ if I = From then
+ Aux (I).Color := Gray;
+ Aux (I).D := 0;
+ Aux (I).Parent_Set := False;
+
+ else
+ Aux (I).Color := White;
+ Aux (I).D := Natural'Last;
+ Aux (I).Parent_Set := False;
+ end if;
+ end loop;
+
+ Vertex_Queue.Put (From);
+
+ while not Vertex_Queue.Is_Empty loop
+ declare
+ U_Index : constant Vertex_Index := Vertex_Queue.Get;
+ U : Aux_Node renames Aux (U_Index);
+ begin
+ Edges :
+ for C in Graph.Vertices (U_Index).Iterate loop
+ declare
+ use all type Edge_Node_Lists.Cursor;
+ V_Index : constant Vertex_Index := Edge_Node_Lists.Element
(C).Vertex_B;
+ V : Aux_Node renames Aux (V_Index);
+ begin
+ if V.Color = White then
+ V.Color := Gray;
+ V.D := U.D + 1;
+ V.Parent := U_Index;
+ V.Parent_Edge := C;
+ V.Parent_Set := True;
+
+ Result_Edge := Find (To, Graph.Vertices (V_Index));
+ if Result_Edge /= Edge_Node_Lists.No_Element then
+ Result_List.Append (Build_Path (V_Index, Result_Edge));
+ end if;
+
+ Vertex_Queue.Put (V_Index);
+ end if;
+ end;
+ end loop Edges;
+ U.Color := Black;
+ end;
+ end loop;
+ return Result_List;
+ end Find_Paths;
+
+ function Find_Cycles_Tiernan (Graph : in Gen_Graphs.Graph)
+ return Path_Arrays.Vector
+ is
+ -- Implements [2] "Algorithm EC"
+ --
+ -- vertex 0 = Invalid_Vertex
+ -- vertex 1 = Graph.Vertices.First_Index
+ -- vertex N = Graph.Vertices.Last_Index
+
+ First : Vertex_Index renames Graph.Vertices.First_Index;
+ Last : Vertex_Index renames Graph.Vertices.Last_Index;
+
+ G : Vertex_Arrays.Vector renames Graph.Vertices;
+ P : Path (1 .. Integer (Last - First + 1));
+ K : Positive := 1; -- ie P_Last
+
+ type H_Row is array (G.First_Index .. G.Last_Index) of Vertex_Index'Base;
+ H : array (G.First_Index .. G.Last_Index) of H_Row := (others => (others
=> Invalid_Vertex));
+
+ Next_Vertex_Found : Boolean;
+
+ Result : Path_Arrays.Vector;
+
+ function Contains (P : in Path; V : in Vertex_Index) return Boolean
+ is (for some N of P => N.Vertex = V);
+
+ function Contains (Row : in H_Row; V : in Vertex_Index) return Boolean
+ is (for some N of Row => N = V);
+
+ function Contains (Edges : in Edge_Lists.List; ID : in Edge_ID) return
Boolean
+ is (for some E of Edges => E.ID = ID);
+
+ procedure Add_Alternate_Edges (P : in out Path)
+ is
+ function Dec (I : in Positive) return Positive
+ is (if I = P'First then P'Last else I - 1);
+ begin
+ for I in P'Range loop
+ for New_Edge of G (P (Dec (I)).Vertex) loop
+ if New_Edge.Vertex_B = P (I).Vertex and (not Contains (P
(I).Edges, New_Edge.ID)) then
+ P (I).Edges.Append ((New_Edge.ID, New_Edge.Data));
+ end if;
+ end loop;
+ end loop;
+ end Add_Alternate_Edges;
+
+ begin
+ P (1) := (First, Edge_Lists.Empty_List);
+
+ All_Initial_Vertices :
+ loop
+ Explore_Vertex :
+ loop
+ Path_Extension :
+ loop -- EC2 Path Extension
+ Next_Vertex_Found := False;
+
+ Find_Next_Vertex :
+ for Edge of G (P (K).Vertex) loop
+ declare
+ Next_Vertex : constant Vertex_Index := Edge.Vertex_B; --
ie G[P[k],j]
+ begin
+ if Next_Vertex > P (1).Vertex and -- (1)
+ (not Contains (P, Next_Vertex)) and -- (2)
+ (not Contains (H (P (K).Vertex), Next_Vertex))
+ then
+ K := K + 1;
+ P (K) := (Next_Vertex, +(Edge.ID, Edge.Data));
+
+ Next_Vertex_Found := True;
+ exit Find_Next_Vertex;
+ end if;
+ end;
+ end loop Find_Next_Vertex;
+
+ exit Path_Extension when not Next_Vertex_Found;
+ end loop Path_Extension;
+
+ -- EC3 Circuit Confirmation
+ for Edge of G (P (K).Vertex) loop
+ if Edge.Vertex_B = P (1).Vertex then
+ P (1).Edges := +(Edge.ID, Edge.Data);
+ if Graph.Multigraph then
+ Add_Alternate_Edges (P (1 .. K));
+ end if;
+ Result.Append (P (1 .. K));
+ exit;
+ end if;
+ end loop;
+
+ -- EC4 Vertex Closure
+ exit Explore_Vertex when K = 1;
+
+ H (P (K).Vertex) := (others => Invalid_Vertex);
+ for M in H (P (K - 1).Vertex)'Range loop
+ if H (P (K - 1).Vertex)(M) = Invalid_Vertex then
+ H (P (K - 1).Vertex)(M) := P (K).Vertex;
+ P (K) := (Invalid_Vertex, Edge_Lists.Empty_List);
+ exit;
+ end if;
+ end loop;
+ K := K - 1;
+ end loop Explore_Vertex;
+
+ -- EC5 Advance Initial Index
+ exit All_Initial_Vertices when P (1).Vertex =
Graph.Vertices.Last_Index;
+
+ P (1) := (P (1).Vertex + 1, Edge_Lists.Empty_List);
+ pragma Assert (K = 1);
+ H := (others => (others => Invalid_Vertex));
+ end loop All_Initial_Vertices;
+
+ -- EC6 Terminate
+ return Result;
+ end Find_Cycles_Tiernan;
+
+ function Find_Cycles (Graph : in Gen_Graphs.Graph) return Path_Arrays.Vector
+ is
+ -- Implements Circuit-Finding Algorithm from [3]
+
+ use all type Ada.Containers.Count_Type;
+
+ pragma Warnings (Off, """Edited_Graph"" is not modified, could be
declared constant");
+ Edited_Graph : Gen_Graphs.Graph := Graph;
+
+ Result : Path_Arrays.Vector;
+
+ A_K : Adjacency_Structures.Vector;
+ B : Adjacency_Structures.Vector;
+ Blocked : array (Graph.Vertices.First_Index ..
Graph.Vertices.Last_Index) of Boolean := (others => False);
+
+ Stack : Vertex_Stacks.Stack;
+ S : Vertex_Index := Graph.Vertices.First_Index;
+
+ Dummy : Boolean;
+ pragma Unreferenced (Dummy);
+
+ function Circuit (V : in Vertex_Index) return Boolean
+ is
+ F : Boolean := False;
+
+ procedure Unblock (U : in Vertex_Index)
+ is begin
+ Blocked (U) := False;
+ declare
+ use Vertex_Lists;
+ Cur : Cursor := B (U).First;
+ Temp : Cursor;
+ W : Vertex_Index;
+ begin
+ loop
+ exit when not Has_Element (Cur);
+ W := Element (Cur);
+ Temp := Cur;
+ Next (Cur);
+ B (U).Delete (Temp);
+ if Blocked (W) then
+ Unblock (W);
+ end if;
+ end loop;
+ end;
+ end Unblock;
+
+ procedure Add_Result
+ is
+ Cycle : Path (1 .. Integer (Stack.Depth));
+ begin
+ for I in 1 .. Stack.Depth loop
+ Cycle (Integer (Stack.Depth - I + 1)) := (Stack.Peek (I),
Edge_Lists.Empty_List);
+ -- We add the edge info later, after finding all the cycles.
+ end loop;
+ Result.Append (Cycle);
+ if Trace > 0 then
+ Ada.Text_IO.Put_Line ("cycle " & Image (Cycle));
+ end if;
+ end Add_Result;
+
+ begin
+ if Trace > 0 then
+ Ada.Text_IO.Put_Line ("circuit start" & V'Image);
+ end if;
+
+ Stack.Push (V);
+ Blocked (V) := True;
+ if V in A_K.First_Index .. A_K.Last_Index then
+ for W of A_K (V) loop
+ if W = S then
+ Add_Result;
+ F := True;
+ elsif not Blocked (W) then
+ if Circuit (W) then
+ F := True;
+ end if;
+ end if;
+ end loop;
+ end if;
+ if F then
+ Unblock (V);
+ else
+ if V in A_K.First_Index .. A_K.Last_Index then
+ for W of A_K (V) loop
+ if (for all V1 of B (W) => V /= V1) then
+ B (W).Append (V);
+ end if;
+ end loop;
+ end if;
+ end if;
+ Stack.Pop;
+ if Trace > 0 then
+ Ada.Text_IO.Put_Line ("circuit finish" & V'Image);
+ end if;
+ return F;
+ end Circuit;
+
+ begin
+ -- [3] restricts the graph to not have loops (edge v-v) or multiple
+ -- edges between two nodes. So we first delete any such edges.
+ Delete_Loops_Multigraph :
+ for V in Edited_Graph.Vertices.First_Index ..
Edited_Graph.Vertices.Last_Index loop
+ declare
+ use Edge_Node_Lists;
+ Cur : Cursor := Edited_Graph.Vertices (V).First;
+ Temp : Cursor;
+ Found_Loop : Boolean := False;
+ begin
+ loop
+ exit when not Has_Element (Cur);
+ if Element (Cur).Vertex_B = V then
+ if not Found_Loop then
+ -- This is a cycle we want in the result. Edge data is
added to all
+ -- cycles later.
+ Result.Append (Path'(1 => (V, Edge_Lists.Empty_List)));
+ Found_Loop := True;
+ end if;
+ Temp := Cur;
+ Next (Cur);
+ Edited_Graph.Vertices (V).Delete (Temp);
+ elsif Element (Cur).Multigraph then
+ -- These will be added back from Graph after we find all
cycles.
+ Temp := Cur;
+ Next (Cur);
+ Edited_Graph.Vertices (V).Delete (Temp);
+ else
+ Next (Cur);
+ end if;
+ end loop;
+ end;
+ end loop Delete_Loops_Multigraph;
+
+ B.Set_First_Last (Graph.Vertices.First_Index, Graph.Vertices.Last_Index);
+
+ -- Start of body of Circuit-Finding Algorithm from [3]
+ loop
+ exit when S = Graph.Vertices.Last_Index;
+ declare
+ use Component_Lists;
+ Subgraph : Adjacency_Structures.Vector;
+ Components : Component_Lists.List;
+ Cur : Component_Lists.Cursor;
+ Least_Vertex_Cur : Component_Lists.Cursor;
+ Least_Vertex_V : Vertex_Index := Vertex_Index'Last;
+
+ function Delete_Edges (Edges : in Edge_Node_Lists.List) return
Vertex_Lists.List
+ is begin
+ return Result : Vertex_Lists.List do
+ for Edge of Edges loop
+ if Edge.Vertex_B >= S then
+ Result.Append (Edge.Vertex_B);
+ end if;
+ end loop;
+ end return;
+ end Delete_Edges;
+ begin
+ Subgraph.Set_First_Last (S, Edited_Graph.Vertices.Last_Index);
+ for V in S .. Edited_Graph.Vertices.Last_Index loop
+ Subgraph (V) := Delete_Edges (Edited_Graph.Vertices (V));
+ end loop;
+
+ Components := Strongly_Connected_Components (Subgraph,
Non_Trivial_Only => True);
+ Cur := Components.First;
+ loop
+ exit when not Has_Element (Cur);
+
+ if Element (Cur).Length > 1 then
+ declare
+ Comp : Vertex_Lists.List renames
Components.Constant_Reference (Cur);
+ begin
+ for W of Comp loop
+ if W < Least_Vertex_V then
+ Least_Vertex_Cur := Cur;
+ Least_Vertex_V := W;
+ end if;
+ end loop;
+ end;
+ end if;
+ Next (Cur);
+ end loop;
+
+ A_K.Clear;
+ if Has_Element (Least_Vertex_Cur) then
+ declare
+ Component : Vertex_Lists.List renames Components
(Least_Vertex_Cur);
+ Min : Vertex_Index := Vertex_Index'Last;
+ Max : Vertex_Index := Vertex_Index'First;
+ begin
+ if Trace > 0 then
+ Ada.Text_IO.Put_Line ("strong component " &
Least_Vertex_V'Image);
+ Ada.Text_IO.Put_Line (Image (Component));
+ end if;
+ for V of Component loop
+ if Min > V then
+ Min := V;
+ end if;
+ if Max < V then
+ Max := V;
+ end if;
+ end loop;
+ A_K.Set_First_Last (Min, Max);
+ for V of Component loop
+ for Edge of Edited_Graph.Vertices (V) loop
+ A_K (V).Append (Edge.Vertex_B);
+ end loop;
+ end loop;
+ end;
+ end if;
+ end;
+
+ if A_K.Length > 0 then
+ S := A_K.First_Index;
+ for I in A_K.First_Index .. A_K.Last_Index loop
+ Blocked (I) := False;
+ B (I).Clear;
+ end loop;
+ Dummy := Circuit (S);
+ S := S + 1;
+ else
+ S := Graph.Vertices.Last_Index;
+ end if;
+ end loop;
+
+ -- Add edge data.
+ for Cycle of Result loop
+ for I in Cycle'First .. Cycle'Last loop
+ declare
+ Prev_I : constant Positive := (if I = Cycle'First then
Cycle'Last else I - 1);
+ begin
+ for Edge of Graph.Vertices (Cycle (Prev_I).Vertex) loop
+ if Cycle (I).Vertex = Edge.Vertex_B then
+ Cycle (I).Edges.Append ((Edge.ID, Edge.Data));
+ end if;
+ end loop;
+ end;
+ end loop;
+ end loop;
+ return Result;
+ end Find_Cycles;
+
+ function Loops (Graph : in Gen_Graphs.Graph) return Vertex_Lists.List
+ is begin
+ return Result : Vertex_Lists.List do
+ for V in Graph.Vertices.First_Index .. Graph.Vertices.Last_Index loop
+ for Edge of Graph.Vertices (V) loop
+ if V = Edge.Vertex_B then
+ Result.Append (V);
+ exit;
+ end if;
+ end loop;
+ end loop;
+ end return;
+ end Loops;
+
+ function To_Adjancency (Graph : in Gen_Graphs.Graph) return
Adjacency_Structures.Vector
+ is
+ function To_Vertex_List (Edges : in Edge_Node_Lists.List) return
Vertex_Lists.List
+ is begin
+ return Result : Vertex_Lists.List do
+ for Edge of Edges loop
+ Result.Append (Edge.Vertex_B);
+ end loop;
+ end return;
+ end To_Vertex_List;
+ begin
+ return Result : Adjacency_Structures.Vector do
+ Result.Set_First_Last (Graph.Vertices.First_Index,
Graph.Vertices.Last_Index);
+ for V in Graph.Vertices.First_Index .. Graph.Vertices.Last_Index loop
+ Result (V) := To_Vertex_List (Graph.Vertices (V));
+ end loop;
+ end return;
+ end To_Adjancency;
+
+ function Strongly_Connected_Components
+ (Graph : in Adjacency_Structures.Vector;
+ Non_Trivial_Only : in Boolean := False)
+ return Component_Lists.List
+ is
+ -- Implements [4] section 4.
+
+ Low_Link : array (Graph.First_Index .. Graph.Last_Index) of
Vertex_Index'Base := (others => Invalid_Vertex);
+
+ Number : array (Graph.First_Index .. Graph.Last_Index) of
Vertex_Index'Base := (others => Invalid_Vertex);
+ -- Number is the order visited in the depth-first search.
+
+ Points : Vertex_Stacks.Stack;
+
+ I : Vertex_Index'Base := Graph.First_Index - 1;
+
+ Result : Component_Lists.List;
+
+ procedure Strong_Connect (V : in Vertex_Index)
+ is begin
+ I := I + 1;
+ Number (V) := I;
+ Low_Link (V) := I;
+ Points.Push (V);
+
+ for W of Graph (V) loop
+ if Number (W) = Invalid_Vertex then
+ -- (v, w) is a tree arc
+ Strong_Connect (W);
+ Low_Link (V) := Vertex_Index'Min (Low_Link (V), Low_Link (W));
+
+ elsif Number (W) < Number (V) then
+ -- (v, w) is a frond or cross-link
+ if (for some P of Points => P = W) then
+ Low_Link (V) := Vertex_Index'Min (Low_Link (V), Low_Link
(W));
+ end if;
+ end if;
+ end loop;
+ if Low_Link (V) = Number (V) then
+ -- v is the root of a component
+ declare
+ use all type Ada.Containers.Count_Type;
+ Component : Vertex_Lists.List;
+ begin
+ while (not Points.Is_Empty) and then Number (Points.Peek) >=
Number (V) loop
+ Component.Append (Points.Pop);
+ end loop;
+ if (not Non_Trivial_Only) or Component.Length > 1 then
+ Result.Append (Component);
+ end if;
+ end;
+ end if;
+ end Strong_Connect;
+ begin
+ for W in Graph.First_Index .. Graph.Last_Index loop
+ if Number (W) = Invalid_Vertex then
+ Strong_Connect (W);
+ end if;
+ end loop;
+ return Result;
+ end Strongly_Connected_Components;
+
+end SAL.Gen_Graphs;
diff --git a/sal-gen_graphs.ads b/sal-gen_graphs.ads
new file mode 100644
index 0000000..9a66f5c
--- /dev/null
+++ b/sal-gen_graphs.ads
@@ -0,0 +1,190 @@
+-- Abstract :
+--
+-- Type and operations for graphs.
+--
+-- References:
+--
+-- [1] Introduction to Algorithms, Thomas H. Cormen, Charles E.
+-- Leiserson, Ronald L. Rivest, Clifford Stein.
+--
+-- [2] "An Efficient Search Algorithm to Find the Elementary Circuits
+-- of a Graph", James C. Tiernan, Communications of the ACM Volume 13
+-- Number 12 December 1970.
+--
https://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.516.9454&rep=rep1&type=pdf
+--
+-- [3] "Finding all the Elementary Circuits of a Directed Graph",
+-- Donald B. Johnson, SIAM J. Comput. Vol 4, No. 1, March 1975.
+-- https://epubs.siam.org/doi/abs/10.1137/0204007
+--
+-- [4] "Depth-First Search and Linear Graph Algorithms", Robert
+-- Tarjan, SIAM J. Comput. Vol. 1, No 2, June 1972.
+-- https://epubs.siam.org/doi/abs/10.1137/0201010
+--
+-- Copyright (C) 2017, 2019 Free Software Foundation All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers.Doubly_Linked_Lists;
+with Ada.Containers.Indefinite_Vectors;
+with SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image;
+with SAL.Gen_Trimmed_Image;
+with SAL.Gen_Unbounded_Definite_Vectors;
+generic
+ type Edge_Data is private;
+ Default_Edge_Data : in Edge_Data;
+ type Vertex_Index is range <>;
+ Invalid_Vertex : in Vertex_Index'Base;
+
+ type Path_Index is range <>;
+
+ with function Edge_Image (Item : in Edge_Data) return String;
+
+package SAL.Gen_Graphs is
+
+ type Graph is tagged private;
+
+ procedure Add_Edge
+ (Graph : in out Gen_Graphs.Graph;
+ Vertex_A : in Vertex_Index;
+ Vertex_B : in Vertex_Index;
+ Data : in Edge_Data);
+ -- Adds a directed edge from Vertex_A to Vertex_B.
+
+ function Count_Nodes (Graph : in Gen_Graphs.Graph) return
Ada.Containers.Count_Type;
+ function Count_Edges (Graph : in Gen_Graphs.Graph) return
Ada.Containers.Count_Type;
+
+ function Multigraph (Graph : in Gen_Graphs.Graph) return Boolean;
+ -- If more than one edge is added between two vertices, the graph is
+ -- a multigraph. The edges are given separate identifiers internally.
+
+ Multigraph_Error : exception;
+
+ type Base_Edge_ID is range 0 .. Integer'Last;
+ subtype Edge_ID is Base_Edge_ID range 1 .. Base_Edge_ID'Last;
+ Invalid_Edge_ID : constant Base_Edge_ID := 0;
+ -- Edge ids are unique graph-wide, assigned by Add_Edge.
+
+ type Edge_Item is record
+ ID : Base_Edge_ID := Invalid_Edge_ID;
+ Data : Edge_Data := Default_Edge_Data;
+ end record;
+ function Image (Item : in Edge_Item) return String
+ is (Edge_Image (Item.Data));
+
+ package Edge_Lists is new Ada.Containers.Doubly_Linked_Lists (Edge_Item);
+
+ function "+" (Right : in Edge_Item) return Edge_Lists.List;
+
+ function Edges (Graph : in Gen_Graphs.Graph; Vertex : in Vertex_Index)
return Edge_Lists.List;
+ -- All edges from Vertex, as set by Add_Edge.
+
+ function Image is new SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
+ (Element_Type => Edge_Item,
+ Lists => Edge_Lists,
+ Element_Image => Image);
+
+ type Path_Item is record
+ Vertex : Vertex_Index'Base := Invalid_Vertex;
+ Edges : Edge_Lists.List;
+ -- Edges describe the edges leading from the previous vertex
+ -- in the path to Vertex. If this is the first vertex in an open
+ -- path, Edges is empty. If it is the first vertex in a
+ -- cycle, the edge are from the last vertex in the cycle.
+ end record;
+
+ type Path is array (Positive range <>) of Path_Item;
+
+ function Image (Item : in Path) return String;
+ -- For trace, debugging.
+
+ package Path_Arrays is new Ada.Containers.Indefinite_Vectors (Path_Index,
Path);
+
+ function "<" (Left, Right : in Path) return Boolean;
+
+ package Sort_Paths is new Path_Arrays.Generic_Sorting;
+
+ function Find_Paths
+ (Graph : in out Gen_Graphs.Graph;
+ From : in Vertex_Index;
+ To : in Edge_Data)
+ return Path_Arrays.Vector;
+ -- Return all non-cyclic paths starting at From that lead to a To
+ -- edge, using algorithm [1]. First entry in each item in result is
+ -- From, with first edge. Last entry in result contains edge data for
+ -- To.
+ --
+ -- Raises Multigraph_Error if Graph is a multigraph.
+
+ function Find_Cycles_Tiernan (Graph : in Gen_Graphs.Graph) return
Path_Arrays.Vector;
+ -- Return all cyclic paths in Graph, using algorithm [2] extended for
+ -- multigraphs.
+ --
+ -- Time complexity is exponential in the number of nodes. Used in
+ -- unit tests for Find_Cycles_Johnson, since [2] is easier to
+ -- implement.
+
+ function Find_Cycles (Graph : in Gen_Graphs.Graph) return
Path_Arrays.Vector;
+ -- Return all cyclic paths in Graph, using algorithm [3] extended for
+ -- multigraphs.
+ --
+ -- Time complexity is linear in the number of nodes and edges.
+
+ package Vertex_Lists is new Ada.Containers.Doubly_Linked_Lists
(Vertex_Index);
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image (Vertex_Index);
+ function Image is new SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
+ (Vertex_Index, "=", Vertex_Lists, Trimmed_Image);
+
+ function Loops (Graph : in Gen_Graphs.Graph) return Vertex_Lists.List;
+ -- List of vertices that have an edge to themselves.
+
+ package Adjacency_Structures is new SAL.Gen_Unbounded_Definite_Vectors
+ (Vertex_Index, Vertex_Lists.List, Vertex_Lists.Empty_List);
+ -- Graphs with no Edge_ID or Edge_Data; useful as intermediate results.
+
+ function To_Adjancency (Graph : in Gen_Graphs.Graph) return
Adjacency_Structures.Vector;
+
+ package Component_Lists is new Ada.Containers.Doubly_Linked_Lists
(Vertex_Lists.List, Vertex_Lists."=");
+
+ function Strongly_Connected_Components
+ (Graph : in Adjacency_Structures.Vector;
+ Non_Trivial_Only : in Boolean := False)
+ return Component_Lists.List;
+ -- Find strongly connected components of Graph, using algorithm in [4].
+ -- If Non_Trivial_Only, don't include single-vertex components.
+
+ Trace : Integer := 0;
+ -- Some bodies output debug info to Text_IO.Current_Output for
+ -- non-zero values of Trace.
+private
+
+ type Edge_Node is record
+ -- Edge is from vertex contaning this Node to Vertex_B
+ ID : Edge_ID;
+ Vertex_B : Vertex_Index;
+ Multigraph : Boolean; -- Same Vertex_B as another edge in same vertex.
+ Data : Edge_Data;
+ end record;
+
+ package Edge_Node_Lists is new Ada.Containers.Doubly_Linked_Lists
(Edge_Node);
+
+ package Vertex_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Vertex_Index, Edge_Node_Lists.List, Edge_Node_Lists.Empty_List);
+
+ type Graph is tagged record
+ Last_Edge_ID : Base_Edge_ID := Invalid_Edge_ID;
+ Multigraph : Boolean := False;
+ Vertices : Vertex_Arrays.Vector;
+ end record;
+
+end SAL.Gen_Graphs;
diff --git a/sal-gen_unbounded_definite_stacks.adb
b/sal-gen_unbounded_definite_stacks.adb
index 6b5337d..0a54eab 100644
--- a/sal-gen_unbounded_definite_stacks.adb
+++ b/sal-gen_unbounded_definite_stacks.adb
@@ -2,7 +2,7 @@
--
-- see spec
--
--- Copyright (C) 1998, 2003, 2009, 2015, 2017, 2018 Free Software Foundation,
Inc.
+-- Copyright (C) 1998, 2003, 2009, 2015, 2017 - 2019 Free Software
Foundation, Inc.
--
-- SAL is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the
@@ -175,4 +175,36 @@ package body SAL.Gen_Unbounded_Definite_Stacks is
Dummy => 1);
end Constant_Ref;
+ function Constant_Ref
+ (Container : aliased in Stack'Class;
+ Position : in Cursor)
+ return Constant_Ref_Type
+ is begin
+ return
+ (Element => Container.Data (Container.Top - Position.Ptr + 1)'Access,
+ Dummy => 1);
+ end Constant_Ref;
+
+ function Has_Element (Position : in Cursor) return Boolean
+ is begin
+ return Position.Container.Depth >= Position.Ptr;
+ end Has_Element;
+
+ function Iterate (Container : aliased in Stack) return
Iterator_Interfaces.Forward_Iterator'Class
+ is begin
+ return Iterator'(Container => Container'Unrestricted_Access);
+ end Iterate;
+
+ overriding function First (Object : Iterator) return Cursor
+ is begin
+ return (Object.Container, 1);
+ end First;
+
+ overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
+ is
+ pragma Unreferenced (Object);
+ begin
+ return (Position.Container, Position.Ptr + 1);
+ end Next;
+
end SAL.Gen_Unbounded_Definite_Stacks;
diff --git a/sal-gen_unbounded_definite_stacks.ads
b/sal-gen_unbounded_definite_stacks.ads
index 954be19..cb54a24 100644
--- a/sal-gen_unbounded_definite_stacks.ads
+++ b/sal-gen_unbounded_definite_stacks.ads
@@ -23,6 +23,7 @@
pragma License (Modified_GPL);
with Ada.Finalization;
+with Ada.Iterator_Interfaces;
with Ada.Unchecked_Deallocation;
generic
type Element_Type is private;
@@ -32,7 +33,9 @@ package SAL.Gen_Unbounded_Definite_Stacks is
type Stack is new Ada.Finalization.Controlled with private
with
- Constant_Indexing => Constant_Ref;
+ Constant_Indexing => Constant_Ref,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
Empty_Stack : constant Stack;
@@ -115,6 +118,20 @@ package SAL.Gen_Unbounded_Definite_Stacks is
return Constant_Ref_Type;
pragma Inline (Constant_Ref);
+ type Cursor is private;
+
+ function Constant_Ref
+ (Container : aliased in Stack'Class;
+ Position : in Cursor)
+ return Constant_Ref_Type;
+ pragma Inline (Constant_Ref);
+
+ function Has_Element (Position : in Cursor) return Boolean;
+
+ package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
+
+ function Iterate (Container : aliased in Stack) return
Iterator_Interfaces.Forward_Iterator'Class;
+
private
type Element_Array is array (Peek_Type range <>) of aliased Element_Type;
@@ -129,6 +146,24 @@ private
-- Data (1 .. Last_Index) has been set at some point.
end record;
+ type Stack_Access is access all Stack;
+
Empty_Stack : constant Stack := (Ada.Finalization.Controlled with
Invalid_Peek_Index, null);
+ type Cursor is record
+ Container : Stack_Access;
+ Ptr : Peek_Type;
+ end record;
+
+ type Iterator is new Iterator_Interfaces.Forward_Iterator with
+ record
+ Container : Stack_Access;
+ end record;
+
+ overriding function First (Object : Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
end SAL.Gen_Unbounded_Definite_Stacks;
diff --git a/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
b/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
index c498e0e..e0d90a6 100644
--- a/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
+++ b/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+-- Copyright (C) 2018 - 2019 Stephen Leake All Rights Reserved.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -18,7 +18,11 @@
pragma License (Modified_GPL);
with Ada.Strings.Unbounded;
-function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector;
Aux : in Aux_Data) return String
+function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux
+ (Item : in Vector;
+ Aux : in Aux_Data;
+ Association : in Boolean := False)
+ return String
is
use Ada.Strings.Unbounded;
Result : Unbounded_String := To_Unbounded_String ("(");
@@ -26,6 +30,9 @@ is
Last : constant Base_Peek_Type := To_Peek_Type (Item.Last_Index);
begin
for I in First .. Last loop
+ if Association then
+ Result := Result & Index_Trimmed_Image (To_Index_Type (I)) & " => ";
+ end if;
Result := Result & Element_Image (Item.Elements (I), Aux);
if I /= Last then
Result := Result & ", ";
diff --git a/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
b/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
index 0be7c41..eb8a89a 100644
--- a/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
+++ b/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
@@ -2,7 +2,7 @@
--
-- Image with auxiliary data for instantiations of parent.
--
--- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+-- Copyright (C) 2018 - 2019 Stephen Leake All Rights Reserved.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -19,5 +19,10 @@ pragma License (Modified_GPL);
generic
type Aux_Data (<>) is private;
+ with function Index_Trimmed_Image (Item : in Index_Type) return String;
with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector;
Aux : in Aux_Data) return String;
+function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux
+ (Item : in Vector;
+ Aux : in Aux_Data;
+ Association : in Boolean := False)
+ return String;
diff --git a/sal-gen_unbounded_definite_vectors.adb
b/sal-gen_unbounded_definite_vectors.adb
index 49d59a6..b5019bb 100644
--- a/sal-gen_unbounded_definite_vectors.adb
+++ b/sal-gen_unbounded_definite_vectors.adb
@@ -470,6 +470,28 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
end if;
end Next;
+ function Prev (Position : in Cursor) return Cursor
+ is begin
+ if Position = No_Element then
+ return No_Element;
+ elsif Position.Index > To_Peek_Type (Position.Container.First) then
+ return (Position.Container, Position.Index - 1);
+ else
+ return No_Element;
+ end if;
+ end Prev;
+
+ procedure Prev (Position : in out Cursor)
+ is begin
+ if Position = No_Element then
+ null;
+ elsif Position.Index > To_Peek_Type (Position.Container.First) then
+ Position.Index := Position.Index - 1;
+ else
+ Position := No_Element;
+ end if;
+ end Prev;
+
function To_Cursor
(Container : aliased in Vector;
Index : in Extended_Index)
diff --git a/sal-gen_unbounded_definite_vectors.ads
b/sal-gen_unbounded_definite_vectors.ads
index ae472d8..8023794 100644
--- a/sal-gen_unbounded_definite_vectors.ads
+++ b/sal-gen_unbounded_definite_vectors.ads
@@ -158,6 +158,8 @@ package SAL.Gen_Unbounded_Definite_Vectors is
function First (Container : aliased in Vector) return Cursor;
function Next (Position : in Cursor) return Cursor;
procedure Next (Position : in out Cursor);
+ function Prev (Position : in Cursor) return Cursor;
+ procedure Prev (Position : in out Cursor);
function To_Cursor
(Container : aliased in Vector;
@@ -223,5 +225,6 @@ private
-- Visible for child package
function To_Peek_Type (Item : in Extended_Index) return Base_Peek_Type with
Inline;
+ function To_Index_Type (Item : in Base_Peek_Type) return Extended_Index;
end SAL.Gen_Unbounded_Definite_Vectors;
diff --git a/sal-generic_decimal_image.adb b/sal-generic_decimal_image.adb
new file mode 100644
index 0000000..2699277
--- /dev/null
+++ b/sal-generic_decimal_image.adb
@@ -0,0 +1,48 @@
+-- Abstract:
+--
+-- see spec
+--
+-- Copyright (C) 2005, 2006, 2009 Stephen Leake. All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This library is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
+-- MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+function SAL.Generic_Decimal_Image
+ (Item : in Number_Type;
+ Width : in Natural)
+ return String
+is
+ pragma Warnings (Off);
+ -- Avoid warning about "abs applied to non-negative value has no
+ -- effect" for some instantiations.
+ Temp : Integer := abs Integer (Item);
+ -- IMPROVEME: need test for Decimal_Image, include constrained positive
number_type
+ pragma Warnings (On);
+ Digit : Integer;
+ Image : String (1 .. Width);
+begin
+ for I in reverse Image'Range loop
+ Digit := Temp mod 10;
+ Temp := Temp / 10;
+ Image (I) := Character'Val (Character'Pos ('0') + Digit);
+ end loop;
+ return Image;
+end SAL.Generic_Decimal_Image;
diff --git a/sal-generic_decimal_image.ads b/sal-generic_decimal_image.ads
new file mode 100644
index 0000000..ec749f6
--- /dev/null
+++ b/sal-generic_decimal_image.ads
@@ -0,0 +1,37 @@
+-- Abstract:
+--
+-- Generic leading zero unsigned decimal image
+--
+-- Copyright (C) 2004, 2009, 2019 Free Software Foundation. All Rights
Reserved.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This library is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
+-- MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+generic
+ type Number_Type is range <>;
+function SAL.Generic_Decimal_Image
+ (Item : in Number_Type;
+ Width : in Natural)
+ return String;
+-- Return a decimal unsigned image of Item, padded with leading zeros
+-- to Width. If Width is too small for Item, leading digits are
+-- silently truncated.
+pragma Pure (SAL.Generic_Decimal_Image);
diff --git a/sal.adb b/sal.adb
index 6a2dc71..ac3b037 100644
--- a/sal.adb
+++ b/sal.adb
@@ -26,7 +26,7 @@ package body SAL is
function Version return String is
begin
- return "SAL 3.1";
+ return "SAL 3.2";
end Version;
end SAL;
diff --git a/wisi-elisp-parse.el b/wisi-elisp-parse.el
index e757ac8..2c93a37 100644
--- a/wisi-elisp-parse.el
+++ b/wisi-elisp-parse.el
@@ -1,1686 +1,1721 @@
-;; wisi-elisp-parse.el --- Wisi parser -*- lexical-binding:t -*-
-
-;; Copyright (C) 2013-2015, 2017 - 2019 Free Software Foundation, Inc.
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-
-;; An extended LALR parser, that handles shift/reduce and
-;; reduce/reduce conflicts by spawning parallel parsers to follow each
-;; path.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'wisi-elisp-lexer)
-(require 'wisi-parse-common)
-
-(defvar wisi-elisp-parse-max-parallel-current (cons 0 0)
- "Cons (count . point); Maximum number of parallel parsers used in most
recent parse,
-point at which that max was spawned.")
-
-(defvar wisi-debug-identical 0
- "Debug terminating identical parsers.
-0 - keep lower-numbered parser.
-1 - keep higher-numbered parser.
-2 - error.")
-
-(cl-defstruct (wisi-elisp-parser-state
- (:copier nil))
- label ;; integer identifying parser for debug
-
- active
- ;; 'shift - need new token
- ;; 'reduce - need reduce
- ;; 'accept - parsing completed
- ;; 'error - failed, error not reported yet
- ;; nil - terminated
- ;;
- ;; 'pending-shift, 'pending-reduce - newly created parser
-
- stack
- ;; Each stack item takes two slots: wisi-tok, state
-
- sp ;; stack pointer
-
- pending
- ;; list of (action-symbol stack-fragment)
- )
-
-(cl-defstruct (wisi-elisp-parser (:include wisi-parser))
- actions
- gotos
- next-token
- )
-
-;;;###autoload
-(defun wisi-make-elisp-parser (automaton next-token)
- "Return ‘wisi-parser’ object.
-
-- AUTOMATON is the parse table generated by `wisi-compile-grammar'.
-
-- NEXT-TOKEN is a function with no argument called by the parser to
- obtain the next token from the current buffer after point, as a
- ’wisi-tok’ object (normally ‘wisi-forward-token’)."
- (make-wisi-elisp-parser
- :actions (aref automaton 0)
- :gotos (aref automaton 1)
- :next-token next-token))
-
-(cl-defmethod wisi-parse-kill ((_parser wisi-elisp-parser))
- nil)
-
-(defvar wisi-elisp-parse--indent nil
- ;; not buffer-local; only let-bound in wisi-parse-current (elisp)
- "A vector of indentation for all lines in buffer.
-Each element can be one of:
-- integer : indent
-
-- list ('anchor (start-id ...) indent) :
- indent for current line, base indent for following 'anchored
- lines. Start-id is list of ids anchored at this line. For parens
- and other uses.
-
-- list ('anchored id delta) :
- indent = delta + 'anchor id line indent; for lines indented
- relative to anchor.
-
-- list ('anchor (start-id ...) ('anchored id delta))
- for nested anchors.")
-
-(cl-defmethod wisi-parse-current ((parser wisi-elisp-parser) _begin _send-end
_parse-end)
- "Parse entire current buffer.
-BEGIN, END are ignored"
-
- (let ((actions (wisi-elisp-parser-actions parser))
- (gotos (wisi-elisp-parser-gotos parser))
- (parser-states ;; vector of parallel parser states
- (vector
- (make-wisi-elisp-parser-state
- :label 0
- :active 'shift
- :stack (make-vector wisi-parse-max-stack-size nil)
- :sp 0
- :pending nil)))
- (active-parser-count 1)
- active-parser-count-prev
- (active 'shift)
- (token nil)
- some-pending
- wisi-elisp-parse--indent)
-
- (cl-case wisi--parse-action
- (indent
- (let ((line-count (1+ (count-lines (point-min) (point-max)))))
- (setq wisi-elisp-parse--indent (make-vector line-count 0))
- (wisi-elisp-lexer-reset line-count wisi--lexer)))
-
- (navigate
- (setq wisi-end-caches nil))
-
- (t nil))
-
- (setf (wisi-parser-lexer-errors parser) nil)
- (setf (wisi-parser-parse-errors parser) nil)
-
- ;; We assume the lexer relies on syntax properties
- (when (< emacs-major-version 25) (syntax-propertize (point-max)))
-
- (goto-char (point-min))
- (forward-comment (point-max))
- (aset (wisi-elisp-parser-state-stack (aref parser-states 0)) 0 0)
-
- (setq token (funcall (wisi-elisp-parser-next-token parser)))
- (setq wisi-elisp-parse-max-parallel-current (cons 0 0))
-
- (while (not (eq active 'accept))
- (setq active-parser-count-prev active-parser-count)
- (setq some-pending nil)
- (dotimes (parser-index (length parser-states))
- (when (eq active (wisi-elisp-parser-state-active (aref parser-states
parser-index)))
- (let* ((parser-state (aref parser-states parser-index))
- (result (wisi-elisp-parse-1 token parser-state (>
active-parser-count 1) actions gotos)))
- (when result
- ;; spawn a new parser
- (when (= active-parser-count wisi-parse-max-parallel)
- (let* ((state (aref (wisi-elisp-parser-state-stack parser-state)
- (wisi-elisp-parser-state-sp parser-state)))
- (msg (wisi-error-msg (concat "too many parallel parsers
required in grammar state %d;"
- " simplify grammar, or
increase `wisi-elisp-parse-max-parallel'")
- state)))
- (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error msg)))
-
- (let ((j (wisi-elisp-parse-free-parser parser-states)))
- (cond
- ((= j -1)
- ;; Add to parser-states; the new parser won't be executed
- ;; again in this parser-index loop.
- (setq parser-states (vconcat parser-states (vector nil)))
- (setq j (1- (length parser-states))))
- ((< j parser-index)
- ;; The new parser won't be executed again in this
- ;; parser-index loop; nothing to do.
- )
- (t
- ;; Don't let the new parser execute again in this
- ;; parser-index loop.
- (setq some-pending t)
- (setf (wisi-elisp-parser-state-active result)
- (cl-case (wisi-elisp-parser-state-active result)
- (shift 'pending-shift)
- (reduce 'pending-reduce)
- )))
- )
- (setq active-parser-count (1+ active-parser-count))
- (when (> active-parser-count (car
wisi-elisp-parse-max-parallel-current))
- (setq wisi-elisp-parse-max-parallel-current (cons
active-parser-count (point))))
- (setf (wisi-elisp-parser-state-label result) j)
- (aset parser-states j result))
- (when (> wisi-debug 1)
- (message "spawn parser (%d active)" active-parser-count)))
-
- (when (eq 'error (wisi-elisp-parser-state-active parser-state))
- (setq active-parser-count (1- active-parser-count))
- (when (> wisi-debug 1)
- (message "terminate parser (%d active)" active-parser-count))
- (cl-case active-parser-count
- (0
- (cond
- ((= active-parser-count-prev 1)
- ;; We were not in a parallel parse; abandon parsing, report
the error.
- (let* ((state (aref (wisi-elisp-parser-state-stack
parser-state)
- (wisi-elisp-parser-state-sp
parser-state)))
- (msg (wisi-error-msg "syntax error in grammar state
%d; unexpected %s, expecting one of %s"
- state
- (wisi-token-text token)
- (mapcar 'car (aref actions
state)))))
- (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error msg)))
- (t
- ;; Report errors from all parsers that failed on this token.
- (let ((msg))
- (dotimes (_ (length parser-states))
- (let* ((parser-state (aref parser-states parser-index))
- (state (aref (wisi-elisp-parser-state-stack
parser-state)
- (wisi-elisp-parser-state-sp
parser-state))))
- (when (eq 'error (wisi-elisp-parser-state-active
parser-state))
- (setq msg
- (concat msg
- (when msg "\n")
- (wisi-error-msg
- "syntax error in grammar state %d;
unexpected %s, expecting one of %s"
- state
- (wisi-token-text token)
- (mapcar 'car (aref actions state)))))
- )))
- (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error msg)))
- ))
-
- (1
- (setf (wisi-elisp-parser-state-active parser-state) nil);
Don't save error for later.
- (wisi-elisp-parse-execute-pending (aref parser-states
(wisi-elisp-parse-active-parser parser-states))))
-
- (t
- ;; We were in a parallel parse, and this parser
- ;; failed; mark it inactive, don't save error for
- ;; later.
- (setf (wisi-elisp-parser-state-active parser-state) nil)
- )))
- )));; end dotimes
-
- (when some-pending
- ;; Change pending-* parsers to *.
- (dotimes (parser-index (length parser-states))
- (cond
- ((eq (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'pending-shift)
- (setf (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'shift))
- ((eq (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'pending-reduce)
- (setf (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'reduce))
- )))
-
- (setq active (wisi-elisp-parsers-active parser-states
active-parser-count))
- (when (eq active 'shift)
- (when (> active-parser-count 1)
- (setq active-parser-count (wisi-elisp-parse-elim-identical parser
parser-states active-parser-count)))
-
- (setq token (funcall (wisi-elisp-parser-next-token parser))))
- )
- (when (> active-parser-count 1)
- (error "ambiguous parse result"))
-
- (cl-case wisi--parse-action
- (indent
- (wisi-elisp-parse--indent-leading-comments)
- (wisi-elisp-parse--resolve-anchors))
-
- (t nil))
-
- ;; Return region parsed.
- (cons (point-min) (point))
- ))
-
-(defun wisi-elisp-parsers-active-index (parser-states)
- ;; only called when active-parser-count = 1
- (let ((result nil)
- (i 0))
- (while (and (not result)
- (< i (length parser-states)))
- (when (wisi-elisp-parser-state-active (aref parser-states i))
- (setq result i))
- (setq i (1+ i)))
- result))
-
-(defun wisi-elisp-parsers-active (parser-states active-count)
- "Return the type of parser cycle to execute.
-PARSER-STATES[*].active is the last action a parser took. If it
-was `shift', that parser used the input token, and should not be
-executed again until another input token is available, after all
-parsers have shifted the current token or terminated.
-
-Returns one of:
-
-`accept' : all PARSER-STATES have active set to nil or `accept' -
-done parsing
-
-`shift' : all PARSER-STATES have active set to nil, `accept', or
-`shift' - get a new token, execute `shift' parsers.
-
-`reduce' : some PARSER-STATES have active set to `reduce' - no new
-token, execute `reduce' parsers."
- (let ((result nil)
- (i 0)
- (shift-count 0)
- (accept-count 0)
- active)
- (while (and (not result)
- (< i (length parser-states)))
- (setq active (wisi-elisp-parser-state-active (aref parser-states i)))
- (cond
- ((eq active 'shift) (setq shift-count (1+ shift-count)))
- ((eq active 'reduce) (setq result 'reduce))
- ((eq active 'accept) (setq accept-count (1+ accept-count)))
- )
- (setq i (1+ i)))
-
- (cond
- (result )
- ((= accept-count active-count)
- 'accept)
- ((= (+ shift-count accept-count) active-count)
- 'shift)
- (t
- ;; all parsers in error state; should not get here
- (error "all parsers in error state; programmer error"))
- )))
-
-(defun wisi-elisp-parse-free-parser (parser-states)
- "Return index to a non-active parser in PARSER-STATES, -1 if there is none."
- (let ((result nil)
- (i 0))
- (while (and (not result)
- (< i (length parser-states)))
- (when (not (wisi-elisp-parser-state-active (aref parser-states i)))
- (setq result i))
- (setq i (1+ i)))
- (if result result -1)))
-
-(defun wisi-elisp-parse-active-parser (parser-states)
- "Return index to the first active parser in PARSER-STATES."
- (let ((result nil)
- (i 0))
- (while (and (not result)
- (< i (length parser-states)))
- (when (wisi-elisp-parser-state-active (aref parser-states i))
- (setq result i))
- (setq i (1+ i)))
- (unless result
- (error "no active parsers"))
- result))
-
-(defun wisi-elisp-parse-elim-identical (parser parser-states
active-parser-count)
- "Check for parsers in PARSER-STATES that have reached identical states
eliminate one.
-Return new ACTIVE-PARSER-COUNT. Assumes all parsers have active
-nil, `shift', or `accept'."
- ;; parser-states passed by reference; active-parser-count by copy
- ;; see test/ada_mode-slices.adb for example
- (dotimes (parser-i (1- (length parser-states)))
- (when (wisi-elisp-parser-state-active (aref parser-states parser-i))
- (dotimes (parser-j (- (length parser-states) parser-i 1))
- (when (wisi-elisp-parser-state-active (aref parser-states (+ parser-i
parser-j 1)))
- (when (eq (wisi-elisp-parser-state-sp (aref parser-states parser-i))
- (wisi-elisp-parser-state-sp (aref parser-states (+
parser-i parser-j 1))))
- (let ((compare t)
- exec)
- (dotimes (stack-i (wisi-elisp-parser-state-sp (aref parser-states
parser-i)))
- (setq
- compare
- (and compare ;; bypass expensive 'arefs' after first stack
item compare fail
- (equal (aref (wisi-elisp-parser-state-stack (aref
parser-states parser-i)) stack-i)
- (aref (wisi-elisp-parser-state-stack (aref
parser-states (+ parser-i parser-j 1)))
- stack-i)))))
- (when compare
- ;; parser stacks are identical
- (setq active-parser-count (1- active-parser-count))
- (when (> wisi-debug 1)
- (message "terminate identical parser %d (%d active)"
- (+ parser-i parser-j 1) active-parser-count)
- (let ((state-i (aref parser-states parser-i))
- (state-j (aref parser-states (+ parser-i parser-j 1))))
- (message "%d actions:" (wisi-elisp-parser-state-label
state-i))
- (mapc #'wisi-elisp-parse-debug-put-action
(wisi-elisp-parser-state-pending state-i))
-
- (message "%d actions:" (wisi-elisp-parser-state-label
state-j))
- (mapc #'wisi-elisp-parse-debug-put-action
(wisi-elisp-parser-state-pending state-j))
- ))
- (cl-ecase wisi-debug-identical
- (0
- (setq exec parser-i)
- (setf (wisi-elisp-parser-state-active (aref parser-states (+
parser-i parser-j 1))) nil))
-
- (1
- (setq exec (+ parser-i parser-j 1))
- (setf (wisi-elisp-parser-state-active (aref parser-states
parser-i)) nil))
-
- (2
- (let ((msg "identical parser stacks"))
- (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error msg)))
- )
- (when (= active-parser-count 1)
- ;; The actions for the two parsers are not
- ;; identical, but most of the time either is good
- ;; enough for indentation and navigation, so we just
- ;; do the actions for the one that is not
- ;; terminating. Some times, a significant action is
- ;; lost. In that case, turn on
- ;; ‘wisi-debug-identical’ to investigate fixing it.
- (wisi-elisp-parse-execute-pending (aref parser-states exec)))
- ))))
- )))
- active-parser-count)
-
-(defun wisi-elisp-parse-exec-action (func nonterm tokens)
- "Execute action if TOKENS not null."
- ;; `tokens' is null when all tokens in a grammar statement are
- ;; optional and not present.
- (unless wisi-action-disable
- (if (< 0 (length tokens))
- (when wisi--parse-action
- (funcall func nonterm tokens))
-
- (when (> wisi-debug 1)
- (message "... action skipped; no tokens"))
- )))
-
-(defvar wisi-elisp-parser-state nil
- "Let-bound in `wisi-elisp-parse-reduce', used in `wisi-parse-find-token'.")
-
-(defun wisi-elisp-parse-debug-put-action (action)
- ;; Action is (semantic-function nonterm [tokens])
- (message "%s [%s]"
- (nth 0 action)
- (mapcar #'wisi-tok-debug-image (nth 2 action))))
-
-(defun wisi-elisp-parse-execute-pending (parser-state)
- (let ((wisi-elisp-parser-state parser-state);; reference, for
wisi-parse-find-token
- (pending (wisi-elisp-parser-state-pending parser-state)))
-
- (when (> wisi-debug 1)
- (message "%d: pending actions:" (wisi-elisp-parser-state-label
parser-state)))
-
- (while pending
- (when (> wisi-debug 1) (wisi-elisp-parse-debug-put-action (car pending)))
-
- (let ((func-args (pop pending)))
- (wisi-elisp-parse-exec-action (nth 0 func-args) (nth 1 func-args)
(cl-caddr func-args)))
- )
- (setf (wisi-elisp-parser-state-pending parser-state) nil)
- ))
-
-(defmacro wisi-elisp-parse-action (i al)
- "Return the parser action.
-I is a token item number and AL is the list of (item . action)
-available at current state. The first element of AL contains the
-default action for this state."
- `(cdr (or (assq ,i ,al) (car ,al))))
-
-(defun wisi-elisp-parse-1 (token parser-state pendingp actions gotos)
- "Perform one shift or reduce on PARSER-STATE.
-If PENDINGP, push actions onto PARSER-STATE.pending; otherwise execute them.
-See `wisi-elisp-parse' for full details.
-Return nil or new parser (a wisi-elisp-parser-state struct)."
- (let* ((state (aref (wisi-elisp-parser-state-stack parser-state)
- (wisi-elisp-parser-state-sp parser-state)))
- (parse-action (wisi-elisp-parse-action (wisi-tok-token token) (aref
actions state)))
- new-parser-state)
-
- (when (> wisi-debug 1)
- ;; output trace info
- (if (> wisi-debug 2)
- (progn
- ;; put top 10 stack items
- (let* ((count (min 20 (wisi-elisp-parser-state-sp parser-state)))
- (msg (make-vector (+ 1 count) nil)))
- (dotimes (i count)
- (aset msg (- count i)
- (aref (wisi-elisp-parser-state-stack parser-state)
- (- (wisi-elisp-parser-state-sp parser-state) i)))
- )
- (message "%d: %s: %d: %s"
- (wisi-elisp-parser-state-label parser-state)
- (wisi-elisp-parser-state-active parser-state)
- (wisi-elisp-parser-state-sp parser-state)
- msg))
- (message " %d: %s: %s" state (wisi-tok-debug-image token)
parse-action))
- (message "%d: %d: %s: %s" (wisi-elisp-parser-state-label parser-state)
state token parse-action)))
-
- (when (and (listp parse-action)
- (not (symbolp (car parse-action))))
- ;; Conflict; spawn a new parser.
- (setq new-parser-state
- (make-wisi-elisp-parser-state
- :active nil
- :stack (vconcat (wisi-elisp-parser-state-stack parser-state))
- :sp (wisi-elisp-parser-state-sp parser-state)
- :pending (wisi-elisp-parser-state-pending parser-state)))
-
- (wisi-elisp-parse-2 (cadr parse-action) token new-parser-state t gotos)
- (setq pendingp t)
- (setq parse-action (car parse-action))
- );; when
-
- ;; current parser
- (wisi-elisp-parse-2 parse-action token parser-state pendingp gotos)
-
- new-parser-state))
-
-(defun wisi-elisp-parse-2 (action token parser-state pendingp gotos)
- "Execute parser ACTION (must not be a conflict).
-Return nil."
- (cond
- ((eq action 'accept)
- (setf (wisi-elisp-parser-state-active parser-state) 'accept))
-
- ((eq action 'error)
- (setf (wisi-elisp-parser-state-active parser-state) 'error))
-
- ((natnump action)
- ;; Shift token and new state (= action) onto stack
- (let ((stack (wisi-elisp-parser-state-stack parser-state)); reference
- (sp (wisi-elisp-parser-state-sp parser-state))); copy
- (setq sp (+ sp 2))
- (aset stack (1- sp) token)
- (aset stack sp action)
- (setf (wisi-elisp-parser-state-sp parser-state) sp))
- (setf (wisi-elisp-parser-state-active parser-state) 'shift))
-
- (t
- (wisi-elisp-parse-reduce action parser-state pendingp gotos)
- (setf (wisi-elisp-parser-state-active parser-state) 'reduce))
- ))
-
-(defun wisi-elisp-parse-first-last (stack i j)
- "Return a pair (FIRST . LAST), indices for the first and last
-non-empty tokens for a nonterminal; or nil if all tokens are
-empty. STACK is the parser stack. I and J are the indices in
-STACK of the first and last tokens of the nonterminal."
- (let ((start (car (wisi-tok-region (aref stack i))))
- (end (cdr (wisi-tok-region (aref stack j)))))
- (while (and (or (not start) (not end))
- (/= i j))
- (cond
- ((not start)
- ;; item i is an empty production
- (setq start (car (wisi-tok-region (aref stack (setq i (+ i 2)))))))
-
- ((not end)
- ;; item j is an empty production
- (setq end (cdr (wisi-tok-region (aref stack (setq j (- j 2)))))))
-
- (t (setq i j))))
-
- (when (and start end)
- (cons i j))
- ))
-
-(cl-defmethod wisi-parse-find-token ((_parser wisi-elisp-parser) token-symbol)
- "Find token with TOKEN-SYMBOL on current parser stack, return token struct.
-For use in grammar actions."
- ;; Called from wisi-parse-exec-action in wisi-parse-reduce
- (let* ((stack (wisi-elisp-parser-state-stack wisi-elisp-parser-state))
- (sp (1- (wisi-elisp-parser-state-sp wisi-elisp-parser-state)))
- (tok (aref stack sp)))
- (while (and (> sp 0)
- (not (eq token-symbol (wisi-tok-token tok))))
- (setq sp (- sp 2))
- (setq tok (aref stack sp)))
- (if (= sp 0)
- (error "token %s not found on parse stack" token-symbol)
- tok)
- ))
-
-(cl-defmethod wisi-parse-stack-peek ((_parser wisi-elisp-parser) n)
- ;; IMPROVEME: store stack in parser
- (let* ((stack (wisi-elisp-parser-state-stack wisi-elisp-parser-state))
- (sp (1- (wisi-elisp-parser-state-sp wisi-elisp-parser-state)))
- (i (- sp (* 2 n))))
- (when (> i 0)
- (aref stack i))))
-
-(defun wisi-elisp-parse-reduce (action parser-state pendingp gotos)
- "Reduce PARSER-STATE.stack, and execute or pend ACTION."
- (let* ((wisi-elisp-parser-state parser-state);; reference, for
wisi-parse-find-token
- (stack (wisi-elisp-parser-state-stack parser-state)); reference
- (sp (wisi-elisp-parser-state-sp parser-state)); copy
- (token-count (nth 2 action))
- (nonterm (nth 0 action))
- (first-last (when (> token-count 0)
- (wisi-elisp-parse-first-last stack (- sp (* 2 (1-
token-count)) 1) (1- sp))))
- (nonterm-region (when first-last
- (cons
- (car (wisi-tok-region (aref stack (car
first-last))))
- (cdr (wisi-tok-region (aref stack (cdr
first-last)))))))
- (post-reduce-state (aref stack (- sp (* 2 token-count))))
- (new-state (cdr (assoc nonterm (aref gotos post-reduce-state))))
- (tokens (make-vector token-count nil))
- line first comment-line comment-end)
-
- (when (not new-state)
- (error "no goto for %s %d" nonterm post-reduce-state))
-
- (dotimes (i token-count) ;; i = 0 .. (1- token-count); last token = 0,
first token = (1- token-count)
- (let ((tok (aref stack (- sp (* 2 i) 1))))
- (when (nth 1 action)
- ;; don't need wisi-tokens for a null user action
- (aset tokens (- token-count i 1) tok))
-
- (when (eq wisi--parse-action 'indent)
- (setq line (or (wisi-tok-line tok) line))
- (cond
- ((numberp (wisi-tok-first tok))
- (setq first (wisi-tok-first tok)))
-
- ((wisi-tok-first tok)
- (setq first (wisi-tok-line tok)))
-
- ((and (not (= i 0))
- (wisi-tok-comment-line tok))
- ;; comment lines following last token are not included in nonterm
- ;; test/ada_mode-nominal.ads Object_Access_Type_5a
- ;; test/ada_mode-parens.adb
- (setq first (wisi-tok-comment-line tok)))
- )
- (when (and (= i 0)
- (wisi-tok-comment-line tok))
- (setq comment-line (wisi-tok-comment-line tok))
- (setq comment-end (wisi-tok-comment-end tok)))
- )))
-
- (setq sp (+ 2 (- sp (* 2 token-count))))
- (aset stack (1- sp)
- (make-wisi-tok
- :token nonterm
- :region nonterm-region
- :nonterminal t
- :line line
- :first first
- :comment-line comment-line
- :comment-end comment-end))
- (aset stack sp new-state)
- (setf (wisi-elisp-parser-state-sp parser-state) sp)
-
- (when (nth 1 action)
- ;; nothing to do for a null user action
- (if pendingp
- (if (wisi-elisp-parser-state-pending parser-state)
- (setf (wisi-elisp-parser-state-pending parser-state)
- (append (wisi-elisp-parser-state-pending parser-state)
- (list (list (nth 1 action) nonterm tokens))))
- (setf (wisi-elisp-parser-state-pending parser-state)
- (list (list (nth 1 action) nonterm tokens))))
-
- ;; Not pending.
- (wisi-elisp-parse-exec-action (nth 1 action) nonterm tokens)
- ))
- ))
-
-;;;; navigate grammar actions
-
-(defun wisi-elisp-parse--set-end (start-mark end-mark)
- "Set END-MARK on all caches in `wisi-end-caches' in range START-MARK
END-MARK,
-delete from `wisi-end-caches'."
- (let ((i 0)
- pos cache)
- (while (< i (length wisi-end-caches))
- (setq pos (nth i wisi-end-caches))
- (setq cache (wisi-get-cache pos))
-
- (if (and (>= pos start-mark)
- (< pos end-mark))
- (progn
- (setf (wisi-cache-end cache) end-mark)
- (setq wisi-end-caches (delq pos wisi-end-caches)))
-
- ;; else not in range
- (setq i (1+ i)))
- )))
-
-(defvar wisi-tokens nil
- ;; Not wisi-elisp-parse--tokens for ease in debugging actions, and
- ;; to match lots of doc strings.
- "Array of ‘wisi-tok’ structures for the right hand side of the current
production.
-Let-bound in parser semantic actions.")
-
-(defvar wisi-nterm nil
- ;; Not wisi-elisp-parse--nterm for ease in debugging actions
- "The token id for the left hand side of the current production.
-Let-bound in parser semantic actions.")
-
-(defun wisi-statement-action (pairs)
- ;; Not wisi-elisp-parse--statement-action to match existing grammar files
- "Cache navigation information in text properties of tokens.
-Intended as a grammar non-terminal action.
-
-PAIRS is a vector of the form [TOKEN-NUMBER CLASS TOKEN-NUMBER
-CLASS ...] where TOKEN-NUMBER is the (1 indexed) token number in
-the production, CLASS is the wisi class of that token. Use in a
-grammar action as:
- (wisi-statement-action [1 statement-start 7 statement-end])"
- (when (eq wisi--parse-action 'navigate)
- (save-excursion
- (let ((first-item t)
- first-keyword-mark
- (override-start nil)
- (i 0))
- (while (< i (length pairs))
- (let* ((number (1- (aref pairs i)))
- (region (wisi-tok-region (aref wisi-tokens number)))
- (token (wisi-tok-token (aref wisi-tokens number)))
- (class (aref pairs (setq i (1+ i))))
- (mark (when region (copy-marker (car region) t)))
- cache)
-
- (setq i (1+ i))
-
- (unless (seq-contains wisi-class-list class)
- (error "%s not in wisi-class-list" class))
-
- (if region
- (progn
- (if (setq cache (wisi-get-cache (car region)))
- ;; We are processing a previously set non-terminal; ie
simple_statement in
- ;;
- ;; statement : label_opt simple_statement
- ;;
- ;; override nonterm, class, containing
- (progn
- (setf (wisi-cache-class cache) (or override-start
class))
- (setf (wisi-cache-nonterm cache) wisi-nterm)
- (setf (wisi-cache-containing cache) first-keyword-mark)
- (if wisi-end-caches
- (push (car region) wisi-end-caches)
- (setq wisi-end-caches (list (car region)))
- ))
-
- ;; else create new cache
- (with-silent-modifications
- (put-text-property
- (car region)
- (1+ (car region))
- 'wisi-cache
- (wisi-cache-create
- :nonterm wisi-nterm
- :token token
- :last (- (cdr region) (car region))
- :class (or override-start class)
- :containing first-keyword-mark)
- ))
- (if wisi-end-caches
- (push (car region) wisi-end-caches)
- (setq wisi-end-caches (list (car region)))
- ))
-
- (when first-item
- (setq first-item nil)
- (when (or override-start
- (eq class 'statement-start))
- (setq override-start nil)
- (setq first-keyword-mark mark)))
-
- (when (eq class 'statement-end)
- (wisi-elisp-parse--set-end first-keyword-mark (copy-marker
(car region) t)))
- )
-
- ;; region is nil when a production is empty; if the first
- ;; token is a start, override the class on the next token.
- (when (and first-item
- (eq class 'statement-start))
- (setq override-start class)))
- ))
- ))))
-
-(defun wisi-containing-action (containing-token contained-token)
- ;; Not wisi-elisp-parse--containing-action to match existing grammar files
- "Set containing marks in all tokens in CONTAINED-TOKEN
-with null containing mark to marker pointing to CONTAINING-TOKEN.
-If CONTAINING-TOKEN is empty, the next token number is used."
- (when (eq wisi--parse-action 'navigate)
- (let* ((containing-tok (aref wisi-tokens (1- containing-token)))
- (containing-region (wisi-tok-region containing-tok))
- (contained-tok (aref wisi-tokens (1- contained-token)))
- (contained-region (wisi-tok-region contained-tok)))
-
- (unless containing-region
- (signal 'wisi-parse-error
- (wisi-error-msg
- "wisi-containing-action: containing-region '%s' is empty.
grammar error; bad action"
- (wisi-tok-token containing-tok))))
-
- (unless (or (not contained-region) ;; contained-token is empty
- (wisi-get-cache (car containing-region)))
- (signal 'wisi-parse-error
- (wisi-error-msg
- "wisi-containing-action: containing-token '%s' has no cache.
grammar error; missing action"
- (wisi-token-text (aref wisi-tokens (1- containing-token))))))
-
- (when contained-region
- ;; nil when empty production, may not contain any caches
- (save-excursion
- (goto-char (cdr contained-region))
- (let ((cache (wisi-backward-cache))
- (mark (copy-marker (car containing-region) t)))
- (while cache
-
- ;; skip blocks that are already marked
- (while (and (>= (point) (car contained-region))
- (markerp (wisi-cache-containing cache)))
- (goto-char (wisi-cache-containing cache))
- (setq cache (wisi-get-cache (point))))
-
- (if (or (and (= (car containing-region) (car contained-region))
- (<= (point) (car contained-region)))
- (< (point) (car contained-region)))
- ;; done
- (setq cache nil)
-
- ;; else set mark, loop
- (setf (wisi-cache-containing cache) mark)
- (setq cache (wisi-backward-cache)))
- ))))
- )))
-
-(defun wisi-elisp-parse--match-token (cache tokens start)
- "Return t if CACHE has id from TOKENS and is at START or has containing
equal to START.
-point must be at cache token start.
-TOKENS is a vector [number token_id token_id ...].
-number is ignored."
- (let ((i 1)
- (done nil)
- (result nil)
- token)
- (when (or (= start (point))
- (and (wisi-cache-containing cache)
- (= start (wisi-cache-containing cache))))
- (while (and (not done)
- (< i (length tokens)))
- (setq token (aref tokens i))
- (if (eq token (wisi-cache-token cache))
- (setq result t
- done t)
- (setq i (1+ i)))
- ))
- result))
-
-(defun wisi-motion-action (token-numbers)
- ;; Not wisi-elisp-parse--motion-action to match existing grammar files
- "Set prev/next marks in all tokens given by TOKEN-NUMBERS.
-TOKEN-NUMBERS is a vector with each element one of:
-
-number: the token number; mark that token
-
-vector [number token_id]:
-vector [number token_id token_id ...]:
- mark all tokens in number nonterminal matching token_id with nil prev/next."
- (when (eq wisi--parse-action 'navigate)
- (save-excursion
- (let (prev-keyword-mark
- prev-cache
- token
- start
- cache
- mark
- (i 0))
- (while (< i (length token-numbers))
- (let ((token-number (aref token-numbers i))
- region)
- (setq i (1+ i))
- (cond
- ((numberp token-number)
- (setq token (aref wisi-tokens (1- token-number)))
- (setq region (wisi-tok-region token))
- (when region
- (unless start (setq start (car region)))
- (setq cache (wisi-get-cache (car region)))
- (unless cache (error "no cache on token %d; add to
statement-action" token-number))
- (setq mark (copy-marker (car region) t))
-
- (if prev-keyword-mark
- (progn
- (setf (wisi-cache-prev cache) prev-keyword-mark)
- (setf (wisi-cache-next prev-cache) mark)
- (setq prev-keyword-mark mark)
- (setq prev-cache cache))
-
- ;; else first token; save as prev
- (setq prev-keyword-mark mark)
- (setq prev-cache cache))
- ))
-
- ((vectorp token-number)
- ;; token-number may contain 1 or more token_ids
- ;; the corresponding region may be empty
- ;; there may not have been a prev keyword
- (setq region (wisi-tok-region (aref wisi-tokens (1- (aref
token-number 0)))))
- (when region ;; not an empty token
- ;; We must search for all targets at the same time, to
- ;; get the motion order right.
- (unless start (setq start (car region)))
- (goto-char (car region))
- (setq cache (wisi-get-cache (point)))
- (unless cache (error "no cache at %d; add to statement-action"
(car region)))
- (while (< (point) (cdr region))
- (when (wisi-elisp-parse--match-token cache token-number start)
- (setq mark (copy-marker (point) t))
-
- (if prev-keyword-mark
- ;; Don't include this token if prev/next
- ;; already set by a lower level statement,
- ;; such as a nested if/then/elsif/end if.
- (when (and (null (wisi-cache-prev cache))
- (null (wisi-cache-next prev-cache)))
- (setf (wisi-cache-prev cache) prev-keyword-mark)
- (setf (wisi-cache-next prev-cache) mark)
- (setq prev-keyword-mark mark)
- (setq prev-cache cache))
-
- ;; else first token; save as prev
- (setq prev-keyword-mark mark)
- (setq prev-cache cache)))
-
- (setq cache (wisi-forward-cache))
- )))
-
- (t
- (error "unexpected token-number %s" token-number))
- )
-
- ))
- ))))
-
-;;;; Face grammar actions
-
-(defun wisi-elisp-parse--face-put-cache (region class)
- "Put a ’wisi-face’ cache with class CLASS on REGION."
- (when (> wisi-debug 1)
- (message "face: put cache %s:%s" region class))
- (with-silent-modifications
- (put-text-property
- (car region)
- (1+ (car region))
- 'wisi-face
- (wisi-cache-create
- :last (- (cdr region) (car region))
- :class class)
- )))
-
-(defun wisi-face-mark-action (pairs)
- ;; Not wisi-elisp-parse--face-mark-action to match existing grammar files
- "PAIRS is a vector of TOKEN CLASS pairs; mark TOKEN (token number)
-as having face CLASS (prefix or suffix).
-Intended as a grammar action."
- (when (eq wisi--parse-action 'face)
- (let ((i 0))
- (while (< i (length pairs))
- (let ((region (wisi-tok-region (aref wisi-tokens (1- (aref pairs i)))))
- (class (aref pairs (setq i (1+ i)))))
- (setq i (1+ i))
- (when region
- ;; region can be null on an optional or virtual token
- (let ((cache (get-text-property (car region) 'wisi-face)))
- (if cache
- ;; previously marked; extend this cache, delete any others
- (progn
- (with-silent-modifications
- (remove-text-properties (+ (car region) (wisi-cache-last
cache)) (cdr region) '(wisi-face nil)))
- (setf (wisi-cache-class cache) class)
- (setf (wisi-cache-last cache) (- (cdr region) (car
region))))
-
- ;; else not previously marked
- (wisi-elisp-parse--face-put-cache region class)))
- ))
- ))))
-
-(defun wisi-face-remove-action (tokens)
- ;; Not wisi-elisp-parse--face-remove-action to match existing grammar files
- "Remove face caches and faces in TOKENS.
-Intended as a grammar action.
-
-TOKENS is a vector of token numbers."
- (when (eq wisi--parse-action 'face)
- (let ((i 0))
- (while (< i (length tokens))
- (let* ((number (1- (aref tokens i)))
- (region (wisi-tok-region (aref wisi-tokens number)))
- face-cache)
-
- (setq i (1+ i))
-
- (when region
- (let ((pos (car region)))
- (while (< pos (cdr region))
- (when (setq face-cache (get-text-property pos 'wisi-face))
- (when (> wisi-debug 1)
- (message "face: remove face %s" (cons pos (+ pos
(wisi-cache-last face-cache)))))
- (with-silent-modifications
- (remove-text-properties
- pos (+ pos (wisi-cache-last face-cache))
- (list
- 'wisi-face nil
- 'font-lock-face nil
- 'fontified t))))
- (setq pos (next-single-property-change
- (+ pos (or (and face-cache
- (wisi-cache-last face-cache))
- 0))
- 'wisi-face nil (cdr region)))
- )))
- )))))
-
-(defun wisi-elisp-parse--face-action-1 (face region)
- "Apply FACE to REGION."
- (when region
- (when (> wisi-debug 1)
- (message "face: add face %s:%s" region face))
- (with-silent-modifications
- (add-text-properties
- (car region) (cdr region)
- (list
- 'font-lock-face face
- 'fontified t)))
- ))
-
-(defun wisi-face-apply-action (triples)
- ;; Not wisi-elisp-parse--face-apply-action to match existing grammar files
- "Set face information in `wisi-face' text properties of tokens.
-Intended as a grammar non-terminal action.
-
-TRIPLES is a vector of the form [TOKEN-NUMBER PREFIX-FACE SUFFIX-FACE ...]
-
-In the first ’wisi-face’ cache in each token region, apply
-PREFIX-FACE to class PREFIX, SUFFIX-FACE to class SUFFIX, or
-SUFFIX-FACE to all of the token region if there is no ’wisi-face’
-cache."
- (when (eq wisi--parse-action 'face)
- (let (number prefix-face suffix-face (i 0))
- (while (< i (length triples))
- (setq number (aref triples i))
- (setq prefix-face (aref triples (setq i (1+ i))))
- (setq suffix-face (aref triples (setq i (1+ i))))
- (cond
- ((integerp number)
- (let* ((token-region (wisi-tok-region (aref wisi-tokens (1- number))))
- (pos (car token-region))
- (j 0)
- (some-cache nil)
- cache)
- (when token-region
- ;; region can be null for an optional or virtual token
- (while (< j 2)
- (setq cache (get-text-property pos 'wisi-face))
- (cond
- ((and (not some-cache)
- (null cache))
- ;; cache is null when applying a face to a token
- ;; directly, without first calling
- ;; wisi-face-mark-action. Or when there is a
- ;; previously applied face in a lower level token,
- ;; such as a numeric literal.
- (wisi-elisp-parse--face-action-1 suffix-face token-region))
-
- ((and cache
- (eq 'prefix (wisi-cache-class cache)))
- (setq some-cache t)
- (wisi-elisp-parse--face-action-1 prefix-face
(wisi-cache-region cache pos)))
-
- ((and cache
- (eq 'suffix (wisi-cache-class cache)))
- (setq some-cache t)
- (wisi-elisp-parse--face-action-1 suffix-face
(wisi-cache-region cache pos)))
-
- (t
- ;; don’t apply a face
- nil)
- )
-
- (setq j (1+ j))
- (if suffix-face
- (setq pos (next-single-property-change (+ 2 pos) 'wisi-face
nil (cdr token-region)))
- (setq j 2))
- ))))
-
- (t
- ;; catch conversion errors from previous grammar syntax
- (error "wisi-face-apply-action with non-integer token number"))
- )
- (setq i (1+ i))
- ))))
-
-(defun wisi-face-apply-list-action (triples)
- ;; Not wisi-elisp-parse--face-apply-list-action to match existing grammar
files
- "Similar to ’wisi-face-apply-action’, but applies faces to all
-tokens with a `wisi-face' cache in the wisi-tokens[token-number]
-region, and does not apply a face if there are no such caches."
- (when (eq wisi--parse-action 'face)
- (let (number token-region face-region prefix-face suffix-face cache (i 0)
pos)
- (while (< i (length triples))
- (setq number (aref triples i))
- (setq prefix-face (aref triples (setq i (1+ i))))
- (setq suffix-face (aref triples (setq i (1+ i))))
- (cond
- ((integerp number)
- (setq token-region (wisi-tok-region (aref wisi-tokens (1- number))))
- (when token-region
- ;; region can be null for an optional token
- (setq pos (car token-region))
- (while (and pos
- (< pos (cdr token-region)))
- (setq cache (get-text-property pos 'wisi-face))
- (setq face-region (wisi-cache-region cache pos))
- (cond
- ((or (null (wisi-cache-class cache))
- (eq 'prefix (wisi-cache-class cache)))
- (wisi-elisp-parse--face-action-1 prefix-face face-region))
- ((eq 'suffix (wisi-cache-class cache))
- (wisi-elisp-parse--face-action-1 suffix-face face-region))
-
- (t
- (error "wisi-face-apply-list-action: face cache class is not
prefix or suffix")))
-
- (setq pos (next-single-property-change (1+ pos) 'wisi-face nil
(cdr token-region)))
- )))
- (t
- ;; catch conversion errors from previous grammar syntax
- (error "wisi-face-apply-list-action with non-integer token number"))
- )
- (setq i (1+ i))
- ))))
-
-;;;; indent grammar actions
-
-(defvar wisi-elisp-parse-indent-hanging-function nil
- "Language-specific implementation of `wisi-hanging', `wisi-hanging%'.
-A function taking args TOK DELTA1 DELTA2 OPTION NO-ACCUMULATE,
-and returning an indent.
-TOK is a `wisi-tok' struct for the token being indented.
-DELTA1, DELTA2 are the indents of the first and following lines
-within the nonterminal. OPTION is non-nil if action is `wisi-hanging%'.
-point is at start of TOK, and may be moved.")
-(make-variable-buffer-local 'wisi-elisp-parse-indent-hanging-function)
-
-(defvar wisi-token-index nil
- ;; Not wisi-elisp-parse--token-index for backward compatibility
- "Index of current token in `wisi-tokens'.
-Let-bound in `wisi-indent-action', for grammar actions.")
-
-(defvar wisi-indent-comment nil
- ;; Not wisi-elisp-parse--indent-comment for backward compatibility
- "Non-nil if computing indent for comment.
-Let-bound in `wisi-indent-action', for grammar actions.")
-
-(defun wisi-elisp-parse--indent-zero-p (indent)
- (cond
- ((integerp indent)
- (= indent 0))
-
- (t ;; 'anchor
- (integerp (nth 2 indent)))
- ))
-
-(defun wisi-elisp-parse--apply-int (i delta)
- "Add DELTA (an integer) to the indent at index I."
- (let ((indent (aref wisi-elisp-parse--indent i))) ;; reference if list
-
- (cond
- ((integerp indent)
- (aset wisi-elisp-parse--indent i (+ delta indent)))
-
- ((listp indent)
- (cond
- ((eq 'anchor (car indent))
- (when (integerp (nth 2 indent))
- (setf (nth 2 indent) (+ delta (nth 2 indent)))
- ;; else anchored; not affected by this delta
- ))
-
- ((eq 'anchored (car indent))
- ;; not affected by this delta
- )))
-
- (t
- (error "wisi-elisp-parse--apply-int: invalid form : %s" indent))
- )))
-
-(defun wisi-elisp-parse--apply-anchored (delta i)
- "Apply DELTA (an anchored indent) to indent I."
- ;; delta is from wisi-anchored; ('anchored 1 delta no-accumulate)
- (let ((indent (aref wisi-elisp-parse--indent i))
- (accumulate (not (nth 3 delta))))
-
- (cond
- ((integerp indent)
- (when (or accumulate
- (= indent 0))
- (let ((temp (seq-take delta 3)))
- (setf (nth 2 temp) (+ indent (nth 2 temp)))
- (aset wisi-elisp-parse--indent i temp))))
-
- ((and (listp indent)
- (eq 'anchor (car indent))
- (integerp (nth 2 indent)))
- (when (or accumulate
- (= (nth 2 indent) 0))
- (let ((temp (seq-take delta 3)))
- (setf (nth 2 temp) (+ (nth 2 indent) (nth 2 temp)))
- (setf (nth 2 indent) temp))))
- )))
-
-(defun wisi-elisp-parse--indent-token-1 (line end delta)
- "Apply indent DELTA to all lines from LINE (a line number) thru END (a
buffer position)."
- (let ((i (1- line));; index to wisi-elisp-lexer-line-begin,
wisi-elisp-parse--indent
- (paren-first (when (and (listp delta)
- (eq 'hanging (car delta)))
- (nth 2 delta))))
-
- (while (<= (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end)
- (unless
- (and ;; no check for called from wisi--indent-comment;
- ;; comments within tokens are indented by
- ;; wisi--indent-token
- wisi-indent-comment-col-0
- (= 11 (syntax-class (syntax-after (aref
(wisi-elisp-lexer-line-begin wisi--lexer) i)))))
- (cond
- ((integerp delta)
- (wisi-elisp-parse--apply-int i delta))
-
- ((listp delta)
- (cond
- ((eq 'anchored (car delta))
- (wisi-elisp-parse--apply-anchored delta i))
-
- ((eq 'hanging (car delta))
- ;; from wisi-hanging; delta is ('hanging first-line nest delta1
delta2 no-accumulate)
- ;; delta1, delta2 may be anchored
- (when (or (not (nth 5 delta))
- (wisi-elisp-parse--indent-zero-p (aref
wisi-elisp-parse--indent i)))
- (if (= i (1- (nth 1 delta)))
- ;; apply delta1
- (let ((delta1 (nth 3 delta)))
- (cond
- ((integerp delta1)
- (wisi-elisp-parse--apply-int i delta1))
-
- (t ;; anchored
- (wisi-elisp-parse--apply-anchored delta1 i))
- ))
-
- ;; don't apply hanging indent in nested parens.
- ;; test/ada_mode-parens.adb
- ;; No_Conditional_Set : constant Ada.Strings.Maps.Character_Set
:=
- ;; Ada.Strings.Maps."or"
- ;; (Ada.Strings.Maps.To_Set (' '),
- (when (= paren-first
- (nth 0 (save-excursion (syntax-ppss (aref
(wisi-elisp-lexer-line-begin wisi--lexer) i)))))
- (let ((delta2 (nth 4 delta)))
- (cond
- ((integerp delta2)
- (wisi-elisp-parse--apply-int i delta2))
-
- (t ;; anchored
- (wisi-elisp-parse--apply-anchored delta2 i))
- )))
- )))
-
- (t
- (error "wisi-elisp-parse--indent-token-1: invalid delta: %s" delta))
- )) ;; listp delta
-
- (t
- (error "wisi-elisp-parse--indent-token-1: invalid delta: %s" delta))
- ))
- (setq i (1+ i))
- )))
-
-(defun wisi-elisp-parse--indent-token (tok token-delta)
- "Add TOKEN-DELTA to all indents in TOK region,"
- (let ((line (if (wisi-tok-nonterminal tok)
- (wisi-tok-first tok)
- (when (wisi-tok-first tok) (wisi-tok-line tok))))
- (end (cdr (wisi-tok-region tok))))
- (when (and line end token-delta)
- (wisi-elisp-parse--indent-token-1 line end token-delta))))
-
-(defun wisi-elisp-parse--indent-comment (tok comment-delta)
- "Add COMMENT-DELTA to all indents in comment region following TOK."
- (let ((line (wisi-tok-comment-line tok))
- (end (wisi-tok-comment-end tok)))
- (when (and line end comment-delta)
- (wisi-elisp-parse--indent-token-1 line end comment-delta))))
-
-(defun wisi-elisp-parse--anchored-1 (tok offset &optional no-accumulate)
- "Return offset of TOK relative to current indentation + OFFSET.
-For use in grammar indent actions."
- (when (wisi-tok-region tok)
- ;; region can be nil when token is inserted by error recovery
- (let ((pos (car (wisi-tok-region tok)))
- delta)
-
- (goto-char pos)
- (setq delta (+ offset (- (current-column) (current-indentation))))
- (wisi-elisp-parse--anchored-2
- (wisi-tok-line tok) ;; anchor-line
- (if wisi-indent-comment
- (wisi-tok-comment-end (aref wisi-tokens wisi-token-index))
- (cdr (wisi-tok-region (aref wisi-tokens wisi-token-index))));; end
- delta
- no-accumulate)
- )))
-
-(defun wisi-elisp-parse--max-anchor (begin-line end)
- (let ((i (1- begin-line))
- (max-i (length (wisi-elisp-lexer-line-begin wisi--lexer)))
- (result 0))
- (while (and (< i max-i)
- (<= (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end))
- (let ((indent (aref wisi-elisp-parse--indent i)))
- (when (listp indent)
- (cond
- ((eq 'anchor (car indent))
- (setq result (max result (car (nth 1 indent))))
- (when (listp (nth 2 indent))
- (setq result (max result (nth 1 (nth 2 indent))))
- ))
- (t ;; anchored
- (setq result (max result (nth 1 indent))))
- )))
- (setq i (1+ i)))
- result
- ))
-
-(defun wisi-elisp-parse--anchored-2 (anchor-line end delta no-accumulate)
- "Set ANCHOR-LINE as anchor, increment anchors thru END, return anchored
delta."
- ;; Typically, we use anchored to indent relative to a token buried in a line:
- ;;
- ;; test/ada_mode-parens.adb
- ;; Local_2 : Integer := (1 + 2 +
- ;; 3);
- ;; line starting with '3' is anchored to '('
- ;;
- ;; If the anchor is a nonterminal, and the first token in the anchor
- ;; is also first on a line, we don't need anchored to compute the
- ;; delta:
- ;;
- ;; test/ada_mode-parens.adb
- ;; Local_5 : Integer :=
- ;; (1 + 2 +
- ;; 3);
- ;; delta for line starting with '3' can just be '3'.
- ;;
- ;; However, in some places we need anchored to prevent later
- ;; deltas from accumulating:
- ;;
- ;; test/ada_mode-parens.adb
- ;; No_Conditional_Set : constant Ada.Strings.Maps.Character_Set :=
- ;; Ada.Strings.Maps."or"
- ;; (Ada.Strings.Maps.To_Set (' '),
- ;;
- ;; here the function call actual parameter part is indented first
- ;; by 'name' and later by 'expression'; we use anchored to keep the
- ;; 'name' delta and ignore the later delta.
- ;;
- ;; So we apply anchored whether the anchor token is first or not.
-
- (let* ((i (1- anchor-line))
- (indent (aref wisi-elisp-parse--indent i)) ;; reference if list
- (anchor-id (1+ (wisi-elisp-parse--max-anchor anchor-line end))))
-
- ;; Set anchor
- (cond
- ((integerp indent)
- (aset wisi-elisp-parse--indent i (list 'anchor (list anchor-id) indent)))
-
- ((and (listp indent)
- (eq 'anchor (car indent)))
- (push anchor-id (nth 1 indent)))
-
- ((and (listp indent)
- (eq 'anchored (car indent)))
- (aset wisi-elisp-parse--indent i (list 'anchor (list anchor-id)
(copy-sequence indent))))
-
- (t
- (error "wisi-anchored-delta: invalid form in indent: %s" indent)))
-
- (list 'anchored anchor-id delta no-accumulate)
- ))
-
-(defun wisi-anchored (token-number offset &optional no-accumulate)
- ;; Not wisi-elisp-parse--anchored to match existing grammar files
- "Return offset of token TOKEN-NUMBER in `wisi-tokens'.relative to current
indentation + OFFSET.
-For use in grammar indent actions."
- (wisi-elisp-parse--anchored-1 (aref wisi-tokens (1- token-number)) offset
no-accumulate))
-
-(defun wisi-anchored* (token-number offset)
- ;; Not wisi-elisp-parse--anchored* to match existing grammar files
- "If TOKEN-NUMBER token in `wisi-tokens' is first on a line,
-call ’wisi-anchored OFFSET’. Otherwise return 0.
-For use in grammar indent actions."
- (if (wisi-tok-first (aref wisi-tokens (1- token-number)))
- (wisi-anchored token-number offset)
- 0))
-
-(defun wisi-anchored*- (token-number offset)
- ;; Not wisi-elisp-parse--anchored*- to match existing grammar files
- "If existing indent is zero, and TOKEN-NUMBER token in `wisi-tokens' is
first on a line,
-call ’wisi-anchored OFFSET’. Otherwise return 0.
-For use in grammar indent actions."
- (if (wisi-tok-first (aref wisi-tokens (1- token-number)))
- (wisi-anchored token-number offset t)
- 0))
-
-(defun wisi-elisp-parse--paren-in-anchor-line (anchor-tok offset)
- "If there is an opening paren containing ANCHOR-TOK in the same line as
ANCHOR-TOK,
-return OFFSET plus the delta from the line indent to the paren
-position. Otherwise return OFFSET."
- (let* ((tok-syntax (syntax-ppss (car (wisi-tok-region anchor-tok))))
- (paren-pos (nth 1 tok-syntax))
- (anchor-line (wisi-tok-line anchor-tok)))
-
- (when (and paren-pos ;; in paren
- (< paren-pos (aref (wisi-elisp-lexer-line-begin wisi--lexer) (1-
anchor-line))))
- ;; paren not in anchor line
- (setq paren-pos nil))
-
- (if paren-pos
- (progn
- (goto-char paren-pos)
- (+ 1 (- (current-column) (current-indentation)) offset))
- offset)
- ))
-
-(defun wisi-anchored% (token-number offset &optional no-accumulate)
- ;; Not wisi-elisp-parse--anchored% to match existing grammar files
- "Return either an anchor for the current token at OFFSET from an enclosing
paren on
-the line containing TOKEN-NUMBER, or OFFSET.
-For use in grammar indent actions."
- (let* ((indent-tok (aref wisi-tokens wisi-token-index))
- ;; indent-tok is a nonterminal; this function makes no sense for
terminals
- (anchor-tok (aref wisi-tokens (1- token-number))))
-
- (wisi-elisp-parse--anchored-2
- (wisi-tok-line anchor-tok)
-
- (if wisi-indent-comment
- (wisi-tok-comment-end indent-tok)
- (cdr (wisi-tok-region indent-tok))) ;; end
-
- (wisi-elisp-parse--paren-in-anchor-line anchor-tok offset)
- no-accumulate)
- ))
-
-(defun wisi-anchored%- (token-number offset)
- ;; Not wisi-elisp-parse--anchored%- to match existing grammar files
- "If existing indent is zero, anchor the current token at OFFSET
-from the first token on the line containing TOKEN-NUMBER in `wisi-tokens'.
-Return the delta.
-For use in grammar indent actions."
- (wisi-anchored% token-number offset t))
-
-(defun wisi-elisp-parse--hanging-1 (delta1 delta2 option no-accumulate)
- "If OPTION is nil, implement `wisi-hanging'; otherwise `wisi-hanging%'."
- (let ((tok (aref wisi-tokens wisi-token-index)))
- ;; tok is a nonterminal; this function makes no sense for terminals
- ;; syntax-ppss moves point to start of tok
-
- (cond
- ((functionp wisi-elisp-parse-indent-hanging-function)
- (funcall wisi-elisp-parse-indent-hanging-function tok delta1 delta2
option no-accumulate))
-
- (t
- (let ((tok-syntax (syntax-ppss (car (wisi-tok-region tok))))
- (first-tok-first-on-line
- ;; first token in tok is first on line
- (and (numberp (wisi-tok-first tok))
- (= (wisi-tok-line tok) (wisi-tok-first tok)))))
- (list 'hanging
- (wisi-tok-line tok) ;; first line of token
- (nth 0 tok-syntax) ;; paren nest level at tok
- delta1
- (if (or (not option) first-tok-first-on-line)
- delta2
- delta1)
- no-accumulate))
- ))
- ))
-
-(defun wisi-hanging (delta1 delta2)
- ;; Not wisi-elisp-parse--hanging to match existing grammar files
- "Use DETLA1 for first line, DELTA2 for following lines.
-For use in grammar indent actions."
- (wisi-elisp-parse--hanging-1 delta1 delta2 nil nil))
-
-(defun wisi-hanging% (delta1 delta2)
- ;; Not wisi-elisp-parse--hanging% to match existing grammar files
- "If first token is first in line, use DETLA1 for first line, DELTA2 for
following lines.
-Otherwise use DELTA1 for all lines.
-For use in grammar indent actions."
- (wisi-elisp-parse--hanging-1 delta1 delta2 t nil))
-
-(defun wisi-hanging%- (delta1 delta2)
- ;; Not wisi-elisp-parse--hanging%- to match existing grammar files
- "If existing indent is non-zero, do nothing.
-Else if first token is first in line, use DETLA1 for first line,
-DELTA2 for following lines. Otherwise use DELTA1 for all lines.
-For use in grammar indent actions."
- (wisi-elisp-parse--hanging-1 delta1 delta2 t t))
-
-(defun wisi-elisp-parse--indent-offset (token offset)
- "Return offset from beginning of first token on line containing TOKEN,
- to beginning of TOKEN, plus OFFSET."
- (save-excursion
- (goto-char (aref (wisi-elisp-lexer-line-begin wisi--lexer) (1-
(wisi-tok-line token))))
- (back-to-indentation)
- (+ offset (- (car (wisi-tok-region token)) (point)))
- ))
-
-(defun wisi-elisp-parse--indent-compute-delta (delta tok)
- "Return evaluation of DELTA."
- (cond
- ((integerp delta)
- delta)
-
- ((symbolp delta)
- (symbol-value delta))
-
- ((vectorp delta)
- ;; [token comment]
- ;; if wisi-indent-comment, we are indenting the comments of the
- ;; previous token; they should align with the 'token' delta.
- (wisi-elisp-parse--indent-compute-delta (aref delta 0) tok))
-
- (t ;; form
- (cond
- ((eq 'anchored (car delta))
- delta)
-
- (t
- (save-excursion
- (goto-char (car (wisi-tok-region tok)))
- (eval delta)))))
- ))
-
-(defun wisi-indent-action (deltas)
- ;; Not wisi-elisp-parse--indent-action to match existing grammar files
- "Accumulate `wisi--indents' from DELTAS.
-DELTAS is a vector; each element can be:
-- an integer
-- a symbol
-- a lisp form
-- a vector.
-
-The first three are evaluated to give an integer delta. A vector must
-have two elements, giving the code and following comment
-deltas. Otherwise the comment delta is the following delta in
-DELTAS."
- (when (eq wisi--parse-action 'indent)
- (dotimes (wisi-token-index (length wisi-tokens))
- (let* ((tok (aref wisi-tokens wisi-token-index))
- (token-delta (aref deltas wisi-token-index))
- (comment-delta
- (cond
- ((vectorp token-delta)
- (aref token-delta 1))
-
- ((< wisi-token-index (1- (length wisi-tokens)))
- (aref deltas (1+ wisi-token-index)))
- )))
- (when (wisi-tok-region tok)
- ;; region is null when optional nonterminal is empty
- (let ((wisi-indent-comment nil))
- (setq token-delta
- (when (and token-delta
- (wisi-tok-first tok))
- (wisi-elisp-parse--indent-compute-delta token-delta tok)))
-
- (when (and token-delta
- (or (consp token-delta)
- (not (= 0 token-delta))))
- (wisi-elisp-parse--indent-token tok token-delta))
-
- (setq wisi-indent-comment t)
- (setq comment-delta
- (when (and comment-delta
- (wisi-tok-comment-line tok))
- (wisi-elisp-parse--indent-compute-delta comment-delta tok)))
-
- (when (and comment-delta
- (or (consp comment-delta)
- (not (= 0 comment-delta))))
- (wisi-elisp-parse--indent-comment tok comment-delta))
- )
- )))))
-
-(defun wisi-indent-action* (n deltas)
- ;; Not wisi-elisp-parse--indent-action* to match existing grammar files
- "If any of the first N tokens in `wisi-tokens' is first on a line,
-call `wisi-indent-action' with DELTAS. Otherwise do nothing."
- (when (eq wisi--parse-action 'indent)
- (let ((done nil)
- (i 0)
- tok)
- (while (and (not done)
- (< i n))
- (setq tok (aref wisi-tokens i))
- (setq i (1+ i))
- (when (and (wisi-tok-region tok)
- (wisi-tok-first tok))
- (setq done t)
- (wisi-indent-action deltas))
- ))))
-
-;;;; non-grammar indent functions
-
-(defconst wisi-elisp-parse--max-anchor-depth 20) ;; IMRPOVEME: can compute in
actions
-
-(defun wisi-elisp-parse--indent-leading-comments ()
- "Set `wisi-elisp-parse--indent to 0 for comment lines before first token in
buffer.
-Leave point at first token (or eob)."
- (save-excursion
- (goto-char (point-min))
- (forward-comment (point-max))
- (let ((end (point))
- (i 0)
- (max-i (length wisi-elisp-parse--indent)))
- (while (and (< i max-i)
- (< (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end))
- (aset wisi-elisp-parse--indent i 0)
- (setq i (1+ i)))
- )))
-
-(defun wisi-elisp-parse--resolve-anchors ()
- (let ((anchor-indent (make-vector wisi-elisp-parse--max-anchor-depth 0))
- pos)
-
- (dotimes (i (length wisi-elisp-parse--indent))
- (let ((indent (aref wisi-elisp-parse--indent i)))
-
- (cond
- ((integerp indent))
-
- ((listp indent)
- (let ((anchor-ids (nth 1 indent))
- (indent2 (nth 2 indent)))
- (cond
- ((eq 'anchor (car indent))
- (cond
- ((integerp indent2)
- (dotimes (i (length anchor-ids))
- (aset anchor-indent (nth i anchor-ids) indent2))
- (setq indent indent2))
-
- ((listp indent2) ;; 'anchored
- (setq indent (+ (aref anchor-indent (nth 1 indent2)) (nth 2
indent2)))
-
- (dotimes (i (length anchor-ids))
- (aset anchor-indent (nth i anchor-ids) indent)))
-
- (t
- (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
- ));; 'anchor
-
- ((eq 'anchored (car indent))
- (setq indent (+ (aref anchor-indent (nth 1 indent)) indent2)))
-
- (t
- (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
- )));; listp indent
-
- (t
- (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
- );; cond indent
-
- (when (> i 0)
- (setq pos (aref (wisi-elisp-lexer-line-begin wisi--lexer) i))
- (with-silent-modifications
- (put-text-property (1- pos) pos 'wisi-indent indent)))
- )) ;; dotimes lines
-
- ))
-
-(provide 'wisi-elisp-parse)
-;;; wisi-elisp-parse.el ends here
+;; wisi-elisp-parse.el --- Wisi parser -*- lexical-binding:t -*-
+
+;; Copyright (C) 2013-2015, 2017 - 2019 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+
+;; An extended LALR parser, that handles shift/reduce and
+;; reduce/reduce conflicts by spawning parallel parsers to follow each
+;; path.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'wisi-elisp-lexer)
+(require 'wisi-parse-common)
+
+(defvar wisi-elisp-parse-max-parallel-current (cons 0 0)
+ "Cons (count . point); Maximum number of parallel parsers used in most
recent parse,
+point at which that max was spawned.")
+
+(defvar wisi-debug-identical 0
+ "Debug terminating identical parsers.
+0 - keep lower-numbered parser.
+1 - keep higher-numbered parser.
+2 - error.")
+
+(cl-defstruct (wisi-elisp-parser-state
+ (:copier nil))
+ label ;; integer identifying parser for debug
+
+ active
+ ;; 'shift - need new token
+ ;; 'reduce - need reduce
+ ;; 'accept - parsing completed
+ ;; 'error - failed, error not reported yet
+ ;; nil - terminated
+ ;;
+ ;; 'pending-shift, 'pending-reduce - newly created parser
+
+ stack
+ ;; Each stack item takes two slots: wisi-tok, state
+
+ sp ;; stack pointer
+
+ pending
+ ;; list of (action-symbol stack-fragment)
+ )
+
+(cl-defstruct (wisi-elisp-parser (:include wisi-parser))
+ actions
+ gotos
+ next-token
+ )
+
+;;;###autoload
+(defun wisi-make-elisp-parser (automaton next-token)
+ "Return ‘wisi-parser’ object.
+
+- AUTOMATON is the parse table generated by `wisi-compile-grammar'.
+
+- NEXT-TOKEN is a function with no argument called by the parser to
+ obtain the next token from the current buffer after point, as a
+ ’wisi-tok’ object (normally ‘wisi-forward-token’)."
+ (make-wisi-elisp-parser
+ :actions (aref automaton 0)
+ :gotos (aref automaton 1)
+ :next-token next-token))
+
+(cl-defmethod wisi-parse-kill ((_parser wisi-elisp-parser))
+ nil)
+
+(defvar wisi-elisp-parse--indent nil
+ ;; not buffer-local; only let-bound in wisi-parse-current (elisp)
+ "A vector of indentation for all lines in buffer.
+Each element can be one of:
+- nil : no indent set yet
+
+- integer : indent
+
+- list ('anchor (start-id ...) indent) :
+ indent for current line, base indent for following 'anchored
+ lines. Start-id is list of ids anchored at this line. For parens
+ and other uses.
+
+- list ('anchored id delta) :
+ indent = delta + 'anchor id line indent; for lines indented
+ relative to anchor.
+
+- list ('anchor (start-id ...) ('anchored id delta))
+ for nested anchors.")
+
+(cl-defmethod wisi-parse-current ((parser wisi-elisp-parser) _begin _send-end
_parse-end)
+ "Parse entire current buffer.
+BEGIN, END are ignored"
+
+ (let ((actions (wisi-elisp-parser-actions parser))
+ (gotos (wisi-elisp-parser-gotos parser))
+ (parser-states ;; vector of parallel parser states
+ (vector
+ (make-wisi-elisp-parser-state
+ :label 0
+ :active 'shift
+ :stack (make-vector wisi-parse-max-stack-size nil)
+ :sp 0
+ :pending nil)))
+ (active-parser-count 1)
+ active-parser-count-prev
+ (active 'shift)
+ (token nil)
+ some-pending
+ wisi-elisp-parse--indent)
+
+ (cl-case wisi--parse-action
+ (indent
+ (let ((line-count (1+ (count-lines (point-min) (point-max)))))
+ (setq wisi-elisp-parse--indent (make-vector line-count nil))
+ (wisi-elisp-lexer-reset line-count wisi--lexer)))
+
+ (navigate
+ (setq wisi-end-caches nil))
+
+ (t nil))
+
+ (setf (wisi-parser-lexer-errors parser) nil)
+ (setf (wisi-parser-parse-errors parser) nil)
+
+ ;; We assume the lexer relies on syntax properties
+ (when (< emacs-major-version 25) (syntax-propertize (point-max)))
+
+ (goto-char (point-min))
+ (forward-comment (point-max))
+ (aset (wisi-elisp-parser-state-stack (aref parser-states 0)) 0 0)
+
+ (setq token (funcall (wisi-elisp-parser-next-token parser)))
+ (setq wisi-elisp-parse-max-parallel-current (cons 0 0))
+
+ (while (not (eq active 'accept))
+ (setq active-parser-count-prev active-parser-count)
+ (setq some-pending nil)
+ (dotimes (parser-index (length parser-states))
+ (when (eq active (wisi-elisp-parser-state-active (aref parser-states
parser-index)))
+ (let* ((parser-state (aref parser-states parser-index))
+ (result (wisi-elisp-parse-1 token parser-state (>
active-parser-count 1) actions gotos)))
+ (when result
+ ;; spawn a new parser
+ (when (= active-parser-count wisi-parse-max-parallel)
+ (let* ((state (aref (wisi-elisp-parser-state-stack parser-state)
+ (wisi-elisp-parser-state-sp parser-state)))
+ (msg (wisi-error-msg (concat "too many parallel parsers
required in grammar state %d;"
+ " simplify grammar, or
increase `wisi-elisp-parse-max-parallel'")
+ state)))
+ (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error msg)))
+
+ (let ((j (wisi-elisp-parse-free-parser parser-states)))
+ (cond
+ ((= j -1)
+ ;; Add to parser-states; the new parser won't be executed
+ ;; again in this parser-index loop.
+ (setq parser-states (vconcat parser-states (vector nil)))
+ (setq j (1- (length parser-states))))
+ ((< j parser-index)
+ ;; The new parser won't be executed again in this
+ ;; parser-index loop; nothing to do.
+ )
+ (t
+ ;; Don't let the new parser execute again in this
+ ;; parser-index loop.
+ (setq some-pending t)
+ (setf (wisi-elisp-parser-state-active result)
+ (cl-case (wisi-elisp-parser-state-active result)
+ (shift 'pending-shift)
+ (reduce 'pending-reduce)
+ )))
+ )
+ (setq active-parser-count (1+ active-parser-count))
+ (when (> active-parser-count (car
wisi-elisp-parse-max-parallel-current))
+ (setq wisi-elisp-parse-max-parallel-current (cons
active-parser-count (point))))
+ (setf (wisi-elisp-parser-state-label result) j)
+ (aset parser-states j result))
+ (when (> wisi-debug 1)
+ (message "spawn parser (%d active)" active-parser-count)))
+
+ (when (eq 'error (wisi-elisp-parser-state-active parser-state))
+ (setq active-parser-count (1- active-parser-count))
+ (when (> wisi-debug 1)
+ (message "terminate parser (%d active)" active-parser-count))
+ (cl-case active-parser-count
+ (0
+ (cond
+ ((= active-parser-count-prev 1)
+ ;; We were not in a parallel parse; abandon parsing, report
the error.
+ (let* ((state (aref (wisi-elisp-parser-state-stack
parser-state)
+ (wisi-elisp-parser-state-sp
parser-state)))
+ (msg (wisi-error-msg "syntax error in grammar state
%d; unexpected %s, expecting one of %s"
+ state
+ (wisi-token-text token)
+ (mapcar 'car (aref actions
state)))))
+ (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error msg)))
+ (t
+ ;; Report errors from all parsers that failed on this token.
+ (let ((msg))
+ (dotimes (_ (length parser-states))
+ (let* ((parser-state (aref parser-states parser-index))
+ (state (aref (wisi-elisp-parser-state-stack
parser-state)
+ (wisi-elisp-parser-state-sp
parser-state))))
+ (when (eq 'error (wisi-elisp-parser-state-active
parser-state))
+ (setq msg
+ (concat msg
+ (when msg "\n")
+ (wisi-error-msg
+ "syntax error in grammar state %d;
unexpected %s, expecting one of %s"
+ state
+ (wisi-token-text token)
+ (mapcar 'car (aref actions state)))))
+ )))
+ (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error msg)))
+ ))
+
+ (1
+ (setf (wisi-elisp-parser-state-active parser-state) nil);
Don't save error for later.
+ (wisi-elisp-parse-execute-pending (aref parser-states
(wisi-elisp-parse-active-parser parser-states))))
+
+ (t
+ ;; We were in a parallel parse, and this parser
+ ;; failed; mark it inactive, don't save error for
+ ;; later.
+ (setf (wisi-elisp-parser-state-active parser-state) nil)
+ )))
+ )));; end dotimes
+
+ (when some-pending
+ ;; Change pending-* parsers to *.
+ (dotimes (parser-index (length parser-states))
+ (cond
+ ((eq (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'pending-shift)
+ (setf (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'shift))
+ ((eq (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'pending-reduce)
+ (setf (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'reduce))
+ )))
+
+ (setq active (wisi-elisp-parsers-active parser-states
active-parser-count))
+ (when (eq active 'shift)
+ (when (> active-parser-count 1)
+ (setq active-parser-count (wisi-elisp-parse-elim-identical parser
parser-states active-parser-count)))
+
+ (setq token (funcall (wisi-elisp-parser-next-token parser))))
+ )
+ (when (> active-parser-count 1)
+ (error "ambiguous parse result"))
+
+ (cl-case wisi--parse-action
+ (indent
+ (wisi-elisp-parse--indent-leading-comments)
+ (wisi-elisp-parse--resolve-anchors))
+
+ (t nil))
+
+ ;; Return region parsed.
+ (cons (point-min) (point))
+ ))
+
+(defun wisi-elisp-parsers-active-index (parser-states)
+ ;; only called when active-parser-count = 1
+ (let ((result nil)
+ (i 0))
+ (while (and (not result)
+ (< i (length parser-states)))
+ (when (wisi-elisp-parser-state-active (aref parser-states i))
+ (setq result i))
+ (setq i (1+ i)))
+ result))
+
+(defun wisi-elisp-parsers-active (parser-states active-count)
+ "Return the type of parser cycle to execute.
+PARSER-STATES[*].active is the last action a parser took. If it
+was `shift', that parser used the input token, and should not be
+executed again until another input token is available, after all
+parsers have shifted the current token or terminated.
+
+Returns one of:
+
+`accept' : all PARSER-STATES have active set to nil or `accept' -
+done parsing
+
+`shift' : all PARSER-STATES have active set to nil, `accept', or
+`shift' - get a new token, execute `shift' parsers.
+
+`reduce' : some PARSER-STATES have active set to `reduce' - no new
+token, execute `reduce' parsers."
+ (let ((result nil)
+ (i 0)
+ (shift-count 0)
+ (accept-count 0)
+ active)
+ (while (and (not result)
+ (< i (length parser-states)))
+ (setq active (wisi-elisp-parser-state-active (aref parser-states i)))
+ (cond
+ ((eq active 'shift) (setq shift-count (1+ shift-count)))
+ ((eq active 'reduce) (setq result 'reduce))
+ ((eq active 'accept) (setq accept-count (1+ accept-count)))
+ )
+ (setq i (1+ i)))
+
+ (cond
+ (result )
+ ((= accept-count active-count)
+ 'accept)
+ ((= (+ shift-count accept-count) active-count)
+ 'shift)
+ (t
+ ;; all parsers in error state; should not get here
+ (error "all parsers in error state; programmer error"))
+ )))
+
+(defun wisi-elisp-parse-free-parser (parser-states)
+ "Return index to a non-active parser in PARSER-STATES, -1 if there is none."
+ (let ((result nil)
+ (i 0))
+ (while (and (not result)
+ (< i (length parser-states)))
+ (when (not (wisi-elisp-parser-state-active (aref parser-states i)))
+ (setq result i))
+ (setq i (1+ i)))
+ (if result result -1)))
+
+(defun wisi-elisp-parse-active-parser (parser-states)
+ "Return index to the first active parser in PARSER-STATES."
+ (let ((result nil)
+ (i 0))
+ (while (and (not result)
+ (< i (length parser-states)))
+ (when (wisi-elisp-parser-state-active (aref parser-states i))
+ (setq result i))
+ (setq i (1+ i)))
+ (unless result
+ (error "no active parsers"))
+ result))
+
+(defun wisi-elisp-parse-elim-identical (parser parser-states
active-parser-count)
+ "Check for parsers in PARSER-STATES that have reached identical states
eliminate one.
+Return new ACTIVE-PARSER-COUNT. Assumes all parsers have active
+nil, `shift', or `accept'."
+ ;; parser-states passed by reference; active-parser-count by copy
+ ;; see test/ada_mode-slices.adb for example
+ (dotimes (parser-i (1- (length parser-states)))
+ (when (wisi-elisp-parser-state-active (aref parser-states parser-i))
+ (dotimes (parser-j (- (length parser-states) parser-i 1))
+ (when (wisi-elisp-parser-state-active (aref parser-states (+ parser-i
parser-j 1)))
+ (when (eq (wisi-elisp-parser-state-sp (aref parser-states parser-i))
+ (wisi-elisp-parser-state-sp (aref parser-states (+
parser-i parser-j 1))))
+ (let ((compare t)
+ exec)
+ (dotimes (stack-i (wisi-elisp-parser-state-sp (aref parser-states
parser-i)))
+ (setq
+ compare
+ (and compare ;; bypass expensive 'arefs' after first stack
item compare fail
+ (equal (aref (wisi-elisp-parser-state-stack (aref
parser-states parser-i)) stack-i)
+ (aref (wisi-elisp-parser-state-stack (aref
parser-states (+ parser-i parser-j 1)))
+ stack-i)))))
+ (when compare
+ ;; parser stacks are identical
+ (setq active-parser-count (1- active-parser-count))
+ (when (> wisi-debug 1)
+ (message "terminate identical parser %d (%d active)"
+ (+ parser-i parser-j 1) active-parser-count)
+ (let ((state-i (aref parser-states parser-i))
+ (state-j (aref parser-states (+ parser-i parser-j 1))))
+ (message "%d actions:" (wisi-elisp-parser-state-label
state-i))
+ (mapc #'wisi-elisp-parse-debug-put-action
(wisi-elisp-parser-state-pending state-i))
+
+ (message "%d actions:" (wisi-elisp-parser-state-label
state-j))
+ (mapc #'wisi-elisp-parse-debug-put-action
(wisi-elisp-parser-state-pending state-j))
+ ))
+ (cl-ecase wisi-debug-identical
+ (0
+ (setq exec parser-i)
+ (setf (wisi-elisp-parser-state-active (aref parser-states (+
parser-i parser-j 1))) nil))
+
+ (1
+ (setq exec (+ parser-i parser-j 1))
+ (setf (wisi-elisp-parser-state-active (aref parser-states
parser-i)) nil))
+
+ (2
+ (let ((msg "identical parser stacks"))
+ (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error msg)))
+ )
+ (when (= active-parser-count 1)
+ ;; The actions for the two parsers are not
+ ;; identical, but most of the time either is good
+ ;; enough for indentation and navigation, so we just
+ ;; do the actions for the one that is not
+ ;; terminating. Some times, a significant action is
+ ;; lost. In that case, turn on
+ ;; ‘wisi-debug-identical’ to investigate fixing it.
+ (wisi-elisp-parse-execute-pending (aref parser-states exec)))
+ ))))
+ )))
+ active-parser-count)
+
+(defun wisi-elisp-parse-exec-action (func nonterm tokens)
+ "Execute action if TOKENS not null."
+ ;; `tokens' is null when all tokens in a grammar statement are
+ ;; optional and not present.
+ (unless wisi-action-disable
+ (if (< 0 (length tokens))
+ (when wisi--parse-action
+ (funcall func nonterm tokens))
+
+ (when (> wisi-debug 1)
+ (message "... action skipped; no tokens"))
+ )))
+
+(defvar wisi-elisp-parser-state nil
+ "Let-bound in `wisi-elisp-parse-reduce', used in `wisi-parse-find-token'.")
+
+(defun wisi-elisp-parse-debug-put-action (action)
+ ;; Action is (semantic-function nonterm [tokens])
+ (message "%s [%s]"
+ (nth 0 action)
+ (mapcar #'wisi-tok-debug-image (nth 2 action))))
+
+(defun wisi-elisp-parse-execute-pending (parser-state)
+ (let ((wisi-elisp-parser-state parser-state);; reference, for
wisi-parse-find-token
+ (pending (wisi-elisp-parser-state-pending parser-state)))
+
+ (when (> wisi-debug 1)
+ (message "%d: pending actions:" (wisi-elisp-parser-state-label
parser-state)))
+
+ (while pending
+ (when (> wisi-debug 1) (wisi-elisp-parse-debug-put-action (car pending)))
+
+ (let ((func-args (pop pending)))
+ (wisi-elisp-parse-exec-action (nth 0 func-args) (nth 1 func-args)
(cl-caddr func-args)))
+ )
+ (setf (wisi-elisp-parser-state-pending parser-state) nil)
+ ))
+
+(defmacro wisi-elisp-parse-action (i al)
+ "Return the parser action.
+I is a token item number and AL is the list of (item . action)
+available at current state. The first element of AL contains the
+default action for this state."
+ `(cdr (or (assq ,i ,al) (car ,al))))
+
+(defun wisi-elisp-parse-1 (token parser-state pendingp actions gotos)
+ "Perform one shift or reduce on PARSER-STATE.
+If PENDINGP, push actions onto PARSER-STATE.pending; otherwise execute them.
+See `wisi-elisp-parse' for full details.
+Return nil or new parser (a wisi-elisp-parser-state struct)."
+ (let* ((state (aref (wisi-elisp-parser-state-stack parser-state)
+ (wisi-elisp-parser-state-sp parser-state)))
+ (parse-action (wisi-elisp-parse-action (wisi-tok-token token) (aref
actions state)))
+ new-parser-state)
+
+ (when (> wisi-debug 1)
+ ;; output trace info
+ (if (> wisi-debug 2)
+ (progn
+ ;; put top 10 stack items
+ (let* ((count (min 20 (wisi-elisp-parser-state-sp parser-state)))
+ (msg (make-vector (+ 1 count) nil)))
+ (dotimes (i count)
+ (aset msg (- count i)
+ (aref (wisi-elisp-parser-state-stack parser-state)
+ (- (wisi-elisp-parser-state-sp parser-state) i)))
+ )
+ (message "%d: %s: %d: %s"
+ (wisi-elisp-parser-state-label parser-state)
+ (wisi-elisp-parser-state-active parser-state)
+ (wisi-elisp-parser-state-sp parser-state)
+ msg))
+ (message " %d: %s: %s" state (wisi-tok-debug-image token)
parse-action))
+ (message "%d: %d: %s: %s" (wisi-elisp-parser-state-label parser-state)
state token parse-action)))
+
+ (when (and (listp parse-action)
+ (not (symbolp (car parse-action))))
+ ;; Conflict; spawn a new parser.
+ (setq new-parser-state
+ (make-wisi-elisp-parser-state
+ :active nil
+ :stack (vconcat (wisi-elisp-parser-state-stack parser-state))
+ :sp (wisi-elisp-parser-state-sp parser-state)
+ :pending (wisi-elisp-parser-state-pending parser-state)))
+
+ (wisi-elisp-parse-2 (cadr parse-action) token new-parser-state t gotos)
+ (setq pendingp t)
+ (setq parse-action (car parse-action))
+ );; when
+
+ ;; current parser
+ (wisi-elisp-parse-2 parse-action token parser-state pendingp gotos)
+
+ new-parser-state))
+
+(defun wisi-elisp-parse-2 (action token parser-state pendingp gotos)
+ "Execute parser ACTION (must not be a conflict).
+Return nil."
+ (cond
+ ((eq action 'accept)
+ (setf (wisi-elisp-parser-state-active parser-state) 'accept))
+
+ ((eq action 'error)
+ (setf (wisi-elisp-parser-state-active parser-state) 'error))
+
+ ((natnump action)
+ ;; Shift token and new state (= action) onto stack
+ (let ((stack (wisi-elisp-parser-state-stack parser-state)); reference
+ (sp (wisi-elisp-parser-state-sp parser-state))); copy
+ (setq sp (+ sp 2))
+ (aset stack (1- sp) token)
+ (aset stack sp action)
+ (setf (wisi-elisp-parser-state-sp parser-state) sp))
+ (setf (wisi-elisp-parser-state-active parser-state) 'shift))
+
+ (t
+ (wisi-elisp-parse-reduce action parser-state pendingp gotos)
+ (setf (wisi-elisp-parser-state-active parser-state) 'reduce))
+ ))
+
+(defun wisi-elisp-parse-first-last (stack i j)
+ "Return a pair (FIRST . LAST), indices for the first and last
+non-empty tokens for a nonterminal; or nil if all tokens are
+empty. STACK is the parser stack. I and J are the indices in
+STACK of the first and last tokens of the nonterminal."
+ (let ((start (car (wisi-tok-region (aref stack i))))
+ (end (cdr (wisi-tok-region (aref stack j)))))
+ (while (and (or (not start) (not end))
+ (/= i j))
+ (cond
+ ((not start)
+ ;; item i is an empty production
+ (setq start (car (wisi-tok-region (aref stack (setq i (+ i 2)))))))
+
+ ((not end)
+ ;; item j is an empty production
+ (setq end (cdr (wisi-tok-region (aref stack (setq j (- j 2)))))))
+
+ (t (setq i j))))
+
+ (when (and start end)
+ (cons i j))
+ ))
+
+(cl-defmethod wisi-parse-find-token ((_parser wisi-elisp-parser) token-symbol)
+ "Find token with TOKEN-SYMBOL on current parser stack, return token struct.
+For use in grammar actions."
+ ;; Called from wisi-parse-exec-action in wisi-parse-reduce
+ (let* ((stack (wisi-elisp-parser-state-stack wisi-elisp-parser-state))
+ (sp (1- (wisi-elisp-parser-state-sp wisi-elisp-parser-state)))
+ (tok (aref stack sp)))
+ (while (and (> sp 0)
+ (not (eq token-symbol (wisi-tok-token tok))))
+ (setq sp (- sp 2))
+ (setq tok (aref stack sp)))
+ (if (= sp 0)
+ (error "token %s not found on parse stack" token-symbol)
+ tok)
+ ))
+
+(cl-defmethod wisi-parse-stack-peek ((_parser wisi-elisp-parser) n)
+ ;; IMPROVEME: store stack in parser
+ (let* ((stack (wisi-elisp-parser-state-stack wisi-elisp-parser-state))
+ (sp (1- (wisi-elisp-parser-state-sp wisi-elisp-parser-state)))
+ (i (- sp (* 2 n))))
+ (when (> i 0)
+ (aref stack i))))
+
+(defun wisi-elisp-parse-reduce (action parser-state pendingp gotos)
+ "Reduce PARSER-STATE.stack, and execute or pend ACTION."
+ (let* ((wisi-elisp-parser-state parser-state);; reference, for
wisi-parse-find-token
+ (stack (wisi-elisp-parser-state-stack parser-state)); reference
+ (sp (wisi-elisp-parser-state-sp parser-state)); copy
+ (token-count (nth 2 action))
+ (nonterm (nth 0 action))
+ (first-last (when (> token-count 0)
+ (wisi-elisp-parse-first-last stack (- sp (* 2 (1-
token-count)) 1) (1- sp))))
+ (nonterm-region (when first-last
+ (cons
+ (car (wisi-tok-region (aref stack (car
first-last))))
+ (cdr (wisi-tok-region (aref stack (cdr
first-last)))))))
+ (post-reduce-state (aref stack (- sp (* 2 token-count))))
+ (new-state (cdr (assoc nonterm (aref gotos post-reduce-state))))
+ (tokens (make-vector token-count nil))
+ line first comment-line comment-end)
+
+ (when (not new-state)
+ (error "no goto for %s %d" nonterm post-reduce-state))
+
+ (dotimes (i token-count) ;; i = 0 .. (1- token-count); last token = 0,
first token = (1- token-count)
+ (let ((tok (aref stack (- sp (* 2 i) 1))))
+ (when (nth 1 action)
+ ;; don't need wisi-tokens for a null user action
+ (aset tokens (- token-count i 1) tok))
+
+ (when (eq wisi--parse-action 'indent)
+ (setq line (or (wisi-tok-line tok) line))
+ (cond
+ ((numberp (wisi-tok-first tok))
+ (setq first (wisi-tok-first tok)))
+
+ ((wisi-tok-first tok)
+ (setq first (wisi-tok-line tok)))
+
+ ((and (not (= i 0))
+ (wisi-tok-comment-line tok))
+ ;; comment lines following last token are not included in nonterm
+ ;; test/ada_mode-nominal.ads Object_Access_Type_5a
+ ;; test/ada_mode-parens.adb
+ (setq first (wisi-tok-comment-line tok)))
+ )
+ (when (and (= i 0)
+ (wisi-tok-comment-line tok))
+ (setq comment-line (wisi-tok-comment-line tok))
+ (setq comment-end (wisi-tok-comment-end tok)))
+ )))
+
+ (setq sp (+ 2 (- sp (* 2 token-count))))
+ (aset stack (1- sp)
+ (make-wisi-tok
+ :token nonterm
+ :region nonterm-region
+ :nonterminal t
+ :line line
+ :first first
+ :comment-line comment-line
+ :comment-end comment-end))
+ (aset stack sp new-state)
+ (setf (wisi-elisp-parser-state-sp parser-state) sp)
+
+ (when (nth 1 action)
+ ;; nothing to do for a null user action
+ (if pendingp
+ (if (wisi-elisp-parser-state-pending parser-state)
+ (setf (wisi-elisp-parser-state-pending parser-state)
+ (append (wisi-elisp-parser-state-pending parser-state)
+ (list (list (nth 1 action) nonterm tokens))))
+ (setf (wisi-elisp-parser-state-pending parser-state)
+ (list (list (nth 1 action) nonterm tokens))))
+
+ ;; Not pending.
+ (wisi-elisp-parse-exec-action (nth 1 action) nonterm tokens)
+ ))
+ ))
+
+;;;; navigate grammar actions
+
+(defun wisi-elisp-parse--set-end (start-mark end-mark)
+ "Set END-MARK on all caches in `wisi-end-caches' in range START-MARK
END-MARK,
+delete from `wisi-end-caches'."
+ (let ((i 0)
+ pos cache)
+ (while (< i (length wisi-end-caches))
+ (setq pos (nth i wisi-end-caches))
+ (setq cache (wisi-get-cache pos))
+
+ (if (and (>= pos start-mark)
+ (< pos end-mark))
+ (progn
+ (setf (wisi-cache-end cache) end-mark)
+ (setq wisi-end-caches (delq pos wisi-end-caches)))
+
+ ;; else not in range
+ (setq i (1+ i)))
+ )))
+
+(defvar wisi-tokens nil
+ ;; Not wisi-elisp-parse--tokens for ease in debugging actions, and
+ ;; to match lots of doc strings.
+ "Array of ‘wisi-tok’ structures for the right hand side of the current
production.
+Let-bound in parser semantic actions.")
+
+(defvar wisi-nterm nil
+ ;; Not wisi-elisp-parse--nterm for ease in debugging actions
+ "The token id for the left hand side of the current production.
+Let-bound in parser semantic actions.")
+
+(defun wisi-statement-action (pairs)
+ ;; Not wisi-elisp-parse--statement-action to match existing grammar files
+ "Cache navigation information in text properties of tokens.
+Intended as a grammar non-terminal action.
+
+PAIRS is a vector of the form [TOKEN-NUMBER CLASS TOKEN-NUMBER
+CLASS ...] where TOKEN-NUMBER is the (1 indexed) token number in
+the production, CLASS is the wisi class of that token. Use in a
+grammar action as:
+ (wisi-statement-action [1 statement-start 7 statement-end])"
+ (when (eq wisi--parse-action 'navigate)
+ (save-excursion
+ (let ((first-item t)
+ first-keyword-mark
+ (override-start nil)
+ (i 0))
+ (while (< i (length pairs))
+ (let* ((number (1- (aref pairs i)))
+ (region (wisi-tok-region (aref wisi-tokens number)))
+ (token (wisi-tok-token (aref wisi-tokens number)))
+ (class (aref pairs (setq i (1+ i))))
+ (mark (when region (copy-marker (car region) t)))
+ cache)
+
+ (setq i (1+ i))
+
+ (unless
+ (cond
+ ((fboundp 'seq-contains) ;; emacs < 27
+ (seq-contains wisi-class-list class))
+ ((fboundp 'seq-contains-p) ;; emacs >= 27
+ (seq-contains-p wisi-class-list class)))
+ (error "%s not in wisi-class-list" class))
+
+ (if region
+ (progn
+ (if (setq cache (wisi-get-cache (car region)))
+ ;; We are processing a previously set non-terminal; ie
simple_statement in
+ ;;
+ ;; statement : label_opt simple_statement
+ ;;
+ ;; override nonterm, class, containing
+ (progn
+ (setf (wisi-cache-class cache) (or override-start
class))
+ (setf (wisi-cache-nonterm cache) wisi-nterm)
+ (setf (wisi-cache-containing cache) first-keyword-mark)
+ (if wisi-end-caches
+ (push (car region) wisi-end-caches)
+ (setq wisi-end-caches (list (car region)))
+ ))
+
+ ;; else create new cache
+ (with-silent-modifications
+ (put-text-property
+ (car region)
+ (1+ (car region))
+ 'wisi-cache
+ (wisi-cache-create
+ :nonterm wisi-nterm
+ :token token
+ :last (- (cdr region) (car region))
+ :class (or override-start class)
+ :containing first-keyword-mark)
+ ))
+ (if wisi-end-caches
+ (push (car region) wisi-end-caches)
+ (setq wisi-end-caches (list (car region)))
+ ))
+
+ (when first-item
+ (setq first-item nil)
+ (when (or override-start
+ (eq class 'statement-start))
+ (setq override-start nil)
+ (setq first-keyword-mark mark)))
+
+ (when (eq class 'statement-end)
+ (wisi-elisp-parse--set-end first-keyword-mark (copy-marker
(car region) t)))
+ )
+
+ ;; region is nil when a production is empty; if the first
+ ;; token is a start, override the class on the next token.
+ (when (and first-item
+ (eq class 'statement-start))
+ (setq override-start class)))
+ ))
+ ))))
+
+(defun wisi-name-action (name)
+ ;; Not wisi-elisp-parse--name-action to simplify grammar files
+ "NAME is a token number; mark that token with the 'wisi-name text property.
+Intended as a grammar action."
+ (when (eq wisi--parse-action 'navigate)
+ (let ((region (wisi-tok-region (aref wisi-tokens (1- name)))))
+ (when region
+ ;; region can be null on an optional or virtual token
+ (with-silent-modifications
+ (put-text-property (car region) (cdr region) 'wisi-name t))
+ ))))
+
+(defun wisi-containing-action (containing-token contained-token)
+ ;; Not wisi-elisp-parse--containing-action to match existing grammar files
+ "Set containing marks in all tokens in CONTAINED-TOKEN
+with null containing mark to marker pointing to CONTAINING-TOKEN.
+If CONTAINING-TOKEN is empty, the next token number is used."
+ (when (eq wisi--parse-action 'navigate)
+ (let* ((containing-tok (aref wisi-tokens (1- containing-token)))
+ (containing-region (wisi-tok-region containing-tok))
+ (contained-tok (aref wisi-tokens (1- contained-token)))
+ (contained-region (wisi-tok-region contained-tok)))
+
+ (unless containing-region
+ (signal 'wisi-parse-error
+ (wisi-error-msg
+ "wisi-containing-action: containing-region '%s' is empty.
grammar error; bad action"
+ (wisi-tok-token containing-tok))))
+
+ (unless (or (not contained-region) ;; contained-token is empty
+ (wisi-get-cache (car containing-region)))
+ (signal 'wisi-parse-error
+ (wisi-error-msg
+ "wisi-containing-action: containing-token '%s' has no cache.
grammar error; missing action"
+ (wisi-token-text (aref wisi-tokens (1- containing-token))))))
+
+ (when contained-region
+ ;; nil when empty production, may not contain any caches
+ (save-excursion
+ (goto-char (cdr contained-region))
+ (let ((cache (wisi-backward-cache))
+ (mark (copy-marker (car containing-region) t)))
+ (while cache
+
+ ;; skip blocks that are already marked
+ (while (and (>= (point) (car contained-region))
+ (markerp (wisi-cache-containing cache)))
+ (goto-char (wisi-cache-containing cache))
+ (setq cache (wisi-get-cache (point))))
+
+ (if (or (and (= (car containing-region) (car contained-region))
+ (<= (point) (car contained-region)))
+ (< (point) (car contained-region)))
+ ;; done
+ (setq cache nil)
+
+ ;; else set mark, loop
+ (setf (wisi-cache-containing cache) mark)
+ (setq cache (wisi-backward-cache)))
+ ))))
+ )))
+
+(defun wisi-elisp-parse--match-token (cache tokens start)
+ "Return t if CACHE has id from TOKENS and is at START or has containing
equal to START.
+point must be at cache token start.
+TOKENS is a vector [number token_id token_id ...].
+number is ignored."
+ (let ((i 1)
+ (done nil)
+ (result nil)
+ token)
+ (when (or (= start (point))
+ (and (wisi-cache-containing cache)
+ (= start (wisi-cache-containing cache))))
+ (while (and (not done)
+ (< i (length tokens)))
+ (setq token (aref tokens i))
+ (if (eq token (wisi-cache-token cache))
+ (setq result t
+ done t)
+ (setq i (1+ i)))
+ ))
+ result))
+
+(defun wisi-motion-action (token-numbers)
+ ;; Not wisi-elisp-parse--motion-action to match existing grammar files
+ "Set prev/next marks in all tokens given by TOKEN-NUMBERS.
+TOKEN-NUMBERS is a vector with each element one of:
+
+number: the token number; mark that token
+
+vector [number token_id]:
+vector [number token_id token_id ...]:
+ mark all tokens in number nonterminal matching token_id with nil prev/next."
+ (when (eq wisi--parse-action 'navigate)
+ (save-excursion
+ (let (prev-keyword-mark
+ prev-cache
+ token
+ start
+ cache
+ mark
+ (i 0))
+ (while (< i (length token-numbers))
+ (let ((token-number (aref token-numbers i))
+ region)
+ (setq i (1+ i))
+ (cond
+ ((numberp token-number)
+ (setq token (aref wisi-tokens (1- token-number)))
+ (setq region (wisi-tok-region token))
+ (when region
+ (unless start (setq start (car region)))
+ (setq cache (wisi-get-cache (car region)))
+ (unless cache (error "no cache on token %d; add to
statement-action" token-number))
+ (setq mark (copy-marker (car region) t))
+
+ (if prev-keyword-mark
+ (progn
+ (setf (wisi-cache-prev cache) prev-keyword-mark)
+ (setf (wisi-cache-next prev-cache) mark)
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache))
+
+ ;; else first token; save as prev
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache))
+ ))
+
+ ((vectorp token-number)
+ ;; token-number may contain 1 or more token_ids
+ ;; the corresponding region may be empty
+ ;; there may not have been a prev keyword
+ (setq region (wisi-tok-region (aref wisi-tokens (1- (aref
token-number 0)))))
+ (when region ;; not an empty token
+ ;; We must search for all targets at the same time, to
+ ;; get the motion order right.
+ (unless start (setq start (car region)))
+ (goto-char (car region))
+ (setq cache (wisi-get-cache (point)))
+ (unless cache (error "no cache at %d; add to statement-action"
(car region)))
+ (while (< (point) (cdr region))
+ (when (wisi-elisp-parse--match-token cache token-number start)
+ (setq mark (copy-marker (point) t))
+
+ (if prev-keyword-mark
+ ;; Don't include this token if prev/next
+ ;; already set by a lower level statement,
+ ;; such as a nested if/then/elsif/end if.
+ (when (and (null (wisi-cache-prev cache))
+ (null (wisi-cache-next prev-cache)))
+ (setf (wisi-cache-prev cache) prev-keyword-mark)
+ (setf (wisi-cache-next prev-cache) mark)
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache))
+
+ ;; else first token; save as prev
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache)))
+
+ (setq cache (wisi-forward-cache))
+ )))
+
+ (t
+ (error "unexpected token-number %s" token-number))
+ )
+
+ ))
+ ))))
+
+;;;; Face grammar actions
+
+(defun wisi-elisp-parse--face-put-cache (region class)
+ "Put a ’wisi-face’ cache with class CLASS on REGION."
+ (when (> wisi-debug 1)
+ (message "face: put cache %s:%s" region class))
+ (with-silent-modifications
+ (put-text-property
+ (car region)
+ (1+ (car region))
+ 'wisi-face
+ (wisi-cache-create
+ :last (- (cdr region) (car region))
+ :class class)
+ )))
+
+(defun wisi-face-mark-action (pairs)
+ ;; Not wisi-elisp-parse--face-mark-action to match existing grammar files
+ "PAIRS is a vector of TOKEN CLASS pairs; mark TOKEN (token number)
+as having face CLASS (prefix or suffix).
+Intended as a grammar action."
+ (when (eq wisi--parse-action 'face)
+ (let ((i 0))
+ (while (< i (length pairs))
+ (let ((region (wisi-tok-region (aref wisi-tokens (1- (aref pairs i)))))
+ (class (aref pairs (setq i (1+ i)))))
+ (setq i (1+ i))
+ (when region
+ ;; region can be null on an optional or virtual token
+ (let ((cache (get-text-property (car region) 'wisi-face)))
+ (if cache
+ ;; previously marked; extend this cache, delete any others
+ (progn
+ (with-silent-modifications
+ (remove-text-properties (+ (car region) (wisi-cache-last
cache)) (cdr region) '(wisi-face nil)))
+ (setf (wisi-cache-class cache) class)
+ (setf (wisi-cache-last cache) (- (cdr region) (car
region))))
+
+ ;; else not previously marked
+ (wisi-elisp-parse--face-put-cache region class)))
+ ))
+ ))))
+
+(defun wisi-face-remove-action (tokens)
+ ;; Not wisi-elisp-parse--face-remove-action to match existing grammar files
+ "Remove face caches and faces in TOKENS.
+Intended as a grammar action.
+
+TOKENS is a vector of token numbers."
+ (when (eq wisi--parse-action 'face)
+ (let ((i 0))
+ (while (< i (length tokens))
+ (let* ((number (1- (aref tokens i)))
+ (region (wisi-tok-region (aref wisi-tokens number)))
+ face-cache)
+
+ (setq i (1+ i))
+
+ (when region
+ (let ((pos (car region)))
+ (while (< pos (cdr region))
+ (when (setq face-cache (get-text-property pos 'wisi-face))
+ (when (> wisi-debug 1)
+ (message "face: remove face %s" (cons pos (+ pos
(wisi-cache-last face-cache)))))
+ (with-silent-modifications
+ (remove-text-properties
+ pos (+ pos (wisi-cache-last face-cache))
+ (list
+ 'wisi-face nil
+ 'font-lock-face nil
+ 'fontified t))))
+ (setq pos (next-single-property-change
+ (+ pos (or (and face-cache
+ (wisi-cache-last face-cache))
+ 0))
+ 'wisi-face nil (cdr region)))
+ )))
+ )))))
+
+(defun wisi-elisp-parse--face-action-1 (face region)
+ "Apply FACE to REGION."
+ (when region
+ (when (> wisi-debug 1)
+ (message "face: add face %s:%s" region face))
+ (with-silent-modifications
+ (add-text-properties
+ (car region) (cdr region)
+ (list
+ 'font-lock-face face
+ 'fontified t)))
+ ))
+
+(defun wisi-face-apply-action (triples)
+ ;; Not wisi-elisp-parse--face-apply-action to match existing grammar files
+ "Set face information in `wisi-face' text properties of tokens.
+Intended as a grammar non-terminal action.
+
+TRIPLES is a vector of the form [TOKEN-NUMBER PREFIX-FACE SUFFIX-FACE ...]
+
+In the first ’wisi-face’ cache in each token region, apply
+PREFIX-FACE to class PREFIX, SUFFIX-FACE to class SUFFIX, or
+SUFFIX-FACE to all of the token region if there is no ’wisi-face’
+cache."
+ (when (eq wisi--parse-action 'face)
+ (let (number prefix-face suffix-face (i 0))
+ (while (< i (length triples))
+ (setq number (aref triples i))
+ (setq prefix-face (aref triples (setq i (1+ i))))
+ (setq suffix-face (aref triples (setq i (1+ i))))
+ (cond
+ ((integerp number)
+ (let* ((token-region (wisi-tok-region (aref wisi-tokens (1- number))))
+ (pos (car token-region))
+ (j 0)
+ (some-cache nil)
+ cache)
+ (when token-region
+ ;; region can be null for an optional or virtual token
+ (while (< j 2)
+ (setq cache (get-text-property pos 'wisi-face))
+ (cond
+ ((and (not some-cache)
+ (null cache))
+ ;; cache is null when applying a face to a token
+ ;; directly, without first calling
+ ;; wisi-face-mark-action. Or when there is a
+ ;; previously applied face in a lower level token,
+ ;; such as a numeric literal.
+ (wisi-elisp-parse--face-action-1 suffix-face token-region))
+
+ ((and cache
+ (eq 'prefix (wisi-cache-class cache)))
+ (setq some-cache t)
+ (wisi-elisp-parse--face-action-1 prefix-face
(wisi-cache-region cache pos)))
+
+ ((and cache
+ (eq 'suffix (wisi-cache-class cache)))
+ (setq some-cache t)
+ (wisi-elisp-parse--face-action-1 suffix-face
(wisi-cache-region cache pos)))
+
+ (t
+ ;; don’t apply a face
+ nil)
+ )
+
+ (setq j (1+ j))
+ (if suffix-face
+ (setq pos (next-single-property-change (+ 2 pos) 'wisi-face
nil (cdr token-region)))
+ (setq j 2))
+ ))))
+
+ (t
+ ;; catch conversion errors from previous grammar syntax
+ (error "wisi-face-apply-action with non-integer token number"))
+ )
+ (setq i (1+ i))
+ ))))
+
+(defun wisi-face-apply-list-action (triples)
+ ;; Not wisi-elisp-parse--face-apply-list-action to match existing grammar
files
+ "Similar to ’wisi-face-apply-action’, but applies faces to all
+tokens with a `wisi-face' cache in the wisi-tokens[token-number]
+region, and does not apply a face if there are no such caches."
+ (when (eq wisi--parse-action 'face)
+ (let (number token-region face-region prefix-face suffix-face cache (i 0)
pos)
+ (while (< i (length triples))
+ (setq number (aref triples i))
+ (setq prefix-face (aref triples (setq i (1+ i))))
+ (setq suffix-face (aref triples (setq i (1+ i))))
+ (cond
+ ((integerp number)
+ (setq token-region (wisi-tok-region (aref wisi-tokens (1- number))))
+ (when token-region
+ ;; region can be null for an optional token
+ (setq pos (car token-region))
+ (while (and pos
+ (< pos (cdr token-region)))
+ (setq cache (get-text-property pos 'wisi-face))
+ (setq face-region (wisi-cache-region cache pos))
+ (cond
+ ((or (null (wisi-cache-class cache))
+ (eq 'prefix (wisi-cache-class cache)))
+ (wisi-elisp-parse--face-action-1 prefix-face face-region))
+ ((eq 'suffix (wisi-cache-class cache))
+ (wisi-elisp-parse--face-action-1 suffix-face face-region))
+
+ (t
+ (error "wisi-face-apply-list-action: face cache class is not
prefix or suffix")))
+
+ (setq pos (next-single-property-change (1+ pos) 'wisi-face nil
(cdr token-region)))
+ )))
+ (t
+ ;; catch conversion errors from previous grammar syntax
+ (error "wisi-face-apply-list-action with non-integer token number"))
+ )
+ (setq i (1+ i))
+ ))))
+
+;;;; indent grammar actions
+
+(defvar wisi-elisp-parse-indent-hanging-function nil
+ "Language-specific implementation of `wisi-hanging', `wisi-hanging%'.
+A function taking args TOK DELTA1 DELTA2 OPTION NO-ACCUMULATE,
+and returning an indent.
+TOK is a `wisi-tok' struct for the token being indented.
+DELTA1, DELTA2 are the indents of the first and following lines
+within the nonterminal. OPTION is non-nil if action is `wisi-hanging%'.
+point is at start of TOK, and may be moved.")
+(make-variable-buffer-local 'wisi-elisp-parse-indent-hanging-function)
+
+(defvar wisi-token-index nil
+ ;; Not wisi-elisp-parse--token-index for backward compatibility
+ "Index of current token in `wisi-tokens'.
+Let-bound in `wisi-indent-action', for grammar actions.")
+
+(defvar wisi-indent-comment nil
+ ;; Not wisi-elisp-parse--indent-comment for backward compatibility
+ "Non-nil if computing indent for comment.
+Let-bound in `wisi-indent-action', for grammar actions.")
+
+(defun wisi-elisp-parse--apply-int (i delta)
+ "Add DELTA (an integer) to the indent at index I."
+ (let ((indent (aref wisi-elisp-parse--indent i))) ;; reference if list
+
+ (cond
+ ((null indent)
+ (aset wisi-elisp-parse--indent i delta))
+
+ ((integerp indent)
+ (aset wisi-elisp-parse--indent i (+ delta indent)))
+
+ ((listp indent)
+ (cond
+ ((eq 'anchor (car indent))
+ (cond
+ ((null (nth 2 indent))
+ (setf (nth 2 indent) delta))
+
+ ((integerp (nth 2 indent))
+ (setf (nth 2 indent) (+ delta (nth 2 indent))))
+
+ ;; else anchored; not affected by this delta
+ ))
+
+ ((eq 'anchored (car indent))
+ ;; not affected by this delta
+ )))
+
+ (t
+ (error "wisi-elisp-parse--apply-int: invalid form : %s" indent))
+ )))
+
+(defun wisi-elisp-parse--apply-anchored (delta i)
+ "Apply DELTA (an anchored indent) to indent I."
+ ;; delta is from wisi-anchored; ('anchored 1 delta no-accumulate)
+ (let ((indent (aref wisi-elisp-parse--indent i))
+ (accumulate (not (nth 3 delta))))
+
+ (when delta
+ (cond
+ ((null indent)
+ (aset wisi-elisp-parse--indent i (seq-take delta 3)))
+
+ ((integerp indent)
+ (when accumulate
+ (let ((temp (seq-take delta 3)))
+ (setf (nth 2 temp) (+ indent (nth 2 temp)))
+ (aset wisi-elisp-parse--indent i temp))))
+
+ ((and (listp indent)
+ (eq 'anchor (car indent))
+ (or (null (nth 2 indent))
+ (integerp (nth 2 indent))))
+ (when (or (null (nth 2 indent))
+ accumulate)
+ (let ((temp (seq-take delta 3)))
+ (cond
+ ((null (nth 2 indent))
+ (setf (nth 2 indent) temp))
+
+ (t
+ (setf (nth 2 temp) (+ (nth 2 indent) (nth 2 temp)))
+ (setf (nth 2 indent) temp))))
+ ))
+ ))))
+
+(defun wisi-elisp-parse--indent-null-p (indent)
+ (or (null indent)
+ (and (eq 'anchor (nth 0 indent))
+ (null (nth 2 indent)))))
+
+(defun wisi-elisp-parse--indent-token-1 (line end delta)
+ "Apply indent DELTA to all lines from LINE (a line number) thru END (a
buffer position)."
+ (let ((i (1- line));; index to wisi-elisp-lexer-line-begin,
wisi-elisp-parse--indent
+ (paren-first (when (and (listp delta)
+ (eq 'hanging (car delta)))
+ (nth 2 delta))))
+
+ (while (<= (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end)
+ (if
+ (and ;; no check for called from wisi--indent-comment;
+ ;; comments within tokens are indented by
+ ;; wisi--indent-token
+ wisi-indent-comment-col-0
+ (= 11 (syntax-class (syntax-after (aref
(wisi-elisp-lexer-line-begin wisi--lexer) i)))))
+ (wisi-elisp-parse--apply-int i 0)
+ (cond
+ ((integerp delta)
+ (wisi-elisp-parse--apply-int i delta))
+
+ ((listp delta)
+ (cond
+ ((eq 'anchored (car delta))
+ (wisi-elisp-parse--apply-anchored delta i))
+
+ ((eq 'hanging (car delta))
+ ;; from wisi-hanging; delta is ('hanging first-line nest delta1
delta2 no-accumulate)
+ ;; delta1, delta2 may be anchored
+ (when (or (not (nth 5 delta))
+ (wisi-elisp-parse--indent-null-p (aref
wisi-elisp-parse--indent i)))
+ (if (= i (1- (nth 1 delta)))
+ ;; apply delta1
+ (let ((delta1 (nth 3 delta)))
+ (cond
+ ((integerp delta1)
+ (wisi-elisp-parse--apply-int i delta1))
+
+ (t ;; anchored
+ (wisi-elisp-parse--apply-anchored delta1 i))
+ ))
+
+ ;; don't apply hanging indent in nested parens.
+ ;; test/ada_mode-parens.adb
+ ;; No_Conditional_Set : constant Ada.Strings.Maps.Character_Set
:=
+ ;; Ada.Strings.Maps."or"
+ ;; (Ada.Strings.Maps.To_Set (' '),
+ (when (= paren-first
+ (nth 0 (save-excursion (syntax-ppss (aref
(wisi-elisp-lexer-line-begin wisi--lexer) i)))))
+ (let ((delta2 (nth 4 delta)))
+ (cond
+ ((integerp delta2)
+ (wisi-elisp-parse--apply-int i delta2))
+
+ (t ;; anchored
+ (wisi-elisp-parse--apply-anchored delta2 i))
+ )))
+ )))
+
+ (t
+ (error "wisi-elisp-parse--indent-token-1: invalid delta: %s" delta))
+ )) ;; listp delta
+
+ (t
+ (error "wisi-elisp-parse--indent-token-1: invalid delta: %s" delta))
+ ))
+ (setq i (1+ i))
+ )))
+
+(defun wisi-elisp-parse--indent-token (tok token-delta)
+ "Add TOKEN-DELTA to all indents in TOK region,"
+ (let ((line (if (wisi-tok-nonterminal tok)
+ (wisi-tok-first tok)
+ (when (wisi-tok-first tok) (wisi-tok-line tok))))
+ (end (cdr (wisi-tok-region tok))))
+ (when (and line end token-delta)
+ (wisi-elisp-parse--indent-token-1 line end token-delta))))
+
+(defun wisi-elisp-parse--indent-comment (tok comment-delta)
+ "Add COMMENT-DELTA to all indents in comment region following TOK."
+ (let ((line (wisi-tok-comment-line tok))
+ (end (wisi-tok-comment-end tok)))
+ (when (and line end comment-delta)
+ (wisi-elisp-parse--indent-token-1 line end comment-delta))))
+
+(defun wisi-elisp-parse--anchored-1 (tok offset &optional no-accumulate)
+ "Return offset of TOK relative to current indentation + OFFSET.
+For use in grammar indent actions."
+ (when (wisi-tok-region tok)
+ ;; region can be nil when token is inserted by error recovery
+ (let ((pos (car (wisi-tok-region tok)))
+ delta)
+
+ (goto-char pos)
+ (setq delta (+ offset (- (current-column) (current-indentation))))
+ (wisi-elisp-parse--anchored-2
+ (wisi-tok-line tok) ;; anchor-line
+ (if wisi-indent-comment
+ (wisi-tok-comment-end (aref wisi-tokens wisi-token-index))
+ (cdr (wisi-tok-region (aref wisi-tokens wisi-token-index))));; end
+ delta
+ no-accumulate)
+ )))
+
+(defun wisi-elisp-parse--max-anchor (begin-line end)
+ (let ((i (1- begin-line))
+ (max-i (length (wisi-elisp-lexer-line-begin wisi--lexer)))
+ (result 0))
+ (while (and (< i max-i)
+ (<= (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end))
+ (let ((indent (aref wisi-elisp-parse--indent i)))
+ (when (and indent (listp indent))
+ (cond
+ ((eq 'anchor (car indent))
+ (setq result (max result (car (nth 1 indent))))
+ (when (and (nth 2 indent) (listp (nth 2 indent)))
+ (setq result (max result (nth 1 (nth 2 indent))))
+ ))
+ (t ;; anchored
+ (setq result (max result (nth 1 indent))))
+ )))
+ (setq i (1+ i)))
+ result
+ ))
+
+(defun wisi-elisp-parse--anchored-2 (anchor-line end delta no-accumulate)
+ "Set ANCHOR-LINE as anchor, increment anchors thru END, return anchored
delta."
+ ;; Typically, we use anchored to indent relative to a token buried in a line:
+ ;;
+ ;; test/ada_mode-parens.adb
+ ;; Local_2 : Integer := (1 + 2 +
+ ;; 3);
+ ;; line starting with '3' is anchored to '('
+ ;;
+ ;; If the anchor is a nonterminal, and the first token in the anchor
+ ;; is also first on a line, we don't need anchored to compute the
+ ;; delta:
+ ;;
+ ;; test/ada_mode-parens.adb
+ ;; Local_5 : Integer :=
+ ;; (1 + 2 +
+ ;; 3);
+ ;; delta for line starting with '3' can just be '3'.
+ ;;
+ ;; However, in some places we need anchored to prevent later
+ ;; deltas from accumulating:
+ ;;
+ ;; test/ada_mode-parens.adb
+ ;; No_Conditional_Set : constant Ada.Strings.Maps.Character_Set :=
+ ;; Ada.Strings.Maps."or"
+ ;; (Ada.Strings.Maps.To_Set (' '),
+ ;;
+ ;; here the function call actual parameter part is indented first
+ ;; by 'name' and later by 'expression'; we use anchored to keep the
+ ;; 'name' delta and ignore the later delta.
+ ;;
+ ;; So we apply anchored whether the anchor token is first or not.
+
+ (let* ((i (1- anchor-line))
+ (indent (aref wisi-elisp-parse--indent i)) ;; reference if list
+ (anchor-id (1+ (wisi-elisp-parse--max-anchor anchor-line end))))
+
+ ;; Set anchor
+ (cond
+ ((or
+ (null indent)
+ (integerp indent))
+ (aset wisi-elisp-parse--indent i (list 'anchor (list anchor-id) indent)))
+
+ ((and (listp indent)
+ (eq 'anchor (car indent)))
+ (push anchor-id (nth 1 indent)))
+
+ ((and (listp indent)
+ (eq 'anchored (car indent)))
+ (aset wisi-elisp-parse--indent i (list 'anchor (list anchor-id)
(copy-sequence indent))))
+
+ (t
+ (error "wisi-anchored-delta: invalid form in indent: %s" indent)))
+
+ (list 'anchored anchor-id delta no-accumulate)
+ ))
+
+(defun wisi-anchored (token-number offset &optional no-accumulate)
+ ;; Not wisi-elisp-parse--anchored to match existing grammar files
+ "Return offset of token TOKEN-NUMBER in `wisi-tokens'.relative to current
indentation + OFFSET.
+For use in grammar indent actions."
+ (wisi-elisp-parse--anchored-1 (aref wisi-tokens (1- token-number)) offset
no-accumulate))
+
+(defun wisi-anchored* (token-number offset)
+ ;; Not wisi-elisp-parse--anchored* to match existing grammar files
+ "If TOKEN-NUMBER token in `wisi-tokens' is first on a line,
+call ’wisi-anchored OFFSET’. Otherwise return 0.
+For use in grammar indent actions."
+ (if (wisi-tok-first (aref wisi-tokens (1- token-number)))
+ (wisi-anchored token-number offset)
+ 0))
+
+(defun wisi-anchored*- (token-number offset)
+ ;; Not wisi-elisp-parse--anchored*- to match existing grammar files
+ "If existing indent is zero, and TOKEN-NUMBER token in `wisi-tokens' is
first on a line,
+call ’wisi-anchored OFFSET’. Otherwise return 0.
+For use in grammar indent actions."
+ (if (wisi-tok-first (aref wisi-tokens (1- token-number)))
+ (wisi-anchored token-number offset t)
+ 0))
+
+(defun wisi-elisp-parse--paren-in-anchor-line (anchor-tok offset)
+ "If there is an opening paren containing ANCHOR-TOK in the same line as
ANCHOR-TOK,
+return OFFSET plus the delta from the line indent to the paren
+position. Otherwise return OFFSET."
+ (let* ((tok-syntax (syntax-ppss (car (wisi-tok-region anchor-tok))))
+ (paren-pos (nth 1 tok-syntax))
+ (anchor-line (wisi-tok-line anchor-tok)))
+
+ (when (and paren-pos ;; in paren
+ (< paren-pos (aref (wisi-elisp-lexer-line-begin wisi--lexer) (1-
anchor-line))))
+ ;; paren not in anchor line
+ (setq paren-pos nil))
+
+ (if paren-pos
+ (progn
+ (goto-char paren-pos)
+ (+ 1 (- (current-column) (current-indentation)) offset))
+ offset)
+ ))
+
+(defun wisi-anchored% (token-number offset &optional no-accumulate)
+ ;; Not wisi-elisp-parse--anchored% to match existing grammar files
+ "Return either an anchor for the current token at OFFSET from an enclosing
paren on
+the line containing TOKEN-NUMBER, or OFFSET.
+For use in grammar indent actions."
+ (let* ((indent-tok (aref wisi-tokens wisi-token-index))
+ ;; indent-tok is a nonterminal; this function makes no sense for
terminals
+ (anchor-tok (aref wisi-tokens (1- token-number))))
+
+ (wisi-elisp-parse--anchored-2
+ (wisi-tok-line anchor-tok)
+
+ (if wisi-indent-comment
+ (wisi-tok-comment-end indent-tok)
+ (cdr (wisi-tok-region indent-tok))) ;; end
+
+ (wisi-elisp-parse--paren-in-anchor-line anchor-tok offset)
+ no-accumulate)
+ ))
+
+(defun wisi-anchored%- (token-number offset)
+ ;; Not wisi-elisp-parse--anchored%- to match existing grammar files
+ "If existing indent is zero, anchor the current token at OFFSET
+from the first token on the line containing TOKEN-NUMBER in `wisi-tokens'.
+Return the delta.
+For use in grammar indent actions."
+ (wisi-anchored% token-number offset t))
+
+(defun wisi-elisp-parse--hanging-1 (delta1 delta2 option no-accumulate)
+ "If OPTION is nil, implement `wisi-hanging'; otherwise `wisi-hanging%'."
+ (let ((tok (aref wisi-tokens wisi-token-index)))
+ ;; tok is a nonterminal; this function makes no sense for terminals
+ ;; syntax-ppss moves point to start of tok
+
+ (cond
+ ((functionp wisi-elisp-parse-indent-hanging-function)
+ (funcall wisi-elisp-parse-indent-hanging-function tok delta1 delta2
option no-accumulate))
+
+ (t
+ (let ((tok-syntax (syntax-ppss (car (wisi-tok-region tok))))
+ (first-tok-first-on-line
+ ;; first token in tok is first on line
+ (and (numberp (wisi-tok-first tok))
+ (= (wisi-tok-line tok) (wisi-tok-first tok)))))
+ (list 'hanging
+ (wisi-tok-line tok) ;; first line of token
+ (nth 0 tok-syntax) ;; paren nest level at tok
+ delta1
+ (if (or (not option) first-tok-first-on-line)
+ delta2
+ delta1)
+ no-accumulate))
+ ))
+ ))
+
+(defun wisi-hanging (delta1 delta2)
+ ;; Not wisi-elisp-parse--hanging to match existing grammar files
+ "Use DETLA1 for first line, DELTA2 for following lines.
+For use in grammar indent actions."
+ (wisi-elisp-parse--hanging-1 delta1 delta2 nil nil))
+
+(defun wisi-hanging% (delta1 delta2)
+ ;; Not wisi-elisp-parse--hanging% to match existing grammar files
+ "If first token is first in line, use DETLA1 for first line, DELTA2 for
following lines.
+Otherwise use DELTA1 for all lines.
+For use in grammar indent actions."
+ (wisi-elisp-parse--hanging-1 delta1 delta2 t nil))
+
+(defun wisi-hanging%- (delta1 delta2)
+ ;; Not wisi-elisp-parse--hanging%- to match existing grammar files
+ "If existing indent is non-zero, do nothing.
+Else if first token is first in line, use DETLA1 for first line,
+DELTA2 for following lines. Otherwise use DELTA1 for all lines.
+For use in grammar indent actions."
+ (wisi-elisp-parse--hanging-1 delta1 delta2 t t))
+
+(defun wisi-elisp-parse--indent-offset (token offset)
+ "Return offset from beginning of first token on line containing TOKEN,
+ to beginning of TOKEN, plus OFFSET."
+ (save-excursion
+ (goto-char (aref (wisi-elisp-lexer-line-begin wisi--lexer) (1-
(wisi-tok-line token))))
+ (back-to-indentation)
+ (+ offset (- (car (wisi-tok-region token)) (point)))
+ ))
+
+(defun wisi-elisp-parse--indent-compute-delta (delta tok)
+ "Return evaluation of DELTA."
+ (cond
+ ((integerp delta)
+ delta)
+
+ ((symbolp delta)
+ (symbol-value delta))
+
+ ((vectorp delta)
+ ;; [token comment]
+ ;; if wisi-indent-comment, we are indenting the comments of the
+ ;; previous token; they should align with the 'token' delta.
+ (wisi-elisp-parse--indent-compute-delta (aref delta 0) tok))
+
+ (t ;; form
+ (cond
+ ((eq 'anchored (car delta))
+ delta)
+
+ (t
+ (save-excursion
+ (goto-char (car (wisi-tok-region tok)))
+ (eval delta)))))
+ ))
+
+(defun wisi-indent-action (deltas)
+ ;; Not wisi-elisp-parse--indent-action to match existing grammar files
+ "Accumulate `wisi--indents' from DELTAS.
+DELTAS is a vector; each element can be:
+- an integer
+- a symbol
+- a lisp form
+- a vector.
+
+The first three are evaluated to give an integer delta. A vector must
+have two elements, giving the code and following comment
+deltas. Otherwise the comment delta is the following delta in
+DELTAS."
+ (when (eq wisi--parse-action 'indent)
+ (dotimes (wisi-token-index (length wisi-tokens))
+ (let* ((tok (aref wisi-tokens wisi-token-index))
+ (token-delta (aref deltas wisi-token-index))
+ (comment-delta
+ (cond
+ ((vectorp token-delta)
+ (aref token-delta 1))
+
+ ((< wisi-token-index (1- (length wisi-tokens)))
+ (aref deltas (1+ wisi-token-index)))
+ )))
+ (when (wisi-tok-region tok)
+ ;; region is null when optional nonterminal is empty
+ (let ((wisi-indent-comment nil))
+ (setq token-delta
+ (when (and token-delta
+ (wisi-tok-first tok))
+ (wisi-elisp-parse--indent-compute-delta token-delta tok)))
+
+ (when token-delta
+ (wisi-elisp-parse--indent-token tok token-delta))
+
+ (setq wisi-indent-comment t)
+ (setq comment-delta
+ (when (and comment-delta
+ (wisi-tok-comment-line tok))
+ (wisi-elisp-parse--indent-compute-delta comment-delta tok)))
+
+ (when comment-delta
+ (wisi-elisp-parse--indent-comment tok comment-delta))
+ )
+ )))))
+
+(defun wisi-indent-action* (n deltas)
+ ;; Not wisi-elisp-parse--indent-action* to match existing grammar files
+ "If any of the first N tokens in `wisi-tokens' is first on a line,
+call `wisi-indent-action' with DELTAS. Otherwise do nothing."
+ (when (eq wisi--parse-action 'indent)
+ (let ((done nil)
+ (i 0)
+ tok)
+ (while (and (not done)
+ (< i n))
+ (setq tok (aref wisi-tokens i))
+ (setq i (1+ i))
+ (when (and (wisi-tok-region tok)
+ (wisi-tok-first tok))
+ (setq done t)
+ (wisi-indent-action deltas))
+ ))))
+
+;;;; non-grammar indent functions
+
+(defconst wisi-elisp-parse--max-anchor-depth 20) ;; IMRPOVEME: can compute in
actions
+
+(defun wisi-elisp-parse--indent-leading-comments ()
+ "Set `wisi-elisp-parse--indent to 0 for comment lines before first token in
buffer.
+Leave point at first token (or eob)."
+ (save-excursion
+ (goto-char (point-min))
+ (forward-comment (point-max))
+ (let ((end (point))
+ (i 0)
+ (max-i (length wisi-elisp-parse--indent)))
+ (while (and (< i max-i)
+ (< (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end))
+ (aset wisi-elisp-parse--indent i 0)
+ (setq i (1+ i)))
+ )))
+
+(defun wisi-elisp-parse--resolve-anchors ()
+ (let ((anchor-indent (make-vector wisi-elisp-parse--max-anchor-depth 0))
+ pos)
+
+ (dotimes (i (length wisi-elisp-parse--indent))
+ (let ((indent (aref wisi-elisp-parse--indent i)))
+
+ (cond
+ ((or (null indent)
+ (integerp indent)))
+
+ ((listp indent)
+ (let ((anchor-ids (nth 1 indent))
+ (indent2 (nth 2 indent)))
+ (cond
+ ((eq 'anchor (car indent))
+ (cond
+ ((null indent2))
+
+ ((integerp indent2)
+ (dotimes (i (length anchor-ids))
+ (aset anchor-indent (nth i anchor-ids) indent2))
+ (setq indent indent2))
+
+ ((listp indent2) ;; 'anchored
+ (setq indent (+ (aref anchor-indent (nth 1 indent2)) (nth 2
indent2)))
+
+ (dotimes (i (length anchor-ids))
+ (aset anchor-indent (nth i anchor-ids) indent)))
+
+ (t
+ (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
+ ));; 'anchor
+
+ ((eq 'anchored (car indent))
+ (setq indent (+ (aref anchor-indent (nth 1 indent)) indent2)))
+
+ (t
+ (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
+ )));; listp indent
+
+ (t
+ (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
+ );; cond indent
+
+ (when (> i 0)
+ (setq pos (aref (wisi-elisp-lexer-line-begin wisi--lexer) i))
+ (with-silent-modifications
+ (put-text-property (1- pos) pos 'wisi-indent indent)))
+ )) ;; dotimes lines
+
+ ))
+
+(provide 'wisi-elisp-parse)
+;;; wisi-elisp-parse.el ends here
diff --git a/wisi-parse-common.el b/wisi-parse-common.el
index bb559a6..895e899 100644
--- a/wisi-parse-common.el
+++ b/wisi-parse-common.el
@@ -61,11 +61,39 @@ for the language-specific parser options."
(cl-defgeneric wisi-parse-expand-region ((parser wisi-parser) begin end)
"Return a cons SEND-BEGIN . SEND-END that is an expansion of
-region BEGIN END that starts at a valid parse start point,
-contains END, and ends at a point the parser can handle
-gracefully."
+region BEGIN END that starts and ends at points the parser can
+handle gracefully."
(cons begin end))
+(defun wisi-search-backward-skip (regexp skip-p)
+ "Search backward for REGEXP. If SKIP-P returns non-nil, search again.
+SKIP-P is a function taking no parameters.
+Return nil if no match found before bob."
+ (let ((maybe-found-p (search-backward-regexp regexp nil t)))
+ (while (and maybe-found-p
+ (funcall skip-p)
+ (setq maybe-found-p (search-backward-regexp regexp nil t))))
+ maybe-found-p))
+
+(defun wisi-search-forward-skip (regexp skip-p)
+ "Search forward for REGEXP. If SKIP-P returns non-nil, search again.
+SKIP-P is a function taking no parameters.
+Return nil if no match found before eob."
+ (let ((maybe-found-p (search-forward-regexp regexp nil t)))
+ (while (and maybe-found-p
+ (funcall skip-p)
+ (setq maybe-found-p (search-forward-regexp regexp nil t))))
+ maybe-found-p))
+
+(defun wisi-show-expanded-region ()
+ "For debugging. Expand currently selected region."
+ (interactive)
+ (let ((region (wisi-parse-expand-region wisi--parser (region-beginning)
(region-end))))
+ (message "pre (%d . %d) post %s" (region-beginning) (region-end) region)
+ (set-mark (car region))
+ (goto-char (cdr region))
+ ))
+
(cl-defgeneric wisi-parse-adjust-indent ((parser wisi-parser) indent _repair)
"Adjust INDENT for REPAIR (a wisi--parse-error-repair struct). Return new
indent."
indent)
@@ -101,7 +129,7 @@ For use in grammar actions.")
containing
;; Marker at the start of the containing statement for this token.
- ;; nil only for first token in buffer
+ ;; nil for outermost containing.
prev ;; marker at previous motion token in statement; nil if none
next ;; marker at next motion token in statement; nil if none
@@ -201,15 +229,6 @@ value from grammar file."
:safe 'integerp)
(make-variable-buffer-local 'wisi-mckenzie-task-count)
-(defcustom wisi-mckenzie-cost-limit nil
- "If integer, sets McKenzie error recovery algorithm cost limit.
-Higher value has more recover power, but takes longer. If nil,
-uses value from grammar file."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-mckenzie-cost-limit)
-
(defcustom wisi-mckenzie-check-limit nil
"If integer, sets McKenzie error recovery algorithm token check limit.
This sets the number of tokens past the error point that must be
@@ -232,11 +251,14 @@ If nil, uses value from grammar file."
:safe 'integerp)
(make-variable-buffer-local 'wisi-mckenzie-enqueue-limit)
-(defvar wisi-parse-max-parallel 15
+(defcustom wisi-parse-max-parallel 15
"Maximum number of parallel parsers during regular parsing.
Parallel parsers are used to resolve redundancy in the grammar.
If a file needs more than this, it's probably an indication that
-the grammar is excessively redundant.")
+the grammar is excessively redundant."
+ :type 'integer
+ :group 'wisi
+ :safe 'integerp)
(defvar wisi-parse-max-stack-size 500
"Maximum parse stack size.
@@ -263,7 +285,6 @@ Normally set from a language-specific option.")
(defconst wisi-class-list
[motion ;; motion-action
- name ;; for which-function
statement-end
statement-override
statement-start
diff --git a/wisi-process-parse.el b/wisi-process-parse.el
index 154b75f..d941781 100644
--- a/wisi-process-parse.el
+++ b/wisi-process-parse.el
@@ -26,22 +26,24 @@
"Options for Wisi package."
:group 'programming)
-(defcustom wisi-process-time-out 1.0
+(defcustom wisi-process-time-out 5.0
"Time out waiting for parser response. An error occurs if there
- is no response from the parser after waiting this amount 5
- times."
+ is no response from the parser after waiting this amount (in
+ seconds)."
:type 'float
:safe 'floatp)
(make-variable-buffer-local 'wisi-process-time-out)
+(defconst wisi-process-parse-protocol-version "3"
+ "Defines data exchanged between this package and the background process.
+Must match emacs_wisi_common_parse.ads Protocol_Version.")
+
(defconst wisi-process-parse-prompt "^;;> "
"Regexp matching executable prompt; indicates previous command is complete.")
(defconst wisi-process-parse-quit-cmd "004quit\n"
"Command to external process telling it to quit.")
-(defvar wisi-process-parse-debug 0)
-
;;;;; sessions
;; The executable builds internal parser structures on startup,
@@ -54,6 +56,7 @@
(cl-defstruct (wisi-process--parser (:include wisi-parser))
(label nil) ;; string uniquely identifying parser
+ language-protocol-version ;; string identifying language-specific params
(exec-file nil) ;; absolute file name of executable
(exec-opts nil) ;; list of process start options for executable
(token-table nil) ;; vector of token symbols, indexed by integer
@@ -65,6 +68,7 @@
(total-wait-time 0.0) ;; total time during last parse spent waiting for
subprocess output.
(response-count 0) ;; responses received from subprocess during last
parse; for profiling.
end-pos ;; last character position parsed
+ language-action-table ;; array of function pointers, each taking an sexp
sent by the process
)
(defvar wisi-process--alist nil
@@ -93,6 +97,24 @@ Otherwise add PARSER to ‘wisi-process--alist’, return it."
(wisi-parse-kill parser)
(setf (wisi-process--parser-exec-file parser) exec-file))))
+(defun wisi-process-parse--check-version (parser)
+ "Verify protocol version reported by process."
+ ;; The process has just started; the first non-comment line in the
+ ;; process buffer contains the process and language protocol versions.
+ (with-current-buffer (wisi-process--parser-buffer parser)
+ (goto-char (point-min))
+ (search-forward-regexp "protocol: process version \\([0-9]+\\) language
version \\([0-9]+\\)")
+ (unless (and (match-string 1)
+ (string-equal (match-string 1)
wisi-process-parse-protocol-version)
+ (match-string 2)
+ (string-equal (match-string 2)
(wisi-process--parser-language-protocol-version parser)))
+ (wisi-parse-kill parser)
+ (error "%s parser process protocol version mismatch: elisp %s %s,
process %s %s"
+ (wisi-process--parser-label parser)
+ wisi-process-parse-protocol-version
(wisi-process--parser-language-protocol-version parser)
+ (match-string 1) (match-string 2)))
+ ))
+
(defun wisi-process-parse--require-process (parser)
"Start the process for PARSER if not already started."
(unless (process-live-p (wisi-process--parser-process parser))
@@ -108,26 +130,17 @@ Otherwise add PARSER to ‘wisi-process--alist’, return it."
(erase-buffer)); delete any previous messages, prompt
(setf (wisi-process--parser-process parser)
- (if (fboundp 'make-process)
- ;; emacs >= 25
- (make-process
- :name process-name
- :buffer (wisi-process--parser-buffer parser)
- :command (append (list (wisi-process--parser-exec-file parser))
- (wisi-process--parser-exec-opts parser)))
- ;; emacs < 25
- (start-process
- process-name
- (wisi-process--parser-buffer parser)
- (wisi-process--parser-exec-file parser)
- (wisi-process--parser-exec-opts parser)
- )))
+ (make-process
+ :name process-name
+ :buffer (wisi-process--parser-buffer parser)
+ :command (append (list (wisi-process--parser-exec-file parser))
+ (wisi-process--parser-exec-opts parser))))
(set-process-query-on-exit-flag (wisi-process--parser-process parser)
nil)
(setf (wisi-process--parser-busy parser) nil)
- ;; IMPROVEME: check protocol and version numbers
(wisi-process-parse--wait parser)
+ (wisi-process-parse--check-version parser)
)))
(defun wisi-process-parse--wait (parser)
@@ -145,16 +158,9 @@ Otherwise add PARSER to ‘wisi-process--alist’, return it."
(not (setq found (re-search-forward
wisi-process-parse-prompt (point-max) t)))))
(setq search-start (point));; don't search same text again
(setq wait-count (1+ wait-count))
- (when (> wisi-process-parse-debug 0)
- (message "wisi-process-parse--wait: %d" wait-count))
(accept-process-output process 0.1))
- (if found
- (when (> wisi-process-parse-debug 0)
- (message "wisi-process-parse--wait: %d" wait-count)
- (when (> wisi-process-parse-debug 2)
- (message "'%s'" (buffer-substring-no-properties (point-min)
(point-max)))))
-
+ (unless found
(wisi-process-parse-show-buffer parser)
(error "%s process died" (wisi-process--parser-exec-file parser)))
)))
@@ -193,17 +199,15 @@ parse region."
wisi-trace-mckenzie
wisi-trace-action
(if wisi-mckenzie-disable 1 0)
- (if wisi-mckenzie-task-count wisi-mckenzie-task-count -1)
- (if wisi-mckenzie-cost-limit wisi-mckenzie-cost-limit -1)
- (if wisi-mckenzie-check-limit wisi-mckenzie-check-limit
-1)
- (if wisi-mckenzie-enqueue-limit
wisi-mckenzie-enqueue-limit -1)
+ (or wisi-mckenzie-task-count -1)
+ (or wisi-mckenzie-check-limit -1)
+ (or wisi-mckenzie-enqueue-limit -1)
+ (or wisi-parse-max-parallel -1)
(- (position-bytes send-end) (position-bytes begin)) ;;
send-end is after last byte
(wisi-parse-format-language-options parser)
))
(msg (format "%03d%s" (length cmd) cmd))
(process (wisi-process--parser-process parser)))
- (when (> wisi-process-parse-debug 0)
- (message msg))
(with-current-buffer (wisi-process--parser-buffer parser)
(erase-buffer))
@@ -221,8 +225,6 @@ complete."
(let* ((cmd (format "noop %d" (1- (position-bytes (point-max)))))
(msg (format "%03d%s" (length cmd) cmd))
(process (wisi-process--parser-process parser)))
- (when (> wisi-process-parse-debug 0)
- (message msg))
(with-current-buffer (wisi-process--parser-buffer parser)
(erase-buffer))
@@ -254,6 +256,13 @@ complete."
)))
))
+(defun wisi-process-parse--Name_Property (parser sexp)
+ ;; sexp is [Name_Property first-pos last-pos]
+ ;; see ‘wisi-process-parse--execute’
+ ;; implements wisi-name-action
+ (with-silent-modifications
+ (put-text-property (aref sexp 1) (1+ (aref sexp 2)) 'wisi-name t)))
+
(defun wisi-process-parse--Face_Property (parser sexp)
;; sexp is [Face_Property first-pos last-pos face-index]
;; see ‘wisi-process-parse--execute’
@@ -366,6 +375,10 @@ complete."
;; see ‘wisi-process-parse--execute’
(setf (wisi-process--parser-end-pos parser) (aref sexp 1)))
+(defun wisi-process-parse--Language (parser sexp)
+ ;; sexp is [Language language-action ...]
+ (funcall (aref (wisi-process--parser-language-action-table parser) (aref
sexp 1)) sexp))
+
(defun wisi-process-parse--execute (parser sexp)
"Execute encoded SEXP sent from external process."
;; sexp is [action arg ...]; an encoded instruction that we need to execute
@@ -379,6 +392,8 @@ complete."
;; length : integer character count
;; class : integer index into wisi-class-list
;;
+ ;; [Name_Property first-pos last-pos]
+ ;;
;; [Face_Property first-pos last-pos face-index]
;; Set a font-lock-face text-property
;; face-index: integer index into parser-elisp-face-table
@@ -418,6 +433,10 @@ complete."
;; Args are token ids; index into parser-token-table. Save the information
;; for later use by ’wisi-repair-error’.
;;
+ ;; [Language ...]
+ ;; Dispatch to a language-specific action, via
+ ;; `wisi-process--parser-language-action-table'.
+ ;;
;;
;; Numeric action codes are given in the case expression below
@@ -430,6 +449,8 @@ complete."
(6 (wisi-process-parse--Check_Error parser sexp))
(7 (wisi-process-parse--Recover parser sexp))
(8 (wisi-process-parse--End parser sexp))
+ (9 (wisi-process-parse--Name_Property parser sexp))
+ (10 (wisi-process-parse--Language parser sexp))
))
;;;;; main
@@ -462,14 +483,14 @@ Send BEGIN thru SEND-END to external parser."
;; wisi-indent-region, we signal an error here.
(if (wisi-process--parser-busy parser)
(progn
- (setf (wisi-parser-parse-errors parser)
+ (setf (wisi-parser-parse-errors parser)
(list
(make-wisi--parse-error
:pos 0
:message (format "%s:%d:%d: parser busy (try
’wisi-kill-parser’)"
(if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "") 1 1))
))
- (error "%s parse abandoned; parser busy" wisi--parse-action)
+ (error "%s parse abandoned; parser busy - use partial parse?"
wisi--parse-action)
)
;; It is not possible for a background elisp function (ie
@@ -487,7 +508,6 @@ Send BEGIN thru SEND-END to external parser."
response-end
(response-count 0)
(sexp-start (point-min))
- (wait-count 0)
(need-more nil) ;; point-max if need more, to check for new input
(done nil)
start-wait-time)
@@ -568,6 +588,9 @@ Send BEGIN thru SEND-END to external parser."
((equal 'parse_error (car response))
;; Parser detected some other error non-fatal error, so
signal it.
+ (push
+ (make-wisi--parse-error :pos 0 :message (cadr
response))
+ (wisi-parser-parse-errors parser))
(signal 'wisi-parse-error (cdr response)))
((and (eq 'error (car response))
@@ -596,12 +619,13 @@ Send BEGIN thru SEND-END to external parser."
(push (make-wisi--parse-error :pos (point) :message
(cadr err)) (wisi-parser-parse-errors parser))
(signal (car err) (cdr err)))
- (error ;; ie from [C:\Windows\system32\KERNEL32.DLL]
+ (error ;; ie from [C:\Windows\system32\KERNEL32.DLL], or
bug in action code above.
(set-buffer response-buffer)
(let ((content (buffer-substring-no-properties
(point-min) (point-max)))
(buf-name (concat (buffer-name) "-save-error")))
(set-buffer (get-buffer-create buf-name))
(insert content)
+ (insert (format "%s" err))
(error "parser failed; error messages in %s"
buf-name)))
))
)
@@ -626,7 +650,6 @@ Send BEGIN thru SEND-END to external parser."
(insert content)
(error "parser failed; error messages in %s" buf-name)))
- (setq wait-count (1+ wait-count))
(setq start-wait-time (float-time))
;; If we specify no time-out here, we get messages about
@@ -646,7 +669,7 @@ Send BEGIN thru SEND-END to external parser."
(- (float-time) start-wait-time)))
(when (and (= (point-max) need-more)
- (> wait-count 5))
+ (> (wisi-process--parser-total-wait-time parser)
wisi-process-time-out))
(error "wisi-process-parse not getting more text (or bad syntax
in process output)"))
(setq need-more nil))
diff --git a/wisi-run-indent-test.el b/wisi-run-indent-test.el
new file mode 100644
index 0000000..ce5b355
--- /dev/null
+++ b/wisi-run-indent-test.el
@@ -0,0 +1,300 @@
+;;; wisi-run-indent-test.el --- utils for automating indentation and casing
tests
+;;
+;; Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+(require 'wisi-tests)
+
+;; user can set these to t in an EMACSCMD
+(defvar skip-cmds nil)
+(defvar skip-reindent-test nil)
+(defvar skip-recase-test nil)
+(defvar skip-write nil)
+
+(defun test-in-comment-p ()
+ (nth 4 (syntax-ppss)))
+
+(defun test-face (token face)
+ "Test if all of TOKEN in next code line has FACE.
+FACE may be a list."
+ (save-excursion
+ (when (test-in-comment-p)
+ (beginning-of-line); forward-comment doesn't move if inside a comment!
+ (forward-comment (point-max)))
+ (condition-case err
+ (search-forward token (line-end-position 5))
+ (error
+ (error "can't find '%s'" token)))
+
+ (save-match-data
+ (wisi-validate-cache (line-beginning-position 0) (line-end-position 5)
nil 'face))
+
+ ;; We don't use face-at-point, because it doesn't respect
+ ;; font-lock-face set by the parser! And we want to check for
+ ;; conflicts between font-lock-keywords and the parser.
+
+ ;; font-lock-keywords sets 'face property, parser sets 'font-lock-face.
+
+ ;; In emacs < 27, if we use (get-text-property (point) 'face), we
+ ;; also get 'font-lock-face, but not vice-versa. So we have to use
+ ;; text-properties-at to check for both.
+ (let* ((token (match-string 0))
+ (props (text-properties-at (match-beginning 0)))
+ key
+ token-face)
+
+ (cond
+ ((plist-get props 'font-lock-face)
+ (setq key 'font-lock-face)
+ (setq token-face (plist-get props 'font-lock-face)))
+
+ ((plist-get props 'face)
+ (setq key 'face)
+ (setq token-face (plist-get props 'face)))
+ )
+
+ (when (and (memq 'font-lock-face props)
+ (memq 'face props))
+ (describe-text-properties (match-beginning 0))
+ (error "mixed font-lock-keyword and parser faces for '%s'" token))
+
+ (unless (not (text-property-not-all 0 (length token) key token-face
token))
+ (error "mixed faces, expecting %s for '%s'" face token))
+
+ (unless (or (and (listp face)
+ (memq token-face face))
+ (eq token-face face))
+ (error "found face %s, expecting %s for '%s'" token-face face token))
+ )))
+
+(defun test-face-1 (search token face)
+ "Move to end of comment, search for SEARCH, call `test-face'."
+ (save-excursion
+ (when (test-in-comment-p)
+ (beginning-of-line); forward-comment doesn't move if inside a comment!
+ (forward-comment (point-max)))
+ (search-forward search)
+ (test-face token face)
+ ))
+
+(defun test-cache-class (token class)
+ "Test if TOKEN in next code line has wisi-cache with class CLASS."
+ (save-excursion
+ (wisi-validate-cache (line-beginning-position 0) (line-end-position 3) nil
'navigate)
+ (beginning-of-line); forward-comment doesn't move if inside a comment!
+ (forward-comment (point-max))
+ (condition-case err
+ (search-forward token (line-end-position 5))
+ (error
+ (error "can't find '%s'" token)))
+
+ (let ((cache (get-text-property (match-beginning 0) 'wisi-cache)))
+
+ (unless cache (error "no cache"))
+ (unless (eq (wisi-cache-class cache) class)
+ (error "expecting class %s, found '%s'" class (wisi-cache-class cache)))
+ )))
+
+(defun test-cache-containing (containing contained)
+ "Test if CONTAINING in next code line has wisi-cache with that contains
CONTAINED."
+ (save-excursion
+ (wisi-validate-cache (line-beginning-position 0) (line-end-position 3) nil
'navigate)
+ (beginning-of-line)
+ (forward-comment (point-max))
+ (let (containing-pos contained-cache)
+ (condition-case err
+ (search-forward containing (line-end-position 5))
+ (error
+ (error "can't find '%s'" containing)))
+ (setq containing-pos (match-beginning 0))
+
+ (condition-case err
+ (search-forward contained (line-end-position 5))
+ (error
+ (error "can't find '%s'" contained)))
+ (setq contained-cache (get-text-property (match-beginning 0)
'wisi-cache))
+
+ (unless contained-cache (error "no cache on %s" contained))
+ (unless (= containing-pos (wisi-cache-containing contained-cache))
+ (error "expecting %d, got %d" containing-pos (wisi-cache-containing
contained-cache)))
+ )))
+
+(defun run-test-here ()
+ "Run an indentation and casing test on the current buffer."
+ (interactive)
+ (setq indent-tabs-mode nil)
+ (setq jit-lock-context-time 0.0);; for test-face
+
+ (let ((error-count 0)
+ (test-buffer (current-buffer))
+ cmd-line
+ last-result last-cmd expected-result)
+ ;; Look for EMACS* comments in the file:
+ ;;
+ ;; EMACSCMD: <form>
+ ;; Executes the lisp form inside a save-excursion, saves the result as
a lisp object.
+ ;;
+ ;; EMACSRESULT: <form>
+ ;; point is moved to end of line, <form> is evaluated inside
+ ;; save-excursion and compared (using `equal') with the result
+ ;; of the previous EMACSCMD, and the test fails if they don't
+ ;; match.
+ ;;
+ ;; EMACS_SKIP_UNLESS: <form>
+ ;; skip entire test if form evals nil
+ ;;
+ ;; EMACSDEBUG: <form>
+ ;; Eval form, display result. Also used for setting breakpoint.
+
+ (goto-char (point-min))
+ (while (and (not skip-cmds)
+ (re-search-forward (concat comment-start "EMACS\\([^:]+\\):")
nil t))
+ (cond
+ ((string= (match-string 1) "CMD")
+ (looking-at ".*$")
+ (save-excursion
+ (setq cmd-line (line-number-at-pos)
+ last-cmd (match-string 0)
+ last-result
+ (condition-case-unless-debug err
+ (eval (car (read-from-string last-cmd)))
+ (error
+ (setq error-count (1+ error-count))
+ (message "%s:%d: command: %s"
+ (buffer-file-name) cmd-line last-cmd)
+ (message "%s:%d: %s: %s"
+ (buffer-file-name)
+ (line-number-at-pos)
+ (car err)
+ (cdr err))))
+ )
+ ;; save-excursion does not preserve mapping of buffer to
+ ;; window, but some tests depend on that. For example,
+ ;; execute-kbd-macro doesn’t work properly if current buffer
+ ;; is not visible..
+ (pop-to-buffer test-buffer)))
+
+ ((string= (match-string 1) "RESULT")
+ (looking-at ".*$")
+ (setq expected-result (save-excursion (end-of-line 1) (eval (car
(read-from-string (match-string 0))))))
+ (unless (equal expected-result last-result)
+ (when debug-on-error (debug))
+ (setq error-count (1+ error-count))
+ (message
+ (concat
+ (format "error: %s:%d:\n" (buffer-file-name) (line-number-at-pos))
+ (format "Result of '%s' does not match.\nGot '%s',\nexpect '%s'"
+ last-cmd
+ last-result
+ expected-result)
+ ))))
+
+ ((string= (match-string 1) "_SKIP_UNLESS")
+ (looking-at ".*$")
+ (unless (eval (car (read-from-string (match-string 0))))
+ (setq skip-cmds t)
+ (setq skip-reindent-test t)
+ (setq skip-recase-test t)
+ ;; We don’t set ‘skip-write’ t here, so the *.diff Make target
succeeds.
+ ))
+
+ ((string= (match-string 1) "DEBUG")
+ (looking-at ".*$")
+ (message "DEBUG: %s:%d %s"
+ (current-buffer)
+ (line-number-at-pos)
+ (save-excursion
+ (eval (car (read-from-string (match-string 0)))))))
+
+ (t
+ (setq error-count (1+ error-count))
+ (error (concat "Unexpected EMACS test command " (match-string 1))))))
+
+ (when (> error-count 0)
+ (error
+ "%s:%d: aborting due to previous errors (%d)"
+ (buffer-file-name) (line-number-at-pos (point)) error-count))
+ )
+
+ (when (not skip-reindent-test)
+ ;; Reindent the buffer
+ (message "indenting")
+
+ ;; first unindent; if the indentation rules do nothing, the test
+ ;; would pass, otherwise! Only unindent by 1 column, so comments
+ ;; not currently in column 0 are still not in column 0, in case
+ ;; the mode supports a special case for comments in column 0.
+ (indent-rigidly (point-min) (point-max) -1)
+
+ ;; indent-region uses save-excursion, so we can't goto an error location
+ (indent-region (point-min) (point-max))
+
+ ;; Cleanup the buffer; indenting often leaves trailing whitespace;
+ ;; files must be saved without any.
+ (delete-trailing-whitespace)
+ )
+ )
+
+(defun run-test (file-name)
+ "Run an indentation and casing test on FILE-NAME."
+ (interactive "f")
+ ;; we'd like to run emacs from a makefile as:
+ ;;
+ ;; emacs -Q --batch -l runtest.el -f run-test-here <filename>
+ ;;
+ ;; However, the function specified with -f is run _before_
+ ;; <filename> is visited. So we try this instead:
+ ;;
+ ;; emacs -Q --batch -l runtest.el --eval '(run-test "<filename>")'
+ ;;
+ ;; And then we discover that processes spawned with start-process
+ ;; don't run when emacs is in --batch mode. So we try this:
+ ;;
+ ;; emacs -Q -l runtest.el --eval '(progn (run-test
"<filename>")(kill-emacs))'
+ ;;
+ ;; Then we have problems with font lock defaulting to jit-lock; that
+ ;; screws up font-lock tests because the test runs before jit-lock
+ ;; does. This forces default font-lock, which fontifies the whole
+ ;; buffer when (font-lock-fontify-buffer) is called, which tests
+ ;; that rely on font-lock do explicitly.
+ (setq font-lock-support-mode nil)
+
+ (let ((dir default-directory))
+ (find-file file-name) ;; sets default-directory
+
+ (when (eq major-mode 'fundamental-mode)
+ ;; Running a grammar in test/wisi
+ (add-to-list 'load-path (expand-file-name "."))
+ (wisi-tests-setup (file-name-sans-extension (file-name-nondirectory
file-name))))
+
+ (run-test-here)
+
+ (unless skip-write
+ ;; Write the result file; makefile will diff.
+ (when skip-reindent-test
+ ;; user sets skip-reindent-test when testing interactive editing
+ ;; commands, so the diff would fail. Revert to the original file,
+ ;; save a copy of that.
+ (revert-buffer t t))
+
+ (delete-trailing-whitespace)
+ (write-file (concat dir (file-name-nondirectory file-name) ".tmp")) )
+ )
+ )
+
+(provide 'wisi-run-indent-test)
+;; end of file
diff --git a/wisi-tests.el b/wisi-tests.el
new file mode 100644
index 0000000..d1468ef
--- /dev/null
+++ b/wisi-tests.el
@@ -0,0 +1,146 @@
+;;; wisi-tests.el --- Common utils for wisi tests -*- lexical-binding:t -*-
+;;
+;; Copyright (C) 2012 - 2019 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
+;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;
+
+(require 'cl-lib)
+(require 'wisi)
+
+(defvar wisi-test-parser 'elisp
+ "Set to ’process to test external process parser.")
+
+(defvar test-syntax-table
+ (let ((table (make-syntax-table)))
+ ;; make-syntax-table sets all alphanumeric to w, etc; so we only
+ ;; have to add test-specific things.
+
+ ;; operator symbols
+ (modify-syntax-entry ?& "." table)
+ (modify-syntax-entry ?* "." table)
+ (modify-syntax-entry ?+ "." table)
+ (modify-syntax-entry ?- "." table)
+ (modify-syntax-entry ?/ "." table)
+ (modify-syntax-entry ?< "." table)
+ (modify-syntax-entry ?= "." table)
+ (modify-syntax-entry ?> "." table)
+ (modify-syntax-entry ?| "." table)
+
+ ;; \f and \n end a comment - see test-syntax-propertize for comment start
+ (modify-syntax-entry ?\f "> " table)
+ (modify-syntax-entry ?\n "> " table)
+ table
+ ))
+
+(defun test-syntax-propertize (start end)
+ "Assign `syntax-table' properties in accessible part of buffer."
+ ;; (info "(elisp)Syntax Properties")
+ (let ((modified (buffer-modified-p))
+ (buffer-undo-list t)
+ (inhibit-read-only t)
+ (inhibit-point-motion-hooks t)
+ (inhibit-modification-hooks t))
+ (goto-char start)
+ (while (re-search-forward
+ "\\(--\\)"; 1: comment start
+ end t)
+ ;; The help for syntax-propertize-extend-region-functions
+ ;; implies that 'start end' will always include whole lines, in
+ ;; which case we don't need
+ ;; syntax-propertize-extend-region-functions
+ (cond
+ ((match-beginning 1)
+ (put-text-property
+ (match-beginning 1) (match-end 1) 'syntax-table '(11 . nil)))
+ ))
+ (unless modified
+ (restore-buffer-modified-p nil))))
+
+(defun wisi-tests-setup (grammar-name)
+ ;; grammar-elisp file must be on load-path
+ ;; use Ada style comments in source
+ (set-syntax-table test-syntax-table)
+ (set (make-local-variable 'syntax-propertize-function)
'test-syntax-propertize)
+ (syntax-ppss-flush-cache (point-min));; force re-evaluate with hook.
+
+ (cl-ecase wisi-test-parser
+ (elisp
+ (require 'wisi-elisp-parse)
+ (let* ((grammar-file-root (concat grammar-name "-lalr-elisp"))
+ (grammar-file-name (concat grammar-file-root ".el"))
+ (grammar-file-abs (locate-file grammar-file-name load-path)))
+ (unless grammar-file-abs
+ (error "can’t find ’%s’ on ’%s’" grammar-file-name load-path))
+ (require (intern grammar-file-root)))
+
+ (wisi-setup
+ :indent-calculate nil
+ :post-indent-fail nil
+ :parser (wisi-make-elisp-parser
+ (symbol-value (intern-soft (concat grammar-name
"-lalr-elisp-parse-table")))
+ `wisi-forward-token)
+ :lexer (wisi-make-elisp-lexer
+ :token-table-raw (symbol-value (intern-soft (concat grammar-name
"-lalr-elisp-token-table-raw")))
+ :keyword-table-raw (symbol-value (intern-soft (concat
grammar-name "-lalr-elisp-keyword-table-raw")))
+ :string-quote-escape-doubled nil
+ :string-quote-escape nil)))
+
+ (process
+ (require 'wisi-process-parse)
+ (require (intern (concat grammar-name "-process"))) ;; generated by
wisi-generate
+ (require (intern grammar-name)) ;; declares parser cl-defstruct
+ (add-to-list 'exec-path default-directory)
+ (wisi-setup
+ :indent-calculate nil
+ :post-indent-fail nil
+ :parser
+ (wisi-process-parse-get
+ (funcall
+ (intern-soft (concat "make-" grammar-name "-wisi-parser"))
+ :label grammar-name
+ :exec-file (concat grammar-name "_wisi_parse.exe")
+ :face-table (symbol-value (intern-soft (concat grammar-name
"-process-face-table")))
+ :token-table (symbol-value (intern-soft (concat grammar-name
"-process-token-table")))
+ ))
+ :lexer (wisi-make-elisp-lexer
+ :token-table-raw (symbol-value (intern-soft (concat grammar-name
"-lalr-elisp-token-table-raw")))
+ :keyword-table-raw (symbol-value (intern-soft (concat
grammar-name "-lalr-elisp-keyword-table-raw")))
+ :string-quote-escape-doubled nil
+ :string-quote-escape nil))
+ (setq wisi-mckenzie-disable nil)
+ )
+ )
+
+ ;; Not clear why this is not being done automatically
+ (syntax-propertize (point-max))
+ )
+
+;;; Initialization
+
+;; Default includes mtn, among others, which is broken in Emacs 22.2
+(setq vc-handled-backends '(CVS))
+
+(setq eval-expression-debug-on-error nil)
+
+;; ’package-initialize’ is not here; it must be run as part of one of the
+;; -l or --eval command line options
+
+(provide 'wisi-tests)
+;; end of file
diff --git a/wisi.adb b/wisi.adb
index 4031df0..b65bbee 100644
--- a/wisi.adb
+++ b/wisi.adb
@@ -17,27 +17,31 @@
pragma License (Modified_GPL);
+with Ada.Exceptions;
with Ada.Strings.Bounded;
with Ada.Text_IO;
+with SAL;
with WisiToken.Semantic_Checks;
package body Wisi is
use WisiToken;
- Navigate_Cache_Code : constant String := "1 ";
- Face_Property_Code : constant String := "2 ";
- Indent_Code : constant String := "3 ";
- Lexer_Error_Code : constant String := "4";
- Parser_Error_Code : constant String := "5";
- Check_Error_Code : constant String := "6";
- Recover_Code : constant String := "7 ";
- End_Code : constant String := "8";
+ Navigate_Cache_Code : constant String := "1";
+ Face_Property_Code : constant String := "2";
+ Indent_Code : constant String := "3";
+ Lexer_Error_Code : constant String := "4";
+ Parser_Error_Code : constant String := "5";
+ Check_Error_Code : constant String := "6";
+ Recover_Code : constant String := "7 ";
+ End_Code : constant String := "8";
+ Name_Property_Code : constant String := "9";
+ Language_Action_Code : constant String := "10 ";
Chars_Per_Int : constant Integer := Integer'Width;
----------
-- body subprogram specs (as needed), alphabetical
- function Indent_Zero_P (Indent : in Indent_Type) return Boolean;
+ function Indent_Nil_P (Indent : in Indent_Type) return Boolean;
function Max_Anchor_ID
(Data : in out Parse_Data_Type;
@@ -79,42 +83,53 @@ package body Wisi is
when Int =>
return "(" & Indent_Label'Image (Indent.Label) & Integer'Image
(Indent.Int_Indent) & ")";
- when Anchor =>
- return "(" & Indent_Label'Image (Indent.Label) & Image
(Indent.Anchor_IDs) & ", " & Integer'Image
- (Indent.Anchor_Indent) & ")";
+ when Anchor_Nil =>
+ return "(" & Indent_Label'Image (Indent.Label) & ", " & Image
(Indent.Anchor_Nil_IDs) & ", nil)";
+
+ when Anchor_Int =>
+ return "(" & Indent_Label'Image (Indent.Label) & ", " & Image
(Indent.Anchor_Int_IDs) & ", " & Integer'Image
+ (Indent.Anchor_Int_Indent) & ")";
when Anchored =>
- return "(" & Indent_Label'Image (Indent.Label) & Integer'Image
(Indent.Anchored_ID) & ", " & Integer'Image
- (Indent.Anchored_Delta) & ")";
+ return "(" & Indent_Label'Image (Indent.Label) & ", " & Integer'Image
(Indent.Anchored_ID) & ", " &
+ Integer'Image (Indent.Anchored_Delta) & ")";
when Anchor_Anchored =>
- return "(" & Indent_Label'Image (Indent.Label) & Image
(Indent.Anchor_Anchored_IDs) & Integer'Image
+ return "(" & Indent_Label'Image (Indent.Label) & ", " & Image
(Indent.Anchor_Anchored_IDs) & Integer'Image
(Indent.Anchor_Anchored_ID) & ", " & Integer'Image
(Indent.Anchor_Anchored_Delta) & ")";
end case;
end Image;
procedure Indent_Apply_Anchored
- (Delta_Indent : in Anchored_Delta;
+ (Delta_Indent : in Simple_Delta_Type;
Indent : in out Indent_Type)
+ with Pre => Delta_Indent.Label = Anchored
is begin
- -- [2] wisi-elisp-parse--apply-anchored
+ -- [2] wisi-elisp-parse--apply-anchored; add Delta_Indent to Indent
case Indent.Label is
when Not_Set =>
Indent := (Anchored, Delta_Indent.Anchored_ID,
Delta_Indent.Anchored_Delta);
when Int =>
- if Indent.Int_Indent = 0 or Delta_Indent.Anchored_Accumulate then
+ if Delta_Indent.Anchored_Accumulate then
Indent := (Anchored, Delta_Indent.Anchored_ID, Indent.Int_Indent +
Delta_Indent.Anchored_Delta);
end if;
- when Anchor =>
- if Delta_Indent.Anchored_Accumulate or Indent.Anchor_Indent = 0 then
+ when Anchor_Nil =>
+ Indent :=
+ (Anchor_Anchored,
+ Indent.Anchor_Nil_IDs,
+ Delta_Indent.Anchored_ID,
+ Delta_Indent.Anchored_Delta);
+
+ when Anchor_Int =>
+ if Delta_Indent.Anchored_Accumulate then
Indent :=
(Anchor_Anchored,
- Indent.Anchor_IDs,
+ Indent.Anchor_Int_IDs,
Delta_Indent.Anchored_ID,
- Delta_Indent.Anchored_Delta + Indent.Anchor_Indent);
+ Delta_Indent.Anchored_Delta + Indent.Anchor_Int_Indent);
end if;
when Anchored | Anchor_Anchored =>
@@ -125,7 +140,7 @@ package body Wisi is
procedure Indent_Apply_Int (Indent : in out Indent_Type; Offset : in
Integer)
is begin
- -- [2] wisi-elisp-parse--apply-int
+ -- [2] wisi-elisp-parse--apply-int; add an Int indent to Indent
case Indent.Label is
when Not_Set =>
Indent := (Int, Offset);
@@ -133,8 +148,14 @@ package body Wisi is
when Int =>
Indent.Int_Indent := Indent.Int_Indent + Offset;
- when Anchor =>
- Indent.Anchor_Indent := Indent.Anchor_Indent + Offset;
+ when Anchor_Nil =>
+ Indent :=
+ (Label => Anchor_Int,
+ Anchor_Int_IDs => Indent.Anchor_Nil_IDs,
+ Anchor_Int_Indent => Offset);
+
+ when Anchor_Int =>
+ Indent.Anchor_Int_Indent := Indent.Anchor_Int_Indent + Offset;
when Anchored | Anchor_Anchored =>
null;
@@ -152,6 +173,9 @@ package body Wisi is
case Delta_Indent.Label is
when Simple =>
case Delta_Indent.Simple_Delta.Label is
+ when None =>
+ null;
+
when Int =>
Indent_Apply_Int (Indent, Delta_Indent.Simple_Delta.Int_Delta);
@@ -160,10 +184,12 @@ package body Wisi is
end case;
when Hanging =>
- if Delta_Indent.Hanging_Accumulate or Indent_Zero_P (Data.Indents
(Line)) then
+ if Delta_Indent.Hanging_Accumulate or Indent_Nil_P (Data.Indents
(Line)) then
if Line = Delta_Indent.Hanging_First_Line then
-- Apply delta_1
case Delta_Indent.Hanging_Delta_1.Label is
+ when None =>
+ null;
when Int =>
Indent_Apply_Int (Indent,
Delta_Indent.Hanging_Delta_1.Int_Delta);
when Anchored =>
@@ -172,6 +198,8 @@ package body Wisi is
else
if Delta_Indent.Hanging_Paren_State = Data.Line_Paren_State
(Line) then
case Delta_Indent.Hanging_Delta_2.Label is
+ when None =>
+ null;
when Int =>
Indent_Apply_Int (Indent,
Delta_Indent.Hanging_Delta_2.Int_Delta);
when Anchored =>
@@ -181,29 +209,18 @@ package body Wisi is
end if;
end if;
end case;
+
+ if Trace_Action > Extra then
+ Ada.Text_IO.Put_Line (";; indent_line: " & Line_Number_Type'Image
(Line) & " => " & Image (Indent));
+ end if;
+
Data.Indents.Replace_Element (Line, Indent);
end Indent_Line;
- function Indent_Zero_P (Indent : in Indent_Type) return Boolean
+ function Indent_Nil_P (Indent : in Indent_Type) return Boolean
is begin
- -- wisi-elisp-parse--indent-zero-p
- case Indent.Label is
- when Not_Set =>
- return True;
-
- when Int =>
- return Indent.Int_Indent = 0;
-
- when Anchor =>
- return Indent.Anchor_Indent = 0;
-
- when Anchored =>
- return Indent.Anchored_Delta = 0;
-
- when Anchor_Anchored =>
- return Indent.Anchor_Anchored_Delta = 0;
- end case;
- end Indent_Zero_P;
+ return Indent.Label in Not_Set | Anchor_Nil;
+ end Indent_Nil_P;
function Max_Anchor_ID
(Data : in out Parse_Data_Type;
@@ -220,8 +237,10 @@ package body Wisi is
case Indent.Label is
when Not_Set | Int =>
null;
- when Anchor =>
- Result := Integer'Max (Result, Indent.Anchor_IDs
(Indent.Anchor_IDs.First_Index));
+ when Anchor_Nil =>
+ Result := Integer'Max (Result, Indent.Anchor_Nil_IDs
(Indent.Anchor_Nil_IDs.First_Index));
+ when Anchor_Int =>
+ Result := Integer'Max (Result, Indent.Anchor_Int_IDs
(Indent.Anchor_Int_IDs.First_Index));
when Anchored =>
Result := Integer'Max (Result, Indent.Anchored_ID);
when Anchor_Anchored =>
@@ -238,8 +257,8 @@ package body Wisi is
Offset : in Integer)
return Integer
is
- Left_Paren_ID : Token_ID renames Data.Descriptor.Left_Paren_ID;
- Right_Paren_ID : Token_ID renames Data.Descriptor.Right_Paren_ID;
+ Left_Paren_ID : Token_ID renames Data.Left_Paren_ID;
+ Right_Paren_ID : Token_ID renames Data.Right_Paren_ID;
I : Base_Token_Index := Anchor_Token.First_Terminals_Index;
Paren_Count : Integer := 0;
@@ -308,6 +327,12 @@ package body Wisi is
Ada.Text_IO.Put_Line (To_String (Line));
end Put;
+ procedure Put (Cache : in WisiToken.Buffer_Region)
+ is begin
+ Ada.Text_IO.Put_Line
+ ("[" & Name_Property_Code & Buffer_Pos'Image (Cache.First) &
Buffer_Pos'Image (Cache.Last) & "]");
+ end Put;
+
procedure Put (Cache : in Face_Cache_Type)
is
package Bounded is new Ada.Strings.Bounded.Generic_Bounded_Length (Max
=> 2 + 4 * Chars_Per_Int);
@@ -341,25 +366,26 @@ package body Wisi is
Ind : constant Integer := Integer'Max (0, Item.Int_Indent);
begin
Ada.Text_IO.Put_Line
- ('[' & Indent_Code & Trimmed_Image (Integer (Line_Number)) &
Integer'Image (Ind) & ']');
+ ('[' & Indent_Code & Line_Number_Type'Image (Line_Number) &
Integer'Image (Ind) & ']');
end;
- when Anchor | Anchored | Anchor_Anchored =>
+ when Anchor_Nil | Anchor_Int | Anchored | Anchor_Anchored =>
raise SAL.Programmer_Error with "Indent item has non-int label: " &
Indent_Label'Image (Item.Label);
end case;
end Put;
procedure Put
- (Item : in Parse.LR.Configuration;
- Terminals : in Augmented_Token_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
+ (Item : in Parse.LR.Configuration;
+ Terminals : in Augmented_Token_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Embedded_Quote_Escape_Doubled : in Boolean)
is
use Ada.Containers;
use Ada.Strings.Unbounded;
use Parse.LR;
Line : Unbounded_String := To_Unbounded_String ("[");
- Last_Op : Config_Op := (Fast_Forward, Token_Index'Last);
+ Last_Op : Config_Op := (Fast_Forward, WisiToken.Token_Index'Last);
begin
if Trace_Action > Detail then
@@ -391,19 +417,19 @@ package body Wisi is
when Insert =>
if Last_Op.Op = Fast_Forward then
Append (Line, "[");
- Append (Line, Buffer_Pos'Image (Terminals
(Op.Token_Index).Char_Region.First));
+ Append (Line, Buffer_Pos'Image (Terminals
(Op.Ins_Token_Index).Char_Region.First));
Append (Line, "[");
elsif Last_Op.Op = Delete then
Append (Line, "]][");
- Append (Line, Buffer_Pos'Image (Terminals
(Op.Token_Index).Char_Region.First));
+ Append (Line, Buffer_Pos'Image (Terminals
(Op.Ins_Token_Index).Char_Region.First));
Append (Line, "[");
else
-- Last_Op.Op = Insert
null;
end if;
- Append (Line, Token_ID'Image (Op.ID));
+ Append (Line, Token_ID'Image (Op.Ins_ID));
Last_Op := Op;
@@ -413,20 +439,20 @@ package body Wisi is
begin
if Last_Op.Op = Fast_Forward then
Append (Line, "[");
- Append (Line, Buffer_Pos'Image (Terminals
(Op.Token_Index).Char_Region.First));
+ Append (Line, Buffer_Pos'Image (Terminals
(Op.Del_Token_Index).Char_Region.First));
Append (Line, "[][");
elsif Last_Op.Op = Insert then
Append (Line, "][");
elsif Last_Op.Op = Delete then
- if Descriptor.Embedded_Quote_Escape_Doubled and then
- ((Last_Op.ID = Descriptor.String_1_ID and Op.ID =
Descriptor.String_1_ID) or
- (Last_Op.ID = Descriptor.String_2_ID and Op.ID =
Descriptor.String_2_ID))
+ if Embedded_Quote_Escape_Doubled and then
+ ((Last_Op.Del_ID = Descriptor.String_1_ID and
Op.Del_ID = Descriptor.String_1_ID) or
+ (Last_Op.Del_ID = Descriptor.String_2_ID and
Op.Del_ID = Descriptor.String_2_ID))
then
declare
- Tok_1 : Augmented_Token renames Terminals
(Last_Op.Token_Index);
- Tok_2 : Augmented_Token renames Terminals
(Op.Token_Index);
+ Tok_1 : Augmented_Token renames Terminals
(Last_Op.Del_Token_Index);
+ Tok_2 : Augmented_Token renames Terminals
(Op.Del_Token_Index);
begin
if Tok_1.Char_Region.Last + 1 =
Tok_2.Char_Region.First then
-- Buffer text was '"""', lexer repair
changed it to '""""'. The
@@ -441,7 +467,7 @@ package body Wisi is
end if;
if not Skip then
- Append (Line, Token_ID'Image (Op.ID));
+ Append (Line, Token_ID'Image (Op.Del_ID));
end if;
end;
Last_Op := Op;
@@ -474,8 +500,9 @@ package body Wisi is
Ada.Text_IO.New_Line;
Ada.Text_IO.Put_Line (";; Begin_Indent: " & Integer'Image
(Data.Begin_Indent));
for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop
- Ada.Text_IO.Put_Line (Line_Number_Type'Image (I) & ", " & Image
(Data.Indents (I)));
+ Ada.Text_IO.Put_Line (";; " & Line_Number_Type'Image (I) & ", " &
Image (Data.Indents (I)));
end loop;
+ Ada.Text_IO.Put_Line (";; resolve anchors");
end if;
for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop
@@ -490,11 +517,17 @@ package body Wisi is
when Int =>
Data.Indents.Replace_Element (I, (Int, Indent.Int_Indent +
Begin_Indent));
- when Anchor =>
- for I of Indent.Anchor_IDs loop
- Anchor_Indent (I) := Indent.Anchor_Indent + Begin_Indent;
+ when Anchor_Nil =>
+ for I of Indent.Anchor_Nil_IDs loop
+ Anchor_Indent (I) := Begin_Indent;
end loop;
- Data.Indents.Replace_Element (I, (Int, Indent.Anchor_Indent +
Begin_Indent));
+ Data.Indents.Replace_Element (I, (Int, Begin_Indent));
+
+ when Anchor_Int =>
+ for I of Indent.Anchor_Int_IDs loop
+ Anchor_Indent (I) := Indent.Anchor_Int_Indent + Begin_Indent;
+ end loop;
+ Data.Indents.Replace_Element (I, (Int, Indent.Anchor_Int_Indent
+ Begin_Indent));
when Anchored =>
Data.Indents.Replace_Element
@@ -589,6 +622,10 @@ package body Wisi is
end case;
Data.Reset;
+ exception
+ when E : others =>
+ raise SAL.Programmer_Error with "wisi.initialize: " &
Ada.Exceptions.Exception_Name (E) & ": " &
+ Ada.Exceptions.Exception_Message (E);
end Initialize;
overriding procedure Reset (Data : in out Parse_Data_Type)
@@ -607,6 +644,9 @@ package body Wisi is
Data.Navigate_Caches.Initialize;
Data.End_Positions.Clear;
+ Data.Name_Caches.Finalize;
+ Data.Name_Caches.Initialize;
+
Data.Face_Caches.Finalize;
Data.Face_Caches.Initialize;
@@ -642,16 +682,16 @@ package body Wisi is
then
-- Previous token contains multiple lines; ie %code in
wisitoken_grammar.wy
declare
- First_Unset_Line : Line_Number_Type;
+ First_Set_Line : Line_Number_Type;
begin
for Line in reverse Data.Line_Begin_Pos.First_Index ..
Token.Line - 1 loop
if Data.Line_Begin_Pos (Line) /= Invalid_Buffer_Pos then
- First_Unset_Line := Line;
+ First_Set_Line := Line;
exit;
end if;
end loop;
- for Line in First_Unset_Line .. Token.Line - 1 loop
- Data.Line_Begin_Pos (Line) := Data.Line_Begin_Pos
(First_Unset_Line); -- good enough
+ for Line in First_Set_Line + 1 .. Token.Line - 1 loop
+ Data.Line_Begin_Pos (Line) := Data.Line_Begin_Pos
(First_Set_Line); -- good enough
end loop;
end;
end if;
@@ -676,7 +716,10 @@ package body Wisi is
Containing_Token.Non_Grammar
(Containing_Token.Non_Grammar.Last_Index).ID =
Data.Descriptor.New_Line_ID);
begin
- if Lexer.First and (Token.ID = Data.Descriptor.Comment_ID or
Trailing_Blank) then
+ if Lexer.First and
+ (Token.ID in Data.First_Comment_ID .. Data.Last_Comment_ID or
+ Trailing_Blank)
+ then
if Containing_Token.First_Trailing_Comment_Line =
Invalid_Line_Number then
Containing_Token.First_Trailing_Comment_Line :=
Token.Line;
end if;
@@ -707,10 +750,10 @@ package body Wisi is
Last_Trailing_Comment_Line => Invalid_Line_Number,
Non_Grammar => <>);
begin
- if Token.ID = Data.Descriptor.Left_Paren_ID then
+ if Token.ID = Data.Left_Paren_ID then
Data.Current_Paren_State := Data.Current_Paren_State + 1;
- elsif Token.ID = Data.Descriptor.Right_Paren_ID then
+ elsif Token.ID = Data.Right_Paren_ID then
Data.Current_Paren_State := Data.Current_Paren_State - 1;
end if;
@@ -899,34 +942,67 @@ package body Wisi is
Tokens : in Syntax_Trees.Valid_Node_Index_Array;
Params : in Statement_Param_Array)
is
- First_Item : Boolean := True;
- Override_Start_Set : Boolean := False;
- Override_Start : Navigate_Class_Type;
+ First_Item : Boolean := True;
+ Start_Set : Boolean := False;
+ Override_Start_Set : Boolean := False;
Containing_Pos : Nil_Buffer_Pos := Nil; -- wisi first-keyword-pos
begin
for Pair of Params loop
- if Tree.Byte_Region (Tokens (Pair.Index)) /= Null_Buffer_Region then
+ if not (Pair.Index in Tokens'Range) then
declare
- Token : constant Aug_Token_Ref := Get_Aug_Token (Data,
Tree, Tokens (Pair.Index));
- Cursor : Navigate_Cache_Trees.Cursor :=
Navigate_Cache_Trees.Find
- (Data.Navigate_Caches.Iterate, Token.Char_Region.First,
+ Nonterm_Tok : constant Aug_Token_Ref := Get_Aug_Token (Data,
Tree, Nonterm);
+ begin
+ raise Fatal_Error with Error_Message
+ (File_Name => -Data.Source_File_Name,
+ Line => Nonterm_Tok.Line,
+ Column => Nonterm_Tok.Column,
+ Message => "wisi-statement-action: " & Trimmed_Image
(Tree.Production_ID (Nonterm)) &
+ " token index" & SAL.Peek_Type'Image (Pair.Index) &
+ " not in tokens range (" & SAL.Peek_Type'Image
(Tokens'First) & " .." &
+ SAL.Peek_Type'Image (Tokens'Last) & "); bad grammar
action.");
+ end;
+
+ elsif Tree.Byte_Region (Tokens (Pair.Index)) /= Null_Buffer_Region
then
+ declare
+ use all type WisiToken.Syntax_Trees.Node_Label;
+ Token : constant Aug_Token_Ref :=
+ (if Pair.Class = Statement_End and then
+ Tree.Label (Tokens (Pair.Index)) =
WisiToken.Syntax_Trees.Nonterm
+ then Data.Terminals.Variable_Ref (Tree.Max_Terminal_Index
(Tokens (Pair.Index)))
+ else Get_Aug_Token (Data, Tree, Tokens (Pair.Index)));
+
+ Cache_Pos : constant Buffer_Pos :=
Token.Char_Region.First;
+ Cursor : Navigate_Cache_Trees.Cursor :=
Navigate_Cache_Trees.Find
+ (Data.Navigate_Caches.Iterate, Cache_Pos,
Direction => Navigate_Cache_Trees.Unknown);
begin
if Navigate_Cache_Trees.Has_Element (Cursor) then
declare
Cache : Navigate_Cache_Type renames Data.Navigate_Caches
(Cursor);
begin
- Cache.Class := (if Override_Start_Set then
Override_Start else Pair.Class);
+ if Pair.Class = Statement_Start then
+ if Start_Set then
+ Cache.Class := Motion;
+ else
+ Cache.Class := Statement_Start;
+ Start_Set := True;
+ end if;
+ elsif Override_Start_Set then
+ Cache.Class := Statement_Start;
+ Start_Set := True;
+ else
+ Cache.Class := Pair.Class;
+ end if;
Cache.Statement_ID := Tree.ID (Nonterm);
Cache.Containing_Pos := Containing_Pos;
end;
else
Cursor := Data.Navigate_Caches.Insert
- ((Pos => Token.Char_Region.First,
+ ((Pos => Cache_Pos,
Statement_ID => Tree.ID (Nonterm),
ID => Token.ID,
Length => Length (Token.Char_Region),
- Class => (if Override_Start_Set then
Override_Start else Pair.Class),
+ Class => (if Override_Start_Set then
Statement_Start else Pair.Class),
Containing_Pos => Containing_Pos,
others => Nil));
end if;
@@ -942,22 +1018,67 @@ package body Wisi is
end if;
if Pair.Class = Statement_End and Containing_Pos.Set then
- Set_End (Data, Containing_Pos.Item, Token.Char_Region.First);
+ Set_End (Data, Containing_Pos.Item, Cache_Pos);
end if;
end;
else
-- Token.Byte_Region is null
if First_Item and Pair.Class = Statement_Start then
- -- We don't reset First_Item here; next token may also be a
start, if
- -- this one is empty.
Override_Start_Set := True;
- Override_Start := Pair.Class;
end if;
end if;
end loop;
end Statement_Action;
+ procedure Name_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Name : in WisiToken.Positive_Index_Type)
+ is
+ use all type WisiToken.Syntax_Trees.Node_Label;
+ begin
+ if not (Name in Tokens'Range) then
+ declare
+ Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tokens (Tokens'First));
+ begin
+ raise Fatal_Error with Error_Message
+ (File_Name => -Data.Source_File_Name,
+ Line => Token.Line,
+ Column => Token.Column,
+ Message => "wisi-name-action: " & Trimmed_Image
(Tree.Production_ID (Nonterm)) & " name (" &
+ Trimmed_Image (Name) & ") not in Tokens range (" &
SAL.Peek_Type'Image (Tokens'First) & " .." &
+ SAL.Peek_Type'Image (Tokens'Last) & "); bad grammar
action.");
+ end;
+ end if;
+
+ if Tree.Label (Tokens (Name)) = Syntax_Trees.Virtual_Terminal then
+ return;
+ end if;
+
+ declare
+ use Name_Cache_Trees;
+ Name_Token : constant Aug_Token_Ref := Get_Aug_Token (Data,
Tree, Tokens (Name));
+ Cursor : constant Name_Cache_Trees.Cursor := Find
+ (Data.Name_Caches.Iterate, Name_Token.Char_Region.First,
+ Direction => Name_Cache_Trees.Unknown);
+ begin
+ if Name_Token.Char_Region = Null_Buffer_Region then
+ return;
+ elsif Has_Element (Cursor) then
+ raise Fatal_Error with Error_Message
+ (File_Name => -Data.Source_File_Name,
+ Line => Name_Token.Line,
+ Column => Name_Token.Column,
+ Message => "wisi-name-action: name set twice.");
+ else
+ Data.Name_Caches.Insert (Name_Token.Char_Region);
+ end if;
+ end;
+ end Name_Action;
+
procedure Containing_Action
(Data : in out Parse_Data_Type;
Tree : in Syntax_Trees.Tree;
@@ -1071,8 +1192,6 @@ package body Wisi is
Tokens : in Syntax_Trees.Valid_Node_Index_Array;
Params : in Motion_Param_Array)
is
- pragma Unreferenced (Nonterm);
-
-- [2] wisi-motion-action
use Navigate_Cache_Trees;
use all type Ada.Containers.Count_Type;
@@ -1122,8 +1241,9 @@ package body Wisi is
Line => Token.Line,
Column => Token.Column,
Message => "wisi-motion-action: token " &
- Token.Image (Data.Descriptor.all) &
- " has no cache; add to statement-action.");
+ WisiToken.Image (Token.ID, Data.Descriptor.all) &
+ " has no cache; add to statement-action for " &
+ Trimmed_Image (Tree.Production_ID (Nonterm)) & ".");
end if;
end if;
@@ -1373,6 +1493,7 @@ package body Wisi is
is begin
return "(" & Simple_Indent_Param_Label'Image (Item.Label) &
(case Item.Label is
+ when None => "",
when Int => Integer'Image (Item.Int_Delta),
when Anchored_Label => Positive_Index_Type'Image
(Item.Anchored_Index) & "," &
Integer'Image (Item.Anchored_Delta),
@@ -1409,7 +1530,9 @@ package body Wisi is
-- [2] wisi-indent-action
for I in Tokens'Range loop
- if Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region then
+ if Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region and
+ I in Params'Range -- in some translated EBNF, not every token has
an indent param
+ then
declare
use all type WisiToken.Syntax_Trees.Node_Index;
use all type SAL.Base_Peek_Type;
@@ -1513,6 +1636,15 @@ package body Wisi is
end if;
end Indent_Hanging_1;
+ procedure Put_Language_Action
+ (Data : in Parse_Data_Type;
+ Content : in String)
+ is
+ pragma Unreferenced (Data);
+ begin
+ Ada.Text_IO.Put_Line ("[" & Language_Action_Code & Content & "]");
+ end Put_Language_Action;
+
procedure Put (Data : in out Parse_Data_Type; Parser : in
Parse.Base_Parser'Class)
is
use all type Ada.Containers.Count_Type;
@@ -1552,8 +1684,15 @@ package body Wisi is
function Get_Last_Line return Line_Number_Type
is begin
for I in Data.Line_Begin_Pos.First_Index ..
Data.Line_Begin_Pos.Last_Index loop
+ if Data.Line_Begin_Pos (I) = Invalid_Buffer_Pos then
+ raise SAL.Programmer_Error with "line_begin_pos" &
Line_Number_Type'Image (I) & " invalid";
+ end if;
if Data.Line_Begin_Pos (I) > Last_Char_Pos then
- return I - 1;
+ if I > Line_Number_Type'First then
+ return I - 1;
+ else
+ return I;
+ end if;
end if;
end loop;
return Data.Line_Begin_Pos.Last_Index;
@@ -1574,6 +1713,9 @@ package body Wisi is
for Cache of Data.Navigate_Caches loop
Put (Cache);
end loop;
+ for Cache of Data.Name_Caches loop
+ Put (Cache);
+ end loop;
when Face =>
for Cache of Data.Face_Caches loop
@@ -1706,7 +1848,7 @@ package body Wisi is
end case;
if Item.Recover.Stack.Depth > 0 then
- Put (Item.Recover, Data.Terminals, Data.Descriptor.all);
+ Put (Item.Recover, Data.Terminals, Data.Descriptor.all,
Data.Embedded_Quote_Escape_Doubled);
end if;
end loop;
end Put;
@@ -1725,9 +1867,11 @@ package body Wisi is
is begin
return "(" & Simple_Delta_Labels'Image (Item.Label) &
(case Item.Label is
+ when None => "",
when Int => Integer'Image (Item.Int_Delta),
when Anchored => Integer'Image (Item.Anchored_ID) & Integer'Image
(Item.Anchored_Delta) & " " &
- Boolean'Image (Item.Anchored_Accumulate) & ")");
+ Boolean'Image (Item.Anchored_Accumulate))
+ & ")";
end Image;
function Image (Item : in Delta_Type) return String
@@ -1792,6 +1936,7 @@ package body Wisi is
(case Tree.Label (Tree_Index) is
when Shared_Terminal => Data.Terminals.Variable_Ref (Tree.Terminal
(Tree_Index)),
when Virtual_Terminal => raise SAL.Programmer_Error with
"wisi_runtime.get_aug_token virtual terminal",
+ when Virtual_Identifier => raise SAL.Programmer_Error with
"wisi_runtime.get_aug_token virtual identifier",
when Nonterm => (Element => Augmented_Token_Access (Tree.Augmented
(Tree_Index))));
end Get_Aug_Token;
@@ -1842,6 +1987,7 @@ package body Wisi is
Accumulate : in Boolean)
return Delta_Type
is
+ -- [2] wisi-elisp-parse--anchored-2; return an anchored delta
use Anchor_ID_Vectors;
-- We can't use a Reference here, because the Element in reference
-- types is constrained (as are all allocated objects of access
@@ -1849,18 +1995,30 @@ package body Wisi is
Indent : Indent_Type := Data.Indents (Anchor_Line);
Anchor_ID : constant Integer := 1 + Max_Anchor_ID (Data, Anchor_Line,
Last_Line);
begin
- -- [2] wisi-elisp-parse--anchored-2
Data.Max_Anchor_ID := Integer'Max (Data.Max_Anchor_ID, Anchor_ID);
case Indent.Label is
when Not_Set =>
- Indent := (Anchor, To_Vector (Anchor_ID, 1), 0);
+ Indent := (Anchor_Nil, To_Vector (Anchor_ID, 1));
+
+ if Trace_Action > Extra then
+ Ada.Text_IO.Put_Line
+ (";; indent_anchored: " & Line_Number_Type'Image (Anchor_Line) &
" => " & Image (Indent));
+ end if;
when Int =>
- Indent := (Anchor, To_Vector (Anchor_ID, 1), Indent.Int_Indent);
+ Indent := (Anchor_Int, To_Vector (Anchor_ID, 1), Indent.Int_Indent);
+
+ if Trace_Action > Extra then
+ Ada.Text_IO.Put_Line
+ (";; indent_anchored: " & Line_Number_Type'Image (Anchor_Line) &
" => " & Image (Indent));
+ end if;
- when Anchor =>
- Indent.Anchor_IDs := Anchor_ID & Indent.Anchor_IDs;
+ when Anchor_Nil =>
+ Indent.Anchor_Nil_IDs := Anchor_ID & Indent.Anchor_Nil_IDs;
+
+ when Anchor_Int =>
+ Indent.Anchor_Int_IDs := Anchor_ID & Indent.Anchor_Int_IDs;
when Anchored =>
Indent := (Anchor_Anchored, To_Vector (Anchor_ID, 1),
Indent.Anchored_ID, Indent.Anchored_Delta);
@@ -1889,6 +2047,9 @@ package body Wisi is
case Param.Label is
when Simple =>
case Param.Param.Label is
+ when None =>
+ return (Simple, (Label => None));
+
when Int =>
return (Simple, (Int, Param.Param.Int_Delta));
@@ -1970,12 +2131,17 @@ package body Wisi is
(Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
Param.Hanging_Delta_2,
Option => False, Accumulate => True);
- when Hanging_1 => -- wisi-hanging%
+ when Hanging_1 => -- wisi-hanging-
+ return Indent_Hanging_1
+ (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
+ Param.Hanging_Delta_2,
+ Option => False, Accumulate => False);
+ when Hanging_2 => -- wisi-hanging%
return Indent_Hanging_1
(Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
Param.Hanging_Delta_2,
Option => True, Accumulate => True);
- when Hanging_2 => -- wisi-hanging%-
+ when Hanging_3 => -- wisi-hanging%-
return Indent_Hanging_1
(Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
Param.Hanging_Delta_2,
@@ -1990,6 +2156,7 @@ package body Wisi is
Delta_Indent : in Delta_Type;
Indenting_Comment : in Boolean)
is
+ -- Aplly Delta_Indent to Indenting_Token
First_Line : constant Line_Number_Type := Indenting_Token.First_Line
(Indenting_Comment);
Last_Line : constant Line_Number_Type := Indenting_Token.Last_Line
(Indenting_Comment);
begin
@@ -2009,7 +2176,7 @@ package body Wisi is
if Data.Line_Begin_Token.all (Line - 1) /=
Augmented_Token_Arrays.No_Index then
for Tok of Data.Terminals (Data.Line_Begin_Token.all (Line -
1)).Non_Grammar loop
if Tok.Line = Line and then
- Tok.ID = Data.Descriptor.Comment_ID and then
+ Tok.ID in Data.First_Comment_ID .. Data.Last_Comment_ID
and then
Tok.Column = 0
then
Indent := False;
@@ -2021,7 +2188,7 @@ package body Wisi is
if Indent then
Indent_Line (Data, Line, Delta_Indent);
else
- Indent_Line (Data, Line, Null_Delta);
+ Indent_Line (Data, Line, (Simple, (Int, 0)));
end if;
end;
else
diff --git a/wisi.ads b/wisi.ads
index d3f1214..818a7cc 100644
--- a/wisi.ads
+++ b/wisi.ads
@@ -79,7 +79,7 @@ package Wisi is
Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
- type Navigate_Class_Type is (Motion, Name, Statement_End,
Statement_Override, Statement_Start, Misc);
+ type Navigate_Class_Type is (Motion, Statement_End, Statement_Override,
Statement_Start, Misc);
-- Matches [1] wisi-class-list.
type Index_Navigate_Class is record
@@ -96,6 +96,13 @@ package Wisi is
Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
Params : in Statement_Param_Array);
+ procedure Name_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Name : in WisiToken.Positive_Index_Type);
+
procedure Containing_Action
(Data : in out Parse_Data_Type;
Tree : in WisiToken.Syntax_Trees.Tree;
@@ -191,7 +198,8 @@ package Wisi is
-- evaluated by wisi-elisp-parse--indent-compute-delta.
type Simple_Indent_Param_Label is -- not hanging
- (Int,
+ (None,
+ Int,
Anchored_0, -- wisi-anchored
Anchored_1, -- wisi-anchored%
Anchored_2, -- wisi-anchored%-
@@ -224,9 +232,12 @@ package Wisi is
Null_Args : Indent_Arg_Arrays.Vector renames Indent_Arg_Arrays.Empty_Vector;
- type Simple_Indent_Param (Label : Simple_Indent_Param_Label := Int) is
+ type Simple_Indent_Param (Label : Simple_Indent_Param_Label := None) is
record
case Label is
+ when None =>
+ null;
+
when Int =>
Int_Delta : Integer;
@@ -245,10 +256,11 @@ package Wisi is
type Indent_Param_Label is
(Simple,
Hanging_0, -- wisi-hanging
- Hanging_1, -- wisi-hanging%
- Hanging_2 -- wisi-hanging%-
+ Hanging_1, -- wisi-hanging-
+ Hanging_2, -- wisi-hanging%
+ Hanging_3 -- wisi-hanging%-
);
- subtype Hanging_Label is Indent_Param_Label range Hanging_0 .. Hanging_2;
+ subtype Hanging_Label is Indent_Param_Label range Hanging_0 .. Hanging_3;
type Indent_Param (Label : Indent_Param_Label := Simple) is
record
@@ -313,6 +325,13 @@ package Wisi is
-- Language specific child packages override this to implement
-- wisi-elisp-parse-indent-hanging-function.
+ type Arg_Index_Array is array (Positive range <>) of
WisiToken.Positive_Index_Type;
+
+ procedure Put_Language_Action
+ (Data : in Parse_Data_Type;
+ Content : in String);
+ -- Send a Language_Action message to Emacs.
+
procedure Put (Data : in out Parse_Data_Type; Parser : in
WisiToken.Parse.Base_Parser'Class);
-- Perform additional post-parse actions, then put result to
-- Ada.Text_IO.Current_Output, as encoded responses as defined in [3]
@@ -442,15 +461,15 @@ private
Nil : constant Nil_Buffer_Pos := (Set => False);
type Navigate_Cache_Type is record
- Pos : WisiToken.Buffer_Pos; -- implicit in wisi-cache
- Statement_ID : WisiToken.Token_ID; -- wisi-cache-nonterm
- ID : WisiToken.Token_ID; -- wisi-cache-token
- Length : Natural; -- wisi-cache-last
- Class : Navigate_Class_Type; -- wisi-cache-class; one of
wisi-class-list
- Containing_Pos : Nil_Buffer_Pos; -- wisi-cache-containing
- Prev_Pos : Nil_Buffer_Pos; -- wisi-cache-prev
- Next_Pos : Nil_Buffer_Pos; -- wisi-cache-next
- End_Pos : Nil_Buffer_Pos; -- wisi-cache-end
+ Pos : WisiToken.Buffer_Pos; -- implicit in wisi-cache
+ Statement_ID : WisiToken.Token_ID; -- wisi-cache-nonterm
+ ID : WisiToken.Token_ID; -- wisi-cache-token
+ Length : Natural; -- wisi-cache-last
+ Class : Navigate_Class_Type; -- wisi-cache-class
+ Containing_Pos : Nil_Buffer_Pos; -- wisi-cache-containing
+ Prev_Pos : Nil_Buffer_Pos; -- wisi-cache-prev
+ Next_Pos : Nil_Buffer_Pos; -- wisi-cache-next
+ End_Pos : Nil_Buffer_Pos; -- wisi-cache-end
end record;
function Key (Cache : in Navigate_Cache_Type) return WisiToken.Buffer_Pos
is (Cache.Pos);
@@ -463,6 +482,11 @@ private
package Navigate_Cache_Trees is new
SAL.Gen_Unbounded_Definite_Red_Black_Trees
(Navigate_Cache_Type, WisiToken.Buffer_Pos);
+ function Key (Cache : in WisiToken.Buffer_Region) return
WisiToken.Buffer_Pos is (Cache.First);
+
+ package Name_Cache_Trees is new SAL.Gen_Unbounded_Definite_Red_Black_Trees
+ (WisiToken.Buffer_Region, WisiToken.Buffer_Pos);
+
type Nil_Integer (Set : Boolean := False) is record
case Set is
when True =>
@@ -482,7 +506,7 @@ private
package Face_Cache_Trees is new SAL.Gen_Unbounded_Definite_Red_Black_Trees
(Face_Cache_Type, WisiToken.Buffer_Pos);
- type Indent_Label is (Not_Set, Int, Anchor, Anchored, Anchor_Anchored);
+ type Indent_Label is (Not_Set, Int, Anchor_Nil, Anchor_Int, Anchored,
Anchor_Anchored);
package Anchor_ID_Vectors is new Ada.Containers.Vectors (Natural, Positive);
@@ -496,9 +520,12 @@ private
when Int =>
Int_Indent : Integer;
- when Anchor =>
- Anchor_IDs : Anchor_ID_Vectors.Vector; -- Largest ID first.
- Anchor_Indent : Integer;
+ when Anchor_Nil =>
+ Anchor_Nil_IDs : Anchor_ID_Vectors.Vector; -- Largest ID first.
+
+ when Anchor_Int =>
+ Anchor_Int_IDs : Anchor_ID_Vectors.Vector; -- Largest ID first.
+ Anchor_Int_Indent : Integer;
when Anchored =>
Anchored_ID : Positive;
@@ -521,6 +548,14 @@ private
(Line_Begin_Token : not null access constant
WisiToken.Line_Begin_Token_Vectors.Vector)
is new WisiToken.Syntax_Trees.User_Data_Type with
record
+ -- Aux token info
+ First_Comment_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
+ Last_Comment_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
+ Left_Paren_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
+ Right_Paren_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
+
+ Embedded_Quote_Escape_Doubled : Boolean := False;
+
-- Data from parsing
Terminals : Augmented_Token_Arrays.Vector;
@@ -548,6 +583,7 @@ private
Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
Post_Parse_Action : Post_Parse_Action_Type;
Navigate_Caches : Navigate_Cache_Trees.Tree; -- Set by Navigate.
+ Name_Caches : Name_Cache_Trees.Tree; -- Set by Navigate.
End_Positions : Navigate_Cursor_Lists.List; -- Dynamic data for
Navigate.
Face_Caches : Face_Cache_Trees.Tree; -- Set by Face.
Indents : Indent_Vectors.Vector; -- Set by Indent.
@@ -560,11 +596,29 @@ private
Max_Anchor_ID : Integer;
end record;
- type Simple_Delta_Labels is (Int, Anchored);
+ type Simple_Delta_Labels is (None, Int, Anchored);
+
+ -- subtype Non_Anchored_Delta_Labels is Simple_Delta_Labels range None ..
Int;
- type Simple_Delta_Type (Label : Simple_Delta_Labels := Int) is
+ -- type Non_Anchored_Delta (Label : Non_Anchored_Delta_Labels := None) is
+ -- record
+ -- case Label is
+ -- when None =>
+ -- null;
+ -- when Int =>
+ -- Int_Delta : Integer;
+ -- end case;
+ -- end record;
+
+ -- function Image (Item : in Non_Anchored_Delta) return String;
+ -- For debugging
+
+ type Simple_Delta_Type (Label : Simple_Delta_Labels := None) is
record
case Label is
+ when None =>
+ null;
+
when Int =>
Int_Delta : Integer;
@@ -575,7 +629,6 @@ private
end case;
end record;
- subtype Anchored_Delta is Simple_Delta_Type (Anchored);
function Image (Item : in Simple_Delta_Type) return String;
-- For debugging
@@ -598,7 +651,7 @@ private
end case;
end record;
- Null_Delta : constant Delta_Type := (Simple, (Int, 0));
+ Null_Delta : constant Delta_Type := (Simple, (Label => None));
function Image (Item : in Delta_Type) return String;
-- For debugging
diff --git a/wisi.el b/wisi.el
index 3aa522c..5ea8d5a 100644
--- a/wisi.el
+++ b/wisi.el
@@ -1,1517 +1,1640 @@
-;;; wisi.el --- Utilities for implementing an indentation/navigation engine
using a generalized LALR parser -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2012 - 2019 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Keywords: parser
-;; indentation
-;; navigation
-;; Version: 2.1.0
-;; package-requires: ((cl-lib "1.0") (emacs "25.0") (seq "2.20"))
-;; URL: http://stephe-leake.org/ada/wisitoken.html
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-;;
-
-;;; Commentary:
-
-;;;; History: see NEWS-wisi.text
-;;
-;;;; Design:
-;;
-;; 'wisi' was originally short for "wisent indentation engine", but
-;; now is just a name. wisi was developed to support Emacs ada-mode
-;; 5.0 indentation, font-lock, and navigation, which are parser based.
-;;
-;; The approach to indenting a given token is to parse the buffer,
-;; computing a delta indent at each parse action.
-;;
-;; The parser actions also cache face and navigation information
-;; as text properties on tokens in statements.
-;;
-;; The three reasons to run the parser (indent, face, navigate) occur
-;; at different times (user indent, font-lock, user navigate), so only
-;; the relevant parser actions are run.
-;;
-;; Parsing can be noticeably slow in large files, so sometimes we do a
-;; partial parse, and keep a list of parsed regions.
-;;
-;; Since we have a cache (the text properties), we need to consider
-;; when to invalidate it. Ideally, we invalidate only when a change
-;; to the buffer would change the result of a parse that crosses that
-;; change, or starts after that change. Changes in whitespace
-;; (indentation and newlines) do not affect an Ada parse. Other
-;; languages are sensitive to newlines (Bash for example) or
-;; indentation (Python). Adding comments does not change a parse,
-;; unless code is commented out.
-;;
-;; For navigate, we expect fully accurate results, and can tolerate
-;; one initial delay, so we always parse the entire file.
-;;
-;; For font-lock, we only parse the portion of the file requested by
-;; font-lock, so we keep a list of regions, and edit that list when
-;; the buffer is changed..
-;;
-;; For indenting, we expect fast results, and can tolerate some
-;; inaccuracy until the editing is done, so we allow partial parse. We
-;; cache the indent for each line in a text property on the newline
-;; char preceding the line. `wisi-indent-region' sets the cache on all
-;; the lines computed (part of the buffer in large files), but
-;; performs the indent only on the lines in the indent
-;; region. Subsequent calls to `wisi-indent-region' apply the cached
-;; indents. Non-whitespace edits to the buffer invalidate the indent
-;; caches in the edited region and after. Since we can do partial
-;; parse, we keep a list of parsed regions.
-;;
-;; See `wisi--post-change' for the details of what we check for
-;; invalidating.
-;;
-;;;; Choice of grammar compiler and parser
-;;
-;; There are two other parsing engines available in Emacs:
-;;
-;; - SMIE
-;;
-;; We don't use this because it is designed to parse small snippets
-;; of code. For Ada indentation, we always need to parse the entire
-;; buffer.
-;;
-;; - semantic
-;;
-;; The Ada grammar as given in the Ada language reference manual is
-;; not LALR(1). So we use a generalized parser. In addition, the
-;; semantic lexer is more complex, and gives different information
-;; than we need. Finally, the semantic parser does not support error
-;; correction, and thus fails in most editing situations.
-;;
-;; We use wisitoken wisi-generate to compile BNF to Elisp source, and
-;; wisi-compile-grammar to compile that to the parser table. See
-;; ada-mode info for more information on the developer tools used for
-;; ada-mode and wisi.
-;;
-;; Alternately, to gain speed and error handling, we use wisi-generate
-;; to generate Ada source, and run that in an external process. That
-;; supports error correction while parsing.
-;;
-;;;; syntax-propertize
-;;
-;; `wisi-forward-token' relies on syntax properties, so
-;; `syntax-propertize' must be called on the text to be lexed before
-;; wisi-forward-token is called.
-;;
-;; Emacs >= 25 calls syntax-propertize transparently in the low-level
-;; lexer functions.
-;;
-;; In Emacs < 25, we call syntax-propertize in wisi-setup, and in
-;; `wisi--post-change'.
-;;
-;;;;;
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'compile)
-(require 'seq)
-(require 'semantic/lex)
-(require 'wisi-parse-common)
-(require 'wisi-elisp-lexer)
-(require 'wisi-fringe)
-
-(defcustom wisi-size-threshold most-positive-fixnum
- "Max size (in characters) for using wisi parser results for anything."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-size-threshold)
-
-(defcustom wisi-partial-parse-threshold 100001
- "Min size (in characters) for using partial wisi parser.
-The partial parser finds a nearby start point, and parses a small
-portion of the file containing the region to parse. For indent,
-it assumes the start point is properly indented."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-partial-parse-threshold)
-
-(defvar wisi-inhibit-parse nil
- "When non-nil, don't run the parser.
-Language code can set this non-nil when syntax is known to be
-invalid temporarily, or when making lots of changes.")
-
-(defcustom wisi-disable-face nil
- "When non-nil, `wisi-setup' does not enable use of parser for font-lock.
-Useful when debugging parser or parser actions."
- :type 'boolean
- :group 'wisi
- :safe 'booleanp)
-
-(defconst wisi-error-buffer-name "*wisi syntax errors*"
- "Name of buffer for displaying syntax errors.")
-
-(defvar wisi-error-buffer nil
- "Buffer for displaying syntax errors.")
-
-(defun wisi-safe-marker-pos (pos)
- "Return an integer buffer position from POS, an integer or marker"
- (cond
- ((markerp pos)
- (marker-position pos))
-
- (t pos)))
-
-;;;; token info cache
-
-(defvar-local wisi-parse-failed nil
- "Non-nil when a recent parse has failed - cleared when parse succeeds.")
-
-(defvar-local wisi--parse-try
- (list
- (cons 'face t)
- (cons 'navigate t)
- (cons 'indent t))
- "Non-nil when parse is needed - cleared when parse succeeds.")
-
-(defun wisi-parse-try (&optional parse-action)
- (cdr (assoc (or parse-action wisi--parse-action) wisi--parse-try)))
-
-(defun wisi-set-parse-try (value &optional parse-action)
- (setcdr (assoc (or parse-action wisi--parse-action) wisi--parse-try) value))
-
-(defvar-local wisi--cached-regions
- (list
- (cons 'face nil)
- (cons 'navigate nil)
- (cons 'indent nil))
- "Alist of lists of regions in buffer where parser text properties are valid.
-Regions in a list are in random order.")
-
-(defun wisi--contained-region (begin end region)
- "Non-nil if BEGIN END (buffer positions) is contained in REGION (a cons of
positions)."
- ;; We assume begin < end
- (and (<= (car region) begin)
- (<= end (cdr region))))
-
-(defun wisi--contained-pos (pos region)
- "Non-nil if POS (a buffer position) is contained in REGION (a cons of
positions)."
- (and (<= (car region) pos)
- (<= pos (cdr region))))
-
-(defun wisi-cache-covers-region (begin end &optional parse-action)
- "Non-nil if BEGIN END is contained in a parsed region."
- (let ((region-list (cdr (assoc (or parse-action wisi--parse-action)
wisi--cached-regions)))
- region)
- (while (and region-list
- (not (wisi--contained-region begin end (car region-list))))
- (pop region-list))
-
- (when region-list
- ;; return a nice value for verbosity in wisi-validate-cache
- (setq region (car region-list))
- (cons (marker-position (car region)) (marker-position (cdr region))))))
-
-(defun wisi-cache-covers-pos (parse-action pos)
- "Non-nil if POS is contained in a PARSE-ACTION parsed region."
- (let ((region-list (cdr (assoc parse-action wisi--cached-regions))))
- (while (and region-list
- (not (wisi--contained-pos pos (car region-list))))
- (pop region-list))
-
- (when region-list
- t)))
-
-(defun wisi-cache-contains-pos (parse-action pos)
- "Non-nil if POS is at or before the end of any PARSE-ACTION parsed region."
- (let ((region-list (cdr (assoc parse-action wisi--cached-regions)))
- result)
- (while (and (not result) region-list)
- (when (<= pos (cdr (car region-list)))
- (setq result t))
- (pop region-list))
-
- result))
-
-(defun wisi-cache-set-region (region)
- "Set the cached region list for `wisi--parse-action' to REGION."
- (setcdr (assoc wisi--parse-action wisi--cached-regions)
- (list (cons (copy-marker (car region))
- (copy-marker (cdr region))))))
-
-(defun wisi-cache-add-region (region)
- "Add REGION to the cached region list for `wisi--parse-action'."
- (push (cons (copy-marker (car region))
- (copy-marker (cdr region)))
- (cdr (assoc wisi--parse-action wisi--cached-regions))))
-
-(defun wisi-cache-delete-regions-after (parse-action pos)
- "Delete any PARSE-ACTION parsed region at or after POS.
-Truncate any region that overlaps POS."
- (let ((region-list (cdr (assoc parse-action wisi--cached-regions)))
- result)
- (while (and (not result) region-list)
- (cond
- ((and (> pos (car (car region-list)))
- (<= pos (cdr (car region-list))))
- ;; region contains POS; keep truncated
- (push (cons (car (car region-list)) (copy-marker pos)) result))
-
- ((> pos (car (car region-list)))
- ;; region is entirely before POS; keep
- (push (car region-list) result))
-
- ;; else region is entirely after POS; delete
- )
-
- (pop region-list))
- (setcdr (assoc parse-action wisi--cached-regions) result)
- ))
-
-(defun wisi--delete-face-cache (after)
- (with-silent-modifications
- (remove-text-properties after (point-max) '(font-lock-face nil))
- )
- (wisi-cache-delete-regions-after 'face after))
-
-(defun wisi--delete-navigate-cache (after)
- (with-silent-modifications
- ;; This text property is 'wisi-cache', not 'wisi-navigate', for
- ;; historical reasons.
- (remove-text-properties after (point-max) '(wisi-cache nil))
- )
- (wisi-cache-delete-regions-after 'navigate after))
-
-(defun wisi--delete-indent-cache (after)
- (with-silent-modifications
- (remove-text-properties after (point-max) '(wisi-indent nil))
- )
- (wisi-cache-delete-regions-after 'indent after))
-
-(defun wisi-invalidate-cache (action after)
- "Invalidate ACTION caches for the current buffer from AFTER to end of
buffer."
- (when (wisi-cache-contains-pos action after)
- (when (> wisi-debug 0) (message "wisi-invalidate-cache %s:%s:%d" action
(current-buffer) after))
- (cond
- ((eq 'face action)
- (wisi--delete-face-cache after))
-
- ((eq 'navigate action)
- (when (wisi-cache-covers-pos 'navigate after)
- ;; We goto statement start to ensure that motion within nested
- ;; structures is properly done (ie prev/next on ’elsif’ is not
- ;; set by wisi-motion-action if already set by a lower level
- ;; statement). We don’t do it for ’face or ’indent, because that
- ;; might require a parse, and they don’t care about nested
- ;; structures.
- (save-excursion
- (goto-char after)
-
- ;; This is copied from ‘wisi-goto-statement-start’; we can’t
- ;; call that because it would call ‘wisi-validate-cache’,
- ;; which would call ‘wisi-invalidate-cache’; infinite loop.
- ;; If this needed a navigate parse to succeed, we would not
- ;; get here.
- (let ((cache (or (wisi-get-cache (point))
- (wisi-backward-cache))))
- (cond
- ((null cache)
- ;; at bob
- nil)
-
- ((eq 'statement-end (wisi-cache-class cache))
- ;; If the change did affect part of a structure statement,
- ;; this is a lower level statement. Otherwise, we are
- ;; invalidating more than necessary; not a problem.
- (wisi-goto-start cache)
- (setq cache (wisi-backward-cache))
- (when cache ;; else bob
- (wisi-goto-start cache)))
-
- (t
- (wisi-goto-start cache))
- ))
-
- (setq after (point))))
- (wisi--delete-navigate-cache after))
-
- ((eq 'indent action)
- ;; The indent cache is stored on newline before line being
- ;; indented. We delete that, because changing text on a line can
- ;; change the indent of that line.
- (setq after
- (save-excursion
- (goto-char after)
- (line-beginning-position)))
- (wisi--delete-indent-cache (max 1 (1- after))))
- )
- ))
-
-(defun wisi-reset-parser ()
- "Force a parse."
- (interactive)
- (wisi-invalidate-cache 'indent (point-min))
- (wisi-invalidate-cache 'face (point-min))
- (wisi-invalidate-cache 'navigate (point-min))
- (wisi-set-parse-try t 'indent)
- (wisi-set-parse-try t 'face)
- (wisi-set-parse-try t 'navigate)
- (wisi-fringe-clean))
-
-;; wisi--change-* keep track of buffer modifications.
-;; If wisi--change-end comes before wisi--change-beg, it means there were
-;; no modifications.
-(defvar-local wisi--change-beg most-positive-fixnum
- "First position where a change may have taken place.")
-
-(defvar-local wisi--change-end nil
- "Marker pointing to the last position where a change may have taken place.")
-
-(defvar-local wisi--deleted-syntax nil
- "Worst syntax class of characters deleted in changes.
-One of:
-nil - no deletions since reset
-0 - only whitespace or comment deleted
-2 - some other syntax deleted
-
-Set by `wisi-before-change', used and reset by `wisi--post-change'.")
-
-(defvar-local wisi-indenting-p nil
- "Non-nil when `wisi-indent-region' is actively indenting.
-Used to ignore whitespace changes in before/after change hooks.")
-
-(defvar-local wisi--parser nil
- "Choice of wisi parser implementation; a ‘wisi-parser’ object.")
-
-(defvar-local wisi--last-parse-action nil
- "Last value of `wisi--parse-action' when `wisi-validate-cache' was run.")
-
-(defun wisi-before-change (begin end)
- "For `before-change-functions'."
- ;; begin . (1- end) is range of text being deleted
- (unless wisi-indenting-p
- ;; We set wisi--change-beg, -end even if only inserting, so we
- ;; don't have to do it again in wisi-after-change.
- (setq wisi--change-beg (min wisi--change-beg begin))
-
- (cond
- ((null wisi--change-end)
- (setq wisi--change-end (copy-marker end)))
-
- ((> end wisi--change-end)
- ;; `buffer-base-buffer' deals with edits in indirect buffers
- ;; created by ediff-regions-*
- (set-marker wisi--change-end end (buffer-base-buffer)))
- )
-
- (unless (= begin end)
- (cond
- ((or (null wisi--deleted-syntax)
- (= 0 wisi--deleted-syntax))
- (save-excursion
- (if (or (nth 4 (syntax-ppss begin)) ; in comment, moves point to begin
- (= end (skip-syntax-forward " " end)));; whitespace
- (setq wisi--deleted-syntax 0)
- (setq wisi--deleted-syntax 2))))
-
- (t
- ;; wisi--deleted-syntax is 2; no change.
- )
- ))))
-
-(defun wisi-after-change (begin end _length)
- "For `after-change-functions'"
- ;; begin . end is range of text being inserted (empty if equal);
- ;; length is the size of the deleted text.
-
- ;; Remove caches on inserted text, which could have caches from
- ;; anywhere, and are in any case invalid.
-
- ;; If the insertion changes a word that has wisi fontification,
- ;; remove fontification from the entire word, so it is all
- ;; refontified consistently.
-
- (let (word-begin word-end)
- (save-excursion
- (goto-char end)
- (skip-syntax-forward "w_")
- (setq word-end (point))
- (goto-char begin)
- (skip-syntax-backward "w_")
- (setq word-begin (point)))
- (if (get-text-property word-begin 'font-lock-face)
- (with-silent-modifications
- (remove-text-properties
- word-begin word-end
- '(font-lock-face nil wisi-cache nil wisi-indent nil fontified nil)))
-
- ;; No point in removing
- ;; 'fontified here; that's already handled by jit-lock.
- (with-silent-modifications
- (remove-text-properties
- begin end
- '(font-lock-face nil wisi-cache nil wisi-indent nil))))
- ))
-
-(defun wisi--post-change (begin end)
- "Update wisi text properties for changes in region BEG END."
- ;; (syntax-ppss-flush-cache begin) is in before-change-functions
-
- ;; see comments above on syntax-propertize
- (when (< emacs-major-version 25) (syntax-propertize end))
-
- (save-excursion
- (let ((need-invalidate t)
- (done nil)
- ;; non-nil if require a parse because the syntax may have
- ;; changed.
-
- (begin-state (syntax-ppss begin))
- (end-state (syntax-ppss end)))
- ;; (info "(elisp)Parser State")
- ;; syntax-ppss has moved point to "end"; might be eob.
-
- ;; consider deletion
- (cond
- ((null wisi--deleted-syntax)
- ;; no deletions
- )
-
- ((= 0 wisi--deleted-syntax)
- ;; Only deleted whitespace; may have joined two words
- (when
- (and (= begin end) ;; no insertions
- (or
- (= (point-min) begin)
- (= 0 (syntax-class (syntax-after (1- begin))))
- (= (point-max) end)
- (= 0 (syntax-class (syntax-after end)))))
- ;; More whitespace on at least one side of deletion; did not
- ;; join two words.
- (setq need-invalidate nil)
- (setq done t)
- ))
-
- (t
- ;; wisi--deleted-syntax is 2; need invalidate and parse for all
- ;; parse actions
- (setq done t)
- ))
-
- (setq wisi--deleted-syntax nil)
-
- (unless done
- ;; consider insertion
- (cond
- ((= begin end)
- ;; no insertions
- nil)
-
- ((and
- (nth 3 begin-state);; in string
- (nth 3 end-state)
- (= (nth 8 begin-state) (nth 8 end-state)));; no intervening
non-string
- (setq need-invalidate nil))
-
- ((and
- (nth 4 begin-state) ; in comment
- (nth 4 end-state)
- (= (nth 8 begin-state) (nth 8 end-state))) ;; no intervening
non-comment
- (setq need-invalidate nil))
-
- ((and
- (or
- (= (point-min) begin)
- (= 0 (syntax-class (syntax-after (1- begin)))); whitespace
- (= (point-max) end)
- (= 0 (syntax-class (syntax-after end))))
- (progn
- (goto-char begin)
- (= (- end begin) (skip-syntax-forward " " end))
- ))
- ;; Inserted only whitespace, there is more whitespace on at
- ;; least one side, and we are not in a comment or string
- ;; (checked above). This may affect indentation, but not
- ;; the indentation cache.
- (setq need-invalidate nil))
- ))
-
- (when need-invalidate
- (wisi-set-parse-try t 'face)
- (wisi-set-parse-try t 'navigate)
- (wisi-set-parse-try t 'indent)
-
- (wisi-invalidate-cache 'face begin)
- (wisi-invalidate-cache 'navigate begin)
- (wisi-invalidate-cache 'indent begin))
- )))
-
-(defun wisi-goto-error ()
- "Move point to position in last error message (if any)."
- (cond
- ((wisi-parser-parse-errors wisi--parser)
- (let ((data (car (wisi-parser-parse-errors wisi--parser))))
- (cond
- ((wisi--parse-error-pos data)
- (push-mark)
- (goto-char (wisi--parse-error-pos data)))
-
- ((string-match ":\\([0-9]+\\):\\([0-9]+\\):" (wisi--parse-error-message
data))
- (let* ((msg (wisi--parse-error-message data))
- (line (string-to-number (match-string 1 msg)))
- (col (string-to-number (match-string 2 msg))))
- (push-mark)
- (goto-char (point-min))
- (condition-case nil
- (progn
- ;; line can be wrong if parser screws up, or user edits buffer
- (forward-line (1- line))
- (forward-char col))
- (error
- ;; just stay at eob.
- nil))))
- )))
- ((wisi-parser-lexer-errors wisi--parser)
- (push-mark)
- (goto-char (wisi--lexer-error-pos (car (wisi-parser-lexer-errors
wisi--parser)))))
- ))
-
-(defun wisi-show-parse-error ()
- "Show current wisi-parse errors."
- (interactive)
- (cond
- ((or (wisi-parser-lexer-errors wisi--parser)
- (wisi-parser-parse-errors wisi--parser))
- (if (and (= 1 (+ (length (wisi-parser-lexer-errors wisi--parser))
- (length (wisi-parser-parse-errors wisi--parser))))
- (or (and (wisi-parser-parse-errors wisi--parser)
- (not (wisi--parse-error-repair (car
(wisi-parser-parse-errors wisi--parser)))))
- (and (wisi-parser-lexer-errors wisi--parser)
- (not (wisi--lexer-error-inserted (car
(wisi-parser-lexer-errors wisi--parser)))))))
- ;; There is exactly one error; if there is error correction
- ;; information, use a ’compilation’ buffer, so
- ;; *-fix-compiler-error will call
- ;; wisi-repair-error. Otherwise, just position cursor at
- ;; error.
- (progn
- (wisi-goto-error)
- (message (or (and (wisi-parser-parse-errors wisi--parser)
- (wisi--parse-error-message (car
(wisi-parser-parse-errors wisi--parser))))
- (and (wisi-parser-lexer-errors wisi--parser)
- (wisi--lexer-error-message (car
(wisi-parser-lexer-errors wisi--parser)))))
- ))
-
- ;; else show all errors in a ’compilation’ buffer
- (setq wisi-error-buffer (get-buffer-create wisi-error-buffer-name))
-
- (let ((lexer-errs (nreverse (cl-copy-seq (wisi-parser-lexer-errors
wisi--parser))))
- (parse-errs (nreverse (cl-copy-seq (wisi-parser-parse-errors
wisi--parser)))))
- (with-current-buffer wisi-error-buffer
- (compilation-mode)
- (setq next-error-last-buffer (current-buffer))
- (setq buffer-read-only nil)
- (erase-buffer)
- ;; compilation-nex-error-function assumes there is not an
- ;; error at point min, so we need a comment.
- (insert "wisi syntax errors")
- (newline)
- (dolist (err lexer-errs)
- (insert (wisi--lexer-error-message err))
- (put-text-property (line-beginning-position) (1+
(line-beginning-position)) 'wisi-error-data err)
- (newline 2))
- (dolist (err parse-errs)
- (insert (wisi--parse-error-message err))
- (put-text-property (line-beginning-position) (1+
(line-beginning-position)) 'wisi-error-data err)
- (newline 2))
- (compilation--flush-parse (point-min) (point-max))
- (compilation--ensure-parse (point-max))
- (when compilation-filter-hook
- (let ((compilation-filter-start (point-min)))
- (run-hooks 'compilation-filter-hook)))
-
- (setq buffer-read-only t)
- (goto-char (point-min)))
-
- (display-buffer wisi-error-buffer
- (cons #'display-buffer-at-bottom
- (list (cons 'window-height
#'shrink-window-if-larger-than-buffer))))
- (next-error))
- ))
-
- ((wisi-parse-try wisi--last-parse-action)
- (message "need parse"))
-
- (t
- (message "parse succeeded"))
- ))
-
-(defun wisi-kill-parser ()
- "Kill the background process running the parser for the current buffer.
-Usefull if the parser appears to be hung."
- (interactive)
- (wisi-parse-kill wisi--parser)
- ;; also force re-parse
- (dolist (parse-action '(face navigate indent))
- (wisi-set-parse-try t parse-action)
- (wisi-invalidate-cache parse-action (point-min)))
- )
-
-(defun wisi-partial-parse-p (begin end)
- (and (wisi-process--parser-p wisi--parser)
- (not (and (= begin (point-min))
- (= end (point-max))))
- (>= (point-max) wisi-partial-parse-threshold)))
-
-(defun wisi--run-parse (begin parse-end)
- "Run the parser, on at least region BEGIN PARSE-END."
- (unless (or (buffer-narrowed-p)
- (= (point-min) (point-max))) ;; some parsers can’t handle an
empty buffer.
- (let* ((partial-parse-p (wisi-partial-parse-p begin parse-end))
- (msg (when (> wisi-debug 0)
- (format "wisi: %sparsing %s %s:%d %d %d ..."
- (if partial-parse-p "partial " "")
- wisi--parse-action
- (buffer-name)
- begin
- (if (markerp parse-end) (marker-position parse-end)
parse-end)
- (line-number-at-pos begin))))
- (parsed-region nil))
-
- (when msg
- (message msg))
-
- (setq wisi--last-parse-action wisi--parse-action)
-
- (unless (eq wisi--parse-action 'face)
- (when (buffer-live-p wisi-error-buffer)
- (with-current-buffer wisi-error-buffer
- (setq buffer-read-only nil)
- (erase-buffer)
- (setq buffer-read-only t))))
-
- (condition-case-unless-debug err
- (save-excursion
- (if partial-parse-p
- (let ((send-region (wisi-parse-expand-region wisi--parser begin
parse-end)))
- (setq parsed-region (wisi-parse-current wisi--parser (car
send-region) (cdr send-region) parse-end))
- (wisi-cache-add-region parsed-region))
-
- ;; parse full buffer
- (setq parsed-region (cons (point-min) (point-max)))
- (wisi-cache-set-region (wisi-parse-current wisi--parser
(point-min) (point-max) (point-max))))
-
- (when (> wisi-debug 0) (message "... parsed %s" parsed-region))
- (setq wisi-parse-failed nil))
- (wisi-parse-error
- (cl-ecase wisi--parse-action
- (face
- ;; caches set by failed elisp parse are ok
- (wisi--delete-face-cache (cdr parsed-region)))
-
- (navigate
- ;; elisp parse partially resets caches
- (wisi--delete-navigate-cache (point-min)))
-
- (indent
- ;; parse does not set caches; see `wisi-indent-region'
- nil))
- (setq wisi-parse-failed t)
- ;; parser should have stored this error message in parser-error-msgs
- )
- (error
- ;; parser failed for other reason
- (setq wisi-parse-failed t)
- (signal (car err) (cdr err)))
- )
-
- (unless partial-parse-p
- (wisi-fringe-display-errors
- (append
- (seq-map (lambda (err) (wisi--lexer-error-pos err))
(wisi-parser-lexer-errors wisi--parser))
- (seq-map (lambda (err) (wisi--parse-error-pos err))
(wisi-parser-parse-errors wisi--parser)))))
-
- (when (> wisi-debug 1)
- (if (or (wisi-parser-lexer-errors wisi--parser)
- (wisi-parser-parse-errors wisi--parser))
- (progn
- (message "%s error" msg)
- (wisi-goto-error)
- (error (or (and (wisi-parser-lexer-errors wisi--parser)
- (wisi--lexer-error-message (car
(wisi-parser-lexer-errors wisi--parser))))
- (and (wisi-parser-parse-errors wisi--parser)
- (wisi--parse-error-message (car
(wisi-parser-parse-errors wisi--parser))))
- )))
-
- ;; no error
- (message "%s done" msg))
- ))))
-
-(defun wisi--check-change ()
- "Process `wisi--change-beg', `wisi--change-end'.
-`wisi--parse-action' must be bound."
- (when (and wisi--change-beg
- wisi--change-end
- (<= wisi--change-beg wisi--change-end))
- (wisi--post-change wisi--change-beg (marker-position wisi--change-end))
- (setq wisi--change-beg most-positive-fixnum)
- (move-marker wisi--change-end (point-min))
- ))
-
-(defun wisi-validate-cache (begin end error-on-fail parse-action)
- "Ensure cached data for PARSE-ACTION is valid in region BEGIN END in current
buffer."
- (if (and (not wisi-inhibit-parse)
- (< (point-max) wisi-size-threshold))
- (let ((wisi--parse-action parse-action))
- (wisi--check-change)
-
- ;; Now we can rely on wisi-cache-covers-region
-
- (if (and (or (not wisi-parse-failed)
- (wisi-parse-try))
- (not (wisi-cache-covers-region begin end)))
- (progn
- ;; Don't keep retrying failed parse until text changes again.
- (wisi-set-parse-try nil)
- (wisi--run-parse begin end))
-
- (when (> wisi-debug 0)
- (message "parse %s skipped: parse-failed %s parse-try %s
cache-covers-region %s %s.%s"
- parse-action
- wisi-parse-failed
- (wisi-parse-try)
- (wisi-cache-covers-region begin end)
- begin end)))
-
- ;; We want this error even if we did not try to parse; it means
- ;; the parse results are not valid.
- (when (and error-on-fail wisi-parse-failed)
- (error "parse %s failed" parse-action))
- )
- (when (> wisi-debug 0)
- (message "parse %s skipped inihibit-parse %s wisi-size-threshold %d"
- parse-action
- wisi-inhibit-parse
- wisi-size-threshold))))
-
-(defun wisi-fontify-region (begin end)
- "For `jit-lock-functions'."
- (wisi-validate-cache begin end nil 'face))
-
-(defun wisi-get-containing-cache (cache)
- "Return cache from (wisi-cache-containing CACHE)."
- (when cache
- (let ((containing (wisi-cache-containing cache)))
- (and containing
- (wisi-get-cache containing)))))
-
-(defun wisi-cache-text (cache)
- "Return property-less buffer substring designated by cache.
-Point must be at cache."
- (buffer-substring-no-properties (point) (+ (point) (wisi-cache-last cache))))
-
-;;;; navigation
-
-(defun wisi-forward-find-class (class limit)
- "Search at point or forward for a token that has a cache with CLASS.
-Return cache, or nil if at end of buffer.
-If LIMIT (a buffer position) is reached, throw an error."
- (let ((cache (or (wisi-get-cache (point))
- (wisi-forward-cache))))
- (while (not (eq class (wisi-cache-class cache)))
- (setq cache (wisi-forward-cache))
- (when (>= (point) limit)
- (error "cache with class %s not found" class)))
- cache))
-
-(defun wisi-forward-find-token (token limit &optional noerror)
- "Search forward for TOKEN.
-If point is at a matching token, return that token. TOKEN may be
-a list; stop on any member of the list. Return `wisi-tok'
-struct, or if LIMIT (a buffer position) is reached, then if
-NOERROR is nil, throw an error, if non-nil, return nil."
- (let ((token-list (cond
- ((listp token) token)
- (t (list token))))
- (tok (wisi-forward-token))
- (done nil))
- (while (not (or done
- (memq (wisi-tok-token tok) token-list)))
- (setq tok (wisi-forward-token))
- (when (or (>= (point) limit)
- (eobp))
- (goto-char limit)
- (setq tok nil)
- (if noerror
- (setq done t)
- (error "token %s not found" token))))
- tok))
-
-(defun wisi-forward-find-cache-token (ids limit)
- "Search forward for a cache with token in IDS (a list of token ids).
-Return cache, or nil if at LIMIT or end of buffer."
- (let ((cache (wisi-forward-cache)))
- (while (and (< (point) limit)
- (not (eobp))
- (not (memq (wisi-cache-token cache) ids)))
- (setq cache (wisi-forward-cache)))
- cache))
-
-(defun wisi-forward-find-nonterm (nonterm limit)
- "Search forward for a token that has a cache with NONTERM.
-NONTERM may be a list; stop on any cache that has a member of the list.
-Return cache, or nil if at end of buffer.
-If LIMIT (a buffer position) is reached, throw an error."
- (let ((nonterm-list (cond
- ((listp nonterm) nonterm)
- (t (list nonterm))))
- (cache (wisi-forward-cache)))
- (while (not (memq (wisi-cache-nonterm cache) nonterm-list))
- (setq cache (wisi-forward-cache))
- (when (>= (point) limit)
- (error "cache with nonterm %s not found" nonterm)))
- cache))
-
-(defun wisi-goto-cache-next (cache)
- (goto-char (wisi-cache-next cache))
- (wisi-get-cache (point))
- )
-
-(defun wisi-forward-statement-keyword ()
- "If not at a cached token, move forward to next
-cache. Otherwise move to cache-next, or cache-end, or next cache
-if both nil. Return cache found."
- (unless (eobp)
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (let ((cache (wisi-get-cache (point))))
- (if (and cache
- (not (eq (wisi-cache-class cache) 'statement-end)))
- (let ((next (or (wisi-cache-next cache)
- (wisi-cache-end cache))))
- (if next
- (goto-char next)
- (wisi-forward-cache)))
- (wisi-forward-cache))
- )
- (wisi-get-cache (point))
- ))
-
-(defun wisi-backward-statement-keyword ()
- "If not at a cached token, move backward to prev
-cache. Otherwise move to cache-prev, or prev cache if nil."
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (let ((cache (wisi-get-cache (point)))
- prev)
- (when cache
- (setq prev (wisi-cache-prev cache))
- (unless prev
- (unless (eq 'statement-start (wisi-cache-class cache))
- (setq prev (wisi-cache-containing cache)))))
- (if prev
- (goto-char prev)
- (wisi-backward-cache))
- ))
-
-(defun wisi-forward-sexp (&optional arg)
- "For `forward-sexp-function'."
- (interactive "^p")
- (or arg (setq arg 1))
- (cond
- ((and (> arg 0) (= 4 (syntax-class (syntax-after (point))))) ;; on open
paren
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- ((and (< arg 0) (= 5 (syntax-class (syntax-after (1- (point)))))) ;; after
close paren
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- ((and (> arg 0) (= 7 (syntax-class (syntax-after (point))))) ;; on (open)
string quote
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- ((and (< arg 0) (= 7 (syntax-class (syntax-after (1- (point)))))) ;; after
(close) string quote
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- (t
- (dotimes (_i (abs arg))
- (if (> arg 0)
- (wisi-forward-statement-keyword)
- (wisi-backward-statement-keyword))))
- ))
-
-(defun wisi-goto-containing (cache &optional error)
- "Move point to containing token for CACHE, return cache at that point.
-If ERROR, throw error when CACHE has no container; else return nil."
- (cond
- ((and (markerp (wisi-cache-containing cache))
-
- (not (= (wisi-cache-containing cache) (point))))
- ;; This check is only needed if some cache points to itself as a
- ;; container. Apparently that happend once that I caught in the
- ;; debugger; emacs hung because we got here in the font-lock
- ;; timer.
-
- (goto-char (wisi-cache-containing cache))
- (wisi-get-cache (point)))
- (t
- (when error
- (error "already at outermost containing token")))
- ))
-
-(defun wisi-goto-containing-paren (cache)
- "Move point to just after the open-paren containing CACHE.
-Return cache for paren, or nil if no containing paren."
- (while (and cache
- (not (eq (wisi-cache-class cache) 'open-paren)))
- (setq cache (wisi-goto-containing cache)))
- (when cache
- (forward-char 1))
- cache)
-
-(defun wisi-goto-start (cache)
- "Move point to containing ancestor of CACHE that has class statement-start.
-Return start cache."
- ;; cache nil at bob, or on cache in partially parsed statement
- (while (and cache
- (not (eq (wisi-cache-class cache) 'statement-start)))
- (setq cache (wisi-goto-containing cache)))
- cache)
-
-(defun wisi-goto-end-1 (cache)
- (goto-char (wisi-cache-end cache)))
-
-(defun wisi-goto-statement-start ()
- "Move point to token at start of statement point is in or after.
-Return start cache."
- (interactive)
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (wisi-goto-start (or (wisi-get-cache (point))
- (wisi-backward-cache))))
-
-(defun wisi-goto-statement-end ()
- "Move point to token at end of statement point is in or before."
- (interactive)
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (let ((cache (or (wisi-get-cache (point))
- (wisi-forward-cache))))
- (when (wisi-cache-end cache)
- ;; nil when cache is statement-end
- (wisi-goto-end-1 cache))
- ))
-
-(defun wisi-next-statement-cache (cache)
- "Move point to CACHE-next, return cache; error if nil."
- (when (not (markerp (wisi-cache-next cache)))
- (error "no next statement cache"))
- (goto-char (wisi-cache-next cache))
- (wisi-get-cache (point)))
-
-(defun wisi-prev-statement-cache (cache)
- "Move point to CACHE-prev, return cache; error if nil."
- (when (not (markerp (wisi-cache-prev cache)))
- (error "no prev statement cache"))
- (goto-char (wisi-cache-prev cache))
- (wisi-get-cache (point)))
-
-;;;; indentation
-
-(defun wisi-comment-indent ()
- "For `comment-indent-function'. Indent single line comment to
-the comment on the previous line."
- ;; Called from `comment-indent', either to insert a new comment, or
- ;; to indent the first line of an existing one. In either case, the
- ;; comment may be after code on the same line. For an existing
- ;; comment, point is at the start of the starting delimiter.
- (or
- (save-excursion
- ;; Check for a preceding comment line; fail if comment follows code.
- (when (forward-comment -1)
- ;; For the case:
- ;;
- ;; code;-- comment
- ;;
- ;; point is on '--', and 'forward-comment' does not move point,
- ;; returns nil.
- (when (looking-at comment-start)
- (current-column))))
-
- (save-excursion
- (back-to-indentation)
- (if (looking-at comment-start)
- ;; An existing comment, no code preceding comment, and
- ;; no comment on preceding line. Return nil, so
- ;; `comment-indent' will call `indent-according-to-mode'
- nil
-
- ;; A comment after code on the same line.
- comment-column))
- ))
-
-(defun wisi-indent-statement ()
- "Indent region given by `wisi-goto-start', `wisi-cache-end'."
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
-
- (save-excursion
- (let ((cache (or (wisi-get-cache (point))
- (wisi-backward-cache))))
- (when cache
- ;; can be nil if in header comment
- (let ((start (progn (wisi-goto-start cache) (point)))
- (end (if (wisi-cache-end cache)
- ;; nil when cache is statement-end
- (wisi-cache-end cache)
- (point))))
- (indent-region start end)
- ))
- )))
-
-(defvar-local wisi-indent-calculate-functions nil
- "Functions to compute indentation special cases.
-Called with point at current indentation of a line; return
-indentation column, or nil if function does not know how to
-indent that line. Run after parser indentation, so other lines
-are indented correctly.")
-
-(defvar-local wisi-post-indent-fail-hook
- "Function to reindent portion of buffer.
-Called from `wisi-indent-region' when a parse succeeds after
-failing; assumes user was editing code that is now syntactically
-correct. Must leave point at indentation of current line.")
-
-(defvar-local wisi-indent-failed nil
- "Non-nil when wisi-indent-region fails due to parse failing; cleared when
indent succeeds.")
-
-(defvar-local wisi-indent-region-fallback 'wisi-indent-region-fallback-default
- "Function to compute indent for lines in region when wisi parse fails.
-Called with BEGIN END.")
-
-(defun wisi-indent-region-fallback-default (begin end)
- ;; Assume there is no indent info at point; user is editing. Indent
- ;; to previous lines.
- (goto-char begin)
- (forward-line -1);; safe at bob
- (back-to-indentation)
- (let ((col (current-column)))
- (while (and (not (eobp))
- (< (point) end))
- (forward-line 1)
- (indent-line-to col)
- (when (bobp)
- ;; single line in buffer; terminate loop
- (goto-char (point-max))))))
-
-(defun wisi-list-memq (a b)
- "Return non-nil if any member of A is a memq of B."
- (let ((temp (copy-sequence a))
- result)
- (while (and (not result)
- temp)
- (when (memq (pop temp) b)
- (setq result t)))
- result))
-
-(defun wisi--get-cached-indent (begin end)
- "Return cached indent for point (must be bol), after correcting
-for parse errors. BEGIN, END is the parsed region."
- (let ((indent (get-text-property (1- (point)) 'wisi-indent)))
- (unless indent
- (error "nil indent for line %d" (line-number-at-pos (point))))
- (when (and (wisi-partial-parse-p begin end)
- (< 0 (length (wisi-parser-parse-errors wisi--parser))))
- (dolist (err (wisi-parser-parse-errors wisi--parser))
- (dolist (repair (wisi--parse-error-repair err))
- ;; point is at bol; error pos may be at first token on same line.
- (save-excursion
- (back-to-indentation)
- (when (>= (point) (wisi--parse-error-repair-pos repair))
- (setq indent (max 0 (wisi-parse-adjust-indent wisi--parser indent
repair))))
- ))))
- indent))
-
-(defun wisi-indent-region (begin end &optional indent-blank-lines)
- "For `indent-region-function', using the wisi indentation engine.
-If INDENT-BLANK-LINES is non-nil, also indent blank lines (for use as
-`indent-line-function')."
- (when (< 0 wisi-debug)
- (message "wisi-indent-region %d %d"
- (wisi-safe-marker-pos begin)
- (wisi-safe-marker-pos end)))
-
- (let ((wisi--parse-action 'indent)
- (parse-required nil)
- (end-mark (copy-marker end))
- (prev-indent-failed wisi-indent-failed))
-
- (wisi--check-change)
-
- ;; BEGIN is inclusive; END is exclusive.
- (save-excursion
- (goto-char begin)
- (setq begin (line-beginning-position))
-
- (when (bobp) (forward-line))
- (while (and (not parse-required)
- (or (and (= begin end) (= (point) end))
- (< (point) end))
- (not (eobp)))
- (unless (get-text-property (1- (point)) 'wisi-indent)
- (setq parse-required t))
- (forward-line))
- )
-
- ;; A parse either succeeds and sets the indent cache on all
- ;; lines in the parsed region, or fails and leaves valid caches
- ;; untouched.
- (when (and parse-required
- (or (not wisi-parse-failed)
- (wisi-parse-try 'indent)))
-
- (wisi-set-parse-try nil)
-
- (wisi--run-parse begin end)
-
- ;; If there were errors corrected, the indentation is
- ;; potentially ambiguous; see
- ;; test/ada_mode-interactive_2.adb. Or it was a partial parse,
- ;; where errors producing bad indent are pretty much expected.
- (unless (wisi-partial-parse-p begin end)
- (setq wisi-indent-failed (< 0 (+ (length (wisi-parser-lexer-errors
wisi--parser))
- (length (wisi-parser-parse-errors
wisi--parser))))))
- )
-
- (if wisi-parse-failed
- (progn
- ;; primary indent failed
- (setq wisi-indent-failed t)
- (when (functionp wisi-indent-region-fallback)
- (when (< 0 wisi-debug)
- (message "wisi-indent-region fallback"))
- (funcall wisi-indent-region-fallback begin end)))
-
- (save-excursion
- ;; Apply cached indents.
- (goto-char begin)
- (let ((wisi-indenting-p t))
- (while (and (not (eobp))
- (or (and (= begin end) (= (point) end))
- (< (point) end-mark))) ;; end-mark is exclusive
- (when (or indent-blank-lines (not (eolp)))
- ;; ’indent-region’ doesn’t indent an empty line; ’indent-line’
does
- (let ((indent (if (bobp) 0 (wisi--get-cached-indent begin end))))
- (indent-line-to indent))
- )
- (forward-line 1))
-
- ;; Run wisi-indent-calculate-functions
- (when wisi-indent-calculate-functions
- (goto-char begin)
- (while (and (not (eobp))
- (< (point) end-mark))
- (back-to-indentation)
- (let ((indent
- (run-hook-with-args-until-success
'wisi-indent-calculate-functions)))
- (when indent
- (indent-line-to indent)))
-
- (forward-line 1)))
- )
-
- (when
- (and prev-indent-failed
- (not wisi-indent-failed))
- ;; Previous parse failed or indent was potentially
- ;; ambiguous, this one is not.
- (goto-char end-mark)
- (when (< 0 wisi-debug)
- (message "wisi-indent-region post-parse-fail-hook"))
- (run-hooks 'wisi-post-indent-fail-hook))
- ))
- ))
-
-(defun wisi-indent-line ()
- "For `indent-line-function'."
- (let ((savep (copy-marker (point)))
- (to-indent nil))
- (back-to-indentation)
- (when (>= (point) savep)
- (setq to-indent t))
-
- (wisi-indent-region (line-beginning-position) (line-end-position) t)
-
- (goto-char savep)
- (when to-indent (back-to-indentation))
- ))
-
-(defun wisi-repair-error-1 (data)
- "Repair error reported in DATA (a ’wisi--parse-error’ or
’wisi--lexer-error’)"
- (let ((wisi--parse-action 'navigate) ;; tell wisi-forward-token not to
compute indent stuff.
- tok-2)
- (cond
- ((wisi--lexer-error-p data)
- (goto-char (1+ (wisi--lexer-error-pos data)))
- (insert (wisi--lexer-error-inserted data)))
- ((wisi--parse-error-p data)
- (dolist (repair (wisi--parse-error-repair data))
- (goto-char (wisi--parse-error-repair-pos repair))
- (dolist (tok-1 (wisi--parse-error-repair-deleted repair))
- (setq tok-2 (wisi-forward-token))
- (if (eq tok-1 (wisi-tok-token tok-2))
- (delete-region (car (wisi-tok-region tok-2)) (cdr
(wisi-tok-region tok-2)))
- (error "mismatched tokens: %d: parser %s, buffer %s %s"
- (point) tok-1 (wisi-tok-token tok-2) (wisi-tok-region
tok-2))))
-
- (dolist (id (wisi--parse-error-repair-inserted repair))
- (insert (cdr (assoc id (wisi-elisp-lexer-id-alist wisi--lexer))))
- (insert " "))
- ))
- )))
-
-(defun wisi-repair-error ()
- "Repair the current error."
- (interactive)
- (let ((wisi-inhibit-parse t)) ;; don’t let the error list change while we
are processing it.
- (if (= 1 (+ (length (wisi-parser-lexer-errors wisi--parser))
- (length (wisi-parser-parse-errors wisi--parser))))
- (progn
- (wisi-goto-error)
- (wisi-repair-error-1 (or (car (wisi-parser-lexer-errors wisi--parser))
- (car (wisi-parser-parse-errors
wisi--parser)))))
- (if (buffer-live-p wisi-error-buffer)
- (let ((err
- (with-current-buffer wisi-error-buffer
- (get-text-property (point) 'wisi-error-data))))
- (wisi-repair-error-1 err))
- (error "no current error found")
- ))))
-
-(defun wisi-repair-errors (&optional beg end)
- "Repair errors reported by last parse.
-If non-nil, only repair errors in BEG END region."
- (interactive)
- (let ((wisi-inhibit-parse t)) ;; don’t let the error list change while we
are processing it.
- (dolist (data (wisi-parser-lexer-errors wisi--parser))
- (when (or (null beg)
- (and (not (= 0 (wisi--lexer-error-inserted data)))
- (wisi--lexer-error-pos data)
- (<= beg (wisi--lexer-error-pos data))
- (<= (wisi--lexer-error-pos data) end)))
- (wisi-repair-error-1 data)))
-
- (dolist (data (wisi-parser-parse-errors wisi--parser))
- (when (or (null beg)
- (and (wisi--parse-error-pos data)
- (<= beg (wisi--parse-error-pos data))
- (<= (wisi--parse-error-pos data) end)))
- (wisi-repair-error-1 data)))
- ))
-
-;;;; debugging
-
-(defun wisi-show-region (string)
- (interactive "Mregion: ")
- (when (not (= ?\( (aref string 0)))
- (setq string (concat "(" string ")")))
-
- (let ((region (read string)))
- (cond
- ((consp (cdr region))
- ;; region is a list; (begin end)
- (set-mark (nth 0 region))
- (goto-char (nth 1 region)))
-
- ((consp region)
- ;; region is a cons; (begin . end)
- (set-mark (car region))
- (goto-char (cdr region)))
- )))
-
-(defun wisi-debug-keys ()
- "Add debug key definitions to `global-map'."
- (interactive)
- (define-key global-map "\M-h" 'wisi-show-containing-or-previous-cache)
- (define-key global-map "\M-i" 'wisi-show-indent)
- (define-key global-map "\M-j" 'wisi-show-cache)
- )
-
-(defun wisi-read-parse-action ()
- "Read a parse action symbol from the minibuffer."
- (intern-soft (completing-read "parse action (indent): " '(face navigate
indent) nil t nil nil 'indent)))
-
-(defun wisi-parse-buffer (&optional parse-action begin end)
- (interactive)
- (unless parse-action
- (setq parse-action (wisi-read-parse-action)))
- (if (use-region-p)
- (progn
- (setq begin (region-beginning))
- (setq end (region-end)))
-
- (unless begin (setq begin (point-min)))
- (unless end (setq end (point-max))))
-
- (wisi-set-parse-try t parse-action)
- (wisi-invalidate-cache parse-action begin)
-
- (cl-ecase parse-action
- (face
- (with-silent-modifications
- (remove-text-properties
- begin end
- (list
- 'font-lock-face nil
- 'fontified nil)))
- (wisi-validate-cache begin end t parse-action)
- (when (fboundp 'font-lock-ensure) (font-lock-ensure))) ;; emacs < 25
-
- (navigate
- (wisi-validate-cache begin end t parse-action))
-
- (indent
- (wisi-indent-region begin end))
- ))
-
-(defun wisi-time (func count &optional report-wait-time)
- "call FUNC COUNT times, show total time"
- (interactive "afunction \nncount ")
-
- (let ((start-time (float-time))
- (start-gcs gcs-done)
- (cum-wait-time 0.0)
- (i 0)
- diff-time
- diff-gcs)
- (while (not (eq (1+ count) (setq i (1+ i))))
- (save-excursion
- (funcall func))
- (when report-wait-time
- (setq cum-wait-time (+ cum-wait-time
(wisi-process--parser-total-wait-time wisi--parser)))))
- (setq diff-time (- (float-time) start-time))
- (setq diff-gcs (- gcs-done start-gcs))
- (if report-wait-time
- (progn
- (message "Total %f seconds, %d gcs; per iteration %f seconds %d gcs
%d responses %f wait"
- diff-time
- diff-gcs
- (/ diff-time count)
- (/ (float diff-gcs) count)
- (wisi-process--parser-response-count wisi--parser)
- (/ cum-wait-time count)))
-
- (message "Total %f seconds, %d gcs; per iteration %f seconds %d gcs"
- diff-time
- diff-gcs
- (/ diff-time count)
- (/ (float diff-gcs) count))
- ))
- nil)
-
-(defun wisi-time-indent-middle-line-cold-cache (count &optional
report-wait-time)
- (goto-char (point-min))
- (forward-line (1- (/ (count-lines (point-min) (point-max)) 2)))
- (let ((cum-wait-time 0.0))
- (wisi-time
- (lambda ()
- (wisi-set-parse-try t 'indent)
- (wisi-invalidate-cache 'indent (point-min))
- (wisi-indent-line)
- (when (wisi-process--parser-p wisi--parser)
- (setq cum-wait-time (+ cum-wait-time
(wisi-process--parser-total-wait-time wisi--parser)))))
- count
- report-wait-time)
- ))
-
-(defun wisi-time-indent-middle-line-warm-cache (count)
- (wisi-set-parse-try t 'indent)
- (wisi-invalidate-cache 'indent (point-min))
- (goto-char (point-min))
- (forward-line (/ (count-lines (point-min) (point-max)) 2))
- (wisi-indent-line)
- (wisi-time #'wisi-indent-line count))
-
-(defun wisi-show-indent ()
- "Show indent cache for current line."
- (interactive)
- (message "%s" (get-text-property (1- (line-beginning-position))
'wisi-indent)))
-
-(defun wisi-show-cache ()
- "Show navigation cache, and applied faces, at point."
- (interactive)
- (message "%s:%s:%s"
- (wisi-get-cache (point))
- (get-text-property (point) 'face)
- (get-text-property (point) 'font-lock-face)
- ))
-
-(defun wisi-show-containing-or-previous-cache ()
- (interactive)
- (let ((cache (wisi-get-cache (point))))
- (if cache
- (message "containing %s" (wisi-goto-containing cache t))
- (message "previous %s" (wisi-backward-cache)))
- ))
-
-;;;;; setup
-
-(cl-defun wisi-setup (&key indent-calculate post-indent-fail parser lexer)
- "Set up a buffer for parsing files with wisi."
- (when wisi--parser
- (wisi-kill-parser))
-
- (setq wisi--parser parser)
- (setq wisi--lexer lexer)
- (setq wisi--cached-regions
- (list
- (cons 'face nil)
- (cons 'navigate nil)
- (cons 'indent nil)))
-
- (setq wisi--parse-try
- (list
- (cons 'face t)
- (cons 'navigate t)
- (cons 'indent t)))
-
- ;; file local variables may have added opentoken, gnatprep
- (setq wisi-indent-calculate-functions (append
wisi-indent-calculate-functions indent-calculate))
- (set (make-local-variable 'indent-line-function) #'wisi-indent-line)
- (set (make-local-variable 'indent-region-function) #'wisi-indent-region)
- (set (make-local-variable 'forward-sexp-function) #'wisi-forward-sexp)
-
- (setq wisi-post-indent-fail-hook post-indent-fail)
- (setq wisi-indent-failed nil)
-
- (add-hook 'before-change-functions #'wisi-before-change 'append t)
- (add-hook 'after-change-functions #'wisi-after-change nil t)
- (setq wisi--change-end (copy-marker (point-min) t))
-
- ;; See comments above on syntax-propertize.
- (when (< emacs-major-version 25) (syntax-propertize (point-max)))
-
- ;; In Emacs >= 26, ‘run-mode-hooks’ (in the major mode function)
- ;; runs ‘hack-local-variables’ after ’*-mode-hooks’; we need
- ;; ‘wisi-post-local-vars’ to run after ‘hack-local-variables’.
- (add-hook 'hack-local-variables-hook 'wisi-post-local-vars nil t)
- )
-
-(defun wisi-post-local-vars ()
- "See wisi-setup."
- (setq hack-local-variables-hook (delq 'wisi-post-local-vars
hack-local-variables-hook))
-
- (unless wisi-disable-face
- (jit-lock-register #'wisi-fontify-region)))
-
-
-(provide 'wisi)
-;;; wisi.el ends here
+;;; wisi.el --- Utilities for implementing an indentation/navigation engine
using a generalized LALR parser -*- lexical-binding:t -*-
+;;
+;; Copyright (C) 2012 - 2019 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
+;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
+;; Keywords: parser
+;; indentation
+;; navigation
+;; Version: 2.1.1
+;; package-requires: ((cl-lib "1.0") (emacs "25.0") (seq "2.20"))
+;; URL: http://stephe-leake.org/ada/wisitoken.html
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;
+
+;;; Commentary:
+
+;;;; History: see NEWS-wisi.text
+;;
+;;;; Design:
+;;
+;; 'wisi' was originally short for "wisent indentation engine", but
+;; now is just a name. wisi was developed to support Emacs ada-mode
+;; 5.0 indentation, font-lock, and navigation, which are parser based.
+;;
+;; The approach to indenting a given token is to parse the buffer,
+;; computing a delta indent at each parse action.
+;;
+;; The parser actions also cache face and navigation information
+;; as text properties on tokens in statements.
+;;
+;; The three reasons to run the parser (indent, face, navigate) occur
+;; at different times (user indent, font-lock, user navigate), so only
+;; the relevant parser actions are run.
+;;
+;; Parsing can be noticeably slow in large files, so sometimes we do a
+;; partial parse, and keep a list of parsed regions.
+;;
+;; Since we have a cache (the text properties), we need to consider
+;; when to invalidate it. Ideally, we invalidate only when a change
+;; to the buffer would change the result of a parse that crosses that
+;; change, or starts after that change. Changes in whitespace
+;; (indentation and newlines) do not affect an Ada parse. Other
+;; languages are sensitive to newlines (Bash for example) or
+;; indentation (Python). Adding comments does not change a parse,
+;; unless code is commented out.
+;;
+;; For navigate, we expect fully accurate results, and can tolerate
+;; one initial delay, so we always parse the entire file.
+;;
+;; For font-lock, we only parse the portion of the file requested by
+;; font-lock, so we keep a list of regions, and edit that list when
+;; the buffer is changed..
+;;
+;; For indenting, we expect fast results, and can tolerate some
+;; inaccuracy until the editing is done, so we allow partial parse. We
+;; cache the indent for each line in a text property on the newline
+;; char preceding the line. `wisi-indent-region' sets the cache on all
+;; the lines computed (part of the buffer in large files), but
+;; performs the indent only on the lines in the indent
+;; region. Subsequent calls to `wisi-indent-region' apply the cached
+;; indents. Non-whitespace edits to the buffer invalidate the indent
+;; caches in the edited region and after. Since we can do partial
+;; parse, we keep a list of parsed regions.
+;;
+;; See `wisi--post-change' for the details of what we check for
+;; invalidating.
+;;
+;;;; Choice of grammar compiler and parser
+;;
+;; There are two other parsing engines available in Emacs:
+;;
+;; - SMIE
+;;
+;; We don't use this because it is designed to parse small snippets
+;; of code. For Ada indentation, we always need to parse the entire
+;; buffer.
+;;
+;; - semantic
+;;
+;; The Ada grammar as given in the Ada language reference manual is
+;; not LALR(1). So we use a generalized parser. In addition, the
+;; semantic lexer is more complex, and gives different information
+;; than we need. Finally, the semantic parser does not support error
+;; correction, and thus fails in most editing situations.
+;;
+;; We use wisitoken wisi-generate to compile BNF to Elisp source, and
+;; wisi-compile-grammar to compile that to the parser table. See
+;; ada-mode info for more information on the developer tools used for
+;; ada-mode and wisi.
+;;
+;; Alternately, to gain speed and error handling, we use wisi-generate
+;; to generate Ada source, and run that in an external process. That
+;; supports error correction while parsing.
+;;
+;;;; syntax-propertize
+;;
+;; `wisi-forward-token' relies on syntax properties, so
+;; `syntax-propertize' must be called on the text to be lexed before
+;; wisi-forward-token is called. Emacs >= 25 calls syntax-propertize
+;; transparently in the low-level lexer functions.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'compile)
+(require 'seq)
+(require 'semantic/lex)
+(require 'wisi-parse-common)
+(require 'wisi-elisp-lexer)
+(require 'wisi-fringe)
+(require 'xref)
+
+(defcustom wisi-size-threshold most-positive-fixnum
+ "Max size (in characters) for using wisi parser results for anything."
+ :type 'integer
+ :group 'wisi
+ :safe 'integerp)
+(make-variable-buffer-local 'wisi-size-threshold)
+
+(defcustom wisi-partial-parse-threshold 100001
+ "Minimum size that will be parsed by each call to the parser.
+A parse is always requested at a point (or on a region); the
+point is first expanded to a start point before the region and an
+end point after the region, that the parser can gracefully
+handle. If the final region covers the entire buffer, a complete
+parse is done. Indent assumes the start point of the parse region
+is properly indented. Most navigate parses ignore this setting
+and parse the whole buffer."
+ :type 'integer
+ :group 'wisi
+ :safe 'integerp)
+(make-variable-buffer-local 'wisi-partial-parse-threshold)
+
+(defvar wisi-inhibit-parse nil
+ "When non-nil, don't run the parser.
+Language code can set this non-nil when syntax is known to be
+invalid temporarily, or when making lots of changes.")
+
+(defcustom wisi-disable-face nil
+ "When non-nil, `wisi-setup' does not enable use of parser for font-lock.
+Useful when debugging parser or parser actions."
+ :type 'boolean
+ :group 'wisi
+ :safe 'booleanp)
+
+(defconst wisi-error-buffer-name "*wisi syntax errors*"
+ "Name of buffer for displaying syntax errors.")
+
+(defvar wisi-error-buffer nil
+ "Buffer for displaying syntax errors.")
+
+(defun wisi-safe-marker-pos (pos)
+ "Return an integer buffer position from POS, an integer or marker"
+ (cond
+ ((markerp pos)
+ (marker-position pos))
+
+ (t pos)))
+
+;;;; token info cache
+
+(defvar-local wisi-parse-failed nil
+ "Non-nil when a recent parse has failed - cleared when parse succeeds.")
+
+(defvar-local wisi--parse-try
+ (list
+ (cons 'face t)
+ (cons 'navigate t)
+ (cons 'indent t))
+ "Non-nil when parse is needed - cleared when parse succeeds.")
+
+(defun wisi-parse-try (&optional parse-action)
+ (cdr (assoc (or parse-action wisi--parse-action) wisi--parse-try)))
+
+(defun wisi-set-parse-try (value &optional parse-action)
+ (setcdr (assoc (or parse-action wisi--parse-action) wisi--parse-try) value))
+
+(defvar-local wisi--cached-regions
+ (list
+ (cons 'face nil)
+ (cons 'navigate nil)
+ (cons 'indent nil))
+ "Alist of lists of regions in buffer where parser text properties are valid.
+Regions in a list are in random order.")
+
+(defun wisi--contained-region (begin end region)
+ "Non-nil if BEGIN and END (buffer positions) are both contained in REGION (a
cons of positions)."
+ ;; We assume begin < end
+ (and (<= (car region) begin)
+ (<= end (cdr region))))
+
+(defun wisi--contained-pos (pos region)
+ "Non-nil if POS (a buffer position) is contained in REGION (a cons of
positions)."
+ (and (<= (car region) pos)
+ (<= pos (cdr region))))
+
+(defun wisi-cache-covers-region (begin end &optional parse-action)
+ "Non-nil if BEGIN END is contained in a parsed region."
+ (let ((region-list (cdr (assoc (or parse-action wisi--parse-action)
wisi--cached-regions)))
+ region)
+ (while (and region-list
+ (not (wisi--contained-region begin end (car region-list))))
+ (pop region-list))
+
+ (when region-list
+ ;; return a nice value for verbosity in wisi-validate-cache
+ (setq region (car region-list))
+ (cons (marker-position (car region)) (marker-position (cdr region))))))
+
+(defun wisi-cache-covers-pos (parse-action pos)
+ "Non-nil if POS is contained in a PARSE-ACTION parsed region."
+ (let ((region-list (cdr (assoc parse-action wisi--cached-regions))))
+ (while (and region-list
+ (not (wisi--contained-pos pos (car region-list))))
+ (pop region-list))
+
+ (when region-list
+ t)))
+
+(defun wisi-cache-contains-pos (parse-action pos)
+ "Non-nil if POS is at or before the end of any PARSE-ACTION parsed region."
+ (let ((region-list (cdr (assoc parse-action wisi--cached-regions)))
+ result)
+ (while (and (not result) region-list)
+ (when (<= pos (cdr (car region-list)))
+ (setq result t))
+ (pop region-list))
+
+ result))
+
+(defun wisi-cache-set-region (region)
+ "Set the cached region list for `wisi--parse-action' to REGION."
+ (setcdr (assoc wisi--parse-action wisi--cached-regions)
+ (list (cons (copy-marker (car region))
+ (copy-marker (cdr region))))))
+
+(defun wisi-cache-add-region (region)
+ "Add REGION to the cached region list for `wisi--parse-action'."
+ (push (cons (copy-marker (car region))
+ (copy-marker (cdr region)))
+ (cdr (assoc wisi--parse-action wisi--cached-regions))))
+
+(defun wisi-cache-delete-regions-after (parse-action pos)
+ "Delete any PARSE-ACTION parsed region at or after POS.
+Truncate any region that overlaps POS."
+ (let ((region-list (cdr (assoc parse-action wisi--cached-regions)))
+ result)
+ (while (and (not result) region-list)
+ (cond
+ ((and (> pos (car (car region-list)))
+ (<= pos (cdr (car region-list))))
+ ;; region contains POS; keep truncated
+ (push (cons (car (car region-list)) (copy-marker pos)) result))
+
+ ((> pos (car (car region-list)))
+ ;; region is entirely before POS; keep
+ (push (car region-list) result))
+
+ ;; else region is entirely after POS; delete
+ )
+
+ (pop region-list))
+ (setcdr (assoc parse-action wisi--cached-regions) result)
+ ))
+
+(defun wisi--delete-face-cache (after)
+ (with-silent-modifications
+ (remove-text-properties after (point-max) '(font-lock-face nil))
+ )
+ (wisi-cache-delete-regions-after 'face after))
+
+(defun wisi--delete-navigate-cache (after)
+ (with-silent-modifications
+ ;; This text property is 'wisi-cache', not 'wisi-navigate', for
+ ;; historical reasons.
+ (remove-text-properties after (point-max) '(wisi-cache nil wisi-name nil))
+ )
+ (wisi-cache-delete-regions-after 'navigate after))
+
+(defun wisi--delete-indent-cache (after)
+ (with-silent-modifications
+ (remove-text-properties after (point-max) '(wisi-indent nil))
+ )
+ (wisi-cache-delete-regions-after 'indent after))
+
+(defun wisi-invalidate-cache (action after)
+ "Invalidate ACTION caches for the current buffer from AFTER to end of
buffer."
+ (when (wisi-cache-contains-pos action after)
+ (when (> wisi-debug 0) (message "wisi-invalidate-cache %s:%s:%d" action
(current-buffer) after))
+ (cond
+ ((eq 'face action)
+ (wisi--delete-face-cache after))
+
+ ((eq 'navigate action)
+ (when (wisi-cache-covers-pos 'navigate after)
+ ;; We goto statement start to ensure that motion within nested
+ ;; structures is properly done (ie prev/next on ’elsif’ is not
+ ;; set by wisi-motion-action if already set by a lower level
+ ;; statement). We don’t do it for ’face or ’indent, because that
+ ;; might require a parse, and they don’t care about nested
+ ;; structures.
+ (save-excursion
+ (goto-char after)
+
+ ;; This is copied from ‘wisi-goto-statement-start’; we can’t
+ ;; call that because it would call ‘wisi-validate-cache’,
+ ;; which would call ‘wisi-invalidate-cache’; infinite loop.
+ ;; If this needed a navigate parse to succeed, we would not
+ ;; get here.
+ (let ((cache (or (wisi-get-cache (point))
+ (wisi-backward-cache))))
+ (cond
+ ((null cache)
+ ;; at bob
+ nil)
+
+ ((eq 'statement-end (wisi-cache-class cache))
+ ;; If the change did affect part of a structure statement,
+ ;; this is a lower level statement. Otherwise, we are
+ ;; invalidating more than necessary; not a problem.
+ (wisi-goto-start cache)
+ (setq cache (wisi-backward-cache))
+ (when cache ;; else bob
+ (wisi-goto-start cache)))
+
+ (t
+ (wisi-goto-start cache))
+ ))
+
+ (setq after (point))))
+ (wisi--delete-navigate-cache after))
+
+ ((eq 'indent action)
+ ;; The indent cache is stored on newline before line being
+ ;; indented. We delete that, because changing text on a line can
+ ;; change the indent of that line.
+ (setq after
+ (save-excursion
+ (goto-char after)
+ (line-beginning-position)))
+ (wisi--delete-indent-cache (max 1 (1- after))))
+ )
+ ))
+
+(defun wisi-reset-parser ()
+ "Force a parse."
+ (interactive)
+ (wisi-invalidate-cache 'indent (point-min))
+ (wisi-invalidate-cache 'face (point-min))
+ (wisi-invalidate-cache 'navigate (point-min))
+ (wisi-set-parse-try t 'indent)
+ (wisi-set-parse-try t 'face)
+ (wisi-set-parse-try t 'navigate)
+ (wisi-fringe-clean))
+
+;; wisi--change-* keep track of buffer modifications.
+;; If wisi--change-end comes before wisi--change-beg, it means there were
+;; no modifications.
+(defvar-local wisi--change-beg most-positive-fixnum
+ "First position where a change may have taken place.")
+
+(defvar-local wisi--change-end nil
+ "Marker pointing to the last position where a change may have taken place.")
+
+(defvar-local wisi--deleted-syntax nil
+ "Worst syntax class of characters deleted in changes.
+One of:
+nil - no deletions since reset
+0 - only whitespace or comment deleted
+2 - some other syntax deleted
+
+Set by `wisi-before-change', used and reset by `wisi--post-change'.")
+
+(defvar-local wisi-indenting-p nil
+ "Non-nil when `wisi-indent-region' is actively indenting.
+Used to ignore whitespace changes in before/after change hooks.")
+
+(defvar-local wisi--parser nil
+ "Choice of wisi parser implementation; a ‘wisi-parser’ object.")
+
+(defvar-local wisi--last-parse-action nil
+ "Last value of `wisi--parse-action' when `wisi-validate-cache' was run.")
+
+(defun wisi-before-change (begin end)
+ "For `before-change-functions'."
+ ;; begin . (1- end) is range of text being deleted
+ (unless wisi-indenting-p
+ ;; We set wisi--change-beg, -end even if only inserting, so we
+ ;; don't have to do it again in wisi-after-change.
+ (setq wisi--change-beg (min wisi--change-beg begin))
+
+ (cond
+ ((null wisi--change-end)
+ (setq wisi--change-end (copy-marker end)))
+
+ ((> end wisi--change-end)
+ ;; `buffer-base-buffer' deals with edits in indirect buffers
+ ;; created by ediff-regions-*
+ (set-marker wisi--change-end end (buffer-base-buffer)))
+ )
+
+ (unless (= begin end)
+ (cond
+ ((or (null wisi--deleted-syntax)
+ (= 0 wisi--deleted-syntax))
+ (save-excursion
+ (if (or (nth 4 (syntax-ppss begin)) ; in comment, moves point to begin
+ (= end (skip-syntax-forward " " end)));; whitespace
+ (setq wisi--deleted-syntax 0)
+ (setq wisi--deleted-syntax 2))))
+
+ (t
+ ;; wisi--deleted-syntax is 2; no change.
+ )
+ ))))
+
+(defun wisi-after-change (begin end _length)
+ "For `after-change-functions'"
+ ;; begin . end is range of text being inserted (empty if equal);
+ ;; length is the size of the deleted text.
+
+ ;; Remove caches on inserted text, which could have caches from
+ ;; anywhere, and are in any case invalid.
+
+ ;; If the insertion changes a word that has wisi fontification,
+ ;; remove fontification from the entire word, so it is all
+ ;; refontified consistently.
+
+ (let (word-begin word-end)
+ (save-excursion
+ (goto-char end)
+ (skip-syntax-forward "w_")
+ (setq word-end (point))
+ (goto-char begin)
+ (skip-syntax-backward "w_")
+ (setq word-begin (point)))
+ (if (get-text-property word-begin 'font-lock-face)
+ (with-silent-modifications
+ (remove-text-properties
+ word-begin word-end
+ '(font-lock-face nil wisi-cache nil wisi-indent nil fontified nil)))
+
+ ;; No point in removing
+ ;; 'fontified here; that's already handled by jit-lock.
+ (with-silent-modifications
+ (remove-text-properties
+ begin end
+ '(font-lock-face nil wisi-cache nil wisi-indent nil))))
+ ))
+
+(defun wisi--post-change (begin end)
+ "Update wisi text properties for changes in region BEG END."
+ ;; (syntax-ppss-flush-cache begin) is in before-change-functions
+
+ (save-excursion
+ (let ((need-invalidate t)
+ (done nil)
+ ;; non-nil if require a parse because the syntax may have
+ ;; changed.
+
+ (begin-state (syntax-ppss begin))
+ (end-state (syntax-ppss end)))
+ ;; (info "(elisp)Parser State")
+ ;; syntax-ppss has moved point to "end"; might be eob.
+
+ ;; consider deletion
+ (cond
+ ((null wisi--deleted-syntax)
+ ;; no deletions
+ )
+
+ ((= 0 wisi--deleted-syntax)
+ ;; Only deleted whitespace; may have joined two words
+ (when
+ (and (= begin end) ;; no insertions
+ (or
+ (= (point-min) begin)
+ (= 0 (syntax-class (syntax-after (1- begin))))
+ (= (point-max) end)
+ (= 0 (syntax-class (syntax-after end)))))
+ ;; More whitespace on at least one side of deletion; did not
+ ;; join two words.
+ (setq need-invalidate nil)
+ (setq done t)
+ ))
+
+ (t
+ ;; wisi--deleted-syntax is 2; need invalidate and parse for all
+ ;; parse actions
+ (setq done t)
+ ))
+
+ (setq wisi--deleted-syntax nil)
+
+ (unless done
+ ;; consider insertion
+ (cond
+ ((= begin end)
+ ;; no insertions
+ nil)
+
+ ((and
+ (nth 3 begin-state);; in string
+ (nth 3 end-state)
+ (= (nth 8 begin-state) (nth 8 end-state)));; no intervening
non-string
+ (setq need-invalidate nil))
+
+ ((and
+ (nth 4 begin-state) ;; in comment
+ (nth 4 end-state)
+ (= (nth 8 begin-state) (nth 8 end-state))) ;; no intervening
non-comment
+
+ (if (and
+ (= 11 (car (syntax-after begin)))
+ (progn (goto-char begin)
+ (skip-syntax-backward "<")
+ (not (= (point) begin))))
+
+ ;; Either inserted last char of a multi-char comment
+ ;; start, or inserted extra comment-start chars.
+ (setq need-invalidate begin)
+ (setq need-invalidate nil)))
+
+ ((and
+ (or
+ (= (point-min) begin)
+ (= 0 (syntax-class (syntax-after (1- begin)))); whitespace
+ (= (point-max) end)
+ (= 0 (syntax-class (syntax-after end))))
+ (progn
+ (goto-char begin)
+ (= (- end begin) (skip-syntax-forward " " end))
+ ))
+ ;; Inserted only whitespace, there is more whitespace on at
+ ;; least one side, and we are not in a comment or string
+ ;; (checked above). This may affect indentation, but not
+ ;; the indentation cache.
+ (setq need-invalidate nil))
+ ))
+
+ (when need-invalidate
+ (wisi-set-parse-try t 'face)
+ (wisi-set-parse-try t 'navigate)
+ (wisi-set-parse-try t 'indent)
+
+ (wisi-invalidate-cache 'face begin)
+ (wisi-invalidate-cache 'navigate begin)
+ (wisi-invalidate-cache 'indent begin))
+ )))
+
+(defun wisi-goto-error ()
+ "Move point to position in last error message (if any)."
+ (cond
+ ((wisi-parser-parse-errors wisi--parser)
+ (let ((data (car (wisi-parser-parse-errors wisi--parser))))
+ (cond
+ ((wisi--parse-error-pos data)
+ (push-mark)
+ (goto-char (wisi--parse-error-pos data)))
+
+ ((string-match ":\\([0-9]+\\):\\([0-9]+\\):" (wisi--parse-error-message
data))
+ (let* ((msg (wisi--parse-error-message data))
+ (line (string-to-number (match-string 1 msg)))
+ (col (string-to-number (match-string 2 msg))))
+ (push-mark)
+ (goto-char (point-min))
+ (condition-case nil
+ (progn
+ ;; line can be wrong if parser screws up, or user edits buffer
+ (forward-line (1- line))
+ (forward-char col))
+ (error
+ ;; just stay at eob.
+ nil))))
+ )))
+ ((wisi-parser-lexer-errors wisi--parser)
+ (push-mark)
+ (goto-char (wisi--lexer-error-pos (car (wisi-parser-lexer-errors
wisi--parser)))))
+ ))
+
+(defun wisi-show-parse-error ()
+ "Show current wisi-parse errors."
+ (interactive)
+ (cond
+ ((or (wisi-parser-lexer-errors wisi--parser)
+ (wisi-parser-parse-errors wisi--parser))
+ (if (and (= 1 (+ (length (wisi-parser-lexer-errors wisi--parser))
+ (length (wisi-parser-parse-errors wisi--parser))))
+ (or (and (wisi-parser-parse-errors wisi--parser)
+ (not (wisi--parse-error-repair (car
(wisi-parser-parse-errors wisi--parser)))))
+ (and (wisi-parser-lexer-errors wisi--parser)
+ (not (wisi--lexer-error-inserted (car
(wisi-parser-lexer-errors wisi--parser)))))))
+ ;; There is exactly one error; if there is error correction
+ ;; information, use a ’compilation’ buffer, so
+ ;; *-fix-compiler-error will call
+ ;; wisi-repair-error. Otherwise, just position cursor at
+ ;; error.
+ (progn
+ (wisi-goto-error)
+ (message (or (and (wisi-parser-parse-errors wisi--parser)
+ (wisi--parse-error-message (car
(wisi-parser-parse-errors wisi--parser))))
+ (and (wisi-parser-lexer-errors wisi--parser)
+ (wisi--lexer-error-message (car
(wisi-parser-lexer-errors wisi--parser)))))
+ ))
+
+ ;; else show all errors in a ’compilation’ buffer
+ (setq wisi-error-buffer (get-buffer-create wisi-error-buffer-name))
+
+ (let ((lexer-errs (nreverse (cl-copy-seq (wisi-parser-lexer-errors
wisi--parser))))
+ (parse-errs (nreverse (cl-copy-seq (wisi-parser-parse-errors
wisi--parser))))
+ (dir default-directory))
+ (with-current-buffer wisi-error-buffer
+ (setq window-size-fixed nil)
+ (compilation-mode)
+ (setq-local compilation-search-path (list dir))
+ (setq default-directory dir)
+ (setq next-error-last-buffer (current-buffer))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ ;; compilation-nex-error-function assumes there is not an
+ ;; error at point-min, so we need a comment.
+ (insert "wisi syntax errors")
+ (newline)
+ (dolist (err lexer-errs)
+ (insert (wisi--lexer-error-message err))
+ (put-text-property (line-beginning-position) (1+
(line-beginning-position)) 'wisi-error-data err)
+ (newline 2))
+ (dolist (err parse-errs)
+ (insert (wisi--parse-error-message err))
+ (put-text-property (line-beginning-position) (1+
(line-beginning-position)) 'wisi-error-data err)
+ (newline 2))
+ (compilation--flush-parse (point-min) (point-max))
+ (compilation--ensure-parse (point-max))
+ (when compilation-filter-hook
+ (let ((compilation-filter-start (point-min)))
+ (run-hooks 'compilation-filter-hook)))
+
+ (setq buffer-read-only t)
+ (goto-char (point-min)))
+
+ (let ((win (display-buffer
+ wisi-error-buffer
+ (cons #'display-buffer-at-bottom
+ (list (cons 'window-height
#'shrink-window-if-larger-than-buffer))))))
+ (set-window-dedicated-p win t))
+
+ (with-current-buffer wisi-error-buffer
+ (setq window-size-fixed t))
+ (next-error))
+ ))
+
+ ((wisi-parse-try wisi--last-parse-action)
+ (message "need parse"))
+
+ (t
+ (message "parse succeeded"))
+ ))
+
+(defun wisi-kill-parser ()
+ "Kill the background process running the parser for the current buffer.
+Usefull if the parser appears to be hung."
+ (interactive)
+ (wisi-parse-kill wisi--parser)
+ ;; also force re-parse
+ (dolist (parse-action '(face navigate indent))
+ (wisi-set-parse-try t parse-action)
+ (wisi-invalidate-cache parse-action (point-min)))
+ )
+
+(defun wisi-partial-parse-p (begin end)
+ (and (wisi-process--parser-p wisi--parser)
+ (not (and (= begin (point-min))
+ (= end (point-max))))
+ (>= (point-max) wisi-partial-parse-threshold)))
+
+(defun wisi--run-parse (begin parse-end)
+ "Run the parser, on at least region BEGIN PARSE-END."
+ (unless (or (buffer-narrowed-p)
+ (= (point-min) (point-max))) ;; some parsers can’t handle an
empty buffer.
+ (let* ((partial-parse-p (wisi-partial-parse-p begin parse-end))
+ (msg (when (> wisi-debug 0)
+ (format "wisi: %sparsing %s %s:%d %d %d ..."
+ (if partial-parse-p "partial " "")
+ wisi--parse-action
+ (buffer-name)
+ begin
+ (if (markerp parse-end) (marker-position parse-end)
parse-end)
+ (line-number-at-pos begin))))
+ (parsed-region nil))
+
+ (when msg
+ (message msg))
+
+ (setq wisi--last-parse-action wisi--parse-action)
+
+ (unless (eq wisi--parse-action 'face)
+ (when (buffer-live-p wisi-error-buffer)
+ (with-current-buffer wisi-error-buffer
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (setq buffer-read-only t))))
+
+ (condition-case-unless-debug err
+ (save-excursion
+ (if partial-parse-p
+ (let ((send-region (wisi-parse-expand-region wisi--parser begin
parse-end)))
+ (setq parsed-region (wisi-parse-current wisi--parser (car
send-region) (cdr send-region) parse-end))
+ (wisi-cache-add-region parsed-region))
+
+ ;; parse full buffer
+ (setq parsed-region (cons (point-min) (point-max)))
+ (wisi-cache-set-region (wisi-parse-current wisi--parser
(point-min) (point-max) (point-max))))
+
+ (when (> wisi-debug 0) (message "... parsed %s" parsed-region))
+ (setq wisi-parse-failed nil))
+ (wisi-parse-error
+ (cl-ecase wisi--parse-action
+ (face
+ ;; Caches set by failed elisp parse are ok, but some parse
+ ;; failures return 'nil' in parse-region.
+ (when (cdr parsed-region)
+ (wisi--delete-face-cache (cdr parsed-region))))
+
+ (navigate
+ ;; elisp parse partially resets caches
+ (wisi--delete-navigate-cache (point-min)))
+
+ (indent
+ ;; parse does not set caches; see `wisi-indent-region'
+ nil))
+ (setq wisi-parse-failed t)
+ ;; parser should have stored this error message in parser-error-msgs
+ )
+ (error
+ ;; parser failed for other reason
+ (setq wisi-parse-failed t)
+ (signal (car err) (cdr err)))
+ )
+
+ (unless partial-parse-p
+ (wisi-fringe-display-errors
+ (append
+ (seq-map (lambda (err) (wisi--lexer-error-pos err))
(wisi-parser-lexer-errors wisi--parser))
+ (seq-map (lambda (err) (wisi--parse-error-pos err))
(wisi-parser-parse-errors wisi--parser)))))
+
+ (when (> wisi-debug 1)
+ (if (or (wisi-parser-lexer-errors wisi--parser)
+ (wisi-parser-parse-errors wisi--parser))
+ (progn
+ (message "%s error" msg)
+ (wisi-goto-error)
+ (error (or (and (wisi-parser-lexer-errors wisi--parser)
+ (wisi--lexer-error-message (car
(wisi-parser-lexer-errors wisi--parser))))
+ (and (wisi-parser-parse-errors wisi--parser)
+ (wisi--parse-error-message (car
(wisi-parser-parse-errors wisi--parser))))
+ )))
+
+ ;; no error
+ (message "%s done" msg))
+ ))))
+
+(defun wisi--check-change ()
+ "Process `wisi--change-beg', `wisi--change-end'.
+`wisi--parse-action' must be bound."
+ (when (and wisi--change-beg
+ wisi--change-end
+ (<= wisi--change-beg wisi--change-end))
+ (wisi--post-change wisi--change-beg (marker-position wisi--change-end))
+ (setq wisi--change-beg most-positive-fixnum)
+ (move-marker wisi--change-end (point-min))
+ ))
+
+(defun wisi-validate-cache (begin end error-on-fail parse-action)
+ "Ensure cached data for PARSE-ACTION is valid in region BEGIN END in current
buffer."
+ (if (and (not wisi-inhibit-parse)
+ (< (point-max) wisi-size-threshold))
+ (let ((wisi--parse-action parse-action))
+ (wisi--check-change)
+
+ ;; Now we can rely on wisi-cache-covers-region
+
+ (if (and (or (not wisi-parse-failed)
+ (wisi-parse-try))
+ (not (wisi-cache-covers-region begin end)))
+ (progn
+ ;; Don't keep retrying failed parse until text changes again.
+ (wisi-set-parse-try nil)
+ (wisi--run-parse begin end))
+
+ (when (> wisi-debug 0)
+ (message "parse %s skipped: parse-failed %s parse-try %s
cache-covers-region %s %s.%s"
+ parse-action
+ wisi-parse-failed
+ (wisi-parse-try)
+ (wisi-cache-covers-region begin end)
+ begin end)))
+
+ ;; We want this error even if we did not try to parse; it means
+ ;; the parse results are not valid.
+ (when (and error-on-fail wisi-parse-failed)
+ (error "parse %s failed" parse-action))
+ )
+ (when (> wisi-debug 0)
+ (message "parse %s skipped inihibit-parse %s wisi-size-threshold %d"
+ parse-action
+ wisi-inhibit-parse
+ wisi-size-threshold))))
+
+(defun wisi-fontify-region (begin end)
+ "For `jit-lock-functions'."
+ (wisi-validate-cache begin end nil 'face))
+
+(defun wisi-get-containing-cache (cache)
+ "Return cache from (wisi-cache-containing CACHE)."
+ (when cache
+ (let ((containing (wisi-cache-containing cache)))
+ (and containing
+ (wisi-get-cache containing)))))
+
+(defun wisi-cache-text (cache)
+ "Return property-less buffer substring designated by cache.
+Point must be at cache."
+ (buffer-substring-no-properties (point) (+ (point) (wisi-cache-last cache))))
+
+;;;; navigation
+
+(defun wisi-forward-find-class (class limit)
+ "Search at point or forward for a token that has a cache with CLASS.
+Return cache, or nil if at end of buffer.
+If LIMIT (a buffer position) is reached, throw an error."
+ (let ((cache (or (wisi-get-cache (point))
+ (wisi-forward-cache))))
+ (while (not (eq class (wisi-cache-class cache)))
+ (setq cache (wisi-forward-cache))
+ (when (>= (point) limit)
+ (error "cache with class %s not found" class)))
+ cache))
+
+(defun wisi-forward-find-token (token limit &optional noerror)
+ "Search forward for TOKEN.
+If point is at a matching token, return that token. TOKEN may be
+a list; stop on any member of the list. Return `wisi-tok'
+struct, or if LIMIT (a buffer position) is reached, then if
+NOERROR is nil, throw an error, if non-nil, return nil."
+ (let ((token-list (cond
+ ((listp token) token)
+ (t (list token))))
+ (tok (wisi-forward-token))
+ (done nil))
+ (while (not (or done
+ (memq (wisi-tok-token tok) token-list)))
+ (setq tok (wisi-forward-token))
+ (when (or (>= (point) limit)
+ (eobp))
+ (goto-char limit)
+ (setq tok nil)
+ (if noerror
+ (setq done t)
+ (error "token %s not found" token))))
+ tok))
+
+(defun wisi-forward-find-cache-token (ids limit)
+ "Search forward for a cache with token in IDS (a list of token ids).
+Return cache, or nil if at LIMIT or end of buffer."
+ (let ((cache (wisi-forward-cache)))
+ (while (and (< (point) limit)
+ (not (eobp))
+ (not (memq (wisi-cache-token cache) ids)))
+ (setq cache (wisi-forward-cache)))
+ cache))
+
+(defun wisi-forward-find-nonterm (nonterm limit)
+ "Search forward for a token that has a cache with NONTERM.
+NONTERM may be a list; stop on any cache that has a member of the list.
+Return cache, or nil if at end of buffer.
+If LIMIT (a buffer position) is reached, throw an error."
+ (let ((nonterm-list (cond
+ ((listp nonterm) nonterm)
+ (t (list nonterm))))
+ (cache (wisi-forward-cache)))
+ (while (not (memq (wisi-cache-nonterm cache) nonterm-list))
+ (setq cache (wisi-forward-cache))
+ (when (>= (point) limit)
+ (error "cache with nonterm %s not found" nonterm)))
+ cache))
+
+(defun wisi-goto-cache-next (cache)
+ (goto-char (wisi-cache-next cache))
+ (wisi-get-cache (point))
+ )
+
+(defun wisi-forward-statement-keyword ()
+ "If not at a cached token, move forward to next
+cache. Otherwise move to cache-next, or cache-end, or next cache
+if both nil. Return cache found."
+ (unless (eobp)
+ (wisi-validate-cache (point-min) (point-max) t 'navigate)
+ (let ((cache (wisi-get-cache (point))))
+ (if (and cache
+ (not (eq (wisi-cache-class cache) 'statement-end)))
+ (let ((next (or (wisi-cache-next cache)
+ (wisi-cache-end cache))))
+ (if next
+ (goto-char next)
+ (wisi-forward-cache)))
+ (wisi-forward-cache))
+ )
+ (wisi-get-cache (point))
+ ))
+
+(defun wisi-backward-statement-keyword ()
+ "If not at a cached token, move backward to prev
+cache. Otherwise move to cache-prev, or prev cache if nil."
+ (wisi-validate-cache (point-min) (point-max) t 'navigate)
+ (let ((cache (wisi-get-cache (point)))
+ prev)
+ (when cache
+ (setq prev (wisi-cache-prev cache))
+ (unless prev
+ (unless (eq 'statement-start (wisi-cache-class cache))
+ (setq prev (wisi-cache-containing cache)))))
+ (if prev
+ (goto-char prev)
+ (wisi-backward-cache))
+ ))
+
+(defun wisi-forward-sexp (&optional arg)
+ "For `forward-sexp-function'."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (cond
+ ((and (> arg 0) (= 4 (syntax-class (syntax-after (point))))) ;; on open
paren
+ (let ((forward-sexp-function nil))
+ (forward-sexp arg)))
+
+ ((and (< arg 0) (= 5 (syntax-class (syntax-after (1- (point)))))) ;; after
close paren
+ (let ((forward-sexp-function nil))
+ (forward-sexp arg)))
+
+ ((and (> arg 0) (= 7 (syntax-class (syntax-after (point))))) ;; on (open)
string quote
+ (let ((forward-sexp-function nil))
+ (forward-sexp arg)))
+
+ ((and (< arg 0) (= 7 (syntax-class (syntax-after (1- (point)))))) ;; after
(close) string quote
+ (let ((forward-sexp-function nil))
+ (forward-sexp arg)))
+
+ (t
+ (dotimes (_i (abs arg))
+ (if (> arg 0)
+ (wisi-forward-statement-keyword)
+ (wisi-backward-statement-keyword))))
+ ))
+
+(defun wisi-goto-containing (cache &optional error)
+ "Move point to containing token for CACHE, return cache at that point.
+If ERROR, throw error when CACHE has no container; else return nil."
+ (cond
+ ((and (markerp (wisi-cache-containing cache))
+
+ (not (= (wisi-cache-containing cache) (point))))
+ ;; This check is only needed if some cache points to itself as a
+ ;; container. Apparently that happend once that I caught in the
+ ;; debugger; emacs hung because we got here in the font-lock
+ ;; timer.
+
+ (goto-char (wisi-cache-containing cache))
+ (wisi-get-cache (point)))
+ (t
+ (when error
+ (error "already at outermost containing token")))
+ ))
+
+(defun wisi-goto-containing-paren (cache)
+ "Move point to just after the open-paren containing CACHE.
+Return cache for paren, or nil if no containing paren."
+ (while (and cache
+ (not (eq (wisi-cache-class cache) 'open-paren)))
+ (setq cache (wisi-goto-containing cache)))
+ (when cache
+ (forward-char 1))
+ cache)
+
+(defun wisi-goto-start (cache)
+ "Move point to containing ancestor of CACHE that has class statement-start.
+Return start cache."
+ ;; cache nil at bob, or on cache in partially parsed statement
+ (while (and cache
+ (not (eq (wisi-cache-class cache) 'statement-start)))
+ (setq cache (wisi-goto-containing cache)))
+ cache)
+
+(defun wisi-goto-end-1 (cache)
+ (goto-char (wisi-cache-end cache)))
+
+(defun wisi-goto-statement-start ()
+ "Move point to token at start of statement point is in or after.
+Return start cache."
+ (interactive)
+ (wisi-validate-cache (point-min) (point-max) t 'navigate)
+ (wisi-goto-start (or (wisi-get-cache (point))
+ (wisi-backward-cache))))
+
+(defun wisi-goto-statement-end ()
+ "Move point to token at end of statement point is in or before."
+ (interactive)
+ (wisi-validate-cache (point-min) (point-max) t 'navigate)
+ (let ((cache (or (wisi-get-cache (point))
+ (wisi-forward-cache))))
+ (when (wisi-cache-end cache)
+ ;; nil when cache is statement-end
+ (wisi-goto-end-1 cache))
+ ))
+
+(defun wisi-next-statement-cache (cache)
+ "Move point to CACHE-next, return cache; error if nil."
+ (when (not (markerp (wisi-cache-next cache)))
+ (error "no next statement cache"))
+ (goto-char (wisi-cache-next cache))
+ (wisi-get-cache (point)))
+
+(defun wisi-prev-statement-cache (cache)
+ "Move point to CACHE-prev, return cache; error if nil."
+ (when (not (markerp (wisi-cache-prev cache)))
+ (error "no prev statement cache"))
+ (goto-char (wisi-cache-prev cache))
+ (wisi-get-cache (point)))
+
+;;;; indentation
+
+(defun wisi-comment-indent ()
+ "For `comment-indent-function'. Indent single line comment to
+the comment on the previous line."
+ ;; Called from `comment-indent', either to insert a new comment, or
+ ;; to indent the first line of an existing one. In either case, the
+ ;; comment may be after code on the same line. For an existing
+ ;; comment, point is at the start of the starting delimiter.
+ (or
+ (save-excursion
+ ;; Check for a preceding comment line; fail if comment follows code.
+ (when (forward-comment -1)
+ ;; For the case:
+ ;;
+ ;; code;-- comment
+ ;;
+ ;; point is on '--', and 'forward-comment' does not move point,
+ ;; returns nil.
+ (when (looking-at comment-start)
+ (current-column))))
+
+ (save-excursion
+ (back-to-indentation)
+ (if (looking-at comment-start)
+ ;; An existing comment, no code preceding comment, and
+ ;; no comment on preceding line. Return nil, so
+ ;; `comment-indent' will call `indent-according-to-mode'
+ nil
+
+ ;; A comment after code on the same line.
+ comment-column))
+ ))
+
+(defun wisi-indent-statement ()
+ "Indent region given by `wisi-goto-start', `wisi-cache-end'."
+ (interactive)
+ (wisi-validate-cache (point-min) (point-max) t 'navigate)
+
+ (save-excursion
+ (let ((cache (or (wisi-get-cache (point))
+ (wisi-backward-cache))))
+ (when cache
+ ;; can be nil if in header comment
+ (let ((start (progn (wisi-goto-start cache) (point)))
+ (end (if (wisi-cache-end cache)
+ ;; nil when cache is statement-end
+ (wisi-cache-end cache)
+ (point))))
+ (indent-region start end)
+ ))
+ )))
+
+(defvar-local wisi-indent-calculate-functions nil
+ "Functions to compute indentation special cases.
+Called with point at current indentation of a line; return
+indentation column, or nil if function does not know how to
+indent that line. Run after parser indentation, so other lines
+are indented correctly.")
+
+(defvar-local wisi-post-indent-fail-hook
+ "Function to reindent portion of buffer.
+Called from `wisi-indent-region' when a parse succeeds after
+failing; assumes user was editing code that is now syntactically
+correct. Must leave point at indentation of current line.")
+
+(defvar-local wisi-indent-failed nil
+ "Non-nil when wisi-indent-region fails due to parse failing; cleared when
indent succeeds.")
+
+(defvar-local wisi-indent-region-fallback 'wisi-indent-region-fallback-default
+ "Function to compute indent for lines in region when wisi parse fails.
+Called with BEGIN END.")
+
+(defun wisi-indent-region-fallback-default (begin end)
+ ;; Assume there is no indent info at point; user is editing. Indent
+ ;; to previous lines.
+ (goto-char begin)
+ (forward-line -1);; safe at bob
+ (back-to-indentation)
+ (let ((col (current-column)))
+ (while (and (not (eobp))
+ (< (point) end))
+ (forward-line 1)
+ (indent-line-to col)
+ (when (bobp)
+ ;; single line in buffer; terminate loop
+ (goto-char (point-max))))))
+
+(defun wisi-list-memq (a b)
+ "Return non-nil if any member of A is a memq of B."
+ (let ((temp (copy-sequence a))
+ result)
+ (while (and (not result)
+ temp)
+ (when (memq (pop temp) b)
+ (setq result t)))
+ result))
+
+(defun wisi--get-cached-indent (begin end)
+ "Return cached indent for point (must be bol), after correcting
+for parse errors. BEGIN, END is the parsed region."
+ (let ((indent (get-text-property (1- (point)) 'wisi-indent)))
+ (if indent
+ (when (and (wisi-partial-parse-p begin end)
+ (< 0 (length (wisi-parser-parse-errors wisi--parser))))
+ (dolist (err (wisi-parser-parse-errors wisi--parser))
+ (dolist (repair (wisi--parse-error-repair err))
+ ;; point is at bol; error pos may be at first token on same line.
+ (save-excursion
+ (back-to-indentation)
+ (when (>= (point) (wisi--parse-error-repair-pos repair))
+ (setq indent (max 0 (wisi-parse-adjust-indent wisi--parser
indent repair))))
+ ))))
+ ;; parse did not compute indent for point. Assume the error will
+ ;; go away soon as the user edits the code, so just return 0.
+ (if (= wisi-debug 0)
+ (setq indent 0)
+ (error "nil indent for line %d" (line-number-at-pos (point)))))
+
+ indent))
+
+(defun wisi-indent-region (begin end &optional indent-blank-lines)
+ "For `indent-region-function', using the wisi indentation engine.
+If INDENT-BLANK-LINES is non-nil, also indent blank lines (for use as
+`indent-line-function')."
+ (when (< 0 wisi-debug)
+ (message "wisi-indent-region %d %d"
+ (wisi-safe-marker-pos begin)
+ (wisi-safe-marker-pos end)))
+
+ (let ((wisi--parse-action 'indent)
+ (parse-required nil)
+ (end-mark (copy-marker end))
+ (prev-indent-failed wisi-indent-failed))
+
+ (wisi--check-change)
+
+ ;; BEGIN is inclusive; END is exclusive.
+ (save-excursion
+ (goto-char begin)
+ (setq begin (line-beginning-position))
+
+ (when (bobp) (forward-line))
+ (while (and (not parse-required)
+ (or (and (= begin end) (= (point) end))
+ (< (point) end))
+ (not (eobp)))
+ (unless (get-text-property (1- (point)) 'wisi-indent)
+ (setq parse-required t))
+ (forward-line))
+ )
+
+ ;; A parse either succeeds and sets the indent cache on all
+ ;; lines in the parsed region, or fails and leaves valid caches
+ ;; untouched.
+ (when (and parse-required
+ (or (not wisi-parse-failed)
+ (wisi-parse-try 'indent)))
+
+ (wisi-set-parse-try nil)
+
+ (wisi--run-parse begin end)
+
+ ;; If there were errors corrected, the indentation is
+ ;; potentially ambiguous; see
+ ;; test/ada_mode-interactive_2.adb. Or it was a partial parse,
+ ;; where errors producing bad indent are pretty much expected.
+ (unless (wisi-partial-parse-p begin end)
+ (setq wisi-indent-failed (< 0 (+ (length (wisi-parser-lexer-errors
wisi--parser))
+ (length (wisi-parser-parse-errors
wisi--parser))))))
+ )
+
+ (if wisi-parse-failed
+ (progn
+ ;; primary indent failed
+ (setq wisi-indent-failed t)
+ (when (functionp wisi-indent-region-fallback)
+ (when (< 0 wisi-debug)
+ (message "wisi-indent-region fallback"))
+ (funcall wisi-indent-region-fallback begin end)))
+
+ (save-excursion
+ ;; Apply cached indents.
+ (goto-char begin)
+ (let ((wisi-indenting-p t))
+ (while (and (not (eobp))
+ (or (and (= begin end) (= (point) end))
+ (< (point) end-mark))) ;; end-mark is exclusive
+ (when (or indent-blank-lines (not (eolp)))
+ ;; ’indent-region’ doesn’t indent an empty line; ’indent-line’
does
+ (let ((indent (if (bobp) 0 (wisi--get-cached-indent begin end))))
+ (indent-line-to indent))
+ )
+ (forward-line 1))
+
+ ;; Run wisi-indent-calculate-functions
+ (when wisi-indent-calculate-functions
+ (goto-char begin)
+ (while (and (not (eobp))
+ (< (point) end-mark))
+ (back-to-indentation)
+ (let ((indent
+ (run-hook-with-args-until-success
'wisi-indent-calculate-functions)))
+ (when indent
+ (indent-line-to indent)))
+
+ (forward-line 1)))
+ )
+
+ (when
+ (and prev-indent-failed
+ (not wisi-indent-failed))
+ ;; Previous parse failed or indent was potentially
+ ;; ambiguous, this one is not.
+ (goto-char end-mark)
+ (when (< 0 wisi-debug)
+ (message "wisi-indent-region post-parse-fail-hook"))
+ (run-hooks 'wisi-post-indent-fail-hook))
+ ))
+ ))
+
+(defun wisi-indent-line ()
+ "For `indent-line-function'."
+ (let ((savep (copy-marker (point)))
+ (to-indent nil))
+ (back-to-indentation)
+ (when (>= (point) savep)
+ (setq to-indent t))
+
+ (wisi-indent-region (line-beginning-position) (line-end-position) t)
+
+ (goto-char savep)
+ (when to-indent (back-to-indentation))
+ ))
+
+(defun wisi-repair-error-1 (data)
+ "Repair error reported in DATA (a ’wisi--parse-error’ or
’wisi--lexer-error’)"
+ (let ((wisi--parse-action 'navigate) ;; tell wisi-forward-token not to
compute indent stuff.
+ tok-2)
+ (cond
+ ((wisi--lexer-error-p data)
+ (goto-char (1+ (wisi--lexer-error-pos data)))
+ (insert (wisi--lexer-error-inserted data)))
+ ((wisi--parse-error-p data)
+ (dolist (repair (wisi--parse-error-repair data))
+ (goto-char (wisi--parse-error-repair-pos repair))
+ (dolist (tok-1 (wisi--parse-error-repair-deleted repair))
+ (setq tok-2 (wisi-forward-token))
+ (if (eq tok-1 (wisi-tok-token tok-2))
+ (delete-region (car (wisi-tok-region tok-2)) (cdr
(wisi-tok-region tok-2)))
+ (error "mismatched tokens: %d: parser %s, buffer %s %s"
+ (point) tok-1 (wisi-tok-token tok-2) (wisi-tok-region
tok-2))))
+
+ (dolist (id (wisi--parse-error-repair-inserted repair))
+ (insert (cdr (assoc id (wisi-elisp-lexer-id-alist wisi--lexer))))
+ (insert " "))
+ ))
+ )))
+
+(defun wisi-repair-error ()
+ "Repair the current error."
+ (interactive)
+ (let ((wisi-inhibit-parse t)) ;; don’t let the error list change while we
are processing it.
+ (if (= 1 (+ (length (wisi-parser-lexer-errors wisi--parser))
+ (length (wisi-parser-parse-errors wisi--parser))))
+ (progn
+ (wisi-goto-error)
+ (wisi-repair-error-1 (or (car (wisi-parser-lexer-errors wisi--parser))
+ (car (wisi-parser-parse-errors
wisi--parser)))))
+ (if (buffer-live-p wisi-error-buffer)
+ (let ((err
+ (with-current-buffer wisi-error-buffer
+ (get-text-property (point) 'wisi-error-data))))
+ (wisi-repair-error-1 err))
+ (error "no current error found")
+ ))))
+
+(defun wisi-repair-errors (&optional beg end)
+ "Repair errors reported by last parse.
+If non-nil, only repair errors in BEG END region."
+ (interactive)
+ (let ((wisi-inhibit-parse t)) ;; don’t let the error list change while we
are processing it.
+ (dolist (data (wisi-parser-lexer-errors wisi--parser))
+ (when (or (null beg)
+ (and (not (= 0 (wisi--lexer-error-inserted data)))
+ (wisi--lexer-error-pos data)
+ (<= beg (wisi--lexer-error-pos data))
+ (<= (wisi--lexer-error-pos data) end)))
+ (wisi-repair-error-1 data)))
+
+ (dolist (data (wisi-parser-parse-errors wisi--parser))
+ (when (or (null beg)
+ (and (wisi--parse-error-pos data)
+ (<= beg (wisi--parse-error-pos data))
+ (<= (wisi--parse-error-pos data) end)))
+ (wisi-repair-error-1 data)))
+ ))
+
+;;; xref integration
+(defconst wisi-xref-ident-regexp "\\([^<]*\\)\\(?:<\\([0-9]+\\)>\\)?"
+ "Match line number encoded into identifier by
`wisi-xref-identifier-at-point'.")
+
+(defun wisi-xref-ident-make (identifier &optional other-function)
+ (let* ((t-prop (get-text-property 0 'xref-identifier identifier))
+ ;; If t-prop is non-nil: identifier is from
+ ;; identifier-at-point, the desired location is the ’other’
+ ;; (spec/body).
+ ;;
+ ;; If t-prop is nil: identifier is from prompt/completion,
+ ;; the line number may be included in the identifier
+ ;; wrapped in <>, and the desired file is the current file.
+ (ident
+ (if t-prop
+ (substring-no-properties identifier 0 nil)
+ (string-match wisi-xref-ident-regexp identifier)
+ (match-string 1 identifier)
+ ))
+ (file
+ (if t-prop
+ (plist-get t-prop ':file)
+ (buffer-file-name)))
+ (line
+ (if t-prop
+ (plist-get t-prop ':line)
+ (when (match-string 2 identifier)
+ (string-to-number (match-string 2 identifier)))))
+ (column
+ (if t-prop
+ (plist-get t-prop ':column)
+ 0))
+ )
+
+ (if t-prop
+ (funcall other-function ident file line column)
+
+ (list (xref-make ident (xref-make-file-location file (or line 1)
column)))
+ )))
+
+(defun wisi-xref-identifier-at-point ()
+ (let ((ident (thing-at-point 'symbol)))
+ (when ident
+ (put-text-property
+ 0 1
+ 'xref-identifier
+ (list ':file (buffer-file-name)
+ ':line (line-number-at-pos)
+ ':column (current-column))
+ ident)
+ ident)))
+
+(defun wisi-next-name-region ()
+ "Return the next region at or after point with text property 'wisi-name'."
+ (let* ((begin
+ (if (get-text-property (point) 'wisi-name)
+ (point)
+ (next-single-property-change (point) 'wisi-name)))
+ (end (next-single-property-change begin 'wisi-name)))
+ (cons begin end)))
+
+(defun wisi-prev-name-region ()
+ "Return the prev region at or before point with text property 'wisi-name'."
+ (let* ((end
+ (if (get-text-property (point) 'wisi-name)
+ (point)
+ (previous-single-property-change (point) 'wisi-name)))
+ (begin (previous-single-property-change end 'wisi-name)))
+ (cons begin end)))
+
+(defun wisi-next-name ()
+ "Return the text at or after point with text property 'wisi-name'."
+ (let ((region (wisi-next-name-region)))
+ (buffer-substring-no-properties (car region) (cdr region))))
+
+(defun wisi-prev-name ()
+ "Return the text at or before point with text property 'wisi-name'."
+ (let ((region (wisi-prev-name-region)))
+ (buffer-substring-no-properties (car region) (cdr region))))
+
+(defun wisi-xref-identifier-completion-table ()
+ (wisi-validate-cache (point-min) (point-max) t 'navigate)
+ (let ((table nil)
+ (pos (point-min))
+ end-pos)
+ (while (setq pos (next-single-property-change pos 'wisi-name))
+ ;; We can’t store location data in a string text property -
+ ;; it does not survive completion. So we include the line
+ ;; number in the identifier string. This also serves to
+ ;; disambiguate overloaded identifiers.
+ (setq end-pos (next-single-property-change pos 'wisi-name))
+ (push
+ (format "%s<%d>"
+ (buffer-substring-no-properties pos end-pos)
+ (line-number-at-pos pos))
+ table)
+ (setq pos end-pos)
+ )
+ table))
+
+;;;; debugging
+
+(defun wisi-show-region (string)
+ (interactive "Mregion: ")
+ (when (not (= ?\( (aref string 0)))
+ (setq string (concat "(" string ")")))
+
+ (let ((region (read string)))
+ (cond
+ ((consp (cdr region))
+ ;; region is a list; (begin end)
+ (set-mark (nth 0 region))
+ (goto-char (nth 1 region)))
+
+ ((consp region)
+ ;; region is a cons; (begin . end)
+ (set-mark (car region))
+ (goto-char (cdr region)))
+ )))
+
+(defun wisi-debug-keys ()
+ "Add debug key definitions to `global-map'."
+ (interactive)
+ (define-key global-map "\M-h" 'wisi-show-containing-or-previous-cache)
+ (define-key global-map "\M-i" 'wisi-show-indent)
+ (define-key global-map "\M-j" 'wisi-show-cache)
+ )
+
+(defun wisi-read-parse-action ()
+ "Read a parse action symbol from the minibuffer."
+ (intern-soft (completing-read "parse action (indent): " '(face navigate
indent) nil t nil nil 'indent)))
+
+(defun wisi-parse-buffer (&optional parse-action begin end)
+ (interactive)
+ (unless parse-action
+ (setq parse-action (wisi-read-parse-action)))
+ (if (use-region-p)
+ (progn
+ (setq begin (region-beginning))
+ (setq end (region-end)))
+
+ (unless begin (setq begin (point-min)))
+ (unless end (setq end (point-max))))
+
+ (wisi-set-parse-try t parse-action)
+ (wisi-invalidate-cache parse-action begin)
+
+ (cl-ecase parse-action
+ (face
+ (with-silent-modifications
+ (remove-text-properties
+ begin end
+ (list
+ 'font-lock-face nil
+ 'fontified nil)))
+ (wisi-validate-cache begin end t parse-action)
+ (when (fboundp 'font-lock-ensure) (font-lock-ensure))) ;; emacs < 25
+
+ (navigate
+ (wisi-validate-cache begin end t parse-action))
+
+ (indent
+ (wisi-indent-region begin end))
+ ))
+
+(defun wisi-time (func count &optional report-wait-time)
+ "call FUNC COUNT times, show total time"
+ (interactive "afunction \nncount ")
+
+ (let ((start-time (float-time))
+ (start-gcs gcs-done)
+ (cum-wait-time 0.0)
+ (i 0)
+ diff-time
+ diff-gcs)
+ (while (not (eq (1+ count) (setq i (1+ i))))
+ (save-excursion
+ (funcall func))
+ (when report-wait-time
+ (setq cum-wait-time (+ cum-wait-time
(wisi-process--parser-total-wait-time wisi--parser)))))
+ (setq diff-time (- (float-time) start-time))
+ (setq diff-gcs (- gcs-done start-gcs))
+ (if report-wait-time
+ (progn
+ (message "Total %f seconds, %d gcs; per iteration %f seconds %d gcs
%d responses %f wait"
+ diff-time
+ diff-gcs
+ (/ diff-time count)
+ (/ (float diff-gcs) count)
+ (wisi-process--parser-response-count wisi--parser)
+ (/ cum-wait-time count)))
+
+ (message "Total %f seconds, %d gcs; per iteration %f seconds %d gcs"
+ diff-time
+ diff-gcs
+ (/ diff-time count)
+ (/ (float diff-gcs) count))
+ ))
+ nil)
+
+(defun wisi-time-indent-middle-line-cold-cache (count &optional
report-wait-time)
+ (goto-char (point-min))
+ (forward-line (1- (/ (count-lines (point-min) (point-max)) 2)))
+ (let ((cum-wait-time 0.0))
+ (wisi-time
+ (lambda ()
+ (wisi-set-parse-try t 'indent)
+ (wisi-invalidate-cache 'indent (point-min))
+ (wisi-indent-line)
+ (when (wisi-process--parser-p wisi--parser)
+ (setq cum-wait-time (+ cum-wait-time
(wisi-process--parser-total-wait-time wisi--parser)))))
+ count
+ report-wait-time)
+ ))
+
+(defun wisi-time-indent-middle-line-warm-cache (count)
+ (wisi-set-parse-try t 'indent)
+ (wisi-invalidate-cache 'indent (point-min))
+ (goto-char (point-min))
+ (forward-line (/ (count-lines (point-min) (point-max)) 2))
+ (wisi-indent-line)
+ (wisi-time #'wisi-indent-line count))
+
+(defun wisi-show-indent ()
+ "Show indent cache for current line."
+ (interactive)
+ (message "%s" (get-text-property (1- (line-beginning-position))
'wisi-indent)))
+
+(defun wisi-show-cache ()
+ "Show wisi text properties at point."
+ (interactive)
+ (message "%s:%s:%s:%s"
+ (wisi-get-cache (point))
+ (get-text-property (point) 'face)
+ (get-text-property (point) 'font-lock-face)
+ (get-text-property (point) 'wisi-name)
+ ))
+
+(defun wisi-show-containing-or-previous-cache ()
+ (interactive)
+ (let ((cache (wisi-get-cache (point))))
+ (if cache
+ (message "containing %s" (wisi-goto-containing cache t))
+ (message "previous %s" (wisi-backward-cache)))
+ ))
+
+;;;;; setup
+
+(cl-defun wisi-setup (&key indent-calculate post-indent-fail parser lexer)
+ "Set up a buffer for parsing files with wisi."
+ (when wisi--parser
+ (wisi-kill-parser))
+
+ (setq wisi--parser parser)
+ (setq wisi--lexer lexer)
+ (setq wisi--cached-regions
+ (list
+ (cons 'face nil)
+ (cons 'navigate nil)
+ (cons 'indent nil)))
+
+ (setq wisi--parse-try
+ (list
+ (cons 'face t)
+ (cons 'navigate t)
+ (cons 'indent t)))
+
+ ;; file local variables may have added opentoken, gnatprep
+ (setq wisi-indent-calculate-functions (append
wisi-indent-calculate-functions indent-calculate))
+ (set (make-local-variable 'indent-line-function) #'wisi-indent-line)
+ (set (make-local-variable 'indent-region-function) #'wisi-indent-region)
+ (set (make-local-variable 'forward-sexp-function) #'wisi-forward-sexp)
+
+ (setq wisi-post-indent-fail-hook post-indent-fail)
+ (setq wisi-indent-failed nil)
+
+ (add-hook 'before-change-functions #'wisi-before-change 'append t)
+ (add-hook 'after-change-functions #'wisi-after-change nil t)
+ (setq wisi--change-end (copy-marker (point-min) t))
+
+ ;; See comments above on syntax-propertize.
+ (when (< emacs-major-version 25) (syntax-propertize (point-max)))
+
+ ;; In Emacs >= 26, ‘run-mode-hooks’ (in the major mode function)
+ ;; runs ‘hack-local-variables’ after ’*-mode-hooks’; we need
+ ;; ‘wisi-post-local-vars’ to run after ‘hack-local-variables’.
+ (add-hook 'hack-local-variables-hook 'wisi-post-local-vars nil t)
+ )
+
+(defun wisi-post-local-vars ()
+ "See wisi-setup."
+ (setq hack-local-variables-hook (delq 'wisi-post-local-vars
hack-local-variables-hook))
+
+ (unless wisi-disable-face
+ (jit-lock-register #'wisi-fontify-region)))
+
+
+(provide 'wisi)
+;;; wisi.el ends here
diff --git a/wisitoken-bnf-generate.adb b/wisitoken-bnf-generate.adb
index d74b4a5..ca98c75 100644
--- a/wisitoken-bnf-generate.adb
+++ b/wisitoken-bnf-generate.adb
@@ -34,19 +34,18 @@ with WisiToken.BNF.Output_Ada_Common;
with WisiToken.BNF.Output_Ada_Emacs;
with WisiToken.BNF.Output_Elisp;
with WisiToken.BNF.Output_Elisp_Common;
-with WisiToken.Generate.Packrat;
with WisiToken.Generate.LR.LALR_Generate;
with WisiToken.Generate.LR.LR1_Generate;
+with WisiToken.Generate.Packrat;
with WisiToken.Parse.LR.Parser_No_Recover; -- for reading BNF file
with WisiToken.Productions;
+with WisiToken.Syntax_Trees;
with WisiToken.Text_IO_Trace;
with WisiToken_Grammar_Runtime;
with Wisitoken_Grammar_Actions;
with Wisitoken_Grammar_Main;
procedure WisiToken.BNF.Generate
is
- use all type Ada.Containers.Count_Type;
-
procedure Put_Usage
is
use Ada.Text_IO;
@@ -54,7 +53,7 @@ is
begin
-- verbosity meaning is actually determined by output choice;
-- they should be consistent with this description.
- Put_Line (Standard_Error, "version 1.1.0");
+ Put_Line (Standard_Error, "version 1.2.0");
Put_Line (Standard_Error, "wisi-generate [options] {wisi grammar file}");
Put_Line (Standard_Error, "Generate source code implementing a parser
for the grammar.");
New_Line (Standard_Error);
@@ -111,7 +110,9 @@ is
Put_Line (Standard_Error, " 1 - add diagnostics to standard out");
Put_Line (Standard_Error, " 2 - more diagnostics to standard out,
ignore unused tokens, unknown conflicts");
Put_Line (Standard_Error, " --generate ...: override grammar file
%generate directive");
+ Put_Line (Standard_Error, " --output_bnf <file_name> : output
translated BNF source to file_name");
Put_Line (Standard_Error, " --suffix <string>; appended to grammar file
name");
+ Put_Line (Standard_Error, " --ignore_conflicts; ignore excess/unknown
conflicts");
Put_Line (Standard_Error,
" --test_main; generate standalone main program for running
the generated parser, modify file names");
Put_Line (Standard_Error, " --time; output execution time of various
stages");
@@ -121,12 +122,16 @@ is
Language_Name : Ada.Strings.Unbounded.Unbounded_String; -- The
language the grammar defines
Output_File_Name_Root : Ada.Strings.Unbounded.Unbounded_String;
Suffix : Ada.Strings.Unbounded.Unbounded_String;
+ BNF_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Output_BNF : Boolean := False;
+ Ignore_Conflicts : Boolean := False;
Test_Main : Boolean := False;
Command_Generate_Set : Generate_Set_Access; -- override grammar file
declarations
Trace : aliased WisiToken.Text_IO_Trace.Trace
(Wisitoken_Grammar_Actions.Descriptor'Access);
Input_Data : aliased WisiToken_Grammar_Runtime.User_Data_Type;
+ Elisp_Tokens : WisiToken.BNF.Tokens;
Grammar_Parser : WisiToken.Parse.LR.Parser_No_Recover.Parser;
Do_Time : Boolean := False;
@@ -183,6 +188,10 @@ begin
WisiToken.Trace_Generate := Integer'Value (Argument (Arg_Next));
Arg_Next := Arg_Next + 1;
+ elsif Argument (Arg_Next) = "--ignore_conflicts" then
+ Ignore_Conflicts := True;
+ Arg_Next := Arg_Next + 1;
+
elsif Argument (Arg_Next) = "--generate" then
Arg_Next := Arg_Next + 1;
declare
@@ -196,39 +205,46 @@ begin
when Constraint_Error =>
raise User_Error with "invalid value for
generator_algorithm: '" & Argument (Arg_Next) & ";";
end;
- begin
- Tuple.Out_Lang := To_Output_Language (Argument (Arg_Next));
- Arg_Next := Arg_Next + 1;
- end;
-
- loop
- exit when Done;
- declare
- Text : constant String := Argument (Arg_Next);
+ if Tuple.Gen_Alg /= None then
begin
- if Text = "text_rep" then
- Tuple.Text_Rep := True;
- Arg_Next := Arg_Next + 1;
-
- elsif (for some I of Lexer_Image => To_Lower (Text) =
I.all) then
- Tuple.Lexer := To_Lexer (Text);
- Arg_Next := Arg_Next + 1;
-
- elsif (for some I in Valid_Interface =>
- To_Lower (Text) = To_Lower
(Valid_Interface'Image (I)))
- then
- Tuple.Interface_Kind :=
WisiToken.BNF.Valid_Interface'Value (Text);
- Arg_Next := Arg_Next + 1;
-
- else
- Done := True;
- end if;
+ Tuple.Out_Lang := To_Output_Language (Argument
(Arg_Next));
+ Arg_Next := Arg_Next + 1;
end;
- end loop;
+ loop
+ exit when Done;
+ declare
+ Text : constant String := Argument (Arg_Next);
+ begin
+ if Text = "text_rep" then
+ Tuple.Text_Rep := True;
+ Arg_Next := Arg_Next + 1;
+
+ elsif (for some I of Lexer_Image => To_Lower (Text) =
I.all) then
+ Tuple.Lexer := To_Lexer (Text);
+ Arg_Next := Arg_Next + 1;
+
+ elsif (for some I in Valid_Interface =>
+ To_Lower (Text) = To_Lower
(Valid_Interface'Image (I)))
+ then
+ Tuple.Interface_Kind :=
WisiToken.BNF.Valid_Interface'Value (Text);
+ Arg_Next := Arg_Next + 1;
+
+ else
+ Done := True;
+ end if;
+ end;
+ end loop;
+ end if;
Add (Command_Generate_Set, Tuple);
end;
+ elsif Argument (Arg_Next) = "--output_bnf" then
+ Output_BNF := True;
+ Arg_Next := Arg_Next + 1;
+ BNF_File_Name := +Argument (Arg_Next);
+ Arg_Next := Arg_Next + 1;
+
elsif Argument (Arg_Next) = "--suffix" then
Arg_Next := Arg_Next + 1;
Suffix := +Argument (Arg_Next);
@@ -286,28 +302,83 @@ begin
-- cache results in those cases; they only happen in test grammars,
-- which are small.
- procedure Parse_Check (Lexer : in Lexer_Type; Parser : in
Generate_Algorithm)
- is begin
+ procedure Parse_Check
+ (Lexer : in Lexer_Type;
+ Parser : in Generate_Algorithm;
+ Phase : in WisiToken_Grammar_Runtime.Action_Phase)
+ is
+ use all type Ada.Containers.Count_Type;
+ use all type WisiToken_Grammar_Runtime.Action_Phase;
+ use all type WisiToken_Grammar_Runtime.Meta_Syntax;
+ begin
Input_Data.User_Parser := Parser;
Input_Data.User_Lexer := Lexer;
-- Specifying the parser and lexer can change the parsed grammar, due
-- to %if {parser | lexer}.
- Input_Data.Reset;
+ Input_Data.Reset; -- only resets Other data
+
+ Input_Data.Phase := Phase;
Grammar_Parser.Execute_Actions;
- -- Ensures Input_Data.User_{Parser|Lexer} are set if needed.
- if Input_Data.Rule_Count = 0 or Input_Data.Tokens.Rules.Length = 0
then
- raise WisiToken.Grammar_Error with "no rules";
- end if;
+ case Phase is
+ when Meta =>
+ case Input_Data.Meta_Syntax is
+ when Unknown =>
+ Input_Data.Meta_Syntax := BNF_Syntax;
+
+ when BNF_Syntax =>
+ null;
+
+ when EBNF_Syntax =>
+ declare
+ Tree : WisiToken.Syntax_Trees.Tree renames
Grammar_Parser.Parsers.First_State_Ref.Tree;
+ begin
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line ("Translate EBNF tree to BNF");
+ end if;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line ("EBNF tree:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor);
+ Ada.Text_IO.New_Line;
+ end if;
+
+ WisiToken_Grammar_Runtime.Translate_EBNF_To_BNF (Tree,
Input_Data);
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("BNF tree:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor);
+ end if;
+
+ if Output_BNF then
+ WisiToken_Grammar_Runtime.Print_Source (-BNF_File_Name,
Tree, Input_Data);
+ end if;
+
+ if WisiToken.Generate.Error then
+ raise WisiToken.Grammar_Error with "errors during
translating EBNF to BNF: aborting";
+ end if;
+ end;
+ end case;
+ when Other =>
+ if Input_Data.Rule_Count = 0 or Input_Data.Tokens.Rules.Length = 0
then
+ raise WisiToken.Grammar_Error with "no rules";
+ end if;
+ end case;
+ exception
+ when E : WisiToken.Syntax_Error | WisiToken.Parse_Error =>
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error,
Ada.Exceptions.Exception_Message (E));
+ Grammar_Parser.Put_Errors;
+ raise;
end Parse_Check;
begin
- if Command_Generate_Set = null then
- -- Get the first quad from the input file
- Parse_Check (None, None);
+ -- Get the the input file quads, translate EBNF
+ Parse_Check (None, None, WisiToken_Grammar_Runtime.Meta);
+ if Command_Generate_Set = null then
if Input_Data.Generate_Set = null then
raise User_Error with
WisiToken.Generate.Error_Message
@@ -315,10 +386,7 @@ begin
"generate algorithm, output_language, lexer, interface not
specified");
end if;
- -- Input_Data.Generate_Set will be free'd and regenerated if
- -- Parse_Check is called, but the content won't change. So make a
- -- copy.
- Generate_Set := new
WisiToken.BNF.Generate_Set'(Input_Data.Generate_Set.all);
+ Generate_Set := Input_Data.Generate_Set;
else
Generate_Set := Command_Generate_Set;
end if;
@@ -326,11 +394,10 @@ begin
Multiple_Tuples := Generate_Set'Length > 1;
for Tuple of Generate_Set.all loop
-
- Input_Data.User_Parser := Tuple.Gen_Alg;
- Input_Data.User_Lexer := Tuple.Lexer;
-
- Parse_Check (Input_Data.User_Lexer, Input_Data.User_Parser);
+ Parse_Check
+ (Lexer => Tuple.Lexer,
+ Parser => Tuple.Gen_Alg,
+ Phase => WisiToken_Grammar_Runtime.Other);
declare
use Ada.Real_Time;
@@ -339,21 +406,33 @@ begin
Time_End : Time;
Generate_Data : aliased WisiToken.BNF.Generate_Utils.Generate_Data
:=
- WisiToken.BNF.Generate_Utils.Initialize (Input_Data);
+ WisiToken.BNF.Generate_Utils.Initialize (Input_Data,
Ignore_Conflicts);
Packrat_Data : WisiToken.Generate.Packrat.Data
(Generate_Data.Descriptor.First_Terminal,
Generate_Data.Descriptor.First_Nonterminal,
Generate_Data.Descriptor.Last_Nonterminal);
+
+ Do_Parse_Table_File : constant Boolean := WisiToken.Trace_Generate
= 0 and
+ Tuple.Gen_Alg in LALR .. Packrat_Proc;
begin
if not Lexer_Done (Input_Data.User_Lexer) then
Lexer_Done (Input_Data.User_Lexer) := True;
- if Input_Data.User_Lexer = re2c_Lexer then
+ case Input_Data.User_Lexer is
+ when re2c_Lexer =>
WisiToken.BNF.Output_Ada_Common.Create_re2c
(Input_Data, Tuple, Generate_Data, -Output_File_Name_Root);
- end if;
+ if Tuple.Out_Lang = Ada_Emacs_Lang and
Elisp_Tokens.Keywords.Is_Empty then
+ -- elisp code needs keywords for font-lock.
+ Elisp_Tokens.Keywords := Input_Data.Tokens.Keywords;
+ end if;
+ when Elisp_Lexer =>
+ Elisp_Tokens := Input_Data.Tokens;
+ when others =>
+ null;
+ end case;
end if;
- if WisiToken.Trace_Generate = 0 and Tuple.Gen_Alg /= External then
+ if Do_Parse_Table_File then
Create
(Parse_Table_File, Out_File,
-Output_File_Name_Root & "_" & To_Lower
(Generate_Algorithm'Image (Tuple.Gen_Alg)) &
@@ -365,6 +444,10 @@ begin
end if;
case Tuple.Gen_Alg is
+ when None =>
+ -- Just translate EBNF to BNF, done in Parse_Check
+ null;
+
when LALR =>
Time_Start := Clock;
@@ -374,9 +457,11 @@ begin
Generate_Data.Descriptor.all,
Generate_Utils.To_Conflicts
(Generate_Data, Input_Data.Conflicts,
Input_Data.Grammar_Lexer.File_Name),
- Generate_Utils.To_McKenzie_Param
- (Generate_Data, Input_Data.McKenzie_Recover,
Input_Data.Grammar_Lexer.File_Name),
- Put_Parse_Table => True);
+ Generate_Utils.To_McKenzie_Param (Generate_Data,
Input_Data.McKenzie_Recover),
+ Put_Parse_Table => True,
+ Include_Extra => Test_Main,
+ Ignore_Conflicts => Ignore_Conflicts,
+ Partial_Recursion =>
Input_Data.Language_Params.Partial_Recursion);
if Do_Time then
Time_End := Clock;
@@ -400,9 +485,11 @@ begin
Generate_Data.Descriptor.all,
Generate_Utils.To_Conflicts
(Generate_Data, Input_Data.Conflicts,
Input_Data.Grammar_Lexer.File_Name),
- Generate_Utils.To_McKenzie_Param
- (Generate_Data, Input_Data.McKenzie_Recover,
Input_Data.Grammar_Lexer.File_Name),
- Put_Parse_Table => True);
+ Generate_Utils.To_McKenzie_Param (Generate_Data,
Input_Data.McKenzie_Recover),
+ Put_Parse_Table => True,
+ Include_Extra => Test_Main,
+ Ignore_Conflicts => Ignore_Conflicts,
+ Partial_Recursion =>
Input_Data.Language_Params.Partial_Recursion);
if Do_Time then
Time_End := Clock;
@@ -438,7 +525,7 @@ begin
null;
end case;
- if WisiToken.Trace_Generate = 0 and Tuple.Gen_Alg /= External then
+ if Do_Parse_Table_File then
Set_Output (Standard_Output);
Close (Parse_Table_File);
end if;
@@ -455,27 +542,33 @@ begin
-Output_File_Name_Root & "_" &
To_Lower (Generate_Algorithm_Image (Tuple.Gen_Alg).all)
&
"_parse_table.txt",
- Generate_Data.Action_Names.all,
Generate_Data.Check_Names.all);
+ Generate_Data.Action_Names.all,
Generate_Data.Check_Names.all);
end if;
when others =>
null;
end case;
- case Tuple.Out_Lang is
- when Ada_Lang =>
- WisiToken.BNF.Output_Ada
- (Input_Data, -Output_File_Name_Root, Generate_Data,
Packrat_Data, Tuple, Test_Main, Multiple_Tuples);
+ if Tuple.Gen_Alg /= None then
+ case Tuple.Out_Lang is
+ when Ada_Lang =>
+ WisiToken.BNF.Output_Ada
+ (Input_Data, -Output_File_Name_Root, Generate_Data,
Packrat_Data, Tuple, Test_Main,
+ Multiple_Tuples);
- when Ada_Emacs_Lang =>
- WisiToken.BNF.Output_Ada_Emacs
- (Input_Data, -Output_File_Name_Root, Generate_Data,
Packrat_Data, Tuple, Test_Main, Multiple_Tuples,
- -Language_Name);
+ when Ada_Emacs_Lang =>
+ WisiToken.BNF.Output_Ada_Emacs
+ (Input_Data, Elisp_Tokens, -Output_File_Name_Root,
Generate_Data, Packrat_Data, Tuple,
+ Test_Main, Multiple_Tuples, -Language_Name);
- when Elisp_Lang =>
- WisiToken.BNF.Output_Elisp (Input_Data, -Output_File_Name_Root,
Generate_Data, Packrat_Data, Tuple);
+ when Elisp_Lang =>
+ WisiToken.BNF.Output_Elisp (Input_Data,
-Output_File_Name_Root, Generate_Data, Packrat_Data, Tuple);
- end case;
+ end case;
+ if WisiToken.Generate.Error then
+ raise WisiToken.Grammar_Error with "errors: aborting";
+ end if;
+ end if;
end;
end loop;
end;
diff --git a/wisitoken-bnf-generate_grammar.adb
b/wisitoken-bnf-generate_grammar.adb
index 2264dcf..165f00f 100644
--- a/wisitoken-bnf-generate_grammar.adb
+++ b/wisitoken-bnf-generate_grammar.adb
@@ -1,86 +1,86 @@
--- Abstract :
---
--- Output Ada source code to recreate Grammar.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Text_IO; use Ada.Text_IO;
-with WisiToken.Generate;
-with WisiToken.Productions;
-procedure WisiToken.BNF.Generate_Grammar
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Action_Names : in WisiToken.Names_Array_Array)
-is
- use all type Ada.Containers.Count_Type;
- use Ada.Strings.Unbounded;
- use WisiToken.Generate;
- use WisiToken.Productions;
- Text : Unbounded_String;
- Need_Comma : Boolean := False;
-begin
- Indent_Line ("Grammar.Set_First (" & Trimmed_Image (Grammar.First_Index) &
");");
- Indent_Line ("Grammar.Set_Last (" & Trimmed_Image (Grammar.Last_Index) &
");");
-
- for Prod of Grammar loop
- Indent_Line ("declare");
- Indent_Line (" Prod : Instance;");
- Indent_Line ("begin");
- Indent := Indent + 3;
- Indent_Line ("Prod.LHS := " & Trimmed_Image (Prod.LHS) & ";");
- Indent_Line ("Prod.RHSs.Set_First (0);");
- Indent_Line ("Prod.RHSs.Set_Last (" & Trimmed_Image
(Prod.RHSs.Last_Index) & ");");
- for RHS_Index in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
- declare
- RHS : Right_Hand_Side renames Prod.RHSs (RHS_Index);
- begin
- Indent_Line ("declare");
- Indent_Line (" RHS : Right_Hand_Side;");
- Indent_Line ("begin");
- Indent := Indent + 3;
- if RHS.Tokens.Length > 0 then
- Indent_Line ("RHS.Tokens.Set_First (1);");
- Indent_Line ("RHS.Tokens.Set_Last (" & Trimmed_Image (Prod.RHSs
(RHS_Index).Tokens.Last_Index) & ");");
-
- if RHS.Tokens.Length = 1 then
- Indent_Line ("To_Vector ((1 => " & Trimmed_Image (RHS.Tokens
(1)) & "), RHS.Tokens);");
- else
- Need_Comma := False;
- Text := +"To_Vector ((";
- for ID of RHS.Tokens loop
- if Need_Comma then
- Text := Text & ", ";
- else
- Need_Comma := True;
- end if;
- Text := Text & Trimmed_Image (ID);
- end loop;
- Text := Text & "), RHS.Tokens);";
- Indent_Wrap (-Text);
- end if;
- end if;
- if Action_Names (Prod.LHS) /= null and then Action_Names
(Prod.LHS)(RHS_Index) /= null then
- Indent_Line ("RHS.Action := " & Action_Names
(Prod.LHS)(RHS_Index).all & "'Access;");
- end if;
- Indent_Line ("Prod.RHSs (" & Trimmed_Image (RHS_Index) & ") :=
RHS;");
- Indent := Indent - 3;
- Indent_Line ("end;");
- end;
- end loop;
- Indent_Line ("Grammar (" & Trimmed_Image (Prod.LHS) & ") := Prod;");
- Indent := Indent - 3;
- Indent_Line ("end;");
- end loop;
-end WisiToken.BNF.Generate_Grammar;
+-- Abstract :
+--
+-- Output Ada source code to recreate Grammar.
+--
+-- Copyright (C) 2018 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Text_IO; use Ada.Text_IO;
+with WisiToken.Generate;
+with WisiToken.Productions;
+procedure WisiToken.BNF.Generate_Grammar
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Action_Names : in WisiToken.Names_Array_Array)
+is
+ use all type Ada.Containers.Count_Type;
+ use Ada.Strings.Unbounded;
+ use WisiToken.Generate;
+ use WisiToken.Productions;
+ Text : Unbounded_String;
+ Need_Comma : Boolean := False;
+begin
+ Indent_Line ("Grammar.Set_First (" & Trimmed_Image (Grammar.First_Index) &
");");
+ Indent_Line ("Grammar.Set_Last (" & Trimmed_Image (Grammar.Last_Index) &
");");
+
+ for Prod of Grammar loop
+ Indent_Line ("declare");
+ Indent_Line (" Prod : Instance;");
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+ Indent_Line ("Prod.LHS := " & Trimmed_Image (Prod.LHS) & ";");
+ Indent_Line ("Prod.RHSs.Set_First (0);");
+ Indent_Line ("Prod.RHSs.Set_Last (" & Trimmed_Image
(Prod.RHSs.Last_Index) & ");");
+ for RHS_Index in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
+ declare
+ RHS : Right_Hand_Side renames Prod.RHSs (RHS_Index);
+ begin
+ Indent_Line ("declare");
+ Indent_Line (" RHS : Right_Hand_Side;");
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+ if RHS.Tokens.Length > 0 then
+ Indent_Line ("RHS.Tokens.Set_First (1);");
+ Indent_Line ("RHS.Tokens.Set_Last (" & Trimmed_Image (Prod.RHSs
(RHS_Index).Tokens.Last_Index) & ");");
+
+ if RHS.Tokens.Length = 1 then
+ Indent_Line ("To_Vector ((1 => " & Trimmed_Image (RHS.Tokens
(1)) & "), RHS.Tokens);");
+ else
+ Need_Comma := False;
+ Text := +"To_Vector ((";
+ for ID of RHS.Tokens loop
+ if Need_Comma then
+ Text := Text & ", ";
+ else
+ Need_Comma := True;
+ end if;
+ Text := Text & Trimmed_Image (ID);
+ end loop;
+ Text := Text & "), RHS.Tokens);";
+ Indent_Wrap (-Text);
+ end if;
+ end if;
+ if Action_Names (Prod.LHS) /= null and then Action_Names
(Prod.LHS)(RHS_Index) /= null then
+ Indent_Line ("RHS.Action := " & Action_Names
(Prod.LHS)(RHS_Index).all & "'Access;");
+ end if;
+ Indent_Line ("Prod.RHSs (" & Trimmed_Image (RHS_Index) & ") :=
RHS;");
+ Indent := Indent - 3;
+ Indent_Line ("end;");
+ end;
+ end loop;
+ Indent_Line ("Grammar (" & Trimmed_Image (Prod.LHS) & ") := Prod;");
+ Indent := Indent - 3;
+ Indent_Line ("end;");
+ end loop;
+end WisiToken.BNF.Generate_Grammar;
diff --git a/wisitoken-bnf-generate_utils.adb b/wisitoken-bnf-generate_utils.adb
index 8e52ca4..0f84547 100644
--- a/wisitoken-bnf-generate_utils.adb
+++ b/wisitoken-bnf-generate_utils.adb
@@ -2,7 +2,7 @@
--
-- see spec
--
--- Copyright (C) 2014, 2015, 2017, 2018 All Rights Reserved.
+-- Copyright (C) 2014, 2015, 2017 - 2019 All Rights Reserved.
--
-- This program is free software; you can redistribute it and/or
-- modify it under terms of the GNU General Public License as
@@ -47,7 +47,7 @@ package body WisiToken.BNF.Generate_Utils is
function Name_1 (Cursor : in Token_Cursor) return String
is begin
- -- This function is used to compute LR1_descriptor.Image
+ -- This function is used to compute Descriptor.Image
case Cursor.Kind is
when Non_Grammar_Kind =>
declare
@@ -128,7 +128,8 @@ package body WisiToken.BNF.Generate_Utils is
when Not_Found =>
Put_Error
(Error_Message
- (Source_File_Name, 1, "start token '" & (Start_Token) & "' not
found; need %start?"));
+ (Source_File_Name, 1,
+ "start token '" & (Start_Token) & "' not found; need %start?"));
end;
for Rule of Data.Tokens.Rules loop
@@ -138,8 +139,8 @@ package body WisiToken.BNF.Generate_Utils is
LHS : Token_ID; -- not initialized for exception
handler
Action_Names : Names_Array (0 .. Integer
(Rule.Right_Hand_Sides.Length) - 1);
Action_All_Empty : Boolean := True;
- Check_Names : Names_Array (0 .. Integer
(Rule.Right_Hand_Sides.Length) - 1);
- Check_All_Empty : Boolean := True;
+ Check_Names : Names_Array (0 .. Integer
(Rule.Right_Hand_Sides.Length) - 1);
+ Check_All_Empty : Boolean := True;
begin
LHS := Find_Token_ID (Data, -Rule.Left_Hand_Side);
@@ -161,7 +162,7 @@ package body WisiToken.BNF.Generate_Utils is
Tokens.Set_First (I);
Tokens.Set_Last (Integer (Right_Hand_Side.Tokens.Length));
for Token of Right_Hand_Side.Tokens loop
- Tokens (I) := Find_Token_ID (Data, Token);
+ Tokens (I) := Find_Token_ID (Data, -Token.Identifier);
I := I + 1;
end loop;
end if;
@@ -211,7 +212,10 @@ package body WisiToken.BNF.Generate_Utils is
----------
-- Public subprograms, declaration order
- function Initialize (Input_Data : aliased in
WisiToken_Grammar_Runtime.User_Data_Type) return Generate_Data
+ function Initialize
+ (Input_Data : aliased in WisiToken_Grammar_Runtime.User_Data_Type;
+ Ignore_Conflicts : in Boolean := False)
+ return Generate_Data
is
EOI_ID : constant Token_ID := Token_ID
(Count (Input_Data.Tokens.Non_Grammar) + Count
(Input_Data.Tokens.Tokens)) + Token_ID
@@ -235,21 +239,16 @@ package body WisiToken.BNF.Generate_Utils is
do
Result.Descriptor.Case_Insensitive :=
Input_Data.Language_Params.Case_Insensitive;
Result.Descriptor.New_Line_ID := Find_Kind (Result, "new-line");
- Result.Descriptor.Comment_ID := Find_Kind (Result, "comment");
- Result.Descriptor.Left_Paren_ID := Find_Kind (Result,
"left-paren");
- Result.Descriptor.Right_Paren_ID := Find_Kind (Result,
"right-paren");
Result.Descriptor.String_1_ID := Find_Kind (Result,
"string-single");
Result.Descriptor.String_2_ID := Find_Kind (Result,
"string-double");
- Result.Descriptor.Embedded_Quote_Escape_Doubled :=
Input_Data.Language_Params.Embedded_Quote_Escape_Doubled;
-
-- Image set in loop below, which also updates these widths.
Result.Descriptor.Terminal_Image_Width := 0;
Result.Descriptor.Image_Width := 0;
Result.Descriptor.Last_Lookahead :=
(case (Input_Data.User_Parser) is
- when None => raise
SAL.Programmer_Error,
+ when None => Invalid_Token_ID,
when LR1 =>
Result.Descriptor.Last_Terminal,
when LALR =>
Result.Descriptor.First_Nonterminal,
when Packrat_Generate_Algorithm | External => Invalid_Token_ID);
@@ -271,6 +270,7 @@ package body WisiToken.BNF.Generate_Utils is
end loop;
To_Grammar (Result, Input_Data.Grammar_Lexer.File_Name,
-Input_Data.Language_Params.Start_Token);
+ Result.Ignore_Conflicts := Ignore_Conflicts;
end return;
end Initialize;
@@ -416,6 +416,7 @@ package body WisiToken.BNF.Generate_Utils is
end if;
when Terminals_Others =>
+
Cursor :=
(Data => Cursor.Data,
Kind => EOI,
@@ -448,6 +449,7 @@ package body WisiToken.BNF.Generate_Utils is
end if;
when WisiToken_Accept =>
+
Cursor :=
(Data => Cursor.Data,
Kind => Nonterminal,
@@ -462,7 +464,6 @@ package body WisiToken.BNF.Generate_Utils is
when Nonterminal =>
Cursor.Kind := Done;
-
return True;
when Done =>
@@ -574,10 +575,15 @@ package body WisiToken.BNF.Generate_Utils is
when Nonterminal =>
Rule_Lists.Next (Cursor.Nonterminal);
- if not Rule_Lists.Has_Element (Cursor.Nonterminal) then
- Cursor.Kind := Done;
+ if Rule_Lists.Has_Element (Cursor.Nonterminal) then
+ return;
end if;
+ loop
+ exit when Next_Kind_Internal (Cursor, Nonterminals);
+ end loop;
+ return;
+
when Done =>
null;
end case;
@@ -672,14 +678,9 @@ package body WisiToken.BNF.Generate_Utils is
return WisiToken.Generate.LR.Conflict_Lists.List
is
use WisiToken.Generate.LR;
- use all type WisiToken.Parse.LR.Parse_Action_Verbs;
Result : WisiToken.Generate.LR.Conflict_Lists.List;
Conflict : WisiToken.Generate.LR.Conflict;
begin
- Data.Accept_Reduce_Conflict_Count := 0;
- Data.Shift_Reduce_Conflict_Count := 0;
- Data.Reduce_Reduce_Conflict_Count := 0;
-
for Item of Conflicts loop
begin
Conflict :=
@@ -690,21 +691,14 @@ package body WisiToken.BNF.Generate_Utils is
-1,
Find_Token_ID (Data, -Item.On));
- case Conflict.Action_A is
- when Shift =>
- Data.Shift_Reduce_Conflict_Count :=
Data.Shift_Reduce_Conflict_Count + 1;
- when Reduce =>
- Data.Reduce_Reduce_Conflict_Count :=
Data.Reduce_Reduce_Conflict_Count + 1;
- when Accept_It =>
- Data.Accept_Reduce_Conflict_Count :=
Data.Reduce_Reduce_Conflict_Count + 1;
- end case;
-
Result.Append (Conflict);
exception
when E : Not_Found =>
- Put_Error
- (Error_Message
- (Source_File_Name, Item.Source_Line,
Ada.Exceptions.Exception_Message (E)));
+ if not Data.Ignore_Conflicts then
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Item.Source_Line,
Ada.Exceptions.Exception_Message (E)));
+ end if;
end;
end loop;
return Result;
@@ -724,9 +718,8 @@ package body WisiToken.BNF.Generate_Utils is
end To_Nonterminal_ID_Set;
function To_McKenzie_Param
- (Data : aliased in Generate_Data;
- Item : in McKenzie_Recover_Param_Type;
- Source_File_Name : in String)
+ (Data : aliased in Generate_Data;
+ Item : in McKenzie_Recover_Param_Type)
return WisiToken.Parse.LR.McKenzie_Param_Type
is
use Ada.Strings.Unbounded;
@@ -738,28 +731,21 @@ package body WisiToken.BNF.Generate_Utils is
Data.Descriptor.Last_Terminal,
Data.Descriptor.First_Nonterminal,
Data.Descriptor.Last_Nonterminal,
- Insert => (others => Item.Default_Insert),
- Delete => (others => Item.Default_Delete_Terminal),
- Push_Back => (others => Item.Default_Push_Back),
- Ignore_Check_Fail => Item.Ignore_Check_Fail,
- Task_Count => 0,
- Cost_Limit => Item.Cost_Limit,
- Check_Limit => Item.Check_Limit,
- Check_Delta_Limit => Item.Check_Delta_Limit,
- Enqueue_Limit => Item.Enqueue_Limit);
-
- ID : Token_ID;
+ Insert => (others => Item.Default_Insert),
+ Delete => (others =>
Item.Default_Delete_Terminal),
+ Push_Back => (others => Item.Default_Push_Back),
+ Undo_Reduce => (others => Item.Default_Push_Back), --
no separate default for undo_reduce
+ Minimal_Complete_Cost_Delta => Item.Minimal_Complete_Cost_Delta,
+ Fast_Forward => Item.Fast_Forward,
+ Matching_Begin => Item.Matching_Begin,
+ Ignore_Check_Fail => Item.Ignore_Check_Fail,
+ Task_Count => 0,
+ Check_Limit => Item.Check_Limit,
+ Check_Delta_Limit => Item.Check_Delta_Limit,
+ Enqueue_Limit => Item.Enqueue_Limit);
begin
for Pair of Item.Delete loop
- ID := Find_Token_ID (Data, -Pair.Name);
- if ID in Result.Delete'Range then
- Result.Delete (ID) := Natural'Value (-Pair.Value);
- else
- Put_Error
- (Error_Message
- (Source_File_Name, Item.Source_Line, "delete cost is only
valid for terminals (" &
- WisiToken.Image (ID, Data.Descriptor.all) & ")"));
- end if;
+ Result.Delete (Find_Token_ID (Data, -Pair.Name)) := Natural'Value
(-Pair.Value);
end loop;
for Pair of Item.Insert loop
Result.Insert (Find_Token_ID (Data, -Pair.Name)) := Natural'Value
(-Pair.Value);
@@ -767,6 +753,9 @@ package body WisiToken.BNF.Generate_Utils is
for Pair of Item.Push_Back loop
Result.Push_Back (Find_Token_ID (Data, -Pair.Name)) := Natural'Value
(-Pair.Value);
end loop;
+ for Pair of Item.Undo_Reduce loop
+ Result.Undo_Reduce (Find_Token_ID (Data, -Pair.Name)) :=
Natural'Value (-Pair.Value);
+ end loop;
return Result;
end To_McKenzie_Param;
@@ -793,10 +782,6 @@ package body WisiToken.BNF.Generate_Utils is
Integer'Image (Input_Data.Check_Count) & " checks," &
WisiToken.State_Index'Image (Generate_Data.Parser_State_Count) & "
states," &
Integer'Image (Generate_Data.Table_Actions_Count) & " parse
actions");
- Put_Line
- (Integer'Image (Generate_Data.Accept_Reduce_Conflict_Count) & "
accept/reduce conflicts," &
- Integer'Image (Generate_Data.Shift_Reduce_Conflict_Count) & "
shift/reduce conflicts," &
- Integer'Image (Generate_Data.Reduce_Reduce_Conflict_Count) & "
reduce/reduce conflicts");
end Put_Stats;
function Actions_Length (State : in Parse.LR.Parse_State) return Integer
diff --git a/wisitoken-bnf-generate_utils.ads b/wisitoken-bnf-generate_utils.ads
index 7720e21..bcf599f 100644
--- a/wisitoken-bnf-generate_utils.ads
+++ b/wisitoken-bnf-generate_utils.ads
@@ -3,7 +3,7 @@
-- Utilities for translating input file structures to WisiToken
-- structures needed for LALR.Generate.
--
--- Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2014, 2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- The WisiToken package is free software; you can redistribute it
-- and/or modify it under terms of the GNU General Public License as
@@ -35,11 +35,11 @@ package WisiToken.BNF.Generate_Utils is
type Generate_Data is limited record
Tokens : access constant WisiToken.BNF.Tokens;
- Descriptor : access WisiToken.Descriptor;
+ Descriptor : WisiToken.Descriptor_Access;
Grammar : WisiToken.Productions.Prod_Arrays.Vector;
- Action_Names : access Names_Array_Array;
- Check_Names : access Names_Array_Array;
+ Action_Names : Names_Array_Array_Access;
+ Check_Names : Names_Array_Array_Access;
-- Names of subprograms for each grammar semantic action and check;
-- non-null only if there is an action or check in the grammar.
@@ -49,16 +49,17 @@ package WisiToken.BNF.Generate_Utils is
-- The following fields are LR specific; so far, it's not worth
-- splitting them out.
- Conflicts : WisiToken.Generate.LR.Conflict_Lists.List;
- LR_Parse_Table : WisiToken.Parse.LR.Parse_Table_Ptr;
- Table_Actions_Count : Integer := -1; --
parse, not user, actions
- Parser_State_Count : WisiToken.Unknown_State_Index := 0;
- Accept_Reduce_Conflict_Count : Integer := 0;
- Shift_Reduce_Conflict_Count : Integer := 0;
- Reduce_Reduce_Conflict_Count : Integer := 0;
+ Ignore_Conflicts : Boolean := False;
+ Conflicts : WisiToken.Generate.LR.Conflict_Lists.List;
+ LR_Parse_Table : WisiToken.Parse.LR.Parse_Table_Ptr;
+ Table_Actions_Count : Integer := -1; -- parse, not
user, actions
+ Parser_State_Count : WisiToken.Unknown_State_Index := 0;
end record;
- function Initialize (Input_Data : aliased in
WisiToken_Grammar_Runtime.User_Data_Type) return Generate_Data;
+ function Initialize
+ (Input_Data : aliased in WisiToken_Grammar_Runtime.User_Data_Type;
+ Ignore_Conflicts : in Boolean := False)
+ return Generate_Data;
function Find_Token_ID (Data : aliased in Generate_Data; Token : in String)
return Token_ID;
@@ -129,7 +130,7 @@ package WisiToken.BNF.Generate_Utils is
-- Return the token value from the .wy file:
-- Keywords: Keywords (i).value
-- Tokens : Tokens (i).Tokens (j).Value
- -- Rules : "" - they have no Value
+ -- Rules : empty string (they have no Value)
function To_Conflicts
(Data : aliased in out Generate_Data;
@@ -144,9 +145,8 @@ package WisiToken.BNF.Generate_Utils is
return Token_ID_Set;
function To_McKenzie_Param
- (Data : aliased in Generate_Data;
- Item : in McKenzie_Recover_Param_Type;
- Source_File_Name : in String)
+ (Data : aliased in Generate_Data;
+ Item : in McKenzie_Recover_Param_Type)
return WisiToken.Parse.LR.McKenzie_Param_Type;
procedure Count_Actions (Data : in out Generate_Utils.Generate_Data);
diff --git a/wisitoken-bnf-output_ada.adb b/wisitoken-bnf-output_ada.adb
index d27c602..944e216 100644
--- a/wisitoken-bnf-output_ada.adb
+++ b/wisitoken-bnf-output_ada.adb
@@ -58,14 +58,15 @@ is
procedure Create_Ada_Actions_Body
(Action_Names : not null access WisiToken.Names_Array_Array;
Check_Names : not null access WisiToken.Names_Array_Array;
+ Label_Count : in Ada.Containers.Count_Type;
Package_Name : in String)
is
+ use all type Ada.Containers.Count_Type;
use GNAT.Regexp;
use Generate_Utils;
use WisiToken.Generate;
File_Name : constant String := Output_File_Name_Root & "_actions.adb";
- -- No generate_algorithm when Test_Main; the generated actions file is
independent of that.
User_Data_Regexp : constant Regexp := Compile (Symbol_Regexp
("User_Data"), Case_Sensitive => False);
Tree_Regexp : constant Regexp := Compile (Symbol_Regexp ("Tree"),
Case_Sensitive => False);
@@ -82,6 +83,10 @@ is
Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Body_Context));
New_Line;
+ if Label_Count > 0 then
+ Put_Line ("with SAL;");
+ end if;
+
Put_Line ("package body " & Package_Name & " is");
Indent := Indent + 3;
New_Line;
@@ -111,6 +116,42 @@ is
Slice (Action, 1, 5) = "wisi-");
end Is_Elisp;
+ procedure Put_Labels (RHS : in RHS_Type; Line : in String)
+ is
+ Output : array (Rule.Labels.First_Index ..
Rule.Labels.Last_Index) of Boolean := (others => False);
+
+ procedure Update_Output (Label : in String)
+ is begin
+ for I in Rule.Labels.First_Index .. Rule.Labels.Last_Index
loop
+ if Label = Rule.Labels (I) then
+ Output (I) := True;
+ end if;
+ end loop;
+ end Update_Output;
+ begin
+ for I in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index loop
+ if Length (RHS.Tokens (I).Label) > 0 then
+ declare
+ Label : constant String := -RHS.Tokens (I).Label;
+ begin
+ if Match (Line, Compile (Symbol_Regexp (Label),
Case_Sensitive => False)) then
+ Indent_Line
+ (Label & " : constant SAL.Peek_Type :=" &
SAL.Peek_Type'Image (I) & ";");
+ Update_Output (Label);
+ end if;
+ end;
+ end if;
+ end loop;
+
+ for I in Rule.Labels.First_Index .. Rule.Labels.Last_Index loop
+ if not Output (I) and
+ Match (Line, Compile (Symbol_Regexp (-Rule.Labels (I)),
Case_Sensitive => False))
+ then
+ Indent_Line (-Rule.Labels (I) & " : constant
SAL.Base_Peek_Type := SAL.Base_Peek_Type'First;");
+ end if;
+ end loop;
+ end Put_Labels;
+
begin
for RHS of Rule.Right_Hand_Sides loop
if Length (RHS.Action) > 0 and then not Is_Elisp (RHS.Action)
then
@@ -141,7 +182,6 @@ is
Unref_Tokens := False;
end if;
end Check_Unref;
-
begin
Check_Unref (Line);
Indent_Line ("procedure " & Name);
@@ -151,11 +191,12 @@ is
Indent_Line (" Tokens : in
WisiToken.Syntax_Trees.Valid_Node_Index_Array)");
Indent_Line ("is");
+ Indent := Indent + 3;
if Unref_User_Data or Unref_Tree or Unref_Nonterm or
Unref_Tokens then
- Indent_Start (" pragma Unreferenced (");
+ Indent_Start ("pragma Unreferenced (");
if Unref_User_Data then
- Put ((if Need_Comma then ", " else "") &
"User_Data");
+ Put ("User_Data");
Need_Comma := True;
end if;
if Unref_Tree then
@@ -173,6 +214,8 @@ is
Put_Line (");");
end if;
+ Put_Labels (RHS, Line);
+ Indent := Indent - 3;
Indent_Line ("begin");
Indent := Indent + 3;
@@ -192,6 +235,7 @@ is
Unref_Nonterm : constant Boolean := 0 = Index (Line,
"Nonterm");
Unref_Tokens : constant Boolean := 0 = Index (Line,
"Tokens");
Unref_Recover : constant Boolean := 0 = Index (Line,
"Recover_Active");
+ Need_Comma : Boolean := False;
begin
Indent_Line ("function " & Name);
Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
@@ -201,19 +245,32 @@ is
Indent_Line (" return
WisiToken.Semantic_Checks.Check_Status");
Indent_Line ("is");
- if Unref_Lexer then
- Indent_Line (" pragma Unreferenced (Lexer);");
- end if;
- if Unref_Nonterm then
- Indent_Line (" pragma Unreferenced (Nonterm);");
- end if;
- if Unref_Tokens then
- Indent_Line (" pragma Unreferenced (Tokens);");
- end if;
- if Unref_Recover then
- Indent_Line (" pragma Unreferenced
(Recover_Active);");
+ Indent := Indent + 3;
+ if Unref_Lexer or Unref_Nonterm or Unref_Tokens or
Unref_Recover then
+ Indent_Start ("pragma Unreferenced (");
+
+ if Unref_Lexer then
+ Put ("Lexer");
+ Need_Comma := True;
+ end if;
+ if Unref_Nonterm then
+ Put ((if Need_Comma then ", " else "") & "Nonterm");
+ Need_Comma := True;
+ end if;
+ if Unref_Tokens then
+ Put ((if Need_Comma then ", " else "") & "Tokens");
+ Need_Comma := True;
+ end if;
+ if Unref_Recover then
+ Put ((if Need_Comma then ", " else "") &
"Recover_Active");
+ Need_Comma := True;
+ end if;
+ Put_Line (");");
end if;
+ Put_Labels (RHS, Line);
+ Indent := Indent - 3;
+
Indent_Line ("begin");
Indent := Indent + 3;
Indent_Line (Line);
@@ -274,9 +331,7 @@ is
case Common_Data.Generate_Algorithm is
when LR_Generate_Algorithm =>
- if Tuple.Text_Rep then
- Put_Line ("with WisiToken.Productions;");
- end if;
+ null;
when Packrat_Gen =>
Put_Line ("with WisiToken.Parse.Packrat.Generated;");
@@ -351,7 +406,7 @@ is
Unit_Name : constant String := File_Name_To_Ada (Output_File_Name_Root) &
"_" & Generate_Algorithm'Image (Common_Data.Generate_Algorithm) &
"_Run";
- Language_Package_Name : constant String :=
"WisiToken.Parse.LR.McKenzie_Recover." & File_Name_To_Ada
+ Default_Language_Runtime_Package : constant String :=
"WisiToken.Parse.LR.McKenzie_Recover." & File_Name_To_Ada
(Output_File_Name_Root);
File_Name : constant String := To_Lower (Unit_Name) & ".ads";
@@ -369,8 +424,19 @@ is
Put_Line ("with " & Generic_Package_Name & ";");
Put_Line ("with " & Actions_Package_Name & ";");
Put_Line ("with " & Main_Package_Name & ";");
- if Input_Data.Language_Params.Error_Recover then
- Put_Line ("with " & Language_Package_Name & "; use " &
Language_Package_Name & ";");
+ if Input_Data.Language_Params.Error_Recover and
+ Input_Data.Language_Params.Use_Language_Runtime
+ then
+ declare
+ Pkg : constant String :=
+ (if -Input_Data.Language_Params.Language_Runtime_Name = ""
+ then Default_Language_Runtime_Package
+ else -Input_Data.Language_Params.Language_Runtime_Name);
+ begin
+ -- For language-specific names in actions, checks.
+ Put_Line ("with " & Pkg & ";");
+ Put_Line ("use " & Pkg & ";");
+ end;
end if;
Put_Line ("procedure " & Unit_Name & " is new " & Generic_Package_Name);
@@ -381,7 +447,11 @@ is
"_parse_table.txt"",");
end if;
if Input_Data.Language_Params.Error_Recover then
- Put_Line ("Fixes'Access, Use_Minimal_Complete_Actions'Access,
String_ID_Set'Access,");
+ if Input_Data.Language_Params.Use_Language_Runtime then
+ Put_Line ("Fixes'Access, Matching_Begin_Tokens'Access,
String_ID_Set'Access,");
+ else
+ Put_Line ("null, null, null,");
+ end if;
end if;
Put_Line (Main_Package_Name & ".Create_Parser);");
Close (File);
@@ -414,7 +484,8 @@ begin
begin
if Input_Data.Action_Count > 0 or Input_Data.Check_Count > 0 then
-- Some WisiToken tests have no actions or checks.
- Create_Ada_Actions_Body (Generate_Data.Action_Names,
Generate_Data.Check_Names, Actions_Package_Name);
+ Create_Ada_Actions_Body
+ (Generate_Data.Action_Names, Generate_Data.Check_Names,
Input_Data.Label_Count, Actions_Package_Name);
end if;
Create_Ada_Actions_Spec
diff --git a/wisitoken-bnf-output_ada_common.adb
b/wisitoken-bnf-output_ada_common.adb
index cbd36b7..b3d7dea 100644
--- a/wisitoken-bnf-output_ada_common.adb
+++ b/wisitoken-bnf-output_ada_common.adb
@@ -133,23 +133,18 @@ package body WisiToken.BNF.Output_Ada_Common is
Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Spec_Pre));
Indent_Line ("Descriptor : aliased WisiToken.Descriptor :=");
- Indent_Line (" (First_Terminal =>" &
WisiToken.Token_ID'Image (Descriptor.First_Terminal) & ",");
+ Indent_Line (" (First_Terminal =>" & WisiToken.Token_ID'Image
(Descriptor.First_Terminal) & ",");
Indent := Indent + 3;
- Indent_Line ("Last_Terminal =>" &
WisiToken.Token_ID'Image (Descriptor.Last_Terminal) & ",");
- Indent_Line ("First_Nonterminal =>" &
WisiToken.Token_ID'Image (Descriptor.First_Nonterminal) & ",");
- Indent_Line ("Last_Nonterminal =>" &
WisiToken.Token_ID'Image (Descriptor.Last_Nonterminal) & ",");
- Indent_Line ("EOI_ID =>" &
WisiToken.Token_ID'Image (Descriptor.EOI_ID) & ",");
- Indent_Line ("Accept_ID =>" &
WisiToken.Token_ID'Image (Descriptor.Accept_ID) & ",");
- Indent_Line ("Case_Insensitive => " & Image
(Input_Data.Language_Params.Case_Insensitive) & ",");
- Indent_Line ("New_Line_ID =>" &
WisiToken.Token_ID'Image (Descriptor.New_Line_ID) & ",");
- Indent_Line ("Comment_ID =>" &
WisiToken.Token_ID'Image (Descriptor.Comment_ID) & ",");
- Indent_Line ("Left_Paren_ID =>" &
WisiToken.Token_ID'Image (Descriptor.Left_Paren_ID) & ",");
- Indent_Line ("Right_Paren_ID =>" &
WisiToken.Token_ID'Image (Descriptor.Right_Paren_ID) & ",");
- Indent_Line ("String_1_ID =>" &
WisiToken.Token_ID'Image (Descriptor.String_1_ID) & ",");
- Indent_Line ("String_2_ID =>" &
WisiToken.Token_ID'Image (Descriptor.String_2_ID) & ",");
- Indent_Line ("Embedded_Quote_Escape_Doubled => " & Image
-
(Input_Data.Language_Params.Embedded_Quote_Escape_Doubled) & ",");
- Indent_Line ("Image =>");
+ Indent_Line ("Last_Terminal =>" & WisiToken.Token_ID'Image
(Descriptor.Last_Terminal) & ",");
+ Indent_Line ("First_Nonterminal =>" & WisiToken.Token_ID'Image
(Descriptor.First_Nonterminal) & ",");
+ Indent_Line ("Last_Nonterminal =>" & WisiToken.Token_ID'Image
(Descriptor.Last_Nonterminal) & ",");
+ Indent_Line ("EOI_ID =>" & WisiToken.Token_ID'Image
(Descriptor.EOI_ID) & ",");
+ Indent_Line ("Accept_ID =>" & WisiToken.Token_ID'Image
(Descriptor.Accept_ID) & ",");
+ Indent_Line ("Case_Insensitive => " & Image
(Input_Data.Language_Params.Case_Insensitive) & ",");
+ Indent_Line ("New_Line_ID =>" & WisiToken.Token_ID'Image
(Descriptor.New_Line_ID) & ",");
+ Indent_Line ("String_1_ID =>" & WisiToken.Token_ID'Image
(Descriptor.String_1_ID) & ",");
+ Indent_Line ("String_2_ID =>" & WisiToken.Token_ID'Image
(Descriptor.String_2_ID) & ",");
+ Indent_Line ("Image =>");
Indent_Start (" (");
Indent := Indent + 3;
loop
@@ -264,12 +259,12 @@ package body WisiToken.BNF.Output_Ada_Common is
is begin
Indent_Line ("procedure Create_Parser");
if Input_Data.Language_Params.Error_Recover then
- Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
- Indent_Line (" Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;");
- Indent_Line (" Language_Use_Minimal_Complete_Actions : in");
- Indent_Line ("
WisiToken.Parse.LR.Parser.Language_Use_Minimal_Complete_Actions_Access;");
- Indent_Line
- (" Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;");
+ Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
+ Indent_Line (" Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;");
+ Indent_Line (" Language_Matching_Begin_Tokens : in " &
+
"WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;");
+ Indent_Line (" Language_String_ID_Set : in " &
+
"WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;");
else
Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;");
end if;
@@ -418,7 +413,6 @@ package body WisiToken.BNF.Output_Ada_Common is
Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data)
is
use Ada.Strings.Unbounded;
- use all type Ada.Containers.Count_Type;
subtype Nonterminal_ID is Token_ID range
Generate_Data.Grammar.First_Index .. Generate_Data.Grammar.Last_Index;
@@ -461,10 +455,14 @@ package body WisiToken.BNF.Output_Ada_Common is
Put ("Insert", Table.McKenzie_Param.Insert);
Put ("Delete", Table.McKenzie_Param.Delete);
Put ("Push_Back", Table.McKenzie_Param.Push_Back);
+ Put ("Undo_Reduce", Table.McKenzie_Param.Undo_Reduce);
+ Indent_Line
+ ("Minimal_Complete_Cost_Delta => " & Integer'Image
(Table.McKenzie_Param.Minimal_Complete_Cost_Delta) & ",");
+ Indent_Line ("Fast_Forward => " & Integer'Image
(Table.McKenzie_Param.Fast_Forward) & ",");
+ Indent_Line ("Matching_Begin => " & Integer'Image
(Table.McKenzie_Param.Matching_Begin) & ",");
Indent_Line ("Ignore_Check_Fail =>" & Integer'Image
(Table.McKenzie_Param.Ignore_Check_Fail) & ",");
Indent_Line ("Task_Count =>" & System.Multiprocessors.CPU_Range'Image
(Table.McKenzie_Param.Task_Count) & ",");
- Indent_Line ("Cost_Limit =>" & Integer'Image
(Table.McKenzie_Param.Cost_Limit) & ",");
Indent_Line ("Check_Limit =>" & Token_Index'Image
(Table.McKenzie_Param.Check_Limit) & ",");
Indent_Line ("Check_Delta_Limit =>" & Integer'Image
(Table.McKenzie_Param.Check_Delta_Limit) & ",");
Indent_Line ("Enqueue_Limit =>" & Integer'Image
(Table.McKenzie_Param.Enqueue_Limit) & ");");
@@ -472,62 +470,48 @@ package body WisiToken.BNF.Output_Ada_Common is
New_Line;
if Common_Data.Text_Rep then
- Indent_Line ("function Productions return
WisiToken.Productions.Prod_Arrays.Vector");
+ Indent_Line ("function Actions return
WisiToken.Parse.LR.Semantic_Action_Array_Arrays.Vector");
Indent_Line ("is begin");
Indent := Indent + 3;
- Indent_Line ("return Prods : WisiToken.Productions.Prod_Arrays.Vector
do");
+ Indent_Line ("return Acts :
WisiToken.Parse.LR.Semantic_Action_Array_Arrays.Vector do");
Indent := Indent + 3;
Indent_Line
- ("Prods.Set_First (" & Trimmed_Image
(Generate_Data.Grammar.First_Index) & ");");
- Indent_Line
- ("Prods.Set_Last (" & Trimmed_Image
(Generate_Data.Grammar.Last_Index) & ");");
+ ("Acts.Set_First_Last (" & Trimmed_Image
(Generate_Data.Grammar.First_Index) & ", " &
+ Trimmed_Image (Generate_Data.Grammar.Last_Index) & ");");
for I in Nonterminal_ID loop
declare
P : Productions.Instance renames Generate_Data.Grammar (I);
begin
- Indent_Line
- ("Set_Production (Prods (" & Trimmed_Image (P.LHS) & "), " &
- Trimmed_Image (P.LHS) & "," & Integer'Image
(P.RHSs.Last_Index) & ");");
-
- for J in P.RHSs.First_Index .. P.RHSs.Last_Index loop
- Line := +"Set_RHS (Prods (" & Trimmed_Image (P.LHS) & ")," &
Natural'Image (J) & ", (";
- declare
- RHS : Productions.Right_Hand_Side renames P.RHSs (J);
- begin
- if RHS.Tokens.Length = 0 then
- Append ("1 .. 0 => <>");
- elsif RHS.Tokens.Length = 1 then
- Append ("1 => " & Trimmed_Image (RHS.Tokens (1)));
- else
- for I in RHS.Tokens.First_Index ..
RHS.Tokens.Last_Index loop
- Append (Trimmed_Image (RHS.Tokens (I)));
- if I < RHS.Tokens.Last_Index then
- Append (", ");
- end if;
- end loop;
+ if Generate_Data.Action_Names (P.LHS) /= null or
Generate_Data.Check_Names (P.LHS) /= null then
+ Indent_Line
+ ("Acts (" & Trimmed_Image (P.LHS) & ").Set_First_Last (0,"
&
+ Integer'Image (P.RHSs.Last_Index) & ");");
+
+ for J in P.RHSs.First_Index .. P.RHSs.Last_Index loop
+ if (Generate_Data.Action_Names (P.LHS) /= null and then
+ Generate_Data.Action_Names (P.LHS)(J) /= null)
+ or
+ (Generate_Data.Check_Names (P.LHS) /= null and then
+ Generate_Data.Check_Names (P.LHS) /= null)
+ then
+ Indent_Wrap
+ ("Acts (" & Trimmed_Image (P.LHS) & ")(" &
Trimmed_Image (J) & ") := (" &
+ (if Generate_Data.Action_Names (P.LHS) = null
then "null"
+ elsif Generate_Data.Action_Names (P.LHS)(J) =
null then "null"
+ else Generate_Data.Action_Names (P.LHS)(J).all &
"'Access") & ", " &
+ (if Generate_Data.Check_Names (P.LHS) = null then
"null"
+ elsif Generate_Data.Check_Names (P.LHS)(J) =
null then "null"
+ else Generate_Data.Check_Names (P.LHS)(J).all &
"'Access") & ");");
end if;
-
- Append ("), ");
- Append
- ((if Generate_Data.Action_Names (P.LHS) = null then
"null"
- elsif Generate_Data.Action_Names (P.LHS)(J) = null
then "null"
- else Generate_Data.Action_Names (P.LHS)(J).all &
"'Access"));
- Append (", ");
- Append
- ((if Generate_Data.Check_Names (P.LHS) = null then
"null"
- elsif Generate_Data.Check_Names (P.LHS)(J) = null
then "null"
- else Generate_Data.Check_Names (P.LHS)(J).all &
"'Access"));
- end;
- Append (");");
- Indent_Wrap (-Line);
- end loop;
+ end loop;
+ end if;
end;
end loop;
Indent := Indent - 3;
Indent_Line ("end return;");
Indent := Indent - 3;
- Indent_Line ("end Productions;");
+ Indent_Line ("end Actions;");
New_Line;
end if;
end Create_LR_Parser_Core_1;
@@ -536,7 +520,8 @@ package body WisiToken.BNF.Output_Ada_Common is
(Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data)
is
- use all type WisiToken.Parse.LR.All_Parse_Action_Verbs;
+ use all type Ada.Containers.Count_Type;
+ use WisiToken.Parse.LR;
use Ada.Strings.Unbounded;
Table : WisiToken.Parse.LR.Parse_Table_Ptr renames
Generate_Data.LR_Parse_Table;
@@ -566,17 +551,9 @@ package body WisiToken.BNF.Output_Ada_Common is
Declare_Subroutines :
for State_Index in Table.States'Range loop
-
- if Input_Data.Language_Params.Error_Recover then
- Indent_Wrap
- ("Table.States (" & Trimmed_Image (State_Index) & ").Productions
:= WisiToken.To_Vector (" &
- Image (Table.States (State_Index).Productions, Strict =>
True) & ");");
- end if;
-
Actions :
declare
use Ada.Containers;
- use WisiToken.Parse.LR;
Base_Indent : constant Ada.Text_IO.Count := Indent;
Node : Action_Node_Ptr := Table.States
(State_Index).Action_List;
begin
@@ -622,6 +599,7 @@ package body WisiToken.BNF.Output_Ada_Common is
Trimmed_Image (Node.Symbol);
Append (", ");
Append (Trimmed_Image (Action_Node.Item.State));
+ Append (");");
when Reduce | Accept_It =>
Line := +"Add_Action (Table.States (" & Trimmed_Image
(State_Index) & "), " &
@@ -651,18 +629,23 @@ package body WisiToken.BNF.Output_Ada_Common is
else Generate_Data.Check_Names
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
"'Access"));
+ Append (");");
when Parse.LR.Error =>
- Line := +"Add_Error (Table.States (" & Trimmed_Image
(State_Index) & ")";
+ Line := +"Add_Error (Table.States (" & Trimmed_Image
(State_Index) & "));";
end case;
+ Indent_Wrap (-Line);
+ Line_Count := Line_Count + 1;
- Action_Node := Action_Node.Next;
- if Action_Node /= null then
+ loop
+ Action_Node := Action_Node.Next;
+ exit when Action_Node = null;
-- There is a conflict; must be Shift/{Reduce|Accept}
or Reduce/{Reduce|Accept}.
-- The added parameters are the same in either case.
case Action_Node.Item.Verb is
when Reduce | Accept_It =>
- Append (", ");
+ Line := +"Add_Conflict (Table.States (" &
Trimmed_Image (State_Index) & "), " &
+ Trimmed_Image (Node.Symbol) & ", ";
Append (Image (Action_Node.Item.Production) & ",");
Append (Count_Type'Image
(Action_Node.Item.Token_Count) & ", ");
Append
@@ -682,24 +665,23 @@ package body WisiToken.BNF.Output_Ada_Common is
else Generate_Data.Check_Names
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
"'Access"));
+ Indent_Wrap (-Line & ");");
+ Line_Count := Line_Count + 1;
when others =>
- raise SAL.Programmer_Error with "conflict second
action verb: " &
+ raise SAL.Programmer_Error with "invalid conflict
action verb: " &
Parse.LR.Parse_Action_Verbs'Image
(Action_Node.Item.Verb);
end case;
- end if;
+ end loop;
end;
- Indent_Wrap (-Line & ");");
- Line_Count := Line_Count + 1;
- Indent := Base_Indent;
- Node := Node.Next;
+ Indent := Base_Indent;
+ Node := Node.Next;
end loop;
end if;
end Actions;
Gotos :
declare
- use WisiToken.Parse.LR;
Node : Goto_Node_Ptr := Table.States (State_Index).Goto_List;
begin
loop
@@ -712,12 +694,21 @@ package body WisiToken.BNF.Output_Ada_Common is
end loop;
end Gotos;
- if Input_Data.Language_Params.Error_Recover and
- Table.States (State_Index).Minimal_Complete_Action.Verb /=
Parse.LR.Pause
- then
- Indent_Wrap
- ("Table.States (" & Trimmed_Image (State_Index) &
").Minimal_Complete_Action := " &
- WisiToken.Parse.LR.Strict_Image (Table.States
(State_Index).Minimal_Complete_Action) & ";");
+ if Input_Data.Language_Params.Error_Recover then
+ if Table.States (State_Index).Kernel.Length > 0 then
+ Indent_Wrap
+ ("Table.States (" & Trimmed_Image (State_Index) & ").Kernel
:= To_Vector (" &
+ Image (Table.States (State_Index).Kernel, Strict => True)
& ");");
+ end if;
+ if Table.States (State_Index).Minimal_Complete_Actions.Length > 0
then
+ Indent_Wrap
+ ("Table.States (" & Trimmed_Image (State_Index) &
").Minimal_Complete_Actions := To_Vector (" &
+ Strict_Image (Table.States
(State_Index).Minimal_Complete_Actions, Strict => True) & ");");
+ if Table.States
(State_Index).Minimal_Complete_Actions_Recursive then
+ Indent_Wrap
+ ("Table.States (" & Trimmed_Image (State_Index) &
").Minimal_Complete_Actions_Recursive := True;");
+ end if;
+ end if;
end if;
if Line_Count > Lines_Per_Subr then
@@ -765,14 +756,14 @@ package body WisiToken.BNF.Output_Ada_Common is
case Common_Data.Interface_Kind is
when Process =>
if Input_Data.Language_Params.Error_Recover then
- Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
- Indent_Line (" Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;");
- Indent_Line (" Language_Use_Minimal_Complete_Actions : in");
- Indent_Line ("
WisiToken.Parse.LR.Parser.Language_Use_Minimal_Complete_Actions_Access;");
+ Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
+ Indent_Line (" Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;");
+ Indent_Line (" Language_Matching_Begin_Tokens : in " &
+
"WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;");
Indent_Line
(" Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;");
else
- Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;");
+ Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;");
end if;
Indent_Line (" Trace : not null access
WisiToken.Trace'Class;");
Indent_Start (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access");
@@ -798,7 +789,7 @@ package body WisiToken.BNF.Output_Ada_Common is
if Common_Data.Text_Rep then
Create_LR_Parser_Core_1 (Common_Data, Generate_Data);
Indent_Line ("Table : constant Parse_Table_Ptr := Get_Text_Rep");
- Indent_Line (" (Text_Rep_File_Name, McKenzie_Param, Productions);");
+ Indent_Line (" (Text_Rep_File_Name, McKenzie_Param, Actions);");
Indent := Indent - 3;
Indent_Line ("begin");
Indent := Indent + 3;
@@ -841,7 +832,7 @@ package body WisiToken.BNF.Output_Ada_Common is
Indent_Line (" Table,");
if Input_Data.Language_Params.Error_Recover then
Indent_Line (" Language_Fixes,");
- Indent_Line (" Language_Use_Minimal_Complete_Actions,");
+ Indent_Line (" Language_Matching_Begin_Tokens,");
Indent_Line (" Language_String_ID_Set,");
end if;
Indent_Line (" User_Data,");
diff --git a/wisitoken-bnf-output_ada_emacs.adb
b/wisitoken-bnf-output_ada_emacs.adb
index a16d289..ae109fa 100644
--- a/wisitoken-bnf-output_ada_emacs.adb
+++ b/wisitoken-bnf-output_ada_emacs.adb
@@ -40,6 +40,7 @@ with WisiToken.Generate.Packrat;
with WisiToken_Grammar_Runtime;
procedure WisiToken.BNF.Output_Ada_Emacs
(Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Elisp_Tokens : in WisiToken.BNF.Tokens;
Output_File_Name_Root : in String;
Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
Packrat_Data : in WisiToken.Generate.Packrat.Data;
@@ -50,9 +51,10 @@ procedure WisiToken.BNF.Output_Ada_Emacs
is
use all type Ada.Containers.Count_Type;
- Language_Runtime_Package : constant String := "Wisi." & Language_Name;
+ Default_Language_Runtime_Package : constant String := "Wisi." &
Language_Name;
Blank_Set : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set (" ");
+ Numeric : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set ("0123456789");
Common_Data : Output_Ada_Common.Common_Data :=
WisiToken.BNF.Output_Ada_Common.Initialize
(Input_Data, Tuple, Output_File_Name_Root, Check_Interface => True);
@@ -155,7 +157,9 @@ is
procedure Create_Ada_Action
(Name : in String;
RHS : in RHS_Type;
+ Prod_ID : in WisiToken.Production_ID;
Unsplit_Lines : in Ada.Strings.Unbounded.Unbounded_String;
+ Labels : in String_Arrays.Vector;
Check : in Boolean)
is
-- Create Action (if Check = False; Lines must be RHS.Action) or
@@ -180,9 +184,63 @@ is
Indent_Action_Line : Unbounded_String;
Check_Line : Unbounded_String;
+ Label_Needed : array (Labels.First_Index .. Labels.Last_Index) of
Boolean := (others => False);
+ Nonterm_Needed : Boolean := False;
+
+ function Label_Used (Label : in String) return Boolean
+ is
+ Found : Boolean := False;
+ begin
+ for Tok of RHS.Tokens loop
+ if -Tok.Label = Label then
+ Found := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Found then
+ return False;
+ end if;
+
+ for I in Labels.First_Index .. Labels.Last_Index loop
+ if Label = Labels (I) then
+ Label_Needed (I) := True;
+ return True;
+ end if;
+ end loop;
+ raise SAL.Programmer_Error;
+ end Label_Used;
+
+ function Count_Label_Needed return Ada.Containers.Count_Type
+ is
+ use Ada.Containers;
+ Result : Count_Type := 0;
+ begin
+ for B of Label_Needed loop
+ if B then Result := Result + 1; end if;
+ end loop;
+ return Result;
+ end Count_Label_Needed;
+
+ function Find_Token_Index (I : in Base_Identifier_Index) return
SAL.Base_Peek_Type
+ is
+ Rule_Label : constant String := -Labels (I);
+ begin
+ for I in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index loop
+ if Length (RHS.Tokens (I).Label) > 0 and then
+ -RHS.Tokens (I).Label = Rule_Label
+ then
+ return I;
+ end if;
+ end loop;
+ return SAL.Base_Peek_Type'First;
+ end Find_Token_Index;
+
function Statement_Params (Params : in String) return String
is
-- Input looks like: [1 function 2 other ...]
+ -- Numbers can be token labels.
+
Last : Integer := Index_Non_Blank (Params); -- skip [
First : Integer;
Second : Integer;
@@ -195,30 +253,46 @@ is
Second := Index (Params, Blank_Set, First);
exit when Second = 0;
- Count := Count + 1;
- Last := Index (Params, Space_Paren_Set, Second + 1);
+ Last := Index (Params, Space_Paren_Set, Second + 1);
- Result := Result & (if Need_Comma then ", " else "") &
- "(" & Params (First .. Second - 1) & ", " &
- Elisp_Name_To_Ada (Params (Second + 1 .. Last - 1), Append_ID =>
False, Trim => 0) & ")";
+ declare
+ Label : constant String := Params (First .. Second - 1);
+ begin
+ if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
+ Count := Count + 1;
+ Result := Result & (if Need_Comma then ", " else "") &
+ "(" & Label & ", " &
+ Elisp_Name_To_Ada (Params (Second + 1 .. Last - 1),
Append_ID => False, Trim => 0) & ")";
- Need_Comma := True;
+ Need_Comma := True;
+ -- else skip
+ end if;
+ end;
end loop;
- if Count = 1 then
- return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
- else
- return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
- end if;
+ Nonterm_Needed := True;
+ return " (Parse_Data, Tree, Nonterm, Tokens, " &
+ (case Count is
+ when 0 => "(1 .. 0 => (1, Motion)))",
+ when 1 => "(1 => " & (-Result) & "))",
+ when others => "(" & (-Result) & "))");
end Statement_Params;
function Containing_Params (Params : in String) return String
is
-- Input looks like: 1 2)
- First : constant Integer := Index_Non_Blank (Params);
- Second : constant Integer := Index (Params, Blank_Set, First);
+ First : constant Integer := Index_Non_Blank (Params);
+ Second : constant Integer := Index (Params, Blank_Set, First);
+ First_Label : constant String := Params (First .. Second - 1);
+ Second_Label : constant String := Params (Second + 1 .. Params'Last
- 1);
begin
- return " (Parse_Data, Tree, Nonterm, Tokens, " &
- Params (First .. Second - 1) & ',' & Params (Second .. Params'Last);
+ if (0 = Index (First_Label, Numeric, Outside) or else Label_Used
(First_Label)) and
+ (0 = Index (Second_Label, Numeric, Outside) or else Label_Used
(Second_Label))
+ then
+ Nonterm_Needed := True;
+ return " (Parse_Data, Tree, Nonterm, Tokens, " & First_Label & ",
" & Second_Label & ")";
+ else
+ return "";
+ end if;
end Containing_Params;
function Motion_Params (Params : in String) return String
@@ -273,14 +347,27 @@ is
end;
end loop;
- Result := Result & (if Need_Comma_1 then " & " else "") & "(" &
- Params (Index_First .. Index_Last) & ", " &
- (if IDs_Count = 1 then "+" else "") & IDs & ")";
+ declare
+ Label : constant String := Params (Index_First ..
Index_Last);
+ begin
+ if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
+ Nonterm_Needed := True;
+ Result := Result & (if Need_Comma_1 then " & " else "") &
"(" &
+ Label & ", " &
+ (if IDs_Count = 1 then "+" else "") & IDs & ")";
+ end if;
+ end;
else
First := Index_Non_Blank (Params, Last);
Last := Index (Params, Delim, First);
- Result := Result & (if Need_Comma_1 then " & " else "") &
- "(" & Params (First .. Last - 1) & ", Empty_IDs)";
+ declare
+ Label : constant String := Params (First .. Last - 1);
+ begin
+ if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
+ Nonterm_Needed := True;
+ Result := Result & (if Need_Comma_1 then " & " else "") &
"(" & Label & ", Empty_IDs)";
+ end if;
+ end;
end if;
Need_Comma_1 := True;
end loop;
@@ -290,6 +377,8 @@ is
function Face_Apply_Params (Params : in String) return String
is
-- Params is a vector of triples: [1 nil font-lock-keyword-face 3
nil font-lock-function-name-face ...]
+ -- Each triple is <token_number> <prefix-face> <suffix-face>.
+ -- The token_number can be a label; faces are "nil" or an elisp name.
-- Result: ((1, 3, 1), (3, 3, 2), ...)
use Ada.Strings.Maps;
Delim : constant Character_Set := To_Set ("]") or Blank_Set;
@@ -299,46 +388,55 @@ is
Result : Unbounded_String;
Need_Comma : Boolean := False;
Count : Integer := 0;
- begin
- loop
- Last := Index_Non_Blank (Params, Last + 1);
-
- exit when Params (Last) = ']' or Params (Last) = ')';
-
- Count := Count + 1;
- First := Last;
- Last := Index (Params, Delim, First);
- Result := Result & (if Need_Comma then ", (" else "(") & Params
(First .. Last - 1);
+ procedure Elisp_Param (Skip : in Boolean)
+ is begin
if Params (Last) = ']' then
Put_Error
(Error_Message
(Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"invalid wisi-face-apply argument"));
- exit;
+ return;
end if;
First := Index_Non_Blank (Params, Last + 1);
Last := Index (Params, Delim, First);
- Result := Result & ',' & Integer'Image
- (Find_Elisp_ID (Input_Data.Tokens.Faces, Params (First .. Last -
1)));
-
- if Params (Last) = ']' then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"invalid wisi-face-apply argument"));
- exit;
+ if not Skip then
+ Result := Result & ',' & Integer'Image
+ (Find_Elisp_ID (Input_Data.Tokens.Faces, Params (First ..
Last - 1)));
end if;
+ end Elisp_Param;
- First := Index_Non_Blank (Params, Last + 1);
- Last := Index (Params, Delim, First);
- Result := Result & ',' &
- Integer'Image (Find_Elisp_ID (Input_Data.Tokens.Faces, Params
(First .. Last - 1))) & ")";
+ begin
+ loop
+ Last := Index_Non_Blank (Params, Last + 1);
- Need_Comma := True;
+ exit when Params (Last) = ']' or Params (Last) = ')';
+
+ First := Last;
+ Last := Index (Params, Delim, First);
+ declare
+ Label : constant String := Params (First .. Last - 1);
+ begin
+ if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
+ Count := Count + 1;
+ Result := Result & (if Need_Comma then ", (" else "(") &
Label;
+ Need_Comma := True;
+ Elisp_Param (Skip => False);
+ Elisp_Param (Skip => False);
+ Result := Result & ")";
+ else
+ Elisp_Param (Skip => True);
+ Elisp_Param (Skip => True);
+ end if;
+ end;
end loop;
- if Count = 1 then
+ if Count = 0 then
+ return "";
+ elsif Count = 1 then
+ Nonterm_Needed := True;
return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
else
+ Nonterm_Needed := True;
return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
end if;
exception
@@ -353,25 +451,36 @@ is
function Face_Mark_Params (Params : in String) return String
is
-- Params is a vector of pairs: [1 prefix 3 suffix ...]
+ -- The token_number can be a label; faces are "nil" or an elisp name.
-- Result: ((1, Prefix), (3, Suffix), ...)
use Ada.Strings.Maps;
Delim : constant Character_Set := To_Set ("]") or Blank_Set;
- Last : Integer := Index_Non_Blank (Params); -- skip [
+ Last : Integer := Index_Non_Blank (Params); -- skip [
First : Integer;
Result : Unbounded_String;
- Need_Comma : Boolean := False;
- Count : Integer := 0;
+ Need_Comma : Boolean := False;
+ Count : Integer := 0;
+ Skip : Boolean;
begin
loop
Last := Index_Non_Blank (Params, Last + 1);
exit when Params (Last) = ']' or Params (Last) = ')';
- Count := Count + 1;
- First := Last;
- Last := Index (Params, Delim, First);
- Result := Result & (if Need_Comma then ", (" else "(") & Params
(First .. Last - 1);
+ First := Last;
+ Last := Index (Params, Delim, First);
+ declare
+ Label : constant String := Params (First .. Last - 1);
+ begin
+ if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
+ Count := Count + 1;
+ Skip := False;
+ Result := Result & (if Need_Comma then ", (" else "(") &
Label;
+ else
+ Skip := True;
+ end if;
+ end;
if Params (Last) = ']' then
Put_Error
@@ -382,15 +491,17 @@ is
First := Index_Non_Blank (Params, Last + 1);
Last := Index (Params, Delim, First);
- Result := Result & ", " & Elisp_Name_To_Ada (Params (First .. Last
- 1), False, 0) & ")";
-
- Need_Comma := True;
+ if not Skip then
+ Result := Result & ", " & Elisp_Name_To_Ada (Params (First ..
Last - 1), False, 0) & ")";
+ Need_Comma := True;
+ end if;
end loop;
- if Count = 1 then
- return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
- else
- return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
- end if;
+ Nonterm_Needed := True;
+ return " (Parse_Data, Tree, Nonterm, Tokens, " &
+ (case Count is
+ when 0 => "(1 .. 0 => (1, Prefix))",
+ when 1 => "(1 => " & (-Result) & "))",
+ when others => "(" & (-Result) & "))");
exception
when E : others =>
Put_Error
@@ -425,6 +536,7 @@ is
Need_Comma := True;
end loop;
+ Nonterm_Needed := True;
if Count = 1 then
return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
else
@@ -447,11 +559,13 @@ is
--
-- - an integer; copy to output
--
- -- - a symbol; convert to Ada name syntax
+ -- - a symbol; convert to Ada name syntax, except 'nil' => None
--
-- - a lisp function call with arbitrary args; convert to
Indent_Param type
--
-- - a vector with two elements [code_indent comment_indent];
convert to Indent_Pair.
+ --
+ -- - a cons of a token label with any of the above.
use Ada.Strings.Maps;
use Ada.Containers;
@@ -466,7 +580,7 @@ is
Need_Comma : Boolean := False;
Param_Count : Count_Type := 0; -- in Params
- function Indent_Label (Elisp_Name : in String) return String
+ function Indent_Function (Elisp_Name : in String) return String
is begin
if Elisp_Name = "wisi-anchored" then return "Anchored_0";
elsif Elisp_Name = "wisi-anchored%" then return "Anchored_1";
@@ -474,8 +588,9 @@ is
elsif Elisp_Name = "wisi-anchored*" then return "Anchored_3";
elsif Elisp_Name = "wisi-anchored*-" then return "Anchored_4";
elsif Elisp_Name = "wisi-hanging" then return "Hanging_0";
- elsif Elisp_Name = "wisi-hanging%" then return "Hanging_1";
- elsif Elisp_Name = "wisi-hanging%-" then return "Hanging_2";
+ elsif Elisp_Name = "wisi-hanging-" then return "Hanging_1";
+ elsif Elisp_Name = "wisi-hanging%" then return "Hanging_2";
+ elsif Elisp_Name = "wisi-hanging%-" then return "Hanging_3";
else
Put_Error
(Error_Message
@@ -483,7 +598,20 @@ is
Elisp_Name & "'"));
return "";
end if;
- end Indent_Label;
+ end Indent_Function;
+
+ function Check_Cons return Integer
+ is
+ -- Params (Last) = '('; check for "(label .", return label'last
+ Blank : constant Integer := Index (Params, " ", Last);
+ begin
+ if Blank = 0 then return 0; end if;
+ if Params'Last > Blank + 1 and then Params (Blank + 1) = '.' then
+ return Blank - 1;
+ else
+ return 0;
+ end if;
+ end Check_Cons;
function Ensure_Simple_Indent (Item : in String) return String
is begin
@@ -494,6 +622,9 @@ is
-- Anchored or Language
return Item;
+ elsif Item = "nil" then
+ return "(Label => None)";
+
else
-- simple integer
return "(Int, " & Item & ")";
@@ -507,6 +638,8 @@ is
--
-- Handles this syntax:
--
+ -- nil => nil
+ --
-- integer literal:
-- 2 => 2
-- -1 => -1
@@ -599,7 +732,7 @@ is
else
-- wisi lisp function call
- Function_Name := +Indent_Label (-Function_Name);
+ Function_Name := +Indent_Function (-Function_Name);
if Length (Function_Name) = 0 then
-- not a recognized function
Last := 1 + Index (Params, ")", Last);
@@ -621,10 +754,15 @@ is
end if;
else
- -- Assume it is a language-specific integer indent option,
like "ada-indent",
- -- declared in Language_Runtime_Package, which is use-visible.
+ -- Assume it is 'nil' or a language-specific integer indent
option,
+ -- like "ada-indent", declared in Language_Runtime_Package,
which is
+ -- use-visible.
Last := Index (Params, Delim, First);
- return Elisp_Name_To_Ada (Params (First .. Last - 1), False, 0);
+ if Params (First .. Last - 1) = "nil" then
+ return "nil";
+ else
+ return Elisp_Name_To_Ada (Params (First .. Last - 1), False,
0);
+ end if;
end if;
exception
when E : others =>
@@ -634,6 +772,14 @@ is
return "";
end Expression;
+ procedure Skip_Expression (Param_First : in Integer)
+ is
+ Junk : constant String := Expression (Param_First);
+ pragma Unreferenced (Junk);
+ begin
+ null;
+ end Skip_Expression;
+
function Ensure_Indent_Param (Item : in String) return String
is begin
-- Return an aggregate for Indent_Param. Item can be anything
@@ -649,56 +795,134 @@ is
-- Anchored or Language
return "(Simple, " & Item & ")";
+ elsif Item = "nil" then
+ return "(Simple, (Label => None))";
+
else
-- simple integer
return "(Simple, (Int, " & Item & "))";
end if;
end Ensure_Indent_Param;
- begin
- loop
- if Params (Last) /= ']' then
- Last := Index_Non_Blank (Params, Last + 1);
- end if;
-
- exit when Params (Last) = ']';
-
- if Need_Comma then
- Result := Result & ", ";
- else
- Need_Comma := True;
- end if;
-
+ procedure One_Param (Prefix : in Boolean := False; Skip : in Boolean
:= False)
+ is
+ procedure Comma
+ is begin
+ if Need_Comma then
+ if not Prefix then
+ Result := Result & ", ";
+ end if;
+ else
+ Need_Comma := True;
+ end if;
+ end Comma;
+ begin
case Params (Last) is
when '(' =>
- Result := Result & "(False, " & Ensure_Indent_Param (Expression
(Last)) & ')';
+ -- cons or function
+ declare
+ Label_Last : constant Integer := Check_Cons;
+ begin
+ if Label_Last > 0 then
+ declare
+ Label : constant String := Params (Last + 1 ..
Label_Last);
+ begin
+ Last := Index_Non_Blank (Params, Label_Last + 3);
+ if Label_Used (Label) then
+ Comma;
+ Result := Result & Label & " => ";
+ One_Param (Prefix => True);
+ else
+ -- This token is not present in this RHS; skip
this param
+ One_Param (Skip => True);
+ end if;
+ if Params (Last) /= ')' then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name,
+ RHS.Source_Line, "invalid indent syntax;
missing ')'"));
+ end if;
+ Last := Last + 1;
+ end;
+ else
+ if Skip then
+ Skip_Expression (Last);
+ else
+ Comma;
+ Result := Result & "(False, " & Ensure_Indent_Param
(Expression (Last)) & ')';
+ end if;
+ end if;
+ end;
when '[' =>
-- vector
- Result := Result & "(True, " & Ensure_Indent_Param (Expression
(Last + 1));
- Result := Result & ", " & Ensure_Indent_Param (Expression (Last
+ 1)) & ')';
+ if Skip then
+ Skip_Expression (Last + 1);
+ Skip_Expression (Last + 1);
+ else
+ Comma;
+ Result := Result & "(True, " & Ensure_Indent_Param
(Expression (Last + 1));
+ Result := Result & ", " & Ensure_Indent_Param (Expression
(Last + 1)) & ')';
+ end if;
if Params (Last) /= ']' then
Put_Error
(Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"invalid indent syntax"));
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"indent missing ']'"));
end if;
Last := Last + 1;
when others =>
-- integer or symbol
- Result := Result & "(False, " & Ensure_Indent_Param (Expression
(Last)) & ')';
-
+ if Skip then
+ Skip_Expression (Last);
+ else
+ Comma;
+ Result := Result & "(False, " & Ensure_Indent_Param
(Expression (Last)) & ')';
+ end if;
end case;
+ end One_Param;
+
+ begin
+ loop
+ if Params (Last) /= ']' then
+ Last := Index_Non_Blank (Params, Last + 1);
+ if Last = 0 then
+ Put_Error (Error_Message
(Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "indent missing ']'"));
+ return -Result;
+ end if;
+ end if;
+
+ exit when Params (Last) = ']';
+
+ One_Param;
+
Param_Count := Param_Count + 1;
end loop;
+ -- In translated EBNF, token counts vary in each RHS; require each
+ -- parameter to be labeled if any are, both for catching errors, and
+ -- becase that would produce mixed positional and named association
+ -- in the Ada action subprogram.
if Param_Count /= RHS.Tokens.Length then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "indent
parameters count of" & Count_Type'Image
- (Param_Count) & " /= production token count of" &
Count_Type'Image (RHS.Tokens.Length)));
+ if Labels.Length = 0 then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Image (Prod_ID) &
+ ": indent parameters count of" & Count_Type'Image
(Param_Count) &
+ " /= production token count of" & Count_Type'Image
(RHS.Tokens.Length)));
+
+ elsif Count_Label_Needed /= RHS.Tokens.Length then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Image (Prod_ID) &
+ ": indent parameter(s) not labeled"));
+ else
+ -- all parameters labeled
+ null;
+ end if;
end if;
+ Nonterm_Needed := True;
if Param_Count = 1 then
Result := Prefix & "1 => " & Result;
else
@@ -711,11 +935,29 @@ is
function Merge_Names_Params (Params : in String) return String
is
-- Input looks like "1 2)"
- First : constant Integer := Index_Non_Blank (Params);
- Second : constant Integer := Index (Params, Blank_Set, First);
+ First : constant Integer := Index_Non_Blank (Params);
+ Second : constant Integer := Index (Params, Blank_Set,
First);
+ Label_First : constant String := Params (First .. Second - 1);
+ Label_Used_First : constant Boolean := 0 = Index (Label_First,
Numeric, Outside) or else
+ Label_Used (Label_First);
+ Label_Second : constant String := Params (Second + 1 ..
Params'Last - 1);
+ Label_Used_Second : constant Boolean := 0 = Index (Label_Second,
Numeric, Outside) or else
+ Label_Used (Label_Second);
begin
- return " (Nonterm, Tokens, " & Params (First .. Second - 1) & ',' &
- Params (Second .. Params'Last);
+ Nonterm_Needed := True;
+
+ if Label_Used_First and Label_Used_Second then
+ return " (Nonterm, Tokens, " & Label_First & ", " & Label_Second &
")";
+
+ elsif (not Label_Used_First) and Label_Used_Second then
+ -- A copied EBNF RHS; see subprograms.wy Name
+ return " (Nonterm, Tokens, " & Label_Second & ")";
+ else
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"merge_names token label error"));
+ return " (Nonterm, Tokens)";
+ end if;
end Merge_Names_Params;
function Match_Names_Params (Params : in String) return String
@@ -732,7 +974,49 @@ is
else "False") & ")";
end Match_Names_Params;
- procedure Translate_Line (Line : in String)
+ function Language_Action_Params (Params : in String; Action_Name : in
String) return String
+ is
+ -- Input looks like: [1 2 ...])
+ Result : Unbounded_String;
+ Need_Comma : Boolean := False;
+ Param_Count : Integer := 0;
+ First : Integer;
+ Last : Integer := Params'First; -- '['
+ begin
+ loop
+ First := Index_Non_Blank (Params, Last + 1);
+ Last := Index (Params, Space_Paren_Set, First);
+ declare
+ Label : constant String := Params (First .. Last - 1);
+ begin
+ if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
+ Param_Count := Param_Count + 1;
+ if Need_Comma then
+ Result := Result & ", ";
+ else
+ Need_Comma := True;
+ end if;
+ Result := Result & Label;
+ end if;
+ exit when Params (Last) = ']';
+ if Last = Params'Last then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Action_Name & " missing ']'"));
+ exit;
+ end if;
+ end;
+ end loop;
+ if Param_Count = 0 then
+ return "";
+ elsif Param_Count = 1 then
+ return "(1 => " & (-Result) & ")";
+ else
+ return "(" & (-Result) & ")";
+ end if;
+ end Language_Action_Params;
+
+ procedure Translate_Sexp (Line : in String)
is
Last : constant Integer := Index (Line, Blank_Set);
Elisp_Name : constant String := Line (Line'First + 1 .. (if Last = 0
then Line'Last else Last) - 1);
@@ -768,56 +1052,101 @@ is
-- wisi action/check functions, in same order as typically used in
-- .wy files; Navigate, Face, Indent, Check.
if Elisp_Name = "wisi-statement-action" then
- Navigate_Lines.Append
- (Elisp_Name_To_Ada (Elisp_Name, False, 5) &
- Statement_Params (Line (Last + 1 .. Line'Last)) & ";");
+ declare
+ Params : constant String := Statement_Params (Line (Last + 1 ..
Line'Last));
+ begin
+ if Params'Length > 0 then
+ Navigate_Lines.Append (Elisp_Name_To_Ada (Elisp_Name, False,
5) & Params & ";");
+ end if;
+ end;
+
+ elsif Elisp_Name = "wisi-name-action" then
+ declare
+ First : constant Integer := Index_Non_Blank (Line, Last + 1);
+ Last : constant Integer := Index (Line, Space_Paren_Set,
First);
+ Label : constant String := Line (First .. Last - 1);
+ begin
+ if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
+ Nonterm_Needed := True;
+ Navigate_Lines.Append
+ ("Name_Action (Parse_Data, Tree, Nonterm, Tokens, " & Line
(First .. Line'Last) & ";");
+ end if;
+ end;
elsif Elisp_Name = "wisi-containing-action" then
- Navigate_Lines.Append
- (Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
- Containing_Params (Line (Last + 1 .. Line'Last)) & ";");
+ declare
+ Params : constant String := Containing_Params (Line (Last + 1
.. Line'Last));
+ begin
+ if Params'Length > 0 then
+ Navigate_Lines.Append (Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) & Params & ";");
+ end if;
+ end;
elsif Elisp_Name = "wisi-motion-action" then
- Navigate_Lines.Append
- (Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
- Motion_Params (Line (Last + 1 .. Line'Last)) & ";");
+ declare
+ Params : constant String := Motion_Params (Line (Last + 1 ..
Line'Last));
+ begin
+ if Params'Length > 0 then
+ Navigate_Lines.Append (Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) & Params & ";");
+ end if;
+ end;
elsif Elisp_Name = "wisi-face-apply-action" then
Assert_Face_Empty;
- Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
- Face_Apply_Params (Line (Last + 1 .. Line'Last)) & ";";
+ declare
+ Params : constant String := Face_Apply_Params (Line (Last + 1
.. Line'Last));
+ begin
+ if Params'Length > 0 then
+ Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim =>
5) & Params & ";";
+ end if;
+ end;
elsif Elisp_Name = "wisi-face-apply-list-action" then
Assert_Face_Empty;
- Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
- Face_Apply_Params (Line (Last + 1 .. Line'Last)) & ";";
+ declare
+ Params : constant String := Face_Apply_Params (Line (Last + 1
.. Line'Last));
+ begin
+ if Params'Length > 0 then
+ Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim =>
5) & Params & ";";
+ end if;
+ end;
elsif Elisp_Name = "wisi-face-mark-action" then
Assert_Face_Empty;
- Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
- Face_Mark_Params (Line (Last + 1 .. Line'Last)) & ";";
+ declare
+ Params : constant String := Face_Mark_Params (Line (Last + 1 ..
Line'Last));
+ begin
+ if Params'Length > 0 then
+ Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim =>
5) & Params & ";";
+ end if;
+ end;
elsif Elisp_Name = "wisi-face-remove-action" then
Assert_Face_Empty;
- Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
- Face_Remove_Params (Line (Last + 1 .. Line'Last)) & ";";
+ declare
+ Params : constant String := Face_Remove_Params (Line (Last + 1
.. Line'Last));
+ begin
+ if Params'Length > 0 then
+ Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim =>
5) & Params & ";";
+ end if;
+ end;
elsif Elisp_Name = "wisi-indent-action" then
Assert_Indent_Empty;
- Indent_Action_Line := +"Indent_Action_0" &
- Indent_Params (Line (Last + 1 .. Line'Last)) & ";";
+ Indent_Action_Line := +"Indent_Action_0" & Indent_Params (Line
(Last + 1 .. Line'Last)) & ";";
elsif Elisp_Name = "wisi-indent-action*" then
Assert_Indent_Empty;
- declare
- Temp : constant Integer := Index (Line, Blank_Set, Last + 1);
- begin
- Indent_Action_Line := +"Indent_Action_1" &
- Indent_Params (Line (Temp + 1 .. Line'Last), Line (Last +
1 .. Temp - 1) & ", ") & ";";
- end;
+ declare
+ Temp : constant Integer := Index (Line, Blank_Set, Last + 1);
+ begin
+ Indent_Action_Line := +"Indent_Action_1" &
+ Indent_Params (Line (Temp + 1 .. Line'Last), Line (Last + 1
.. Temp - 1) & ", ") & ";";
+ end;
elsif Elisp_Name = "wisi-propagate-name" then
Assert_Check_Empty;
+ Nonterm_Needed := True;
Check_Line := +"return " & Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) &
" (Nonterm, Tokens, " & Line (Last + 1 .. Line'Last) & ";";
@@ -833,21 +1162,53 @@ is
elsif Elisp_Name = "wisi-terminate-partial-parse" then
Assert_Check_Empty;
+ Nonterm_Needed := True;
Check_Line := +"return Terminate_Partial_Parse
(Partial_Parse_Active, Partial_Parse_Byte_Goal, " &
"Recover_Active, Nonterm);";
+ elsif Is_Present (Input_Data.Tokens.Actions, Elisp_Name) then
+ -- Language-specific action
+ declare
+ Item : Elisp_Action_Type renames Input_Data.Tokens.Actions
+ (Input_Data.Tokens.Actions.Find (+Elisp_Name));
+ Params : constant String := Language_Action_Params (Line (Last
+ 1 .. Line'Last), Elisp_Name);
+ Code : constant String := -Item.Ada_Name &
+ " (Wisi.Parse_Data_Type'Class (User_Data), Tree, Tokens, " &
Params & ");";
+ begin
+ if Params'Length > 0 then
+ if "navigate" = -Item.Action_Label then
+ Navigate_Lines.Append (Code);
+
+ elsif "face" = -Item.Action_Label then
+ Assert_Face_Empty;
+ Face_Line := +Code;
+
+ elsif "indent" = -Item.Action_Label then
+ Assert_Indent_Empty;
+ Indent_Action_Line := +Code;
+
+ else
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name,
RHS.Source_Line, "unrecognized action label: '" &
+ (-Item.Action_Label) & "'"));
+ end if;
+
+ -- else skip
+ end if;
+ end;
else
Put_Error
(Error_Message
(Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"unrecognized elisp action: '" &
Elisp_Name & "'"));
end if;
- end Translate_Line;
+ end Translate_Sexp;
begin
for Sexp of Sexps loop
begin
- Translate_Line (Sexp);
+ Translate_Sexp (Sexp);
exception
when E : Not_Found =>
Put_Error
@@ -869,22 +1230,45 @@ is
Unref_Nonterm : constant Boolean := 0 = Index (Check_Line,
"Nonterm");
Unref_Tokens : constant Boolean := 0 = Index (Check_Line,
"Tokens");
Unref_Recover : constant Boolean := 0 = Index (Check_Line,
"Recover_Active");
+ Need_Comma : Boolean := False;
begin
- if Unref_Lexer or Unref_Nonterm or Unref_Tokens or Unref_Recover
then
+ if Unref_Lexer or Unref_Nonterm or Unref_Tokens or Unref_Recover or
+ (for some I of Label_Needed => I)
+ then
Indent_Line ("is");
- if Unref_Lexer then
- Indent_Line (" pragma Unreferenced (Lexer);");
- end if;
- if Unref_Nonterm then
- Indent_Line (" pragma Unreferenced (Nonterm);");
- end if;
- if Unref_Tokens then
- Indent_Line (" pragma Unreferenced (Tokens);");
- end if;
- if Unref_Recover then
- Indent_Line (" pragma Unreferenced (Recover_Active);");
+
+ Indent := Indent + 3;
+ if Unref_Lexer or Unref_Nonterm or Unref_Tokens or
Unref_Recover then
+ Indent_Start ("pragma Unreferenced (");
+
+ if Unref_Lexer then
+ Put ((if Need_Comma then ", " else "") & "Lexer");
+ Need_Comma := True;
+ end if;
+ if Unref_Nonterm then
+ Put ((if Need_Comma then ", " else "") & "Nonterm");
+ Need_Comma := True;
+ end if;
+ if Unref_Tokens then
+ Put ((if Need_Comma then ", " else "") & "Tokens");
+ Need_Comma := True;
+ end if;
+ if Unref_Recover then
+ Put ((if Need_Comma then ", " else "") &
"Recover_Active");
+ Need_Comma := True;
+ end if;
+ Put_Line (");");
end if;
+ for I in Label_Needed'Range loop
+ if Label_Needed (I) then
+ Indent_Line
+ (-Labels (I) & " : constant SAL.Peek_Type :=" &
+ SAL.Peek_Type'Image (Find_Token_Index (I)) & ";");
+ end if;
+ end loop;
+ Indent := Indent - 3;
+
Indent_Line ("begin");
else
Indent_Line ("is begin");
@@ -900,8 +1284,24 @@ is
Indent_Line (" Nonterm : in
WisiToken.Syntax_Trees.Valid_Node_Index;");
Indent_Line (" Tokens : in
WisiToken.Syntax_Trees.Valid_Node_Index_Array)");
Indent_Line ("is");
- Indent_Start (" Parse_Data : Wisi.Parse_Data_Type renames");
- Put_Line (" Wisi.Parse_Data_Type (User_Data);");
+
+ Indent := Indent + 3;
+ Indent_Line ("Parse_Data : Wisi.Parse_Data_Type renames
Wisi.Parse_Data_Type (User_Data);");
+
+ if not Nonterm_Needed then
+ -- Language_Action may not use this
+ Indent_Line ("pragma Unreferenced (Nonterm);");
+ end if;
+
+ for I in Label_Needed'Range loop
+ if Label_Needed (I) then
+ Indent_Line
+ (-Labels (I) & " : constant SAL.Peek_Type :=" &
+ SAL.Peek_Type'Image (Find_Token_Index (I)) & ";");
+ end if;
+ end loop;
+
+ Indent := Indent - 3;
Indent_Line ("begin");
Indent := Indent + 3;
@@ -965,6 +1365,7 @@ is
procedure Create_Ada_Actions_Body
(Action_Names : not null access WisiToken.Names_Array_Array;
Check_Names : not null access WisiToken.Names_Array_Array;
+ Label_Count : in Ada.Containers.Count_Type;
Package_Name : in String)
is
use Ada.Strings.Unbounded;
@@ -989,10 +1390,21 @@ is
Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
New_Line;
+ if Label_Count > 0 then
+ Put_Line ("with SAL;");
+ end if;
+
Put_Line ("with Wisi; use Wisi;");
- if Input_Data.Language_Params.Language_Runtime then
- Put_Line ("with " & Language_Runtime_Package & "; use " &
Language_Runtime_Package & ";");
- -- For language-specific names in actions, checks.
+ if Input_Data.Language_Params.Use_Language_Runtime then
+ declare
+ Pkg : constant String :=
+ (if -Input_Data.Language_Params.Language_Runtime_Name = ""
+ then Default_Language_Runtime_Package
+ else -Input_Data.Language_Params.Language_Runtime_Name);
+ begin
+ -- For language-specific names in actions, checks.
+ Put_Line ("with " & Pkg & "; use " & Pkg & ";");
+ end;
end if;
case Common_Data.Interface_Kind is
@@ -1023,26 +1435,26 @@ is
-- No need for a Token_Cursor here, since we only need the
-- nonterminals.
declare
- LHS_ID : constant WisiToken.Token_ID := Find_Token_ID
(Generate_Data, -Rule.Left_Hand_Side);
- Prod_Index : Integer := 0; -- Semantic_Action
defines Prod_Index as zero-origin
+ LHS_ID : constant WisiToken.Token_ID := Find_Token_ID
(Generate_Data, -Rule.Left_Hand_Side);
+ RHS_Index : Integer := 0; -- Semantic_Action
defines RHS_Index as zero-origin
begin
for RHS of Rule.Right_Hand_Sides loop
if Length (RHS.Action) > 0 then
declare
- Name : constant String := Action_Names
(LHS_ID)(Prod_Index).all;
+ Name : constant String := Action_Names
(LHS_ID)(RHS_Index).all;
begin
- Create_Ada_Action (Name, RHS, RHS.Action, Check => False);
+ Create_Ada_Action (Name, RHS, (LHS_ID, RHS_Index),
RHS.Action, Rule.Labels, Check => False);
end;
end if;
if Length (RHS.Check) > 0 then
declare
- Name : constant String := Check_Names
(LHS_ID)(Prod_Index).all;
+ Name : constant String := Check_Names
(LHS_ID)(RHS_Index).all;
begin
- Create_Ada_Action (Name, RHS, RHS.Check, Check => True);
+ Create_Ada_Action (Name, RHS, (LHS_ID, RHS_Index),
RHS.Check, Rule.Labels, Check => True);
end;
end if;
- Prod_Index := Prod_Index + 1;
+ RHS_Index := RHS_Index + 1;
end loop;
end;
end loop;
@@ -1070,7 +1482,9 @@ is
Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
New_Line;
- Put_Line ("with " & Actions_Package_Name & "; use " &
Actions_Package_Name & ";");
+ if Input_Data.Action_Count > 0 or Input_Data.Check_Count > 0 then
+ Put_Line ("with " & Actions_Package_Name & "; use " &
Actions_Package_Name & ";");
+ end if;
case Common_Data.Lexer is
when None | Elisp_Lexer =>
@@ -1084,9 +1498,7 @@ is
case Common_Data.Generate_Algorithm is
when LR_Generate_Algorithm =>
- if Tuple.Text_Rep then
- Put_Line ("with WisiToken.Productions;");
- end if;
+ null;
when Packrat_Generate_Algorithm =>
Put_Line ("with WisiToken.Parse;");
@@ -1232,6 +1644,19 @@ is
Output_Elisp_Common.Indent_Name_Table
(Output_File_Name_Root, "process-face-table", Input_Data.Tokens.Faces);
+ -- We need the elisp lexer for some operations
+ if Elisp_Tokens.Keywords.Length > 0 then
+ New_Line;
+ Output_Elisp_Common.Indent_Keyword_Table
+ (Output_File_Name_Root, "elisp", Elisp_Tokens.Keywords,
Ada.Strings.Unbounded.To_String'Access);
+ end if;
+ if Elisp_Tokens.Tokens.Length > 0 then
+ New_Line;
+ Output_Elisp_Common.Indent_Token_Table
+ (Output_File_Name_Root, "elisp", Elisp_Tokens.Tokens,
Ada.Strings.Unbounded.To_String'Access);
+ end if;
+
+ New_Line;
Put_Line ("(provide '" & Output_File_Name_Root & "-process)");
Set_Output (Standard_Output);
Close (File);
@@ -1467,7 +1892,11 @@ begin
when Module => "_Module") &
Gen_Alg_Name & "_Main";
begin
- Create_Ada_Actions_Body (Generate_Data.Action_Names,
Generate_Data.Check_Names, Actions_Package_Name);
+ if Input_Data.Action_Count > 0 or Input_Data.Check_Count > 0 then
+ -- We typically have no actions when just getting started with a new
language.
+ Create_Ada_Actions_Body
+ (Generate_Data.Action_Names, Generate_Data.Check_Names,
Input_Data.Label_Count, Actions_Package_Name);
+ end if;
Create_Ada_Actions_Spec
(Output_File_Name => Output_File_Name_Root &
diff --git a/wisitoken-bnf-output_elisp.adb b/wisitoken-bnf-output_elisp.adb
index 8007bd2..ff52449 100644
--- a/wisitoken-bnf-output_elisp.adb
+++ b/wisitoken-bnf-output_elisp.adb
@@ -2,7 +2,7 @@
--
-- Output Elisp code implementing the grammar defined by the parameters.
--
--- Copyright (C) 2012 - 2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2012 - 2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- The WisiToken package is free software; you can redistribute it
-- and/or modify it under terms of the GNU General Public License as
@@ -216,7 +216,7 @@ is
for RHS of Rule.Right_Hand_Sides loop
Put (" ((");
for Token of RHS.Tokens loop
- Put (Token & " ");
+ Put (-Token.Identifier & " ");
end loop;
if Length (RHS.Action) = 0 then
Put (")");
diff --git a/wisitoken-bnf-output_elisp_common.adb
b/wisitoken-bnf-output_elisp_common.adb
index 9d46b4f..a0b7158 100644
--- a/wisitoken-bnf-output_elisp_common.adb
+++ b/wisitoken-bnf-output_elisp_common.adb
@@ -2,7 +2,7 @@
--
-- See spec
--
--- Copyright (C) 2012, 2013, 2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2012, 2013, 2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- This program is free software; you can redistribute it and/or
-- modify it under terms of the GNU General Public License as
@@ -87,6 +87,20 @@ package body WisiToken.BNF.Output_Elisp_Common is
use Ada.Strings.Unbounded;
use Ada.Text_IO;
use WisiToken.Generate;
+
+ function To_Double_Quotes (Item : in String) return String
+ is
+ Result : String := Item;
+ begin
+ if Result (Result'First) = ''' then
+ Result (Result'First) := '"';
+ end if;
+ if Result (Result'Last) = ''' then
+ Result (Result'Last) := '"';
+ end if;
+ return Result;
+ end To_Double_Quotes;
+
begin
Indent_Line ("(defconst " & Output_File_Root & "-" & Label &
"-token-table-raw");
Indent_Line (" '(");
@@ -111,7 +125,7 @@ package body WisiToken.BNF.Output_Elisp_Common is
-- value not used by elisp
Indent_Line ("(" & Image (Token.Name) & " . """")");
else
- Indent_Line ("(" & Image (Token.Name) & " . " &
(-Token.Value) & ")");
+ Indent_Line ("(" & Image (Token.Name) & " . " &
To_Double_Quotes (-Token.Value) & ")");
end if;
end if;
end loop;
@@ -139,7 +153,6 @@ package body WisiToken.BNF.Output_Elisp_Common is
end loop;
Indent_Line ("])");
Indent := Indent - 3;
- New_Line;
end Indent_Name_Table;
end WisiToken.BNF.Output_Elisp_Common;
diff --git a/wisitoken-bnf.adb b/wisitoken-bnf.adb
index 22492f0..dc37d56 100644
--- a/wisitoken-bnf.adb
+++ b/wisitoken-bnf.adb
@@ -2,7 +2,7 @@
--
-- see spec
--
--- Copyright (C) 2012 - 2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2012 - 2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- This program is free software; you can redistribute it and/or
-- modify it under terms of the GNU General Public License as
@@ -39,6 +39,16 @@ package body WisiToken.BNF is
Free (Prev);
end Add;
+ function To_Generate_Algorithm (Item : in String) return Generate_Algorithm
+ is begin
+ for I in Generate_Algorithm loop
+ if To_Lower (Generate_Algorithm_Image (I).all) = To_Lower (Item) then
+ return I;
+ end if;
+ end loop;
+ raise User_Error with "invalid generate algorithm name: '" & Item & "'";
+ end To_Generate_Algorithm;
+
function To_Output_Language (Item : in String) return Output_Language
is begin
for I in Output_Language loop
@@ -176,6 +186,13 @@ package body WisiToken.BNF is
raise Not_Found;
end Value;
+ function Is_Present (List : in Elisp_Action_Maps.Map; Name : in String)
return Boolean
+ is
+ use Elisp_Action_Maps;
+ begin
+ return No_Element /= List.Find (+Name);
+ end Is_Present;
+
function Count (Tokens : in Token_Lists.List) return Integer
is
Result : Integer := 0;
diff --git a/wisitoken-bnf.ads b/wisitoken-bnf.ads
index 3d46c45..3532de7 100644
--- a/wisitoken-bnf.ads
+++ b/wisitoken-bnf.ads
@@ -32,9 +32,11 @@ pragma License (Modified_GPL);
with Ada.Characters.Handling;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
+with Ada.Containers.Ordered_Maps;
+with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
-with WisiToken;
+with WisiToken.Parse.LR;
package WisiToken.BNF is
-- See also WisiToken exceptions
@@ -47,14 +49,18 @@ package WisiToken.BNF is
subtype LR_Generate_Algorithm is Generate_Algorithm range LALR .. LR1;
subtype Packrat_Generate_Algorithm is Generate_Algorithm range Packrat_Gen
.. Packrat_Proc;
- Generate_Algorithm_Image : constant array (Valid_Generate_Algorithm) of
access constant String :=
- (LALR => new String'("LALR"),
+ Generate_Algorithm_Image : constant array (Generate_Algorithm) of
String_Access_Constant :=
+ (None => new String'("None"),
+ LALR => new String'("LALR"),
LR1 => new String'("LR1"),
Packrat_Gen => new String'("Packrat_Gen"),
Packrat_Proc => new String'("Packrat_Proc"),
External => new String'("External"));
-- Suitable for Ada package names.
+ function To_Generate_Algorithm (Item : in String) return Generate_Algorithm;
+ -- Raises User_Error for invalid Item
+
type Generate_Algorithm_Set is array (Generate_Algorithm) of Boolean;
type Generate_Algorithm_Set_Access is access Generate_Algorithm_Set;
@@ -63,7 +69,7 @@ package WisiToken.BNF is
-- _Lang to avoid colliding with the standard package Ada and
-- WisiToken packages named *.Ada. In the grammar file, they
-- are named by (case insensitive):
- Output_Language_Image : constant array (Output_Language) of access constant
String :=
+ Output_Language_Image : constant array (Output_Language) of
String_Access_Constant :=
(Ada_Lang => new String'("Ada"),
Ada_Emacs_Lang => new String'("Ada_Emacs"),
Elisp_Lang => new String'("elisp"));
@@ -76,7 +82,7 @@ package WisiToken.BNF is
-- We append "_Lexer" to these names to avoid colliding with the
-- similarly-named WisiToken packages. In the grammar file, they
-- are named by:
- Lexer_Image : constant array (Lexer_Type) of access constant String :=
+ Lexer_Image : constant array (Lexer_Type) of String_Access_Constant :=
(None => new String'("none"),
Elisp_Lexer => new String'("elisp"),
re2c_Lexer => new String'("re2c"));
@@ -93,11 +99,11 @@ package WisiToken.BNF is
subtype Valid_Interface is Interface_Type range Process .. Module;
type Generate_Tuple is record
- Gen_Alg : Valid_Generate_Algorithm;
- Out_Lang : Output_Language;
- Lexer : Lexer_Type := None;
- Interface_Kind : Interface_Type := None;
- Text_Rep : Boolean := False;
+ Gen_Alg : Generate_Algorithm := None;
+ Out_Lang : Output_Language := Ada_Lang;
+ Lexer : Lexer_Type := None;
+ Interface_Kind : Interface_Type := None;
+ Text_Rep : Boolean := False;
end record;
type Generate_Set is array (Natural range <>) of Generate_Tuple;
@@ -110,16 +116,21 @@ package WisiToken.BNF is
package String_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists
(String);
+ package String_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (WisiToken.Identifier_Index, Ada.Strings.Unbounded.Unbounded_String,
+ Default_Element => Ada.Strings.Unbounded.Null_Unbounded_String);
+
type Language_Param_Type is record
-- Set by grammar file declarations or command line options. Error
-- recover parameters are in McKenzie_Recover_Param_Type below.
- Case_Insensitive : Boolean := False;
- Embedded_Quote_Escape_Doubled : Boolean := False;
- End_Names_Optional_Option : Ada.Strings.Unbounded.Unbounded_String;
- Language_Runtime : Boolean := True;
- Declare_Enums : Boolean := True;
- Error_Recover : Boolean := False;
- Start_Token : Ada.Strings.Unbounded.Unbounded_String;
+ Case_Insensitive : Boolean := False;
+ End_Names_Optional_Option : Ada.Strings.Unbounded.Unbounded_String;
+ Use_Language_Runtime : Boolean := True;
+ Language_Runtime_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Declare_Enums : Boolean := True;
+ Error_Recover : Boolean := False;
+ Start_Token : Ada.Strings.Unbounded.Unbounded_String;
+ Partial_Recursion : Boolean := False;
end record;
type Raw_Code_Location is
@@ -174,26 +185,46 @@ package WisiToken.BNF is
end record;
package String_Pair_Lists is new Ada.Containers.Doubly_Linked_Lists
(String_Pair_Type);
-
function Is_Present (List : in String_Pair_Lists.List; Name : in String)
return Boolean;
function Value (List : in String_Pair_Lists.List; Name : in String) return
String;
+ type Elisp_Action_Type is record
+ -- Elisp name is the key
+ Action_Label : Ada.Strings.Unbounded.Unbounded_String;
+ Ada_Name : Ada.Strings.Unbounded.Unbounded_String;
+ end record;
+
+ package Elisp_Action_Maps is new Ada.Containers.Ordered_Maps
+ (Ada.Strings.Unbounded.Unbounded_String, Elisp_Action_Type,
Ada.Strings.Unbounded."<");
+
+ function Is_Present (List : in Elisp_Action_Maps.Map; Name : in String)
return Boolean;
+
type McKenzie_Recover_Param_Type is record
Source_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
-- Of the %mckenzie_cost_default declaration; we assume the others
-- are near.
- Default_Insert : Natural := 0;
- Default_Delete_Terminal : Natural := 0;
- Default_Push_Back : Natural := 0;
- Delete : String_Pair_Lists.List;
- Insert : String_Pair_Lists.List;
- Push_Back : String_Pair_Lists.List;
- Ignore_Check_Fail : Natural := 0;
- Cost_Limit : Natural := Integer'Last;
- Check_Limit : WisiToken.Token_Index :=
WisiToken.Token_Index'Last;
- Check_Delta_Limit : Natural := Integer'Last;
- Enqueue_Limit : Natural := Integer'Last;
+ Default_Insert : Natural := 0;
+ Default_Delete_Terminal : Natural := 0;
+ Default_Push_Back : Natural := 0; -- also
default for undo_reduce
+ Delete : String_Pair_Lists.List;
+ Insert : String_Pair_Lists.List;
+ Push_Back : String_Pair_Lists.List;
+ Undo_Reduce : String_Pair_Lists.List;
+ Minimal_Complete_Cost_Delta : Integer :=
+ WisiToken.Parse.LR.Default_McKenzie_Param.Minimal_Complete_Cost_Delta;
+ Fast_Forward : Integer :=
+ WisiToken.Parse.LR.Default_McKenzie_Param.Fast_Forward;
+ Matching_Begin : Integer :=
+ WisiToken.Parse.LR.Default_McKenzie_Param.Matching_Begin;
+ Ignore_Check_Fail : Natural :=
+ WisiToken.Parse.LR.Default_McKenzie_Param.Ignore_Check_Fail;
+ Check_Limit : WisiToken.Token_Index :=
+ WisiToken.Parse.LR.Default_McKenzie_Param.Check_Limit;
+ Check_Delta_Limit : Natural :=
+ WisiToken.Parse.LR.Default_McKenzie_Param.Check_Delta_Limit;
+ Enqueue_Limit : Natural :=
+ WisiToken.Parse.LR.Default_McKenzie_Param.Enqueue_Limit;
end record;
type Token_Kind_Type is record
@@ -231,8 +262,17 @@ package WisiToken.BNF is
package Conflict_Lists is new Ada.Containers.Doubly_Linked_Lists (Conflict);
+ type Labeled_Token is record
+ Label : Ada.Strings.Unbounded.Unbounded_String;
+ Identifier : Ada.Strings.Unbounded.Unbounded_String;
+ end record;
+
+ package Labeled_Token_Arrays is new Ada.Containers.Vectors
(Positive_Index_Type, Labeled_Token);
+ -- Index matches Syntax_Trees.Valid_Node_Index_Array, used for Tokens
+ -- in call to post parse grammar action.
+
type RHS_Type is record
- Tokens : String_Lists.List;
+ Tokens : Labeled_Token_Arrays.Vector;
Action : Ada.Strings.Unbounded.Unbounded_String;
Check : Ada.Strings.Unbounded.Unbounded_String;
Source_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
@@ -242,6 +282,7 @@ package WisiToken.BNF is
type Rule_Type is record
Left_Hand_Side : aliased Ada.Strings.Unbounded.Unbounded_String;
Right_Hand_Sides : RHS_Lists.List;
+ Labels : String_Arrays.Vector;
Source_Line : WisiToken.Line_Number_Type;
end record;
@@ -257,13 +298,18 @@ package WisiToken.BNF is
-- Rules included here because they define the nonterminal tokens, as
-- well as the productions.
- -- The following are specified in grammar file declarations and used in
other declarations
- -- or actions. Faces, Indents only used if .wy action language is
- -- elisp and output language is not elisp.
+ Virtual_Identifiers : String_Arrays.Vector;
+ -- Nonterminals and terminals introduced by translating from EBNF to
+ -- BNF.
+
+ -- The following are specified in grammar file declarations and used
+ -- in other declarations or actions. Faces, Indents only used if .wy
+ -- action language is elisp and output language is not elisp.
re2c_Regexps : String_Pair_Lists.List; -- %re2c_regexp
Faces : String_Lists.List; -- %elisp_face
Indents : String_Pair_Lists.List; -- %elisp_indent
+ Actions : Elisp_Action_Maps.Map; -- %elisp_action
end record;
function "+" (Item : in String) return
Ada.Strings.Unbounded.Unbounded_String
diff --git a/wisitoken-gen_token_enum.ads b/wisitoken-gen_token_enum.ads
index 36fca14..05bdb99 100644
--- a/wisitoken-gen_token_enum.ads
+++ b/wisitoken-gen_token_enum.ads
@@ -43,44 +43,36 @@ package WisiToken.Gen_Token_Enum is
subtype Nonterminal_Enum_ID is Token_Enum_ID range First_Nonterminal ..
Last_Nonterminal;
LR1_Descriptor : aliased WisiToken.Descriptor :=
- (First_Terminal => +First_Terminal,
- Last_Terminal => +Last_Terminal,
- First_Nonterminal => +First_Nonterminal,
- Last_Nonterminal => +Last_Nonterminal,
- EOI_ID => +EOF_ID,
- Accept_ID => +Accept_ID,
- Case_Insensitive => Case_Insensitive,
- New_Line_ID => Invalid_Token_ID,
- Comment_ID => Invalid_Token_ID,
- Left_Paren_ID => Invalid_Token_ID,
- Right_Paren_ID => Invalid_Token_ID,
- String_1_ID => Invalid_Token_ID,
- String_2_ID => Invalid_Token_ID,
- Embedded_Quote_Escape_Doubled => False,
- Image => (others => null), -- set in body
elaboration time code
- Terminal_Image_Width => Terminal_Enum_ID'Width,
- Image_Width => Token_Enum_ID'Width,
- Last_Lookahead => +Last_Terminal);
+ (First_Terminal => +First_Terminal,
+ Last_Terminal => +Last_Terminal,
+ First_Nonterminal => +First_Nonterminal,
+ Last_Nonterminal => +Last_Nonterminal,
+ EOI_ID => +EOF_ID,
+ Accept_ID => +Accept_ID,
+ Case_Insensitive => Case_Insensitive,
+ New_Line_ID => Invalid_Token_ID,
+ String_1_ID => Invalid_Token_ID,
+ String_2_ID => Invalid_Token_ID,
+ Image => (others => null), -- set in body elaboration
time code
+ Terminal_Image_Width => Terminal_Enum_ID'Width,
+ Image_Width => Token_Enum_ID'Width,
+ Last_Lookahead => +Last_Terminal);
LALR_Descriptor : aliased WisiToken.Descriptor :=
- (First_Terminal => +First_Terminal,
- Last_Terminal => +Last_Terminal,
- First_Nonterminal => +First_Nonterminal,
- Last_Nonterminal => +Last_Nonterminal,
- EOI_ID => +EOF_ID,
- Accept_ID => +Accept_ID,
- Case_Insensitive => Case_Insensitive,
- New_Line_ID => Invalid_Token_ID,
- Comment_ID => Invalid_Token_ID,
- Left_Paren_ID => Invalid_Token_ID,
- Right_Paren_ID => Invalid_Token_ID,
- String_1_ID => Invalid_Token_ID,
- String_2_ID => Invalid_Token_ID,
- Embedded_Quote_Escape_Doubled => False,
- Image => (others => null),
- Terminal_Image_Width => Terminal_Enum_ID'Width,
- Image_Width => Token_Enum_ID'Width,
- Last_Lookahead => +First_Nonterminal);
+ (First_Terminal => +First_Terminal,
+ Last_Terminal => +Last_Terminal,
+ First_Nonterminal => +First_Nonterminal,
+ Last_Nonterminal => +Last_Nonterminal,
+ EOI_ID => +EOF_ID,
+ Accept_ID => +Accept_ID,
+ Case_Insensitive => Case_Insensitive,
+ New_Line_ID => Invalid_Token_ID,
+ String_1_ID => Invalid_Token_ID,
+ String_2_ID => Invalid_Token_ID,
+ Image => (others => null),
+ Terminal_Image_Width => Terminal_Enum_ID'Width,
+ Image_Width => Token_Enum_ID'Width,
+ Last_Lookahead => +First_Nonterminal);
type Enum_Syntax is array (Token_Enum_ID range Token_Enum_ID'First ..
Last_Terminal) of
WisiToken.Lexer.Regexp.Syntax_Item;
diff --git a/wisitoken-generate-lr-lalr_generate.adb
b/wisitoken-generate-lr-lalr_generate.adb
index 2a1f403..f55c822 100644
--- a/wisitoken-generate-lr-lalr_generate.adb
+++ b/wisitoken-generate-lr-lalr_generate.adb
@@ -1,597 +1,610 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-with Ada.Text_IO;
-with SAL.Gen_Definite_Doubly_Linked_Lists;
-package body WisiToken.Generate.LR.LALR_Generate is
-
- package Item_List_Cursor_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists
(LR1_Items.Item_Lists.Cursor);
-
- type Item_Map is record
- -- Keep track of all copies of Item, so Lookaheads can be updated
- -- after they are initially copied.
- From : LR1_Items.Item_Lists.Cursor;
- To : Item_List_Cursor_Lists.List;
- end record;
-
- package Item_Map_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists
(Item_Map);
- -- IMPROVEME: should be a 3D array indexed by Prod, rhs_index,
- -- dot_index. But it's not broken or slow, so we're not fixing it.
-
- function Propagate_Lookahead (Descriptor : in WisiToken.Descriptor) return
access LR1_Items.Lookahead
- is begin
- return new Token_ID_Set'(LR1_Items.To_Lookahead
(Descriptor.Last_Lookahead, Descriptor));
- end Propagate_Lookahead;
-
- function Null_Lookahead (Descriptor : in WisiToken.Descriptor) return
access LR1_Items.Lookahead
- is begin
- return new Token_ID_Set'(Descriptor.First_Terminal ..
Descriptor.Last_Lookahead => False);
- end Null_Lookahead;
-
- ----------
- -- Debug output
-
- procedure Put
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Propagations : in Item_Map_Lists.List)
- is
- use LR1_Items.Item_Lists;
- begin
- for Map of Propagations loop
- Ada.Text_IO.Put ("From ");
- LR1_Items.Put (Grammar, Descriptor, Constant_Ref (Map.From),
Show_Lookaheads => True);
- Ada.Text_IO.New_Line;
-
- for Cur of Map.To loop
- Ada.Text_IO.Put ("To ");
- LR1_Items.Put (Grammar, Descriptor, Constant_Ref (Cur),
Show_Lookaheads => True);
- Ada.Text_IO.New_Line;
- end loop;
- end loop;
- end Put;
-
- ----------
- -- Generate utils
-
- function LALR_Goto_Transitions
- (Kernel : in LR1_Items.Item_Set;
- Symbol : in Token_ID;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set
- is
- use Token_ID_Arrays;
- use LR1_Items;
- use LR1_Items.Item_Lists;
-
- Goto_Set : Item_Set;
- Dot_ID : Token_ID;
- begin
- for Item of Kernel.Set loop
-
- if Has_Element (Item.Dot) then
-
- Dot_ID := Element (Item.Dot);
- -- ID of token after Dot
-
- -- If Symbol = EOF_Token, this is the start symbol accept
- -- production; don't need a kernel with dot after EOF.
- if (Dot_ID = Symbol and Symbol /= Descriptor.EOI_ID) and then
- not Has_Element (Find (Item.Prod, Next (Item.Dot), Goto_Set))
- then
- Goto_Set.Set.Insert
- ((Prod => Item.Prod,
- Dot => Next (Item.Dot),
- Lookaheads => new Token_ID_Set'(Item.Lookaheads.all)));
-
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line ("LALR_Goto_Transitions 1 " & Image
(Symbol, Descriptor));
- Put (Grammar, Descriptor, Goto_Set);
- end if;
- end if;
-
- if Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- First_Nonterm_Set (Dot_ID, Symbol)
- then
- -- Find the production(s) that create Dot_ID with first token
Symbol
- -- and put them in.
- --
- -- This is equivalent to Filter (LR1_Items.Closure,
In_Kernel), but
- -- more efficient, because it does not generate non-kernel
items. See
- -- Test/compare_goto_transitions.adb.
- for Prod of Grammar loop
- for RHS_2_I in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index
loop
- declare
- P_ID : constant Production_ID := (Prod.LHS,
RHS_2_I);
- Dot_2 : constant Token_ID_Arrays.Cursor := Prod.RHSs
(RHS_2_I).Tokens.First;
- begin
- if (Dot_ID = Prod.LHS or First_Nonterm_Set (Dot_ID,
Prod.LHS)) and
- (Has_Element (Dot_2) and then Element (Dot_2) =
Symbol)
- then
- if not Has_Element (Find (P_ID, Next (Dot_2),
Goto_Set)) then
- Goto_Set.Set.Insert
- ((Prod => P_ID,
- Dot => Next (Dot_2),
- Lookaheads => Null_Lookahead (Descriptor)));
-
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line ("LALR_Goto_Transitions
2 " & Image (Symbol, Descriptor));
- Put (Grammar, Descriptor, Goto_Set);
- end if;
-
- -- else already in goto set
- end if;
- end if;
- end;
- end loop;
- end loop;
- end if;
- end if; -- item.dot /= null
- end loop;
-
- return Goto_Set;
- end LALR_Goto_Transitions;
-
- function LALR_Kernels
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set_List
- is
- use all type Token_ID_Arrays.Cursor;
- use all type Ada.Containers.Count_Type;
- use LR1_Items;
-
- First_State_Index : constant State_Index := 0;
- Kernels : LR1_Items.Item_Set_List;
- Kernel_Tree : LR1_Items.Item_Set_Trees.Tree; -- for fast find
- States_To_Check : State_Index_Queues.Queue;
- Checking_State : State_Index;
-
- New_Item_Set : Item_Set :=
- (Set => Item_Lists.To_List
- ((Prod => (Grammar.First_Index, 0),
- Dot => Grammar (Grammar.First_Index).RHSs (0).Tokens.First,
- Lookaheads => Null_Lookahead (Descriptor))),
- Goto_List => <>,
- Dot_IDs => <>,
- State => First_State_Index);
-
- Found_State : Unknown_State_Index;
- begin
- Kernels.Set_First (First_State_Index);
-
- Add (New_Item_Set, Kernels, Kernel_Tree, Descriptor, Include_Lookaheads
=> False);
-
- States_To_Check.Put (First_State_Index);
- loop
- exit when States_To_Check.Is_Empty;
- Checking_State := States_To_Check.Get;
-
- if Trace_Generate > Detail then
- Ada.Text_IO.Put ("Checking ");
- Put (Grammar, Descriptor, Kernels (Checking_State));
- end if;
-
- for Symbol in Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal loop
- -- LALR_Goto_Transitions does _not_ ignore Symbol if it is not in
- -- Item_Set.Dot_IDs, so we can't iterate on that here as we do in
- -- LR1_Generate.
-
- New_Item_Set := LALR_Goto_Transitions
- (Kernels (Checking_State), Symbol, First_Nonterm_Set, Grammar,
Descriptor);
-
- if New_Item_Set.Set.Length > 0 then
-
- Found_State := Find (New_Item_Set, Kernel_Tree,
Match_Lookaheads => False);
-
- if Found_State = Unknown_State then
- New_Item_Set.State := Kernels.Last_Index + 1;
-
- States_To_Check.Put (New_Item_Set.State);
-
- Add (New_Item_Set, Kernels, Kernel_Tree, Descriptor,
Include_Lookaheads => False);
-
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line (" adding state" &
Unknown_State_Index'Image (Kernels.Last_Index));
- end if;
-
- Kernels (Checking_State).Goto_List.Insert ((Symbol,
Kernels.Last_Index));
- else
-
- -- If there's not already a goto entry between these two
sets, create one.
- if not Is_In ((Symbol, Found_State), Kernels
(Checking_State).Goto_List) then
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line
- (" state" & Unknown_State_Index'Image
(Checking_State) &
- " adding goto on " & Image (Symbol, Descriptor) &
" to state" &
- Unknown_State_Index'Image (Found_State));
-
- end if;
-
- Kernels (Checking_State).Goto_List.Insert ((Symbol,
Found_State));
- end if;
- end if;
- end if;
- end loop;
- end loop;
-
- if Trace_Generate > Detail then
- Ada.Text_IO.New_Line;
- end if;
-
- return Kernels;
- end LALR_Kernels;
-
- -- Add a propagation entry (if it doesn't already exist) from From in
- -- From_Set to To_Item.
- procedure Add_Propagation
- (From : in LR1_Items.Item;
- From_Set : in LR1_Items.Item_Set;
- To_Item : in LR1_Items.Item_Lists.Cursor;
- Propagations : in out Item_Map_Lists.List)
- is
- use Item_Map_Lists;
- use Item_List_Cursor_Lists;
- use LR1_Items;
- use LR1_Items.Item_Lists;
-
- From_Cur : constant Item_Lists.Cursor := Find (From, From_Set);
-
- From_Match : Item_Map_Lists.Cursor := Propagations.First;
- To_Match : Item_List_Cursor_Lists.Cursor;
- begin
- Find_From :
- loop
- exit Find_From when not Has_Element (From_Match);
-
- declare
- Map : Item_Map renames Constant_Ref (From_Match);
- begin
- if From_Cur = Map.From then
-
- To_Match := Map.To.First;
- loop
- exit when not Has_Element (To_Match);
-
- declare
- use all type SAL.Compare_Result;
- Cur : Item_Lists.Cursor renames Constant_Ref
(To_Match);
- Test_Item : LR1_Items.Item renames Constant_Ref (Cur);
- begin
- if Equal = LR1_Items.Item_Compare (Test_Item,
Constant_Ref (To_Item)) then
- exit Find_From;
- end if;
- end;
- Next (To_Match);
- end loop;
- exit Find_From;
- end if;
- end;
-
- Next (From_Match);
- end loop Find_From;
-
- if not Has_Element (From_Match) then
- Propagations.Append ((From_Cur, To_List (To_Item)));
-
- elsif not Has_Element (To_Match) then
- Ref (From_Match).To.Append (To_Item);
-
- else
- raise SAL.Programmer_Error with "Add_Propagation: unexpected case";
- end if;
- end Add_Propagation;
-
- -- Calculate the lookaheads from Closure_Item for Source_Item.
- -- Source_Item must be one of the kernel items in Source_Set.
- -- Closure_Item must be an item in the lookahead closure of Source_Item
for #.
- --
- -- Spontaneous lookaheads are put in Source_Item.Lookahead,
- -- propagated lookaheads in Propagations.
- --
- -- Set Used_Tokens = True for all tokens in lookaheads.
- procedure Generate_Lookahead_Info
- (Source_Item : in LR1_Items.Item;
- Source_Set : in LR1_Items.Item_Set;
- Closure_Item : in LR1_Items.Item;
- Propagations : in out Item_Map_Lists.List;
- Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Kernels : in out LR1_Items.Item_Set_List)
- is
- use LR1_Items;
- use LR1_Items.Item_Lists;
- use Token_ID_Arrays;
-
- Spontaneous_Count : Integer := 0;
- begin
- if Trace_Generate > Outline then
- Ada.Text_IO.Put_Line (" closure_item: ");
- LR1_Items.Put (Grammar, Descriptor, Closure_Item);
- Ada.Text_IO.New_Line;
- end if;
-
- if not Has_Element (Closure_Item.Dot) then
- return;
- end if;
-
- declare
- ID : constant Token_ID := Element
(Closure_Item.Dot);
- Next_Dot : constant Token_ID_Arrays.Cursor := Next
(Closure_Item.Dot);
- Goto_State : constant Unknown_State_Index := LR1_Items.Goto_State
(Source_Set, ID);
- To_Item : constant Item_Lists.Cursor :=
- (if Goto_State = Unknown_State then Item_Lists.No_Element
- else LR1_Items.Find (Closure_Item.Prod, Next_Dot, Kernels
(Goto_State)));
- begin
- if Closure_Item.Lookaheads (Descriptor.Last_Lookahead) and
Has_Element (To_Item) then
- Add_Propagation
- (From => Source_Item,
- From_Set => Source_Set,
- To_Item => To_Item,
- Propagations => Propagations);
- end if;
-
- if Has_Element (To_Item) then
- if Trace_Generate > Outline then
- Spontaneous_Count := Spontaneous_Count + 1;
- Ada.Text_IO.Put_Line (" spontaneous: " & Lookahead_Image
(Closure_Item.Lookaheads.all, Descriptor));
- end if;
-
- LR1_Items.Include (Ref (To_Item), Closure_Item.Lookaheads.all,
Descriptor);
- end if;
- end;
- end Generate_Lookahead_Info;
-
- procedure Propagate_Lookaheads
- (List : in Item_Map_Lists.List;
- Descriptor : in WisiToken.Descriptor)
- is
- -- In List, update all To lookaheads from From lookaheads,
- -- recursively.
-
- use LR1_Items.Item_Lists;
-
- More_To_Check : Boolean := True;
- Added_One : Boolean;
- begin
- while More_To_Check loop
-
- More_To_Check := False;
- for Mapping of List loop
- for Copy of Mapping.To loop
- LR1_Items.Include (Ref (Copy), Constant_Ref
(Mapping.From).Lookaheads.all, Added_One, Descriptor);
-
- More_To_Check := More_To_Check or Added_One;
- end loop;
- end loop;
- end loop;
- end Propagate_Lookaheads;
-
- -- Calculate the LALR(1) lookaheads for Grammar.
- -- Kernels should be the sets of LR(0) kernels on input, and will
- -- become the set of LALR(1) kernels on output.
- procedure Fill_In_Lookaheads
- (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Kernels : in out LR1_Items.Item_Set_List;
- Descriptor : in WisiToken.Descriptor)
- is
- pragma Warnings (Off, """Kernel_Item_Set"" is not modified, could be
declared constant");
- -- WORKAROUND: GNAT GPL 2018 complains Kernel_Item_Set could be a
constant, but
- -- when we declare that, it complains the target of the assignment of
- -- .Prod, .Dot below must be a variable.
-
- Kernel_Item_Set : LR1_Items.Item_Set := -- used for temporary arg to
Closure
- (Set => LR1_Items.Item_Lists.To_List
- ((Prod => <>,
- Dot => <>,
- Lookaheads => Propagate_Lookahead (Descriptor))),
- Goto_List => <>,
- Dot_IDs => <>,
- State => <>);
-
- Closure : LR1_Items.Item_Set;
-
- Propagation_List : Item_Map_Lists.List;
-
- begin
- for Kernel of Kernels loop
- if Trace_Generate > Outline then
- Ada.Text_IO.Put ("Adding lookaheads for ");
- LR1_Items.Put (Grammar, Descriptor, Kernel);
- end if;
-
- for Kernel_Item of Kernel.Set loop
- Kernel_Item_Set.Set (Kernel_Item_Set.Set.First).Prod :=
Kernel_Item.Prod;
- Kernel_Item_Set.Set (Kernel_Item_Set.Set.First).Dot :=
Kernel_Item.Dot;
-
- Closure := LR1_Items.Closure
- (Kernel_Item_Set, Has_Empty_Production, First_Terminal_Sequence,
Grammar, Descriptor);
-
- for Closure_Item of Closure.Set loop
- Generate_Lookahead_Info
- (Kernel_Item, Kernel, Closure_Item, Propagation_List,
Descriptor, Grammar, Kernels);
- end loop;
- end loop;
- end loop;
-
- if Trace_Generate > Outline then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("Propagations:");
- Put (Grammar, Descriptor, Propagation_List);
- Ada.Text_IO.New_Line;
- end if;
-
- Propagate_Lookaheads (Propagation_List, Descriptor);
- end Fill_In_Lookaheads;
-
- -- Add actions for all Kernels to Table.
- procedure Add_Actions
- (Kernels : in LR1_Items.Item_Set_List;
- Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Conflicts : out Conflict_Lists.List;
- Table : in out Parse_Table;
- Descriptor : in WisiToken.Descriptor)
- is
- Closure : LR1_Items.Item_Set;
- begin
- for Kernel of Kernels loop
- -- IMPROVEME: there are three "closure" computations that could
- -- probably be refactored to save computation; in
- -- LALR_Goto_Transitions, Fill_In_Lookaheads, and here.
- Closure := LR1_Items.Closure (Kernel, Has_Empty_Production,
First_Terminal_Sequence, Grammar, Descriptor);
-
- Add_Actions (Closure, Table, Grammar, Has_Empty_Production,
First_Nonterm_Set, Conflicts, Descriptor);
- end loop;
-
- if Trace_Generate > Detail then
- Ada.Text_IO.New_Line;
- end if;
- end Add_Actions;
-
- function Generate
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
- McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
- Put_Parse_Table : in Boolean := False)
- return Parse_Table_Ptr
- is
- use all type Ada.Containers.Count_Type;
-
- Ignore_Unused_Tokens : constant Boolean := WisiToken.Trace_Generate
> Detail;
- Ignore_Unknown_Conflicts : constant Boolean := WisiToken.Trace_Generate
> Detail;
- Unused_Tokens : constant Boolean :=
WisiToken.Generate.Check_Unused_Tokens (Descriptor, Grammar);
-
- Table : Parse_Table_Ptr;
-
- Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Grammar);
-
- Minimal_Terminal_Sequences : constant Minimal_Sequence_Array :=
- Compute_Minimal_Terminal_Sequences (Descriptor, Grammar);
-
- Minimal_Terminal_First : constant Token_Array_Token_ID :=
- Compute_Minimal_Terminal_First (Descriptor,
Minimal_Terminal_Sequences);
-
- First_Nonterm_Set : constant Token_Array_Token_Set :=
WisiToken.Generate.First
- (Grammar, Has_Empty_Production, Descriptor.First_Terminal);
-
- First_Terminal_Sequence : constant Token_Sequence_Arrays.Vector :=
- WisiToken.Generate.To_Terminal_Sequence_Array (First_Nonterm_Set,
Descriptor);
-
- Kernels : LR1_Items.Item_Set_List := LALR_Kernels (Grammar,
First_Nonterm_Set, Descriptor);
-
- Unknown_Conflicts : Conflict_Lists.List;
- Known_Conflicts_Edit : Conflict_Lists.List := Known_Conflicts;
-
- begin
- WisiToken.Generate.Error := False; -- necessary in unit tests; some
previous test might have encountered an error.
-
- Fill_In_Lookaheads (Grammar, Has_Empty_Production,
First_Terminal_Sequence, Kernels, Descriptor);
-
- if Unused_Tokens then
- WisiToken.Generate.Error := not Ignore_Unused_Tokens;
- Ada.Text_IO.New_Line;
- end if;
-
- if Trace_Generate > Detail then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("LR(1) Kernels:");
- LR1_Items.Put (Grammar, Descriptor, Kernels, Show_Lookaheads => True);
- end if;
-
- Table := new Parse_Table
- (State_First => Kernels.First_Index,
- State_Last => Kernels.Last_Index,
- First_Terminal => Descriptor.First_Terminal,
- Last_Terminal => Descriptor.Last_Terminal,
- First_Nonterminal => Descriptor.First_Nonterminal,
- Last_Nonterminal => Descriptor.Last_Nonterminal);
-
- if McKenzie_Param = Default_McKenzie_Param then
- -- Descriminants in Default are wrong
- Table.McKenzie_Param :=
- (First_Terminal => Descriptor.First_Terminal,
- Last_Terminal => Descriptor.Last_Terminal,
- First_Nonterminal => Descriptor.First_Nonterminal,
- Last_Nonterminal => Descriptor.Last_Nonterminal,
- Insert => (others => 0),
- Delete => (others => 0),
- Push_Back => (others => 0),
- Ignore_Check_Fail => Default_McKenzie_Param.Ignore_Check_Fail,
- Task_Count => Default_McKenzie_Param.Task_Count,
- Cost_Limit => Default_McKenzie_Param.Cost_Limit,
- Check_Limit => Default_McKenzie_Param.Check_Limit,
- Check_Delta_Limit => Default_McKenzie_Param.Check_Delta_Limit,
- Enqueue_Limit => Default_McKenzie_Param.Enqueue_Limit);
- else
- Table.McKenzie_Param := McKenzie_Param;
- end if;
-
- Add_Actions
- (Kernels, Grammar, Has_Empty_Production, First_Nonterm_Set,
First_Terminal_Sequence, Unknown_Conflicts,
- Table.all, Descriptor);
-
- -- Set Table.States.Productions, Minimal_Complete_Actions for
McKenzie_Recover
- for State in Table.States'Range loop
- Table.States (State).Productions := LR1_Items.Productions (Kernels
(State));
- if Trace_Generate > Extra then
- Ada.Text_IO.Put_Line ("Set_Minimal_Complete_Actions:" &
State_Index'Image (State));
- end if;
- WisiToken.Generate.LR.Set_Minimal_Complete_Actions
- (Table.States (State), Kernels (State), Descriptor, Grammar,
Minimal_Terminal_Sequences,
- Minimal_Terminal_First);
- end loop;
-
- if Put_Parse_Table then
- WisiToken.Generate.LR.Put_Parse_Table
- (Table, "LALR", Grammar, Kernels, Unknown_Conflicts, Descriptor);
- end if;
-
- Delete_Known (Unknown_Conflicts, Known_Conflicts_Edit);
-
- if Unknown_Conflicts.Length > 0 then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "unknown
conflicts:");
- Put (Unknown_Conflicts, Ada.Text_IO.Current_Error, Descriptor);
- Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
- WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
- end if;
-
- if Known_Conflicts_Edit.Length > 0 then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "excess known
conflicts:");
- Put (Known_Conflicts_Edit, Ada.Text_IO.Current_Error, Descriptor);
- Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
- WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
- end if;
-
- return Table;
- end Generate;
-
-end WisiToken.Generate.LR.LALR_Generate;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers;
+with Ada.Text_IO;
+with SAL.Gen_Definite_Doubly_Linked_Lists;
+package body WisiToken.Generate.LR.LALR_Generate is
+
+ package Item_List_Cursor_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists
(LR1_Items.Item_Lists.Cursor);
+
+ type Item_Map is record
+ -- Keep track of all copies of Item, so Lookaheads can be updated
+ -- after they are initially copied.
+ From : LR1_Items.Item_Lists.Cursor;
+ To : Item_List_Cursor_Lists.List;
+ end record;
+
+ package Item_Map_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists
(Item_Map);
+ -- IMPROVEME: should be a 3D array indexed by Prod, rhs_index,
+ -- dot_index. But it's not broken or slow, so we're not fixing it.
+
+ function Propagate_Lookahead (Descriptor : in WisiToken.Descriptor) return
Token_ID_Set_Access
+ is begin
+ return new Token_ID_Set'(LR1_Items.To_Lookahead
(Descriptor.Last_Lookahead, Descriptor));
+ end Propagate_Lookahead;
+
+ function Null_Lookahead (Descriptor : in WisiToken.Descriptor) return
Token_ID_Set_Access
+ is begin
+ return new Token_ID_Set'(Descriptor.First_Terminal ..
Descriptor.Last_Lookahead => False);
+ end Null_Lookahead;
+
+ ----------
+ -- Debug output
+
+ procedure Put
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Propagations : in Item_Map_Lists.List)
+ is
+ use LR1_Items.Item_Lists;
+ begin
+ for Map of Propagations loop
+ Ada.Text_IO.Put ("From ");
+ LR1_Items.Put (Grammar, Descriptor, Constant_Ref (Map.From),
Show_Lookaheads => True);
+ Ada.Text_IO.New_Line;
+
+ for Cur of Map.To loop
+ Ada.Text_IO.Put ("To ");
+ LR1_Items.Put (Grammar, Descriptor, Constant_Ref (Cur),
Show_Lookaheads => True);
+ Ada.Text_IO.New_Line;
+ end loop;
+ end loop;
+ end Put;
+
+ ----------
+ -- Generate utils
+
+ function LALR_Goto_Transitions
+ (Kernel : in LR1_Items.Item_Set;
+ Symbol : in Token_ID;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set
+ is
+ use Token_ID_Arrays;
+ use LR1_Items;
+ use LR1_Items.Item_Lists;
+
+ Goto_Set : Item_Set;
+ Dot_ID : Token_ID;
+ begin
+ for Item of Kernel.Set loop
+
+ if Has_Element (Item.Dot) then
+
+ Dot_ID := Element (Item.Dot);
+ -- ID of token after Dot
+
+ -- If Symbol = EOF_Token, this is the start symbol accept
+ -- production; don't need a kernel with dot after EOF.
+ if (Dot_ID = Symbol and Symbol /= Descriptor.EOI_ID) and then
+ not Has_Element (Find (Item.Prod, Next (Item.Dot), Goto_Set))
+ then
+ Goto_Set.Set.Insert
+ ((Prod => Item.Prod,
+ Dot => Next (Item.Dot),
+ Lookaheads => new Token_ID_Set'(Item.Lookaheads.all)));
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line ("LALR_Goto_Transitions 1 " & Image
(Symbol, Descriptor));
+ Put (Grammar, Descriptor, Goto_Set);
+ end if;
+ end if;
+
+ if Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
+ First_Nonterm_Set (Dot_ID, Symbol)
+ then
+ -- Find the production(s) that create Dot_ID with first token
Symbol
+ -- and put them in.
+ for Prod of Grammar loop
+ for RHS_2_I in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index
loop
+ declare
+ P_ID : constant Production_ID := (Prod.LHS,
RHS_2_I);
+ Dot_2 : constant Token_ID_Arrays.Cursor := Prod.RHSs
(RHS_2_I).Tokens.First;
+ begin
+ if (Dot_ID = Prod.LHS or First_Nonterm_Set (Dot_ID,
Prod.LHS)) and
+ (Has_Element (Dot_2) and then Element (Dot_2) =
Symbol)
+ then
+ if not Has_Element (Find (P_ID, Next (Dot_2),
Goto_Set)) then
+ Goto_Set.Set.Insert
+ ((Prod => P_ID,
+ Dot => Next (Dot_2),
+ Lookaheads => Null_Lookahead (Descriptor)));
+
+ -- else already in goto set
+ end if;
+ end if;
+ end;
+ end loop;
+ end loop;
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line ("LALR_Goto_Transitions 2 " & Image
(Symbol, Descriptor));
+ Put (Grammar, Descriptor, Goto_Set);
+ end if;
+ end if;
+ end if; -- item.dot /= null
+ end loop;
+
+ return Goto_Set;
+ end LALR_Goto_Transitions;
+
+ function LALR_Kernels
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set_List
+ is
+ use all type Token_ID_Arrays.Cursor;
+ use all type Ada.Containers.Count_Type;
+ use LR1_Items;
+
+ First_State_Index : constant State_Index := 0;
+ Kernels : LR1_Items.Item_Set_List;
+ Kernel_Tree : LR1_Items.Item_Set_Trees.Tree; -- for fast find
+ States_To_Check : State_Index_Queues.Queue;
+ Checking_State : State_Index;
+
+ New_Item_Set : Item_Set :=
+ (Set => Item_Lists.To_List
+ ((Prod => (Grammar.First_Index, 0),
+ Dot => Grammar (Grammar.First_Index).RHSs (0).Tokens.First,
+ Lookaheads => Null_Lookahead (Descriptor))),
+ Goto_List => <>,
+ Dot_IDs => <>,
+ State => First_State_Index);
+
+ Found_State : Unknown_State_Index;
+ begin
+ Kernels.Set_First (First_State_Index);
+
+ Add (New_Item_Set, Kernels, Kernel_Tree, Descriptor, Include_Lookaheads
=> False);
+
+ States_To_Check.Put (First_State_Index);
+ loop
+ exit when States_To_Check.Is_Empty;
+ Checking_State := States_To_Check.Get;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put ("Checking ");
+ Put (Grammar, Descriptor, Kernels (Checking_State));
+ end if;
+
+ for Symbol in Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal loop
+ -- LALR_Goto_Transitions does _not_ ignore Symbol if it is not in
+ -- Item_Set.Dot_IDs, so we can't iterate on that here as we do in
+ -- LR1_Generate.
+
+ New_Item_Set := LALR_Goto_Transitions
+ (Kernels (Checking_State), Symbol, First_Nonterm_Set, Grammar,
Descriptor);
+
+ if New_Item_Set.Set.Length > 0 then
+
+ Found_State := Find (New_Item_Set, Kernel_Tree,
Match_Lookaheads => False);
+
+ if Found_State = Unknown_State then
+ New_Item_Set.State := Kernels.Last_Index + 1;
+
+ States_To_Check.Put (New_Item_Set.State);
+
+ Add (New_Item_Set, Kernels, Kernel_Tree, Descriptor,
Include_Lookaheads => False);
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line (" adding state" &
Unknown_State_Index'Image (Kernels.Last_Index));
+
+ Ada.Text_IO.Put_Line
+ (" state" & Unknown_State_Index'Image (Checking_State)
&
+ " adding goto on " & Image (Symbol, Descriptor) & "
to state" &
+ Unknown_State_Index'Image (Kernels.Last_Index));
+ end if;
+
+ Kernels (Checking_State).Goto_List.Insert ((Symbol,
Kernels.Last_Index));
+ else
+
+ -- If there's not already a goto entry between these two
sets, create one.
+ if not Is_In ((Symbol, Found_State), Kernels
(Checking_State).Goto_List) then
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line
+ (" state" & Unknown_State_Index'Image
(Checking_State) &
+ " adding goto on " & Image (Symbol, Descriptor) &
" to state" &
+ Unknown_State_Index'Image (Found_State));
+
+ end if;
+
+ Kernels (Checking_State).Goto_List.Insert ((Symbol,
Found_State));
+ end if;
+ end if;
+ end if;
+ end loop;
+ end loop;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.New_Line;
+ end if;
+
+ return Kernels;
+ end LALR_Kernels;
+
+ -- Add a propagation entry (if it doesn't already exist) from From in
+ -- From_Set to To_Item.
+ procedure Add_Propagation
+ (From : in LR1_Items.Item;
+ From_Set : in LR1_Items.Item_Set;
+ To_Item : in LR1_Items.Item_Lists.Cursor;
+ Propagations : in out Item_Map_Lists.List)
+ is
+ use Item_Map_Lists;
+ use Item_List_Cursor_Lists;
+ use LR1_Items;
+ use LR1_Items.Item_Lists;
+
+ From_Cur : constant Item_Lists.Cursor := Find (From, From_Set);
+
+ From_Match : Item_Map_Lists.Cursor := Propagations.First;
+ To_Match : Item_List_Cursor_Lists.Cursor;
+ begin
+ Find_From :
+ loop
+ exit Find_From when not Has_Element (From_Match);
+
+ declare
+ Map : Item_Map renames Constant_Ref (From_Match);
+ begin
+ if From_Cur = Map.From then
+
+ To_Match := Map.To.First;
+ loop
+ exit when not Has_Element (To_Match);
+
+ declare
+ use all type SAL.Compare_Result;
+ Cur : Item_Lists.Cursor renames Constant_Ref
(To_Match);
+ Test_Item : LR1_Items.Item renames Constant_Ref (Cur);
+ begin
+ if Equal = LR1_Items.Item_Compare (Test_Item,
Constant_Ref (To_Item)) then
+ exit Find_From;
+ end if;
+ end;
+ Next (To_Match);
+ end loop;
+ exit Find_From;
+ end if;
+ end;
+
+ Next (From_Match);
+ end loop Find_From;
+
+ if not Has_Element (From_Match) then
+ Propagations.Append ((From_Cur, To_List (To_Item)));
+
+ elsif not Has_Element (To_Match) then
+ Ref (From_Match).To.Append (To_Item);
+
+ else
+ raise SAL.Programmer_Error with "Add_Propagation: unexpected case";
+ end if;
+ end Add_Propagation;
+
+ -- Calculate the lookaheads from Closure_Item for Source_Item.
+ -- Source_Item must be one of the kernel items in Source_Set.
+ -- Closure_Item must be an item in the lookahead closure of Source_Item
for #.
+ --
+ -- Spontaneous lookaheads are put in Source_Item.Lookahead,
+ -- propagated lookaheads in Propagations.
+ --
+ -- Set Used_Tokens = True for all tokens in lookaheads.
+ procedure Generate_Lookahead_Info
+ (Source_Item : in LR1_Items.Item;
+ Source_Set : in LR1_Items.Item_Set;
+ Closure_Item : in LR1_Items.Item;
+ Propagations : in out Item_Map_Lists.List;
+ Descriptor : in WisiToken.Descriptor;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Kernels : in out LR1_Items.Item_Set_List)
+ is
+ use LR1_Items;
+ use LR1_Items.Item_Lists;
+ use Token_ID_Arrays;
+
+ Spontaneous_Count : Integer := 0;
+ begin
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line (" closure_item: ");
+ LR1_Items.Put (Grammar, Descriptor, Closure_Item);
+ Ada.Text_IO.New_Line;
+ end if;
+
+ if not Has_Element (Closure_Item.Dot) then
+ return;
+ end if;
+
+ declare
+ ID : constant Token_ID := Element
(Closure_Item.Dot);
+ Next_Dot : constant Token_ID_Arrays.Cursor := Next
(Closure_Item.Dot);
+ Goto_State : constant Unknown_State_Index := LR1_Items.Goto_State
(Source_Set, ID);
+ To_Item : constant Item_Lists.Cursor :=
+ (if Goto_State = Unknown_State then Item_Lists.No_Element
+ else LR1_Items.Find (Closure_Item.Prod, Next_Dot, Kernels
(Goto_State)));
+ begin
+ if Closure_Item.Lookaheads (Descriptor.Last_Lookahead) and
Has_Element (To_Item) then
+ Add_Propagation
+ (From => Source_Item,
+ From_Set => Source_Set,
+ To_Item => To_Item,
+ Propagations => Propagations);
+ end if;
+
+ if Has_Element (To_Item) then
+ if Trace_Generate > Outline then
+ Spontaneous_Count := Spontaneous_Count + 1;
+ Ada.Text_IO.Put_Line (" spontaneous: " & Lookahead_Image
(Closure_Item.Lookaheads.all, Descriptor));
+ end if;
+
+ LR1_Items.Include (Ref (To_Item), Closure_Item.Lookaheads.all,
Descriptor);
+ end if;
+ end;
+ end Generate_Lookahead_Info;
+
+ procedure Propagate_Lookaheads
+ (List : in Item_Map_Lists.List;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ -- In List, update all To lookaheads from From lookaheads,
+ -- recursively.
+
+ use LR1_Items.Item_Lists;
+
+ More_To_Check : Boolean := True;
+ Added_One : Boolean;
+ begin
+ while More_To_Check loop
+
+ More_To_Check := False;
+ for Mapping of List loop
+ for Copy of Mapping.To loop
+ LR1_Items.Include (Ref (Copy), Constant_Ref
(Mapping.From).Lookaheads.all, Added_One, Descriptor);
+
+ More_To_Check := More_To_Check or Added_One;
+ end loop;
+ end loop;
+ end loop;
+ end Propagate_Lookaheads;
+
+ -- Calculate the LALR(1) lookaheads for Grammar.
+ -- Kernels should be the sets of LR(0) kernels on input, and will
+ -- become the set of LALR(1) kernels on output.
+ procedure Fill_In_Lookaheads
+ (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Kernels : in out LR1_Items.Item_Set_List;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ pragma Warnings (Off, """Kernel_Item_Set"" is not modified, could be
declared constant");
+ -- WORKAROUND: GNAT GPL 2018 complains Kernel_Item_Set could be a
constant, but
+ -- when we declare that, it complains the target of the assignment of
+ -- .Prod, .Dot below must be a variable.
+
+ Kernel_Item_Set : LR1_Items.Item_Set := -- used for temporary arg to
Closure
+ (Set => LR1_Items.Item_Lists.To_List
+ ((Prod => <>,
+ Dot => <>,
+ Lookaheads => Propagate_Lookahead (Descriptor))),
+ Goto_List => <>,
+ Dot_IDs => <>,
+ State => <>);
+
+ Closure : LR1_Items.Item_Set;
+
+ Propagation_List : Item_Map_Lists.List;
+
+ begin
+ for Kernel of Kernels loop
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put ("Adding lookaheads for ");
+ LR1_Items.Put (Grammar, Descriptor, Kernel);
+ end if;
+
+ for Kernel_Item of Kernel.Set loop
+ Kernel_Item_Set.Set (Kernel_Item_Set.Set.First).Prod :=
Kernel_Item.Prod;
+ Kernel_Item_Set.Set (Kernel_Item_Set.Set.First).Dot :=
Kernel_Item.Dot;
+
+ Closure := LR1_Items.Closure
+ (Kernel_Item_Set, Has_Empty_Production, First_Terminal_Sequence,
Grammar, Descriptor);
+
+ for Closure_Item of Closure.Set loop
+ Generate_Lookahead_Info
+ (Kernel_Item, Kernel, Closure_Item, Propagation_List,
Descriptor, Grammar, Kernels);
+ end loop;
+ end loop;
+ end loop;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Propagations:");
+ Put (Grammar, Descriptor, Propagation_List);
+ Ada.Text_IO.New_Line;
+ end if;
+
+ Propagate_Lookaheads (Propagation_List, Descriptor);
+ end Fill_In_Lookaheads;
+
+ -- Add actions for all Kernels to Table.
+ procedure Add_Actions
+ (Kernels : in LR1_Items.Item_Set_List;
+ Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Conflict_Counts : out Conflict_Count_Lists.List;
+ Conflicts : out Conflict_Lists.List;
+ Table : in out Parse_Table;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ Closure : LR1_Items.Item_Set;
+ begin
+ for Kernel of Kernels loop
+ -- IMPROVEME: there are three "closure" computations that could
+ -- probably be refactored to save computation; in
+ -- LALR_Goto_Transitions, Fill_In_Lookaheads, and here.
+ Closure := LR1_Items.Closure (Kernel, Has_Empty_Production,
First_Terminal_Sequence, Grammar, Descriptor);
+
+ Add_Actions
+ (Closure, Table, Grammar, Has_Empty_Production, First_Nonterm_Set,
+ Conflict_Counts, Conflicts, Descriptor);
+ end loop;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.New_Line;
+ end if;
+ end Add_Actions;
+
+ function Generate
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
+ McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
+ Put_Parse_Table : in Boolean := False;
+ Include_Extra : in Boolean := False;
+ Ignore_Conflicts : in Boolean := False;
+ Partial_Recursion : in Boolean := True)
+ return Parse_Table_Ptr
+ is
+ use all type Ada.Containers.Count_Type;
+
+ Ignore_Unused_Tokens : constant Boolean := WisiToken.Trace_Generate
> Detail;
+ Ignore_Unknown_Conflicts : constant Boolean := Ignore_Conflicts or
WisiToken.Trace_Generate > Detail;
+ Unused_Tokens : constant Boolean :=
WisiToken.Generate.Check_Unused_Tokens (Descriptor, Grammar);
+
+ Table : Parse_Table_Ptr;
+
+ Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Grammar);
+
+ Recursions : constant WisiToken.Generate.Recursions :=
+ (if Partial_Recursion
+ then WisiToken.Generate.Compute_Partial_Recursion (Grammar)
+ else WisiToken.Generate.Compute_Full_Recursion (Grammar));
+ Minimal_Terminal_Sequences : constant Minimal_Sequence_Array :=
+ Compute_Minimal_Terminal_Sequences (Descriptor, Grammar, Recursions);
+
+ Minimal_Terminal_First : constant Token_Array_Token_ID :=
+ Compute_Minimal_Terminal_First (Descriptor,
Minimal_Terminal_Sequences);
+
+ First_Nonterm_Set : constant Token_Array_Token_Set :=
WisiToken.Generate.First
+ (Grammar, Has_Empty_Production, Descriptor.First_Terminal);
+
+ First_Terminal_Sequence : constant Token_Sequence_Arrays.Vector :=
+ WisiToken.Generate.To_Terminal_Sequence_Array (First_Nonterm_Set,
Descriptor);
+
+ Kernels : LR1_Items.Item_Set_List := LALR_Kernels (Grammar,
First_Nonterm_Set, Descriptor);
+
+ Conflict_Counts : Conflict_Count_Lists.List;
+ Unknown_Conflicts : Conflict_Lists.List;
+ Known_Conflicts_Edit : Conflict_Lists.List := Known_Conflicts;
+
+ begin
+ WisiToken.Generate.Error := False; -- necessary in unit tests; some
previous test might have encountered an error.
+
+ Fill_In_Lookaheads (Grammar, Has_Empty_Production,
First_Terminal_Sequence, Kernels, Descriptor);
+
+ if Unused_Tokens then
+ WisiToken.Generate.Error := not Ignore_Unused_Tokens;
+ Ada.Text_IO.New_Line;
+ end if;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("LR(1) Kernels:");
+ LR1_Items.Put (Grammar, Descriptor, Kernels, Show_Lookaheads => True);
+ end if;
+
+ Table := new Parse_Table
+ (State_First => Kernels.First_Index,
+ State_Last => Kernels.Last_Index,
+ First_Terminal => Descriptor.First_Terminal,
+ Last_Terminal => Descriptor.Last_Terminal,
+ First_Nonterminal => Descriptor.First_Nonterminal,
+ Last_Nonterminal => Descriptor.Last_Nonterminal);
+
+ if McKenzie_Param = Default_McKenzie_Param then
+ -- Descriminants in Default are wrong
+ Table.McKenzie_Param :=
+ (First_Terminal => Descriptor.First_Terminal,
+ Last_Terminal => Descriptor.Last_Terminal,
+ First_Nonterminal => Descriptor.First_Nonterminal,
+ Last_Nonterminal => Descriptor.Last_Nonterminal,
+ Insert => (others => 0),
+ Delete => (others => 0),
+ Push_Back => (others => 0),
+ Undo_Reduce => (others => 0),
+ Minimal_Complete_Cost_Delta =>
Default_McKenzie_Param.Minimal_Complete_Cost_Delta,
+ Fast_Forward => Default_McKenzie_Param.Fast_Forward,
+ Matching_Begin =>
Default_McKenzie_Param.Matching_Begin,
+ Ignore_Check_Fail =>
Default_McKenzie_Param.Ignore_Check_Fail,
+ Task_Count => Default_McKenzie_Param.Task_Count,
+ Check_Limit => Default_McKenzie_Param.Check_Limit,
+ Check_Delta_Limit =>
Default_McKenzie_Param.Check_Delta_Limit,
+ Enqueue_Limit =>
Default_McKenzie_Param.Enqueue_Limit);
+ else
+ Table.McKenzie_Param := McKenzie_Param;
+ end if;
+
+ Add_Actions
+ (Kernels, Grammar, Has_Empty_Production, First_Nonterm_Set,
First_Terminal_Sequence, Conflict_Counts,
+ Unknown_Conflicts, Table.all, Descriptor);
+
+ for State in Table.States'Range loop
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line ("Set_Minimal_Complete_Actions:" &
State_Index'Image (State));
+ end if;
+ WisiToken.Generate.LR.Set_Minimal_Complete_Actions
+ (Table.States (State), Kernels (State), Descriptor, Grammar,
Minimal_Terminal_Sequences,
+ Minimal_Terminal_First);
+ end loop;
+
+ if Put_Parse_Table then
+ WisiToken.Generate.LR.Put_Parse_Table
+ (Table, "LALR", Grammar, Recursions, Minimal_Terminal_Sequences,
Kernels, Conflict_Counts, Descriptor,
+ Include_Extra);
+ end if;
+
+ Delete_Known (Unknown_Conflicts, Known_Conflicts_Edit);
+
+ if Unknown_Conflicts.Length > 0 then
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "unknown
conflicts:");
+ Put (Unknown_Conflicts, Ada.Text_IO.Current_Error, Descriptor);
+ Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
+ WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
+ end if;
+
+ if Known_Conflicts_Edit.Length > 0 then
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "excess known
conflicts:");
+ Put (Known_Conflicts_Edit, Ada.Text_IO.Current_Error, Descriptor);
+ Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
+ WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
+ end if;
+
+ return Table;
+ end Generate;
+
+end WisiToken.Generate.LR.LALR_Generate;
diff --git a/wisitoken-generate-lr-lalr_generate.ads
b/wisitoken-generate-lr-lalr_generate.ads
index b4a109f..9e33931 100644
--- a/wisitoken-generate-lr-lalr_generate.ads
+++ b/wisitoken-generate-lr-lalr_generate.ads
@@ -25,11 +25,14 @@ with WisiToken.Productions;
package WisiToken.Generate.LR.LALR_Generate is
function Generate
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
- McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
- Put_Parse_Table : in Boolean := False)
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
+ McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
+ Put_Parse_Table : in Boolean := False;
+ Include_Extra : in Boolean := False;
+ Ignore_Conflicts : in Boolean := False;
+ Partial_Recursion : in Boolean := True)
return Parse_Table_Ptr
with Pre =>
Descriptor.Last_Lookahead = Descriptor.First_Nonterminal and
@@ -76,6 +79,7 @@ package WisiToken.Generate.LR.LALR_Generate is
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Conflict_Counts : out Conflict_Count_Lists.List;
Conflicts : out Conflict_Lists.List;
Table : in out Parse_Table;
Descriptor : in WisiToken.Descriptor);
diff --git a/wisitoken-generate-lr-lr1_generate.adb
b/wisitoken-generate-lr-lr1_generate.adb
index 62c20c1..0f177d9 100644
--- a/wisitoken-generate-lr-lr1_generate.adb
+++ b/wisitoken-generate-lr-lr1_generate.adb
@@ -1,321 +1,331 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-with Ada.Text_IO;
-with WisiToken.Generate;
-package body WisiToken.Generate.LR.LR1_Generate is
-
- function LR1_Goto_Transitions
- (Set : in LR1_Items.Item_Set;
- Symbol : in Token_ID;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set
- is
- use all type Ada.Containers.Count_Type;
- use Token_ID_Arrays;
- use LR1_Items;
-
- Goto_Set : Item_Set;
- begin
- for Item of Set.Set loop
- if Item.Dot /= No_Element then
- if Element (Item.Dot) = Symbol and
- -- We don't need a state with dot after EOI in the
- -- accept production. EOI should only appear in the
- -- accept production.
- Symbol /= Descriptor.EOI_ID
- then
- Goto_Set.Set.Insert ((Item.Prod, Next (Item.Dot), new
Token_ID_Set'(Item.Lookaheads.all)));
- end if;
- end if;
- end loop;
-
- if Goto_Set.Set.Length > 0 then
- return Closure (Goto_Set, Has_Empty_Production,
First_Terminal_Sequence, Grammar, Descriptor);
- else
- return Goto_Set;
- end if;
- end LR1_Goto_Transitions;
-
- function LR1_Item_Sets
- (Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set_List
- is
- use all type Ada.Containers.Count_Type;
-
- -- [dragon] algorithm 4.9 pg 231; figure 4.38 pg 232; procedure
- -- "items", with some optimizations.
-
- use LR1_Items;
-
- First_State_Index : constant State_Index := 0;
-
- C : LR1_Items.Item_Set_List; -- result
- C_Tree : LR1_Items.Item_Set_Trees.Tree; -- for fast find
- States_To_Check : State_Index_Queues.Queue;
- -- [dragon] specifies 'until no more items can be added', but we use
- -- a queue to avoid checking unecessary states. Ada LR1 has over
- -- 100,000 states, so this is a significant gain (reduced time from
- -- 600 seconds to 40).
-
- I : State_Index;
- Dot_IDs : Token_ID_Arrays.Vector;
-
- New_Item_Set : Item_Set := Closure
- ((Set => Item_Lists.To_List
- ((Prod => (Grammar.First_Index, 0),
- Dot => Grammar (Grammar.First_Index).RHSs
(0).Tokens.First,
- Lookaheads => new Token_ID_Set'(To_Lookahead (Descriptor.EOI_ID,
Descriptor)))),
- Goto_List => <>,
- Dot_IDs => <>,
- State => First_State_Index),
- Has_Empty_Production, First_Terminal_Sequence, Grammar, Descriptor);
-
- Found_State : Unknown_State_Index;
-
- begin
- C.Set_First (First_State_Index);
-
- Add (New_Item_Set, C, C_Tree, Descriptor, Include_Lookaheads => True);
-
- States_To_Check.Put (First_State_Index);
- loop
- exit when States_To_Check.Is_Empty;
- I := States_To_Check.Get;
-
- if Trace_Generate > Outline then
- Ada.Text_IO.Put ("Checking ");
- Put (Grammar, Descriptor, C (I), Show_Lookaheads => True,
Show_Goto_List => True);
- end if;
-
- Dot_IDs := C (I).Dot_IDs;
- -- We can't iterate on C (I).Dot_IDs when the loop adds items to C;
- -- it might be reallocated to grow.
-
- for Symbol of Dot_IDs loop
- -- [dragon] has 'for each grammar symbol X', but
LR1_Goto_Transitions
- -- rejects Symbol that is not in Dot_IDs, so we iterate over that.
-
- New_Item_Set := LR1_Goto_Transitions
- (C (I), Symbol, Has_Empty_Production, First_Terminal_Sequence,
Grammar, Descriptor);
-
- if New_Item_Set.Set.Length > 0 then -- 'goto (I, X) not empty'
-
- Found_State := Find (New_Item_Set, C_Tree, Match_Lookaheads =>
True); -- 'not in C'
-
- if Found_State = Unknown_State then
- New_Item_Set.State := C.Last_Index + 1;
-
- States_To_Check.Put (New_Item_Set.State);
-
- Add (New_Item_Set, C, C_Tree, Descriptor, Include_Lookaheads
=> True);
-
- if Trace_Generate > Outline then
- Ada.Text_IO.Put_Line
- (" adding state" & Unknown_State_Index'Image
(C.Last_Index) & ": from state" &
- Unknown_State_Index'Image (I) & " on " & Image
(Symbol, Descriptor));
- Put (Grammar, Descriptor, New_Item_Set, Show_Lookaheads
=> True);
- end if;
-
- C (I).Goto_List.Insert ((Symbol, C.Last_Index));
- else
-
- -- If there's not already a goto entry between these two
sets, create one.
- if not Is_In ((Symbol, Found_State), Goto_List => C
(I).Goto_List) then
- if Trace_Generate > Outline then
- Ada.Text_IO.Put_Line
- (" adding goto on " & Image (Symbol, Descriptor) &
" to state" &
- Unknown_State_Index'Image (Found_State));
-
- end if;
-
- C (I).Goto_List.Insert ((Symbol, Found_State));
- end if;
- end if;
- end if;
- end loop;
- end loop;
-
- if Trace_Generate > Outline then
- Ada.Text_IO.New_Line;
- end if;
-
- return C;
- end LR1_Item_Sets;
-
- procedure Add_Actions
- (Item_Sets : in LR1_Items.Item_Set_List;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflicts : out Conflict_Lists.List;
- Table : in out Parse_Table;
- Descriptor : in WisiToken.Descriptor)
- is
- -- Add actions for all Item_Sets to Table.
- begin
- for Item_Set of Item_Sets loop
- Add_Actions (Item_Set, Table, Grammar, Has_Empty_Production,
First_Nonterm_Set, Conflicts, Descriptor);
- end loop;
-
- if Trace_Generate > Outline then
- Ada.Text_IO.New_Line;
- end if;
- end Add_Actions;
-
- function Generate
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
- McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
- Put_Parse_Table : in Boolean := False)
- return Parse_Table_Ptr
- is
- use type Ada.Containers.Count_Type;
-
- Ignore_Unused_Tokens : constant Boolean := WisiToken.Trace_Generate
> Detail;
- Ignore_Unknown_Conflicts : constant Boolean := WisiToken.Trace_Generate
> Detail;
- Unused_Tokens : constant Boolean :=
WisiToken.Generate.Check_Unused_Tokens (Descriptor, Grammar);
-
- Table : Parse_Table_Ptr;
-
- Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Grammar);
-
- Minimal_Terminal_Sequences : constant Minimal_Sequence_Array :=
- Compute_Minimal_Terminal_Sequences (Descriptor, Grammar);
-
- Minimal_Terminal_First : constant Token_Array_Token_ID :=
- Compute_Minimal_Terminal_First (Descriptor,
Minimal_Terminal_Sequences);
-
- First_Nonterm_Set : constant Token_Array_Token_Set :=
WisiToken.Generate.First
- (Grammar, Has_Empty_Production, Descriptor.First_Terminal);
-
- First_Terminal_Sequence : constant Token_Sequence_Arrays.Vector :=
- WisiToken.Generate.To_Terminal_Sequence_Array (First_Nonterm_Set,
Descriptor);
-
- Item_Sets : constant LR1_Items.Item_Set_List := LR1_Item_Sets
- (Has_Empty_Production, First_Terminal_Sequence, Grammar, Descriptor);
-
- Unknown_Conflicts : Conflict_Lists.List;
- Known_Conflicts_Edit : Conflict_Lists.List := Known_Conflicts;
- begin
- if Trace_Generate > Outline then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("LR(1) Item_Sets:");
- LR1_Items.Put (Grammar, Descriptor, Item_Sets);
- end if;
-
- Table := new Parse_Table
- (State_First => Item_Sets.First_Index,
- State_Last => Item_Sets.Last_Index,
- First_Terminal => Descriptor.First_Terminal,
- Last_Terminal => Descriptor.Last_Terminal,
- First_Nonterminal => Descriptor.First_Nonterminal,
- Last_Nonterminal => Descriptor.Last_Nonterminal);
-
- if McKenzie_Param = Default_McKenzie_Param then
- -- Descriminants in Default are wrong
- Table.McKenzie_Param :=
- (First_Terminal => Descriptor.First_Terminal,
- Last_Terminal => Descriptor.Last_Terminal,
- First_Nonterminal => Descriptor.First_Nonterminal,
- Last_Nonterminal => Descriptor.Last_Nonterminal,
- Insert => (others => 0),
- Delete => (others => 0),
- Push_Back => (others => 0),
- Ignore_Check_Fail => Default_McKenzie_Param.Ignore_Check_Fail,
- Task_Count => Default_McKenzie_Param.Task_Count,
- Cost_Limit => Default_McKenzie_Param.Cost_Limit,
- Check_Limit => Default_McKenzie_Param.Check_Limit,
- Check_Delta_Limit => Default_McKenzie_Param.Check_Delta_Limit,
- Enqueue_Limit => Default_McKenzie_Param.Enqueue_Limit);
- else
- Table.McKenzie_Param := McKenzie_Param;
- end if;
-
- Add_Actions
- (Item_Sets, Grammar, Has_Empty_Production, First_Nonterm_Set,
Unknown_Conflicts, Table.all, Descriptor);
-
- -- Set Table.States.Productions, Minimal_Complete_Actions for
McKenzie_Recover
- for State in Table.States'Range loop
- Table.States (State).Productions := LR1_Items.Productions
- (LR1_Items.Filter (Item_Sets (State), Grammar, Descriptor,
LR1_Items.In_Kernel'Access));
-
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line ("Set_Minimal_Complete_Actions:" &
State_Index'Image (State));
- end if;
-
- WisiToken.Generate.LR.Set_Minimal_Complete_Actions
- (Table.States (State),
- LR1_Items.Filter (Item_Sets (State), Grammar, Descriptor,
LR1_Items.In_Kernel'Access),
- Descriptor, Grammar, Minimal_Terminal_Sequences,
Minimal_Terminal_First);
- end loop;
-
- if Put_Parse_Table then
- WisiToken.Generate.LR.Put_Parse_Table
- (Table, "LR1", Grammar, Item_Sets, Unknown_Conflicts, Descriptor);
- end if;
-
- if Trace_Generate > Outline then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("Has_Empty_Production: " & Image
(Has_Empty_Production, Descriptor));
-
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("Minimal_Terminal_First:");
- for ID in Minimal_Terminal_First'Range loop
- Ada.Text_IO.Put_Line
- (Image (ID, Descriptor) & " =>" &
- (if Minimal_Terminal_First (ID) = Invalid_Token_ID
- then ""
- else ' ' & Image (Minimal_Terminal_First (ID), Descriptor)));
- end loop;
- end if;
-
- Delete_Known (Unknown_Conflicts, Known_Conflicts_Edit);
-
- if Unknown_Conflicts.Length > 0 then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "unknown
conflicts:");
- Put (Unknown_Conflicts, Ada.Text_IO.Current_Error, Descriptor);
- Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
- WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
- end if;
-
- if Known_Conflicts_Edit.Length > 0 then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "excess known
conflicts:");
- Put (Known_Conflicts_Edit, Ada.Text_IO.Current_Error, Descriptor);
- Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
- WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
- end if;
-
- WisiToken.Generate.Error := WisiToken.Generate.Error or (Unused_Tokens
and not Ignore_Unused_Tokens);
-
- return Table;
- end Generate;
-
-end WisiToken.Generate.LR.LR1_Generate;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers;
+with Ada.Text_IO;
+with WisiToken.Generate;
+package body WisiToken.Generate.LR.LR1_Generate is
+
+ function LR1_Goto_Transitions
+ (Set : in LR1_Items.Item_Set;
+ Symbol : in Token_ID;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set
+ is
+ use all type Ada.Containers.Count_Type;
+ use Token_ID_Arrays;
+ use LR1_Items;
+
+ Goto_Set : Item_Set;
+ begin
+ for Item of Set.Set loop
+ if Item.Dot /= No_Element then
+ if Element (Item.Dot) = Symbol and
+ -- We don't need a state with dot after EOI in the
+ -- accept production. EOI should only appear in the
+ -- accept production.
+ Symbol /= Descriptor.EOI_ID
+ then
+ Goto_Set.Set.Insert ((Item.Prod, Next (Item.Dot), new
Token_ID_Set'(Item.Lookaheads.all)));
+ end if;
+ end if;
+ end loop;
+
+ if Goto_Set.Set.Length > 0 then
+ return Closure (Goto_Set, Has_Empty_Production,
First_Terminal_Sequence, Grammar, Descriptor);
+ else
+ return Goto_Set;
+ end if;
+ end LR1_Goto_Transitions;
+
+ function LR1_Item_Sets
+ (Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set_List
+ is
+ use all type Ada.Containers.Count_Type;
+
+ -- [dragon] algorithm 4.9 pg 231; figure 4.38 pg 232; procedure
+ -- "items", with some optimizations.
+
+ use LR1_Items;
+
+ First_State_Index : constant State_Index := 0;
+
+ C : LR1_Items.Item_Set_List; -- result
+ C_Tree : LR1_Items.Item_Set_Trees.Tree; -- for fast find
+ States_To_Check : State_Index_Queues.Queue;
+ -- [dragon] specifies 'until no more items can be added', but we use
+ -- a queue to avoid checking unecessary states. Ada LR1 has over
+ -- 100,000 states, so this is a significant gain (reduced time from
+ -- 600 seconds to 40).
+
+ I : State_Index;
+ Dot_IDs : Token_ID_Arrays.Vector;
+
+ New_Item_Set : Item_Set := Closure
+ ((Set => Item_Lists.To_List
+ ((Prod => (Grammar.First_Index, 0),
+ Dot => Grammar (Grammar.First_Index).RHSs
(0).Tokens.First,
+ Lookaheads => new Token_ID_Set'(To_Lookahead (Descriptor.EOI_ID,
Descriptor)))),
+ Goto_List => <>,
+ Dot_IDs => <>,
+ State => First_State_Index),
+ Has_Empty_Production, First_Terminal_Sequence, Grammar, Descriptor);
+
+ Found_State : Unknown_State_Index;
+
+ begin
+ C.Set_First (First_State_Index);
+
+ Add (New_Item_Set, C, C_Tree, Descriptor, Include_Lookaheads => True);
+
+ States_To_Check.Put (First_State_Index);
+ loop
+ exit when States_To_Check.Is_Empty;
+ I := States_To_Check.Get;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put ("Checking ");
+ Put (Grammar, Descriptor, C (I), Show_Lookaheads => True,
Show_Goto_List => True);
+ end if;
+
+ Dot_IDs := C (I).Dot_IDs;
+ -- We can't iterate on C (I).Dot_IDs when the loop adds items to C;
+ -- it might be reallocated to grow.
+
+ for Symbol of Dot_IDs loop
+ -- [dragon] has 'for each grammar symbol X', but
LR1_Goto_Transitions
+ -- rejects Symbol that is not in Dot_IDs, so we iterate over that.
+
+ New_Item_Set := LR1_Goto_Transitions
+ (C (I), Symbol, Has_Empty_Production, First_Terminal_Sequence,
Grammar, Descriptor);
+
+ if New_Item_Set.Set.Length > 0 then -- 'goto (I, X) not empty'
+
+ Found_State := Find (New_Item_Set, C_Tree, Match_Lookaheads =>
True); -- 'not in C'
+
+ if Found_State = Unknown_State then
+ New_Item_Set.State := C.Last_Index + 1;
+
+ States_To_Check.Put (New_Item_Set.State);
+
+ Add (New_Item_Set, C, C_Tree, Descriptor, Include_Lookaheads
=> True);
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line
+ (" adding state" & Unknown_State_Index'Image
(C.Last_Index) & ": from state" &
+ Unknown_State_Index'Image (I) & " on " & Image
(Symbol, Descriptor));
+ Put (Grammar, Descriptor, New_Item_Set, Show_Lookaheads
=> True);
+ end if;
+
+ C (I).Goto_List.Insert ((Symbol, C.Last_Index));
+ else
+
+ -- If there's not already a goto entry between these two
sets, create one.
+ if not Is_In ((Symbol, Found_State), Goto_List => C
(I).Goto_List) then
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line
+ (" adding goto on " & Image (Symbol, Descriptor) &
" to state" &
+ Unknown_State_Index'Image (Found_State));
+
+ end if;
+
+ C (I).Goto_List.Insert ((Symbol, Found_State));
+ end if;
+ end if;
+ end if;
+ end loop;
+ end loop;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ end if;
+
+ return C;
+ end LR1_Item_Sets;
+
+ procedure Add_Actions
+ (Item_Sets : in LR1_Items.Item_Set_List;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflict_Counts : out Conflict_Count_Lists.List;
+ Conflicts : out Conflict_Lists.List;
+ Table : in out Parse_Table;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ -- Add actions for all Item_Sets to Table.
+ begin
+ for Item_Set of Item_Sets loop
+ Add_Actions
+ (Item_Set, Table, Grammar, Has_Empty_Production, First_Nonterm_Set,
Conflict_Counts, Conflicts, Descriptor);
+ end loop;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ end if;
+ end Add_Actions;
+
+ function Generate
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
+ McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
+ Put_Parse_Table : in Boolean := False;
+ Include_Extra : in Boolean := False;
+ Ignore_Conflicts : in Boolean := False;
+ Partial_Recursion : in Boolean := True)
+ return Parse_Table_Ptr
+ is
+ use type Ada.Containers.Count_Type;
+
+ Ignore_Unused_Tokens : constant Boolean := WisiToken.Trace_Generate
> Detail;
+ Ignore_Unknown_Conflicts : constant Boolean := Ignore_Conflicts or
WisiToken.Trace_Generate > Detail;
+ Unused_Tokens : constant Boolean :=
WisiToken.Generate.Check_Unused_Tokens (Descriptor, Grammar);
+
+ Table : Parse_Table_Ptr;
+
+ Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Grammar);
+
+ Recursions : constant WisiToken.Generate.Recursions :=
+ (if Partial_Recursion
+ then WisiToken.Generate.Compute_Partial_Recursion (Grammar)
+ else WisiToken.Generate.Compute_Full_Recursion (Grammar));
+ Minimal_Terminal_Sequences : constant Minimal_Sequence_Array :=
+ Compute_Minimal_Terminal_Sequences (Descriptor, Grammar, Recursions);
+
+ Minimal_Terminal_First : constant Token_Array_Token_ID :=
+ Compute_Minimal_Terminal_First (Descriptor,
Minimal_Terminal_Sequences);
+
+ First_Nonterm_Set : constant Token_Array_Token_Set :=
WisiToken.Generate.First
+ (Grammar, Has_Empty_Production, Descriptor.First_Terminal);
+
+ First_Terminal_Sequence : constant Token_Sequence_Arrays.Vector :=
+ WisiToken.Generate.To_Terminal_Sequence_Array (First_Nonterm_Set,
Descriptor);
+
+ Item_Sets : constant LR1_Items.Item_Set_List := LR1_Item_Sets
+ (Has_Empty_Production, First_Terminal_Sequence, Grammar, Descriptor);
+
+ Conflict_Counts : Conflict_Count_Lists.List;
+ Unknown_Conflicts : Conflict_Lists.List;
+ Known_Conflicts_Edit : Conflict_Lists.List := Known_Conflicts;
+ begin
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("LR(1) Item_Sets:");
+ LR1_Items.Put (Grammar, Descriptor, Item_Sets);
+ end if;
+
+ Table := new Parse_Table
+ (State_First => Item_Sets.First_Index,
+ State_Last => Item_Sets.Last_Index,
+ First_Terminal => Descriptor.First_Terminal,
+ Last_Terminal => Descriptor.Last_Terminal,
+ First_Nonterminal => Descriptor.First_Nonterminal,
+ Last_Nonterminal => Descriptor.Last_Nonterminal);
+
+ if McKenzie_Param = Default_McKenzie_Param then
+ -- Descriminants in Default are wrong
+ Table.McKenzie_Param :=
+ (First_Terminal => Descriptor.First_Terminal,
+ Last_Terminal => Descriptor.Last_Terminal,
+ First_Nonterminal => Descriptor.First_Nonterminal,
+ Last_Nonterminal => Descriptor.Last_Nonterminal,
+ Insert => (others => 0),
+ Delete => (others => 0),
+ Push_Back => (others => 0),
+ Undo_Reduce => (others => 0),
+ Minimal_Complete_Cost_Delta =>
Default_McKenzie_Param.Minimal_Complete_Cost_Delta,
+ Fast_Forward => Default_McKenzie_Param.Fast_Forward,
+ Matching_Begin =>
Default_McKenzie_Param.Matching_Begin,
+ Ignore_Check_Fail =>
Default_McKenzie_Param.Ignore_Check_Fail,
+ Task_Count => Default_McKenzie_Param.Task_Count,
+ Check_Limit => Default_McKenzie_Param.Check_Limit,
+ Check_Delta_Limit =>
Default_McKenzie_Param.Check_Delta_Limit,
+ Enqueue_Limit =>
Default_McKenzie_Param.Enqueue_Limit);
+ else
+ Table.McKenzie_Param := McKenzie_Param;
+ end if;
+
+ Add_Actions
+ (Item_Sets, Grammar, Has_Empty_Production, First_Nonterm_Set,
+ Conflict_Counts, Unknown_Conflicts, Table.all, Descriptor);
+
+ for State in Table.States'Range loop
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line ("Set_Minimal_Complete_Actions:" &
State_Index'Image (State));
+ end if;
+ WisiToken.Generate.LR.Set_Minimal_Complete_Actions
+ (Table.States (State),
+ LR1_Items.Filter (Item_Sets (State), Grammar, Descriptor,
LR1_Items.In_Kernel'Access),
+ Descriptor, Grammar, Minimal_Terminal_Sequences,
Minimal_Terminal_First);
+ end loop;
+
+ if Put_Parse_Table then
+ WisiToken.Generate.LR.Put_Parse_Table
+ (Table, "LR1", Grammar, Recursions, Minimal_Terminal_Sequences,
Item_Sets, Conflict_Counts, Descriptor,
+ Include_Extra);
+ end if;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Has_Empty_Production: " & Image
(Has_Empty_Production, Descriptor));
+
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Minimal_Terminal_First:");
+ for ID in Minimal_Terminal_First'Range loop
+ Ada.Text_IO.Put_Line
+ (Image (ID, Descriptor) & " =>" &
+ (if Minimal_Terminal_First (ID) = Invalid_Token_ID
+ then ""
+ else ' ' & Image (Minimal_Terminal_First (ID), Descriptor)));
+ end loop;
+ end if;
+
+ Delete_Known (Unknown_Conflicts, Known_Conflicts_Edit);
+
+ if Unknown_Conflicts.Length > 0 then
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "unknown
conflicts:");
+ Put (Unknown_Conflicts, Ada.Text_IO.Current_Error, Descriptor);
+ Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
+ WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
+ end if;
+
+ if Known_Conflicts_Edit.Length > 0 then
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "excess known
conflicts:");
+ Put (Known_Conflicts_Edit, Ada.Text_IO.Current_Error, Descriptor);
+ Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
+ WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
+ end if;
+
+ WisiToken.Generate.Error := WisiToken.Generate.Error or (Unused_Tokens
and not Ignore_Unused_Tokens);
+
+ return Table;
+ end Generate;
+
+end WisiToken.Generate.LR.LR1_Generate;
diff --git a/wisitoken-generate-lr-lr1_generate.ads
b/wisitoken-generate-lr-lr1_generate.ads
index 92992cb..6e8ade6 100644
--- a/wisitoken-generate-lr-lr1_generate.ads
+++ b/wisitoken-generate-lr-lr1_generate.ads
@@ -30,11 +30,14 @@ with WisiToken.Productions;
package WisiToken.Generate.LR.LR1_Generate is
function Generate
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
- McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
- Put_Parse_Table : in Boolean := False)
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
+ McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
+ Put_Parse_Table : in Boolean := False;
+ Include_Extra : in Boolean := False;
+ Ignore_Conflicts : in Boolean := False;
+ Partial_Recursion : in Boolean := True)
return Parse_Table_Ptr
with Pre => Descriptor.First_Nonterminal = Descriptor.Accept_ID;
-- Generate a generalized LR1 parse table for Grammar. The
@@ -78,6 +81,7 @@ package WisiToken.Generate.LR.LR1_Generate is
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflict_Counts : out Conflict_Count_Lists.List;
Conflicts : out Conflict_Lists.List;
Table : in out Parse_Table;
Descriptor : in WisiToken.Descriptor);
diff --git a/wisitoken-generate-lr.adb b/wisitoken-generate-lr.adb
index f909fde..b814885 100644
--- a/wisitoken-generate-lr.adb
+++ b/wisitoken-generate-lr.adb
@@ -24,30 +24,12 @@ with WisiToken.Generate;
package body WisiToken.Generate.LR is
package RHS_Set is new SAL.Gen_Unbounded_Definite_Vectors (Natural,
Boolean, Default_Element => False);
- type Token_ID_RHS_Set is array (Token_ID range <>) of RHS_Set.Vector;
- type Token_ID_Array_Positive is array (Token_ID range <>) of Positive;
+ type LHS_RHS_Set is array (Token_ID range <>) of RHS_Set.Vector;
----------
-- Body subprograms, alphabetical
- function Find
- (Symbol : in Token_ID;
- Action_List : in Action_Node_Ptr)
- return Action_Node_Ptr
- is
- Action_Node : Action_Node_Ptr := Action_List;
- begin
- while Action_Node /= null loop
- if Action_Node.Symbol = Symbol then
- return Action_Node;
- end if;
- Action_Node := Action_Node.Next;
- end loop;
-
- return null;
- end Find;
-
function Min
(Item : in RHS_Sequence_Arrays.Vector;
RHS_Set : in LR.RHS_Set.Vector)
@@ -70,15 +52,72 @@ package body WisiToken.Generate.LR is
end if;
end Min;
+ function Net_Recursion (Cycle : in Recursion_Cycle; RHS : in Natural)
return Recursion
+ is
+ Result : Recursion := None;
+ begin
+ if Cycle'Length = 1 then
+ for E of Cycle (Cycle'First).Edges loop
+ if E.Data.RHS = RHS then
+ Result := Net_Recursion (Result, E.Data.Recursive);
+ end if;
+ end loop;
+ else
+ for Item of Cycle loop
+ for E of Item.Edges loop
+ Result := Net_Recursion (Result, E.Data.Recursive);
+ end loop;
+ end loop;
+ end if;
+ return Result;
+ end Net_Recursion;
+
+ function Worst_Recursion (Cycle : in Recursion_Cycle; RHS : in Natural)
return Recursion
+ is
+ Result : Recursion := None;
+ begin
+ if Cycle'Length = 1 then
+ for E of Cycle (Cycle'First).Edges loop
+ if E.Data.RHS = RHS then
+ Result := Worst_Recursion (Result, E.Data.Recursive);
+ end if;
+ end loop;
+ else
+ for Item of Cycle loop
+ for E of Item.Edges loop
+ Result := Worst_Recursion (Result, E.Data.Recursive);
+ end loop;
+ end loop;
+ end if;
+ return Result;
+ end Worst_Recursion;
+
+ function Worst_Recursion
+ (Recursion_IDs : in Recursion_Lists.List;
+ Recursions : in Generate.Recursions;
+ RHS : in Natural)
+ return Recursion
+ is
+ Result : Recursion := None;
+ begin
+ for ID of Recursion_IDs loop
+ Result := Worst_Recursion
+ (Result,
+ (if Recursions.Full
+ then Net_Recursion (Recursions.Recursions (ID), RHS)
+ else Worst_Recursion (Recursions.Recursions (ID), RHS)));
+ end loop;
+ return Result;
+ end Worst_Recursion;
+
procedure Terminal_Sequence
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- All_Sequences : in out Minimal_Sequence_Array;
- All_Set : in out Token_ID_Set;
- RHS_Set : in out Token_ID_RHS_Set;
- Recursing : in out Token_ID_Set;
- Recursing_Index : in out Token_ID_Array_Positive;
- Nonterm : in Token_ID)
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ All_Sequences : in out Minimal_Sequence_Array;
+ All_Seq_Set : in out Token_ID_Set;
+ RHS_Seq_Set : in out LHS_RHS_Set;
+ Recursing : in out Token_ID_Set;
+ Nonterm : in Token_ID)
is
use Ada.Containers;
use Token_ID_Arrays;
@@ -88,35 +127,45 @@ package body WisiToken.Generate.LR is
Prod : Productions.Instance renames Grammar (Nonterm);
Skipped_Recursive : Boolean := False;
+
+ procedure Init_All_Sequences (LHS : in Token_ID)
+ is
+ Prod : Productions.Instance renames Grammar (LHS);
+ begin
+ if All_Sequences (LHS).Length = 0 then
+ All_Sequences (LHS).Set_First_Last (Prod.RHSs.First_Index,
Prod.RHSs.Last_Index);
+ end if;
+ if RHS_Seq_Set (LHS).Length = 0 then
+ RHS_Seq_Set (LHS).Set_First_Last (Prod.RHSs.First_Index,
Prod.RHSs.Last_Index);
+ end if;
+ end Init_All_Sequences;
+
begin
- -- We get here because All_Sequences (Nonterm) has not been comptued
- -- yet. Attempt to compute All_Sequences (Nonterm); it may not
- -- succeed due to recursion. If successful, set All_Set (Nonterm)
- -- True.
+ -- We get here because All_Sequences (Nonterm) has not been fully
+ -- computed yet (All_Seq_Set (Nonterm) is False). Attempt to
+ -- compute All_Sequences (Nonterm); it may not succeed due to
+ -- recursion. If successful, set All_Seq_Set (Nonterm).
--
-- In a useful grammar, all direct and indirect recursive nonterms
-- have a non-recursive minimal terminal sequence; finding it will
-- break the recursion, allowing this algorithm to complete. This is
-- checked in Compute_Minimal_Terminal_Sequences.
- -- Fill All_Sequences (Nonterm) with terminals from each production
- -- for Nonterm. We set partial results so recursion can be resolved.
- if All_Sequences (Nonterm).Length = 0 then
- All_Sequences (Nonterm).Set_First_Last (Prod.RHSs.First_Index,
Prod.RHSs.Last_Index); -- defaults empty
- RHS_Set (Nonterm).Set_First_Last (Prod.RHSs.First_Index,
Prod.RHSs.Last_Index); -- defaults False
- end if;
+ Init_All_Sequences (Nonterm);
for RHS in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
- if not RHS_Set (Nonterm)(RHS) then
+ if not RHS_Seq_Set (Nonterm)(RHS) then
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line (Trimmed_Image ((Nonterm, RHS)) & " " &
Image (Nonterm, Descriptor) & " compute");
+ end if;
if Prod.RHSs (RHS).Tokens.Length = 0 then
- RHS_Set (Nonterm)(RHS) := True;
+ RHS_Seq_Set (Nonterm)(RHS) := True;
if Trace_Generate > Extra then
Ada.Text_IO.Put_Line (Trimmed_Image (Production_ID'(Nonterm,
RHS)) & " => () empty");
end if;
else
for I in Prod.RHSs (RHS).Tokens.First_Index .. Prod.RHSs
(RHS).Tokens.Last_Index loop
- Recursing_Index (Nonterm) := I;
declare
ID : Token_ID renames Prod.RHSs (RHS).Tokens (I);
begin
@@ -124,40 +173,22 @@ package body WisiToken.Generate.LR is
All_Sequences (Nonterm) (RHS).Sequence.Append (ID);
else
- if not All_Set (ID) then
- -- Need to compute some RHSs of ID
-
+ if (for some RHS of RHS_Seq_Set (ID) => RHS) then
+ -- There is a minimal sequence for ID; use it
+ null;
+ else
if ID = Nonterm or Recursing (ID) then
- -- Nonterm is mutually recursive with itself or
some other.
- All_Sequences (Nonterm)(RHS).Left_Recursive := I
= Positive'First and
- (ID = Nonterm or Recursing_Index (ID) =
Positive'First);
+ -- Clear partial minimal sequence; we are
starting over.
+ All_Sequences (Nonterm)(RHS).Sequence.Clear;
+ goto Skip;
- if (for some RHS of RHS_Set (ID) => RHS) then
- -- There is a minimal sequence for ID; use it
- null;
- else
- if Trace_Generate > Extra then
- Ada.Text_IO.Put_Line
- (Trimmed_Image (Production_ID'(Nonterm,
RHS)) & "." & Trimmed_Image (I) & " => " &
- (if ID = Nonterm
- then "direct recursive"
- else "indirect recursive " & Image
(ID, Descriptor)));
- end if;
-
- All_Sequences (Nonterm)(RHS).Left_Recursive
:= False;
- All_Sequences (Nonterm)(RHS).Sequence.Clear;
- goto Skip;
- end if;
else
Recursing (ID) := True;
- if Trace_Generate > Extra then
- Ada.Text_IO.Put_Line (Trimmed_Image (ID) & "
" & Image (ID, Descriptor) & " compute");
- end if;
Terminal_Sequence
- (Grammar, Descriptor, All_Sequences, All_Set,
RHS_Set, Recursing, Recursing_Index, ID);
+ (Grammar, Descriptor, All_Sequences,
All_Seq_Set, RHS_Seq_Set, Recursing, ID);
Recursing (ID) := False;
- if All_Set (ID) or else (for some RHS of RHS_Set
(ID) => RHS) then
+ if All_Seq_Set (ID) or else (for some RHS of
RHS_Seq_Set (ID) => RHS) then
-- Found a minimal sequence for ID; use it
null;
else
@@ -167,14 +198,14 @@ package body WisiToken.Generate.LR is
end if;
end if;
declare
- Min_RHS : constant Integer := Min (All_Sequences
(ID), RHS_Set (ID));
+ Min_RHS : constant Integer := Min (All_Sequences
(ID), RHS_Seq_Set (ID));
begin
All_Sequences (Nonterm)(RHS).Sequence.Append
(All_Sequences (ID)(Min_RHS).Sequence);
end;
end if;
end;
end loop;
- RHS_Set (Nonterm)(RHS) := True;
+ RHS_Seq_Set (Nonterm)(RHS) := True;
if Trace_Generate > Extra then
Ada.Text_IO.Put_Line
(Trimmed_Image (Production_ID'(Nonterm, RHS)) & " => " &
@@ -187,7 +218,7 @@ package body WisiToken.Generate.LR is
end loop;
if Skipped_Recursive then
- if (for some RHS of RHS_Set (Nonterm) => not RHS) then
+ if (for some RHS of RHS_Seq_Set (Nonterm) => not RHS) then
-- Some RHSs are have unresolved recursion; we will
-- eventually try again when the recursion is resolved.
if Trace_Generate > Extra then
@@ -198,7 +229,7 @@ package body WisiToken.Generate.LR is
end if;
end if;
- All_Set (Nonterm) := True;
+ All_Seq_Set (Nonterm) := True;
if Trace_Generate > Extra then
Ada.Text_IO.Put_Line
@@ -228,31 +259,33 @@ package body WisiToken.Generate.LR is
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflict_Counts : in out Conflict_Count_Lists.List;
Conflicts : in out Conflict_Lists.List;
Descriptor : in WisiToken.Descriptor)
is
Matching_Action : constant Action_Node_Ptr := Find (Symbol, Action_List);
begin
- if Trace_Generate > Outline then
+ if Trace_Generate > Detail then
Ada.Text_IO.Put (Image (Symbol, Descriptor) & " => ");
Put (Descriptor, Action);
Ada.Text_IO.New_Line;
end if;
if Matching_Action /= null then
- if Equal (Matching_Action.Action.Item, Action) then
- -- Matching_Action is identical to Action, so there is no
- -- conflict; just don't add it again.
- if Trace_Generate > Outline then
+ if Is_In (Action, Matching_Action.Action) then
+ -- Action is already in the list.
+ if Trace_Generate > Detail then
Ada.Text_IO.Put_Line (" - already present");
end if;
return;
else
-- There is a conflict. Report it and add it, so the
- -- generalized parser can follow both paths
+ -- generalized parser can follow all paths
declare
- -- Enforce canonical Shift/Reduce or Accept/Reduce
- -- order, to simplify searching and code generation.
+ -- Enforce canonical Shift/Reduce or Accept/Reduce order, to
simplify
+ -- searching and code generation. There can be only one Shift
in the
+ -- list of conflicting actions, so we keep it the first item
in the
+ -- list; no order in the rest of the list.
Action_A : constant Parse_Action_Rec :=
(if Action.Verb in Shift | Accept_It then Action else
Matching_Action.Action.Item);
@@ -268,37 +301,66 @@ package body WisiToken.Generate.LR is
(Closure, Action_B, Symbol, Grammar, Has_Empty_Production,
First_Nonterm_Set, Descriptor),
State_Index => Closure.State,
On => Symbol);
+
+ Counts : Conflict_Count_Lists.Cursor;
begin
+ for Cur in Conflict_Counts.Iterate loop
+ if Conflict_Counts (Cur).State = Closure.State then
+ Counts := Cur;
+ exit;
+ end if;
+ end loop;
+
+ if not Conflict_Count_Lists.Has_Element (Counts) then
+ Conflict_Counts.Append ((Closure.State, others => 0));
+ Counts := Conflict_Counts.Last;
+ end if;
+
+ declare
+ use Conflict_Count_Lists;
+ Counts_Ref : constant Reference_Type := Reference
(Conflict_Counts, Counts);
+ begin
+ case Action_A.Verb is
+ when Shift =>
+ case Action_B.Verb is
+ when Shift | Accept_It | WisiToken.Parse.LR.Error =>
+ raise SAL.Programmer_Error;
+ when Reduce =>
+ Counts_Ref.Shift_Reduce := Counts_Ref.Shift_Reduce + 1;
+ end case;
+ when Reduce =>
+ case Action_B.Verb is
+ when Shift | Accept_It | WisiToken.Parse.LR.Error =>
+ raise SAL.Programmer_Error;
+ when Reduce =>
+ Counts_Ref.Reduce_Reduce := Counts_Ref.Reduce_Reduce +
1;
+ end case;
+ when Accept_It =>
+ case Action_B.Verb is
+ when Shift | Accept_It | WisiToken.Parse.LR.Error =>
+ raise SAL.Programmer_Error;
+ when Reduce =>
+ Counts_Ref.Accept_Reduce := Counts_Ref.Accept_Reduce +
1;
+ end case;
+ when WisiToken.Parse.LR.Error =>
+ raise SAL.Programmer_Error;
+ end case;
+ end;
+
if not Is_Present (New_Conflict, Conflicts) then
-- The same conflict may occur in a different
-- item set. Only add it to conflicts once.
Conflicts.Append (New_Conflict);
- if Trace_Generate > Outline then
+ if Trace_Generate > Detail then
Ada.Text_IO.Put_Line (" - conflict added: " & Image
(New_Conflict, Descriptor));
end if;
else
- if Trace_Generate > Outline then
+ if Trace_Generate > Detail then
Ada.Text_IO.Put_Line (" - conflict duplicate: " & Image
(New_Conflict, Descriptor));
end if;
end if;
- -- More than two actions can occur; see triple_conflict.wy. We
make
- -- that an error, since the grammar will be better off without
them.
- -- But keep going; the full parse table output will be needed
to fix
- -- the excess conflict.
- if Matching_Action.Action.Next /= null then
- if Matching_Action.Action.Item = Action or
Matching_Action.Action.Next.Item = Action then
- if Trace_Generate > Outline then
- Ada.Text_IO.Put_Line (" - conflict duplicate");
- end if;
- else
- WisiToken.Generate.Put_Error
- ("More than two actions on " & Image (Symbol,
Descriptor) &
- " in state" & State_Index'Image (Closure.State));
- end if;
- end if;
-
if Action.Verb = Shift then
Matching_Action.Action := new Parse_Action_Node'(Action,
Matching_Action.Action);
else
@@ -317,6 +379,7 @@ package body WisiToken.Generate.LR is
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflict_Counts : in out Conflict_Count_Lists.List;
Conflicts : in out Conflict_Lists.List;
Descriptor : in WisiToken.Descriptor)
is
@@ -324,7 +387,7 @@ package body WisiToken.Generate.LR is
State : constant State_Index := Closure.State;
begin
- if Trace_Generate > Outline then
+ if Trace_Generate > Detail then
Ada.Text_IO.Put_Line ("adding actions for state" & State_Index'Image
(State));
end if;
@@ -334,7 +397,7 @@ package body WisiToken.Generate.LR is
Add_Lookahead_Actions
(Item, Table.States (State).Action_List, Grammar,
Has_Empty_Production, First_Nonterm_Set,
- Conflicts, Closure, Descriptor);
+ Conflict_Counts, Conflicts, Closure, Descriptor);
elsif Element (Item.Dot) in Descriptor.First_Terminal ..
Descriptor.Last_Terminal then
-- Dot is before a terminal token.
@@ -358,7 +421,7 @@ package body WisiToken.Generate.LR is
-- EOF is not pushed on stack in parser, because the
action for EOF
-- is Accept, not Shift.
Table.States (State).Action_List, Closure,
- Grammar, Has_Empty_Production, First_Nonterm_Set,
Conflicts, Descriptor);
+ Grammar, Has_Empty_Production, First_Nonterm_Set,
Conflict_Counts, Conflicts, Descriptor);
end;
else
if Goto_State /= Unknown_State then
@@ -366,13 +429,14 @@ package body WisiToken.Generate.LR is
(Dot_ID,
(Shift, Goto_State),
Table.States (State).Action_List,
- Closure, Grammar, Has_Empty_Production,
First_Nonterm_Set, Conflicts, Descriptor);
+ Closure, Grammar, Has_Empty_Production,
First_Nonterm_Set,
+ Conflict_Counts, Conflicts, Descriptor);
end if;
end if;
end;
else
-- Dot is before a non-terminal token; no action.
- if Trace_Generate > Outline then
+ if Trace_Generate > Detail then
Ada.Text_IO.Put_Line (Image (Element (Item.Dot), Descriptor) &
" => no action");
end if;
end if;
@@ -437,6 +501,7 @@ package body WisiToken.Generate.LR is
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflict_Counts : in out Conflict_Count_Lists.List;
Conflicts : in out Conflict_Lists.List;
Closure : in LR1_Items.Item_Set;
Descriptor : in WisiToken.Descriptor)
@@ -445,7 +510,7 @@ package body WisiToken.Generate.LR is
RHS : Productions.Right_Hand_Side renames Prod.RHSs (Item.Prod.RHS);
Action : constant Parse_Action_Rec := (Reduce, Item.Prod, RHS.Action,
RHS.Check, RHS.Tokens.Length);
begin
- if Trace_Generate > Outline then
+ if Trace_Generate > Detail then
Ada.Text_IO.Put_Line ("processing lookaheads");
end if;
@@ -457,7 +522,7 @@ package body WisiToken.Generate.LR is
else
Add_Action
(Lookahead, Action, Action_List, Closure, Grammar,
- Has_Empty_Production, First_Nonterm_Set, Conflicts,
Descriptor);
+ Has_Empty_Production, First_Nonterm_Set, Conflict_Counts,
Conflicts, Descriptor);
end if;
end if;
end loop;
@@ -635,9 +700,13 @@ package body WisiToken.Generate.LR is
Known.On = Item.On;
end Match;
+ ----------
+ -- Minimal terminal sequences.
+
function Image (Item : in RHS_Sequence; Descriptor : in
WisiToken.Descriptor) return String
is begin
- return "(" & Boolean'Image (Item.Left_Recursive) & ", " & Image
(Item.Sequence, Descriptor) & ")";
+ return "(" & Image (Item.Recursion) & ", " & Recursion'Image
(Item.Worst_Recursion) & ", " &
+ Image (Item.Sequence, Descriptor) & ")";
end Image;
function Min (Item : in RHS_Sequence_Arrays.Vector) return RHS_Sequence
@@ -661,43 +730,87 @@ package body WisiToken.Generate.LR is
end Min;
function Compute_Minimal_Terminal_Sequences
- (Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
+ (Descriptor : in WisiToken.Descriptor;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Recursions : in Generate.Recursions)
return Minimal_Sequence_Array
is
- -- Result (ID).Length = 0 is a valid sequence (ie the nonterminal can
- -- be empty), so we use an auxilliary array to track whether Result
- -- (ID) has been computed.
- --
- -- We also need to detect mutual recursion, and incomplete grammars.
-
- All_Set : Token_ID_Set := (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal => False);
- Recursing : Token_ID_Set := (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal => False);
+ -- Result (ID).Sequence.Length = 0 is a valid result (ie the
+ -- nonterminal can be empty), so we use an auxilliary array to track
+ -- whether Result (ID) has been computed.
- Recursing_Index : Token_ID_Array_Positive :=
- (Descriptor.First_Nonterminal .. Descriptor.Last_Nonterminal =>
Positive'Last);
+ All_Seq_Set : Token_ID_Set := (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal => False);
+ Recursing : Token_ID_Set := (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal => False);
- RHS_Set : Token_ID_RHS_Set :=
- (Descriptor.First_Nonterminal .. Descriptor.Last_Nonterminal =>
LR.RHS_Set.Empty_Vector);
+ RHS_Seq_Set : LHS_RHS_Set :=
+ (Descriptor.First_Nonterminal .. Descriptor.Last_Nonterminal =>
RHS_Set.Empty_Vector);
- Last_Count : Integer := 0;
- This_Count : Integer;
+ Last_Seq_Count : Integer := 0;
+ This_Count : Integer;
+ Pass_Count : Integer := 0;
begin
return Result : Minimal_Sequence_Array (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal) do
loop
- exit when (for all B of All_Set => B);
- for P of Grammar loop
- if not All_Set (P.LHS) then
- Terminal_Sequence (Grammar, Descriptor, Result, All_Set,
RHS_Set, Recursing, Recursing_Index, P.LHS);
+ exit when (for all B of All_Seq_Set => B);
+ Pass_Count := Pass_Count + 1;
+ if Trace_Generate > Detail then
+ if Trace_Generate > Extra then
+ Ada.Text_IO.New_Line;
end if;
+ Ada.Text_IO.Put_Line ("Compute_Minimal_Terminal_Sequences pass"
& Integer'Image (Pass_Count));
+ end if;
+ for P of Grammar loop
+ Terminal_Sequence (Grammar, Descriptor, Result, All_Seq_Set,
RHS_Seq_Set, Recursing, P.LHS);
end loop;
- This_Count := Count (All_Set);
- if This_Count = Last_Count then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, Image
(All_Set, Descriptor, Inverted => True));
- raise Grammar_Error with "recursion not resolved";
+ This_Count := Count (All_Seq_Set);
+ if This_Count = Last_Seq_Count then
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, Image
(All_Seq_Set, Descriptor, Inverted => True));
+ raise Grammar_Error with "sequences not resolved";
end if;
- Last_Count := This_Count;
+ Last_Seq_Count := This_Count;
end loop;
+
+ -- Set Result.Recursions
+ for Recursion_ID in Recursions.Recursions.First_Index ..
Recursions.Recursions.Last_Index loop
+ declare
+ Cycle : Recursion_Cycle renames Recursions.Recursions
(Recursion_ID);
+ begin
+ for I in Cycle'Range loop
+ declare
+ Edges : constant Grammar_Graphs.Edge_Lists.List :=
+ (if Recursions.Full then
+ (if I = Cycle'Last
+ then Cycle (Cycle'First).Edges
+ else Cycle (I + 1).Edges)
+ else Cycle (I).Edges);
+ begin
+ for E of Edges loop
+ Result (Cycle (I).Vertex)(E.Data.RHS).Recursion.Append
(Recursion_ID);
+ end loop;
+ end;
+ end loop;
+ end;
+ end loop;
+
+ -- Set Result.Worst_Recursions
+ for Nonterm in Result'Range loop
+ for RHS in Result (Nonterm).First_Index .. Result
(Nonterm).Last_Index loop
+ declare
+ RHS_Seq : RHS_Sequence renames Result (Nonterm)(RHS);
+ begin
+ RHS_Seq.Worst_Recursion := Worst_Recursion
(RHS_Seq.Recursion, Recursions, RHS);
+ end;
+ end loop;
+ end loop;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line ("Minimal_Terminal_Sequences:");
+ for LHS in Result'Range loop
+ Ada.Text_IO.Put_Line
+ (Trimmed_Image (LHS) & " " & Image (LHS, Descriptor) & " ==>
" &
+ Image (Result (LHS), Descriptor));
+ end loop;
+ end if;
end return;
end Compute_Minimal_Terminal_Sequences;
@@ -739,7 +852,7 @@ package body WisiToken.Generate.LR is
subtype Terminals is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
Working_Set : LR1_Items.Item_Lists.List := Kernel.Set;
- Del : LR1_Items.Item_Lists.Cursor;
+ Recursive : Boolean := False;
function Find_Action (List : in Action_Node_Ptr; ID : in Token_ID)
return Minimal_Action
is
@@ -764,100 +877,237 @@ package body WisiToken.Generate.LR is
raise SAL.Programmer_Error;
end Find_Action;
+ function Min_Length (Item : in RHS_Sequence_Arrays.Vector) return
Ada.Containers.Count_Type
+ is
+ use Ada.Containers;
+ Min : Count_Type := Count_Type'Last;
+ begin
+ for RHS of Item loop
+ if RHS.Sequence.Length < Min then
+ Min := RHS.Sequence.Length;
+ end if;
+ end loop;
+ return Min;
+ end Min_Length;
+
+ function After_Dot_Length (Item : in LR1_Items.Item) return
Ada.Containers.Count_Type
+ is
+ use Ada.Containers;
+ Prod : constant Production_ID := Item.Prod;
+ I : Token_ID_Arrays.Cursor := Item.Dot;
+ Result : Count_Type := 0;
+ Tokens : Vector renames Grammar (Prod.LHS).RHSs (Prod.RHS).Tokens;
+ begin
+ loop
+ exit when I = Token_ID_Arrays.No_Element;
+
+ if Tokens (I) in Terminals then
+ Result := Result + 1;
+ else
+ Result := Result + Min_Length (Minimal_Terminal_Sequences
(Tokens (I)));
+ end if;
+ Next (I);
+ end loop;
+ return Result;
+ end After_Dot_Length;
+
procedure Delete_Non_Minimal
is
- Min_Length : Ada.Containers.Count_Type :=
Ada.Containers.Count_Type'Last;
- I : LR1_Items.Item_Lists.Cursor;
- Min_I : LR1_Items.Item_Lists.Cursor;
+ use Ada.Containers;
+
+ Min_Length : Count_Type := Count_Type'Last;
+ I : LR1_Items.Item_Lists.Cursor;
+ Recursive_Count : Count_Type := 0;
+ Delete_Recursive : Boolean;
+
+ function Immediate_Recursive return Boolean
+ is
+ -- Direct left recursion is never minimal; for example, consider
+ -- ada_lite LALR state 149:
+ --
+ -- 61.0:association_list <= association_list ^ COMMA
association_opt
+ --
+ -- If we already have an association_list, adding a COMMA to it
+ -- cannot be minimal.
+ --
+ -- Similarly, indirect left recursion is not minimal; consider
+ -- ada_lite LALR states 29 and 60:
+ --
+ -- State 29:
+ -- 103.3:name <= selected_component ^,
+ --
+ -- State 60:
+ -- 94.0:function_specification <= FUNCTION name ^
parameter_and_result_profile
+ -- 103.0:name <= name ^ LEFT_PAREN range_list
+ -- 103.1:name <= name ^ actual_parameter_part
+ -- 123.0:selected_component <= name ^ DOT IDENTIFIER
+ --
+ -- If we already have a name, adding actual_parameter_part or DOT
IDENTIFIER cannot be
+ -- minimal.
+
+ -- There is a trade off here between error recovery power and
risk of
+ -- recursive loops. Consider ada_lite state 152:
+ --
+ -- 103.0:name <= name LEFT_PAREN range_list ^ RIGHT_PAREN
+ -- 117.0:range_list <= range_list ^ COMMA range_g
+ --
+ -- Both productions are Left_Recursive, but in the first item,
dot is past
+ -- the recursion, and can be usefully completed.
+ --
+ -- However, that might allow loops; see java_enum_ch19.wy.
+ --
+ -- A similar argument applies to right recursive items; from
+ -- java_expressions_ch19.wy:
+ --
+ -- State 7:
+ -- 27.0:Assignment <= LeftHandSide ^ EQUAL Expression
+ --
+ -- State 22:
+ -- 28.0:LeftHandSide <= Identifier ^
+ -- 34.0:ClassType <= Identifier ^
+ --
+ -- State 25:
+ -- 24.1:Expression <= AssignmentExpression ^
+ --
+ -- State 26:
+ -- 26.1:AssignmentExpression <= Assignment ^
+ --
+ -- Choosing LeftHandSide for the minimal action in state 22 will
lead
+ -- to a loop thru state 7. However, Assignment can also occur in
+ -- Statement, where it is not recursive:
+ --
+ -- State 1:
+ -- 23.0:Statement <= LEFT_CURLY_BRACKET ^ Assignment
RIGHT_CURLY_BRACKET
+ --
+ -- This is not easy to check for.
+ --
+ -- It is not expensive to check for loops in
Minimal_Complete_Action
+ -- at run-time, so given all the above we allow items that are
"past
+ -- the recursion" here.
+
+ Item : LR1_Items.Item renames Constant_Ref (I).Element.all;
+ Prod : constant WisiToken.Production_ID := Item.Prod;
+ Min_Seq : RHS_Sequence renames Minimal_Terminal_Sequences
(Prod.LHS)(Prod.RHS);
+ begin
+ return Min_Seq.Worst_Recursion in Right | Left and then
+ (Has_Element (Item.Dot) and then
+ Item.Dot = To_Cursor (Grammar (Prod.LHS).RHSs
(Prod.RHS).Tokens, 2));
+ end Immediate_Recursive;
+
begin
- -- The absolute minimal production for an LHS may not be in this
state.
- -- For example, for an Ada aggregate, the minimal terminal sequence
is:
+ -- The absolute minimal production for an LHS may not be in this
+ -- state. For example, for an Ada aggregate, the absolute minimal
+ -- terminal sequence is:
+ --
-- aggregate <= LEFT_PAREN RIGHT_PAREN
- -- but one state has:
+ --
+ -- but one state has only:
+ --
-- aggregate <= LEFT_PAREN expression_opt WITH ^ NULL RECORD
RIGHT_PAREN
-- aggregate <= LEFT_PAREN expression_opt WITH ^ association_list
RIGHT_PAREN
--
- -- Find the minimum of the productions that are present
+ -- Find the minimum tokens after dot of the productions that are
present
+ -- First see if all are recursive
I := Working_Set.First;
loop
exit when not Has_Element (I);
- declare
- Prod : constant WisiToken.Production_ID := Constant_Ref
(I).Prod;
- begin
- -- IMPROVEME: If Dot is near the end of a production, this is
not the
- -- best metric; the best metric is count of remaining tokens to
- -- insert. But changing to that won't make much difference; it
only
- -- matters when Dot is not near the beginning, but then we
don't have
- -- multiple productions (they all must have same prefix).
- --
- -- We must eliminate direct left recursion; otherwise it can
appear
- -- to have a minimum length. For example, consider ada_lite
state
- -- 149:
- --
- -- 57.0:actual_parameter_part <= LEFT_PAREN association_list ^
RIGHT_PAREN
- -- 61.0:association_list <= association_list ^ COMMA
association_opt
- --
- -- Both have length 2, but the association_list requires a
- -- RIGHT_PAREN eventually.
- --
- -- We also have to eliminate indirect left recursion; consider
ada_lite state 60:
- --
- -- 94.0:function_specification <= FUNCTION name ^
parameter_and_result_profile
- -- 103.0:name <= name ^ LEFT_PAREN range_list
- -- 103.1:name <= name ^ actual_parameter_part
- -- 123.0:selected_component <= name ^ DOT IDENTIFIER
- --
- -- 'selected' component has length 3, which two others also
have, but
- -- it requires more eventually.
- --
- -- An item production is left recursive only if Dot is after
the
- -- first token (ie, before the second token); consider
conflict_name
- -- state 5:
- --
- -- 8.0:attribute_reference <= name TICK ^
attribute_designator, RIGHT_PAREN/TICK/Wisi_EOI
- -- 11.0:qualified_expression <= name TICK ^ aggregate,
RIGHT_PAREN/TICK/Wisi_EOI
- --
- -- Both are indirect left recursive with "name", but both are
past
- -- the recursion, and can be completed.
-
- if Min_Length > Minimal_Terminal_Sequences
(Prod.LHS)(Prod.RHS).Sequence.Length and
- not (Minimal_Terminal_Sequences
(Prod.LHS)(Prod.RHS).Left_Recursive and then
- (Has_Element (Constant_Ref (I).Dot) and then
- Constant_Ref (I).Dot = To_Cursor (Grammar
(Prod.LHS).RHSs (Prod.RHS).Tokens, 2)))
- then
- Min_Length := Minimal_Terminal_Sequences
(Prod.LHS)(Prod.RHS).Sequence.Length;
- Min_I := I;
- end if;
- end;
+
+ if Immediate_Recursive then
+ Recursive_Count := Recursive_Count + 1;
+ end if;
+
Next (I);
end loop;
- if not Has_Element (Min_I) then
- Working_Set.Clear;
- else
- I := Working_Set.First;
- loop
- exit when not Has_Element (I);
+ Delete_Recursive := Recursive_Count < Working_Set.Length;
+
+ I := Working_Set.First;
+ loop
+ exit when not Has_Element (I);
+
+ if Delete_Recursive and Immediate_Recursive then
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line ("delete " & Image (Constant_Ref
(I).Prod) & " recursive");
+ end if;
declare
- Prod : constant WisiToken.Production_ID := Constant_Ref
(I).Prod;
+ Del : LR1_Items.Item_Lists.Cursor := I;
begin
- if I /= Min_I then
- if Trace_Generate > Extra then
- Ada.Text_IO.Put_Line ("delete " & Image (Prod) & " not
minimal");
- end if;
- Del := I;
- Next (I);
- Working_Set.Delete (Del);
- else
- Next (I);
+ Next (I);
+ Working_Set.Delete (Del);
+ end;
+
+ else
+ Recursive := Recursive or Minimal_Terminal_Sequences
+ (Constant_Ref (I).Prod.LHS)(Constant_Ref
(I).Prod.RHS).Worst_Recursion in
+ Left | Right;
+
+ declare
+ Prod_Length : constant Count_Type := After_Dot_Length
(Constant_Ref (I));
+ begin
+ if Min_Length > Prod_Length then
+ Min_Length := Prod_Length;
end if;
end;
- end loop;
- end if;
+
+ Next (I);
+ end if;
+ end loop;
+
+ -- Now we have the minimum length; check remaining items against that
+ I := Working_Set.First;
+ loop
+ exit when not Has_Element (I);
+ if Min_Length < After_Dot_Length (Constant_Ref (I)) then
+ declare
+ Del : LR1_Items.Item_Lists.Cursor := I;
+ begin
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line ("delete " & Image (Constant_Ref
(I).Prod));
+ end if;
+ Next (I);
+ Working_Set.Delete (Del);
+ end;
+ else
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line ("keep " & Image (Constant_Ref
(I).Prod));
+ end if;
+ Next (I);
+ end if;
+ end loop;
end Delete_Non_Minimal;
begin
+ if Kernel.State > 0 then
+ declare
+ use Ada.Containers;
+ I : Count_Type := 1;
+
+ function Before_Dot (Item : in LR1_Items.Item) return Token_ID
+ is
+ Tokens : Token_ID_Arrays.Vector renames Grammar
(Item.Prod.LHS).RHSs (Item.Prod.RHS).Tokens;
+ begin
+ if Item.Dot = Token_ID_Arrays.No_Element then
+ return Tokens (Tokens.Last_Index);
+ else
+ return Tokens (Prev (Item.Dot));
+ end if;
+ end Before_Dot;
+ begin
+ State.Kernel.Set_First_Last (1, Kernel.Set.Length);
+ for Item of Kernel.Set loop
+ State.Kernel (I) :=
+ (LHS => Item.Prod.LHS,
+ Before_Dot => Before_Dot (Item),
+ Length_After_Dot => After_Dot_Length (Item),
+ Recursive => Minimal_Terminal_Sequences
+ (Item.Prod.LHS)(Item.Prod.RHS).Worst_Recursion in Right |
Left);
+
+ I := I + 1;
+ end loop;
+ end;
+ end if;
+
-- The actions computed here are used in the error recovery
-- algorithm, to decide what terminals to insert in the input stream
-- in order to correct an error. The strategy is to complete a high
@@ -867,8 +1117,7 @@ package body WisiToken.Generate.LR is
-- production.
--
-- The actions are empty in a state that includes the accept
- -- production, or where the only not left recursive productions can
- -- be empty. That tells the error recovery algorithm to stop using
+ -- production. That tells the error recovery algorithm to stop using
-- the minimal complete actions strategy.
if (for some Item of Working_Set =>
@@ -879,53 +1128,86 @@ package body WisiToken.Generate.LR is
return;
end if;
- if Working_Set.Length > 1 then
- -- There are multiple productions in this state, all equally valid;
- -- the choice is determined by what input error recovery inserts.
- Delete_Non_Minimal;
- end if;
+ Delete_Non_Minimal;
- if Trace_Generate > Extra then
- Ada.Text_IO.Put_Line ("after deletions:");
- LR1_Items.Put (Grammar, Descriptor, Working_Set, Show_Lookaheads =>
False);
- end if;
+ State.Minimal_Complete_Actions_Recursive := Recursive;
- -- Find the actions for the remaining productions.
-
- for Item of Working_Set loop
- if not Has_Element (Item.Dot) then
- -- Item has no next terminal. Include a reduce action; the
- -- Minimal_Terminal_First for the resulting state will be used.
- if Trace_Generate > Extra then
- Ada.Text_IO.Put_Line ("reduce " & Image (Item.Prod));
- end if;
- State.Minimal_Complete_Action :=
- (Reduce, Item.Prod.LHS,
- Token_Count => Grammar (Item.Prod.LHS).RHSs
(Item.Prod.RHS).Tokens.Length);
- else
- declare
- ID : constant Token_ID := Element (Item.Dot);
- begin
- if ID /= Descriptor.EOI_ID then
+ if Working_Set.Length > 0 then
+ -- There are one or more productions with equal after-dot length in
+ -- this state, all equally valid; the choice is determined by what
+ -- input error recovery inserts.
+ --
+ -- We could simply choose one arbitrarily, but that can lead to loops
+ -- (see discussion above in Immediate_Recursive). So we consider the
+ -- higher level production. However, in general we cannot precompute
+ -- what higher-level productions might be completed from each state;
+ -- we must use the parse stack during error recovery. In that case,
+ -- we store multiple minimal actions in the state (see
+ -- Insert_Minimal_Complete_Actions in
+ -- wisitoken-parse-lr-mckenzie_recover-explore.adb).
- if ID in Terminals then
- State.Minimal_Complete_Action := Find_Action
(State.Action_List, ID);
+ declare
+ Actions : Minimal_Action_Array (1 .. Working_Set.Length) :=
(others => (others => <>));
- else
- if Minimal_Terminal_First (ID) = Invalid_Token_ID then
- -- Item.Dot is a nullable nonterm, include a reduce
of the null
- -- nonterm, rather than a shift of the following
terminal; recover
- -- must do the reduce first.
- State.Minimal_Complete_Action := (Reduce, ID,
Token_Count => 0);
+ I : Ada.Containers.Count_Type := 1;
+ Skip : Boolean;
+ begin
+ for Item of Working_Set loop
+
+ if not Has_Element (Item.Dot) then
+ -- Item has no next terminal. Include a reduce action; the
+ -- Minimal_Terminal_First for the resulting state will be
used.
+ Actions (I) :=
+ (Reduce, Item.Prod.LHS,
+ Token_Count => Grammar (Item.Prod.LHS).RHSs
(Item.Prod.RHS).Tokens.Length);
+ else
+ declare
+ ID : constant Token_ID := Element (Item.Dot);
+ begin
+ if ID in Terminals then
+ Actions (I) := Find_Action (State.Action_List, ID);
else
- State.Minimal_Complete_Action := Find_Action
(State.Action_List, Minimal_Terminal_First (ID));
+ if Minimal_Terminal_First (ID) = Invalid_Token_ID then
+ -- Item.Dot is a nullable nonterm; include a
reduce to the null
+ -- nonterm, rather than a shift of the following
terminal; recover
+ -- must do the reduce first.
+ Actions (I) := (Reduce, ID, Token_Count => 0);
+
+ else
+ Actions (I) := Find_Action (State.Action_List,
Minimal_Terminal_First (ID));
+ end if;
end if;
- end if;
+ end;
end if;
- end;
- end if;
- end loop;
+ I := I + 1;
+ end loop;
+
+ if Actions'Length = 1 then
+ State.Minimal_Complete_Actions :=
Minimal_Action_Arrays.To_Vector (Actions (Actions'First));
+ else
+ -- Check for duplicates; see
three_action_conflict_lalr.parse_table
+ -- state 3 or lalr_generator_bug_01_lalr.parse_table state 28
+ for I in Actions'Range loop
+ Skip := False;
+ for J in Actions'First .. I - 1 loop
+ if Actions (I) = Actions (J) then
+ Skip := True;
+ exit;
+ end if;
+ end loop;
+ if not Skip then
+ State.Minimal_Complete_Actions.Append (Actions (I));
+ end if;
+ end loop;
+ end if;
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line
+ (Image (State.Minimal_Complete_Actions, Descriptor) & (if
Recursive then " recursive" else ""));
+ end if;
+ end;
+ end if;
end Set_Minimal_Complete_Actions;
----------
@@ -937,14 +1219,14 @@ package body WisiToken.Generate.LR is
Action_Names : in Names_Array_Array;
Check_Names : in Names_Array_Array)
is
+ use Ada.Containers;
use Ada.Text_IO;
File : File_Type;
begin
-- Only space, semicolon, newline delimit object values. Bounds of
-- arrays output before each array, unless known from discriminants.
-- End of lists indicated by semicolon. Action, Check subprograms are
- -- represented by True if present, False if not; look up the actual
- -- address Table.Productions.
+ -- represented by True if present, False if not.
Create (File, Out_File, File_Name);
@@ -956,13 +1238,6 @@ package body WisiToken.Generate.LR is
New_Line (File);
for State of Table.States loop
- Put (File, Integer'Image (State.Productions.First_Index));
- Put (File, Integer'Image (State.Productions.Last_Index));
- for Prod of State.Productions loop
- Put (File, Token_ID'Image (Prod.LHS) & Integer'Image (Prod.RHS));
- end loop;
- New_Line (File);
-
declare
Node_I : Action_Node_Ptr := State.Action_List;
begin
@@ -1033,22 +1308,38 @@ package body WisiToken.Generate.LR is
New_Line (File);
end;
- declare
- Action : Minimal_Action renames State.Minimal_Complete_Action;
- begin
- case State.Minimal_Complete_Action.Verb is
- when Pause =>
- null;
- when Shift =>
- Put (File, Minimal_Verbs'Image (Action.Verb));
- Put (File, Token_ID'Image (Action.ID) & State_Index'Image
(Action.State));
- when Reduce =>
- Put (File, Minimal_Verbs'Image (Action.Verb));
- Put (File, Token_ID'Image (Action.Nonterm) &
Ada.Containers.Count_Type'Image (Action.Token_Count));
- end case;
- end;
- Put (File, ';');
- New_Line (File);
+ if State.Kernel.Length = 0 then
+ -- Not set for state 0
+ Put_Line (File, "0 -1");
+
+ else
+ Put (File, Count_Type'Image (State.Kernel.First_Index));
+ Put (File, Count_Type'Image (State.Kernel.Last_Index));
+ for Item of State.Kernel loop
+ Put (File, Token_ID'Image (Item.LHS) & Token_ID'Image
(Item.Before_Dot) &
+ Count_Type'Image (Item.Length_After_Dot));
+ end loop;
+ New_Line (File);
+ end if;
+
+ if State.Minimal_Complete_Actions.Length = 0 then
+ null;
+ else
+ Put (File, Count_Type'Image
(State.Minimal_Complete_Actions.First_Index));
+ Put (File, Count_Type'Image
(State.Minimal_Complete_Actions.Last_Index));
+ for Action of State.Minimal_Complete_Actions loop
+ Put (File, " ");
+ case Action.Verb is
+ when Shift =>
+ Put (File, Minimal_Verbs'Image (Action.Verb));
+ Put (File, Token_ID'Image (Action.ID) & State_Index'Image
(Action.State));
+ when Reduce =>
+ Put (File, Minimal_Verbs'Image (Action.Verb));
+ Put (File, Token_ID'Image (Action.Nonterm) &
Ada.Containers.Count_Type'Image (Action.Token_Count));
+ end case;
+ end loop;
+ end if;
+ Put_Line (File, ";");
end loop;
Close (File);
end Put_Text_Rep;
@@ -1096,17 +1387,28 @@ package body WisiToken.Generate.LR is
end if;
end loop;
Put_Line ("(Push_Back =>");
- for I in Item.Delete'Range loop
- Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Delete (I)));
- if I = Item.Delete'Last then
+ for I in Item.Push_Back'Range loop
+ Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Push_Back (I)));
+ if I = Item.Push_Back'Last then
Put_Line (")");
else
Put_Line (",");
end if;
end loop;
+ Put_Line ("(Undo_Reduce =>");
+ for I in Item.Undo_Reduce'Range loop
+ Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Undo_Reduce (I)));
+ if I = Item.Undo_Reduce'Last then
+ Put_Line (")");
+ else
+ Put_Line (",");
+ end if;
+ end loop;
+ Put_Line ("Minimal_Complete_Cost_Delta => " & Integer'Image
(Item.Minimal_Complete_Cost_Delta));
+ Put_Line ("Fast_Forward => " & Integer'Image (Item.Fast_Forward));
+ Put_Line ("Matching_Begin => " & Integer'Image (Item.Matching_Begin));
Put_Line ("Ignore_Check_Fail =>" & Integer'Image
(Item.Ignore_Check_Fail));
Put_Line ("Task_Count =>" &
System.Multiprocessors.CPU_Range'Image (Item.Task_Count));
- Put_Line ("Cost_Limit =>" & Integer'Image (Item.Cost_Limit));
Put_Line ("Check_Limit =>" & Token_Index'Image (Item.Check_Limit));
Put_Line ("Check_Delta_Limit =>" & Integer'Image
(Item.Check_Delta_Limit));
Put_Line ("Enqueue_Limit =>" & Integer'Image (Item.Enqueue_Limit));
@@ -1150,6 +1452,7 @@ package body WisiToken.Generate.LR is
procedure Put (Descriptor : in WisiToken.Descriptor; State : in Parse_State)
is
+ use all type Ada.Containers.Count_Type;
use Ada.Text_IO;
use Ada.Strings.Fixed;
Action_Ptr : Action_Node_Ptr := State.Action_List;
@@ -1183,25 +1486,54 @@ package body WisiToken.Generate.LR is
end loop;
New_Line;
- Put (" Minimal_Complete_Action => (");
- case State.Minimal_Complete_Action.Verb is
- when Pause =>
+ Put (" Minimal_Complete_Action => "); -- No trailing 's' for
compatibility with previous good parse tables.
+ case State.Minimal_Complete_Actions.Length is
+ when 0 =>
null;
- when Shift =>
- Put (Image (State.Minimal_Complete_Action.ID, Descriptor));
- when Reduce =>
- Put (Image (State.Minimal_Complete_Action.Nonterm, Descriptor));
+ when 1 =>
+ -- No () here for compatibity with previous known good parse tables.
+ declare
+ Action : Minimal_Action renames State.Minimal_Complete_Actions
(State.Minimal_Complete_Actions.First_Index);
+ begin
+ case Action.Verb is
+ when Shift =>
+ Put (Image (Action.ID, Descriptor));
+ when Reduce =>
+ Put (Image (Action.Nonterm, Descriptor));
+ end case;
+ end;
+ when others =>
+ Put ("(");
+ for I in State.Minimal_Complete_Actions.First_Index ..
State.Minimal_Complete_Actions.Last_Index loop
+ case State.Minimal_Complete_Actions (I).Verb is
+ when Shift =>
+ Put (Image (State.Minimal_Complete_Actions (I).ID, Descriptor));
+ when Reduce =>
+ Put (Image (State.Minimal_Complete_Actions (I).Nonterm,
Descriptor));
+ end case;
+ if I < State.Minimal_Complete_Actions.Last_Index then
+ Put (", ");
+ end if;
+ end loop;
+ Put (")");
end case;
- Put_Line (")");
+ if State.Minimal_Complete_Actions_Recursive then
+ Put_Line (" recursive");
+ else
+ New_Line;
+ end if;
end Put;
procedure Put_Parse_Table
- (Table : in Parse_Table_Ptr;
- Title : in String;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Kernels : in LR1_Items.Item_Set_List;
- Conflicts : in Conflict_Lists.List;
- Descriptor : in WisiToken.Descriptor)
+ (Table : in Parse_Table_Ptr;
+ Title : in String;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Recursions : in Generate.Recursions;
+ Minimal_Terminal_Sequences : in Minimal_Sequence_Array;
+ Kernels : in LR1_Items.Item_Set_List;
+ Conflicts : in Conflict_Count_Lists.List;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Extra : in Boolean := False)
is
use all type Ada.Containers.Count_Type;
use Ada.Text_IO;
@@ -1211,10 +1543,32 @@ package body WisiToken.Generate.LR is
New_Line;
Put_Line ("Productions:");
- WisiToken.Productions.Put (Grammar, Descriptor);
+ for LHS in Grammar.First_Index .. Grammar.Last_Index loop
+ declare
+ Prod : WisiToken.Productions.Instance renames Grammar (LHS);
+ begin
+ for RHS in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
+ Put (WisiToken.Productions.Image (Prod.LHS, RHS, Prod.RHSs
(RHS).Tokens, Descriptor));
+ if not Include_Extra or Minimal_Terminal_Sequences
(LHS)(RHS).Recursion.Length = 0 then
+ New_Line;
+ else
+ Put_Line
+ (" ; " & Image (Minimal_Terminal_Sequences
(LHS)(RHS).Recursion) & " " &
+ Recursion'Image (Minimal_Terminal_Sequences
(LHS)(RHS).Worst_Recursion));
+ end if;
+ end loop;
+ end;
+ end loop;
+
+ if Include_Extra then
+ New_Line;
+ Put_Line ((if Recursions.Full then "Recursions:" else "Partial
recursions:"));
+ for I in Recursions.Recursions.First_Index ..
Recursions.Recursions.Last_Index loop
+ Put_Line (Trimmed_Image (I) & " => " & Grammar_Graphs.Image
(Recursions.Recursions (I)));
+ end loop;
+ end if;
- if Table.McKenzie_Param.Cost_Limit /= Default_McKenzie_Param.Cost_Limit
or
- Table.McKenzie_Param.Check_Limit /=
Default_McKenzie_Param.Check_Limit or
+ if Table.McKenzie_Param.Check_Limit /=
Default_McKenzie_Param.Check_Limit or
Table.McKenzie_Param.Check_Delta_Limit /=
Default_McKenzie_Param.Check_Delta_Limit or
Table.McKenzie_Param.Enqueue_Limit /=
Default_McKenzie_Param.Enqueue_Limit
then
@@ -1227,7 +1581,8 @@ package body WisiToken.Generate.LR is
Put_Line (Title & " Parse Table:");
for State_Index in Table.States'Range loop
- LR1_Items.Put (Grammar, Descriptor, Kernels (State_Index),
Kernel_Only => True, Show_Lookaheads => True);
+ LR1_Items.Put
+ (Grammar, Descriptor, Kernels (State_Index), Kernel_Only => True,
Show_Lookaheads => Include_Extra);
New_Line;
Put (Descriptor, Table.States (State_Index));
@@ -1239,17 +1594,30 @@ package body WisiToken.Generate.LR is
if Conflicts.Length > 0 then
declare
use Ada.Strings.Unbounded;
- Last_State : Unknown_State_Index := Unknown_State;
- Line : Unbounded_String := +"States with conflicts:";
+ Line : Unbounded_String := +"States with conflicts:";
+ Accept_Reduce : Integer := 0;
+ Shift_Reduce : Integer := 0;
+ Reduce_Reduce : Integer := 0;
begin
- for Conflict of Conflicts loop
- if Conflict.State_Index /= Last_State then
- Append (Line, State_Index'Image (Conflict.State_Index));
- Last_State := Conflict.State_Index;
- end if;
+ for Count of Conflicts loop
+ Line := Line & State_Index'Image (Count.State);
+ Accept_Reduce := Accept_Reduce + Count.Accept_Reduce;
+ Shift_Reduce := Shift_Reduce + Count.Shift_Reduce;
+ Reduce_Reduce := Reduce_Reduce + Count.Reduce_Reduce;
end loop;
+
+ New_Line;
Indent_Wrap (-Line);
+
+ New_Line;
+ Put_Line
+ (Integer'Image (Accept_Reduce) & " accept/reduce conflicts," &
+ Integer'Image (Shift_Reduce) & " shift/reduce conflicts," &
+ Integer'Image (Reduce_Reduce) & " reduce/reduce conflicts");
end;
+ else
+ New_Line;
+ Put_Line (" 0 accept/reduce conflicts, 0 shift/reduce conflicts, 0
reduce/reduce conflicts");
end if;
end Put_Parse_Table;
diff --git a/wisitoken-generate-lr.ads b/wisitoken-generate-lr.ads
index 9cb22f2..297689b 100644
--- a/wisitoken-generate-lr.ads
+++ b/wisitoken-generate-lr.ads
@@ -46,6 +46,15 @@ package WisiToken.Generate.LR is
package Conflict_Lists is new Ada.Containers.Doubly_Linked_Lists (Conflict);
+ type Conflict_Count is record
+ State : State_Index;
+ Accept_Reduce : Integer := 0;
+ Shift_Reduce : Integer := 0;
+ Reduce_Reduce : Integer := 0;
+ end record;
+
+ package Conflict_Count_Lists is new Ada.Containers.Doubly_Linked_Lists
(Conflict_Count);
+
procedure Put
(Item : in Conflict_Lists.List;
File : in Ada.Text_IO.File_Type;
@@ -59,6 +68,7 @@ package WisiToken.Generate.LR is
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflict_Counts : in out Conflict_Count_Lists.List;
Conflicts : in out Conflict_Lists.List;
Descriptor : in WisiToken.Descriptor);
-- Add (Symbol, Action) to Action_List; check for conflicts
@@ -71,6 +81,7 @@ package WisiToken.Generate.LR is
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflict_Counts : in out Conflict_Count_Lists.List;
Conflicts : in out Conflict_Lists.List;
Descriptor : in WisiToken.Descriptor);
-- Add actions for Closure to Table. Has_Empty_Production, First,
@@ -82,6 +93,7 @@ package WisiToken.Generate.LR is
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflict_Counts : in out Conflict_Count_Lists.List;
Conflicts : in out Conflict_Lists.List;
Closure : in LR1_Items.Item_Set;
Descriptor : in WisiToken.Descriptor);
@@ -95,11 +107,6 @@ package WisiToken.Generate.LR is
-- Delete Known_Conflicts from Conflicts.
function Find
- (Symbol : in Token_ID;
- Action_List : in Action_Node_Ptr)
- return Action_Node_Ptr;
-
- function Find
(Closure : in LR1_Items.Item_Set;
Action : in Parse_Action_Rec;
Lookahead : in Token_ID;
@@ -117,11 +124,15 @@ package WisiToken.Generate.LR is
function Match (Known : in Conflict; Item : in
Conflict_Lists.Constant_Reference_Type) return Boolean;
+ ----------
+ -- Minimal terminal sequences.
+
type RHS_Sequence is
record
- Left_Recursive : Boolean := False;
- -- Direct or indirect; see comment in
- -- Set_Minimal_Complete_Actions.Delete_Non_Minimal.
+ Recursion : Recursion_Lists.List;
+ -- All recursion cycles involving this RHS.
+
+ Worst_Recursion : WisiToken.Recursion := None; -- worst case of all
Recursion.
Sequence : Token_ID_Arrays.Vector;
end record;
@@ -132,7 +143,7 @@ package WisiToken.Generate.LR is
function Image (Item : in RHS_Sequence; Descriptor : in
WisiToken.Descriptor) return String;
-- Positional Ada aggregate syntax.
- function Image is new RHS_Sequence_Arrays.Gen_Image_Aux (Descriptor, Image);
+ function Image is new RHS_Sequence_Arrays.Gen_Image_Aux (Descriptor,
Trimmed_Image, Image);
function Min (Item : in RHS_Sequence_Arrays.Vector) return RHS_Sequence;
-- Return element of Item with minimum length;
@@ -140,13 +151,13 @@ package WisiToken.Generate.LR is
type Minimal_Sequence_Array is array (Token_ID range <>) of
RHS_Sequence_Arrays.Vector;
function Compute_Minimal_Terminal_Sequences
- (Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
+ (Descriptor : in WisiToken.Descriptor;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Recursions : in Generate.Recursions)
return Minimal_Sequence_Array;
-- For each production in Grammar, compute the minimal sequence of
-- terminals that will complete it. Result is an empty sequence if
- -- the production may be empty, or Invalid_Token_ID if it is
- -- recursive.
+ -- the production may be empty.
function Compute_Minimal_Terminal_First
(Descriptor : in WisiToken.Descriptor;
@@ -169,7 +180,11 @@ package WisiToken.Generate.LR is
-- terminal is a block ending or statement start.
--
-- The Minimal_Complete_Actions will be empty in a state where there
- -- is nothing useful to do.
+ -- is nothing useful to do; the accept state, or one where all
+ -- productions are recursive.
+ --
+ -- Also set State.Kernels; used to resolve multiple reduce actions at
+ -- runtime.
----------
-- Parse table output
@@ -191,11 +206,15 @@ package WisiToken.Generate.LR is
-- Put Item to Ada.Text_IO.Current_Output in parse table format.
procedure Put_Parse_Table
- (Table : in Parse_Table_Ptr;
- Title : in String;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Kernels : in LR1_Items.Item_Set_List;
- Conflicts : in Conflict_Lists.List;
- Descriptor : in WisiToken.Descriptor);
+ (Table : in Parse_Table_Ptr;
+ Title : in String;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Recursions : in Generate.Recursions;
+ Minimal_Terminal_Sequences : in Minimal_Sequence_Array;
+ Kernels : in LR1_Items.Item_Set_List;
+ Conflicts : in Conflict_Count_Lists.List;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Extra : in Boolean := False);
+ -- "Extra" is recursions, lookaheads.
end WisiToken.Generate.LR;
diff --git a/wisitoken-generate-lr1_items.adb b/wisitoken-generate-lr1_items.adb
index b6d14ca..86cd8d9 100644
--- a/wisitoken-generate-lr1_items.adb
+++ b/wisitoken-generate-lr1_items.adb
@@ -451,9 +451,8 @@ package body WisiToken.Generate.LR1_Items is
Added_Item := False;
if Trace_Generate > Extra then
- Ada.Text_IO.Put_Line ("I:");
+ Ada.Text_IO.Put_Line (" closure:");
Put (Grammar, Descriptor, I);
- Ada.Text_IO.New_Line;
end if;
else
Item_I := Item_Lists.Next (Item_I);
diff --git a/wisitoken-generate-lr1_items.ads b/wisitoken-generate-lr1_items.ads
index 3ee55d8..0fd8c55 100644
--- a/wisitoken-generate-lr1_items.ads
+++ b/wisitoken-generate-lr1_items.ads
@@ -96,7 +96,7 @@ package WisiToken.Generate.LR1_Items is
type Item is record
Prod : Production_ID;
Dot : Token_ID_Arrays.Cursor; -- token after item Dot
- Lookaheads : access Lookahead := null;
+ Lookaheads : Token_ID_Set_Access := null;
-- Programmer must remember to copy Item.Lookaheads.all, not
-- Item.Lookaheads. Wrapping this in Ada.Finalization.Controlled
-- would just slow it down.
diff --git a/wisitoken-generate-packrat.adb b/wisitoken-generate-packrat.adb
index 80a4c10..c50b1ed 100644
--- a/wisitoken-generate-packrat.adb
+++ b/wisitoken-generate-packrat.adb
@@ -1,247 +1,247 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Generate.Packrat is
-
- function Potential_Direct_Right_Recursive
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Empty : in Token_ID_Set)
- return Token_ID_Set
- is
- subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
- begin
- return Result : Token_ID_Set (Nonterminal) := (others => False) do
- for Prod of Grammar loop
- RHS_Loop :
- for RHS of Prod.RHSs loop
- ID_Loop :
- for I in reverse RHS.Tokens.First_Index + 1 ..
RHS.Tokens.Last_Index loop
- declare
- ID : constant Token_ID := RHS.Tokens (I);
- begin
- if ID = Prod.LHS then
- Result (ID) := True;
- exit RHS_Loop;
- elsif not (ID in Nonterminal) then
- exit ID_Loop;
- elsif not Empty (ID) then
- exit ID_Loop;
- end if;
- end;
- end loop ID_Loop;
- end loop RHS_Loop;
- end loop;
- end return;
- end Potential_Direct_Right_Recursive;
-
- procedure Indirect_Left_Recursive (Data : in out Packrat.Data)
- is
- begin
- for Prod_I of Data.Grammar loop
- for Prod_J of Data.Grammar loop
- Data.Involved (Prod_I.LHS, Prod_J.LHS) :=
- Data.First (Prod_I.LHS, Prod_J.LHS) and
- Data.First (Prod_J.LHS, Prod_I.LHS);
- end loop;
- end loop;
- end Indirect_Left_Recursive;
-
- ----------
- -- Public subprograms
-
- function Initialize
- (Source_File_Name : in String;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Source_Line_Map : in Productions.Source_Line_Maps.Vector;
- First_Terminal : in Token_ID)
- return Packrat.Data
- is
- Empty : constant Token_ID_Set := WisiToken.Generate.Has_Empty_Production
(Grammar);
- begin
- return Result : Packrat.Data :=
- (First_Terminal => First_Terminal,
- First_Nonterminal => Grammar.First_Index,
- Last_Nonterminal => Grammar.Last_Index,
- Source_File_Name => +Source_File_Name,
- Grammar => Grammar,
- Source_Line_Map => Source_Line_Map,
- Empty => Empty,
- Direct_Left_Recursive => Potential_Direct_Left_Recursive (Grammar,
Empty),
- First => WisiToken.Generate.First (Grammar, Empty,
First_Terminal => First_Terminal),
- Involved => (others => (others => False)))
- do
- Indirect_Left_Recursive (Result);
- end return;
- end Initialize;
-
- procedure Check_Recursion (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
- is
- Right_Recursive : constant Token_ID_Set :=
Potential_Direct_Right_Recursive (Data.Grammar, Data.Empty);
- begin
- for Prod of Data.Grammar loop
- if Data.Direct_Left_Recursive (Prod.LHS) and Right_Recursive
(Prod.LHS) then
- -- We only implement the simplest left recursion solution ([warth
- -- 2008] figure 3); [tratt 2010] section 6.3 gives this condition
for
- -- that to be valid.
- -- FIXME: not quite? definite direct right recursive ok?
- -- FIXME: for indirect left recursion, need potential indirect
right recursive check?
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
- "' is both left and right recursive; not supported."));
- end if;
-
- for I in Data.Involved'Range (2) loop
- if Prod.LHS /= I and then Data.Involved (Prod.LHS, I) then
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
- "' is indirect recursive with " & Image (I, Descriptor)
& ", not supported"));
- end if;
- end loop;
- end loop;
- end Check_Recursion;
-
- procedure Check_RHS_Order (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
- is
- use all type Ada.Containers.Count_Type;
- begin
- for Prod of Data.Grammar loop
- -- Empty must be last
- for I in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index - 1 loop
- if Prod.RHSs (I).Tokens.Length = 0 then
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).RHS_Map (I),
- "right hand side" & Integer'Image (I) & " in " & Image
(Prod.LHS, Descriptor) &
- " is empty, but not last; no later right hand side will
match."));
- WisiToken.Generate.Error := True;
- end if;
- end loop;
-
- for I in Prod.RHSs.First_Index + 1 .. Prod.RHSs.Last_Index loop
- declare
- Cur : Token_ID_Arrays.Vector renames Prod.RHSs (I).Tokens;
- begin
- -- Shared prefix; longer must be first
- for J in Prod.RHSs.First_Index .. I - 1 loop
- declare
- Prev : Token_ID_Arrays.Vector renames Prod.RHSs
(J).Tokens;
- K : constant Natural := Shared_Prefix (Prev, Cur);
- begin
- if K > 0 and Prev.Length < Cur.Length then
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).RHS_Map (I),
- "right hand side" & Integer'Image (I) & " in " &
Image (Prod.LHS, Descriptor) &
- " may never match; it shares a prefix with a
shorter previous rhs" &
- Integer'Image (J) & "."));
- end if;
- end;
- end loop;
-
- -- recursion; typical LALR list is written:
- --
- -- statement_list
- -- : statement
- -- | statement_list statement
- -- ;
- -- association_list
- -- : association
- -- | association_list COMMA association
- -- ;
- --
- -- a different recursive definition:
- --
- -- name
- -- : IDENTIFIER
- -- | name LEFT_PAREN range_list RIGHT_PAREN
- -- | name actual_parameter_part
- -- ...
- -- ;
- --
- -- For packrat, the recursive RHSs must come before others:
- --
- -- statement_list
- -- : statement_list statement
- -- | statement
- -- ;
- -- association_list
- -- : association_list COMMA association
- -- | association
- -- ;
- -- name
- -- : name LEFT_PAREN range_list RIGHT_PAREN
- -- | name actual_parameter_part
- -- | IDENTIFIER
- -- ...
- -- ;
- declare
- Prev : Token_ID_Arrays.Vector renames Prod.RHSs (I -
1).Tokens;
- begin
- if Cur.Length > 0 and then Prev.Length > 0 and then
- Cur (1) = Prod.LHS and then Prev (1) /= Prod.LHS
- then
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line,
- "recursive right hand sides must be before
others."));
- end if;
- end;
- end;
- end loop;
- end loop;
- end Check_RHS_Order;
-
- procedure Check_All (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
- is begin
- Check_Recursion (Data, Descriptor);
- Check_RHS_Order (Data, Descriptor);
- end Check_All;
-
- function Potential_Direct_Left_Recursive
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Empty : in Token_ID_Set)
- return Token_ID_Set
- is
- subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
- begin
- -- FIXME: this duplicates the computation of First; if keep First,
- -- change this to use it.
- return Result : Token_ID_Set (Nonterminal) := (others => False) do
- for Prod of Grammar loop
- RHS_Loop :
- for RHS of Prod.RHSs loop
- ID_Loop :
- for ID of RHS.Tokens loop
- if ID = Prod.LHS then
- Result (ID) := True;
- exit RHS_Loop;
- elsif not (ID in Nonterminal) then
- exit ID_Loop;
- elsif not Empty (ID) then
- exit ID_Loop;
- end if;
- end loop ID_Loop;
- end loop RHS_Loop;
- end loop;
- end return;
- end Potential_Direct_Left_Recursive;
-
-end WisiToken.Generate.Packrat;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Generate.Packrat is
+
+ function Potential_Direct_Right_Recursive
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Empty : in Token_ID_Set)
+ return Token_ID_Set
+ is
+ subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
+ begin
+ return Result : Token_ID_Set (Nonterminal) := (others => False) do
+ for Prod of Grammar loop
+ RHS_Loop :
+ for RHS of Prod.RHSs loop
+ ID_Loop :
+ for I in reverse RHS.Tokens.First_Index + 1 ..
RHS.Tokens.Last_Index loop
+ declare
+ ID : constant Token_ID := RHS.Tokens (I);
+ begin
+ if ID = Prod.LHS then
+ Result (ID) := True;
+ exit RHS_Loop;
+ elsif not (ID in Nonterminal) then
+ exit ID_Loop;
+ elsif not Empty (ID) then
+ exit ID_Loop;
+ end if;
+ end;
+ end loop ID_Loop;
+ end loop RHS_Loop;
+ end loop;
+ end return;
+ end Potential_Direct_Right_Recursive;
+
+ procedure Indirect_Left_Recursive (Data : in out Packrat.Data)
+ is
+ begin
+ for Prod_I of Data.Grammar loop
+ for Prod_J of Data.Grammar loop
+ Data.Involved (Prod_I.LHS, Prod_J.LHS) :=
+ Data.First (Prod_I.LHS, Prod_J.LHS) and
+ Data.First (Prod_J.LHS, Prod_I.LHS);
+ end loop;
+ end loop;
+ end Indirect_Left_Recursive;
+
+ ----------
+ -- Public subprograms
+
+ function Initialize
+ (Source_File_Name : in String;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Source_Line_Map : in Productions.Source_Line_Maps.Vector;
+ First_Terminal : in Token_ID)
+ return Packrat.Data
+ is
+ Empty : constant Token_ID_Set := WisiToken.Generate.Has_Empty_Production
(Grammar);
+ begin
+ return Result : Packrat.Data :=
+ (First_Terminal => First_Terminal,
+ First_Nonterminal => Grammar.First_Index,
+ Last_Nonterminal => Grammar.Last_Index,
+ Source_File_Name => +Source_File_Name,
+ Grammar => Grammar,
+ Source_Line_Map => Source_Line_Map,
+ Empty => Empty,
+ Direct_Left_Recursive => Potential_Direct_Left_Recursive (Grammar,
Empty),
+ First => WisiToken.Generate.First (Grammar, Empty,
First_Terminal => First_Terminal),
+ Involved => (others => (others => False)))
+ do
+ Indirect_Left_Recursive (Result);
+ end return;
+ end Initialize;
+
+ procedure Check_Recursion (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
+ is
+ Right_Recursive : constant Token_ID_Set :=
Potential_Direct_Right_Recursive (Data.Grammar, Data.Empty);
+ begin
+ for Prod of Data.Grammar loop
+ if Data.Direct_Left_Recursive (Prod.LHS) and Right_Recursive
(Prod.LHS) then
+ -- We only implement the simplest left recursion solution ([warth
+ -- 2008] figure 3); [tratt 2010] section 6.3 gives this condition
for
+ -- that to be valid.
+ -- FIXME: not quite? definite direct right recursive ok?
+ -- FIXME: for indirect left recursion, need potential indirect
right recursive check?
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
+ "' is both left and right recursive; not supported."));
+ end if;
+
+ for I in Data.Involved'Range (2) loop
+ if Prod.LHS /= I and then Data.Involved (Prod.LHS, I) then
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
+ "' is indirect recursive with " & Image (I, Descriptor)
& ", not supported"));
+ end if;
+ end loop;
+ end loop;
+ end Check_Recursion;
+
+ procedure Check_RHS_Order (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ for Prod of Data.Grammar loop
+ -- Empty must be last
+ for I in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index - 1 loop
+ if Prod.RHSs (I).Tokens.Length = 0 then
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).RHS_Map (I),
+ "right hand side" & Integer'Image (I) & " in " & Image
(Prod.LHS, Descriptor) &
+ " is empty, but not last; no later right hand side will
match."));
+ WisiToken.Generate.Error := True;
+ end if;
+ end loop;
+
+ for I in Prod.RHSs.First_Index + 1 .. Prod.RHSs.Last_Index loop
+ declare
+ Cur : Token_ID_Arrays.Vector renames Prod.RHSs (I).Tokens;
+ begin
+ -- Shared prefix; longer must be first
+ for J in Prod.RHSs.First_Index .. I - 1 loop
+ declare
+ Prev : Token_ID_Arrays.Vector renames Prod.RHSs
(J).Tokens;
+ K : constant Natural := Shared_Prefix (Prev, Cur);
+ begin
+ if K > 0 and Prev.Length < Cur.Length then
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).RHS_Map (I),
+ "right hand side" & Integer'Image (I) & " in " &
Image (Prod.LHS, Descriptor) &
+ " may never match; it shares a prefix with a
shorter previous rhs" &
+ Integer'Image (J) & "."));
+ end if;
+ end;
+ end loop;
+
+ -- recursion; typical LALR list is written:
+ --
+ -- statement_list
+ -- : statement
+ -- | statement_list statement
+ -- ;
+ -- association_list
+ -- : association
+ -- | association_list COMMA association
+ -- ;
+ --
+ -- a different recursive definition:
+ --
+ -- name
+ -- : IDENTIFIER
+ -- | name LEFT_PAREN range_list RIGHT_PAREN
+ -- | name actual_parameter_part
+ -- ...
+ -- ;
+ --
+ -- For packrat, the recursive RHSs must come before others:
+ --
+ -- statement_list
+ -- : statement_list statement
+ -- | statement
+ -- ;
+ -- association_list
+ -- : association_list COMMA association
+ -- | association
+ -- ;
+ -- name
+ -- : name LEFT_PAREN range_list RIGHT_PAREN
+ -- | name actual_parameter_part
+ -- | IDENTIFIER
+ -- ...
+ -- ;
+ declare
+ Prev : Token_ID_Arrays.Vector renames Prod.RHSs (I -
1).Tokens;
+ begin
+ if Cur.Length > 0 and then Prev.Length > 0 and then
+ Cur (1) = Prod.LHS and then Prev (1) /= Prod.LHS
+ then
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line,
+ "recursive right hand sides must be before
others."));
+ end if;
+ end;
+ end;
+ end loop;
+ end loop;
+ end Check_RHS_Order;
+
+ procedure Check_All (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
+ is begin
+ Check_Recursion (Data, Descriptor);
+ Check_RHS_Order (Data, Descriptor);
+ end Check_All;
+
+ function Potential_Direct_Left_Recursive
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Empty : in Token_ID_Set)
+ return Token_ID_Set
+ is
+ subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
+ begin
+ -- FIXME: this duplicates the computation of First; if keep First,
+ -- change this to use it.
+ return Result : Token_ID_Set (Nonterminal) := (others => False) do
+ for Prod of Grammar loop
+ RHS_Loop :
+ for RHS of Prod.RHSs loop
+ ID_Loop :
+ for ID of RHS.Tokens loop
+ if ID = Prod.LHS then
+ Result (ID) := True;
+ exit RHS_Loop;
+ elsif not (ID in Nonterminal) then
+ exit ID_Loop;
+ elsif not Empty (ID) then
+ exit ID_Loop;
+ end if;
+ end loop ID_Loop;
+ end loop RHS_Loop;
+ end loop;
+ end return;
+ end Potential_Direct_Left_Recursive;
+
+end WisiToken.Generate.Packrat;
diff --git a/wisitoken-generate-packrat.ads b/wisitoken-generate-packrat.ads
index ec9a4cb..17bf03e 100644
--- a/wisitoken-generate-packrat.ads
+++ b/wisitoken-generate-packrat.ads
@@ -1,75 +1,75 @@
--- Abstract :
---
--- Types and operations for computing grammar properties used in
--- generating a packrat parser.
---
--- We use the terminology in [tratt 2010] for recursion in
--- productions.
---
--- References :
---
--- See wisitoken-parse-packrat.ads.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package WisiToken.Generate.Packrat is
-
- type Data (First_Terminal, First_Nonterminal, Last_Nonterminal : Token_ID)
is tagged
- record
- -- Data needed to check a grammar and generate code. Tagged to allow
- -- Object.Method syntax. Descriptor not included to avoid duplicating
- -- lots of discriminants.
- Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
- Grammar : WisiToken.Productions.Prod_Arrays.Vector;
- Source_Line_Map : Productions.Source_Line_Maps.Vector;
- Empty : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
- Direct_Left_Recursive : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
- First : Token_Array_Token_Set
- (First_Nonterminal .. Last_Nonterminal, First_Terminal ..
Last_Nonterminal);
- Involved : Token_Array_Token_Set
- (First_Nonterminal .. Last_Nonterminal, First_Nonterminal ..
Last_Nonterminal);
- end record;
-
- function Initialize
- (Source_File_Name : in String;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Source_Line_Map : in Productions.Source_Line_Maps.Vector;
- First_Terminal : in Token_ID)
- return Packrat.Data;
-
- procedure Check_Recursion (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
- -- Check that any rule recursion present is supported.
-
- procedure Check_RHS_Order (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
- -- For each production, check that right hand sides that share
- -- prefixes have the longest right hand side first, and that any
- -- empty right hand side is last.
- --
- -- Violations output a message to Ada.Text_IO.Standard_Error, and
- -- set WisiToken.Generate.Error True.
-
- procedure Check_All (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
- -- Run all the above checks.
- --
- -- Note that WisiToken.Generate.Check_Consistent is run in
- -- wisi-gen_generate_utils.To_Grammar.
-
- function Potential_Direct_Left_Recursive
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Empty : in Token_ID_Set)
- return Token_ID_Set;
-
-end WisiToken.Generate.Packrat;
+-- Abstract :
+--
+-- Types and operations for computing grammar properties used in
+-- generating a packrat parser.
+--
+-- We use the terminology in [tratt 2010] for recursion in
+-- productions.
+--
+-- References :
+--
+-- See wisitoken-parse-packrat.ads.
+--
+-- Copyright (C) 2018 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package WisiToken.Generate.Packrat is
+
+ type Data (First_Terminal, First_Nonterminal, Last_Nonterminal : Token_ID)
is tagged
+ record
+ -- Data needed to check a grammar and generate code. Tagged to allow
+ -- Object.Method syntax. Descriptor not included to avoid duplicating
+ -- lots of discriminants.
+ Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Grammar : WisiToken.Productions.Prod_Arrays.Vector;
+ Source_Line_Map : Productions.Source_Line_Maps.Vector;
+ Empty : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
+ Direct_Left_Recursive : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
+ First : Token_Array_Token_Set
+ (First_Nonterminal .. Last_Nonterminal, First_Terminal ..
Last_Nonterminal);
+ Involved : Token_Array_Token_Set
+ (First_Nonterminal .. Last_Nonterminal, First_Nonterminal ..
Last_Nonterminal);
+ end record;
+
+ function Initialize
+ (Source_File_Name : in String;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Source_Line_Map : in Productions.Source_Line_Maps.Vector;
+ First_Terminal : in Token_ID)
+ return Packrat.Data;
+
+ procedure Check_Recursion (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
+ -- Check that any rule recursion present is supported.
+
+ procedure Check_RHS_Order (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
+ -- For each production, check that right hand sides that share
+ -- prefixes have the longest right hand side first, and that any
+ -- empty right hand side is last.
+ --
+ -- Violations output a message to Ada.Text_IO.Standard_Error, and
+ -- set WisiToken.Generate.Error True.
+
+ procedure Check_All (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
+ -- Run all the above checks.
+ --
+ -- Note that WisiToken.Generate.Check_Consistent is run in
+ -- wisi-gen_generate_utils.To_Grammar.
+
+ function Potential_Direct_Left_Recursive
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Empty : in Token_ID_Set)
+ return Token_ID_Set;
+
+end WisiToken.Generate.Packrat;
diff --git a/wisitoken-generate.adb b/wisitoken-generate.adb
index 9796b87..769a581 100644
--- a/wisitoken-generate.adb
+++ b/wisitoken-generate.adb
@@ -1,434 +1,543 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Directories;
-with Ada.Text_IO;
-with Ada.Strings.Fixed;
-package body WisiToken.Generate is
-
- function Error_Message
- (File_Name : in String;
- File_Line : in Line_Number_Type;
- Message : in String)
- return String
- is
- use Ada.Directories;
- use Ada.Strings.Fixed;
- use Ada.Strings;
- begin
- return Simple_Name (File_Name) & ":" &
- Trim (Line_Number_Type'Image (File_Line), Left) & ":0: " & Message;
- end Error_Message;
-
- procedure Put_Error (Message : in String)
- is begin
- Error := True;
- Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, Message);
- end Put_Error;
-
- procedure Check_Consistent
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Source_File_Name : in String)
- is begin
- if Descriptor.Accept_ID /= Descriptor.First_Nonterminal then
- Put_Error
- (Error_Message
- (Source_File_Name, Line_Number_Type'First,
- "Descriptor.Accept_ID /= Descriptor.First_Nonterminal"));
- end if;
- if Grammar.First_Index /= Descriptor.First_Nonterminal then
- Put_Error
- (Error_Message
- (Source_File_Name, Line_Number_Type'First,
- "Grammar.First_Index /= Descriptor.First_Nonterminal"));
- end if;
- if Grammar.Last_Index /= Descriptor.Last_Nonterminal then
- Put_Error
- (Error_Message
- (Source_File_Name, Line_Number_Type'First,
- "Grammar.Last_Index /= Descriptor.Last_Nonterminal"));
- end if;
-
- for Nonterm in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal loop
- if Grammar (Nonterm).LHS /= Nonterm then
- Put_Error
- (Error_Message
- (Source_File_Name, Line_Number_Type'First,
- "Grammar (" & Image (Nonterm, Descriptor) & ").LHS /= " &
- Image (Nonterm, Descriptor)));
- end if;
- end loop;
- end Check_Consistent;
-
- function Check_Unused_Tokens
- (Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
- return Boolean
- is
- subtype Terminals is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
- subtype Nonterminals is Token_ID range Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal;
-
- Used_Tokens : Token_ID_Set := (Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal => False);
-
- Changed : Boolean := False;
- Abort_Generate : Boolean := False;
- Unused_Tokens : Boolean := False;
- begin
- Used_Tokens (Descriptor.Accept_ID) := True;
-
- -- First mark all nonterminals that occur in used nonterminals as
- -- used.
- loop
- for Prod of Grammar loop
- if Used_Tokens (Prod.LHS) then
- for RHS of Prod.RHSs loop
- for J of RHS.Tokens loop
- if J in Nonterminals then
- Changed := Changed or else not Used_Tokens (J);
- Used_Tokens (J) := True;
- end if;
- end loop;
- end loop;
- end if;
- end loop;
- exit when not Changed;
- Changed := False;
- end loop;
-
- -- Now mark terminals used in used nonterminals
- for Prod of Grammar loop
- if Used_Tokens (Prod.LHS) then
- for RHS of Prod.RHSs loop
- for J of RHS.Tokens loop
- if not (J in Used_Tokens'Range) then
- WisiToken.Generate.Put_Error
- ("non-grammar token " & Image (J, Descriptor) & " used
in grammar");
-
- -- This causes lots of problems with token_id not in
terminal or
- -- nonterminal range, so abort early.
- Abort_Generate := True;
- end if;
-
- if J in Terminals then
- Used_Tokens (J) := True;
- end if;
- end loop;
- end loop;
- end if;
- end loop;
-
- for I in Used_Tokens'Range loop
- if not Used_Tokens (I) then
- if not Unused_Tokens then
- WisiToken.Generate.Put_Error ("Unused tokens:");
- Unused_Tokens := True;
- end if;
- WisiToken.Generate.Put_Error (Image (I, Descriptor));
- end if;
- end loop;
-
- if Abort_Generate then
- raise Grammar_Error;
- end if;
-
- return Unused_Tokens;
- end Check_Unused_Tokens;
-
- function Has_Empty_Production (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Token_ID_Set
- is
- use all type Ada.Containers.Count_Type;
-
- subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
-
- Result : Token_ID_Set := (Nonterminal => False);
- Changed : Boolean := True;
- begin
- loop
- exit when not Changed;
- Changed := False;
-
- for Prod of Grammar loop
- for RHS of Prod.RHSs loop
- if (RHS.Tokens.Length = 0 or else
- (RHS.Tokens (1) in Nonterminal and then Result
(RHS.Tokens (1)))) and
- not Result (Prod.LHS)
- then
- Result (Prod.LHS) := True;
- Changed := True;
- end if;
- end loop;
- end loop;
- end loop;
- return Result;
- end Has_Empty_Production;
-
- function First
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal : in Token_ID;
- Non_Terminal : in Token_ID)
- return Token_ID_Set
- is
- Derivations : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
- Added_Tokens : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
- Search_Tokens : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
-
- function Compute_Non_Terminals return Token_ID_Set
- is
- Result : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
- begin
- -- Can't use a simple aggregate for this; bounds are non-static.
- Result (First_Terminal .. Grammar.First_Index - 1) := (others =>
False);
- Result (Grammar.First_Index .. Grammar.Last_Index) := (others =>
True);
- return Result;
- end Compute_Non_Terminals;
-
- Non_Terminals : constant Token_ID_Set := Compute_Non_Terminals;
-
- begin
- Search_Tokens (Non_Terminal) := True;
-
- while Any (Search_Tokens) loop
-
- Added_Tokens := (others => False);
-
- for Prod of Grammar loop
- if Search_Tokens (Prod.LHS) then
- for RHS of Prod.RHSs loop
- for Derived_Token of RHS.Tokens loop
- if not Derivations (Derived_Token) then
- Added_Tokens (Derived_Token) := True;
- end if;
-
- if Non_Terminals (Derived_Token) and then
Has_Empty_Production (Derived_Token) then
- null;
- else
- exit;
- end if;
- end loop;
- end loop;
- end if;
- end loop;
-
- Derivations := Derivations or Added_Tokens;
- Search_Tokens := Added_Tokens and Non_Terminals;
- end loop;
-
- return Derivations;
- end First;
-
- function First
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal : in Token_ID)
- return Token_Array_Token_Set
- is
- Matrix : Token_Array_Token_Set :=
- (Grammar.First_Index .. Grammar.Last_Index =>
- (First_Terminal .. Grammar.Last_Index => False));
-
- procedure Set_Slice (Matrix : in out Token_Array_Token_Set; I :
Token_ID; Value : in Token_ID_Set)
- is begin
- for J in Matrix'Range (2) loop
- Matrix (I, J) := Value (J);
- end loop;
- end Set_Slice;
-
- begin
- for NT_Index in Matrix'Range loop
- Set_Slice (Matrix, NT_Index, First (Grammar, Has_Empty_Production,
First_Terminal, NT_Index));
- end loop;
-
- return Matrix;
- end First;
-
- function To_Terminal_Sequence_Array
- (First : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return Token_Sequence_Arrays.Vector
- is
- subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
- begin
- return Result : Token_Sequence_Arrays.Vector do
- Result.Set_First (First'First (1));
- Result.Set_Last (First'Last (1));
-
- for I in First'Range (1) loop
- declare
- Row : Token_ID_Arrays.Vector renames Result (I);
- begin
- for J in First'Range (2) loop
- if First (I, J) and then J in Terminal then
- Row.Append (J);
- end if;
- end loop;
- end;
- end loop;
- end return;
- end To_Terminal_Sequence_Array;
-
- function Follow
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- First : in Token_Array_Token_Set;
- Has_Empty_Production : in Token_ID_Set)
- return Token_Array_Token_Set
- is
- subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
- subtype Nonterminal is Token_ID range Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal;
-
- Prev_Result : Token_Array_Token_Set := (Nonterminal => (Terminal =>
False));
- Result : Token_Array_Token_Set := (Nonterminal => (Terminal =>
False));
-
- ID : Token_ID;
- begin
- -- [dragon] pgp 189:
- --
- -- Rule 1 Follow (S, EOF) = True; EOF is explicit in the
- -- start symbol production, so this is covered by Rule 2.
- --
- -- Rule 2: If A => alpha B Beta, add First (Beta) to Follow (B)
- --
- -- Rule 3; if A => alpha B, or A -> alpha B Beta and Beta
- -- can be null, add Follow (A) to Follow (B)
- --
- -- We don't assume any order in the productions list, so we
- -- have to keep applying rule 3 until nothing changes.
-
- for B in Nonterminal loop
- for Prod of Grammar loop
- for A of Prod.RHSs loop
- for I in A.Tokens.First_Index .. A.Tokens.Last_Index loop
- if A.Tokens (I) = B then
- if I < A.Tokens.Last_Index then
- -- Rule 1
- ID := A.Tokens (1 + I);
- if ID in Terminal then
- Result (B, ID) := True;
- else
- Or_Slice (Result, B, Slice (First, ID));
- end if;
- end if;
- end if;
- end loop;
- end loop;
- end loop;
- end loop;
-
- Prev_Result := Result;
- loop
- for B in Nonterminal loop
- for Prod of Grammar loop
- for A of Prod.RHSs loop
- for I in A.Tokens.First_Index .. A.Tokens.Last_Index loop
- if A.Tokens (I) = B then
- if I = A.Tokens.Last_Index or else
- (A.Tokens (1 + I) in Nonterminal and then
- Has_Empty_Production (A.Tokens (1 + I)))
- then
- -- rule 3
- Or_Slice (Result, B, Slice (Result, Prod.LHS));
- end if;
- end if;
- end loop;
- end loop;
- end loop;
- end loop;
-
- exit when Prev_Result = Result;
- Prev_Result := Result;
- end loop;
- return Result;
- end Follow;
-
- ----------
- -- Indented text output
-
- procedure Indent_Line (Text : in String)
- is
- use Ada.Text_IO;
- begin
- Set_Col (Indent);
- Put_Line (Text);
- Line_Count := Line_Count + 1;
- end Indent_Line;
-
- procedure Indent_Start (Text : in String)
- is
- use Ada.Text_IO;
- begin
- Set_Col (Indent);
- Put (Text);
- end Indent_Start;
-
- procedure Indent_Wrap (Text : in String)
- is
- use all type Ada.Text_IO.Count;
- use Ada.Strings;
- use Ada.Strings.Fixed;
- I : Natural;
- First : Integer := Text'First;
- begin
- if Text'Length + Indent <= Max_Line_Length then
- Indent_Line (Text);
- else
- loop
- I := Text'Last;
- loop
- I := Index (Text (First .. Text'Last), " ", From => I, Going =>
Backward);
- exit when I - First + Integer (Indent) <= Max_Line_Length;
- I := I - 1;
- end loop;
- Indent_Line (Text (First .. I - 1));
- First := I + 1;
- exit when Text'Last - First + Integer (Indent) <= Max_Line_Length;
- end loop;
- Indent_Line (Text (First .. Text'Last));
- end if;
- end Indent_Wrap;
-
- procedure Indent_Wrap_Comment (Text : in String; Comment_Syntax : in String)
- is
- use all type Ada.Text_IO.Count;
- use Ada.Strings;
- use Ada.Strings.Fixed;
- Prefix : constant String := Comment_Syntax & " ";
- I : Natural;
- First : Integer := Text'First;
- begin
- if Text'Length + Indent <= Max_Line_Length - 4 then
- Indent_Line (Prefix & Text);
- else
- loop
- I := Text'Last;
- loop
- I := Index (Text (First .. Text'Last), " ", From => I, Going =>
Backward);
- exit when I - First + Integer (Indent) <= Max_Line_Length - 4;
- I := I - 1;
- end loop;
- Indent_Line (Prefix & Text (First .. I - 1));
- First := I + 1;
- exit when Text'Last - First + Integer (Indent) <= Max_Line_Length
- 4;
- end loop;
- Indent_Line (Prefix & Text (First .. Text'Last));
- end if;
- end Indent_Wrap_Comment;
-
-end WisiToken.Generate;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Directories;
+with Ada.Text_IO;
+with Ada.Strings.Fixed;
+package body WisiToken.Generate is
+
+ function Error_Message
+ (File_Name : in String;
+ File_Line : in Line_Number_Type;
+ Message : in String)
+ return String
+ is
+ use Ada.Directories;
+ use Ada.Strings.Fixed;
+ use Ada.Strings;
+ begin
+ return Simple_Name (File_Name) & ":" &
+ Trim (Line_Number_Type'Image (File_Line), Left) & ":0: " & Message;
+ end Error_Message;
+
+ procedure Put_Error (Message : in String)
+ is begin
+ Error := True;
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, Message);
+ end Put_Error;
+
+ procedure Check_Consistent
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Source_File_Name : in String)
+ is begin
+ if Descriptor.Accept_ID /= Descriptor.First_Nonterminal then
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Line_Number_Type'First,
+ "Descriptor.Accept_ID /= Descriptor.First_Nonterminal"));
+ end if;
+ if Grammar.First_Index /= Descriptor.First_Nonterminal then
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Line_Number_Type'First,
+ "Grammar.First_Index /= Descriptor.First_Nonterminal"));
+ end if;
+ if Grammar.Last_Index /= Descriptor.Last_Nonterminal then
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Line_Number_Type'First,
+ "Grammar.Last_Index /= Descriptor.Last_Nonterminal"));
+ end if;
+
+ for Nonterm in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal loop
+ if Grammar (Nonterm).LHS /= Nonterm then
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Line_Number_Type'First,
+ "Grammar (" & Image (Nonterm, Descriptor) & ").LHS = " &
+ Image (Grammar (Nonterm).LHS, Descriptor) & " /= " &
+ Image (Nonterm, Descriptor)));
+ end if;
+ end loop;
+ end Check_Consistent;
+
+ function Check_Unused_Tokens
+ (Descriptor : in WisiToken.Descriptor;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
+ return Boolean
+ is
+ subtype Terminals is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+ subtype Nonterminals is Token_ID range Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal;
+
+ Used_Tokens : Token_ID_Set := (Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal => False);
+
+ Changed : Boolean := False;
+ Abort_Generate : Boolean := False;
+ Unused_Tokens : Boolean := False;
+ begin
+ Used_Tokens (Descriptor.Accept_ID) := True;
+
+ -- First mark all nonterminals that occur in used nonterminals as
+ -- used.
+ loop
+ for Prod of Grammar loop
+ if Used_Tokens (Prod.LHS) then
+ for RHS of Prod.RHSs loop
+ for J of RHS.Tokens loop
+ if J in Nonterminals then
+ Changed := Changed or else not Used_Tokens (J);
+ Used_Tokens (J) := True;
+ end if;
+ end loop;
+ end loop;
+ end if;
+ end loop;
+ exit when not Changed;
+ Changed := False;
+ end loop;
+
+ -- Now mark terminals used in used nonterminals
+ for Prod of Grammar loop
+ if Used_Tokens (Prod.LHS) then
+ for RHS of Prod.RHSs loop
+ for J of RHS.Tokens loop
+ if not (J in Used_Tokens'Range) then
+ WisiToken.Generate.Put_Error
+ ("non-grammar token " & Image (J, Descriptor) & " used
in grammar");
+
+ -- This causes lots of problems with token_id not in
terminal or
+ -- nonterminal range, so abort early.
+ Abort_Generate := True;
+ end if;
+
+ if J in Terminals then
+ Used_Tokens (J) := True;
+ end if;
+ end loop;
+ end loop;
+ end if;
+ end loop;
+
+ for I in Used_Tokens'Range loop
+ if not Used_Tokens (I) then
+ if not Unused_Tokens then
+ WisiToken.Generate.Put_Error ("Unused tokens:");
+ Unused_Tokens := True;
+ end if;
+ WisiToken.Generate.Put_Error (Image (I, Descriptor));
+ end if;
+ end loop;
+
+ if Abort_Generate then
+ raise Grammar_Error;
+ end if;
+
+ return Unused_Tokens;
+ end Check_Unused_Tokens;
+
+ function Has_Empty_Production (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Token_ID_Set
+ is
+ use all type Ada.Containers.Count_Type;
+
+ subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
+
+ Result : Token_ID_Set := (Nonterminal => False);
+ Changed : Boolean := True;
+ begin
+ loop
+ exit when not Changed;
+ Changed := False;
+
+ for Prod of Grammar loop
+ for RHS of Prod.RHSs loop
+ if (RHS.Tokens.Length = 0 or else
+ (RHS.Tokens (1) in Nonterminal and then Result
(RHS.Tokens (1)))) and
+ not Result (Prod.LHS)
+ then
+ Result (Prod.LHS) := True;
+ Changed := True;
+ end if;
+ end loop;
+ end loop;
+ end loop;
+ return Result;
+ end Has_Empty_Production;
+
+ function First
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal : in Token_ID;
+ Non_Terminal : in Token_ID)
+ return Token_ID_Set
+ is
+ Derivations : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
+ Added_Tokens : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
+ Search_Tokens : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
+
+ function Compute_Non_Terminals return Token_ID_Set
+ is
+ Result : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
+ begin
+ -- Can't use a simple aggregate for this; bounds are non-static.
+ Result (First_Terminal .. Grammar.First_Index - 1) := (others =>
False);
+ Result (Grammar.First_Index .. Grammar.Last_Index) := (others =>
True);
+ return Result;
+ end Compute_Non_Terminals;
+
+ Non_Terminals : constant Token_ID_Set := Compute_Non_Terminals;
+
+ begin
+ Search_Tokens (Non_Terminal) := True;
+
+ while Any (Search_Tokens) loop
+
+ Added_Tokens := (others => False);
+
+ for Prod of Grammar loop
+ if Search_Tokens (Prod.LHS) then
+ for RHS of Prod.RHSs loop
+ for Derived_Token of RHS.Tokens loop
+ if not Derivations (Derived_Token) then
+ Added_Tokens (Derived_Token) := True;
+ end if;
+
+ if Non_Terminals (Derived_Token) and then
Has_Empty_Production (Derived_Token) then
+ null;
+ else
+ exit;
+ end if;
+ end loop;
+ end loop;
+ end if;
+ end loop;
+
+ Derivations := Derivations or Added_Tokens;
+ Search_Tokens := Added_Tokens and Non_Terminals;
+ end loop;
+
+ return Derivations;
+ end First;
+
+ function First
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal : in Token_ID)
+ return Token_Array_Token_Set
+ is
+ Matrix : Token_Array_Token_Set :=
+ (Grammar.First_Index .. Grammar.Last_Index =>
+ (First_Terminal .. Grammar.Last_Index => False));
+
+ procedure Set_Slice (Matrix : in out Token_Array_Token_Set; I :
Token_ID; Value : in Token_ID_Set)
+ is begin
+ for J in Matrix'Range (2) loop
+ Matrix (I, J) := Value (J);
+ end loop;
+ end Set_Slice;
+
+ begin
+ for NT_Index in Matrix'Range loop
+ Set_Slice (Matrix, NT_Index, First (Grammar, Has_Empty_Production,
First_Terminal, NT_Index));
+ end loop;
+
+ return Matrix;
+ end First;
+
+ function To_Terminal_Sequence_Array
+ (First : in Token_Array_Token_Set;
+ Descriptor : in WisiToken.Descriptor)
+ return Token_Sequence_Arrays.Vector
+ is
+ subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+ begin
+ return Result : Token_Sequence_Arrays.Vector do
+ Result.Set_First (First'First (1));
+ Result.Set_Last (First'Last (1));
+
+ for I in First'Range (1) loop
+ declare
+ Row : Token_ID_Arrays.Vector renames Result (I);
+ begin
+ for J in First'Range (2) loop
+ if First (I, J) and then J in Terminal then
+ Row.Append (J);
+ end if;
+ end loop;
+ end;
+ end loop;
+ end return;
+ end To_Terminal_Sequence_Array;
+
+ function Follow
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ First : in Token_Array_Token_Set;
+ Has_Empty_Production : in Token_ID_Set)
+ return Token_Array_Token_Set
+ is
+ subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+ subtype Nonterminal is Token_ID range Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal;
+
+ Prev_Result : Token_Array_Token_Set := (Nonterminal => (Terminal =>
False));
+ Result : Token_Array_Token_Set := (Nonterminal => (Terminal =>
False));
+
+ ID : Token_ID;
+ begin
+ -- [dragon] pgp 189:
+ --
+ -- Rule 1 Follow (S, EOF) = True; EOF is explicit in the
+ -- start symbol production, so this is covered by Rule 2.
+ --
+ -- Rule 2: If A => alpha B Beta, add First (Beta) to Follow (B)
+ --
+ -- Rule 3; if A => alpha B, or A -> alpha B Beta and Beta
+ -- can be null, add Follow (A) to Follow (B)
+ --
+ -- We don't assume any order in the productions list, so we
+ -- have to keep applying rule 3 until nothing changes.
+
+ for B in Nonterminal loop
+ for Prod of Grammar loop
+ for A of Prod.RHSs loop
+ for I in A.Tokens.First_Index .. A.Tokens.Last_Index loop
+ if A.Tokens (I) = B then
+ if I < A.Tokens.Last_Index then
+ -- Rule 1
+ ID := A.Tokens (1 + I);
+ if ID in Terminal then
+ Result (B, ID) := True;
+ else
+ Or_Slice (Result, B, Slice (First, ID));
+ end if;
+ end if;
+ end if;
+ end loop;
+ end loop;
+ end loop;
+ end loop;
+
+ Prev_Result := Result;
+ loop
+ for B in Nonterminal loop
+ for Prod of Grammar loop
+ for A of Prod.RHSs loop
+ for I in A.Tokens.First_Index .. A.Tokens.Last_Index loop
+ if A.Tokens (I) = B then
+ if I = A.Tokens.Last_Index or else
+ (A.Tokens (1 + I) in Nonterminal and then
+ Has_Empty_Production (A.Tokens (1 + I)))
+ then
+ -- rule 3
+ Or_Slice (Result, B, Slice (Result, Prod.LHS));
+ end if;
+ end if;
+ end loop;
+ end loop;
+ end loop;
+ end loop;
+
+ exit when Prev_Result = Result;
+ Prev_Result := Result;
+ end loop;
+ return Result;
+ end Follow;
+
+ function To_Graph (Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
return Grammar_Graphs.Graph
+ is
+ use all type Ada.Containers.Count_Type;
+ subtype Nonterminals is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
+ Graph : Grammar_Graphs.Graph;
+ J : Integer := 1;
+ begin
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line ("grammar graph:");
+ end if;
+
+ for LHS in Grammar.First_Index .. Grammar.Last_Index loop
+ declare
+ Prod : WisiToken.Productions.Instance renames Grammar (LHS);
+ begin
+ for RHS in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
+ declare
+ Tokens : Token_ID_Arrays.Vector renames Prod.RHSs
(RHS).Tokens;
+ begin
+ for I in Tokens.First_Index .. Tokens.Last_Index loop
+ if Tokens (I) in Nonterminals then
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line
+ ("(" & Trimmed_Image (LHS) & ", " & Trimmed_Image
(Tokens (I)) & "," & J'Image & ")");
+ J := J + 1;
+ end if;
+ Graph.Add_Edge
+ (LHS, Tokens (I),
+ (RHS,
+ Recursive =>
+ (if Tokens.Length = 1 then Single
+ elsif I = Tokens.First_Index then Left
+ elsif I = Tokens.Last_Index then Right
+ else Middle)));
+ end if;
+ end loop;
+ end;
+ end loop;
+ end;
+ end loop;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line ("..." & Graph.Count_Nodes'Image & " nodes" &
Graph.Count_Edges'Image & " edges.");
+ end if;
+ return Graph;
+ end To_Graph;
+
+ function Compute_Full_Recursion (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Recursions
+ is
+ Graph : constant Grammar_Graphs.Graph := To_Graph (Grammar);
+ begin
+ return Result : Recursions :=
+ (Full => True,
+ Recursions => Graph.Find_Cycles)
+ do
+ Grammar_Graphs.Sort_Paths.Sort (Result.Recursions);
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line ("full recursions:");
+ for I in Result.Recursions.First_Index ..
Result.Recursions.Last_Index loop
+ Ada.Text_IO.Put_Line (Trimmed_Image (I) & " => " &
Grammar_Graphs.Image (Result.Recursions (I)));
+ end loop;
+ end if;
+ end return;
+ end Compute_Full_Recursion;
+
+ function Compute_Partial_Recursion (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Recursions
+ is
+ use Grammar_Graphs;
+ Graph : constant Grammar_Graphs.Graph := To_Graph (Grammar);
+ Components : constant Component_Lists.List :=
Strongly_Connected_Components
+ (To_Adjancency (Graph), Non_Trivial_Only => True);
+ Loops : constant Vertex_Lists.List := Graph.Loops;
+ begin
+ return Result : Recursions do
+ Result.Full := False;
+ for Comp of Components loop
+ declare
+ Path : Recursion_Cycle (1 .. Integer (Comp.Length));
+ Last : Integer := Path'First - 1;
+ begin
+ for V of Comp loop
+ Last := Last + 1;
+ Path (Last) := (V, Graph.Edges (V));
+ end loop;
+ Result.Recursions.Append (Path);
+ end;
+ end loop;
+
+ declare
+ Path : Recursion_Cycle (1 .. Integer (Loops.Length));
+ Last : Integer := Path'First - 1;
+ begin
+ for V of Loops loop
+ Last := Last + 1;
+ Path (Last) := (V, Graph.Edges (V));
+ end loop;
+ Result.Recursions.Append (Path);
+ end;
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line ("partial recursions:");
+ for I in Result.Recursions.First_Index ..
Result.Recursions.Last_Index loop
+ Ada.Text_IO.Put_Line (Trimmed_Image (I) & " => " &
Grammar_Graphs.Image (Result.Recursions (I)));
+ end loop;
+ end if;
+ end return;
+ end Compute_Partial_Recursion;
+
+ ----------
+ -- Indented text output
+
+ procedure Indent_Line (Text : in String)
+ is
+ use Ada.Text_IO;
+ begin
+ Set_Col (Indent);
+ Put_Line (Text);
+ Line_Count := Line_Count + 1;
+ end Indent_Line;
+
+ procedure Indent_Start (Text : in String)
+ is
+ use Ada.Text_IO;
+ begin
+ Set_Col (Indent);
+ Put (Text);
+ end Indent_Start;
+
+ procedure Indent_Wrap (Text : in String)
+ is
+ use all type Ada.Text_IO.Count;
+ use Ada.Strings;
+ use Ada.Strings.Fixed;
+ I : Natural;
+ First : Integer := Text'First;
+ begin
+ if Text'Length + Indent <= Max_Line_Length then
+ Indent_Line (Text);
+ else
+ loop
+ I := Text'Last;
+ loop
+ I := Index (Text (First .. Text'Last), " ", From => I, Going =>
Backward);
+ exit when I - First + Integer (Indent) <= Max_Line_Length;
+ I := I - 1;
+ end loop;
+ Indent_Line (Text (First .. I - 1));
+ First := I + 1;
+ exit when Text'Last - First + Integer (Indent) <= Max_Line_Length;
+ end loop;
+ Indent_Line (Text (First .. Text'Last));
+ end if;
+ end Indent_Wrap;
+
+ procedure Indent_Wrap_Comment (Text : in String; Comment_Syntax : in String)
+ is
+ use all type Ada.Text_IO.Count;
+ use Ada.Strings;
+ use Ada.Strings.Fixed;
+ Prefix : constant String := Comment_Syntax & " ";
+ I : Natural;
+ First : Integer := Text'First;
+ begin
+ if Text'Length + Indent <= Max_Line_Length - 4 then
+ Indent_Line (Prefix & Text);
+ else
+ loop
+ I := Text'Last;
+ loop
+ I := Index (Text (First .. Text'Last), " ", From => I, Going =>
Backward);
+ exit when I - First + Integer (Indent) <= Max_Line_Length - 4;
+ I := I - 1;
+ end loop;
+ Indent_Line (Prefix & Text (First .. I - 1));
+ First := I + 1;
+ exit when Text'Last - First + Integer (Indent) <= Max_Line_Length
- 4;
+ end loop;
+ Indent_Line (Prefix & Text (First .. Text'Last));
+ end if;
+ end Indent_Wrap_Comment;
+
+end WisiToken.Generate;
diff --git a/wisitoken-generate.ads b/wisitoken-generate.ads
index 01340eb..45d8c7c 100644
--- a/wisitoken-generate.ads
+++ b/wisitoken-generate.ads
@@ -1,121 +1,189 @@
--- Abstract :
---
--- Types and operations for generating parsers, common to all parser
--- types.
---
--- The wisi* packages deal with reading *.wy files and generating
--- source code files. The wisitoken-generate* packages deal with
--- computing parser properties from the grammar. (For historical
--- reasons, not all packages follow this naming convention yet).
---
--- References :
---
--- See wisitoken.ads
---
--- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Productions;
-package WisiToken.Generate is
-
- Error : Boolean := False;
- -- Set True by errors during grammar generation
-
- function Error_Message
- (File_Name : in String;
- File_Line : in WisiToken.Line_Number_Type;
- Message : in String)
- return String;
-
- procedure Put_Error (Message : in String);
- -- Set Error True, output Message to Standard_Error
-
- procedure Check_Consistent
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Source_File_Name : in String);
- -- Check requirements on Descriptor values.
-
- function Check_Unused_Tokens
- (Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
- return Boolean;
- -- Return False if there is a terminal or nonterminal that is not
- -- used in the grammar.
- --
- -- Raises Grammar_Error if there is a non-grammar token used in the
- -- grammar.
-
- function Has_Empty_Production (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Token_ID_Set;
- -- Result (ID) is True if any production for ID can be an empty
- -- production, recursively.
-
- function First
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal : in Token_ID)
- return Token_Array_Token_Set;
- -- For each nonterminal in Grammar, find the set of tokens
- -- (terminal or nonterminal) that any string derived from it can
- -- start with. Together with Has_Empty_Production, implements
- -- algorithm FIRST from [dragon], augmented with nonterminals.
- --
- -- LALR, LR1 generate want First as both Token_Sequence_Arrays.Vector
- -- and Token_Array_Token_Set, Packrat wants Token_Array_Token_Set,
- -- existing tests all use Token_Array_Token_Set. So for LR1 we use
- -- To_Terminal_Sequence_Array.
-
- function To_Terminal_Sequence_Array
- (First : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return Token_Sequence_Arrays.Vector;
- -- Only includes terminals.
-
- function Follow
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- First : in Token_Array_Token_Set;
- Has_Empty_Production : in Token_ID_Set)
- return Token_Array_Token_Set;
- -- For each nonterminal in Grammar, find the set of terminal
- -- tokens that can follow it. Implements algorithm FOLLOW from
- -- [dragon] pg 189.
-
- ----------
- -- Indented text output. Mostly used for code generation in wisi,
- -- also used in outputing the parse_table and other debug stuff.
-
- Max_Line_Length : constant := 120;
-
- Indent : Standard.Ada.Text_IO.Positive_Count := 1;
- Line_Count : Integer;
-
- procedure Indent_Line (Text : in String);
- -- Put Text, indented to Indent, to Current_Output, with newline.
-
- procedure Indent_Start (Text : in String);
- -- Put Text indented to Indent to Current_Output, without newline.
- -- Should be followed by Put_Line, not Indent_Line.
-
- procedure Indent_Wrap (Text : in String);
- -- Put Text, indented to Indent, wrapped at Max_Line_Length, to
- -- Current_Output, ending with newline.
-
- procedure Indent_Wrap_Comment (Text : in String; Comment_Syntax : in
String);
- -- Put Text, prefixed by Comment_Syntax and two spaces, indented to
- -- Indent, wrapped at Max_Line_Length, to Current_Output, ending with
- -- newline.
-
-end WisiToken.Generate;
+-- Abstract :
+--
+-- Types and operations for generating parsers, common to all parser
+-- types.
+--
+-- The wisi* packages deal with reading *.wy files and generating
+-- source code files. The wisitoken-generate* packages deal with
+-- computing parser properties from the grammar. (For historical
+-- reasons, not all packages follow this naming convention yet).
+--
+-- References :
+--
+-- See wisitoken.ads
+--
+-- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers.Doubly_Linked_Lists;
+with SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image;
+with SAL.Gen_Graphs;
+with WisiToken.Productions;
+package WisiToken.Generate is
+
+ Error : Boolean := False;
+ -- Set True by errors during grammar generation
+
+ function Error_Message
+ (File_Name : in String;
+ File_Line : in WisiToken.Line_Number_Type;
+ Message : in String)
+ return String;
+
+ procedure Put_Error (Message : in String);
+ -- Set Error True, output Message to Standard_Error
+
+ procedure Check_Consistent
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Source_File_Name : in String);
+ -- Check requirements on Descriptor values.
+
+ function Check_Unused_Tokens
+ (Descriptor : in WisiToken.Descriptor;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
+ return Boolean;
+ -- Return False if there is a terminal or nonterminal that is not
+ -- used in the grammar.
+ --
+ -- Raises Grammar_Error if there is a non-grammar token used in the
+ -- grammar.
+
+ function Has_Empty_Production (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Token_ID_Set;
+ -- Result (ID) is True if any production for ID can be an empty
+ -- production, recursively.
+
+ function First
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal : in Token_ID)
+ return Token_Array_Token_Set;
+ -- For each nonterminal in Grammar, find the set of tokens
+ -- (terminal or nonterminal) that any string derived from it can
+ -- start with. Together with Has_Empty_Production, implements
+ -- algorithm FIRST from [dragon], augmented with nonterminals.
+ --
+ -- LALR, LR1 generate want First as both Token_Sequence_Arrays.Vector
+ -- and Token_Array_Token_Set, Packrat wants Token_Array_Token_Set,
+ -- existing tests all use Token_Array_Token_Set. So for LR1 we use
+ -- To_Terminal_Sequence_Array.
+
+ function To_Terminal_Sequence_Array
+ (First : in Token_Array_Token_Set;
+ Descriptor : in WisiToken.Descriptor)
+ return Token_Sequence_Arrays.Vector;
+ -- Only includes terminals.
+
+ function Follow
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ First : in Token_Array_Token_Set;
+ Has_Empty_Production : in Token_ID_Set)
+ return Token_Array_Token_Set;
+ -- For each nonterminal in Grammar, find the set of terminal
+ -- tokens that can follow it. Implements algorithm FOLLOW from
+ -- [dragon] pg 189.
+
+ ----------
+ -- Recursion
+
+ -- Recursion is the result of a cycle in the grammar. We can form a
+ -- graph representing the grammar by taking the nonterminals as the
+ -- graph vertices, and the occurence of a nonterminal in a production
+ -- right hand side as a directed edge connecting two nonterminals
+ -- (the other is the left hand side of that production. Then
+ -- recursion is represented by a cycle in the graph.
+
+ type Recursion_Item is record
+ RHS : Natural := 0;
+ -- The edge leading to this node. We don't need the actual token
+ -- number.
+
+ Recursive : Recursion := None;
+ -- Position of the token in the RHS.
+ end record;
+
+ function Edge_Image (Edge : in Recursion_Item) return String is
+ (Trimmed_Image (Edge.RHS) & " " & Recursion'Image (Edge.Recursive));
+
+ type Base_Recursion_Index is range 0 .. Integer'Last;
+ subtype Recursion_Index is Base_Recursion_Index range 1 ..
Base_Recursion_Index'Last;
+ Invalid_Recursion_Index : constant Base_Recursion_Index := 0;
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image (Base_Recursion_Index);
+
+ package Grammar_Graphs is new SAL.Gen_Graphs
+ (Edge_Data => Recursion_Item,
+ Default_Edge_Data => (others => <>),
+ Vertex_Index => Token_ID,
+ Invalid_Vertex => Invalid_Token_ID,
+ Path_Index => Recursion_Index,
+ Edge_Image => Edge_Image);
+
+ subtype Recursion_Cycle is Grammar_Graphs.Path;
+ -- A recursion, with lowest numbered production first. If there is
+ -- only one element, the recursion is direct; otherwise indirect.
+
+ subtype Recursion_Array is Grammar_Graphs.Path_Arrays.Vector;
+ -- For the collection of all cycles.
+
+ type Recursions is record
+ Full : Boolean;
+ Recursions : Recursion_Array;
+ -- If Full, elements are paths; edges at path (I) are to path (I). If
+ -- not Full, elements are strongly connected components; edges at
+ -- path (I) are from path (I).
+ end record;
+
+ package Recursion_Lists is new Ada.Containers.Doubly_Linked_Lists
(Recursion_Index);
+ function Image is new SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
+ (Recursion_Index, "=", Recursion_Lists, Trimmed_Image);
+
+ function To_Graph (Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
return Grammar_Graphs.Graph;
+
+ function Compute_Full_Recursion (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Recursions;
+ -- Each element of result is a cycle in the grammar.
+
+ function Compute_Partial_Recursion (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Recursions;
+ -- Each element of the result contains all members of a non-trivial
+ -- strongly connected component in the grammar, in arbitrary order.
+ -- This is an approximation to the full recursion, when that is too
+ -- hard to compute (ie for Java).
+
+ ----------
+ -- Indented text output. Mostly used for code generation in wisi,
+ -- also used in outputing the parse_table and other debug stuff.
+
+ Max_Line_Length : constant := 120;
+
+ Indent : Standard.Ada.Text_IO.Positive_Count := 1;
+ Line_Count : Integer;
+
+ procedure Indent_Line (Text : in String);
+ -- Put Text, indented to Indent, to Current_Output, with newline.
+
+ procedure Indent_Start (Text : in String);
+ -- Put Text indented to Indent to Current_Output, without newline.
+ -- Should be followed by Put_Line, not Indent_Line.
+
+ procedure Indent_Wrap (Text : in String);
+ -- Put Text, indented to Indent, wrapped at Max_Line_Length, to
+ -- Current_Output, ending with newline.
+
+ procedure Indent_Wrap_Comment (Text : in String; Comment_Syntax : in
String);
+ -- Put Text, prefixed by Comment_Syntax and two spaces, indented to
+ -- Indent, wrapped at Max_Line_Length, to Current_Output, ending with
+ -- newline.
+
+end WisiToken.Generate;
diff --git a/wisitoken-lexer-re2c.adb b/wisitoken-lexer-re2c.adb
index 10bbd16..d66088d 100644
--- a/wisitoken-lexer-re2c.adb
+++ b/wisitoken-lexer-re2c.adb
@@ -81,7 +81,7 @@ package body WisiToken.Lexer.re2c is
overriding procedure Reset_With_String_Access
(Lexer : in out Instance;
- Input : access String;
+ Input : in Ada.Strings.Unbounded.String_Access;
File_Name : in Ada.Strings.Unbounded.Unbounded_String;
Begin_Char : in Buffer_Pos := Buffer_Pos'First;
Begin_Line : in Line_Number_Type := Line_Number_Type'First)
diff --git a/wisitoken-lexer-re2c.ads b/wisitoken-lexer-re2c.ads
index b58c4ea..b871e9c 100644
--- a/wisitoken-lexer-re2c.ads
+++ b/wisitoken-lexer-re2c.ads
@@ -92,7 +92,7 @@ package WisiToken.Lexer.re2c is
overriding procedure Reset_With_String_Access
(Lexer : in out Instance;
- Input : access String;
+ Input : in Ada.Strings.Unbounded.String_Access;
File_Name : in Ada.Strings.Unbounded.Unbounded_String;
Begin_Char : in Buffer_Pos := Buffer_Pos'First;
Begin_Line : in Line_Number_Type := Line_Number_Type'First);
diff --git a/wisitoken-lexer-regexp.adb b/wisitoken-lexer-regexp.adb
index 1790b74..3e5a421 100644
--- a/wisitoken-lexer-regexp.adb
+++ b/wisitoken-lexer-regexp.adb
@@ -178,9 +178,9 @@ package body WisiToken.Lexer.Regexp is
end Reset_With_String;
overriding procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : access String;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String;
+ (Lexer : in out Instance;
+ Input : in Ada.Strings.Unbounded.String_Access;
+ File_Name : in Ada.Strings.Unbounded.Unbounded_String;
Begin_Char : in Buffer_Pos := Buffer_Pos'First;
Begin_Line : in Line_Number_Type := Line_Number_Type'First)
is begin
diff --git a/wisitoken-lexer-regexp.ads b/wisitoken-lexer-regexp.ads
index 3a3d5f4..da55448 100644
--- a/wisitoken-lexer-regexp.ads
+++ b/wisitoken-lexer-regexp.ads
@@ -67,7 +67,7 @@ package WisiToken.Lexer.Regexp is
Begin_Line : in Line_Number_Type := Line_Number_Type'First);
overriding procedure Reset_With_String_Access
(Lexer : in out Instance;
- Input : access String;
+ Input : in Ada.Strings.Unbounded.String_Access;
File_Name : in Ada.Strings.Unbounded.Unbounded_String;
Begin_Char : in Buffer_Pos := Buffer_Pos'First;
Begin_Line : in Line_Number_Type := Line_Number_Type'First);
diff --git a/wisitoken-lexer.ads b/wisitoken-lexer.ads
index 7be10ed..3de31c7 100644
--- a/wisitoken-lexer.ads
+++ b/wisitoken-lexer.ads
@@ -70,7 +70,7 @@ package WisiToken.Lexer is
procedure Reset_With_String_Access
(Lexer : in out Instance;
- Input : access String;
+ Input : in Ada.Strings.Unbounded.String_Access;
File_Name : in Ada.Strings.Unbounded.Unbounded_String;
Begin_Char : in Buffer_Pos := Buffer_Pos'First;
Begin_Line : in Line_Number_Type := Line_Number_Type'First)
@@ -154,7 +154,7 @@ private
case Label is
when String_Label =>
- Buffer : access String;
+ Buffer : Ada.Strings.Unbounded.String_Access;
User_Buffer : Boolean := False;
-- If User_Buffer is True, user provided buffer and will deallocate
-- it. Otherwise we must deallocate it.
diff --git a/wisitoken-parse-lr-mckenzie_recover-base.adb
b/wisitoken-parse-lr-mckenzie_recover-base.adb
index 17301b2..ae60955 100644
--- a/wisitoken-parse-lr-mckenzie_recover-base.adb
+++ b/wisitoken-parse-lr-mckenzie_recover-base.adb
@@ -1,433 +1,442 @@
--- Abstract :
---
--- Base utilities for McKenzie_Recover
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Task_Identification;
-with GNAT.Traceback.Symbolic;
-package body WisiToken.Parse.LR.McKenzie_Recover.Base is
-
- function Get_Barrier
- (Parsers : not null access Parser_Lists.List;
- Parser_Status : in Parser_Status_Array;
- Cost_Limit : in Natural;
- Min_Success_Check_Count : in Natural;
- Check_Delta_Limit : in Natural;
- Enqueue_Limit : in Natural)
- return Boolean
- is
- use all type SAL.Base_Peek_Type;
- Done_Count : SAL.Base_Peek_Type := 0;
- begin
- -- Return True if all parsers are done, or if any parser has a config
- -- available to check.
- for P_Status of Parser_Status loop
- case P_Status.Recover_State is
- when Active =>
- if P_Status.Parser_State.Recover.Check_Count - Check_Delta_Limit
>= Min_Success_Check_Count then
- -- fail; another parser succeeded, this one taking too long.
- Done_Count := Done_Count + 1;
-
- elsif P_Status.Parser_State.Recover.Enqueue_Count >= Enqueue_Limit
then
- -- fail
- Done_Count := Done_Count + 1;
-
- elsif P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
- if P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
Cost_Limit then
- return True;
- else
- if P_Status.Active_Workers = 0 then
- -- fail; remaining configs exceed cost limit
- Done_Count := Done_Count + 1;
- end if;
- end if;
-
- else
- if P_Status.Active_Workers = 0 then
- -- fail; no configs left to check (rarely happens with real
- -- languages).
- Done_Count := Done_Count + 1;
- end if;
- end if;
-
- when Ready =>
- -- We don't check Enqueue_Limit here; there will only be a few
more
- -- to find all the same-cost solutions.
-
- if P_Status.Parser_State.Recover.Config_Heap.Count > 0 and then
- P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
P_Status.Parser_State.Recover.Results.Min_Key
- then
- -- Still more to check.
- return True;
-
- elsif P_Status.Active_Workers = 0 then
- Done_Count := Done_Count + 1;
- end if;
-
- when Success | Fail =>
- Done_Count := Done_Count + 1;
- end case;
- end loop;
-
- return Done_Count = Parsers.Count;
- end Get_Barrier;
-
- protected body Supervisor is
-
- procedure Initialize
- (Parsers : not null access Parser_Lists.List;
- Terminals : not null access constant Base_Token_Arrays.Vector)
- is
- use all type SAL.Base_Peek_Type;
- Index : SAL.Peek_Type := 1;
- begin
- Supervisor.Parsers := Parsers;
- Supervisor.Terminals := Terminals;
- All_Parsers_Done := False;
- Success_Counter := 0;
- Min_Success_Check_Count := Natural'Last;
- Fatal_Called := False;
- Result := Recover_Status'First;
- Error_ID := Ada.Exceptions.Null_Id;
-
- for I in Parsers.Iterate loop
- if Parsers.Reference (I).Recover_Insert_Delete.Length > 0 then
- -- Previous error recovery resume not finished; this is
supposed to
- -- be checked in Parser.
- raise SAL.Programmer_Error;
- end if;
-
- Parser_Status (Index) :=
- (Recover_State => Active,
- Parser_State => Parser_Lists.Persistent_State_Ref (I),
- Fail_Mode => Success,
- Active_Workers => 0);
-
- declare
- Data : McKenzie_Data renames Parsers.Reference (I).Recover;
- begin
- Data.Config_Heap.Clear;
- Data.Results.Clear;
- Data.Enqueue_Count := 0;
- Data.Check_Count := 0;
- Data.Success := False;
- end;
-
- Index := Index + 1;
- end loop;
- end Initialize;
-
- entry Get
- (Parser_Index : out SAL.Base_Peek_Type;
- Config : out Configuration;
- Status : out Config_Status)
- when (Fatal_Called or All_Parsers_Done) or else
- Get_Barrier (Parsers, Parser_Status, Cost_Limit,
Min_Success_Check_Count, Check_Delta_Limit, Enqueue_Limit)
- is
- use all type SAL.Base_Peek_Type;
- Done_Count : SAL.Base_Peek_Type := 0;
- Min_Cost : Integer := Integer'Last;
- Min_Cost_Index : SAL.Base_Peek_Type;
-
- procedure Set_Outputs (I : in SAL.Peek_Type)
- is begin
- Parser_Index := I;
- Config := Parser_Status
(I).Parser_State.Recover.Config_Heap.Remove;
- Status := Valid;
-
- Parser_Status (I).Parser_State.Recover.Check_Count :=
- Parser_Status (I).Parser_State.Recover.Check_Count + 1;
-
- Parser_Status (I).Active_Workers := Parser_Status
(I).Active_Workers + 1;
- end Set_Outputs;
-
- procedure Set_All_Done
- is begin
- Parser_Index := SAL.Base_Peek_Type'First;
- Config := (others => <>);
- Status := All_Done;
- end Set_All_Done;
-
- begin
- if Fatal_Called or All_Parsers_Done then
- Set_All_Done;
- return;
- end if;
-
- -- Same logic as in Get_Barrier, but different actions.
- for I in Parser_Status'Range loop
- declare
- P_Status : Base.Parser_Status renames Parser_Status (I);
- begin
- case P_Status.Recover_State is
- when Active =>
- if P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
- if P_Status.Parser_State.Recover.Check_Count -
Check_Delta_Limit >= Min_Success_Check_Count then
- if Trace_McKenzie > Outline then
- Put_Line (Trace.all, P_Status.Parser_State.Label,
"fail; check delta (limit" &
- Integer'Image (Min_Success_Check_Count
+ Check_Delta_Limit) & ")");
- end if;
- P_Status.Recover_State := Fail;
- P_Status.Fail_Mode := Fail_Check_Delta;
-
- Done_Count := Done_Count + 1;
-
- elsif P_Status.Parser_State.Recover.Enqueue_Count >=
Enqueue_Limit then
- if Trace_McKenzie > Outline then
- Put_Line (Trace.all, P_Status.Parser_State.Label,
"fail; enqueue limit (" &
- Integer'Image (Enqueue_Limit) & ")");
- end if;
- P_Status.Recover_State := Fail;
- P_Status.Fail_Mode := Fail_Enqueue_Limit;
-
- Done_Count := Done_Count + 1;
-
- elsif P_Status.Parser_State.Recover.Config_Heap.Min_Key
<= Cost_Limit then
- if P_Status.Parser_State.Recover.Config_Heap.Min_Key <
Min_Cost then
- Min_Cost :=
P_Status.Parser_State.Recover.Config_Heap.Min_Key;
- Min_Cost_Index := I;
- end if;
-
- else
- if P_Status.Active_Workers = 0 then
- if Trace_McKenzie > Outline then
- Put_Line (Trace.all,
P_Status.Parser_State.Label, "fail; cost");
- end if;
- P_Status.Recover_State := Fail;
- P_Status.Fail_Mode := Fail_Cost;
-
- Done_Count := Done_Count + 1;
- end if;
- end if;
- else
- if P_Status.Active_Workers = 0 then
- -- No configs left to check (rarely happens with real
languages).
- if Trace_McKenzie > Outline then
- Put_Line (Trace.all, P_Status.Parser_State.Label,
"fail; no configs left");
- end if;
- P_Status.Recover_State := Fail;
- P_Status.Fail_Mode := Fail_No_Configs_Left;
-
- Done_Count := Done_Count + 1;
- end if;
- end if;
-
- when Ready =>
- if P_Status.Parser_State.Recover.Enqueue_Count >=
Enqueue_Limit then
- if Trace_McKenzie > Outline then
- Put_Line (Trace.all, P_Status.Parser_State.Label,
"fail; enqueue limit (" &
- Integer'Image (Enqueue_Limit) & ")");
- end if;
- P_Status.Recover_State := Fail;
- P_Status.Fail_Mode := Fail_Enqueue_Limit;
-
- Done_Count := Done_Count + 1;
-
- elsif P_Status.Parser_State.Recover.Config_Heap.Count > 0
and then
- P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
P_Status.Parser_State.Recover.Results.Min_Key
- then
- -- Still more to check.
- Set_Outputs (I);
- return;
-
- elsif P_Status.Active_Workers = 0 then
- P_Status.Recover_State := Success;
- Done_Count := Done_Count + 1;
- end if;
-
- when Success | Fail =>
- Done_Count := Done_Count + 1;
- end case;
- end;
- end loop;
-
- if Min_Cost /= Integer'Last then
- Set_Outputs (Min_Cost_Index);
-
- elsif Done_Count = Parsers.Count then
- if Trace_McKenzie > Extra then
- Trace.Put_Line ("Supervisor: done, " & (if Success_Counter > 0
then "succeed" else "fail"));
- end if;
-
- Set_All_Done;
- All_Parsers_Done := True;
- else
- raise SAL.Programmer_Error with "Get_Barrier and Get logic do not
match";
- end if;
- end Get;
-
- procedure Success
- (Parser_Index : in SAL.Peek_Type;
- Config : in Configuration;
- Configs : in out Config_Heaps.Heap_Type)
- is
- use all type SAL.Base_Peek_Type;
- Data : McKenzie_Data renames Parser_Status
(Parser_Index).Parser_State.Recover;
- begin
- Put (Parser_Index, Configs); -- Decrements Active_Worker_Count.
-
- if Trace_McKenzie > Detail then
- Put
- ("succeed: enqueue" & Integer'Image (Data.Enqueue_Count) & ",
check " & Integer'Image (Data.Check_Count),
- Trace.all, Parser_Status (Parser_Index).Parser_State.Label,
Terminals.all, Config);
- end if;
-
- if Force_Full_Explore then
- return;
- end if;
-
- Success_Counter := Success_Counter + 1;
- Result := Success;
-
- Data.Success := True;
-
- if Data.Check_Count < Min_Success_Check_Count then
- Min_Success_Check_Count := Data.Check_Count;
- end if;
-
- if Force_High_Cost_Solutions then
- Data.Results.Add (Config);
- if Data.Results.Count > 3 then
- Parser_Status (Parser_Index).Recover_State := Ready;
- end if;
- else
- if Data.Results.Count = 0 then
- Data.Results.Add (Config);
-
- Parser_Status (Parser_Index).Recover_State := Ready;
-
- elsif Config.Cost < Data.Results.Min_Key then
- -- delete higher cost configs from Results
- loop
- Data.Results.Drop;
- exit when Data.Results.Count = 0 or else
- Config.Cost >= Data.Results.Min_Key;
- end loop;
-
- Data.Results.Add (Config);
-
- elsif Config.Cost = Data.Results.Min_Key then
- Data.Results.Add (Config);
-
- else
- -- Config.Cost > Results.Min_Key
- null;
- end if;
- end if;
- end Success;
-
- procedure Put (Parser_Index : in SAL.Peek_Type; Configs : in out
Config_Heaps.Heap_Type)
- is
- use all type SAL.Base_Peek_Type;
- Configs_Count : constant SAL.Base_Peek_Type := Configs.Count; --
Before it is emptied, for Trace.
-
- P_Status : Base.Parser_Status renames Parser_Status (Parser_Index);
- Data : McKenzie_Data renames P_Status.Parser_State.Recover;
- begin
- P_Status.Active_Workers := P_Status.Active_Workers - 1;
-
- loop
- exit when Configs.Count = 0;
-
- -- [1] has a check for duplicate configs here; that only happens
with
- -- higher costs, which take too long for our application.
- Data.Config_Heap.Add (Configs.Remove);
- Data.Enqueue_Count := Data.Enqueue_Count + 1;
- end loop;
-
- if Trace_McKenzie > Detail then
- Put_Line
- (Trace.all, P_Status.Parser_State.Label,
- "enqueue:" & SAL.Base_Peek_Type'Image (Configs_Count) &
- "/" & SAL.Base_Peek_Type'Image (Data.Config_Heap.Count) &
- "/" & Trimmed_Image (Data.Enqueue_Count) &
- "/" & Trimmed_Image (Data.Check_Count) &
- ", min cost:" &
- (if Data.Config_Heap.Count > 0
- then Integer'Image (Data.Config_Heap.Min_Key)
- else " ? ") &
- ", active workers:" & Integer'Image
(P_Status.Active_Workers));
- end if;
- end Put;
-
- function Recover_Result return Recover_Status
- is
- Temp : Recover_Status := Result;
- begin
- if Result = Success then
- return Success;
- else
- for S of Parser_Status loop
- Temp := Recover_Status'Max (Result, S.Fail_Mode);
- end loop;
- return Temp;
- end if;
- end Recover_Result;
-
- procedure Fatal (E : in Ada.Exceptions.Exception_Occurrence)
- is
- use Ada.Exceptions;
- Task_ID : constant String := Ada.Task_Identification.Image
(Ada.Task_Identification.Current_Task);
- begin
- if Trace_McKenzie > Outline then
- Trace.Put_Line (Task_ID & " Supervisor: Error");
- end if;
- Fatal_Called := True;
- Error_ID := Exception_Identity (E);
- Error_Message := +Exception_Message (E);
- if Debug_Mode then
- Trace.Put_Line (Exception_Name (E) & ": " & Exception_Message (E));
- Trace.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
- end if;
- end Fatal;
-
- entry Done (Error_ID : out Ada.Exceptions.Exception_Id; Message : out
Ada.Strings.Unbounded.Unbounded_String)
- when All_Parsers_Done or Fatal_Called
- is begin
- Error_ID := Supervisor.Error_ID;
- Message := Error_Message;
- if Trace_McKenzie > Detail then
- Trace.New_Line;
- Trace.Put_Line ("Supervisor: Done");
- end if;
- end Done;
-
- function Parser_State (Parser_Index : in SAL.Peek_Type) return
Parser_Lists.Constant_Reference_Type
- is begin
- return (Element => Parser_Status (Parser_Index).Parser_State);
- end Parser_State;
-
- function Label (Parser_Index : in SAL.Peek_Type) return Natural
- is begin
- return Parser_Status (Parser_Index).Parser_State.Label;
- end Label;
-
- end Supervisor;
-
- procedure Put
- (Message : in String;
- Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Config : in Configuration;
- Task_ID : in Boolean := True)
- is begin
- Put (Message, Super.Trace.all, Super.Parser_State (Parser_Index).Label,
- Shared.Terminals.all, Config, Task_ID);
- end Put;
-
-end WisiToken.Parse.LR.McKenzie_Recover.Base;
+-- Abstract :
+--
+-- Base utilities for McKenzie_Recover
+--
+-- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with GNAT.Traceback.Symbolic;
+package body WisiToken.Parse.LR.McKenzie_Recover.Base is
+
+ function Get_Barrier
+ (Parsers : not null access Parser_Lists.List;
+ Parser_Status : in Parser_Status_Array;
+ Min_Success_Check_Count : in Natural;
+ Check_Delta_Limit : in Natural;
+ Enqueue_Limit : in Natural)
+ return Boolean
+ is
+ use all type SAL.Base_Peek_Type;
+ Done_Count : SAL.Base_Peek_Type := 0;
+ begin
+ -- Return True if all parsers are done, or if any parser has a config
+ -- available to check.
+ for P_Status of Parser_Status loop
+ case P_Status.Recover_State is
+ when Active | Ready =>
+ if P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
+ if P_Status.Parser_State.Recover.Check_Count -
Check_Delta_Limit >= Min_Success_Check_Count then
+ -- fail; another parser succeeded, this one taking too long.
+ Done_Count := Done_Count + 1;
+
+ elsif P_Status.Parser_State.Recover.Enqueue_Count +
+ P_Status.Parser_State.Recover.Config_Full_Count >=
Enqueue_Limit
+ then
+ -- fail
+ Done_Count := Done_Count + 1;
+ end if;
+ end if;
+
+ case P_Status.Recover_State is
+ when Active =>
+ if P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
+ -- Still working
+ return True;
+ else
+ if P_Status.Active_Workers = 0 then
+ -- fail; no configs left to check.
+ Done_Count := Done_Count + 1;
+ end if;
+ end if;
+
+ when Ready =>
+ if P_Status.Parser_State.Recover.Config_Heap.Count > 0 and then
+ P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
P_Status.Parser_State.Recover.Results.Min_Key
+ then
+ -- Still more to check.
+ return True;
+
+ elsif P_Status.Active_Workers = 0 then
+ Done_Count := Done_Count + 1;
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ when Success | Fail =>
+ Done_Count := Done_Count + 1;
+ end case;
+ end loop;
+
+ return Done_Count = Parsers.Count;
+ end Get_Barrier;
+
+ protected body Supervisor is
+
+ procedure Initialize
+ (Parsers : not null access Parser_Lists.List;
+ Terminals : not null access constant Base_Token_Arrays.Vector)
+ is
+ use all type SAL.Base_Peek_Type;
+ Index : SAL.Peek_Type := 1;
+ begin
+ Supervisor.Parsers := Parsers;
+ Supervisor.Terminals := Terminals;
+ All_Parsers_Done := False;
+ Success_Counter := 0;
+ Min_Success_Check_Count := Natural'Last;
+ Fatal_Called := False;
+ Result := Recover_Status'First;
+ Error_ID := Ada.Exceptions.Null_Id;
+
+ for I in Parsers.Iterate loop
+ if Parsers.Reference (I).Recover_Insert_Delete.Length > 0 then
+ -- Previous error recovery resume not finished; this is
supposed to
+ -- be checked in Parser.
+ raise SAL.Programmer_Error;
+ end if;
+
+ Parser_Status (Index) :=
+ (Recover_State => Active,
+ Parser_State => Parser_Lists.Persistent_State_Ref (I),
+ Fail_Mode => Success,
+ Active_Workers => 0);
+
+ declare
+ Data : McKenzie_Data renames Parsers.Reference (I).Recover;
+ begin
+ Data.Config_Heap.Clear;
+ Data.Results.Clear;
+ Data.Enqueue_Count := 0;
+ Data.Check_Count := 0;
+ Data.Success := False;
+ end;
+
+ Index := Index + 1;
+ end loop;
+ end Initialize;
+
+ entry Get
+ (Parser_Index : out SAL.Base_Peek_Type;
+ Config : out Configuration;
+ Status : out Config_Status)
+ when (Fatal_Called or All_Parsers_Done) or else
+ Get_Barrier (Parsers, Parser_Status, Min_Success_Check_Count,
Check_Delta_Limit, Enqueue_Limit)
+ is
+ use all type SAL.Base_Peek_Type;
+ Done_Count : SAL.Base_Peek_Type := 0;
+ Min_Cost : Integer := Integer'Last;
+ Min_Cost_Index : SAL.Base_Peek_Type;
+
+ procedure Set_Outputs (I : in SAL.Peek_Type)
+ is begin
+ Parser_Index := I;
+ Config := Parser_Status
(I).Parser_State.Recover.Config_Heap.Remove;
+ Status := Valid;
+
+ Parser_Status (I).Parser_State.Recover.Check_Count :=
+ Parser_Status (I).Parser_State.Recover.Check_Count + 1;
+
+ Parser_Status (I).Active_Workers := Parser_Status
(I).Active_Workers + 1;
+ end Set_Outputs;
+
+ procedure Set_All_Done
+ is begin
+ Parser_Index := SAL.Base_Peek_Type'First;
+ Config := (others => <>);
+ Status := All_Done;
+ end Set_All_Done;
+
+ begin
+ if Fatal_Called or All_Parsers_Done then
+ Set_All_Done;
+ return;
+ end if;
+
+ -- Same logic as in Get_Barrier, but different actions.
+ --
+ -- No task_id in outline trace messages, because they may appear in
+ -- .parse_good
+ for I in Parser_Status'Range loop
+ declare
+ P_Status : Base.Parser_Status renames Parser_Status (I);
+ begin
+ case P_Status.Recover_State is
+ when Active | Ready =>
+ if P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
+ if P_Status.Parser_State.Recover.Check_Count -
Check_Delta_Limit >= Min_Success_Check_Count then
+ if Trace_McKenzie > Outline then
+ Put_Line
+ (Trace.all,
+ P_Status.Parser_State.Label, "fail; check delta
(limit" &
+ Integer'Image (Min_Success_Check_Count +
Check_Delta_Limit) & ")",
+ Task_ID => False);
+ end if;
+ P_Status.Recover_State := Fail;
+ P_Status.Fail_Mode := Fail_Check_Delta;
+
+ Done_Count := Done_Count + 1;
+
+ elsif P_Status.Parser_State.Recover.Enqueue_Count +
+ P_Status.Parser_State.Recover.Config_Full_Count >=
Enqueue_Limit
+ then
+ if Trace_McKenzie > Outline then
+ Put_Line
+ (Trace.all,
+ P_Status.Parser_State.Label, "fail; enqueue
limit (" &
+ Enqueue_Limit'Image & " cost" &
+
P_Status.Parser_State.Recover.Config_Heap.Min_Key'Image & ")",
+ Task_ID => False);
+ end if;
+ P_Status.Recover_State := Fail;
+ P_Status.Fail_Mode := Fail_Enqueue_Limit;
+
+ Done_Count := Done_Count + 1;
+ end if;
+ end if;
+
+ case P_Status.Recover_State is
+ when Active =>
+ if P_Status.Parser_State.Recover.Config_Heap.Count > 0
then
+ if P_Status.Parser_State.Recover.Config_Heap.Min_Key <
Min_Cost then
+ Min_Cost :=
P_Status.Parser_State.Recover.Config_Heap.Min_Key;
+ Min_Cost_Index := I;
+ -- not done
+ end if;
+ else
+ if P_Status.Active_Workers = 0 then
+ -- No configs left to check (rarely happens with
real languages).
+ if Trace_McKenzie > Outline then
+ Put_Line
+ (Trace.all, P_Status.Parser_State.Label,
"fail; no configs left", Task_ID => False);
+ end if;
+ P_Status.Recover_State := Fail;
+ P_Status.Fail_Mode := Fail_No_Configs_Left;
+
+ Done_Count := Done_Count + 1;
+ end if;
+ end if;
+
+ when Ready =>
+ if P_Status.Parser_State.Recover.Config_Heap.Count > 0
and then
+ P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
+ P_Status.Parser_State.Recover.Results.Min_Key
+ then
+ -- Still more to check. We don't check Min_Cost here
so this parser
+ -- can finish quickly.
+ Set_Outputs (I);
+ return;
+
+ elsif P_Status.Active_Workers = 0 then
+ P_Status.Recover_State := Success;
+ Done_Count := Done_Count + 1;
+ end if;
+ when others =>
+ null;
+ end case;
+
+ when Success | Fail =>
+ Done_Count := Done_Count + 1;
+ end case;
+ end;
+ end loop;
+
+ if Min_Cost /= Integer'Last then
+ Set_Outputs (Min_Cost_Index);
+
+ elsif Done_Count = Parsers.Count then
+ if Trace_McKenzie > Extra then
+ Trace.Put_Line ("Supervisor: done, " & (if Success_Counter > 0
then "succeed" else "fail"));
+ end if;
+
+ Set_All_Done;
+ All_Parsers_Done := True;
+ else
+ raise SAL.Programmer_Error with "Get_Barrier and Get logic do not
match";
+ end if;
+ end Get;
+
+ procedure Success
+ (Parser_Index : in SAL.Peek_Type;
+ Config : in Configuration;
+ Configs : in out Config_Heaps.Heap_Type)
+ is
+ use all type SAL.Base_Peek_Type;
+ Data : McKenzie_Data renames Parser_Status
(Parser_Index).Parser_State.Recover;
+ begin
+ Put (Parser_Index, Configs); -- Decrements Active_Worker_Count.
+
+ if Trace_McKenzie > Detail then
+ Put
+ ("succeed: enqueue" & Integer'Image (Data.Enqueue_Count) & ",
check " & Integer'Image (Data.Check_Count),
+ Trace.all, Parser_Status (Parser_Index).Parser_State.Label,
Terminals.all, Config);
+ end if;
+
+ if Force_Full_Explore then
+ return;
+ end if;
+
+ Success_Counter := Success_Counter + 1;
+ Result := Success;
+
+ Data.Success := True;
+
+ if Data.Check_Count < Min_Success_Check_Count then
+ Min_Success_Check_Count := Data.Check_Count;
+ end if;
+
+ if Force_High_Cost_Solutions then
+ Data.Results.Add (Config);
+ if Data.Results.Count > 3 then
+ Parser_Status (Parser_Index).Recover_State := Ready;
+ end if;
+ else
+ if Data.Results.Count = 0 then
+ Data.Results.Add (Config);
+
+ Parser_Status (Parser_Index).Recover_State := Ready;
+
+ elsif Config.Cost < Data.Results.Min_Key then
+ -- delete higher cost configs from Results
+ loop
+ Data.Results.Drop;
+ exit when Data.Results.Count = 0 or else
+ Config.Cost >= Data.Results.Min_Key;
+ end loop;
+
+ Data.Results.Add (Config);
+
+ elsif Config.Cost = Data.Results.Min_Key then
+ Data.Results.Add (Config);
+
+ else
+ -- Config.Cost > Results.Min_Key
+ null;
+ end if;
+ end if;
+ end Success;
+
+ procedure Put (Parser_Index : in SAL.Peek_Type; Configs : in out
Config_Heaps.Heap_Type)
+ is
+ use all type SAL.Base_Peek_Type;
+ Configs_Count : constant SAL.Base_Peek_Type := Configs.Count; --
Before it is emptied, for Trace.
+
+ P_Status : Base.Parser_Status renames Parser_Status (Parser_Index);
+ Data : McKenzie_Data renames P_Status.Parser_State.Recover;
+ begin
+ P_Status.Active_Workers := P_Status.Active_Workers - 1;
+
+ loop
+ exit when Configs.Count = 0;
+
+ -- [1] has a check for duplicate configs here; that only happens
with
+ -- higher costs, which take too long for our application.
+ Data.Config_Heap.Add (Configs.Remove);
+ Data.Enqueue_Count := Data.Enqueue_Count + 1;
+ end loop;
+
+ if Trace_McKenzie > Detail then
+ Put_Line
+ (Trace.all, P_Status.Parser_State.Label,
+ "enqueue:" & SAL.Base_Peek_Type'Image (Configs_Count) &
+ "/" & SAL.Base_Peek_Type'Image (Data.Config_Heap.Count) &
+ "/" & Trimmed_Image (Data.Enqueue_Count) &
+ "/" & Trimmed_Image (Data.Check_Count) &
+ ", min cost:" &
+ (if Data.Config_Heap.Count > 0
+ then Integer'Image (Data.Config_Heap.Min_Key)
+ else " ? ") &
+ ", active workers:" & Integer'Image
(P_Status.Active_Workers));
+ end if;
+ end Put;
+
+ procedure Config_Full (Parser_Index : in SAL.Peek_Type)
+ is
+ P_Status : Base.Parser_Status renames Parser_Status (Parser_Index);
+ Data : McKenzie_Data renames P_Status.Parser_State.Recover;
+ begin
+ Data.Config_Full_Count := Data.Config_Full_Count + 1;
+ if Trace_McKenzie > Outline then
+ Put_Line (Trace.all, Label (Parser_Index), "config.ops is full; "
& Data.Config_Full_Count'Image);
+ end if;
+ end Config_Full;
+
+ function Recover_Result return Recover_Status
+ is
+ Temp : Recover_Status := Result;
+ begin
+ if Result = Success then
+ return Success;
+ else
+ for S of Parser_Status loop
+ Temp := Recover_Status'Max (Result, S.Fail_Mode);
+ end loop;
+ return Temp;
+ end if;
+ end Recover_Result;
+
+ procedure Fatal (E : in Ada.Exceptions.Exception_Occurrence)
+ is
+ use Ada.Exceptions;
+ begin
+ if Trace_McKenzie > Outline then
+ Trace.Put_Line ("task " & Task_Attributes.Value'Image & "
Supervisor: Error");
+ end if;
+ Fatal_Called := True;
+ Error_ID := Exception_Identity (E);
+ Error_Message := +Exception_Message (E);
+ if Debug_Mode then
+ Trace.Put_Line (Exception_Name (E) & ": " & Exception_Message (E));
+ Trace.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
+ end if;
+ end Fatal;
+
+ entry Done (Error_ID : out Ada.Exceptions.Exception_Id; Message : out
Ada.Strings.Unbounded.Unbounded_String)
+ when All_Parsers_Done or Fatal_Called
+ is begin
+ Error_ID := Supervisor.Error_ID;
+ Message := Error_Message;
+ if Trace_McKenzie > Detail then
+ Trace.New_Line;
+ Trace.Put_Line ("Supervisor: Done");
+ end if;
+ end Done;
+
+ function Parser_State (Parser_Index : in SAL.Peek_Type) return
Parser_Lists.Constant_Reference_Type
+ is begin
+ return (Element => Parser_Status (Parser_Index).Parser_State);
+ end Parser_State;
+
+ function Label (Parser_Index : in SAL.Peek_Type) return Natural
+ is begin
+ return Parser_Status (Parser_Index).Parser_State.Label;
+ end Label;
+
+ end Supervisor;
+
+ procedure Put
+ (Message : in String;
+ Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Config : in Configuration;
+ Task_ID : in Boolean := True)
+ is begin
+ Put (Message, Super.Trace.all, Super.Parser_State (Parser_Index).Label,
+ Shared.Terminals.all, Config, Task_ID);
+ end Put;
+
+end WisiToken.Parse.LR.McKenzie_Recover.Base;
diff --git a/wisitoken-parse-lr-mckenzie_recover-base.ads
b/wisitoken-parse-lr-mckenzie_recover-base.ads
index c5d78ea..cde4bd5 100644
--- a/wisitoken-parse-lr-mckenzie_recover-base.ads
+++ b/wisitoken-parse-lr-mckenzie_recover-base.ads
@@ -1,181 +1,184 @@
--- Abstract :
---
--- Base utilities for McKenzie_Recover
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Exceptions;
-with WisiToken.Parse.LR.Parser;
-with WisiToken.Parse.LR.Parser_Lists;
-private package WisiToken.Parse.LR.McKenzie_Recover.Base is
-
- ----------
- -- Protected object specs.
- --
- -- Tasking design requirements:
- --
- -- 1) For each parse_state, find all solutions of the same lowest
- -- cost.
- --
- -- 2) use as many CPUs as available as fully as possible.
- --
- -- 3) avoid
- -- a) busy waits
- -- b) race conditions
- -- c) deadlocks.
- --
- -- For 2), we use worker_tasks to perform the check computations on
- -- each configuration. We allocate N - 1 worker_tasks, where N is the
- -- number of available CPUs, saving one CPU for Supervisor and the
- -- foreground IDE.
- --
- -- For 1), worker_tasks always get the lowest cost configuration
- -- available. However, some active worker_task may have a lower cost
- -- configuration that it has not yet delivered to Supervisor.
- -- Therefore we always wait until all current active worker_tasks
- -- deliver their results before deciding we are done.
- --
- -- For 3a) we have one Supervisor protected object that controls
- -- access to all Parse_States and configurations, and a Shared object
- -- that provides appropriate access to the Shared_Parser components.
- --
- -- It is tempting to try to reduce contention for Supervisor by
- -- having one protected object per parser, but that requires the
- -- worker tasks to busy loop checking all the parsers.
- --
- -- There is still a race condition on Success; the solutions can be
- -- delivered in different orders on different runs. This matters
- -- because each solution results in a successful parse, possibly with
- -- different actions (different indentation computed, for example).
- -- Which solution finally succeeds depends on which are terminated
- -- due to identical parser stacks, which in turn depends on the order
- -- they were delivered. See ada-mode/tests/ada_mode-interactive_2.adb
- -- for an example.
- --
- -- There is also a race condition on how many failed or higher cost
- -- configurations are checked, before the final solutions are found.
-
- type Config_Status is (Valid, All_Done);
- type Recover_State is (Active, Ready, Success, Fail);
-
- type Parser_Status is record
- Recover_State : Base.Recover_State;
- Parser_State : Parser_Lists.State_Access;
- Fail_Mode : Recover_Status;
-
- Active_Workers : Natural;
- -- Count of Worker_Tasks that have done Get but not Put or Success.
- end record;
-
- type Parser_Status_Array is array (SAL.Peek_Type range <>) of Parser_Status;
-
- protected type Supervisor
- (Trace : not null access WisiToken.Trace'Class;
- Cost_Limit : Natural;
- Check_Delta_Limit : Natural;
- Enqueue_Limit : Natural;
- Parser_Count : SAL.Peek_Type)
- is
- -- There is only one object of this type, declared in Recover.
-
- procedure Initialize
- (Parsers : not null access Parser_Lists.List;
- Terminals : not null access constant Base_Token_Arrays.Vector);
-
- entry Get
- (Parser_Index : out SAL.Base_Peek_Type;
- Config : out Configuration;
- Status : out Config_Status);
- -- Get a new configuration to check. Available when there is a
- -- configuration to get, or when all configs have been checked.
- --
- -- Increments active worker count.
- --
- -- Status values mean:
- --
- -- Valid - Parser_Index, Config are valid, should be checked.
- --
- -- All_Done - Parser_Index, Config are not valid.
-
- procedure Success
- (Parser_Index : in SAL.Peek_Type;
- Config : in Configuration;
- Configs : in out Config_Heaps.Heap_Type);
- -- Report that Configuration succeeds for Parser_Label, and enqueue
- -- Configs.
- --
- -- Decrements active worker count.
-
- procedure Put (Parser_Index : in SAL.Peek_Type; Configs : in out
Config_Heaps.Heap_Type);
- -- Add Configs to the McKenzie_Data Config_Heap for Parser_Label
- --
- -- Decrements active worker count.
-
- function Recover_Result return Recover_Status;
-
- procedure Fatal (E : in Ada.Exceptions.Exception_Occurrence);
- -- Report a fatal error; abort all processing, make Done
- -- available.
-
- entry Done (Error_ID : out Ada.Exceptions.Exception_Id; Message : out
Ada.Strings.Unbounded.Unbounded_String);
- -- Available when all parsers have failed or succeeded, or an error
- -- occured.
- --
- -- If Error_ID is not Null_Id, an error occured.
-
- function Parser_State (Parser_Index : in SAL.Peek_Type) return
Parser_Lists.Constant_Reference_Type;
- function Label (Parser_Index : in SAL.Peek_Type) return Natural;
-
- private
- Parsers : access Parser_Lists.List;
- Terminals : access constant Base_Token_Arrays.Vector;
-
- All_Parsers_Done : Boolean;
- Success_Counter : Natural;
- Min_Success_Check_Count : Natural;
- Fatal_Called : Boolean;
- Result : Recover_Status;
- Error_ID : Ada.Exceptions.Exception_Id;
- Error_Message : Ada.Strings.Unbounded.Unbounded_String;
- Parser_Status : Parser_Status_Array (1 .. Parser_Count);
- end Supervisor;
-
- type Shared
- (Trace : not null access
WisiToken.Trace'Class;
- Lexer : not null access constant
WisiToken.Lexer.Instance'Class;
- Table : not null access constant
Parse_Table;
- Language_Fixes :
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Use_Minimal_Complete_Actions :
WisiToken.Parse.LR.Parser.Language_Use_Minimal_Complete_Actions_Access;
- Language_String_ID_Set :
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
- Terminals : not null access constant
Base_Token_Arrays.Vector;
- Line_Begin_Token : not null access constant
Line_Begin_Token_Vectors.Vector)
- is null record;
- -- There is only one object of this type, declared in Recover. It
- -- provides appropriate access to Shared_Parser components.
- --
- -- Since all the accessible objects are read-only (except Trace),
- -- there are no protected operations, and this is not a protected
- -- type.
-
- procedure Put
- (Message : in String;
- Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Config : in Configuration;
- Task_ID : in Boolean := True);
-
-end WisiToken.Parse.LR.McKenzie_Recover.Base;
+-- Abstract :
+--
+-- Base utilities for McKenzie_Recover
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Exceptions;
+with WisiToken.Parse.LR.Parser;
+with WisiToken.Parse.LR.Parser_Lists;
+private package WisiToken.Parse.LR.McKenzie_Recover.Base is
+
+ ----------
+ -- Protected object specs.
+ --
+ -- Tasking design requirements:
+ --
+ -- 1) For each parse_state, find all solutions of the same lowest
+ -- cost.
+ --
+ -- 2) use as many CPUs as available as fully as possible.
+ --
+ -- 3) avoid
+ -- a) busy waits
+ -- b) race conditions
+ -- c) deadlocks.
+ --
+ -- For 2), we use worker_tasks to perform the check computations on
+ -- each configuration. We allocate N - 1 worker_tasks, where N is the
+ -- number of available CPUs, saving one CPU for Supervisor and the
+ -- foreground IDE.
+ --
+ -- For 1), worker_tasks always get the lowest cost configuration
+ -- available. However, some active worker_task may have a lower cost
+ -- configuration that it has not yet delivered to Supervisor.
+ -- Therefore we always wait until all current active worker_tasks
+ -- deliver their results before deciding we are done.
+ --
+ -- For 3a) we have one Supervisor protected object that controls
+ -- access to all Parse_States and configurations, and a Shared object
+ -- that provides appropriate access to the Shared_Parser components.
+ --
+ -- It is tempting to try to reduce contention for Supervisor by
+ -- having one protected object per parser, but that requires the
+ -- worker tasks to busy loop checking all the parsers.
+ --
+ -- There is still a race condition on Success; the solutions can be
+ -- delivered in different orders on different runs. This matters
+ -- because each solution results in a successful parse, possibly with
+ -- different actions (different indentation computed, for example).
+ -- Which solution finally succeeds depends on which are terminated
+ -- due to identical parser stacks, which in turn depends on the order
+ -- they were delivered. See ada-mode/tests/ada_mode-interactive_2.adb
+ -- for an example.
+ --
+ -- There is also a race condition on how many failed or higher cost
+ -- configurations are checked, before the final solutions are found.
+
+ type Config_Status is (Valid, All_Done);
+ type Recover_State is (Active, Ready, Success, Fail);
+
+ type Parser_Status is record
+ Recover_State : Base.Recover_State;
+ Parser_State : Parser_Lists.State_Access;
+ Fail_Mode : Recover_Status;
+
+ Active_Workers : Natural;
+ -- Count of Worker_Tasks that have done Get but not Put or Success.
+ end record;
+
+ type Parser_Status_Array is array (SAL.Peek_Type range <>) of Parser_Status;
+
+ protected type Supervisor
+ (Trace : not null access WisiToken.Trace'Class;
+ Check_Delta_Limit : Natural;
+ Enqueue_Limit : Natural;
+ Parser_Count : SAL.Peek_Type)
+ is
+ -- There is only one object of this type, declared in Recover.
+
+ procedure Initialize
+ (Parsers : not null access Parser_Lists.List;
+ Terminals : not null access constant Base_Token_Arrays.Vector);
+
+ entry Get
+ (Parser_Index : out SAL.Base_Peek_Type;
+ Config : out Configuration;
+ Status : out Config_Status);
+ -- Get a new configuration to check. Available when there is a
+ -- configuration to get, or when all configs have been checked.
+ --
+ -- Increments active worker count.
+ --
+ -- Status values mean:
+ --
+ -- Valid - Parser_Index, Config are valid, should be checked.
+ --
+ -- All_Done - Parser_Index, Config are not valid.
+
+ procedure Success
+ (Parser_Index : in SAL.Peek_Type;
+ Config : in Configuration;
+ Configs : in out Config_Heaps.Heap_Type);
+ -- Report that Configuration succeeds for Parser_Label, and enqueue
+ -- Configs.
+ --
+ -- Decrements active worker count.
+
+ procedure Put (Parser_Index : in SAL.Peek_Type; Configs : in out
Config_Heaps.Heap_Type);
+ -- Add Configs to the McKenzie_Data Config_Heap for Parser_Label
+ --
+ -- Decrements active worker count.
+
+ procedure Config_Full (Parser_Index : in SAL.Peek_Type);
+ -- Report that a config.ops was full when trying to add another op.
+ -- This is counted towards the enqueue limit.
+
+ function Recover_Result return Recover_Status;
+
+ procedure Fatal (E : in Ada.Exceptions.Exception_Occurrence);
+ -- Report a fatal error; abort all processing, make Done
+ -- available.
+
+ entry Done (Error_ID : out Ada.Exceptions.Exception_Id; Message : out
Ada.Strings.Unbounded.Unbounded_String);
+ -- Available when all parsers have failed or succeeded, or an error
+ -- occured.
+ --
+ -- If Error_ID is not Null_Id, an error occured.
+
+ function Parser_State (Parser_Index : in SAL.Peek_Type) return
Parser_Lists.Constant_Reference_Type;
+ function Label (Parser_Index : in SAL.Peek_Type) return Natural;
+
+ private
+ Parsers : access Parser_Lists.List;
+ Terminals : access constant Base_Token_Arrays.Vector;
+
+ All_Parsers_Done : Boolean;
+ Success_Counter : Natural;
+ Min_Success_Check_Count : Natural;
+ Fatal_Called : Boolean;
+ Result : Recover_Status;
+ Error_ID : Ada.Exceptions.Exception_Id;
+ Error_Message : Ada.Strings.Unbounded.Unbounded_String;
+ Parser_Status : Parser_Status_Array (1 .. Parser_Count);
+ end Supervisor;
+
+ type Shared
+ (Trace : not null access WisiToken.Trace'Class;
+ Lexer : not null access constant
WisiToken.Lexer.Instance'Class;
+ Table : not null access constant Parse_Table;
+ Language_Fixes :
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Matching_Begin_Tokens :
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set :
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+ Terminals : not null access constant
Base_Token_Arrays.Vector;
+ Line_Begin_Token : not null access constant
Line_Begin_Token_Vectors.Vector)
+ is null record;
+ -- There is only one object of this type, declared in Recover. It
+ -- provides appropriate access to Shared_Parser components.
+ --
+ -- Since all the accessible objects are read-only (except Trace),
+ -- there are no protected operations, and this is not a protected
+ -- type.
+
+ procedure Put
+ (Message : in String;
+ Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Config : in Configuration;
+ Task_ID : in Boolean := True);
+
+end WisiToken.Parse.LR.McKenzie_Recover.Base;
diff --git a/wisitoken-parse-lr-mckenzie_recover-explore.adb
b/wisitoken-parse-lr-mckenzie_recover-explore.adb
index 56bd3fe..272eadf 100644
--- a/wisitoken-parse-lr-mckenzie_recover-explore.adb
+++ b/wisitoken-parse-lr-mckenzie_recover-explore.adb
@@ -1,1406 +1,1668 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Parse.LR.McKenzie_Recover.Parse;
-with WisiToken.Parse.LR.Parser;
-package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
-
- procedure Do_Shift
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Config : in out Configuration;
- State : in State_Index;
- ID : in Token_ID;
- Cost_Delta : in Integer;
- Strategy : in Strategies)
- is
- use all type SAL.Base_Peek_Type;
- McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
-
- Op : constant Config_Op := (Insert, ID, Config.Current_Shared_Token);
- begin
- Config.Strategy_Counts (Strategy) := Config.Strategy_Counts (Strategy) +
1;
-
- begin
- if Config.Current_Ops = No_Insert_Delete then
- Config.Ops.Append (Op);
- else
- Config.Ops.Insert (Op, Before => Config.Current_Ops);
- Config.Current_Ops := Config.Current_Ops + 1;
- end if;
- exception
- when SAL.Container_Full =>
- if Trace_McKenzie > Outline then
- Put_Line (Super.Trace.all, Super.Label (Parser_Index), "config.ops
is full");
- end if;
- raise Bad_Config;
- end;
-
- if Cost_Delta = 0 then
- Config.Cost := Config.Cost + McKenzie_Param.Insert (ID);
- else
- -- Cost_Delta /= 0 comes from Try_Insert_Terminal when
- -- Minimal_Complete_Actions is useful. That doesn't mean it is better
- -- than any other solution, so don't let cost be 0.
- Config.Cost := Integer'Max (1, Config.Cost + McKenzie_Param.Insert
(ID) + Cost_Delta);
- end if;
-
- Config.Error_Token.ID := Invalid_Token_ID;
- Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
-
- Config.Stack.Push ((State, Syntax_Trees.Invalid_Node_Index, (ID, Virtual
=> True, others => <>)));
- if Trace_McKenzie > Detail then
- Base.Put ("insert " & Image (ID, Super.Trace.Descriptor.all), Super,
Shared, Parser_Index, Config);
- end if;
-
- Local_Config_Heap.Add (Config);
- end Do_Shift;
-
- procedure Do_Reduce_1
- (Label : in String;
- Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Config : in out Configuration;
- Action : in Reduce_Action_Rec;
- Do_Language_Fixes : in Boolean := True)
- is
- use all type SAL.Base_Peek_Type;
- use all type Semantic_Checks.Check_Status_Label;
- use all type WisiToken.Parse.LR.Parser.Language_Fixes_Access;
-
- Prev_State : constant Unknown_State_Index := Config.Stack.Peek.State;
-
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- Table : Parse_Table renames Shared.Table.all;
- Nonterm : Recover_Token;
- New_State : Unknown_State_Index;
- begin
- Config.Check_Status := Parse.Reduce_Stack (Shared, Config.Stack, Action,
Nonterm, Default_Virtual => True);
- case Config.Check_Status.Label is
- when Ok =>
- null;
-
- when Semantic_Checks.Error =>
- Config.Error_Token := Nonterm;
- Config.Check_Token_Count := Action.Token_Count;
-
- if Do_Language_Fixes then
- if Shared.Language_Fixes /= null then
- Shared.Language_Fixes
- (Super.Trace.all, Shared.Lexer, Super.Label (Parser_Index),
Shared.Table.all, Shared.Terminals.all,
- Super.Parser_State (Parser_Index).Tree, Local_Config_Heap,
- Config);
- end if;
- end if;
-
- -- Finish the reduce; ignore the check fail.
- Config.Stack.Pop (SAL.Base_Peek_Type (Config.Check_Token_Count));
- Config.Error_Token.ID := Invalid_Token_ID;
- Config.Check_Status := (Label => Ok);
- end case;
-
- if Config.Stack.Depth = 0 or else Config.Stack (1).State = Unknown_State
then
- raise Bad_Config;
- end if;
-
- New_State := Goto_For (Table, Config.Stack (1).State,
Action.Production.LHS);
-
- if New_State = Unknown_State then
- raise Bad_Config;
- end if;
-
- Config.Stack.Push ((New_State, Syntax_Trees.Invalid_Node_Index,
Nonterm));
-
- if Trace_McKenzie > Extra and Label'Length > 0 then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), Label &
- ": state" & State_Index'Image (Prev_State) & " reduce to " &
- Image (Action.Production.LHS, Descriptor) & ", goto" &
- State_Index'Image (New_State));
- end if;
- end Do_Reduce_1;
-
- procedure Do_Reduce_2
- (Label : in String;
- Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Config : in out Configuration;
- Inserted_ID : in Token_ID;
- Cost_Delta : in Integer;
- Strategy : in Strategies)
- is
- -- Perform reduce actions until shift Inserted_ID; if all succeed,
- -- add the final configuration to the heap. If a conflict is
- -- encountered, process the other action the same way. If a semantic
- -- check fails, enqueue possible solutions. For parse table error
- -- actions, or exception Bad_Config, just return.
-
- Table : Parse_Table renames Shared.Table.all;
- Next_Action : constant Parse_Action_Node_Ptr := Action_For (Table,
Config.Stack (1).State, Inserted_ID);
- begin
- if Next_Action.Next /= null then
- -- There is a conflict; create a new config to shift or reduce.
- declare
- New_Config : Configuration := Config;
- Action : Parse_Action_Rec renames Next_Action.Next.Item;
- begin
- case Action.Verb is
- when Shift =>
- Do_Shift
- (Super, Shared, Parser_Index, Local_Config_Heap, New_Config,
Action.State, Inserted_ID,
- Cost_Delta, Strategy);
-
- when Reduce =>
- Do_Reduce_1 (Label, Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action);
- Do_Reduce_2 (Label, Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Inserted_ID,
- Cost_Delta, Strategy);
-
- when Accept_It =>
- raise SAL.Programmer_Error with "found test case for Do_Reduce
Accept_It conflict";
-
- when Error =>
- null;
- end case;
- end;
-
- -- There can be only one conflict.
- end if;
-
- case Next_Action.Item.Verb is
- when Shift =>
- Do_Shift
- (Super, Shared, Parser_Index, Local_Config_Heap, Config,
Next_Action.Item.State, Inserted_ID,
- Cost_Delta, Strategy);
-
- when Reduce =>
- Do_Reduce_1 (Label, Super, Shared, Parser_Index, Local_Config_Heap,
Config, Next_Action.Item);
- Do_Reduce_2 (Label, Super, Shared, Parser_Index, Local_Config_Heap,
Config, Inserted_ID, Cost_Delta, Strategy);
-
- when Accept_It =>
- raise SAL.Programmer_Error with "found test case for Do_Reduce
Accept_It";
-
- when Error =>
- null;
- end case;
-
- exception
- when Bad_Config =>
- null;
- end Do_Reduce_2;
-
- function Fast_Forward
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Config : in out Configuration)
- return Non_Success_Status
- is
- -- Apply the ops in Config; they were inserted by some fix.
- -- Return Abandon if Config should be abandoned, otherwise Continue.
- -- Leaves Config.Error_Token, Config.Check_Status set.
- --
- -- If there are conflicts, all are parsed; if more than one succeed,
- -- all are enqueued in Local_Config_Heap, and this returns Abandon.
-
- use all type SAL.Base_Peek_Type;
- use all type Ada.Containers.Count_Type;
-
- Parse_Items : Parse.Parse_Item_Arrays.Vector;
- begin
- if Parse.Parse
- (Super, Shared, Parser_Index, Parse_Items, Config,
- Shared_Token_Goal => Invalid_Token_Index,
- All_Conflicts => True,
- Trace_Prefix => "fast_forward")
- then
- -- At least one config parsed without error, so continue with them.
- if Parse_Items.Length = 1 then
- Config := Parse_Items (1).Config;
- Config.Current_Ops := No_Insert_Delete;
- Config.Ops.Append ((Fast_Forward, Config.Current_Shared_Token));
- return Continue;
- else
- -- Enqueue all passing configs, abandon current.
- for Item of Parse_Items loop
- if Item.Parsed and Item.Config.Error_Token.ID =
Invalid_Token_ID then
- Item.Config.Ops.Append ((Fast_Forward,
Item.Config.Current_Shared_Token));
- Config.Current_Ops := No_Insert_Delete;
- Local_Config_Heap.Add (Item.Config);
-
- if Trace_McKenzie > Detail then
- Base.Put ("fast forward conflict", Super, Shared,
Parser_Index, Item.Config);
- end if;
- end if;
- end loop;
- return Abandon;
- end if;
-
- else
- -- No parse item parsed without error. This indicates that Config.Ops
- -- (enqueued by language_fixes) did not fix all the problems; see
- -- test_mckenzie_recover Two_Missing_Ends. If it made progress we try
- -- more fixes.
- for Item of Parse_Items loop
- declare
- Parsed_Config : Configuration renames Item.Config;
- Remaining : SAL.Base_Peek_Type;
- begin
- if Parsed_Config.Current_Insert_Delete = No_Insert_Delete then
- -- Insert_Delete contains only Deletes, and the next token
caused an
- -- error.
- Parsed_Config.Ops.Append ((Fast_Forward,
Config.Current_Shared_Token));
- Local_Config_Heap.Add (Parsed_Config);
- if Trace_McKenzie > Detail then
- Base.Put ("fast forward failure", Super, Shared,
Parser_Index, Item.Config);
- end if;
-
- elsif Parsed_Config.Current_Insert_Delete = 1 then
- -- No progress made; abandon config
- null;
-
- else
- -- Find fixes at the failure point. We don't reset
- -- Config.Current_Insert_Delete here, to allow skipping
Check.
- --
- -- If the unparsed ops are at Config.Current_Shared_Token,
then new
- -- ops applied in Process_One below must be inserted in
Config.Ops
- -- before the unparsed ops, so the final order applied to
the full
- -- parser is correct.
- if Parsed_Config.Insert_Delete
(Parsed_Config.Current_Insert_Delete).Token_Index =
- Parsed_Config.Current_Shared_Token
- then
- Parsed_Config.Current_Ops := Parsed_Config.Ops.Last_Index;
- Remaining := Parsed_Config.Insert_Delete.Last_Index -
Parsed_Config.Current_Insert_Delete;
- loop
- exit when Remaining = 0;
- if Parsed_Config.Ops (Parsed_Config.Current_Ops).Op in
Insert_Delete_Op_Label then
- Remaining := Remaining - 1;
- end if;
- Parsed_Config.Current_Ops := Parsed_Config.Current_Ops
- 1;
- if Parsed_Config.Current_Ops <
Parsed_Config.Ops.First_Index then
- if Trace_McKenzie > Outline then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
- "Insert_Delete is out of sync with Ops");
- end if;
- raise Bad_Config;
- end if;
- end loop;
- end if;
-
- if Parsed_Config.Current_Insert_Delete > 1 then
- if Parsed_Config.Current_Ops = No_Insert_Delete then
- Parsed_Config.Ops.Append ((Fast_Forward,
Config.Current_Shared_Token));
- else
- Parsed_Config.Ops.Insert
- ((Fast_Forward, Config.Current_Shared_Token), Before
=> Parsed_Config.Current_Ops);
- Parsed_Config.Current_Ops := Parsed_Config.Current_Ops
+ 1;
- end if;
- end if;
- Local_Config_Heap.Add (Parsed_Config);
- if Trace_McKenzie > Detail then
- Base.Put ("fast forward failure", Super, Shared,
Parser_Index, Item.Config);
- end if;
- end if;
- end;
- end loop;
- return Abandon;
- end if;
- exception
- when SAL.Container_Full | Bad_Config =>
- return Abandon;
- end Fast_Forward;
-
- function Check
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- return Check_Status
- is
- use all type Ada.Containers.Count_Type;
- use all type Semantic_Checks.Check_Status_Label;
- use all type Parser.Language_Fixes_Access;
-
- Parse_Items : Parse.Parse_Item_Arrays.Vector;
- begin
- if Parse.Parse
- (Super, Shared, Parser_Index, Parse_Items, Config,
Config.Resume_Token_Goal,
- All_Conflicts => False,
- Trace_Prefix => "check")
- then
- Config.Error_Token.ID := Invalid_Token_ID;
- return Success;
- end if;
-
- -- All Parse_Items failed; enqueue them so Language_Fixes can try to
fix them.
- declare
- Parse_Error_Found : Boolean := False;
- begin
- for Item of Parse_Items loop
-
- if Item.Config.Error_Token.ID /= Invalid_Token_ID and
Item.Config.Check_Status.Label = Ok then
- Parse_Error_Found := True;
-
- if Item.Shift_Count = 0 or
- ((Item.Config.Ops.Length > 0 and then
- Item.Config.Ops (Item.Config.Ops.Last_Index).Op in
Undo_Reduce | Push_Back) and
- Item.Config.Current_Shared_Token =
Config.Current_Shared_Token)
- then
- -- (Item.config.ops is empty on the very first Check). This
is the
- -- same error Config originally found; report it in Config,
so
- -- Use_Minimal_Complete_Actions can see it.
- Config.Error_Token := Item.Config.Error_Token;
- Config.Check_Status := (Label => Ok);
- end if;
- end if;
-
- if Item.Shift_Count > 0 and then
- (Item.Config.Check_Status.Label /= Ok or
- Item.Config.Error_Token.ID /= Invalid_Token_ID)
- then
- -- Some progress was made; let Language_Fixes try to fix the
new
- -- error.
- --
- -- This is abandoning the original location of the error,
which may
- -- not be entirely fixed. So we increase the cost. See
- -- test_mckenzie_recover Loop_Bounds.
- Item.Config.Cost := Item.Config.Cost + 1;
- begin
- if Item.Config.Ops (Item.Config.Ops.Last_Index).Op =
Fast_Forward then
- Item.Config.Ops
(Item.Config.Ops.Last_Index).FF_Token_Index :=
- Item.Config.Current_Shared_Token;
- else
- Item.Config.Ops.Append ((Fast_Forward,
Item.Config.Current_Shared_Token));
- end if;
- exception
- when SAL.Container_Full =>
- raise Bad_Config;
- end;
- Local_Config_Heap.Add (Item.Config);
- if Trace_McKenzie > Detail then
- Base.Put ("for Language_Fixes ", Super, Shared,
Parser_Index, Item.Config);
- end if;
- end if;
- end loop;
-
- if Parse_Error_Found then
- return Continue;
- else
- -- Failed due to Semantic_Check
- if Shared.Language_Fixes = null then
- -- Only fix is to ignore the error
- return Continue;
- else
- -- Assume Language_Fixes handles this, not Explore.
- return Abandon;
- end if;
- end if;
- end;
- exception
- when Bad_Config =>
- return Abandon;
- end Check;
-
- function Check_Reduce_To_Start
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Orig_Config : in Configuration)
- return Boolean
- -- Returns True if Config reduces to the start nonterm.
- is
- Table : Parse_Table renames Shared.Table.all;
-
- function To_Reduce_Action (Item : in Minimal_Action) return
Reduce_Action_Rec
- is begin
- return (Reduce, (Item.Nonterm, 0), null, null, Item.Token_Count);
- end To_Reduce_Action;
-
- Local_Config_Heap : Config_Heaps.Heap_Type; -- never used, because
Do_Language_Fixes is False.
-
- Config : Configuration := Orig_Config;
- Action : Minimal_Action := Table.States
(Config.Stack.Peek.State).Minimal_Complete_Action;
- begin
- loop
- case Action.Verb is
- when Pause =>
- return True;
-
- when Shift =>
- return False;
-
- when Reduce =>
- Do_Reduce_1
- ("", Super, Shared, Parser_Index, Local_Config_Heap, Config,
- To_Reduce_Action (Action),
- Do_Language_Fixes => False);
-
- Action := Table.States
(Config.Stack.Peek.State).Minimal_Complete_Action;
- end case;
- -- loop only exits via returns above
- end loop;
- end Check_Reduce_To_Start;
-
- procedure Try_Push_Back
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
- McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
-
- Token : constant Recover_Token := Config.Stack (1).Token;
- begin
- -- Try pushing back the stack top, to allow insert and other
- -- operations at that point.
- --
- -- Since we are not actually changing the source text, it is tempting
- -- to give this operation zero cost. But then we keep doing push_back
- -- forever, making no progress. So we give it a cost.
-
- if not Token.Virtual then
- -- If Virtual, this is from earlier in this recover session; no point
- -- in trying to redo it.
-
- declare
- New_Config : Configuration := Config;
- begin
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- New_Config.Stack.Pop;
-
- if Token.Min_Terminal_Index = Invalid_Token_Index then
- -- Token is empty; Config.current_shared_token does not
change, no
- -- cost increase.
- New_Config.Ops.Append ((Push_Back, Token.ID,
New_Config.Current_Shared_Token));
- else
- New_Config.Cost := New_Config.Cost + McKenzie_Param.Push_Back
(Token.ID);
- New_Config.Ops.Append ((Push_Back, Token.ID,
Token.Min_Terminal_Index));
- New_Config.Current_Shared_Token := Token.Min_Terminal_Index;
- end if;
-
- Local_Config_Heap.Add (New_Config);
-
- if Trace_McKenzie > Detail then
- Base.Put ("push_back " & Image (Token.ID,
Trace.Descriptor.all), Super, Shared,
- Parser_Index, New_Config);
- end if;
- end;
- end if;
- exception
- when SAL.Container_Full =>
- if Trace_McKenzie > Outline then
- Put_Line (Super.Trace.all, Super.Label (Parser_Index), "config.ops is
full");
- end if;
- end Try_Push_Back;
-
- procedure Insert_From_Action_List
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- use all type Ada.Containers.Count_Type;
-
- Table : Parse_Table renames Shared.Table.all;
- EOF_ID : Token_ID renames Super.Trace.Descriptor.EOI_ID;
-
- -- Find terminal insertions from the current state's action_list to try.
- --
- -- We perform any needed reductions and one shift, so the config is
- -- in a consistent state, and enqueue the result. If there are any
- -- conflicts or semantic check fails encountered, they create other
- -- configs to enqueue.
-
- I : Action_List_Iterator := First (Table.States (Config.Stack
(1).State));
-
- Cached_Config : Configuration;
- Cached_Action : Reduce_Action_Rec;
- -- Most of the time, all the reductions in a state are the same. So
- -- we cache the first result. This includes one reduction; if an
- -- associated semantic check failed, this does not include the fixes.
- begin
- loop
- exit when I.Is_Done;
-
- declare
- ID : constant Token_ID := I.Symbol;
- Action : Parse_Action_Rec renames I.Action;
- begin
- if ID /= EOF_ID and then -- can't insert eof
- ID /= Invalid_Token_ID and then -- invalid when Verb = Error
- (Config.Ops.Length = 0 or else
- -- Don't insert an ID we just pushed back or deleted; we
know that failed.
- (Config.Ops (Config.Ops.Last_Index) /= (Push_Back, ID,
Config.Current_Shared_Token) and
- Config.Ops (Config.Ops.Last_Index) /= (Delete, ID,
Config.Current_Shared_Token)))
- then
- case Action.Verb is
- when Shift =>
- declare
- New_Config : Configuration := Config;
- begin
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- Do_Shift
- (Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Action.State, ID,
- Cost_Delta => 0,
- Strategy => Explore_Table);
- end;
-
- when Reduce =>
- if not Equal (Action, Cached_Action) then
- declare
- New_Config : Configuration := Config;
- begin
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- Do_Reduce_1 ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action);
- Cached_Config := New_Config;
- Cached_Action := Action;
-
- Do_Reduce_2
- ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
- Cost_Delta => 0,
- Strategy => Explore_Table);
- end;
-
- else
- declare
- New_Config : Configuration := Cached_Config;
- begin
- Do_Reduce_2
- ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
- Cost_Delta => 0,
- Strategy => Explore_Table);
- end;
- end if;
-
- when Accept_It =>
- raise SAL.Programmer_Error with "found test case for
Process_One Accept_It";
-
- when Error =>
- null;
- end case;
- end if;
- end;
- I.Next;
- end loop;
- end Insert_From_Action_List;
-
- function Insert_Minimal_Complete_Actions
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Orig_Config : in Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- return Integer
- -- Returns count of terminals inserted; 0 if Orig_Config reduces to
- -- the start nonterm.
- is
- use all type Ada.Containers.Count_Type;
-
- Table : Parse_Table renames Shared.Table.all;
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- Insert_Count : Integer := 0;
-
- Cost_Delta : constant Integer := -1;
-
- New_Config : Configuration := Orig_Config;
- Complete_Action : Minimal_Action := Table.States
(New_Config.Stack.Peek.State).Minimal_Complete_Action;
-
- function To_Reduce_Action (Item : in Minimal_Action) return
Reduce_Action_Rec
- is begin
- return (Reduce, (Item.Nonterm, 0), null, null, Item.Token_Count);
- end To_Reduce_Action;
-
- procedure Minimal_Do_Shift
- is begin
- if New_Config.Ops.Length > 0 and then
- -- Don't insert an ID we just pushed back or deleted; we know that
failed.
- (New_Config.Ops (New_Config.Ops.Last_Index) =
- (Push_Back, Complete_Action.ID, New_Config.Current_Shared_Token)
or
- New_Config.Ops (New_Config.Ops.Last_Index) =
- (Delete, Complete_Action.ID, New_Config.Current_Shared_Token))
- then
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions abandoned " &
- Image (Complete_Action.ID, Descriptor));
- end if;
- pragma Assert (Insert_Count = 0);
- else
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions shift " &
- Image (Complete_Action.ID, Descriptor));
- end if;
- New_Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
- Insert_Count := Insert_Count + 1;
-
- Do_Shift
- (Super, Shared, Parser_Index, Local_Config_Heap, New_Config,
Complete_Action.State, Complete_Action.ID,
- Cost_Delta,
- Strategy => Minimal_Complete);
- end if;
- end Minimal_Do_Shift;
-
- begin
- case Complete_Action.Verb is
- when Pause =>
- return 0;
-
- when Reduce =>
- -- Do a reduce, look at resulting state. Keep reducing until we can't
- -- anymore.
- declare
- Reduce_Action : Reduce_Action_Rec := To_Reduce_Action
(Complete_Action);
- begin
- loop
- Do_Reduce_1
- ("Minimal_Complete_Actions", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Reduce_Action,
- Do_Language_Fixes => False);
-
- Complete_Action := Table.States
(New_Config.Stack.Peek.State).Minimal_Complete_Action;
-
- case Complete_Action.Verb is
- when Pause =>
- return 0;
- when Shift =>
- Minimal_Do_Shift;
- return Insert_Count;
- when Reduce =>
- null;
- end case;
-
- Reduce_Action := To_Reduce_Action
- (Table.States
(New_Config.Stack.Peek.State).Minimal_Complete_Action);
- end loop;
- end;
-
- when Shift =>
- Minimal_Do_Shift;
- end case;
- return Insert_Count;
- end Insert_Minimal_Complete_Actions;
-
- procedure Insert_Matching_Begin
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Matching_Begin_Token : in Token_ID)
- is
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- New_Config : Configuration := Config;
-
- Action : constant Parse_Action_Node_Ptr := Action_For
- (Shared.Table.all, New_Config.Stack (1).State, Matching_Begin_Token);
- begin
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), "Matching_Begin
insert " &
- Image (Matching_Begin_Token, Descriptor));
- end if;
-
- case Action.Item.Verb is
- when Shift =>
- Do_Shift
- (Super, Shared, Parser_Index, Local_Config_Heap, New_Config,
Action.Item.State,
- Matching_Begin_Token,
- Cost_Delta => -1,
- Strategy => Matching_Begin);
-
- when Reduce =>
- Do_Reduce_1
- ("Matching_Begin", Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Action.Item,
- Do_Language_Fixes => False);
-
- Do_Reduce_2
- ("Matching_Begin", Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Matching_Begin_Token,
- Cost_Delta => -1,
- Strategy => Matching_Begin);
-
- when Error | Accept_It =>
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), "Matching_Begin
abandoned " &
- Image (Matching_Begin_Token, Descriptor));
- end if;
- end case;
- end Insert_Matching_Begin;
-
- procedure Try_Insert_Terminal
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Use_Minimal_Complete_Actions : in Boolean;
- Matching_Begin_Token : in Token_ID)
- is begin
- if Use_Minimal_Complete_Actions then
- if 0 = Insert_Minimal_Complete_Actions (Super, Shared, Parser_Index,
Config, Local_Config_Heap) then
- if Matching_Begin_Token /= Invalid_Token_ID then
- Insert_Matching_Begin (Super, Shared, Parser_Index, Config,
Local_Config_Heap, Matching_Begin_Token);
- else
- Insert_From_Action_List (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
- end if;
- else
- -- We _do not_ do Insert_From_Action_list when
- -- Insert_Minimal_Complete inserted something; let it try again
next
- -- cycle.
- null;
- end if;
- else
- Insert_From_Action_List (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
- end if;
-
- -- It is tempting to use the Goto_List to find nonterms to insert.
- -- But that can easily lead to error states, and it turns out to be
- -- not useful, especially if the grammar has been relaxed so most
- -- expressions and lists can be empty.
-
- exception
- when Bad_Config =>
- null;
- end Try_Insert_Terminal;
-
- procedure Try_Insert_Quote
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- use all type Parser.Language_String_ID_Set_Access;
-
- Descriptor : WisiToken.Descriptor renames Shared.Trace.Descriptor.all;
- Check_Limit : Token_Index renames
Shared.Table.McKenzie_Param.Check_Limit;
-
- Current_Line : constant Line_Number_Type :=
Shared.Terminals.all (Config.Current_Shared_Token).Line;
- Lexer_Error_Token_Index : Base_Token_Index;
- Lexer_Error_Token : Base_Token;
-
- function Recovered_Lexer_Error (Line : in Line_Number_Type) return
Base_Token_Index
- is begin
- -- We are assuming the list of lexer errors is short, so binary
- -- search would not be significantly faster.
- for Err of reverse Shared.Lexer.Errors loop
- if Err.Recover_Token /= Invalid_Token_Index and then
- Shared.Terminals.all (Err.Recover_Token).Line = Line
- then
- return Err.Recover_Token;
- end if;
- end loop;
- return Invalid_Token_Index;
- end Recovered_Lexer_Error;
-
- function String_ID_Set (String_ID : in Token_ID) return Token_ID_Set
- is begin
- return
- (if Shared.Language_String_ID_Set = null
- then (Descriptor.First_Terminal .. Descriptor.Last_Terminal =>
True)
- else Shared.Language_String_ID_Set (Descriptor, String_ID));
- end String_ID_Set;
-
- procedure String_Literal_In_Stack
- (New_Config : in out Configuration;
- Matching : in SAL.Peek_Type;
- String_Literal_ID : in Token_ID)
- is
- Saved_Shared_Token : constant Token_Index :=
New_Config.Current_Shared_Token;
-
- Tok : Recover_Token;
- J : Token_Index;
- Parse_Items : Parse.Parse_Item_Arrays.Vector;
- begin
- -- Matching is the index of a token on New_Config.Stack containing a
string
- -- literal. Push back thru that token, then delete all tokens after
- -- the string literal to Saved_Shared_Token.
- for I in 1 .. Matching loop
- Tok := New_Config.Stack.Pop.Token;
- New_Config.Ops.Append ((Push_Back, Tok.ID,
Tok.Min_Terminal_Index));
- end loop;
-
- New_Config.Current_Shared_Token := Tok.Min_Terminal_Index;
-
- -- Find last string literal in pushed back terminals.
- J := Saved_Shared_Token - 1;
- loop
- exit when Shared.Terminals.all (J).ID = String_Literal_ID;
- J := J - 1;
- end loop;
-
- begin
- if Parse.Parse
- (Super, Shared, Parser_Index, Parse_Items, New_Config,
- Shared_Token_Goal => J,
- All_Conflicts => False,
- Trace_Prefix => "insert quote parse pushback")
- then
- -- The non-deleted tokens parsed without error. We don't care
if any
- -- conflicts were encountered; we are not using the parse
result.
- New_Config := Parse_Items (1).Config;
- New_Config.Ops.Append ((Fast_Forward,
New_Config.Current_Shared_Token));
- else
- raise SAL.Programmer_Error;
- end if;
- exception
- when Bad_Config =>
- raise SAL.Programmer_Error;
- end;
- J := New_Config.Current_Shared_Token; -- parse result
- loop
- exit when J = Saved_Shared_Token;
- New_Config.Ops.Append ((Delete, Shared.Terminals.all (J).ID, J));
- J := J + 1;
- end loop;
-
- New_Config.Current_Shared_Token := Saved_Shared_Token;
-
- end String_Literal_In_Stack;
-
- procedure Finish
- (Label : in String;
- New_Config : in out Configuration;
- First, Last : in Base_Token_Index)
- is begin
- -- Delete tokens First .. Last; either First - 1 or Last + 1 should
- -- be a String_Literal. Leave Current_Shared_Token at Last + 1.
-
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
-
- -- This is a guess, so we give it a nominal cost
- New_Config.Cost := New_Config.Cost + 1;
-
- for I in First .. Last loop
- if New_Config.Ops.Is_Full then
- if Trace_McKenzie > Outline then
- Put_Line (Super.Trace.all, Super.Label (Parser_Index),
"config.ops is full");
- end if;
- raise Bad_Config;
- end if;
- New_Config.Ops.Append ((Delete, Shared.Terminals.all (I).ID, I));
- end loop;
- New_Config.Current_Shared_Token := Last + 1;
-
- -- Allow insert/delete tokens
- New_Config.Ops.Append ((Fast_Forward,
New_Config.Current_Shared_Token));
-
- if New_Config.Resume_Token_Goal - Check_Limit <
New_Config.Current_Shared_Token then
- New_Config.Resume_Token_Goal := New_Config.Current_Shared_Token +
Check_Limit;
- if Trace_McKenzie > Detail then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"resume_token_goal:" & Token_Index'Image
- (New_Config.Resume_Token_Goal));
- end if;
- end if;
-
- Config.Strategy_Counts (String_Quote) := Config.Strategy_Counts
(String_Quote) + 1;
-
- if Trace_McKenzie > Detail then
- Base.Put ("insert missing quote " & Label & " ", Super, Shared,
Parser_Index, New_Config);
- end if;
- end Finish;
-
- begin
- -- When the lexer finds an unbalanced quote, it inserts a virtual
- -- balancing quote at the same character position as the unbalanced
- -- quote, returning an empty string literal token there. The parser
- -- does not see that as an error; it encounters a syntax error
- -- before, at, or after that string literal.
- --
- -- Here we assume the parse error in Config.Error_Token is due to
- -- putting the balancing quote in the wrong place, and attempt to
- -- find a better place to put the balancing quote. Then all tokens
- -- from the balancing quote to the unbalanced quote are now part of a
- -- string literal, so delete them, leaving just the string literal
- -- created by Lexer error recovery.
-
- -- First we check to see if there is an unbalanced quote in the
- -- current line; if not, just return. Some lexer errors are for other
- -- unrecognized characters; see ada_mode-recover_bad_char.adb.
- --
- -- An alternate strategy is to treat the lexer error as a parse error
- -- immediately, but that complicates the parse logic.
-
- Config.String_Quote_Checked := Current_Line;
-
- Lexer_Error_Token_Index := Recovered_Lexer_Error (Current_Line);
-
- if Lexer_Error_Token_Index = Invalid_Token_Index then
- return;
- end if;
-
- Lexer_Error_Token := Shared.Terminals.all (Lexer_Error_Token_Index);
-
- -- It is not possible to tell where the best place to put the
- -- balancing quote is, so we always try all reasonable places.
-
- if Lexer_Error_Token.Byte_Region.First =
Config.Error_Token.Byte_Region.First then
- -- The parse error token is the string literal at the lexer error.
- --
- -- case a: Insert the balancing quote somewhere before the error
- -- point. There is no way to tell how far back to put the balancing
- -- quote, so we just do one non-empty token. See
- -- test_mckenzie_recover.adb String_Quote_0. So far we have not found
- -- a test case for more than one token.
- declare
- New_Config : Configuration := Config;
- Token : Recover_Token;
- begin
- loop
- Token := New_Config.Stack.Pop.Token;
- if Token.Byte_Region /= Null_Buffer_Region then
- New_Config.Ops.Append ((Push_Back, Token.ID,
Token.Min_Terminal_Index));
- exit;
- end if;
- end loop;
-
- Finish ("a", New_Config, Token.Min_Terminal_Index,
Config.Current_Shared_Token - 1);
- Local_Config_Heap.Add (New_Config);
- end;
-
- -- Note that it is not reasonable to insert a quote after the error
- -- in this case. If that were the right solution, the parser error
- -- token would not be the lexer repaired string literal, since a
- -- string literal would be legal here.
-
- elsif Lexer_Error_Token.Byte_Region.First <
Config.Error_Token.Byte_Region.First then
- -- The unbalanced quote is before the parse error token; see
- -- test_mckenzie_recover.adb String_Quote_2.
- --
- -- The missing quote belongs after the parse error token, before or
- -- at the end of the current line; try inserting it at the end of
- -- the current line.
- --
- -- The lexer repaired string literal may be in a reduced token on the
- -- stack.
-
- declare
- use all type SAL.Base_Peek_Type;
- Matching : SAL.Peek_Type := 1;
- begin
- Find_Descendant_ID
- (Super.Parser_State (Parser_Index).Tree, Config,
Lexer_Error_Token.ID,
- String_ID_Set (Lexer_Error_Token.ID), Matching);
-
- if Matching = Config.Stack.Depth then
- -- String literal is in a virtual nonterm; give up. So far
this only
- -- happens in a high cost non critical config.
- if Trace_McKenzie > Detail then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), "abandon
missing quote b; string literal in virtual");
- end if;
- return;
- end if;
-
- declare
- New_Config : Configuration := Config;
- begin
- String_Literal_In_Stack (New_Config, Matching,
Lexer_Error_Token.ID);
-
- Finish
- ("b", New_Config, Config.Current_Shared_Token,
Shared.Line_Begin_Token.all (Current_Line + 1) - 1);
- Local_Config_Heap.Add (New_Config);
- end;
- end;
-
- else
- -- The unbalanced quote is after the parse error token.
-
- -- case c: Assume a missing quote belongs immediately before the
current token.
- -- See test_mckenzie_recover.adb String_Quote_3.
- declare
- New_Config : Configuration := Config;
- begin
- Finish ("c", New_Config, Config.Current_Shared_Token,
Lexer_Error_Token_Index - 1);
- Local_Config_Heap.Add (New_Config);
- exception
- when Bad_Config =>
- null;
- end;
-
- -- case d: Assume a missing quote belongs somewhere farther before
- -- the current token; try one non-empty (as in case a above). See
- -- test_mckenzie_recover.adb String_Quote_4.
- declare
- New_Config : Configuration := Config;
- Token : Recover_Token;
- begin
- loop
- Token := New_Config.Stack.Pop.Token;
- if Token.Byte_Region /= Null_Buffer_Region then
- New_Config.Ops.Append ((Push_Back, Token.ID,
Token.Min_Terminal_Index));
- exit;
- end if;
- end loop;
-
- Finish ("d", New_Config, Token.Min_Terminal_Index,
Lexer_Error_Token_Index - 1);
- Local_Config_Heap.Add (New_Config);
- exception
- when Bad_Config =>
- null;
- end;
-
- -- case e: Assume the actual error is an extra quote that terminates
- -- an intended string literal early, in which case there is a token
- -- on the stack containing the string literal that should be extended
- -- to the found quote. See test_mckenzie_recover.adb String_Quote_1.
- declare
- use all type SAL.Base_Peek_Type;
- Matching : SAL.Peek_Type := 1;
- begin
- -- Lexer_Error_Token is a string literal; find a matching one.
- Find_Descendant_ID
- (Super.Parser_State (Parser_Index).Tree, Config,
Lexer_Error_Token.ID, String_ID_Set
- (Lexer_Error_Token.ID), Matching);
-
- if Matching = Config.Stack.Depth then
- -- No matching string literal, so this case does not apply.
- null;
- else
- declare
- New_Config : Configuration := Config;
- begin
- String_Literal_In_Stack (New_Config, Matching,
Lexer_Error_Token.ID);
-
- Finish ("e", New_Config, Config.Current_Shared_Token,
Lexer_Error_Token_Index);
- Local_Config_Heap.Add (New_Config);
- end;
- end if;
- end;
- end if;
- exception
- when SAL.Container_Full =>
- if Trace_McKenzie > Outline then
- Put_Line (Super.Trace.all, Super.Label (Parser_Index), "config.ops is
full");
- end if;
-
- when Bad_Config =>
- null;
- end Try_Insert_Quote;
-
- procedure Try_Delete_Input
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- -- Try deleting (= skipping) the current shared input token.
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
- EOF_ID : Token_ID renames Trace.Descriptor.EOI_ID;
- Check_Limit : Token_Index renames
Shared.Table.McKenzie_Param.Check_Limit;
-
- McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
-
- ID : constant Token_ID := Shared.Terminals.all
(Config.Current_Shared_Token).ID;
- begin
- if ID /= EOF_ID then
- -- can't delete EOF
- declare
- New_Config : Configuration := Config;
- begin
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- New_Config.Cost := New_Config.Cost + McKenzie_Param.Delete (ID);
-
- if Match_Since_FF (Config.Ops, (Push_Back, ID,
Config.Current_Shared_Token))
- then
- -- We are deleting a push_back; cancel the push_back cost, to
make
- -- this the same as plain deleting.
- New_Config.Cost := Natural'Max (Natural'First, New_Config.Cost
- McKenzie_Param.Push_Back (ID));
- end if;
-
- New_Config.Ops.Append ((Delete, ID, Config.Current_Shared_Token));
- New_Config.Current_Shared_Token := New_Config.Current_Shared_Token
+ 1;
- loop
- exit when not Super.Parser_State
(Parser_Index).Prev_Deleted.Contains (New_Config.Current_Shared_Token);
- New_Config.Current_Shared_Token :=
New_Config.Current_Shared_Token + 1;
- end loop;
-
- if New_Config.Resume_Token_Goal - Check_Limit <
New_Config.Current_Shared_Token then
- New_Config.Resume_Token_Goal := New_Config.Current_Shared_Token
+ Check_Limit;
- end if;
-
- Local_Config_Heap.Add (New_Config);
-
- if Trace_McKenzie > Detail then
- Base.Put
- ("delete " & Image (ID, Trace.Descriptor.all), Super, Shared,
Parser_Index, New_Config);
- end if;
- end;
- end if;
- exception
- when SAL.Container_Full =>
- if Trace_McKenzie > Outline then
- Put_Line (Super.Trace.all, Super.Label (Parser_Index), "config.ops is
full");
- end if;
- end Try_Delete_Input;
-
- procedure Process_One
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Config_Status : out Base.Config_Status)
- is
- -- Get one config from Super, check to see if it is a viable
- -- solution. If not, enqueue variations to check.
-
- use all type Base.Config_Status;
- use all type Parser.Language_Fixes_Access;
- use all type SAL.Base_Peek_Type;
- use all type Semantic_Checks.Check_Status_Label;
- use all type
WisiToken.Parse.LR.Parser.Language_Use_Minimal_Complete_Actions_Access;
-
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- Table : Parse_Table renames Shared.Table.all;
-
- Parser_Index : SAL.Base_Peek_Type;
- Config : Configuration;
-
- Local_Config_Heap : Config_Heaps.Heap_Type;
- -- We collect all the variants to enqueue, then deliver them all at
- -- once to Super, to minimizes task interactions.
-
- Use_Minimal_Complete_Actions : Boolean := False;
- Matching_Begin_Token : Token_ID := Invalid_Token_ID;
-
- function Allow_Insert_Terminal (Config : in Configuration) return Boolean
- is begin
- if Use_Minimal_Complete_Actions then
- if Table.States
(Config.Stack.Peek.State).Minimal_Complete_Action.Verb = Pause then
- -- This happens when there is an extra token after an
acceptable
- -- grammar statement. There is no production to complete, so
try
- -- other things.
- Use_Minimal_Complete_Actions := False;
- else
- if Trace_McKenzie > Detail then
- Put_Line (Super.Trace.all, Super.Label (Parser_Index), "use
Minimal_Complete_Actions");
- end if;
- return True;
- end if;
- end if;
- return None_Since_FF (Config.Ops, Delete);
- end Allow_Insert_Terminal;
-
- begin
- Super.Get (Parser_Index, Config, Config_Status);
-
- if Config_Status = All_Done then
- return;
- end if;
-
- if Trace_McKenzie > Extra then
- Base.Put ("dequeue", Super, Shared, Parser_Index, Config);
- Put_Line (Trace, Super.Label (Parser_Index), "stack: " & Image
(Config.Stack, Trace.Descriptor.all));
- end if;
-
- if Config.Current_Insert_Delete = 1 then
- -- If Config.Current_Insert_Delete > 1 then Fast_Forward failed on
this
- -- config; don't fast_forward again.
-
- case Fast_Forward (Super, Shared, Parser_Index, Local_Config_Heap,
Config) is
- when Abandon =>
- -- We know Local_Config_Heap is empty; just tell
- -- Super we are done working.
- Super.Put (Parser_Index, Local_Config_Heap);
- return;
- when Continue =>
- -- We don't increase cost for this Fast_Forward, since it is due
to a
- -- Language_Fixes.
- null;
- end case;
- end if;
-
- if Config.Error_Token.ID /= Invalid_Token_ID then
- if Shared.Language_Fixes = null then
- null;
- else
- Shared.Language_Fixes
- (Trace, Shared.Lexer, Super.Label (Parser_Index),
Shared.Table.all,
- Shared.Terminals.all, Super.Parser_State (Parser_Index).Tree,
Local_Config_Heap,
- Config);
-
- -- The solutions provided by Language_Fixes should be lower cost
than
- -- others (typically 0), so they will be checked first.
-
- if Config.Check_Status.Label = Ok then
- -- Parse table Error action.
- --
- -- We don't clear Config.Error_Token here, because
Try_Insert_Terminal calls
- -- Language_Use_Minimal_Complete_Actions, which needs it. We
only clear it
- -- when a parse results in no error (or a different error), or
a
- -- push_back moves the Current_Token.
- null;
-
- else
- -- Assume "ignore check error" is a viable solution. But give
it a
- -- cost, so a solution provided by Language_Fixes is preferred.
-
- declare
- New_State : Unknown_State_Index;
- begin
- Config.Cost := Config.Cost +
Table.McKenzie_Param.Ignore_Check_Fail;
-
- -- finish reduce.
- Config.Stack.Pop (SAL.Base_Peek_Type
(Config.Check_Token_Count));
-
- New_State := Goto_For (Table, Config.Stack (1).State,
Config.Error_Token.ID);
-
- if New_State = Unknown_State then
- if Config.Stack.Depth = 1 then
- -- Stack is empty, and we did not get Accept; really
bad syntax got
- -- us here; abandon this config. See
ada_mode-recover_bad_char.adb.
- Super.Put (Parser_Index, Local_Config_Heap);
- return;
- else
- raise SAL.Programmer_Error with
- "process_one found test case for new_state =
Unknown; old state " &
- Trimmed_Image (Config.Stack (1).State) & " nonterm "
& Image
- (Config.Error_Token.ID, Trace.Descriptor.all);
- end if;
- end if;
-
- Config.Stack.Push ((New_State,
Syntax_Trees.Invalid_Node_Index, Config.Error_Token));
-
- -- We must clear Check_Status here, so if this config comes
back
- -- here, we don't try to reduce the stack again. We also
clear
- -- Error_Token, so this doesn't look like a parse error.
- Config.Check_Status := (Label => Ok);
-
- Config.Error_Token.ID := Invalid_Token_ID;
- end;
- end if;
- end if;
- end if;
-
- if Config.Current_Insert_Delete > 1 then
- -- Fast_Forward failed on this config; no need to check it. Remove
- -- already parsed items from Insert_Delete, setting
- -- Current_Insert_Delete to 1, so it will be checked after the Ops
- -- applied below.
- Config.Insert_Delete.Delete_First (Config.Current_Insert_Delete - 1);
- Config.Current_Insert_Delete := 1;
- else
- case Check (Super, Shared, Parser_Index, Config, Local_Config_Heap) is
- when Success =>
- Super.Success (Parser_Index, Config, Local_Config_Heap);
- return;
-
- when Abandon =>
- Super.Put (Parser_Index, Local_Config_Heap);
- return;
-
- when Continue =>
- null;
-
- end case;
- end if;
-
- if Trace_McKenzie > Detail then
- Base.Put ("continuing", Super, Shared, Parser_Index, Config);
- if Trace_McKenzie > Extra then
- Put_Line (Trace, Super.Label (Parser_Index), "stack: " & Image
(Config.Stack, Trace.Descriptor.all));
- end if;
- end if;
-
- -- Grouping these operations ensures that there are no duplicate
- -- solutions found. We reset the grouping after each fast_forward.
- --
- -- All possible permutations will be explored.
-
- if Shared.Language_Use_Minimal_Complete_Actions = null then
- Use_Minimal_Complete_Actions := False;
- Matching_Begin_Token := Invalid_Token_ID;
- else
- declare
- Current_Token : Token_ID;
- Next_Token : Token_ID;
- begin
- Current_Token_ID_Peek_2
- (Shared.Terminals.all, Config.Current_Shared_Token,
Config.Insert_Delete, Config.Current_Insert_Delete,
- Super.Parser_State (Parser_Index).Prev_Deleted, Current_Token,
Next_Token);
-
- Shared.Language_Use_Minimal_Complete_Actions
- (Current_Token, Next_Token, Config,
- Use_Complete => Use_Minimal_Complete_Actions,
- Matching_Begin_Token => Matching_Begin_Token);
- end;
- end if;
-
- if None_Since_FF (Config.Ops, Delete) and then
- None_Since_FF (Config.Ops, Insert) and then
- Config.Stack.Depth > 1 and then -- can't delete the first state
- (not (Use_Minimal_Complete_Actions and then Check_Reduce_To_Start
(Super, Shared, Parser_Index, Config)))
- -- If Config reduces to the start nonterm, there's no point in
push_back.
- then
- Try_Push_Back (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
- end if;
-
- if Allow_Insert_Terminal (Config) then
- Try_Insert_Terminal
- (Super, Shared, Parser_Index, Config, Local_Config_Heap,
Use_Minimal_Complete_Actions, Matching_Begin_Token);
- end if;
-
- if Config.Current_Insert_Delete = No_Insert_Delete then
- if Config.Check_Status.Label = Ok and
- (Descriptor.String_1_ID /= Invalid_Token_ID or
Descriptor.String_2_ID /= Invalid_Token_ID) and
- (Config.String_Quote_Checked = Invalid_Line_Number or else
- Config.String_Quote_Checked < Shared.Terminals.all
(Config.Current_Shared_Token).Line)
- then
- -- See if there is a mismatched quote. The solution is to delete
- -- tokens, replacing them with a string literal. So we try this
when
- -- it is ok to try delete.
- Try_Insert_Quote (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
- end if;
-
- Try_Delete_Input (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
- end if;
-
- Super.Put (Parser_Index, Local_Config_Heap);
- exception
- when others =>
- -- Just abandon this config; tell Super we are done.
- Super.Put (Parser_Index, Local_Config_Heap);
- if Debug_Mode then
- raise;
- end if;
- end Process_One;
-
-end WisiToken.Parse.LR.McKenzie_Recover.Explore;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Exceptions;
+with WisiToken.Parse.LR.McKenzie_Recover.Parse;
+with WisiToken.Parse.LR.Parser;
+package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
+
+ procedure Do_Shift
+ (Label : in String;
+ Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type;
+ Config : in out Configuration;
+ State : in State_Index;
+ ID : in Token_ID;
+ Cost_Delta : in Integer;
+ Strategy : in Strategies)
+ is
+ McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
+
+ Op : constant Config_Op := (Insert, ID, Config.Current_Shared_Token,
State, Config.Stack.Depth);
+ begin
+ Config.Strategy_Counts (Strategy) := Config.Strategy_Counts (Strategy) +
1;
+
+ begin
+ Config.Ops.Append (Op);
+ exception
+ when SAL.Container_Full =>
+ Super.Config_Full (Parser_Index);
+ raise Bad_Config;
+ end;
+
+ if Cost_Delta = 0 then
+ Config.Cost := Config.Cost + McKenzie_Param.Insert (ID);
+ else
+ -- Cost_Delta /= 0 comes from Insert_Minimal_Complete_Actions. That
+ -- doesn't mean it is better than any other solution, so don't let
+ -- cost be 0.
+ --
+ -- We don't just eliminate all cost for Minimal_Complete_Actions;
+ -- that leads to using it far too much at the expense of better
+ -- solutions.
+ Config.Cost := Integer'Max (1, Config.Cost + McKenzie_Param.Insert
(ID) + Cost_Delta);
+ end if;
+
+ Config.Error_Token.ID := Invalid_Token_ID;
+ Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
+
+ Config.Stack.Push ((State, Syntax_Trees.Invalid_Node_Index, (ID, Virtual
=> True, others => <>)));
+ if Trace_McKenzie > Detail then
+ Base.Put
+ ((if Label'Length > 0 then Label & ": " else "") & "insert " &
Image (ID, Super.Trace.Descriptor.all),
+ Super, Shared, Parser_Index, Config);
+ end if;
+
+ Local_Config_Heap.Add (Config);
+ end Do_Shift;
+
+ procedure Do_Reduce_1
+ (Label : in String;
+ Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type;
+ Config : in out Configuration;
+ Action : in Reduce_Action_Rec;
+ Do_Language_Fixes : in Boolean := True)
+ is
+ use all type SAL.Base_Peek_Type;
+ use all type Semantic_Checks.Check_Status_Label;
+ use all type WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+
+ Prev_State : constant Unknown_State_Index := Config.Stack.Peek.State;
+
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+ Table : Parse_Table renames Shared.Table.all;
+ Nonterm : Recover_Token;
+ New_State : Unknown_State_Index;
+ begin
+ Config.Check_Status := Parse.Reduce_Stack (Shared, Config.Stack, Action,
Nonterm, Default_Virtual => True);
+ case Config.Check_Status.Label is
+ when Ok =>
+ null;
+
+ when Semantic_Checks.Error =>
+ Config.Error_Token := Nonterm;
+ Config.Check_Token_Count := Action.Token_Count;
+
+ if Do_Language_Fixes then
+ if Shared.Language_Fixes /= null then
+ Shared.Language_Fixes
+ (Super.Trace.all, Shared.Lexer, Super.Label (Parser_Index),
Shared.Table.all, Shared.Terminals.all,
+ Super.Parser_State (Parser_Index).Tree, Local_Config_Heap,
+ Config);
+ end if;
+ end if;
+
+ -- Finish the reduce; ignore the check fail.
+ Config.Stack.Pop (SAL.Base_Peek_Type (Config.Check_Token_Count));
+ Config.Error_Token.ID := Invalid_Token_ID;
+ Config.Check_Status := (Label => Ok);
+ end case;
+
+ if Config.Stack.Depth = 0 or else Config.Stack (1).State = Unknown_State
then
+ raise Bad_Config;
+ end if;
+
+ New_State := Goto_For (Table, Config.Stack (1).State,
Action.Production.LHS);
+
+ if New_State = Unknown_State then
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index), Label &
+ ": Do_Reduce_1: unknown_State " &
Config.Stack.Peek.State'Image & " " &
+ Image (Action.Production.LHS, Descriptor));
+ end if;
+ raise Bad_Config;
+ end if;
+
+ Config.Stack.Push ((New_State, Syntax_Trees.Invalid_Node_Index,
Nonterm));
+
+ if Trace_McKenzie > Extra and Label'Length > 0 then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index), Label &
+ ": state" & State_Index'Image (Prev_State) & " reduce" &
+ Ada.Containers.Count_Type'Image (Action.Token_Count) & " to " &
+ Image (Action.Production.LHS, Descriptor) & ", goto" &
+ State_Index'Image (New_State) & " via" & State_Index'Image
(Config.Stack (2).State));
+ end if;
+ end Do_Reduce_1;
+
+ procedure Do_Reduce_2
+ (Label : in String;
+ Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type;
+ Config : in out Configuration;
+ Inserted_ID : in Token_ID;
+ Cost_Delta : in Integer;
+ Strategy : in Strategies)
+ is
+ -- Perform reduce actions until shift Inserted_ID; if all succeed,
+ -- add the final configuration to the heap, return True. If a conflict
is
+ -- encountered, process the other action the same way. If a semantic
+ -- check fails, enqueue possible solutions. For parse table error
+ -- actions, or exception Bad_Config, return False.
+
+ Orig_Config : Configuration;
+ Table : Parse_Table renames Shared.Table.all;
+ Next_Action : Parse_Action_Node_Ptr := Action_For (Table, Config.Stack
(1).State, Inserted_ID);
+ begin
+ if Next_Action.Next /= null then
+ Orig_Config := Config;
+ end if;
+
+ case Next_Action.Item.Verb is
+ when Shift =>
+ Do_Shift
+ (Label, Super, Shared, Parser_Index, Local_Config_Heap, Config,
Next_Action.Item.State, Inserted_ID,
+ Cost_Delta, Strategy);
+
+ when Reduce =>
+ Do_Reduce_1 (Label, Super, Shared, Parser_Index, Local_Config_Heap,
Config, Next_Action.Item);
+ Do_Reduce_2
+ (Label, Super, Shared, Parser_Index, Local_Config_Heap, Config,
Inserted_ID, Cost_Delta, Strategy);
+
+ when Accept_It =>
+ raise SAL.Programmer_Error with "found test case for Do_Reduce
Accept_It";
+
+ when Error =>
+ null;
+ end case;
+
+ loop
+ exit when Next_Action.Next = null;
+ -- There is a conflict; create a new config to shift or reduce.
+ declare
+ New_Config : Configuration := Orig_Config;
+ Action : Parse_Action_Rec renames Next_Action.Next.Item;
+ begin
+ case Action.Verb is
+ when Shift =>
+ Do_Shift
+ (Label, Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Action.State, Inserted_ID,
+ Cost_Delta, Strategy);
+
+ when Reduce =>
+ Do_Reduce_1 (Label, Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action);
+ Do_Reduce_2
+ (Label, Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Inserted_ID,
+ Cost_Delta, Strategy);
+
+ when Accept_It =>
+ raise SAL.Programmer_Error with "found test case for Do_Reduce
Accept_It conflict";
+
+ when Error =>
+ null;
+ end case;
+ end;
+
+ Next_Action := Next_Action.Next;
+ end loop;
+ exception
+ when Bad_Config =>
+ if Debug_Mode then
+ raise;
+ end if;
+ end Do_Reduce_2;
+
+ function Fast_Forward
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type;
+ Config : in out Configuration)
+ return Non_Success_Status
+ is
+ -- Apply the ops in Config; they were inserted by some fix.
+ -- Return Abandon if Config should be abandoned, otherwise Continue.
+ -- Leaves Config.Error_Token, Config.Check_Status set.
+ --
+ -- If there are conflicts, all are parsed; if more than one succeed,
+ -- all are enqueued in Local_Config_Heap, and this returns Abandon.
+
+ use all type SAL.Base_Peek_Type;
+ use all type Ada.Containers.Count_Type;
+
+ Parse_Items : Parse.Parse_Item_Arrays.Vector;
+
+ Dummy : Boolean := Parse.Parse
+ (Super, Shared, Parser_Index, Parse_Items, Config,
+ Shared_Token_Goal => Invalid_Token_Index,
+ All_Conflicts => True,
+ Trace_Prefix => "fast_forward");
+ begin
+ -- This solution is from Language_Fixes; any cost increase is done
there.
+
+ if Parse_Items.Length = 1 then
+ declare
+ Item : Parse.Parse_Item renames Parse_Items (1);
+ begin
+ if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
+ -- Item.Config.Error_Token.ID, Check_Status are correct.
+ Config := Item.Config;
+
+ Config.Ops.Append ((Fast_Forward, Config.Current_Shared_Token));
+ Config.Minimal_Complete_State := None;
+ Config.Matching_Begin_Done := False;
+ return Continue;
+ else
+ return Abandon;
+ end if;
+ end;
+ else
+ for Item of Parse_Items loop
+ if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
+ Item.Config.Ops.Append ((Fast_Forward,
Item.Config.Current_Shared_Token));
+ Item.Config.Minimal_Complete_State := None;
+ Item.Config.Matching_Begin_Done := False;
+ Local_Config_Heap.Add (Item.Config);
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("fast forward enqueue", Super, Shared,
Parser_Index, Item.Config);
+ end if;
+ end if;
+ end loop;
+ return Abandon;
+ end if;
+ exception
+ when Bad_Config =>
+ return Abandon;
+ when SAL.Container_Full =>
+ Super.Config_Full (Parser_Index);
+ return Abandon;
+ end Fast_Forward;
+
+ function Check
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ return Check_Status
+ is
+ use all type Semantic_Checks.Check_Status_Label;
+
+ McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
+
+ Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ Result : Check_Status := Continue;
+
+ function Max_Push_Back_Token_Index (Ops : in Config_Op_Arrays.Vector)
return WisiToken.Base_Token_Index
+ is
+ Result : WisiToken.Base_Token_Index :=
WisiToken.Base_Token_Index'First;
+ begin
+ -- For Ops since last Fast_Forward, return maximum Token_Index in a
+ -- Push_Back. If there are no such ops, return a value that will be
+ -- less than the current token index.
+ for Op of reverse Ops loop
+ exit when Op.Op = Fast_Forward;
+ if Op.Op = Push_Back and then Op.PB_Token_Index > Result then
+ Result := Op.PB_Token_Index;
+ end if;
+ end loop;
+ return Result;
+ end Max_Push_Back_Token_Index;
+
+ begin
+ if Parse.Parse
+ (Super, Shared, Parser_Index, Parse_Items, Config,
Config.Resume_Token_Goal,
+ All_Conflicts => False,
+ Trace_Prefix => "check")
+ then
+ Config.Error_Token.ID := Invalid_Token_ID;
+ -- FIXME: if there were conflicts, enqueue them; they might yield a
+ -- cheaper or same cost solution?
+ return Success;
+ end if;
+
+ -- Set Config.error to reflect failure, if it is at current token, so
+ -- Use_Minimal_Complete_Actions can see it.
+ declare
+ Item : Parse.Parse_Item renames Parse_Items
(Parse_Items.First_Index);
+ Parsed_Config : Configuration renames Item.Config;
+ begin
+ if Parsed_Config.Check_Status.Label /= Ok then
+ Config.Check_Status := Parsed_Config.Check_Status;
+ Config.Error_Token := Parsed_Config.Error_Token;
+
+ -- Explore cannot fix a check fail; only Language_Fixes can. The
+ -- "ignore error" case is handled immediately on return from
+ -- Language_Fixes in Process_One, below.
+ Result := Abandon;
+
+ elsif Parsed_Config.Error_Token.ID /= Invalid_Token_ID then
+
+ if Item.Shift_Count = 0 then
+ Config.Error_Token := Parsed_Config.Error_Token;
+ Config.Check_Status := (Label => Ok);
+ else
+ -- Error is not at current token, but Explore might find
something
+ -- that will help (see test_mckenzie_recover.adb Extra_Begin).
On the
+ -- other hand, this can lead to lots of bogus configs (see
+ -- If_In_Handler).
+ Config.Error_Token.ID := Invalid_Token_ID;
+ Config.Check_Status := (Label => Ok);
+ end if;
+ end if;
+ end;
+
+ -- All Parse_Items either failed or were not parsed; if they failed
+ -- and made progress, enqueue them so Language_Fixes can try to fix
+ -- them.
+ for Item of Parse_Items loop
+ if Item.Config.Error_Token.ID /= Invalid_Token_ID and then
+ Item.Shift_Count > 0 and then
+ Max_Push_Back_Token_Index (Item.Config.Ops) <
Item.Config.Current_Shared_Token - 1
+ then
+ -- Some progress was made; explore at the new error point. It is
+ -- likely that there is only one actual error point, and this
moves
+ -- away from it, so we give it a cost.
+ begin
+ Item.Config.Minimal_Complete_State := None;
+ Item.Config.Matching_Begin_Done := False;
+ if Item.Config.Ops (Item.Config.Ops.Last_Index).Op =
Fast_Forward then
+
+ Item.Config.Cost := Item.Config.Cost +
McKenzie_Param.Fast_Forward;
+
+ Item.Config.Ops (Item.Config.Ops.Last_Index).FF_Token_Index
:=
+ Item.Config.Current_Shared_Token;
+
+ else
+ Item.Config.Cost := Item.Config.Cost +
McKenzie_Param.Fast_Forward;
+
+ Item.Config.Ops.Append ((Fast_Forward,
Item.Config.Current_Shared_Token));
+ end if;
+ exception
+ when SAL.Container_Full =>
+ Super.Config_Full (Parser_Index);
+ raise Bad_Config;
+ end;
+ Local_Config_Heap.Add (Item.Config);
+ if Trace_McKenzie > Detail then
+ Base.Put ("new error point ", Super, Shared, Parser_Index,
Item.Config);
+ end if;
+ end if;
+ end loop;
+
+ if Trace_McKenzie > Extra then
+ Put_Line (Super.Trace.all, Super.Label (Parser_Index), "check result:
" & Result'Image);
+ end if;
+ return Result;
+ exception
+ when Bad_Config =>
+ return Abandon;
+ end Check;
+
+ function Check_Reduce_To_Start
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Orig_Config : in Configuration)
+ return Boolean
+ -- Returns True if Config reduces to the start nonterm.
+ is
+ Table : Parse_Table renames Shared.Table.all;
+
+ function To_Reduce_Action (Item : in Minimal_Action) return
Reduce_Action_Rec
+ is begin
+ return (Reduce, (Item.Nonterm, 0), null, null, Item.Token_Count);
+ end To_Reduce_Action;
+
+ Local_Config_Heap : Config_Heaps.Heap_Type; -- never used, because
Do_Language_Fixes is False.
+
+ Config : Configuration := Orig_Config;
+ Actions : Minimal_Action_Arrays.Vector := Table.States
(Config.Stack.Peek.State).Minimal_Complete_Actions;
+ begin
+ loop
+ case Actions.Length is
+ when 0 =>
+ if (for some Item of Table.States (Config.Stack.Peek.State).Kernel
=>
+ Item.LHS = Super.Trace.Descriptor.Accept_ID)
+ then
+ return True;
+ else
+ return False;
+ end if;
+
+ when 1 =>
+ case Actions (Actions.First_Index).Verb is
+ when Shift =>
+ return False;
+
+ when Reduce =>
+ Do_Reduce_1
+ ("", Super, Shared, Parser_Index, Local_Config_Heap, Config,
+ To_Reduce_Action (Actions (Actions.First_Index)),
+ Do_Language_Fixes => False);
+
+ Actions := Table.States
(Config.Stack.Peek.State).Minimal_Complete_Actions;
+ end case;
+
+ when others =>
+ return False;
+ end case;
+
+ -- loop only exits via returns above
+ end loop;
+ end Check_Reduce_To_Start;
+
+ procedure Try_Push_Back
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+ McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
+
+ Token : constant Recover_Token := Config.Stack (1).Token;
+ begin
+ -- Try pushing back the stack top, to allow insert and other
+ -- operations at that point.
+ --
+ -- Since we are not actually changing the source text, it is tempting
+ -- to give this operation zero cost. But then we keep doing push_back
+ -- forever, making no progress. So we give it a cost.
+
+ if not Token.Virtual then
+ -- If Virtual, this is from earlier in this recover session; no point
+ -- in trying to redo it.
+
+ declare
+ New_Config : Configuration := Config;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ New_Config.Stack.Pop;
+
+ if Token.Min_Terminal_Index = Invalid_Token_Index then
+ -- Token is empty; Config.current_shared_token does not
change, no
+ -- cost increase.
+ New_Config.Ops.Append ((Push_Back, Token.ID,
New_Config.Current_Shared_Token));
+ else
+ New_Config.Cost := New_Config.Cost + McKenzie_Param.Push_Back
(Token.ID);
+ New_Config.Ops.Append ((Push_Back, Token.ID,
Token.Min_Terminal_Index));
+ New_Config.Current_Shared_Token := Token.Min_Terminal_Index;
+ end if;
+ New_Config.Strategy_Counts (Explore_Table) :=
New_Config.Strategy_Counts (Explore_Table) + 1;
+
+ Local_Config_Heap.Add (New_Config);
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("push_back " & Image (Token.ID,
Trace.Descriptor.all), Super, Shared,
+ Parser_Index, New_Config);
+ end if;
+ end;
+ end if;
+ exception
+ when SAL.Container_Full =>
+ Super.Config_Full (Parser_Index);
+ end Try_Push_Back;
+
+ function Just_Pushed_Back_Or_Deleted (Config : in Configuration; ID : in
Token_ID) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Config.Ops.Length = 0 then
+ return False;
+ else
+ declare
+ Last_Op : Config_Op renames Config.Ops (Config.Ops.Last_Index);
+ begin
+ return Last_Op = (Push_Back, ID, Config.Current_Shared_Token) or
+ Last_Op = (Push_Back, ID, Config.Current_Shared_Token - 1) or
+ Last_Op = (Delete, ID, Config.Current_Shared_Token) or
+ Last_Op = (Delete, ID, Config.Current_Shared_Token - 1);
+ end;
+ end if;
+ end Just_Pushed_Back_Or_Deleted;
+
+ procedure Try_Undo_Reduce
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+ McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
+
+ Token : constant Recover_Token := Config.Stack (1).Token;
+ begin
+ -- Try expanding the nonterm on the stack top, to allow pushing_back
+ -- its components, or insert and other operations at that point.
+
+ if Undo_Reduce_Valid (Config.Stack, Super.Parser_State
(Parser_Index).Tree) then
+ declare
+ New_Config : Configuration := Config;
+ Token_Count : Ada.Containers.Count_Type;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ Token_Count := Undo_Reduce (New_Config.Stack, Super.Parser_State
(Parser_Index).Tree);
+
+ if Token.Min_Terminal_Index /= Invalid_Token_Index then
+ -- If Token is empty no cost increase.
+ New_Config.Cost := New_Config.Cost + McKenzie_Param.Undo_Reduce
(Token.ID);
+ end if;
+
+ New_Config.Ops.Append ((Undo_Reduce, Token.ID, Token_Count));
+
+ New_Config.Strategy_Counts (Explore_Table) :=
New_Config.Strategy_Counts (Explore_Table) + 1;
+
+ Local_Config_Heap.Add (New_Config);
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("undo_reduce " & Image (Token.ID,
Trace.Descriptor.all), Super, Shared,
+ Parser_Index, New_Config);
+ end if;
+ end;
+ end if;
+ exception
+ when SAL.Container_Full =>
+ Super.Config_Full (Parser_Index);
+ end Try_Undo_Reduce;
+
+ procedure Insert_From_Action_List
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in Configuration;
+ Minimal_Insert : in Token_ID_Arrays.Vector;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ Table : Parse_Table renames Shared.Table.all;
+ EOF_ID : Token_ID renames Super.Trace.Descriptor.EOI_ID;
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+
+ -- Find terminal insertions from the current state's action_list to try.
+ --
+ -- We perform any needed reductions and one shift, so the config is
+ -- in a consistent state, and enqueue the result. If there are any
+ -- conflicts or semantic check fails encountered, they create other
+ -- configs to enqueue.
+
+ I : Action_List_Iterator := First (Table.States
(Config.Stack.Peek.State));
+
+ Current_Token : constant Token_ID := Current_Token_ID_Peek
+ (Shared.Terminals.all, Config.Current_Shared_Token,
Config.Insert_Delete, Config.Current_Insert_Delete);
+
+ Cached_Config : Configuration;
+ Cached_Action : Reduce_Action_Rec;
+ -- Most of the time, all the reductions in a state are the same. So
+ -- we cache the first result. This includes one reduction; if an
+ -- associated semantic check failed, this does not include the fixes.
+ begin
+
+ loop
+ exit when I.Is_Done;
+
+ declare
+ ID : constant Token_ID := I.Symbol;
+ Action : Parse_Action_Rec renames I.Action;
+ begin
+ if ID /= EOF_ID and then -- can't insert eof
+ ID /= Invalid_Token_ID -- invalid when Verb = Error
+ then
+ if Just_Pushed_Back_Or_Deleted (Config, ID) then
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index), "Insert:
abandon " & Image (ID, Descriptor) &
+ ": undo push_back");
+ end if;
+ elsif ID = Current_Token then
+ -- This needed because we allow explore when the error is
not at the
+ -- explore point; it prevents inserting useless tokens (ie
+ -- 'identifier ;' in ada_lite).
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index), "Insert:
abandon " & Image (ID, Descriptor) &
+ ": current token");
+ end if;
+
+ elsif (for some Minimal of Minimal_Insert => ID = Minimal) then
+ -- Was inserted by Insert_Minimal_Complete_Actions
+ null;
+
+ else
+ case Action.Verb is
+ when Shift =>
+ declare
+ New_Config : Configuration := Config;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ Do_Shift
+ ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action.State, ID,
+ Cost_Delta => 0,
+ Strategy => Explore_Table);
+ end;
+
+ when Reduce =>
+ if not Equal (Action, Cached_Action) then
+ declare
+ New_Config : Configuration := Config;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ Do_Reduce_1 ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action);
+ Cached_Config := New_Config;
+ Cached_Action := Action;
+
+ Do_Reduce_2
+ ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
+ Cost_Delta => 0,
+ Strategy => Explore_Table);
+ end;
+
+ else
+ declare
+ New_Config : Configuration := Cached_Config;
+ begin
+ Do_Reduce_2
+ ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
+ Cost_Delta => 0,
+ Strategy => Explore_Table);
+ end;
+ end if;
+
+ when Accept_It =>
+ raise SAL.Programmer_Error with "found test case for
Process_One Accept_It";
+
+ when Error =>
+ null;
+ end case;
+ end if;
+ end if;
+ end;
+ I.Next;
+ end loop;
+ end Insert_From_Action_List;
+
+ function Insert_Minimal_Complete_Actions
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Orig_Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ return Token_ID_Arrays.Vector
+ -- Return tokens inserted (empty if none).
+ is
+ use all type SAL.Base_Peek_Type;
+ use Ada.Containers;
+
+ Table : Parse_Table renames Shared.Table.all;
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+ Inserted : Token_ID_Array (1 .. 10) := (others => Invalid_Token_ID);
+ Inserted_Last : Integer := Inserted'First - 1;
+
+ type Work_Item is record
+ Action : Minimal_Action;
+ Config : Configuration;
+ end record;
+
+ package Item_Queues is new SAL.Gen_Unbounded_Definite_Queues (Work_Item);
+
+ Work : Item_Queues.Queue;
+
+ function To_Reduce_Action (Action : in Minimal_Action) return
Reduce_Action_Rec
+ is (Reduce, (Action.Nonterm, 0), null, null, Action.Token_Count);
+
+ procedure Minimal_Do_Shift (Action : in Minimal_Action; Config : in out
Configuration)
+ is begin
+ -- Check for a cycle. We compare stack depth as well as state, so
+ -- nested compound statements don't look like a cycle; see
+ -- test_mckenzie_recover Push_Back_1. We don't check for cycles in
+ -- Insert_From_Action_List because we assume cost eliminates cycles
+ -- there; Minimal_Complete_Delta is usually negative, so cost does
+ -- not necessarily increase here.
+ for Op of reverse Config.Ops loop
+ if Op.Op = Insert and then
+ (Op.Ins_ID = Action.ID and Op.State = Action.State and
Op.Stack_Depth = Config.Stack.Depth)
+ then
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: abandon " &
+ Image (Action.ID, Descriptor) & Action.State'Image & ":
cycle");
+ end if;
+ return;
+ end if;
+ end loop;
+
+ -- We don't check Action.ID = Current_Token; the error is at the
+ -- explore point, so ID is valid.
+
+ if Just_Pushed_Back_Or_Deleted (Config, Action.ID) then
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
+ "Minimal_Complete_Actions: abandon " & Image (Action.ID,
Descriptor) & ": undo push back");
+ end if;
+ else
+ Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+ Config.Minimal_Complete_State := Active;
+ Inserted_Last := Inserted_Last + 1;
+ Inserted (Inserted_Last) := Action.ID;
+
+ Do_Shift
+ ("Minimal_Complete_Actions", Super, Shared, Parser_Index,
Local_Config_Heap, Config,
+ Action.State, Action.ID,
Table.McKenzie_Param.Minimal_Complete_Cost_Delta,
+ Strategy => Minimal_Complete);
+ end if;
+ end Minimal_Do_Shift;
+
+ procedure Enqueue_Min_Actions
+ (Label : in String;
+ Actions : in Minimal_Action_Arrays.Vector;
+ Recursive : in Boolean;
+ Config : in Configuration;
+ Reduce_Only : in Boolean)
+ is
+ use SAL;
+ Length : array (Actions.First_Index .. Actions.Last_Index) of
Count_Type := (others => Count_Type'Last);
+
+ Item_Not_Recursive : array (Actions.First_Index ..
Actions.Last_Index) of Boolean := (others => False);
+
+ Not_Recursive_Count : Count_Type := 0;
+ Min_Length : Count_Type := Count_Type'Last;
+ Use_Recursive : Boolean;
+ begin
+ -- Enqueue non-minimal actions on Work,
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: " & Label &
+ Image (Actions, Descriptor) & (if Recursive then " recursive"
else ""));
+ end if;
+
+ if Actions.Length = 0 then
+ return;
+ elsif Actions.Length = 1 then
+ if (not Reduce_Only) or Actions (Actions.First_Index).Verb =
Reduce then
+ Work.Add ((Actions (Actions.First_Index), Config));
+ end if;
+ return;
+ end if;
+
+ for I in Actions.First_Index .. Actions.Last_Index loop
+ declare
+ Action : Minimal_Action renames Actions (I);
+ Next_State : constant State_Index :=
+ (case Action.Verb is
+ when Shift => Action.State,
+ when Reduce => Goto_For
+ (Shared.Table.all,
+ Config.Stack.Peek (Base_Peek_Type (Action.Token_Count) +
1).State,
+ Action.Nonterm));
+ Before_Dot : constant Token_ID :=
+ (case Action.Verb is
+ when Shift => Action.ID,
+ when Reduce => Action.Nonterm);
+ Kernel : Kernel_Info_Arrays.Vector renames
Shared.Table.States (Next_State).Kernel;
+ begin
+ if (not Reduce_Only) or Action.Verb = Reduce then
+ for Item of Kernel loop
+ Item_Not_Recursive (I) := Item_Not_Recursive (I) or not
Item.Recursive;
+ if Item.Before_Dot = Before_Dot and
+ Item.Length_After_Dot < Length (I)
+ then
+ Length (I) := Item.Length_After_Dot;
+ if Length (I) < Min_Length then
+ Min_Length := Length (I);
+ end if;
+ end if;
+ end loop;
+ end if;
+ end;
+ if Item_Not_Recursive (I) then
+ Not_Recursive_Count := Not_Recursive_Count + 1;
+ end if;
+ end loop;
+
+ Use_Recursive := Recursive and Not_Recursive_Count > 0 and
Not_Recursive_Count < Actions.Length;
+
+ for I in Length'Range loop
+ if (Use_Recursive and Item_Not_Recursive (I)) or ((not
Use_Recursive) and Length (I) = Min_Length) then
+ Work.Add ((Actions (I), Config));
+ elsif Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: drop " &
+ Image (Actions (I), Descriptor));
+ end if;
+ end loop;
+ end Enqueue_Min_Actions;
+
+ begin
+ if Orig_Config.Stack.Depth = 1 then
+ -- Get here with an empty source file, or a syntax error on the first
+ -- token.
+ return Token_ID_Arrays.Empty_Vector;
+
+ elsif Orig_Config.Minimal_Complete_State = Done then
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: done");
+ end if;
+ return Token_ID_Arrays.Empty_Vector;
+ end if;
+
+ Enqueue_Min_Actions
+ ("",
+ Table.States (Orig_Config.Stack.Peek.State).Minimal_Complete_Actions,
+ Table.States
(Orig_Config.Stack.Peek.State).Minimal_Complete_Actions_Recursive,
+ Orig_Config, Reduce_Only => False);
+
+ loop
+ exit when Work.Is_Empty;
+
+ declare
+ Item : Work_Item := Work.Get;
+ begin
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: dequeue work item " &
+ Image (Item.Action, Descriptor));
+ end if;
+
+ case Item.Action.Verb is
+ when Reduce =>
+ -- Do a reduce, look at resulting state. Keep reducing until
we can't
+ -- anymore.
+ declare
+ Reduce_Action : Reduce_Action_Rec := To_Reduce_Action
(Item.Action);
+ Actions : Minimal_Action_Arrays.Vector;
+ Recursive : Boolean;
+ begin
+ loop
+ Do_Reduce_1
+ ("Minimal_Complete_Actions", Super, Shared,
Parser_Index, Local_Config_Heap, Item.Config,
+ Reduce_Action,
+ Do_Language_Fixes => False);
+
+ Actions := Table.States
(Item.Config.Stack.Peek.State).Minimal_Complete_Actions;
+ Recursive := Table.States
(Item.Config.Stack.Peek.State).Minimal_Complete_Actions_Recursive;
+
+ case Actions.Length is
+ when 0 =>
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
+ "Minimal_Complete_Actions abandoned: no
actions");
+ end if;
+ exit;
+ when 1 =>
+ case Actions (Actions.First_Index).Verb is
+ when Shift =>
+ Minimal_Do_Shift (Actions (Actions.First_Index),
Item.Config);
+ exit;
+ when Reduce =>
+ Reduce_Action := To_Reduce_Action (Actions
(Actions.First_Index));
+ end case;
+
+ when others =>
+ Enqueue_Min_Actions ("multiple actions ", Actions,
Recursive, Item.Config, Reduce_Only => True);
+ exit;
+ end case;
+ end loop;
+ end;
+
+ when Shift =>
+ Minimal_Do_Shift (Item.Action, Item.Config);
+ end case;
+ end;
+ end loop;
+
+ if Inserted_Last = Inserted'First - 1 then
+ if Orig_Config.Minimal_Complete_State = Active then
+ Orig_Config.Minimal_Complete_State := Done;
+ end if;
+ end if;
+
+ return To_Vector (Inserted (1 .. Inserted_Last));
+ end Insert_Minimal_Complete_Actions;
+
+ procedure Insert_Matching_Begin
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type;
+ Matching_Begin_Tokens : in Token_ID_Arrays.Vector)
+ is
+ Table : Parse_Table renames Shared.Table.all;
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+ begin
+ -- We don't check for insert = current token; that's either ok or a
+ -- severe bug in Language_Use_Minimal_Complete.
+
+ if Config.Matching_Begin_Done then
+ if Trace_McKenzie > Extra then
+ Put_Line (Super.Trace.all, Super.Label (Parser_Index),
"Matching_Begin abandoned: done");
+ end if;
+ return;
+ end if;
+
+ if Just_Pushed_Back_Or_Deleted (Config, Matching_Begin_Tokens
(Matching_Begin_Tokens.First_Index)) then
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index), "Matching_Begin
abandoned " &
+ Image (Matching_Begin_Tokens
(Matching_Begin_Tokens.First_Index), Descriptor) & ": undo push_back");
+ end if;
+ return;
+ end if;
+
+ -- Set up for Parse
+ declare
+ New_Config : Configuration := Config;
+ begin
+ for ID of Matching_Begin_Tokens loop
+ Insert (New_Config, ID);
+ end loop;
+
+ declare
+ use all type SAL.Base_Peek_Type;
+ Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ Dummy : constant Boolean := Parse.Parse
+ (Super, Shared, Parser_Index, Parse_Items, New_Config,
+ Shared_Token_Goal => Invalid_Token_Index,
+ All_Conflicts => True,
+ Trace_Prefix => "parse Matching_Begin");
+ begin
+ for Item of Parse_Items loop
+ if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
+ Item.Config.Matching_Begin_Done := True;
+ Item.Config.Cost := Item.Config.Cost +
Table.McKenzie_Param.Matching_Begin;
+ Item.Config.Strategy_Counts (Matching_Begin) :=
Item.Config.Strategy_Counts (Matching_Begin) + 1;
+ Item.Config.Error_Token.ID := Invalid_Token_ID;
+ Item.Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ if Trace_McKenzie > Detail then
+ Base.Put
+ ("Matching_Begin: insert " & Image
(Matching_Begin_Tokens, Descriptor),
+ Super, Shared, Parser_Index, Item.Config);
+ end if;
+ Local_Config_Heap.Add (Item.Config);
+ else
+ if Trace_McKenzie > Detail then
+ Base.Put
+ ("Matching_Begin: abandon " & Image
(Matching_Begin_Tokens, Descriptor) & ": parse fail",
+ Super, Shared, Parser_Index, Item.Config);
+ end if;
+ end if;
+ end loop;
+ end;
+ end;
+ exception
+ when SAL.Container_Full =>
+ Super.Config_Full (Parser_Index);
+ end Insert_Matching_Begin;
+
+ procedure Try_Insert_Terminal
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ use all type
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ use all type Ada.Containers.Count_Type;
+ Tokens : Token_ID_Array_1_3;
+ Matching_Begin_Tokens : Token_ID_Arrays.Vector;
+ Forbid_Minimal_Insert : Boolean := False;
+
+ Minimal_Inserted : Token_ID_Arrays.Vector;
+ begin
+ if Shared.Language_Matching_Begin_Tokens /= null then
+ Current_Token_ID_Peek_3
+ (Shared.Terminals.all, Config.Current_Shared_Token,
Config.Insert_Delete, Config.Current_Insert_Delete,
+ Super.Parser_State (Parser_Index).Prev_Deleted, Tokens);
+
+ Shared.Language_Matching_Begin_Tokens (Tokens, Config,
Matching_Begin_Tokens, Forbid_Minimal_Insert);
+ end if;
+
+ if not Forbid_Minimal_Insert then
+ -- See test_mckenzie_recover.adb Forbid_Minimal_Insert for rationale.
+ Minimal_Inserted := Insert_Minimal_Complete_Actions
+ (Super, Shared, Parser_Index, Config, Local_Config_Heap);
+ end if;
+
+ if Matching_Begin_Tokens.Length > 0 then
+ Insert_Matching_Begin (Super, Shared, Parser_Index, Config,
Local_Config_Heap, Matching_Begin_Tokens);
+ end if;
+
+ -- We always do all three Insert_Minimal_Complete (unless
+ -- Forbid_Minimal_Insert), Insert_Matching_Begin,
+ -- Insert_From_Action_List; in general it's not possible to tell when
+ -- one will be better (see test_mckenzie_recover.adb
+ -- Always_Minimal_Complete, Always_Matching_Begin).
+ -- Insert_From_Action does not insert the Minimal_Inserted tokens,
+ -- and it will never insert the Matching_Begin_Tokens, so there is no
+ -- duplication. Insert_From_Action_List will normally be more
+ -- expensive.
+ Insert_From_Action_List (Super, Shared, Parser_Index, Config,
Minimal_Inserted, Local_Config_Heap);
+
+ -- It is tempting to use the Goto_List to find nonterms to insert.
+ -- But that can easily lead to error states, and it turns out to be
+ -- not useful, especially if the grammar has been relaxed so most
+ -- expressions and lists can be empty.
+
+ exception
+ when Bad_Config =>
+ null;
+ end Try_Insert_Terminal;
+
+ procedure Try_Insert_Quote
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ use all type Parser.Language_String_ID_Set_Access;
+
+ Descriptor : WisiToken.Descriptor renames Shared.Trace.Descriptor.all;
+ Check_Limit : WisiToken.Token_Index renames
Shared.Table.McKenzie_Param.Check_Limit;
+
+ Current_Line : constant Line_Number_Type :=
Shared.Terminals.all (Config.Current_Shared_Token).Line;
+ Lexer_Error_Token_Index : Base_Token_Index;
+ Lexer_Error_Token : Base_Token;
+
+ function Recovered_Lexer_Error (Line : in Line_Number_Type) return
Base_Token_Index
+ is begin
+ -- We are assuming the list of lexer errors is short, so binary
+ -- search would not be significantly faster.
+ for Err of reverse Shared.Lexer.Errors loop
+ if Err.Recover_Token /= Invalid_Token_Index and then
+ Shared.Terminals.all (Err.Recover_Token).Line = Line
+ then
+ return Err.Recover_Token;
+ end if;
+ end loop;
+ return Invalid_Token_Index;
+ end Recovered_Lexer_Error;
+
+ function String_ID_Set (String_ID : in Token_ID) return Token_ID_Set
+ is begin
+ if Shared.Language_String_ID_Set = null then
+ return (String_ID .. String_ID => True);
+ else
+ return Shared.Language_String_ID_Set (Descriptor, String_ID);
+ end if;
+ end String_ID_Set;
+
+ procedure String_Literal_In_Stack
+ (New_Config : in out Configuration;
+ Matching : in SAL.Peek_Type;
+ String_Literal_ID : in Token_ID)
+ is
+ Saved_Shared_Token : constant WisiToken.Token_Index :=
New_Config.Current_Shared_Token;
+
+ Tok : Recover_Token;
+ J : WisiToken.Token_Index;
+ Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ begin
+ -- Matching is the index of a token on New_Config.Stack containing a
string
+ -- literal. Push back thru that token, then delete all tokens after
+ -- the string literal to Saved_Shared_Token.
+ for I in 1 .. Matching loop
+ Tok := New_Config.Stack.Pop.Token;
+ New_Config.Ops.Append ((Push_Back, Tok.ID,
Tok.Min_Terminal_Index));
+ end loop;
+
+ New_Config.Current_Shared_Token := Tok.Min_Terminal_Index;
+
+ -- Find last string literal in pushed back terminals.
+ J := Saved_Shared_Token - 1;
+ loop
+ exit when Shared.Terminals.all (J).ID = String_Literal_ID;
+ J := J - 1;
+ end loop;
+
+ begin
+ if Parse.Parse
+ (Super, Shared, Parser_Index, Parse_Items, New_Config,
+ Shared_Token_Goal => J,
+ All_Conflicts => False,
+ Trace_Prefix => "insert quote parse pushback")
+ then
+ -- The non-deleted tokens parsed without error. We don't care
if any
+ -- conflicts were encountered; we are not using the parse
result.
+ New_Config := Parse_Items (1).Config;
+ New_Config.Ops.Append ((Fast_Forward,
New_Config.Current_Shared_Token));
+ else
+ raise SAL.Programmer_Error;
+ end if;
+ exception
+ when Bad_Config =>
+ raise SAL.Programmer_Error;
+ end;
+ J := New_Config.Current_Shared_Token; -- parse result
+ loop
+ exit when J = Saved_Shared_Token;
+ New_Config.Ops.Append ((Delete, Shared.Terminals.all (J).ID, J));
+ J := J + 1;
+ end loop;
+
+ New_Config.Current_Shared_Token := Saved_Shared_Token;
+
+ end String_Literal_In_Stack;
+
+ procedure Finish
+ (Label : in String;
+ New_Config : in out Configuration;
+ First, Last : in Base_Token_Index)
+ is begin
+ -- Delete tokens First .. Last; either First - 1 or Last + 1 should
+ -- be a String_Literal. Leave Current_Shared_Token at Last + 1.
+
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
+
+ -- This is a guess, so we give it a nominal cost
+ New_Config.Cost := New_Config.Cost + 1;
+
+ for I in First .. Last loop
+ New_Config.Ops.Append ((Delete, Shared.Terminals.all (I).ID, I));
+ end loop;
+ New_Config.Current_Shared_Token := Last + 1;
+
+ -- Let explore do insert after these deletes.
+ New_Config.Ops.Append ((Fast_Forward,
New_Config.Current_Shared_Token));
+
+ if New_Config.Resume_Token_Goal - Check_Limit <
New_Config.Current_Shared_Token then
+ New_Config.Resume_Token_Goal := New_Config.Current_Shared_Token +
Check_Limit;
+ if Trace_McKenzie > Detail then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"resume_token_goal:" & WisiToken.Token_Index'Image
+ (New_Config.Resume_Token_Goal));
+ end if;
+ end if;
+
+ New_Config.Strategy_Counts (String_Quote) :=
New_Config.Strategy_Counts (String_Quote) + 1;
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("insert missing quote " & Label & " ", Super, Shared,
Parser_Index, New_Config);
+ end if;
+ exception
+ when SAL.Container_Full =>
+ Super.Config_Full (Parser_Index);
+ raise Bad_Config;
+ end Finish;
+
+ begin
+ -- When the lexer finds an unbalanced quote, it inserts a virtual
+ -- balancing quote at the same character position as the unbalanced
+ -- quote, returning an empty string literal token there. The parser
+ -- does not see that as an error; it encounters a syntax error
+ -- before, at, or after that string literal.
+ --
+ -- Here we assume the parse error in Config.Error_Token is due to
+ -- putting the balancing quote in the wrong place, and attempt to
+ -- find a better place to put the balancing quote. Then all tokens
+ -- from the balancing quote to the unbalanced quote are now part of a
+ -- string literal, so delete them, leaving just the string literal
+ -- created by Lexer error recovery.
+
+ -- First we check to see if there is an unbalanced quote in the
+ -- current line; if not, just return. Some lexer errors are for other
+ -- unrecognized characters; see ada_mode-recover_bad_char.adb.
+ --
+ -- An alternate strategy is to treat the lexer error as a parse error
+ -- immediately, but that complicates the parse logic.
+
+ Config.String_Quote_Checked := Current_Line;
+
+ Lexer_Error_Token_Index := Recovered_Lexer_Error (Current_Line);
+
+ if Lexer_Error_Token_Index = Invalid_Token_Index then
+ return;
+ end if;
+
+ Lexer_Error_Token := Shared.Terminals.all (Lexer_Error_Token_Index);
+
+ -- It is not possible to tell where the best place to put the
+ -- balancing quote is, so we always try all reasonable places.
+
+ if Lexer_Error_Token.Byte_Region.First =
Config.Error_Token.Byte_Region.First then
+ -- The parse error token is the string literal at the lexer error.
+ --
+ -- case a: Insert the balancing quote somewhere before the error
+ -- point. There is no way to tell how far back to put the balancing
+ -- quote, so we just do one non-empty token. See
+ -- test_mckenzie_recover.adb String_Quote_0. So far we have not found
+ -- a test case for more than one token.
+ declare
+ New_Config : Configuration := Config;
+ Token : Recover_Token;
+ begin
+ loop
+ Token := New_Config.Stack.Pop.Token;
+ if Token.Byte_Region /= Null_Buffer_Region then
+ New_Config.Ops.Append ((Push_Back, Token.ID,
Token.Min_Terminal_Index));
+ exit;
+ end if;
+ end loop;
+
+ Finish ("a", New_Config, Token.Min_Terminal_Index,
Config.Current_Shared_Token - 1);
+ Local_Config_Heap.Add (New_Config);
+ end;
+
+ -- Note that it is not reasonable to insert a quote after the error
+ -- in this case. If that were the right solution, the parser error
+ -- token would not be the lexer repaired string literal, since a
+ -- string literal would be legal here.
+
+ elsif Lexer_Error_Token.Byte_Region.First <
Config.Error_Token.Byte_Region.First then
+ -- The unbalanced quote is before the parse error token; see
+ -- test_mckenzie_recover.adb String_Quote_2.
+ --
+ -- The missing quote belongs after the parse error token, before or
+ -- at the end of the current line; try inserting it at the end of
+ -- the current line.
+ --
+ -- The lexer repaired string literal may be in a reduced token on the
+ -- stack.
+
+ declare
+ use all type SAL.Base_Peek_Type;
+ Matching : SAL.Peek_Type := 1;
+ begin
+ Find_Descendant_ID
+ (Super.Parser_State (Parser_Index).Tree, Config,
Lexer_Error_Token.ID,
+ String_ID_Set (Lexer_Error_Token.ID), Matching);
+
+ if Matching = Config.Stack.Depth then
+ -- String literal is in a virtual nonterm; give up. So far
this only
+ -- happens in a high cost non critical config.
+ if Trace_McKenzie > Detail then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index), "abandon
missing quote b; string literal in virtual");
+ end if;
+ return;
+ end if;
+
+ declare
+ New_Config : Configuration := Config;
+ begin
+ String_Literal_In_Stack (New_Config, Matching,
Lexer_Error_Token.ID);
+
+ Finish
+ ("b", New_Config, Config.Current_Shared_Token,
Shared.Line_Begin_Token.all (Current_Line + 1) - 1);
+ Local_Config_Heap.Add (New_Config);
+ end;
+ end;
+
+ else
+ -- The unbalanced quote is after the parse error token.
+
+ -- case c: Assume a missing quote belongs immediately before the
current token.
+ -- See test_mckenzie_recover.adb String_Quote_3.
+ declare
+ New_Config : Configuration := Config;
+ begin
+ Finish ("c", New_Config, Config.Current_Shared_Token,
Lexer_Error_Token_Index - 1);
+ Local_Config_Heap.Add (New_Config);
+ exception
+ when Bad_Config =>
+ null;
+ end;
+
+ -- case d: Assume a missing quote belongs somewhere farther before
+ -- the current token; try one non-empty (as in case a above). See
+ -- test_mckenzie_recover.adb String_Quote_4.
+ declare
+ New_Config : Configuration := Config;
+ Token : Recover_Token;
+ begin
+ loop
+ Token := New_Config.Stack.Pop.Token;
+ if Token.Byte_Region /= Null_Buffer_Region then
+ New_Config.Ops.Append ((Push_Back, Token.ID,
Token.Min_Terminal_Index));
+ exit;
+ end if;
+ end loop;
+
+ Finish ("d", New_Config, Token.Min_Terminal_Index,
Lexer_Error_Token_Index - 1);
+ Local_Config_Heap.Add (New_Config);
+ exception
+ when SAL.Container_Empty =>
+ -- From Stack.Pop
+ null;
+ when Bad_Config =>
+ null;
+ end;
+
+ -- case e: Assume the actual error is an extra quote that terminates
+ -- an intended string literal early, in which case there is a token
+ -- on the stack containing the string literal that should be extended
+ -- to the found quote. See test_mckenzie_recover.adb String_Quote_1.
+ declare
+ use all type SAL.Base_Peek_Type;
+ Matching : SAL.Peek_Type := 1;
+ begin
+ -- Lexer_Error_Token is a string literal; find a matching one.
+ Find_Descendant_ID
+ (Super.Parser_State (Parser_Index).Tree, Config,
Lexer_Error_Token.ID, String_ID_Set
+ (Lexer_Error_Token.ID), Matching);
+
+ if Matching = Config.Stack.Depth then
+ -- No matching string literal, so this case does not apply.
+ null;
+ else
+ declare
+ New_Config : Configuration := Config;
+ begin
+ String_Literal_In_Stack (New_Config, Matching,
Lexer_Error_Token.ID);
+
+ Finish ("e", New_Config, Config.Current_Shared_Token,
Lexer_Error_Token_Index);
+ Local_Config_Heap.Add (New_Config);
+ end;
+ end if;
+ end;
+ end if;
+ exception
+ when SAL.Container_Full =>
+ Super.Config_Full (Parser_Index);
+
+ when Bad_Config =>
+ null;
+ end Try_Insert_Quote;
+
+ procedure Try_Delete_Input
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ -- Try deleting (= skipping) the current shared input token.
+
+ use all type Ada.Containers.Count_Type;
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+ EOF_ID : Token_ID renames Trace.Descriptor.EOI_ID;
+ Check_Limit : WisiToken.Token_Index renames
Shared.Table.McKenzie_Param.Check_Limit;
+
+ McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
+
+ ID : constant Token_ID := Shared.Terminals.all
(Config.Current_Shared_Token).ID;
+ begin
+ if ID /= EOF_ID and then
+ -- can't delete EOF
+ (Config.Ops.Length = 0 or else
+ -- Don't delete an ID we just inserted; waste of time
+ (not Equal (Config.Ops (Config.Ops.Last_Index), (Insert, ID,
Config.Current_Shared_Token, 1, 0))))
+ then
+ declare
+ New_Config : Configuration := Config;
+
+ function Matching_Push_Back return Boolean
+ is begin
+ for Op of reverse New_Config.Ops loop
+ exit when not (Op.Op in Undo_Reduce | Push_Back | Delete);
+ if Op = (Push_Back, ID, New_Config.Current_Shared_Token) then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Matching_Push_Back;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ New_Config.Cost := New_Config.Cost + McKenzie_Param.Delete (ID);
+ New_Config.Strategy_Counts (Explore_Table) :=
Config.Strategy_Counts (Explore_Table) + 1;
+
+ if Matching_Push_Back then
+ -- We are deleting a push_back; cancel the push_back cost, to
make
+ -- this the same as plain deleting.
+ New_Config.Cost := Natural'Max (Natural'First, New_Config.Cost
- McKenzie_Param.Push_Back (ID));
+ end if;
+
+ New_Config.Ops.Append ((Delete, ID, Config.Current_Shared_Token));
+ New_Config.Current_Shared_Token := New_Config.Current_Shared_Token
+ 1;
+ loop
+ exit when not Super.Parser_State
(Parser_Index).Prev_Deleted.Contains (New_Config.Current_Shared_Token);
+ New_Config.Current_Shared_Token :=
New_Config.Current_Shared_Token + 1;
+ end loop;
+
+ if New_Config.Resume_Token_Goal - Check_Limit <
New_Config.Current_Shared_Token then
+ New_Config.Resume_Token_Goal := New_Config.Current_Shared_Token
+ Check_Limit;
+ end if;
+
+ Local_Config_Heap.Add (New_Config);
+
+ if Trace_McKenzie > Detail then
+ Base.Put
+ ("delete " & Image (ID, Trace.Descriptor.all), Super, Shared,
Parser_Index, New_Config);
+ end if;
+ end;
+ end if;
+ exception
+ when SAL.Container_Full =>
+ Super.Config_Full (Parser_Index);
+ end Try_Delete_Input;
+
+ procedure Process_One
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Config_Status : out Base.Config_Status)
+ is
+ -- Get one config from Super, check to see if it is a viable
+ -- solution. If not, enqueue variations to check.
+
+ use all type Base.Config_Status;
+ use all type Parser.Language_Fixes_Access;
+ use all type SAL.Base_Peek_Type;
+ use all type Semantic_Checks.Check_Status_Label;
+
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+ Table : Parse_Table renames Shared.Table.all;
+
+ Parser_Index : SAL.Base_Peek_Type;
+ Config : Configuration;
+
+ Local_Config_Heap : Config_Heaps.Heap_Type;
+ -- We collect all the variants to enqueue, then deliver them all at
+ -- once to Super, to minimizes task interactions.
+ begin
+ Super.Get (Parser_Index, Config, Config_Status);
+
+ if Config_Status = All_Done then
+ return;
+ end if;
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("dequeue", Super, Shared, Parser_Index, Config);
+ if Trace_McKenzie > Extra then
+ Put_Line (Trace, Super.Label (Parser_Index), "stack: " & Image
(Config.Stack, Trace.Descriptor.all));
+ end if;
+ end if;
+
+ -- Fast_Forward; parse Insert, Delete in Config.Ops that have not
+ -- been parsed yet. 'parse' here means adjusting Config.Stack and
+ -- Current_Terminal_Index. Code in this file always parses when
+ -- adding ops to Config (except as noted); Language_Fixes should use
+ -- McKenzie_Recover.Insert, Delete instead.
+ if Config.Current_Insert_Delete = 1 then
+ -- Config.Current_Insert_Delete > 1 is a programming error.
+
+ case Fast_Forward (Super, Shared, Parser_Index, Local_Config_Heap,
Config) is
+ when Abandon =>
+ -- We know Local_Config_Heap is empty; just tell
+ -- Super we are done working.
+ Super.Put (Parser_Index, Local_Config_Heap);
+ return;
+ when Continue =>
+ -- We don't increase cost for this Fast_Forward, since it is due
to a
+ -- Language_Fixes.
+ null;
+ end case;
+ end if;
+
+ pragma Assert (Config.Current_Insert_Delete = 0);
+
+ -- Language_Fixes: let it enqueue configs.
+ if Config.Error_Token.ID /= Invalid_Token_ID then
+ if Shared.Language_Fixes = null then
+ null;
+ else
+ Shared.Language_Fixes
+ (Trace, Shared.Lexer, Super.Label (Parser_Index),
Shared.Table.all,
+ Shared.Terminals.all, Super.Parser_State (Parser_Index).Tree,
Local_Config_Heap,
+ Config);
+
+ -- The solutions enqueued by Language_Fixes should be lower cost
than
+ -- others (typically 0), so they will be checked first.
+
+ if Config.Check_Status.Label = Ok then
+ -- Parse table Error action.
+ --
+ -- We don't clear Config.Error_Token here, because
+ -- Language_Use_Minimal_Complete_Actions needs it. We only
clear it
+ -- when a parse results in no error (or a different error), or
a
+ -- push_back moves the Current_Token.
+ null;
+
+ else
+ -- Assume "ignore check error" is a viable solution. But give
it a
+ -- cost, so a solution provided by Language_Fixes is preferred.
+
+ declare
+ New_State : Unknown_State_Index;
+ begin
+ Config.Cost := Config.Cost +
Table.McKenzie_Param.Ignore_Check_Fail;
+
+ -- finish reduce.
+ Config.Stack.Pop (SAL.Base_Peek_Type
(Config.Check_Token_Count));
+
+ New_State := Goto_For (Table, Config.Stack (1).State,
Config.Error_Token.ID);
+
+ if New_State = Unknown_State then
+ if Config.Stack.Depth = 1 then
+ -- Stack is empty, and we did not get Accept; really
bad syntax got
+ -- us here; abandon this config. See
ada_mode-recover_bad_char.adb.
+ Super.Put (Parser_Index, Local_Config_Heap);
+ return;
+ else
+ raise SAL.Programmer_Error with
+ "process_one found test case for new_state =
Unknown; old state " &
+ Trimmed_Image (Config.Stack (1).State) & " nonterm "
& Image
+ (Config.Error_Token.ID, Trace.Descriptor.all);
+ end if;
+ end if;
+
+ Config.Stack.Push ((New_State,
Syntax_Trees.Invalid_Node_Index, Config.Error_Token));
+
+ -- We clear Check_Status and Error_Token so the check error
is ignored.
+ Config.Check_Status := (Label => Ok);
+
+ Config.Error_Token.ID := Invalid_Token_ID;
+ end;
+ end if;
+ end if;
+ end if;
+
+ -- Call Check to see if this config succeeds. Note that Check does
+ -- more than Fast_Forward, so the fact that Fast_Forward succeeds
+ -- does not mean we don't need to call Check.
+ case Check (Super, Shared, Parser_Index, Config, Local_Config_Heap) is
+ when Success =>
+ Super.Success (Parser_Index, Config, Local_Config_Heap);
+ return;
+
+ when Abandon =>
+ Super.Put (Parser_Index, Local_Config_Heap);
+ return;
+
+ when Continue =>
+ null;
+
+ end case;
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("continuing", Super, Shared, Parser_Index, Config);
+ if Trace_McKenzie > Extra then
+ Put_Line (Trace, Super.Label (Parser_Index), "stack: " & Image
(Config.Stack, Trace.Descriptor.all));
+ end if;
+ end if;
+
+ -- Grouping these operations (push_back, delete, insert) ensures that
+ -- there are no duplicate solutions found. We reset the grouping
+ -- after each fast_forward.
+ --
+ -- We do delete before insert so Insert_Matching_Begin can operate on
+ -- the new next token, before Fast_Forwarding past it.
+ --
+ -- All possible permutations will be explored.
+
+ Try_Insert_Terminal (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+
+ if None_Since_FF (Config.Ops, Delete) and then
+ None_Since_FF (Config.Ops, Insert) and then
+ Config.Stack.Depth > 1 and then -- can't delete the first state
+ (not Check_Reduce_To_Start (Super, Shared, Parser_Index, Config))
+ -- If Config reduces to the start nonterm, there's no point in
push_back.
+ then
+ Try_Push_Back (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+ Try_Undo_Reduce (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+ end if;
+
+ if None_Since_FF (Config.Ops, Insert) then
+ Try_Delete_Input (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+ end if;
+
+ -- This is run once per input line, independent of what other ops
+ -- have been done.
+ if Config.Check_Status.Label = Ok and
+ (Descriptor.String_1_ID /= Invalid_Token_ID or Descriptor.String_2_ID
/= Invalid_Token_ID) and
+ (Config.String_Quote_Checked = Invalid_Line_Number or else
+ Config.String_Quote_Checked < Shared.Terminals.all
(Config.Current_Shared_Token).Line)
+ then
+ -- See if there is a mismatched quote. The solution is to delete
+ -- tokens, replacing them with a string literal. So we try this when
+ -- it is ok to try delete.
+ Try_Insert_Quote (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+ end if;
+
+ Super.Put (Parser_Index, Local_Config_Heap);
+ exception
+ when E : others =>
+ -- Just abandon this config; tell Super we are done.
+ Super.Put (Parser_Index, Local_Config_Heap);
+ if Debug_Mode then
+ raise;
+ elsif Trace_McKenzie > Outline then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
+ "Process_One: unhandled exception " &
Ada.Exceptions.Exception_Name (E) & ": " &
+ Ada.Exceptions.Exception_Message (E));
+ end if;
+ end Process_One;
+
+end WisiToken.Parse.LR.McKenzie_Recover.Explore;
diff --git a/wisitoken-parse-lr-mckenzie_recover-explore.ads
b/wisitoken-parse-lr-mckenzie_recover-explore.ads
index 1777728..b80124a 100644
--- a/wisitoken-parse-lr-mckenzie_recover-explore.ads
+++ b/wisitoken-parse-lr-mckenzie_recover-explore.ads
@@ -1,28 +1,28 @@
--- Abstract :
---
--- Code to explore parse table, enqueuing new configs to check.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Parse.LR.McKenzie_Recover.Base;
-private package WisiToken.Parse.LR.McKenzie_Recover.Explore is
-
- procedure Process_One
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Config_Status : out Base.Config_Status);
-
-end WisiToken.Parse.LR.McKenzie_Recover.Explore;
+-- Abstract :
+--
+-- Code to explore parse table, enqueuing new configs to check.
+--
+-- Copyright (C) 2018 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Parse.LR.McKenzie_Recover.Base;
+private package WisiToken.Parse.LR.McKenzie_Recover.Explore is
+
+ procedure Process_One
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Config_Status : out Base.Config_Status);
+
+end WisiToken.Parse.LR.McKenzie_Recover.Explore;
diff --git a/wisitoken-parse-lr-mckenzie_recover-parse.adb
b/wisitoken-parse-lr-mckenzie_recover-parse.adb
index 52ee7f1..963cf1a 100644
--- a/wisitoken-parse-lr-mckenzie_recover-parse.adb
+++ b/wisitoken-parse-lr-mckenzie_recover-parse.adb
@@ -1,304 +1,325 @@
--- Abstract :
---
--- See spec
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
-
- procedure Compute_Nonterm
- (ID : in Token_ID;
- Stack : in Recover_Stacks.Stack;
- Tokens : in out Recover_Token_Array;
- Nonterm : out Recover_Token;
- Default_Virtual : in Boolean)
- is
- use all type SAL.Base_Peek_Type;
-
- Min_Terminal_Index_Set : Boolean := False;
- begin
- Nonterm :=
- (ID => ID,
- Virtual => (if Tokens'Length = 0 then Default_Virtual else False),
- others => <>);
-
- for I in Tokens'Range loop
- Tokens (I) := Stack (Tokens'Last - I + 1).Token;
- end loop;
-
- for T of Tokens loop
- Nonterm.Virtual := Nonterm.Virtual or T.Virtual;
-
- if Nonterm.Byte_Region.First > T.Byte_Region.First then
- Nonterm.Byte_Region.First := T.Byte_Region.First;
- end if;
-
- if Nonterm.Byte_Region.Last < T.Byte_Region.Last then
- Nonterm.Byte_Region.Last := T.Byte_Region.Last;
- end if;
-
- if not Min_Terminal_Index_Set then
- if T.Min_Terminal_Index /= Invalid_Token_Index then
- Min_Terminal_Index_Set := True;
- Nonterm.Min_Terminal_Index := T.Min_Terminal_Index;
- end if;
- end if;
- end loop;
- end Compute_Nonterm;
-
- function Reduce_Stack
- (Shared : not null access Base.Shared;
- Stack : in out Recover_Stacks.Stack;
- Action : in Reduce_Action_Rec;
- Nonterm : out Recover_Token;
- Default_Virtual : in Boolean)
- return Semantic_Checks.Check_Status
- is
- use all type SAL.Base_Peek_Type;
- use all type Semantic_Checks.Semantic_Check;
- use all type Semantic_Checks.Check_Status_Label;
-
- Last : constant SAL.Base_Peek_Type := SAL.Base_Peek_Type
(Action.Token_Count);
- Tokens : Recover_Token_Array (1 .. Last);
- begin
- Compute_Nonterm (Action.Production.LHS, Stack, Tokens, Nonterm,
Default_Virtual);
-
- if Action.Check = null then
- -- Now we can pop the stack.
- Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
- return (Label => Ok);
- else
- return Status : constant Semantic_Checks.Check_Status :=
- Action.Check (Shared.Lexer, Nonterm, Tokens, Recover_Active => True)
- do
- if Status.Label = Ok then
- Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
- end if;
- end return;
- end if;
- end Reduce_Stack;
-
- function Parse_One_Item
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Parse_Items : in out Parse_Item_Arrays.Vector;
- Parse_Item_Index : in Positive;
- Shared_Token_Goal : in Base_Token_Index;
- Trace_Prefix : in String)
- return Boolean
- is
- -- Perform parse actions on Parse_Items (Parse_Item_Index), until one
- -- fails (return False) or Shared_Token_Goal is shifted (return
- -- True).
- --
- -- We return Boolean, not Check_Status, because Abandon and Continue
- -- are up to the caller.
- --
- -- If any actions have a conflict, append the conflict config and
action to
- -- Parse_Items.
-
- use all type Ada.Containers.Count_Type;
- use all type SAL.Base_Peek_Type;
- use all type Semantic_Checks.Check_Status_Label;
-
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- Table : Parse_Table renames Shared.Table.all;
-
- Item : Parse_Item renames Parse_Items (Parse_Item_Index);
- Config : Configuration renames Item.Config;
- Action : Parse_Action_Node_Ptr renames Item.Action;
-
- Restore_Terminals_Current : Base_Token_Index;
- Current_Token : Base_Token := McKenzie_Recover.Current_Token
- (Terminals => Shared.Terminals.all,
- Terminals_Current => Config.Current_Shared_Token,
- Restore_Terminals_Current => Restore_Terminals_Current,
- Insert_Delete => Config.Insert_Delete,
- Current_Insert_Delete => Config.Current_Insert_Delete,
- Prev_Deleted => Super.Parser_State
(Parser_Index).Prev_Deleted);
-
- New_State : Unknown_State_Index;
- Success : Boolean := True;
-
- begin
- if Trace_McKenzie > Detail then
- Base.Put (Trace_Prefix & ": " & Image (Current_Token, Descriptor),
Super, Shared, Parser_Index, Config);
- if Shared_Token_Goal /= Invalid_Token_Index then
- Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
Shared_Token_Goal :" &
- Token_Index'Image (Shared_Token_Goal));
- end if;
- end if;
-
- Item.Parsed := True;
-
- if Action = null then
- Action := Action_For (Table, Config.Stack (1).State,
Current_Token.ID);
- end if;
-
- loop
- if Action.Next /= null then
- if Parse_Items.Is_Full then
- if Trace_McKenzie > Outline then
- Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix &
": too many conflicts; abandoning");
- end if;
- else
- if Trace_McKenzie > Detail then
- Put_Line
- (Trace, Super.Label (Parser_Index), Trace_Prefix & ":" &
State_Index'Image
- (Config.Stack.Peek.State) & ": add conflict " &
- Image (Action.Next.Item, Descriptor));
- end if;
-
- Parse_Items.Append ((Config, Action.Next, Parsed => False,
Shift_Count => 0));
- end if;
- end if;
-
- if Trace_McKenzie > Extra then
- Put_Line
- (Trace, Super.Label (Parser_Index), Trace_Prefix & ":" &
State_Index'Image (Config.Stack.Peek.State) &
- " :" & Token_Index'Image (Config.Current_Shared_Token) &
- ":" & Image (Current_Token, Descriptor) &
- " : " & Image (Action.Item, Descriptor));
- end if;
-
- case Action.Item.Verb is
- when Shift =>
- Item.Shift_Count := Item.Shift_Count + 1;
-
- Config.Stack.Push
- ((Action.Item.State,
- Syntax_Trees.Invalid_Node_Index,
- (Current_Token.ID,
- Byte_Region => Current_Token.Byte_Region,
- Min_Terminal_Index =>
- (if Config.Current_Insert_Delete = No_Insert_Delete
- then Config.Current_Shared_Token
- else Invalid_Token_Index),
- Name => Null_Buffer_Region,
- Virtual => Config.Current_Insert_Delete /=
No_Insert_Delete)));
-
- Current_Token := Next_Token
- (Terminals => Shared.Terminals.all,
- Terminals_Current => Config.Current_Shared_Token,
- Restore_Terminals_Current => Restore_Terminals_Current,
- Insert_Delete => Config.Insert_Delete,
- Current_Insert_Delete => Config.Current_Insert_Delete,
- Prev_Deleted => Super.Parser_State
(Parser_Index).Prev_Deleted);
-
- when Reduce =>
- declare
- Nonterm : Recover_Token;
- begin
- Config.Check_Status := Reduce_Stack
- (Shared, Config.Stack, Action.Item, Nonterm,
- Default_Virtual => Config.Current_Insert_Delete /=
No_Insert_Delete);
-
- case Config.Check_Status.Label is
- when Ok =>
- New_State := Config.Stack.Peek.State;
- New_State := Goto_For (Table, New_State,
Action.Item.Production.LHS);
-
- if New_State = Unknown_State then
- -- Most likely from an inappropriate language fix.
- if Trace_McKenzie > Outline then
- Base.Put (Trace_Prefix & ": Unknown_State: ", Super,
Shared, Parser_Index, Config);
- Put_Line (Trace, Trace_Prefix & ": stack: " & Image
(Config.Stack, Descriptor));
- end if;
-
- -- We can't just return False here; user must abandon
this config.
- raise Bad_Config;
- end if;
-
- Config.Stack.Push ((New_State,
Syntax_Trees.Invalid_Node_Index, Nonterm));
-
- when Semantic_Checks.Error =>
- Config.Error_Token := Nonterm;
- Config.Check_Token_Count := Action.Item.Token_Count;
- Success := False;
- end case;
- end;
-
- when Error =>
-
- Config.Error_Token :=
- (ID => Current_Token.ID,
- Byte_Region => Current_Token.Byte_Region,
- others => <>);
- Success := False;
-
- when Accept_It =>
- null;
- end case;
-
- exit when not Success or
- Action.Item.Verb = Accept_It or
- (if Shared_Token_Goal = Invalid_Token_Index
- then Config.Insert_Delete.Length = 0
- else Config.Current_Shared_Token > Shared_Token_Goal);
-
- Action := Action_For (Table, Config.Stack (1).State,
Current_Token.ID);
- end loop;
-
- Config.Current_Shared_Token := Restore_Terminals_Current;
-
- return Success;
- end Parse_One_Item;
-
- function Parse
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Parse_Items : out Parse_Item_Arrays.Vector;
- Config : in Configuration;
- Shared_Token_Goal : in Base_Token_Index;
- All_Conflicts : in Boolean;
- Trace_Prefix : in String)
- return Boolean
- is
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
-
- Last_Index : Positive;
- Success : Boolean;
- begin
- Parse_Items.Clear;
- Parse_Items.Append ((Config, Action => null, Parsed => False,
Shift_Count => 0));
-
- -- Clear any errors; so they reflect the parse result.
- Parse_Items (Parse_Items.First_Index).Config.Error_Token.ID :=
Invalid_Token_ID;
- Parse_Items (Parse_Items.First_Index).Config.Check_Status := (Label =>
Semantic_Checks.Ok);
-
- loop
- -- Loop over initial config and any conflicts.
- Last_Index := Parse_Items.Last_Index;
-
- Success := Parse_One_Item
- (Super, Shared, Parser_Index, Parse_Items, Last_Index,
Shared_Token_Goal, Trace_Prefix);
-
- exit when Parse_Items.Last_Index = Last_Index;
-
- exit when Success and not All_Conflicts;
-
- if Trace_McKenzie > Detail then
- Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
parse conflict");
- end if;
- end loop;
-
- return Success;
- end Parse;
-
-end WisiToken.Parse.LR.McKenzie_Recover.Parse;
+-- Abstract :
+--
+-- See spec
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
+
+ procedure Compute_Nonterm
+ (ID : in Token_ID;
+ Stack : in Recover_Stacks.Stack;
+ Tokens : in out Recover_Token_Array;
+ Nonterm : out Recover_Token;
+ Default_Virtual : in Boolean)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ Min_Terminal_Index_Set : Boolean := False;
+ begin
+ Nonterm :=
+ (ID => ID,
+ Virtual => (if Tokens'Length = 0 then Default_Virtual else False),
+ others => <>);
+
+ for I in Tokens'Range loop
+ Tokens (I) := Stack (Tokens'Last - I + 1).Token;
+ end loop;
+
+ for T of Tokens loop
+ Nonterm.Virtual := Nonterm.Virtual or T.Virtual;
+
+ if Nonterm.Byte_Region.First > T.Byte_Region.First then
+ Nonterm.Byte_Region.First := T.Byte_Region.First;
+ end if;
+
+ if Nonterm.Byte_Region.Last < T.Byte_Region.Last then
+ Nonterm.Byte_Region.Last := T.Byte_Region.Last;
+ end if;
+
+ if not Min_Terminal_Index_Set then
+ if T.Min_Terminal_Index /= Invalid_Token_Index then
+ Min_Terminal_Index_Set := True;
+ Nonterm.Min_Terminal_Index := T.Min_Terminal_Index;
+ end if;
+ end if;
+ end loop;
+ end Compute_Nonterm;
+
+ function Reduce_Stack
+ (Shared : not null access Base.Shared;
+ Stack : in out Recover_Stacks.Stack;
+ Action : in Reduce_Action_Rec;
+ Nonterm : out Recover_Token;
+ Default_Virtual : in Boolean)
+ return Semantic_Checks.Check_Status
+ is
+ use all type SAL.Base_Peek_Type;
+ use all type Semantic_Checks.Semantic_Check;
+ use all type Semantic_Checks.Check_Status_Label;
+
+ Last : constant SAL.Base_Peek_Type := SAL.Base_Peek_Type
(Action.Token_Count);
+ Tokens : Recover_Token_Array (1 .. Last);
+ begin
+ Compute_Nonterm (Action.Production.LHS, Stack, Tokens, Nonterm,
Default_Virtual);
+
+ if Action.Check = null then
+ -- Now we can pop the stack.
+ Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
+ return (Label => Ok);
+ else
+ return Status : constant Semantic_Checks.Check_Status :=
+ Action.Check (Shared.Lexer, Nonterm, Tokens, Recover_Active => True)
+ do
+ if Status.Label = Ok then
+ Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
+ end if;
+ end return;
+ end if;
+ end Reduce_Stack;
+
+ function Parse_One_Item
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Parse_Items : in out Parse_Item_Arrays.Vector;
+ Parse_Item_Index : in Positive;
+ Shared_Token_Goal : in Base_Token_Index;
+ Trace_Prefix : in String)
+ return Boolean
+ is
+ -- Perform parse actions on Parse_Items (Parse_Item_Index), until one
+ -- fails (return False) or Shared_Token_Goal is shifted (return
+ -- True).
+ --
+ -- We return Boolean, not Check_Status, because Abandon and Continue
+ -- are up to the caller.
+ --
+ -- If any actions have conflicts, append the conflict configs and
actions to
+ -- Parse_Items.
+
+ use all type Ada.Containers.Count_Type;
+ use all type SAL.Base_Peek_Type;
+ use all type Semantic_Checks.Check_Status_Label;
+
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+ Table : Parse_Table renames Shared.Table.all;
+
+ Item : Parse_Item renames Parse_Items (Parse_Item_Index);
+ Config : Configuration renames Item.Config;
+ Action : Parse_Action_Node_Ptr renames Item.Action;
+
+ Conflict : Parse_Action_Node_Ptr;
+
+ Restore_Terminals_Current : Base_Token_Index;
+ Current_Token : Base_Token := McKenzie_Recover.Current_Token
+ (Terminals => Shared.Terminals.all,
+ Terminals_Current => Config.Current_Shared_Token,
+ Restore_Terminals_Current => Restore_Terminals_Current,
+ Insert_Delete => Config.Insert_Delete,
+ Current_Insert_Delete => Config.Current_Insert_Delete,
+ Prev_Deleted => Super.Parser_State
(Parser_Index).Prev_Deleted);
+
+ New_State : Unknown_State_Index;
+ Success : Boolean := True;
+
+ begin
+ if Trace_McKenzie > Detail then
+ if Trace_McKenzie > Extra then
+ if Config.Current_Insert_Delete /= No_Insert_Delete then
+ Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
Insert_Delete: " &
+ Image (Insert_Delete_Arrays.Vector
(Config.Insert_Delete), Trace.Descriptor.all));
+ end if;
+ end if;
+
+ Base.Put (Trace_Prefix & ": " & Image (Current_Token, Descriptor),
Super, Shared, Parser_Index, Config);
+ if Shared_Token_Goal /= Invalid_Token_Index then
+ Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
Shared_Token_Goal :" &
+ WisiToken.Token_Index'Image (Shared_Token_Goal));
+ end if;
+ end if;
+
+ Item.Parsed := True;
+
+ if Action = null then
+ Action := Action_For (Table, Config.Stack (1).State,
Current_Token.ID);
+ end if;
+
+ loop
+ Conflict := Action.Next;
+ loop
+ exit when Conflict = null;
+ if Parse_Items.Is_Full then
+ if Trace_McKenzie > Outline then
+ Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix &
": too many conflicts; abandoning");
+ end if;
+ else
+ declare
+ New_Config : Configuration := Config;
+ begin
+ New_Config.Current_Shared_Token := Restore_Terminals_Current;
+
+ if Trace_McKenzie > Detail then
+ Put_Line
+ (Trace, Super.Label (Parser_Index), Trace_Prefix & ":"
& State_Index'Image
+ (New_Config.Stack.Peek.State) & ": add conflict " &
+ Image (Conflict.Item, Descriptor));
+ end if;
+
+ Parse_Items.Append ((New_Config, Conflict, Parsed => False,
Shift_Count => Item.Shift_Count));
+ end;
+ end if;
+ Conflict := Conflict.Next;
+ end loop;
+
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Trace, Super.Label (Parser_Index), Trace_Prefix & ":" &
State_Index'Image (Config.Stack.Peek.State) &
+ " :" & WisiToken.Token_Index'Image
(Config.Current_Shared_Token) &
+ ":" & Image (Current_Token, Descriptor) &
+ " : " & Image (Action.Item, Descriptor) &
+ (if Action.Item.Verb = Reduce
+ then " via" & Config.Stack (SAL.Peek_Type
(Action.Item.Token_Count + 1)).State'Image
+ else ""));
+ end if;
+
+ case Action.Item.Verb is
+ when Shift =>
+ Item.Shift_Count := Item.Shift_Count + 1;
+
+ Config.Stack.Push
+ ((Action.Item.State,
+ Syntax_Trees.Invalid_Node_Index,
+ (Current_Token.ID,
+ Byte_Region => Current_Token.Byte_Region,
+ Min_Terminal_Index =>
+ (if Config.Current_Insert_Delete = No_Insert_Delete
+ then Config.Current_Shared_Token
+ else Invalid_Token_Index),
+ Name => Null_Buffer_Region,
+ Virtual => Config.Current_Insert_Delete /=
No_Insert_Delete)));
+
+ Current_Token := Next_Token
+ (Terminals => Shared.Terminals.all,
+ Terminals_Current => Config.Current_Shared_Token,
+ Restore_Terminals_Current => Restore_Terminals_Current,
+ Insert_Delete => Config.Insert_Delete,
+ Current_Insert_Delete => Config.Current_Insert_Delete,
+ Prev_Deleted => Super.Parser_State
(Parser_Index).Prev_Deleted);
+
+ when Reduce =>
+ declare
+ Nonterm : Recover_Token;
+ begin
+ Config.Check_Status := Reduce_Stack
+ (Shared, Config.Stack, Action.Item, Nonterm,
+ Default_Virtual => Config.Current_Insert_Delete /=
No_Insert_Delete);
+
+ case Config.Check_Status.Label is
+ when Ok =>
+ New_State := Config.Stack.Peek.State;
+ New_State := Goto_For (Table, New_State,
Action.Item.Production.LHS);
+
+ if New_State = Unknown_State then
+ -- Most likely from an inappropriate language fix.
+ if Trace_McKenzie > Outline then
+ Base.Put (Trace_Prefix & ": Unknown_State: ", Super,
Shared, Parser_Index, Config);
+ Put_Line (Trace, Trace_Prefix & ": stack: " & Image
(Config.Stack, Descriptor));
+ end if;
+
+ -- We can't just return False here; user must abandon
this config.
+ raise Bad_Config;
+ end if;
+
+ Config.Stack.Push ((New_State,
Syntax_Trees.Invalid_Node_Index, Nonterm));
+
+ when Semantic_Checks.Error =>
+ Config.Error_Token := Nonterm;
+ Config.Check_Token_Count := Action.Item.Token_Count;
+ Success := False;
+ end case;
+ end;
+
+ when Error =>
+
+ Config.Error_Token :=
+ (ID => Current_Token.ID,
+ Byte_Region => Current_Token.Byte_Region,
+ others => <>);
+ Success := False;
+
+ when Accept_It =>
+ null;
+ end case;
+
+ exit when not Success or
+ Action.Item.Verb = Accept_It or
+ (if Shared_Token_Goal = Invalid_Token_Index
+ then Config.Insert_Delete.Length = 0
+ else Config.Current_Shared_Token > Shared_Token_Goal);
+
+ Action := Action_For (Table, Config.Stack (1).State,
Current_Token.ID);
+ end loop;
+
+ Config.Current_Shared_Token := Restore_Terminals_Current;
+
+ return Success;
+ end Parse_One_Item;
+
+ function Parse
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Parse_Items : out Parse_Item_Arrays.Vector;
+ Config : in Configuration;
+ Shared_Token_Goal : in Base_Token_Index;
+ All_Conflicts : in Boolean;
+ Trace_Prefix : in String)
+ return Boolean
+ is
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+
+ Last_Parsed : Natural;
+ Success : Boolean;
+ begin
+ Parse_Items.Clear;
+ Parse_Items.Append ((Config, Action => null, Parsed => False,
Shift_Count => 0));
+
+ -- Clear any errors; so they reflect the parse result.
+ Parse_Items (Parse_Items.First_Index).Config.Error_Token.ID :=
Invalid_Token_ID;
+ Parse_Items (Parse_Items.First_Index).Config.Check_Status := (Label =>
Semantic_Checks.Ok);
+
+ Last_Parsed := Parse_Items.First_Index;
+ loop
+ -- Loop over initial config and any conflicts.
+ Success := Parse_One_Item
+ (Super, Shared, Parser_Index, Parse_Items, Last_Parsed,
Shared_Token_Goal, Trace_Prefix);
+
+ exit when Parse_Items.Last_Index = Last_Parsed;
+
+ exit when Success and not All_Conflicts;
+
+ Last_Parsed := Last_Parsed + 1;
+ if Trace_McKenzie > Detail then
+ Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
parse conflict");
+ end if;
+ end loop;
+
+ return Success;
+ end Parse;
+
+end WisiToken.Parse.LR.McKenzie_Recover.Parse;
diff --git a/wisitoken-parse-lr-mckenzie_recover-parse.ads
b/wisitoken-parse-lr-mckenzie_recover-parse.ads
index 0db7178..e5e4d36 100644
--- a/wisitoken-parse-lr-mckenzie_recover-parse.ads
+++ b/wisitoken-parse-lr-mckenzie_recover-parse.ads
@@ -1,77 +1,80 @@
--- Abstract :
---
--- Config parsing subprograms.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Parse.LR.McKenzie_Recover.Base;
-private package WisiToken.Parse.LR.McKenzie_Recover.Parse is
-
- function Reduce_Stack
- (Shared : not null access Base.Shared;
- Stack : in out Recover_Stacks.Stack;
- Action : in Reduce_Action_Rec;
- Nonterm : out Recover_Token;
- Default_Virtual : in Boolean)
- return Semantic_Checks.Check_Status;
- -- Reduce Stack according to Action, setting Nonterm. If
- -- Action.Token_Count = 0, set Nonterm.Virtual := Default_Virtual.
-
- type Parse_Item is record
- Config : Configuration;
- Action : Parse_Action_Node_Ptr;
- Parsed : Boolean;
- Shift_Count : Natural := 0;
-
- -- On return from Parse, if Parsed = False, this item was queued by a
- -- conflict, but not parsed; it should be ignored.
- --
- -- Otherwise, if Config.Error_Token.ID = Invalid_Token_ID and
- -- Config.Check_Status.Label = Ok, Config was parsed successfully to
- -- the goal.
- --
- -- Otherwise, the parser failed a semantic check, or encountered an
- -- Error action. Shift_Count gives the number of shifts performed. If
- -- Check_Status.Label is Error, Action.Item.Verb must be Reduce, and
- -- Config is in the pre-reduce state.
- end record;
-
- package Parse_Item_Arrays is new SAL.Gen_Bounded_Definite_Vectors
(Positive, Parse_Item, Capacity => 10);
- -- Parse_Item_Arrays.Capacity sets maximum conflicts in one call to Parse
-
- function Parse
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Parse_Items : out Parse_Item_Arrays.Vector;
- Config : in Configuration;
- Shared_Token_Goal : in Base_Token_Index;
- All_Conflicts : in Boolean;
- Trace_Prefix : in String)
- return Boolean;
- -- Attempt to parse Config until Config.Inserted is all shifted, and
- -- either Shared_Token_Goal = Invalid_Token_Index or
- -- Shared_Token_Goal is shifted.
- --
- -- Parsed configs are in Parse_Items; there is more than one if a
- -- conflict is encountered. Parse returns True if at least one
- -- Parse_Item parsed successfully to the goal. In that case, the
- -- other items are either not parsed or failed. See comment in
- -- Parse_Item for more detail.
- --
- -- Raises Bad_Config if parse encounters Unknown_State.
-
-end WisiToken.Parse.LR.McKenzie_Recover.Parse;
+-- Abstract :
+--
+-- Config parsing subprograms.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Parse.LR.McKenzie_Recover.Base;
+private package WisiToken.Parse.LR.McKenzie_Recover.Parse is
+
+ function Reduce_Stack
+ (Shared : not null access Base.Shared;
+ Stack : in out Recover_Stacks.Stack;
+ Action : in Reduce_Action_Rec;
+ Nonterm : out Recover_Token;
+ Default_Virtual : in Boolean)
+ return Semantic_Checks.Check_Status;
+ -- Reduce Stack according to Action, setting Nonterm. If
+ -- Action.Token_Count = 0, set Nonterm.Virtual := Default_Virtual.
+
+ type Parse_Item is record
+ Config : Configuration;
+ Action : Parse_Action_Node_Ptr;
+ Parsed : Boolean;
+ Shift_Count : Natural := 0;
+
+ -- On return from Parse, if Parsed = False, this item was queued by a
+ -- conflict, but not parsed; it should be ignored.
+ --
+ -- Otherwise, if Config.Error_Token.ID = Invalid_Token_ID and
+ -- Config.Check_Status.Label = Ok, Config was parsed successfully to
+ -- the goal.
+ --
+ -- Otherwise, the parser failed a semantic check, or encountered an
+ -- Error action. Action gives the last action processed. Shift_Count
+ -- gives the number of shifts performed. If Check_Status.Label is
+ -- Error, Action.Item.Verb must be Reduce, and Config is in the
+ -- pre-reduce state.
+ end record;
+
+ package Parse_Item_Arrays is new SAL.Gen_Bounded_Definite_Vectors
(Positive, Parse_Item, Capacity => 10);
+ -- Parse_Item_Arrays.Capacity sets maximum conflicts in one call to Parse
+
+ function Parse
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Parse_Items : out Parse_Item_Arrays.Vector;
+ Config : in Configuration;
+ Shared_Token_Goal : in Base_Token_Index;
+ All_Conflicts : in Boolean;
+ Trace_Prefix : in String)
+ return Boolean;
+ -- Attempt to parse Config and any conflict configs. If not
+ -- All_Conflicts, return when Config.Insert_Delete is all processed,
+ -- and either Shared_Token_Goal = Invalid_Token_Index or
+ -- Shared_Token_Goal is shifted. If All_Conflicts, return when all
+ -- conflict configs have been parsed.
+ --
+ -- Parsed configs are in Parse_Items; there is more than one if a
+ -- conflict is encountered. Parse returns True if at least one
+ -- Parse_Item parsed successfully to the goal. In that case, the
+ -- other items are either not parsed or failed. See comment in
+ -- Parse_Item for more detail.
+ --
+ -- Raises Bad_Config if parse encounters Unknown_State.
+
+end WisiToken.Parse.LR.McKenzie_Recover.Parse;
diff --git a/wisitoken-parse-lr-mckenzie_recover.adb
b/wisitoken-parse-lr-mckenzie_recover.adb
index 31c6285..49c2106 100644
--- a/wisitoken-parse-lr-mckenzie_recover.adb
+++ b/wisitoken-parse-lr-mckenzie_recover.adb
@@ -1,1137 +1,1252 @@
--- Abstract :
---
--- See spec
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Characters.Handling;
-with Ada.Exceptions;
-with Ada.Task_Identification;
-with Ada.Unchecked_Deallocation;
-with GNAT.Traceback.Symbolic;
-with System.Multiprocessors;
-with WisiToken.Parse.LR.McKenzie_Recover.Base;
-with WisiToken.Parse.LR.McKenzie_Recover.Explore;
-with WisiToken.Parse.LR.Parser_Lists;
-package body WisiToken.Parse.LR.McKenzie_Recover is
- use all type System.Multiprocessors.CPU_Range;
-
- type Supervisor_Access is access all Base.Supervisor;
- type Shared_Access is access all Base.Shared;
-
- task type Worker_Task is
- entry Start
- (Super : in Supervisor_Access;
- Shared : in Shared_Access);
- -- Start getting parser/configs to check from Config_Store. Stop when
- -- Super reports All_Done;
-
- entry Done;
- -- Available after Super has reported All_Done.
- end Worker_Task;
-
- type Worker_Access is access Worker_Task;
- procedure Free is new Ada.Unchecked_Deallocation (Worker_Task,
Worker_Access);
-
- task body Worker_Task
- is
- use all type Base.Config_Status;
- Super : Supervisor_Access;
- Shared : Shared_Access;
-
- Status : Base.Config_Status := Valid;
- begin
- loop
- select
- accept Start
- (Super : in Supervisor_Access;
- Shared : in Shared_Access)
-
- do
- Worker_Task.Super := Super;
- Worker_Task.Shared := Shared;
- end Start;
- or
- terminate;
- end select;
-
- loop
- Explore.Process_One (Super, Shared, Status);
- exit when Status = All_Done;
- end loop;
-
- accept Done;
-
- Super := null;
- Shared := null;
- end loop;
-
- exception
- when E : others =>
- Super.Fatal (E);
- if Debug_Mode then
- Shared.Trace.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback
(E));
- end if;
- end Worker_Task;
-
- Worker_Tasks : array (1 .. System.Multiprocessors.CPU_Range'Max (1,
System.Multiprocessors.Number_Of_CPUs - 1)) of
- Worker_Access;
- -- Declaring an array of tasks directly causes a circular elaboration
- -- problem, and would mean a task that terminates due to an exception
- -- is never restarted.
-
- function To_Recover
- (Parser_Stack : in Parser_Lists.Parser_Stacks.Stack;
- Tree : in Syntax_Trees.Tree)
- return Recover_Stacks.Stack
- is
- use all type SAL.Base_Peek_Type;
- Result : Recover_Stacks.Stack;
- Depth : constant SAL.Peek_Type := Parser_Stack.Depth;
- begin
- Result.Set_Depth (Depth);
- for I in 1 .. Depth loop
- declare
- Item : Parser_Lists.Parser_Stack_Item renames Parser_Stack (I);
- Token : constant Recover_Token := (if I = Depth then (others =>
<>) else Tree.Recover_Token (Item.Token));
- begin
- Result.Set (I, Depth, (Item.State, Item.Token, Token));
- end;
- end loop;
- return Result;
- end To_Recover;
-
- procedure Recover_Init
- (Shared_Parser : in out LR.Parser.Parser;
- Parser_State : in out Parser_Lists.Parser_State)
- is
- use all type WisiToken.Parse.LR.Parser.Language_Fixes_Access;
-
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
- Config : constant Configuration_Access :=
Parser_State.Recover.Config_Heap.Add (Configuration'(others => <>));
- Error : Parse_Error renames Parser_State.Errors
(Parser_State.Errors.Last);
- begin
- Parser_State.Recover.Enqueue_Count := Parser_State.Recover.Enqueue_Count
+ 1;
-
- Config.Resume_Token_Goal := Parser_State.Shared_Token +
Shared_Parser.Table.McKenzie_Param.Check_Limit;
-
- if Trace_McKenzie > Outline then
- Trace.New_Line;
- Trace.Put_Line
- ("parser" & Integer'Image (Parser_State.Label) &
- ": State" & State_Index'Image (Parser_State.Stack (1).State) &
- " Current_Token" & Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) &
- " Resume_Token_Goal" & Token_Index'Image
(Config.Resume_Token_Goal));
- Trace.Put_Line (Image (Error, Parser_State.Tree,
Trace.Descriptor.all));
- if Trace_McKenzie > Extra then
- Put_Line
- (Trace, Parser_State.Label, Parser_Lists.Image
- (Parser_State.Stack, Trace.Descriptor.all,
Parser_State.Tree));
- end if;
- end if;
-
- -- Additional initialization of Parser_State.Recover is done in
- -- Supervisor.Initialize.
-
- Config.Stack := To_Recover (Parser_State.Stack, Parser_State.Tree);
-
- -- Parser_State.Recover_Insert_Delete must be empty (else we would not
get
- -- here). Therefore Parser_State current token is in
- -- Shared_Parser.Shared_Token.
-
- Config.Current_Shared_Token := Parser_State.Shared_Token;
-
- case Error.Label is
- when Action =>
- Config.Error_Token := Parser_State.Tree.Recover_Token
(Error.Error_Token);
- if Trace_McKenzie > Detail then
- Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config.all,
- Task_ID => False);
- end if;
-
- when Check =>
- if Shared_Parser.Language_Fixes = null then
- -- The only fix is to ignore the error.
- if Trace_McKenzie > Detail then
- Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config.all,
- Task_ID => False);
- end if;
-
- else
- -- Undo the reduction that encountered the error, let Process_One
- -- enqueue possible solutions. We leave the cost at 0, since this
is
- -- the root config. Later logic will enqueue the 'ignore error'
- -- solution; see McKenzie_Recover.Explore Process_One.
-
- Config.Check_Status := Error.Check_Status;
- Config.Error_Token := Config.Stack (1).Token;
- Config.Check_Token_Count := Undo_Reduce (Config.Stack,
Parser_State.Tree);
-
- Config.Ops.Append ((Undo_Reduce, Config.Error_Token.ID,
Config.Check_Token_Count));
-
- if Trace_McKenzie > Detail then
- Put ("undo_reduce " & Image
- (Config.Error_Token.ID, Trace.Descriptor.all), Trace,
Parser_State.Label,
- Shared_Parser.Terminals, Config.all, Task_ID => False);
- end if;
- end if;
-
- when Message =>
- -- Last error entry should be the failure that caused us to enter
- -- recovery.
- raise SAL.Programmer_Error;
- end case;
- end Recover_Init;
-
- function Recover (Shared_Parser : in out LR.Parser.Parser) return
Recover_Status
- is
- use all type Parser.Post_Recover_Access;
- use all type SAL.Base_Peek_Type;
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
-
- Parsers : Parser_Lists.List renames Shared_Parser.Parsers;
-
- Current_Parser : Parser_Lists.Cursor;
-
- Super : aliased Base.Supervisor
- (Trace'Access,
- Cost_Limit => Shared_Parser.Table.McKenzie_Param.Cost_Limit,
- Check_Delta_Limit =>
Shared_Parser.Table.McKenzie_Param.Check_Delta_Limit,
- Enqueue_Limit => Shared_Parser.Table.McKenzie_Param.Enqueue_Limit,
- Parser_Count => Parsers.Count);
-
- Shared : aliased Base.Shared
- (Shared_Parser.Trace,
- Shared_Parser.Lexer.all'Access,
- Shared_Parser.Table,
- Shared_Parser.Language_Fixes,
- Shared_Parser.Language_Use_Minimal_Complete_Actions,
- Shared_Parser.Language_String_ID_Set,
- Shared_Parser.Terminals'Access,
- Shared_Parser.Line_Begin_Token'Access);
-
- Task_Count : constant System.Multiprocessors.CPU_Range :=
- (if Shared_Parser.Table.McKenzie_Param.Task_Count = 0
- then Worker_Tasks'Last
- -- Keep one CPU free for this main task, and the user.
- else Shared_Parser.Table.McKenzie_Param.Task_Count);
-
- begin
- if Trace_McKenzie > Outline then
- Trace.New_Line;
- Trace.Put_Line (" McKenzie error recovery");
- end if;
-
- Super.Initialize (Parsers'Unrestricted_Access,
Shared_Parser.Terminals'Unrestricted_Access);
-
- for Parser_State of Parsers loop
- Recover_Init (Shared_Parser, Parser_State);
- end loop;
-
- if Trace_McKenzie > Outline then
- Trace.New_Line;
- Trace.Put_Line (System.Multiprocessors.CPU_Range'Image
(Worker_Tasks'Last) & " parallel tasks");
- end if;
-
- for I in Worker_Tasks'First .. Task_Count loop
- if Worker_Tasks (I) = null then
- Worker_Tasks (I) := new Worker_Task;
- if Debug_Mode then
- Trace.Put_Line ("new Worker_Task" &
System.Multiprocessors.CPU_Range'Image (I));
- end if;
-
- elsif Worker_Tasks (I)'Terminated then
- Free (Worker_Tasks (I));
- Worker_Tasks (I) := new Worker_Task;
- if Debug_Mode then
- Trace.Put_Line ("recreated Worker_Task" &
System.Multiprocessors.CPU_Range'Image (I));
- end if;
- end if;
-
- Worker_Tasks (I).Start (Super'Unchecked_Access,
Shared'Unchecked_Access);
- end loop;
-
- declare
- use Ada.Exceptions;
- ID : Exception_Id;
- Message : Ada.Strings.Unbounded.Unbounded_String;
- begin
- Super.Done (ID, Message); -- Wait for all parsers to fail or succeed
-
- -- Ensure all worker tasks stop getting configs before proceeding;
- -- otherwise local variables disappear while the task is still trying
- -- to access them.
- for I in Worker_Tasks'First .. Task_Count loop
- if not Worker_Tasks (I)'Terminated then
- Worker_Tasks (I).Done;
- end if;
- end loop;
-
- if ID /= Null_Id then
- Raise_Exception (ID, -Message);
- end if;
- end;
-
- -- Adjust parser state for each successful recovery.
- --
- -- One option here would be to keep only the parser with the least
- -- cost fix. However, the normal reason for having multiple parsers
- -- is to resolve a grammar ambiguity; the least cost fix might
- -- resolve the ambiguity the wrong way. As could any other fix, of
- -- course.
-
- -- Spawn new parsers for multiple solutions
- declare
- use Parser_Lists;
- Cur : Cursor := Parsers.First;
- Solutions : SAL.Base_Peek_Type := 0;
- Spawn_Limit : SAL.Base_Peek_Type := Shared_Parser.Max_Parallel; --
per parser
- begin
- for Parser of Parsers loop
- if Parser.Recover.Success then
- Solutions := Solutions + Parser.Recover.Results.Count;
- end if;
- end loop;
-
- if Solutions > Shared_Parser.Max_Parallel and Trace_McKenzie >
Outline then
- Trace.Put_Line ("too many parallel parsers required in recover;
dropping some solutions");
- Spawn_Limit := Shared_Parser.Max_Parallel / Parsers.Count;
- end if;
-
- loop
- declare
- Data : McKenzie_Data renames State_Ref (Cur).Recover;
- begin
- if Data.Success then
- if Trace_McKenzie > Outline then
- Trace.Put_Line
- (Integer'Image (Label (Cur)) &
- ": succeed" & SAL.Base_Peek_Type'Image
(Data.Results.Count) &
- ", enqueue" & Integer'Image (Data.Enqueue_Count) &
- ", check " & Integer'Image (Data.Check_Count) &
- ", cost: " & Integer'Image (Data.Results.Min_Key));
- end if;
-
- if Data.Results.Count > 1 then
- for I in 1 .. SAL.Base_Peek_Type'Min (Spawn_Limit,
Data.Results.Count - 1) loop
- Parsers.Prepend_Copy (Cur); -- does not copy recover
- if Trace_McKenzie > Outline or Trace_Parse > Outline
then
- Trace.Put_Line
- ("spawn parser" & Integer'Image
(Parsers.First.Label) & " from " &
- Trimmed_Image (Cur.Label) & " (" &
Trimmed_Image (Integer (Parsers.Count)) &
- " active)");
- Put ("", Trace, Parsers.First.Label,
Shared_Parser.Terminals,
- Data.Results.Peek, Task_ID => False);
- end if;
-
- State_Ref (Parsers.First).Recover.Results.Add
(Data.Results.Remove);
- State_Ref (Parsers.First).Recover.Success := True;
- end loop;
- end if;
-
- if Trace_McKenzie > Outline or Trace_Parse > Outline then
- Put ("", Trace, Cur.State_Ref.Label,
Shared_Parser.Terminals, Data.Results.Peek,
- Task_ID => False);
- end if;
- else
- if Trace_McKenzie > Outline then
- Trace.Put_Line
- (Integer'Image (Cur.Label) &
- ": fail, enqueue" & Integer'Image
(Data.Enqueue_Count) &
- ", check " & Integer'Image (Data.Check_Count) &
- ", cost_limit: " & Integer'Image
(Shared_Parser.Table.McKenzie_Param.Cost_Limit) &
- ", max shared_token " & Token_Index'Image
(Shared_Parser.Terminals.Last_Index));
- end if;
- end if;
-
- end;
- Next (Cur);
- exit when Is_Done (Cur);
- end loop;
- end;
-
- -- Edit Parser_State to apply solutions.
-
- -- We don't use 'for Parser_State of Parsers loop' here,
- -- because we might need to terminate a parser.
- Current_Parser := Parsers.First;
- loop
- exit when Current_Parser.Is_Done;
-
- if Current_Parser.State_Ref.Recover.Success then
- begin
- -- Can't have active 'renames State_Ref' when terminate a
parser
- declare
- use all type Syntax_Trees.Node_Index;
- use Parser_Lists;
-
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
-
- Descriptor : WisiToken.Descriptor renames
Shared_Parser.Trace.Descriptor.all;
- Tree : Syntax_Trees.Tree renames Parser_State.Tree;
- Data : McKenzie_Data renames Parser_State.Recover;
- Result : Configuration renames Data.Results.Peek;
-
- Min_Op_Token_Index : WisiToken.Token_Index :=
WisiToken.Token_Index'Last;
- Min_Push_Back_Token_Index : WisiToken.Token_Index :=
WisiToken.Token_Index'Last;
-
- Stack_Matches_Ops : Boolean := True;
- Shared_Token_Changed : Boolean := False;
- Current_Token_Virtual : Boolean := False;
-
- Sorted_Insert_Delete : Sorted_Insert_Delete_Arrays.Vector;
-
- procedure Apply_Prev_Token
- is begin
- loop
- exit when not Parser_State.Prev_Deleted.Contains
(Parser_State.Shared_Token);
- Parser_State.Shared_Token := Parser_State.Shared_Token
+ 1;
- end loop;
- end Apply_Prev_Token;
-
- begin
- -- The verb will be reset by the main parser; just indicate
the
- -- parser recovered from the error.
- Parser_State.Set_Verb (Shift);
-
- Parser_State.Errors (Parser_State.Errors.Last).Recover :=
Result;
-
- Parser_State.Resume_Token_Goal := Result.Resume_Token_Goal;
-
- if Trace_McKenzie > Extra then
- Put_Line (Trace, Parser_State.Label, "before Ops
applied:", Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "stack " & Image
(Parser_State.Stack, Descriptor, Tree),
- Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "Shared_Token " & Image
- (Parser_State.Shared_Token, Shared_Parser.Terminals,
Descriptor),
- Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "Current_Token " &
Parser_State.Tree.Image
- (Parser_State.Current_Token, Descriptor),
- Task_ID => False);
- end if;
-
- -- We don't apply all Ops to the parser stack here, because
that
- -- requires updating the syntax tree as well, and we want
to let the
- -- main parser do that, partly as a double check on the
algorithms
- -- here.
- --
- -- However, the main parser can only apply Insert and
Delete ops; we
- -- must apply Push_Back and Undo_Reduce here. Note that
Fast_Forward
- -- ops are just for bookkeeping.
- --
- -- In order to apply Undo_Reduce, we also need to apply any
preceding
- -- ops. See test_mckenzie_recover.adb Missing_Name_2 for an
example
- -- of multiple Undo_Reduce. On the other hand, Push_Back
can be
- -- applied without the preceding ops.
- --
- -- A Push_Back can go back past preceding ops, including
Undo_Reduce;
- -- there's no point in applying ops that are later
superceded by such
- -- a Push_Back. See test_mckenzie_recover.adb
Out_Of_Order_Ops for an
- -- example.
- --
- -- Push_Back can also go back past a previous error
recovery; we must
- -- apply Parser_State.Prev_Deleted here as well, when
computing
- -- Shared_Token.
- --
- -- So first we go thru Ops to find the earliest Push_Back.
Then we
- -- apply ops that are before that point, up to the first
Insert or
- -- Fast_Forward. After that, we enqueue Insert and Delete
ops on
- -- Parser_State.Recover_Insert_Delete, in token_index
order, and any
- -- Undo_Reduce are rejected.
- --
- -- Then the main parser parses the edited input stream.
- --
- -- There's no need to modify Parser_State.Tree. Any tree
nodes
- -- created by the failed parse that are pushed back are
useful for
- -- error repair, and will just be ignored in future
parsing. This
- -- also avoids enlarging a non-flushed branched tree, which
saves
- -- time and space.
-
- for Op of Result.Ops loop
- case Op.Op is
- when Fast_Forward =>
- if Op.FF_Token_Index < Min_Op_Token_Index then
- Min_Op_Token_Index := Op.FF_Token_Index;
- end if;
-
- when Undo_Reduce =>
- null;
-
- when Push_Back | Insert | Delete =>
- if Op.Token_Index /= Invalid_Token_Index then
- if Op.Token_Index < Min_Op_Token_Index then
- Min_Op_Token_Index := Op.Token_Index;
- end if;
- if Op.Token_Index < Min_Push_Back_Token_Index then
- Min_Push_Back_Token_Index := Op.Token_Index;
- end if;
- end if;
-
- end case;
- end loop;
-
- for Op of Result.Ops loop
- case Op.Op is
- when Fast_Forward =>
- Stack_Matches_Ops := False;
-
- when Undo_Reduce =>
- if not Stack_Matches_Ops then
- if Trace_McKenzie > Outline then
- Put_Line
- (Trace, Parser_State.Label, "Undo_Reduce after
insert or fast_forward",
- Task_ID => False);
- end if;
- raise Bad_Config;
- end if;
-
- declare
- Item : constant Parser_Lists.Parser_Stack_Item :=
Parser_State.Stack.Pop;
- begin
- case Tree.Label (Item.Token) is
- when Syntax_Trees.Shared_Terminal |
Syntax_Trees.Virtual_Terminal =>
- raise Bad_Config;
-
- when Syntax_Trees.Nonterm =>
- for C of Tree.Children (Item.Token) loop
- Parser_State.Stack.Push ((Tree.State (C), C));
- end loop;
- end case;
- end;
-
- when Push_Back =>
- if Stack_Matches_Ops then
- Parser_State.Stack.Pop;
- if Op.Token_Index /= Invalid_Token_Index then
- Parser_State.Shared_Token := Op.Token_Index;
- Shared_Token_Changed := True;
- end if;
-
- elsif Op.Token_Index = Min_Op_Token_Index then
- loop
- -- Multiple push_backs can have the same
Op.Token_Index, so we may
- -- already be at the target.
- exit when Parser_State.Shared_Token <=
Op.Token_Index and
- Tree.Min_Terminal_Index (Parser_State.Stack
(1).Token) /= Invalid_Token_Index;
- -- also push back empty tokens.
-
- declare
- Item : constant
Parser_Lists.Parser_Stack_Item := Parser_State.Stack.Pop;
-
- Min_Index : constant Base_Token_Index :=
- Parser_State.Tree.Min_Terminal_Index
(Item.Token);
- begin
- if Min_Index /= Invalid_Token_Index then
- Shared_Token_Changed := True;
- Parser_State.Shared_Token := Min_Index;
- end if;
- end;
- end loop;
- pragma Assert (Parser_State.Shared_Token =
Op.Token_Index);
- end if;
-
- when Insert =>
- if Stack_Matches_Ops and Op.Token_Index =
Parser_State.Shared_Token then
- -- This is the first Insert. Even if a later
Push_Back supercedes it,
- -- we record Stack_Matches_Ops false here.
- Stack_Matches_Ops := False;
-
- if Op.Token_Index <= Min_Push_Back_Token_Index then
- Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (Op.ID);
- Current_Token_Virtual := True;
- else
- Sorted_Insert_Delete.Insert (Op);
- end if;
- else
- Sorted_Insert_Delete.Insert (Op);
- end if;
-
- when Delete =>
- if Stack_Matches_Ops and Op.Token_Index =
Parser_State.Shared_Token then
- -- We can apply multiple deletes.
- Parser_State.Shared_Token := Op.Token_Index + 1;
- Apply_Prev_Token;
- Shared_Token_Changed := True;
- else
- Sorted_Insert_Delete.Insert (Op);
- end if;
- end case;
- end loop;
-
- -- We may not have processed the current Insert or Delete
above, if
- -- they are after a fast_forward.
- for Op of Sorted_Insert_Delete loop
- if Op.Token_Index = Parser_State.Shared_Token and not
Current_Token_Virtual then
- case Insert_Delete_Op_Label'(Op.Op) is
- when Insert =>
- Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (Op.ID);
- Current_Token_Virtual := True;
-
- when Delete =>
- Parser_State.Shared_Token := Op.Token_Index + 1;
- Apply_Prev_Token;
- Shared_Token_Changed := True;
- end case;
- else
- Parser_State.Recover_Insert_Delete.Put (Op);
- end if;
- end loop;
-
- -- If not Shared_Token_Changed, Shared_Token is the error
token,
- -- which is the next token to read. If
Shared_Token_Changed, we have
- -- set Shared_Token consistent with that; it is the next
token to
- -- read. If Current_Token_Virtual, then after all the
virtual tokens
- -- are inserted, the main parser would normally increment
- -- Parser_State.Shared_Token to get the next token, but we
don't want
- -- that now. We could set Shared_Token to 1 less, but this
way the
- -- debug messages all show the expected Shared_Terminal.
-
- Parser_State.Inc_Shared_Token := not Current_Token_Virtual;
-
- -- The main parser always sets Current_Token to be the
syntax tree
- -- node containing Shared_Token; ensure that is true here
(virtual
- -- tokens where handled above).
-
- if (not Current_Token_Virtual) and Shared_Token_Changed then
- Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
- (Parser_State.Shared_Token, Shared_Parser.Terminals);
- end if;
-
- if Trace_McKenzie > Extra then
- Put_Line (Trace, Parser_State.Label, "after Ops
applied:", Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "stack " &
Parser_Lists.Image
- (Parser_State.Stack, Descriptor, Tree),
- Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "Shared_Token " & Image
- (Parser_State.Shared_Token, Shared_Parser.Terminals,
Descriptor), Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "Current_Token " &
Parser_State.Tree.Image
- (Parser_State.Current_Token, Descriptor), Task_ID =>
False);
- Put_Line
- (Trace, Parser_State.Label, "recover_insert_delete " &
Image
- (Parser_State.Recover_Insert_Delete, Descriptor),
Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "inc_shared_token " &
Boolean'Image (Parser_State.Inc_Shared_Token) &
- " parser verb " & All_Parse_Action_Verbs'Image
(Parser_State.Verb),
- Task_ID => False);
- end if;
- end;
- exception
- when Bad_Config =>
- if Parsers.Count = 1 then
- -- Oops. just give up
- return Fail_Programmer_Error;
- end if;
- Parsers.Terminate_Parser (Current_Parser, "bad config in
recover", Trace, Shared_Parser.Terminals);
- end;
- end if;
- Current_Parser.Next;
- end loop;
-
- if Shared_Parser.Post_Recover /= null then
- Shared_Parser.Post_Recover.all;
- end if;
-
- return Super.Recover_Result;
-
- exception
- when others =>
- return Fail_Programmer_Error;
- end Recover;
-
- ----------
- -- Spec private subprograms; for language-specific
- -- child packages.
-
- procedure Check (ID : Token_ID; Expected_ID : in Token_ID)
- is begin
- pragma Assert (ID = Expected_ID, Token_ID'Image (ID) & " /=" &
Token_ID'Image (Expected_ID));
- end Check;
-
- function Current_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out WisiToken.Base_Token_Index;
- Restore_Terminals_Current : out WisiToken.Base_Token_Index;
- Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
- return Base_Token
- is
- use all type SAL.Base_Peek_Type;
-
- procedure Inc_I_D
- is begin
- Current_Insert_Delete := Current_Insert_Delete + 1;
- if Current_Insert_Delete > Insert_Delete.Last_Index then
- Current_Insert_Delete := No_Insert_Delete;
- Insert_Delete.Clear;
- end if;
- end Inc_I_D;
-
- begin
- if Terminals_Current = Invalid_Token_Index then
- -- Happens with really bad syntax; see test_mckenzie_recover.adb
Error_4.
- raise Bad_Config;
- end if;
-
- loop
- if Current_Insert_Delete = No_Insert_Delete then
- Restore_Terminals_Current := Terminals_Current;
- return Terminals (Terminals_Current);
-
- elsif Insert_Delete (Current_Insert_Delete).Token_Index =
Terminals_Current then
- declare
- Op : Insert_Delete_Op renames Insert_Delete
(Current_Insert_Delete);
- begin
- case Insert_Delete_Op_Label (Op.Op) is
- when Insert =>
- -- Decrement Terminals_Current so Next_Token knows it
should always
- -- increment it. Save the initial value, to restore in case
of error.
- Restore_Terminals_Current := Terminals_Current;
- Terminals_Current := Terminals_Current - 1;
- return (ID => Op.ID, others => <>);
-
- when Delete =>
- Terminals_Current := Terminals_Current + 1;
- loop
- exit when not Prev_Deleted.Contains (Terminals_Current);
- Terminals_Current := Terminals_Current + 1;
- end loop;
- Restore_Terminals_Current := Terminals_Current;
- Inc_I_D;
- end case;
- end;
- else
- return Terminals (Terminals_Current);
- end if;
- end loop;
- end Current_Token;
-
- procedure Current_Token_ID_Peek_2
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in Base_Token_Index;
- Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector;
- Current_Token : out Token_ID;
- Next_Token : out Token_ID)
- is
- use all type SAL.Base_Peek_Type;
- Terminals_Next : Token_Index := Terminals_Current + 1;
- begin
- if Terminals_Current = Base_Token_Index'First then
- -- Happens with really bad syntax; see test_mckenzie_recover.adb
Error_4.
- raise Bad_Config;
- end if;
-
- loop
- exit when not Prev_Deleted.Contains (Terminals_Next);
- Terminals_Next := Terminals_Next + 1;
- end loop;
- if Terminals_Next <= Terminals.Last_Index then
- Next_Token := Terminals (Terminals_Next).ID;
- else
- Next_Token := Invalid_Token_ID;
- end if;
-
- if Current_Insert_Delete = No_Insert_Delete then
- Current_Token := Terminals (Terminals_Current).ID;
-
- elsif Insert_Delete (Current_Insert_Delete).Token_Index =
Terminals_Current then
- declare
- Op : Insert_Delete_Op renames Insert_Delete
(Current_Insert_Delete);
- begin
- case Insert_Delete_Op_Label (Op.Op) is
- when Insert =>
- Current_Token := Op.ID;
-
- when Delete =>
- -- This should have been handled in Check
- raise SAL.Programmer_Error;
- end case;
- end;
- else
- Current_Token := Terminals (Terminals_Current).ID;
- end if;
-
- if Current_Insert_Delete = Insert_Delete.Last_Index then
- null;
-
- elsif Insert_Delete (Current_Insert_Delete + 1).Token_Index =
Terminals_Current then
- declare
- Op : Insert_Delete_Op renames Insert_Delete (Current_Insert_Delete
+ 1);
- begin
- case Insert_Delete_Op_Label (Op.Op) is
- when Insert =>
- Next_Token := Op.ID;
-
- when Delete =>
- -- This should have been handled in Check
- raise SAL.Programmer_Error;
- end case;
- end;
- end if;
- end Current_Token_ID_Peek_2;
-
- procedure Delete (Config : in out Configuration; ID : in Token_ID)
- is
- Op : constant Config_Op := (Delete, ID, Config.Current_Shared_Token);
- begin
- Config.Ops.Append (Op);
- Config.Insert_Delete.Insert (Op);
- Config.Current_Insert_Delete := 1;
- exception
- when SAL.Container_Full =>
- raise Bad_Config;
- end Delete;
-
- procedure Find_ID
- (Config : in Configuration;
- ID : in Token_ID;
- Matching_Index : in out SAL.Peek_Type)
- is
- use all type SAL.Peek_Type;
- begin
- loop
- exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- declare
- Stack_ID : Token_ID renames Config.Stack (Matching_Index).Token.ID;
- begin
- exit when Stack_ID = ID;
- end;
- Matching_Index := Matching_Index + 1;
- end loop;
- end Find_ID;
-
- procedure Find_ID
- (Config : in Configuration;
- IDs : in Token_ID_Set;
- Matching_Index : in out SAL.Peek_Type)
- is
- use all type SAL.Peek_Type;
- begin
- loop
- exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- declare
- ID : Token_ID renames Config.Stack (Matching_Index).Token.ID;
- begin
- exit when ID in IDs'First .. IDs'Last and then IDs (ID);
- end;
- Matching_Index := Matching_Index + 1;
- end loop;
- end Find_ID;
-
- procedure Find_Descendant_ID
- (Tree : in Syntax_Trees.Tree;
- Config : in Configuration;
- ID : in Token_ID;
- ID_Set : in Token_ID_Set;
- Matching_Index : in out SAL.Peek_Type)
- is
- use Syntax_Trees;
- use all type SAL.Peek_Type;
- begin
- loop
- exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- exit when Config.Stack (Matching_Index).Token.ID in ID_Set'Range and
then
- (ID_Set (Config.Stack (Matching_Index).Token.ID) and
- (Config.Stack (Matching_Index).Tree_Index /= Invalid_Node_Index
and then
- Tree.Find_Descendant (Config.Stack
(Matching_Index).Tree_Index, ID) /= Invalid_Node_Index));
-
- Matching_Index := Matching_Index + 1;
- end loop;
- end Find_Descendant_ID;
-
- procedure Find_Matching_Name
- (Config : in Configuration;
- Lexer : access constant WisiToken.Lexer.Instance'Class;
- Name : in String;
- Matching_Name_Index : in out SAL.Peek_Type;
- Case_Insensitive : in Boolean)
- is
- use Ada.Characters.Handling;
- use all type SAL.Peek_Type;
- Match_Name : constant String := (if Case_Insensitive then To_Lower
(Name) else Name);
- begin
- loop
- exit when Matching_Name_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- declare
- Token : Recover_Token renames Config.Stack
(Matching_Name_Index).Token;
- Name_Region : constant Buffer_Region :=
- (if Token.Name = Null_Buffer_Region
- then Token.Byte_Region
- else Token.Name);
- begin
- exit when Name_Region /= Null_Buffer_Region and then
- Match_Name =
- (if Case_Insensitive
- then To_Lower (Lexer.Buffer_Text (Name_Region))
- else Lexer.Buffer_Text (Name_Region));
-
- Matching_Name_Index := Matching_Name_Index + 1;
- end;
- end loop;
- end Find_Matching_Name;
-
- procedure Find_Matching_Name
- (Config : in Configuration;
- Lexer : access constant WisiToken.Lexer.Instance'Class;
- Name : in String;
- Matching_Name_Index : in out SAL.Peek_Type;
- Other_ID : in Token_ID;
- Other_Count : out Integer;
- Case_Insensitive : in Boolean)
- is
- use Ada.Characters.Handling;
- use all type SAL.Peek_Type;
- Match_Name : constant String := (if Case_Insensitive then To_Lower
(Name) else Name);
- begin
- Other_Count := 0;
-
- loop
- exit when Matching_Name_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- declare
- Token : Recover_Token renames Config.Stack
(Matching_Name_Index).Token;
- Name_Region : constant Buffer_Region :=
- (if Token.Name = Null_Buffer_Region
- then Token.Byte_Region
- else Token.Name);
- begin
- exit when Name_Region /= Null_Buffer_Region and then
- Match_Name =
- (if Case_Insensitive
- then To_Lower (Lexer.Buffer_Text (Name_Region))
- else Lexer.Buffer_Text (Name_Region));
-
- if Other_ID = Token.ID then
- Other_Count := Other_Count + 1;
- end if;
-
- Matching_Name_Index := Matching_Name_Index + 1;
- end;
- end loop;
- end Find_Matching_Name;
-
- procedure Insert (Config : in out Configuration; ID : in Token_ID)
- is
- Op : constant Config_Op := (Insert, ID, Config.Current_Shared_Token);
- begin
- Config.Ops.Append (Op);
- Config.Insert_Delete.Insert (Op);
- Config.Current_Insert_Delete := 1;
- exception
- when SAL.Container_Full =>
- raise Bad_Config;
- end Insert;
-
- procedure Insert (Config : in out Configuration; IDs : in Token_ID_Array)
- is begin
- for ID of IDs loop
- Insert (Config, ID);
- end loop;
- end Insert;
-
- function Next_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out Base_Token_Index;
- Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
- Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
- return Base_Token
- is
- use all type SAL.Base_Peek_Type;
-
- function Next_Terminal return Base_Token
- is begin
- Terminals_Current := Terminals_Current + 1;
- loop
- exit when not Prev_Deleted.Contains (Terminals_Current);
- Terminals_Current := Terminals_Current + 1;
- end loop;
-
- Restore_Terminals_Current := Terminals_Current;
- return Terminals (Terminals_Current);
- end Next_Terminal;
-
- begin
- loop
- if Insert_Delete.Last_Index > 0 and then Current_Insert_Delete =
Insert_Delete.Last_Index then
- Current_Insert_Delete := No_Insert_Delete;
- Insert_Delete.Clear;
- return Next_Terminal;
-
- elsif Current_Insert_Delete = No_Insert_Delete then
- return Next_Terminal;
-
- elsif Insert_Delete (Current_Insert_Delete + 1).Token_Index =
Terminals_Current + 1 then
- Current_Insert_Delete := Current_Insert_Delete + 1;
- declare
- Op : constant Insert_Delete_Op := Insert_Delete
(Current_Insert_Delete);
- begin
- case Insert_Delete_Op_Label'(Op.Op) is
- when Insert =>
- return (ID => Op.ID, others => <>);
-
- when Delete =>
- Terminals_Current := Terminals_Current + 1;
- Restore_Terminals_Current := Terminals_Current;
- end case;
- end;
-
- else
- return Next_Terminal;
- end if;
- end loop;
- end Next_Token;
-
- procedure Push_Back (Config : in out Configuration)
- is
- Item : constant Recover_Stack_Item := Config.Stack.Pop;
- Token_Index : constant Base_Token_Index :=
Item.Token.Min_Terminal_Index;
-
- function Compare (Left : in Base_Token_Index; Right : in Config_Op)
return Boolean
- is (case Right.Op is
- when Fast_Forward => False,
- when Undo_Reduce => False,
- when Push_Back => False,
- when Insert | Delete => Left < Right.Token_Index);
- -- If Left = Right.Token_Index, we assume the Right ops go _after_
- -- the Left, so the Left do not need to be repeated.
- begin
- if Token_Index /= Invalid_Token_Index then
- Config.Current_Shared_Token := Token_Index;
- for I in Config.Ops.First_Index .. Config.Ops.Last_Index loop
- if Compare (Token_Index, Config.Ops (I)) then
- Config.Insert_Delete.Insert (Config.Ops (I));
- end if;
- end loop;
- end if;
-
- Config.Ops.Append ((Push_Back, Item.Token.ID,
Config.Current_Shared_Token));
- exception
- when SAL.Container_Full =>
- raise Bad_Config;
- end Push_Back;
-
- procedure Push_Back_Check (Config : in out Configuration; Expected_ID : in
Token_ID)
- is begin
- Check (Config.Stack (1).Token.ID, Expected_ID);
- Push_Back (Config);
- end Push_Back_Check;
-
- procedure Push_Back_Check (Config : in out Configuration; Expected : in
Token_ID_Array)
- is begin
- for ID of Expected loop
- Push_Back_Check (Config, ID);
- end loop;
- end Push_Back_Check;
-
- procedure Put
- (Message : in String;
- Trace : in out WisiToken.Trace'Class;
- Parser_Label : in Natural;
- Terminals : in Base_Token_Arrays.Vector;
- Config : in Configuration;
- Task_ID : in Boolean := True)
- is
- -- For debugging output
-
- -- Build a string, call trace.put_line once, so output from multiple
- -- tasks is not interleaved (mostly).
- use all type Ada.Strings.Unbounded.Unbounded_String;
- use all type SAL.Base_Peek_Type;
- use all type WisiToken.Semantic_Checks.Check_Status_Label;
-
- Descriptor : WisiToken.Descriptor renames Trace.Descriptor.all;
-
- Result : Ada.Strings.Unbounded.Unbounded_String :=
- (if Task_ID then +Ada.Task_Identification.Image
(Ada.Task_Identification.Current_Task) else +"") &
- Integer'Image (Parser_Label) & ": " &
- (if Message'Length > 0 then Message & ":" else "");
- begin
- Result := Result & Natural'Image (Config.Cost) & ", ";
- if Config.Check_Status.Label /= Ok then
- Result := Result & Semantic_Checks.Check_Status_Label'Image
(Config.Check_Status.Label) & " ";
- elsif Config.Error_Token.ID /= Invalid_Token_ID then
- Result := Result & "Error " & Image (Config.Error_Token, Descriptor)
& " ";
- end if;
- Result := Result & Image (Config.Stack, Descriptor, Depth => 1);
-
- if Config.Current_Insert_Delete = No_Insert_Delete then
- Result := Result & "|" & Image (Config.Current_Shared_Token,
Terminals, Descriptor) & "|";
- else
- Result := Result & "/" & Trimmed_Image (Config.Current_Insert_Delete)
& ":" &
- Image (Config.Insert_Delete (Config.Current_Insert_Delete),
Descriptor) & "/";
- end if;
-
- Result := Result & Image (Config.Ops, Descriptor);
- Trace.Put_Line (-Result);
- end Put;
-
- procedure Put_Line
- (Trace : in out WisiToken.Trace'Class;
- Parser_Label : in Natural;
- Message : in String;
- Task_ID : in Boolean := True)
- is begin
- Trace.Put_Line
- ((if Task_ID then Ada.Task_Identification.Image
(Ada.Task_Identification.Current_Task) else "") &
- Integer'Image (Parser_Label) & ": " & Message);
- end Put_Line;
-
- function Undo_Reduce
- (Stack : in out Recover_Stacks.Stack;
- Tree : in Syntax_Trees.Tree)
- return Ada.Containers.Count_Type
- is
- Nonterm_Item : constant Recover_Stack_Item := Stack.Pop;
- Children : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Children (Nonterm_Item.Tree_Index);
- begin
- for C of Children loop
- Stack.Push ((Tree.State (C), C, Tree.Recover_Token (C)));
- end loop;
- return Children'Length;
- end Undo_Reduce;
-
- procedure Undo_Reduce_Check
- (Config : in out Configuration;
- Tree : in Syntax_Trees.Tree;
- Expected : in Token_ID)
- is begin
- Check (Config.Stack (1).Token.ID, Expected);
- Config.Ops.Append ((Undo_Reduce, Expected, Undo_Reduce (Config.Stack,
Tree)));
- exception
- when SAL.Container_Full =>
- raise Bad_Config;
- end Undo_Reduce_Check;
-
- procedure Undo_Reduce_Check
- (Config : in out Configuration;
- Tree : in Syntax_Trees.Tree;
- Expected : in Token_ID_Array)
- is begin
- for ID of Expected loop
- Undo_Reduce_Check (Config, Tree, ID);
- end loop;
- end Undo_Reduce_Check;
-
-end WisiToken.Parse.LR.McKenzie_Recover;
+-- Abstract :
+--
+-- See spec
+--
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Characters.Handling;
+with Ada.Exceptions;
+with Ada.Unchecked_Deallocation;
+with System.Multiprocessors;
+with WisiToken.Parse.LR.McKenzie_Recover.Base;
+with WisiToken.Parse.LR.McKenzie_Recover.Explore;
+with WisiToken.Parse.LR.Parser_Lists;
+package body WisiToken.Parse.LR.McKenzie_Recover is
+ use all type System.Multiprocessors.CPU_Range;
+
+ type Supervisor_Access is access all Base.Supervisor;
+ type Shared_Access is access all Base.Shared;
+
+ task type Worker_Task is
+ entry Start
+ (ID : in Integer;
+ Super : in Supervisor_Access;
+ Shared : in Shared_Access);
+ -- Start getting parser/configs to check from Config_Store. Stop when
+ -- Super reports All_Done;
+
+ entry Done;
+ -- Available after Super has reported All_Done.
+ end Worker_Task;
+
+ type Worker_Access is access Worker_Task;
+ procedure Free is new Ada.Unchecked_Deallocation (Worker_Task,
Worker_Access);
+
+ task body Worker_Task
+ is
+ use all type Base.Config_Status;
+ Super : Supervisor_Access;
+ Shared : Shared_Access;
+
+ Status : Base.Config_Status := Valid;
+ begin
+ loop
+ select
+ accept Start
+ (ID : in Integer;
+ Super : in Supervisor_Access;
+ Shared : in Shared_Access)
+
+ do
+ Task_Attributes.Set_Value (ID);
+ Worker_Task.Super := Super;
+ Worker_Task.Shared := Shared;
+ end Start;
+ or
+ terminate;
+ end select;
+
+ loop
+ Explore.Process_One (Super, Shared, Status);
+ exit when Status = All_Done;
+ end loop;
+
+ accept Done;
+
+ Super := null;
+ Shared := null;
+ end loop;
+
+ exception
+ when E : others =>
+ Super.Fatal (E);
+ end Worker_Task;
+
+ Worker_Tasks : array (1 .. System.Multiprocessors.CPU_Range'Max (1,
System.Multiprocessors.Number_Of_CPUs - 1)) of
+ Worker_Access;
+ -- Declaring an array of tasks directly causes a circular elaboration
+ -- problem, and would mean a task that terminates due to an exception
+ -- is never restarted.
+
+ function To_Recover
+ (Parser_Stack : in Parser_Lists.Parser_Stacks.Stack;
+ Tree : in Syntax_Trees.Tree)
+ return Recover_Stacks.Stack
+ is
+ use all type SAL.Base_Peek_Type;
+ Result : Recover_Stacks.Stack;
+ Depth : constant SAL.Peek_Type := Parser_Stack.Depth;
+ begin
+ Result.Set_Depth (Depth);
+ for I in 1 .. Depth loop
+ declare
+ Item : Parser_Lists.Parser_Stack_Item renames Parser_Stack (I);
+ Token : constant Recover_Token := (if I = Depth then (others =>
<>) else Tree.Recover_Token (Item.Token));
+ begin
+ Result.Set (I, Depth, (Item.State, Item.Token, Token));
+ end;
+ end loop;
+ return Result;
+ end To_Recover;
+
+ procedure Recover_Init
+ (Shared_Parser : in out LR.Parser.Parser;
+ Parser_State : in out Parser_Lists.Parser_State)
+ is
+ use all type WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+ Config : constant Configuration_Access :=
Parser_State.Recover.Config_Heap.Add (Configuration'(others => <>));
+ Error : Parse_Error renames Parser_State.Errors
(Parser_State.Errors.Last);
+ begin
+ Parser_State.Recover.Enqueue_Count := Parser_State.Recover.Enqueue_Count
+ 1;
+
+ Config.Resume_Token_Goal := Parser_State.Shared_Token +
Shared_Parser.Table.McKenzie_Param.Check_Limit;
+
+ if Trace_McKenzie > Outline then
+ Trace.New_Line;
+ Trace.Put_Line
+ ("parser" & Integer'Image (Parser_State.Label) &
+ ": State" & State_Index'Image (Parser_State.Stack (1).State) &
+ " Current_Token" & Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) &
+ " Resume_Token_Goal" & WisiToken.Token_Index'Image
(Config.Resume_Token_Goal));
+ Trace.Put_Line
+ ((case Error.Label is
+ when Action => "Action",
+ when Check => "Check, " & Semantic_Checks.Image
(Error.Check_Status, Trace.Descriptor.all),
+ when Message => raise SAL.Programmer_Error));
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Trace, Parser_State.Label, Parser_Lists.Image
+ (Parser_State.Stack, Trace.Descriptor.all,
Parser_State.Tree));
+ end if;
+ end if;
+
+ -- Additional initialization of Parser_State.Recover is done in
+ -- Supervisor.Initialize.
+
+ Config.Stack := To_Recover (Parser_State.Stack, Parser_State.Tree);
+
+ -- Parser_State.Recover_Insert_Delete must be empty (else we would not
get
+ -- here). Therefore Parser_State current token is in
+ -- Shared_Parser.Shared_Token.
+
+ Config.Current_Shared_Token := Parser_State.Shared_Token;
+
+ case Error.Label is
+ when Action =>
+ Config.Error_Token := Parser_State.Tree.Recover_Token
(Error.Error_Token);
+ if Trace_McKenzie > Detail then
+ Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config.all,
+ Task_ID => False);
+ end if;
+
+ when Check =>
+ if Shared_Parser.Language_Fixes = null then
+ -- The only fix is to ignore the error.
+ if Trace_McKenzie > Detail then
+ Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config.all,
+ Task_ID => False);
+ end if;
+
+ else
+ -- Undo the reduction that encountered the error, let Process_One
+ -- enqueue possible solutions. We leave the cost at 0, since this
is
+ -- the root config. Later logic will enqueue the 'ignore error'
+ -- solution; see McKenzie_Recover.Explore Process_One.
+
+ Config.Check_Status := Error.Check_Status;
+ Config.Error_Token := Config.Stack (1).Token;
+ Config.Check_Token_Count := Undo_Reduce (Config.Stack,
Parser_State.Tree);
+
+ Config.Ops.Append ((Undo_Reduce, Config.Error_Token.ID,
Config.Check_Token_Count));
+
+ if Trace_McKenzie > Detail then
+ Put ("undo_reduce " & Image
+ (Config.Error_Token.ID, Trace.Descriptor.all), Trace,
Parser_State.Label,
+ Shared_Parser.Terminals, Config.all, Task_ID => False);
+ end if;
+ end if;
+
+ when Message =>
+ -- Last error entry should be the failure that caused us to enter
+ -- recovery.
+ raise SAL.Programmer_Error;
+ end case;
+ end Recover_Init;
+
+ function Recover (Shared_Parser : in out LR.Parser.Parser) return
Recover_Status
+ is
+ use all type Parser.Post_Recover_Access;
+ use all type SAL.Base_Peek_Type;
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+
+ Parsers : Parser_Lists.List renames Shared_Parser.Parsers;
+
+ Current_Parser : Parser_Lists.Cursor;
+
+ Super : aliased Base.Supervisor
+ (Trace'Access,
+ Check_Delta_Limit =>
Shared_Parser.Table.McKenzie_Param.Check_Delta_Limit,
+ Enqueue_Limit => Shared_Parser.Table.McKenzie_Param.Enqueue_Limit,
+ Parser_Count => Parsers.Count);
+
+ Shared : aliased Base.Shared
+ (Shared_Parser.Trace,
+ Shared_Parser.Lexer.all'Access,
+ Shared_Parser.Table,
+ Shared_Parser.Language_Fixes,
+ Shared_Parser.Language_Matching_Begin_Tokens,
+ Shared_Parser.Language_String_ID_Set,
+ Shared_Parser.Terminals'Access,
+ Shared_Parser.Line_Begin_Token'Access);
+
+ Task_Count : constant System.Multiprocessors.CPU_Range :=
+ (if Shared_Parser.Table.McKenzie_Param.Task_Count = 0
+ then Worker_Tasks'Last
+ -- Keep one CPU free for this main task, and the user.
+ else Shared_Parser.Table.McKenzie_Param.Task_Count);
+
+ begin
+ if Trace_McKenzie > Outline then
+ Trace.New_Line;
+ Trace.Put_Line (" McKenzie error recovery");
+ end if;
+
+ Super.Initialize (Parsers'Unrestricted_Access,
Shared_Parser.Terminals'Unrestricted_Access);
+
+ for Parser_State of Parsers loop
+ Recover_Init (Shared_Parser, Parser_State);
+ end loop;
+
+ if Trace_McKenzie > Outline then
+ Trace.New_Line;
+ Trace.Put_Line (System.Multiprocessors.CPU_Range'Image
(Worker_Tasks'Last) & " parallel tasks");
+ end if;
+
+ for I in Worker_Tasks'First .. Task_Count loop
+ if Worker_Tasks (I) = null then
+ Worker_Tasks (I) := new Worker_Task;
+ if Debug_Mode then
+ Trace.Put_Line ("new Worker_Task" &
System.Multiprocessors.CPU_Range'Image (I));
+ end if;
+
+ elsif Worker_Tasks (I)'Terminated then
+ Free (Worker_Tasks (I));
+ Worker_Tasks (I) := new Worker_Task;
+ if Debug_Mode then
+ Trace.Put_Line ("recreated Worker_Task" &
System.Multiprocessors.CPU_Range'Image (I));
+ end if;
+ end if;
+
+ Worker_Tasks (I).Start (Integer (I), Super'Unchecked_Access,
Shared'Unchecked_Access);
+ end loop;
+
+ declare
+ use Ada.Exceptions;
+ ID : Exception_Id;
+ Message : Ada.Strings.Unbounded.Unbounded_String;
+ begin
+ Super.Done (ID, Message); -- Wait for all parsers to fail or succeed
+
+ -- Ensure all worker tasks stop getting configs before proceeding;
+ -- otherwise local variables disappear while the task is still trying
+ -- to access them.
+ for I in Worker_Tasks'First .. Task_Count loop
+ if not Worker_Tasks (I)'Terminated then
+ Worker_Tasks (I).Done;
+ end if;
+ end loop;
+
+ if ID /= Null_Id then
+ Raise_Exception (ID, -Message);
+ end if;
+ end;
+
+ -- Adjust parser state for each successful recovery.
+ --
+ -- One option here would be to keep only the parser with the least
+ -- cost fix. However, the normal reason for having multiple parsers
+ -- is to resolve a grammar ambiguity; the least cost fix might
+ -- resolve the ambiguity the wrong way. As could any other fix, of
+ -- course.
+
+ -- Spawn new parsers for multiple solutions.
+ --
+ -- We could try to check here for redundant solutions; configs for a
+ -- parser that have the same or "equivalent" ops. But those will be
+ -- caught in the main parse by the check for duplicate state; doing
+ -- the same check here is premature optimization.
+ declare
+ use Parser_Lists;
+ Cur : Cursor := Parsers.First;
+ Solutions : SAL.Base_Peek_Type := 0;
+ Spawn_Limit : SAL.Base_Peek_Type := Shared_Parser.Max_Parallel; --
per parser
+ begin
+ for Parser of Parsers loop
+ if Parser.Recover.Success then
+ Solutions := Solutions + Parser.Recover.Results.Count;
+ end if;
+ end loop;
+
+ if Solutions > Shared_Parser.Max_Parallel and Trace_McKenzie >
Outline then
+ Trace.Put_Line ("too many parallel parsers required in recover;
dropping some solutions");
+ Spawn_Limit := Shared_Parser.Max_Parallel / Parsers.Count;
+ end if;
+
+ loop
+ declare
+ Data : McKenzie_Data renames State_Ref (Cur).Recover;
+ begin
+ if Data.Success then
+ if Trace_McKenzie > Outline then
+ Trace.Put_Line
+ (Integer'Image (Label (Cur)) &
+ ": succeed" & SAL.Base_Peek_Type'Image
(Data.Results.Count) &
+ ", enqueue" & Integer'Image (Data.Enqueue_Count) &
+ ", check " & Integer'Image (Data.Check_Count) &
+ ", cost: " & Integer'Image (Data.Results.Min_Key));
+ end if;
+
+ if Data.Results.Count > 1 then
+ for I in 1 .. SAL.Base_Peek_Type'Min (Spawn_Limit,
Data.Results.Count - 1) loop
+ Parsers.Prepend_Copy (Cur); -- does not copy recover
+ if Trace_McKenzie > Outline or Trace_Parse > Outline
then
+ Trace.Put_Line
+ ("spawn parser" & Integer'Image
(Parsers.First.Label) & " from " &
+ Trimmed_Image (Cur.Label) & " (" &
Trimmed_Image (Integer (Parsers.Count)) &
+ " active)");
+ Put ("", Trace, Parsers.First.Label,
Shared_Parser.Terminals,
+ Data.Results.Peek, Task_ID => False, Strategy
=> True);
+ end if;
+
+ State_Ref (Parsers.First).Recover.Results.Add
(Data.Results.Remove);
+ State_Ref (Parsers.First).Recover.Success := True;
+ end loop;
+ end if;
+
+ if Trace_McKenzie > Outline or Trace_Parse > Outline then
+ Put ("", Trace, Cur.State_Ref.Label,
Shared_Parser.Terminals, Data.Results.Peek,
+ Task_ID => False, Strategy => True);
+ end if;
+ else
+ if Trace_McKenzie > Outline then
+ Trace.Put_Line
+ (Integer'Image (Cur.Label) &
+ ": fail, enqueue" & Integer'Image
(Data.Enqueue_Count) &
+ ", check " & Integer'Image (Data.Check_Count) &
+ ", max shared_token " & WisiToken.Token_Index'Image
(Shared_Parser.Terminals.Last_Index));
+ end if;
+ end if;
+
+ end;
+ Next (Cur);
+ exit when Is_Done (Cur);
+ end loop;
+ end;
+
+ -- Edit Parser_State to apply solutions.
+
+ -- We don't use 'for Parser_State of Parsers loop' here,
+ -- because we might need to terminate a parser.
+ Current_Parser := Parsers.First;
+ loop
+ exit when Current_Parser.Is_Done;
+
+ if Current_Parser.State_Ref.Recover.Success then
+ begin
+ -- Can't have active 'renames State_Ref' when terminate a
parser
+ declare
+ use Parser_Lists;
+
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+
+ Descriptor : WisiToken.Descriptor renames
Shared_Parser.Trace.Descriptor.all;
+ Tree : Syntax_Trees.Tree renames Parser_State.Tree;
+ Data : McKenzie_Data renames Parser_State.Recover;
+ Result : Configuration renames Data.Results.Peek;
+
+ Min_Op_Token_Index : WisiToken.Token_Index :=
WisiToken.Token_Index'Last;
+ Min_Push_Back_Token_Index : WisiToken.Token_Index :=
WisiToken.Token_Index'Last;
+
+ Stack_Matches_Ops : Boolean := True;
+ Shared_Token_Changed : Boolean := False;
+ Current_Token_Virtual : Boolean := False;
+
+ Sorted_Insert_Delete : Sorted_Insert_Delete_Arrays.Vector;
+
+ procedure Apply_Prev_Token
+ is begin
+ loop
+ exit when not Parser_State.Prev_Deleted.Contains
(Parser_State.Shared_Token);
+ Parser_State.Shared_Token := Parser_State.Shared_Token
+ 1;
+ end loop;
+ end Apply_Prev_Token;
+
+ begin
+ -- The verb will be reset by the main parser; just indicate
the
+ -- parser recovered from the error.
+ Parser_State.Set_Verb (Shift);
+
+ Parser_State.Errors (Parser_State.Errors.Last).Recover :=
Result;
+
+ Parser_State.Resume_Token_Goal := Result.Resume_Token_Goal;
+
+ if Trace_McKenzie > Extra then
+ Put_Line (Trace, Parser_State.Label, "before Ops
applied:", Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "stack " & Image
(Parser_State.Stack, Descriptor, Tree),
+ Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "Shared_Token " & Image
+ (Parser_State.Shared_Token, Shared_Parser.Terminals,
Descriptor),
+ Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "Current_Token " &
Parser_State.Tree.Image
+ (Parser_State.Current_Token, Descriptor),
+ Task_ID => False);
+ end if;
+
+ -- We don't apply all Ops to the parser stack here, because
that
+ -- requires updating the syntax tree as well, and we want
to let the
+ -- main parser do that, partly as a double check on the
algorithms
+ -- here.
+ --
+ -- However, the main parser can only apply Insert and
Delete ops; we
+ -- must apply Push_Back and Undo_Reduce here. Note that
Fast_Forward
+ -- ops are just for bookkeeping.
+ --
+ -- In order to apply Undo_Reduce, we also need to apply any
preceding
+ -- ops. See test_mckenzie_recover.adb Missing_Name_2 for an
example
+ -- of multiple Undo_Reduce. On the other hand, Push_Back
can be
+ -- applied without the preceding ops.
+ --
+ -- A Push_Back can go back past preceding ops, including
Undo_Reduce;
+ -- there's no point in applying ops that are later
superceded by such
+ -- a Push_Back. See test_mckenzie_recover.adb
Out_Of_Order_Ops for an
+ -- example.
+ --
+ -- Push_Back can also go back past a previous error
recovery; we must
+ -- apply Parser_State.Prev_Deleted here as well, when
computing
+ -- Shared_Token.
+ --
+ -- So first we go thru Ops to find the earliest Push_Back.
Then we
+ -- apply ops that are before that point, up to the first
Insert or
+ -- Fast_Forward. After that, we enqueue Insert and Delete
ops on
+ -- Parser_State.Recover_Insert_Delete, in token_index
order, and any
+ -- Undo_Reduce are rejected.
+ --
+ -- Then the main parser parses the edited input stream.
+ --
+ -- There's no need to modify Parser_State.Tree. Any tree
nodes
+ -- created by the failed parse that are pushed back are
useful for
+ -- error repair, and will just be ignored in future
parsing. This
+ -- also avoids enlarging a non-flushed branched tree, which
saves
+ -- time and space.
+
+ for Op of Result.Ops loop
+ case Op.Op is
+ when Fast_Forward =>
+ if Op.FF_Token_Index < Min_Op_Token_Index then
+ Min_Op_Token_Index := Op.FF_Token_Index;
+ end if;
+
+ when Undo_Reduce =>
+ null;
+
+ when Push_Back =>
+ if Op.PB_Token_Index /= Invalid_Token_Index then
+ if Op.PB_Token_Index < Min_Op_Token_Index then
+ Min_Op_Token_Index := Op.PB_Token_Index;
+ end if;
+ if Op.PB_Token_Index < Min_Push_Back_Token_Index
then
+ Min_Push_Back_Token_Index := Op.PB_Token_Index;
+ end if;
+ end if;
+
+ when Insert =>
+ if Op.Ins_Token_Index /= Invalid_Token_Index then
+ if Op.Ins_Token_Index < Min_Op_Token_Index then
+ Min_Op_Token_Index := Op.Ins_Token_Index;
+ end if;
+ if Op.Ins_Token_Index < Min_Push_Back_Token_Index
then
+ Min_Push_Back_Token_Index := Op.Ins_Token_Index;
+ end if;
+ end if;
+
+ when Delete =>
+ if Op.Del_Token_Index /= Invalid_Token_Index then
+ if Op.Del_Token_Index < Min_Op_Token_Index then
+ Min_Op_Token_Index := Op.Del_Token_Index;
+ end if;
+ if Op.Del_Token_Index < Min_Push_Back_Token_Index
then
+ Min_Push_Back_Token_Index := Op.Del_Token_Index;
+ end if;
+ end if;
+
+ end case;
+ end loop;
+
+ for Op of Result.Ops loop
+ case Op.Op is
+ when Fast_Forward =>
+ Stack_Matches_Ops := False;
+
+ when Undo_Reduce =>
+ if not Stack_Matches_Ops then
+ if Trace_McKenzie > Outline then
+ Put_Line
+ (Trace, Parser_State.Label, "Undo_Reduce after
insert or fast_forward",
+ Task_ID => False);
+ end if;
+ raise Bad_Config;
+ end if;
+
+ declare
+ Item : constant Parser_Lists.Parser_Stack_Item :=
Parser_State.Stack.Pop;
+ begin
+ case Tree.Label (Item.Token) is
+ when Syntax_Trees.Shared_Terminal |
+ Syntax_Trees.Virtual_Identifier |
+ Syntax_Trees.Virtual_Terminal =>
+ if Trace_McKenzie > Outline then
+ Put_Line
+ (Trace, Parser_State.Label, "expecting
nonterminal, found " &
+ Image (Tree.ID (Item.Token),
Trace.Descriptor.all),
+ Task_ID => False);
+ end if;
+ raise Bad_Config;
+
+ when Syntax_Trees.Nonterm =>
+ for C of Tree.Children (Item.Token) loop
+ Parser_State.Stack.Push ((Tree.State (C), C));
+ end loop;
+ end case;
+ end;
+
+ when Push_Back =>
+ if Stack_Matches_Ops then
+ Parser_State.Stack.Pop;
+ if Op.PB_Token_Index /= Invalid_Token_Index then
+ Parser_State.Shared_Token := Op.PB_Token_Index;
+ Shared_Token_Changed := True;
+ end if;
+
+ elsif Op.PB_Token_Index = Min_Op_Token_Index then
+ loop
+ -- Multiple push_backs can have the same
Op.PB_Token_Index, so we may
+ -- already be at the target.
+ exit when Parser_State.Shared_Token <=
Op.PB_Token_Index and
+ (Parser_State.Stack.Depth = 1 or else
+ Tree.Min_Terminal_Index (Parser_State.Stack
(1).Token) /= Invalid_Token_Index);
+ -- also push back empty tokens.
+
+ declare
+ Item : constant
Parser_Lists.Parser_Stack_Item := Parser_State.Stack.Pop;
+
+ Min_Index : constant Base_Token_Index :=
+ Parser_State.Tree.Min_Terminal_Index
(Item.Token);
+ begin
+ if Min_Index /= Invalid_Token_Index then
+ Shared_Token_Changed := True;
+ Parser_State.Shared_Token := Min_Index;
+ end if;
+ end;
+ end loop;
+ pragma Assert (Parser_State.Shared_Token =
Op.PB_Token_Index);
+ end if;
+
+ when Insert =>
+ if Stack_Matches_Ops and Op.Ins_Token_Index =
Parser_State.Shared_Token then
+ -- This is the first Insert. Even if a later
Push_Back supercedes it,
+ -- we record Stack_Matches_Ops false here.
+ Stack_Matches_Ops := False;
+
+ if Op.Ins_Token_Index <= Min_Push_Back_Token_Index
then
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (Op.Ins_ID);
+ Current_Token_Virtual := True;
+ else
+ Sorted_Insert_Delete.Insert (Op);
+ end if;
+ else
+ Sorted_Insert_Delete.Insert (Op);
+ end if;
+
+ when Delete =>
+ if Stack_Matches_Ops and Op.Del_Token_Index =
Parser_State.Shared_Token then
+ -- We can apply multiple deletes.
+ Parser_State.Shared_Token := Op.Del_Token_Index + 1;
+ Apply_Prev_Token;
+ Shared_Token_Changed := True;
+ else
+ Sorted_Insert_Delete.Insert (Op);
+ end if;
+ end case;
+ end loop;
+
+ -- We may not have processed the current Insert or Delete
above, if
+ -- they are after a fast_forward.
+ for Op of Sorted_Insert_Delete loop
+ if Token_Index (Op) = Parser_State.Shared_Token and not
Current_Token_Virtual then
+ case Insert_Delete_Op_Label'(Op.Op) is
+ when Insert =>
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (ID (Op));
+ Current_Token_Virtual := True;
+
+ when Delete =>
+ Parser_State.Shared_Token := Op.Del_Token_Index + 1;
+ Apply_Prev_Token;
+ Shared_Token_Changed := True;
+ end case;
+ else
+ Parser_State.Recover_Insert_Delete.Put (Op);
+ end if;
+ end loop;
+
+ -- If not Shared_Token_Changed, Shared_Token is the error
token,
+ -- which is the next token to read. If
Shared_Token_Changed, we have
+ -- set Shared_Token consistent with that; it is the next
token to
+ -- read. If Current_Token_Virtual, then after all the
virtual tokens
+ -- are inserted, the main parser would normally increment
+ -- Parser_State.Shared_Token to get the next token, but we
don't want
+ -- that now. We could set Shared_Token to 1 less, but this
way the
+ -- debug messages all show the expected Shared_Terminal.
+
+ Parser_State.Inc_Shared_Token := not Current_Token_Virtual;
+
+ -- The main parser always sets Current_Token to be the
syntax tree
+ -- node containing Shared_Token; ensure that is true here
(virtual
+ -- tokens where handled above).
+
+ if (not Current_Token_Virtual) and Shared_Token_Changed then
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
+ (Parser_State.Shared_Token, Shared_Parser.Terminals);
+ end if;
+
+ if Trace_McKenzie > Extra then
+ Put_Line (Trace, Parser_State.Label, "after Ops
applied:", Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "stack " &
Parser_Lists.Image
+ (Parser_State.Stack, Descriptor, Tree),
+ Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "Shared_Token " & Image
+ (Parser_State.Shared_Token, Shared_Parser.Terminals,
Descriptor), Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "Current_Token " &
Parser_State.Tree.Image
+ (Parser_State.Current_Token, Descriptor), Task_ID =>
False);
+ Put_Line
+ (Trace, Parser_State.Label, "recover_insert_delete " &
Image
+ (Parser_State.Recover_Insert_Delete, Descriptor),
Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "inc_shared_token " &
Boolean'Image (Parser_State.Inc_Shared_Token) &
+ " parser verb " & All_Parse_Action_Verbs'Image
(Parser_State.Verb),
+ Task_ID => False);
+ end if;
+ end;
+ exception
+ when Bad_Config =>
+ if Parsers.Count = 1 then
+ -- Oops. just give up
+ return Fail_Programmer_Error;
+ end if;
+ Parsers.Terminate_Parser (Current_Parser, "bad config in
recover", Trace, Shared_Parser.Terminals);
+ end;
+ end if;
+ Current_Parser.Next;
+ end loop;
+
+ if Shared_Parser.Post_Recover /= null then
+ Shared_Parser.Post_Recover.all;
+ end if;
+
+ return Super.Recover_Result;
+
+ exception
+ when others =>
+ return Fail_Programmer_Error;
+ end Recover;
+
+ ----------
+ -- Spec private subprograms; for language-specific
+ -- child packages.
+
+ procedure Check (ID : Token_ID; Expected_ID : in Token_ID)
+ is begin
+ pragma Assert (ID = Expected_ID, Token_ID'Image (ID) & " /=" &
Token_ID'Image (Expected_ID));
+ end Check;
+
+ function Current_Token
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out WisiToken.Base_Token_Index;
+ Restore_Terminals_Current : out WisiToken.Base_Token_Index;
+ Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type;
+ Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
+ return Base_Token
+ is
+ use all type SAL.Base_Peek_Type;
+
+ procedure Inc_I_D
+ is begin
+ Current_Insert_Delete := Current_Insert_Delete + 1;
+ if Current_Insert_Delete > Insert_Delete.Last_Index then
+ Current_Insert_Delete := No_Insert_Delete;
+ Insert_Delete.Clear;
+ end if;
+ end Inc_I_D;
+
+ begin
+ if Terminals_Current = Invalid_Token_Index then
+ -- Happens with really bad syntax; see test_mckenzie_recover.adb
Error_4.
+ raise Bad_Config;
+ end if;
+
+ loop
+ if Current_Insert_Delete = No_Insert_Delete then
+ Restore_Terminals_Current := Terminals_Current;
+ return Terminals (Terminals_Current);
+
+ elsif Token_Index (Insert_Delete (Current_Insert_Delete)) =
Terminals_Current then
+ declare
+ Op : Insert_Delete_Op renames Insert_Delete
(Current_Insert_Delete);
+ begin
+ case Insert_Delete_Op_Label (Op.Op) is
+ when Insert =>
+ -- Decrement Terminals_Current so Next_Token knows it
should always
+ -- increment it. Save the initial value, to restore in case
of error.
+ Restore_Terminals_Current := Terminals_Current;
+ Terminals_Current := Terminals_Current - 1;
+ return (ID => ID (Op), others => <>);
+
+ when Delete =>
+ Terminals_Current := Terminals_Current + 1;
+ loop
+ exit when not Prev_Deleted.Contains (Terminals_Current);
+ Terminals_Current := Terminals_Current + 1;
+ end loop;
+ Restore_Terminals_Current := Terminals_Current;
+ Inc_I_D;
+ end case;
+ end;
+ else
+ return Terminals (Terminals_Current);
+ end if;
+ end loop;
+ end Current_Token;
+
+ function Current_Token_ID_Peek
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in SAL.Base_Peek_Type)
+ return Token_ID
+ is
+ use all type SAL.Base_Peek_Type;
+ Result : Token_ID;
+ begin
+ if Terminals_Current = Base_Token_Index'First then
+ -- Happens with really bad syntax.
+ raise Bad_Config;
+ end if;
+
+ -- First set Result from Terminals; may be overridden by
+ -- Insert_Delete below.
+ Result := Terminals (Terminals_Current).ID;
+
+ if Current_Insert_Delete = No_Insert_Delete then
+ null;
+
+ elsif Token_Index (Insert_Delete (Current_Insert_Delete)) =
Terminals_Current then
+ declare
+ Op : Insert_Delete_Op renames Insert_Delete
(Current_Insert_Delete);
+ begin
+ case Insert_Delete_Op_Label (Op.Op) is
+ when Insert =>
+ Result := Op.Ins_ID;
+
+ when Delete =>
+ -- This should have been handled in Check
+ raise SAL.Programmer_Error;
+ end case;
+ end;
+ end if;
+ return Result;
+ end Current_Token_ID_Peek;
+
+ procedure Current_Token_ID_Peek_3
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in SAL.Base_Peek_Type;
+ Prev_Deleted : in Recover_Token_Index_Arrays.Vector;
+ Tokens : out Token_ID_Array_1_3)
+ is
+ use all type SAL.Base_Peek_Type;
+ Terminals_Next : WisiToken.Token_Index := Terminals_Current + 1;
+ begin
+ if Terminals_Current = Base_Token_Index'First then
+ -- Happens with really bad syntax; see test_mckenzie_recover.adb
Error_4.
+ raise Bad_Config;
+ end if;
+
+ -- First set Tokens from Terminals; may be overridden by
+ -- Insert_Delete below.
+ Tokens (1) := Terminals (Terminals_Current).ID;
+ loop
+ exit when not Prev_Deleted.Contains (Terminals_Next);
+ Terminals_Next := Terminals_Next + 1;
+ end loop;
+ if Terminals_Next <= Terminals.Last_Index then
+ Tokens (2) := Terminals (Terminals_Next).ID;
+ loop
+ Terminals_Next := Terminals_Next + 1;
+ exit when not Prev_Deleted.Contains (Terminals_Next);
+ end loop;
+ if Terminals_Next <= Terminals.Last_Index then
+ Tokens (3) := Terminals (Terminals_Next).ID;
+ else
+ Tokens (3) := Invalid_Token_ID;
+ end if;
+ else
+ Tokens (2) := Invalid_Token_ID;
+ Tokens (3) := Invalid_Token_ID;
+ end if;
+
+ if Current_Insert_Delete = No_Insert_Delete then
+ null;
+ else
+ for I in Tokens'Range loop
+ declare
+ J : constant SAL.Base_Peek_Type := Current_Insert_Delete +
SAL.Peek_Type (I) - 1;
+ begin
+ if (J >= Insert_Delete.First_Index and J <=
Insert_Delete.Last_Index) and then
+ Token_Index (Insert_Delete (J)) = Terminals_Current
+ then
+ declare
+ Op : Insert_Delete_Op renames Insert_Delete (J);
+ begin
+ case Insert_Delete_Op_Label (Op.Op) is
+ when Insert =>
+ Tokens (I) := Op.Ins_ID;
+
+ when Delete =>
+ -- This should have been handled in Check
+ raise SAL.Programmer_Error;
+ end case;
+ end;
+ end if;
+ end;
+ end loop;
+ end if;
+ end Current_Token_ID_Peek_3;
+
+ procedure Delete_Check
+ (Terminals : in Base_Token_Arrays.Vector;
+ Config : in out Configuration;
+ ID : in Token_ID)
+ is
+ Op : constant Config_Op := (Delete, ID, Config.Current_Shared_Token);
+ begin
+ Check (Terminals (Config.Current_Shared_Token).ID, ID);
+ Config.Ops.Append (Op);
+ Config.Insert_Delete.Insert (Op);
+ Config.Current_Insert_Delete := 1;
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end Delete_Check;
+
+ procedure Delete_Check
+ (Terminals : in Base_Token_Arrays.Vector;
+ Config : in out Configuration;
+ Index : in out WisiToken.Token_Index;
+ ID : in Token_ID)
+ is
+ Op : constant Config_Op := (Delete, ID, Index);
+ begin
+ Check (Terminals (Index).ID, ID);
+ Config.Ops.Append (Op);
+ Config.Insert_Delete.Insert (Op);
+ Config.Current_Insert_Delete := 1;
+ Index := Index + 1;
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end Delete_Check;
+
+ procedure Find_ID
+ (Config : in Configuration;
+ ID : in Token_ID;
+ Matching_Index : in out SAL.Peek_Type)
+ is
+ use all type SAL.Peek_Type;
+ begin
+ loop
+ exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ declare
+ Stack_ID : Token_ID renames Config.Stack (Matching_Index).Token.ID;
+ begin
+ exit when Stack_ID = ID;
+ end;
+ Matching_Index := Matching_Index + 1;
+ end loop;
+ end Find_ID;
+
+ procedure Find_ID
+ (Config : in Configuration;
+ IDs : in Token_ID_Set;
+ Matching_Index : in out SAL.Peek_Type)
+ is
+ use all type SAL.Peek_Type;
+ begin
+ loop
+ exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ declare
+ ID : Token_ID renames Config.Stack (Matching_Index).Token.ID;
+ begin
+ exit when ID in IDs'First .. IDs'Last and then IDs (ID);
+ end;
+ Matching_Index := Matching_Index + 1;
+ end loop;
+ end Find_ID;
+
+ procedure Find_Descendant_ID
+ (Tree : in Syntax_Trees.Tree;
+ Config : in Configuration;
+ ID : in Token_ID;
+ ID_Set : in Token_ID_Set;
+ Matching_Index : in out SAL.Peek_Type)
+ is
+ use Syntax_Trees;
+ use all type SAL.Peek_Type;
+ begin
+ loop
+ exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ exit when Config.Stack (Matching_Index).Token.ID in ID_Set'Range and
then
+ (ID_Set (Config.Stack (Matching_Index).Token.ID) and
+ (Config.Stack (Matching_Index).Tree_Index /= Invalid_Node_Index
and then
+ Tree.Find_Descendant (Config.Stack
(Matching_Index).Tree_Index, ID) /= Invalid_Node_Index));
+
+ Matching_Index := Matching_Index + 1;
+ end loop;
+ end Find_Descendant_ID;
+
+ procedure Find_Matching_Name
+ (Config : in Configuration;
+ Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Name : in String;
+ Matching_Name_Index : in out SAL.Peek_Type;
+ Case_Insensitive : in Boolean)
+ is
+ use Ada.Characters.Handling;
+ use all type SAL.Peek_Type;
+ Match_Name : constant String := (if Case_Insensitive then To_Lower
(Name) else Name);
+ begin
+ loop
+ exit when Matching_Name_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ declare
+ Token : Recover_Token renames Config.Stack
(Matching_Name_Index).Token;
+ Name_Region : constant Buffer_Region :=
+ (if Token.Name = Null_Buffer_Region
+ then Token.Byte_Region
+ else Token.Name);
+ begin
+ exit when Name_Region /= Null_Buffer_Region and then
+ Match_Name =
+ (if Case_Insensitive
+ then To_Lower (Lexer.Buffer_Text (Name_Region))
+ else Lexer.Buffer_Text (Name_Region));
+
+ Matching_Name_Index := Matching_Name_Index + 1;
+ end;
+ end loop;
+ end Find_Matching_Name;
+
+ procedure Find_Matching_Name
+ (Config : in Configuration;
+ Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Name : in String;
+ Matching_Name_Index : in out SAL.Peek_Type;
+ Other_ID : in Token_ID;
+ Other_Count : out Integer;
+ Case_Insensitive : in Boolean)
+ is
+ use Ada.Characters.Handling;
+ use all type SAL.Peek_Type;
+ Match_Name : constant String := (if Case_Insensitive then To_Lower
(Name) else Name);
+ begin
+ Other_Count := 0;
+
+ loop
+ exit when Matching_Name_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ declare
+ Token : Recover_Token renames Config.Stack
(Matching_Name_Index).Token;
+ Name_Region : constant Buffer_Region :=
+ (if Token.Name = Null_Buffer_Region
+ then Token.Byte_Region -- FIXME: why not only Token.name?
+ else Token.Name);
+ begin
+ exit when Name_Region /= Null_Buffer_Region and then
+ Match_Name =
+ (if Case_Insensitive
+ then To_Lower (Lexer.Buffer_Text (Name_Region))
+ else Lexer.Buffer_Text (Name_Region));
+
+ if Other_ID = Token.ID then
+ Other_Count := Other_Count + 1;
+ end if;
+
+ Matching_Name_Index := Matching_Name_Index + 1;
+ end;
+ end loop;
+ end Find_Matching_Name;
+
+ procedure Insert (Config : in out Configuration; ID : in Token_ID)
+ is
+ Op : constant Config_Op := (Insert, ID, Config.Current_Shared_Token,
Unknown_State, 0);
+ begin
+ Config.Ops.Append (Op);
+ Config.Insert_Delete.Insert (Op);
+ Config.Current_Insert_Delete := 1;
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end Insert;
+
+ procedure Insert (Config : in out Configuration; IDs : in Token_ID_Array)
+ is begin
+ for ID of IDs loop
+ Insert (Config, ID);
+ end loop;
+ end Insert;
+
+ function Next_Token
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out Base_Token_Index;
+ Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
+ Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type;
+ Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
+ return Base_Token
+ is
+ use all type SAL.Base_Peek_Type;
+
+ function Next_Terminal return Base_Token
+ is begin
+ Terminals_Current := Terminals_Current + 1;
+ loop
+ exit when not Prev_Deleted.Contains (Terminals_Current);
+ Terminals_Current := Terminals_Current + 1;
+ end loop;
+
+ Restore_Terminals_Current := Terminals_Current;
+ return Terminals (Terminals_Current);
+ end Next_Terminal;
+
+ begin
+ loop
+ if Insert_Delete.Last_Index > 0 and then Current_Insert_Delete =
Insert_Delete.Last_Index then
+ Current_Insert_Delete := No_Insert_Delete;
+ Insert_Delete.Clear;
+ return Next_Terminal;
+
+ elsif Current_Insert_Delete = No_Insert_Delete then
+ return Next_Terminal;
+
+ elsif Token_Index (Insert_Delete (Current_Insert_Delete + 1)) =
Terminals_Current + 1 then
+ Current_Insert_Delete := Current_Insert_Delete + 1;
+ declare
+ Op : constant Insert_Delete_Op := Insert_Delete
(Current_Insert_Delete);
+ begin
+ case Insert_Delete_Op_Label'(Op.Op) is
+ when Insert =>
+ return (ID => Op.Ins_ID, others => <>);
+
+ when Delete =>
+ Terminals_Current := Terminals_Current + 1;
+ Restore_Terminals_Current := Terminals_Current;
+ end case;
+ end;
+
+ else
+ return Next_Terminal;
+ end if;
+ end loop;
+ end Next_Token;
+
+ procedure Push_Back (Config : in out Configuration)
+ is
+ Item : constant Recover_Stack_Item := Config.Stack.Pop;
+ Token_Index : constant Base_Token_Index :=
Item.Token.Min_Terminal_Index;
+
+ function Compare (Left : in Base_Token_Index; Right : in Config_Op)
return Boolean
+ is (case Right.Op is
+ when Fast_Forward => False,
+ when Undo_Reduce => False,
+ when Push_Back => False,
+ when Insert => Left < Right.Ins_Token_Index,
+ when Delete => Left < Right.Del_Token_Index);
+ -- If Left = Right.Token_Index, we assume the Right ops go _after_
+ -- the Left, so the Left do not need to be repeated.
+ begin
+ if Token_Index /= Invalid_Token_Index then
+ Config.Current_Shared_Token := Token_Index;
+ for I in Config.Ops.First_Index .. Config.Ops.Last_Index loop
+ if Compare (Token_Index, Config.Ops (I)) then
+ Config.Insert_Delete.Insert (Config.Ops (I), Ignore_If_Equal =>
True);
+ end if;
+ end loop;
+ end if;
+
+ Config.Ops.Append ((Push_Back, Item.Token.ID,
Config.Current_Shared_Token));
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end Push_Back;
+
+ procedure Push_Back_Check (Config : in out Configuration; Expected_ID : in
Token_ID)
+ is begin
+ Check (Config.Stack (1).Token.ID, Expected_ID);
+ Push_Back (Config);
+ end Push_Back_Check;
+
+ procedure Push_Back_Check (Config : in out Configuration; Expected : in
Token_ID_Array)
+ is begin
+ for ID of Expected loop
+ Push_Back_Check (Config, ID);
+ end loop;
+ end Push_Back_Check;
+
+ procedure Put
+ (Message : in String;
+ Trace : in out WisiToken.Trace'Class;
+ Parser_Label : in Natural;
+ Terminals : in Base_Token_Arrays.Vector;
+ Config : in Configuration;
+ Task_ID : in Boolean := True;
+ Strategy : in Boolean := False)
+ is
+ -- For debugging output
+
+ -- Build a string, call trace.put_line once, so output from multiple
+ -- tasks is not interleaved (mostly).
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+ use all type SAL.Base_Peek_Type;
+ use all type WisiToken.Semantic_Checks.Check_Status_Label;
+
+ Descriptor : WisiToken.Descriptor renames Trace.Descriptor.all;
+
+ Result : Ada.Strings.Unbounded.Unbounded_String :=
+ (if Task_ID then +"task" & Task_Attributes.Value'Image else +"") &
+ Integer'Image (Parser_Label) & ": " &
+ (if Message'Length > 0 then Message & ":" else "");
+ begin
+ Result := Result & Natural'Image (Config.Cost);
+ if Strategy or Trace_McKenzie > Extra then
+ Result := Result & ", (";
+ for C of Config.Strategy_Counts loop
+ Result := Result & Integer'Image (C);
+ end loop;
+ Result := Result & "), ";
+ else
+ Result := Result & ", ";
+ end if;
+ if Config.Check_Status.Label /= Ok then
+ Result := Result & Semantic_Checks.Check_Status_Label'Image
(Config.Check_Status.Label) & " ";
+ elsif Config.Error_Token.ID /= Invalid_Token_ID then
+ Result := Result & "Error " & Image (Config.Error_Token, Descriptor)
& " ";
+ end if;
+ Result := Result & Image (Config.Stack, Descriptor, Depth => 1);
+
+ if Config.Current_Insert_Delete = No_Insert_Delete then
+ Result := Result & "|" & Image (Config.Current_Shared_Token,
Terminals, Descriptor) & "|";
+ else
+ Result := Result & "/" & Trimmed_Image (Config.Current_Insert_Delete)
& ":" &
+ Image (Config.Insert_Delete (Config.Current_Insert_Delete),
Descriptor) & "/";
+ end if;
+
+ Result := Result & Image (Config.Ops, Descriptor);
+ if Config.Minimal_Complete_State /= None then
+ Result := Result & " minimal_complete " &
Config.Minimal_Complete_State'Image;
+ end if;
+ Trace.Put_Line (-Result);
+ end Put;
+
+ procedure Put_Line
+ (Trace : in out WisiToken.Trace'Class;
+ Parser_Label : in Natural;
+ Message : in String;
+ Task_ID : in Boolean := True)
+ is begin
+ Trace.Put_Line
+ ((if Task_ID then "task" & Task_Attributes.Value'Image else "") &
+ Integer'Image (Parser_Label) & ": " & Message);
+ end Put_Line;
+
+ function Undo_Reduce
+ (Stack : in out Recover_Stacks.Stack;
+ Tree : in Syntax_Trees.Tree)
+ return Ada.Containers.Count_Type
+ is
+ Nonterm_Item : constant Recover_Stack_Item := Stack.Pop;
+ begin
+ if Nonterm_Item.Token.Byte_Region = Null_Buffer_Region then
+ return 0;
+ end if;
+ declare
+ Children : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Children (Nonterm_Item.Tree_Index);
+ begin
+ for C of Children loop
+ Stack.Push ((Tree.State (C), C, Tree.Recover_Token (C)));
+ end loop;
+ return Children'Length;
+ end;
+ end Undo_Reduce;
+
+ procedure Undo_Reduce_Check
+ (Config : in out Configuration;
+ Tree : in Syntax_Trees.Tree;
+ Expected : in Token_ID)
+ is begin
+ Check (Config.Stack (1).Token.ID, Expected);
+ Config.Ops.Append ((Undo_Reduce, Expected, Undo_Reduce (Config.Stack,
Tree)));
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end Undo_Reduce_Check;
+
+ procedure Undo_Reduce_Check
+ (Config : in out Configuration;
+ Tree : in Syntax_Trees.Tree;
+ Expected : in Token_ID_Array)
+ is begin
+ for ID of Expected loop
+ Undo_Reduce_Check (Config, Tree, ID);
+ end loop;
+ end Undo_Reduce_Check;
+
+end WisiToken.Parse.LR.McKenzie_Recover;
diff --git a/wisitoken-parse-lr-mckenzie_recover.ads
b/wisitoken-parse-lr-mckenzie_recover.ads
index eba872a..b143866 100644
--- a/wisitoken-parse-lr-mckenzie_recover.ads
+++ b/wisitoken-parse-lr-mckenzie_recover.ads
@@ -1,227 +1,273 @@
--- Abstract :
---
--- Implement [McKenzie] error recovery, extended to parallel parsers.
---
--- References:
---
--- [McKenzie] McKenzie, Bruce J., Yeatman, Corey, and De Vere,
--- Lorraine. Error repair in shift reduce parsers. ACM Trans. Prog.
--- Lang. Syst., 17(4):672-689, July 1995. Described in [Grune 2008] ref 321.
---
--- [Grune 2008] Parsing Techniques, A Practical Guide, Second
--- Edition. Dick Grune, Ceriel J.H. Jacobs.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Parse.LR.Parser;
-with WisiToken.Lexer;
-package WisiToken.Parse.LR.McKenzie_Recover is
-
- Bad_Config : exception;
- -- Raised when a config is determined to violate some programming
- -- convention; abandon it.
-
- type Recover_Status is
- (Fail_Check_Delta, Fail_Enqueue_Limit, Fail_Cost, Fail_No_Configs_Left,
Fail_Programmer_Error,
- Success);
-
- function Recover (Shared_Parser : in out WisiToken.Parse.LR.Parser.Parser)
return Recover_Status;
- -- Attempt to modify Parser.Parsers state and Parser.Lookahead to
- -- allow recovering from an error state.
-
- Force_Full_Explore : Boolean := False;
- -- Sometimes recover throws an exception in a race condition case
- -- that is hard to reproduce. Setting this True ignores all Success,
- -- so all configs are checked.
-
- Force_High_Cost_Solutions : Boolean := False;
- -- Similarly, setting this true keeps all solutions that are found,
- -- and forces at least three.
-
-private
-
- ----------
- -- Visible for language-specific child packages. Alphabetical.
-
- procedure Check (ID : Token_ID; Expected_ID : in Token_ID)
- with Inline => True;
- -- Check that ID = Expected_ID; raise Assertion_Error if not.
- -- Implemented using 'pragma Assert'.
-
- function Current_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out Base_Token_Index;
- Restore_Terminals_Current : out WisiToken.Base_Token_Index;
- Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
- return Base_Token;
- -- Return the current token, from either Terminals or Insert_Delete;
- -- set up for Next_Token.
- --
- -- See Next_Token for more info.
-
- procedure Current_Token_ID_Peek_2
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in Base_Token_Index;
- Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector;
- Current_Token : out Token_ID;
- Next_Token : out Token_ID);
- -- Return the current token, from either Terminals or Insert_Delete,
- -- without setting up for Next_Token.
-
- procedure Delete (Config : in out Configuration; ID : in Token_ID);
- -- Append a Delete op to Config.Ops, and insert it in
- -- Config.Insert_Deleted in token_index order.
-
- procedure Find_ID
- (Config : in Configuration;
- ID : in Token_ID;
- Matching_Index : in out SAL.Peek_Type);
- -- Search Config.Stack for a token with ID, starting at
- -- Matching_Index. If found, Matching_Index points to it.
- -- If not found, Matching_Index = Config.Stack.Depth.
-
- procedure Find_ID
- (Config : in Configuration;
- IDs : in Token_ID_Set;
- Matching_Index : in out SAL.Peek_Type);
- -- Search Config.Stack for a token with ID in IDs, starting at
- -- Matching_Index. If found, Matching_Index points to it.
- -- If not found, Matching_Index = Config.Stack.Depth.
-
- procedure Find_Descendant_ID
- (Tree : in Syntax_Trees.Tree;
- Config : in Configuration;
- ID : in Token_ID;
- ID_Set : in Token_ID_Set;
- Matching_Index : in out SAL.Peek_Type);
- -- Search Config.Stack for a token with id in ID_Set, with a
- -- descendant with id = ID, starting at Matching_Index. If found,
- -- Matching_Index points to it. If not found, Matching_Index =
- -- Config.Stack.Depth.
-
- procedure Find_Matching_Name
- (Config : in Configuration;
- Lexer : access constant WisiToken.Lexer.Instance'Class;
- Name : in String;
- Matching_Name_Index : in out SAL.Peek_Type;
- Case_Insensitive : in Boolean);
- -- Search Config.Stack for a token matching Name, starting at
- -- Matching_Name_Index. If found, Matching_Name_Index points to it.
- -- If not found, Matching_Name_Index = Config.Stack.Depth.
-
- procedure Find_Matching_Name
- (Config : in Configuration;
- Lexer : access constant WisiToken.Lexer.Instance'Class;
- Name : in String;
- Matching_Name_Index : in out SAL.Peek_Type;
- Other_ID : in Token_ID;
- Other_Count : out Integer;
- Case_Insensitive : in Boolean);
- -- Search Config.Stack for a token matching Name, starting at
- -- Matching_Name_Index. If found, Matching_Name_Index points to it.
- -- If not found, Matching_Name_Index = Config.Stack.Depth.
- --
- -- Also count tokens with ID = Other_ID.
-
- procedure Insert (Config : in out Configuration; ID : in Token_ID);
- -- Append an Insert op to Config.Ops, and insert it in
- -- Config.Insert_Deleted in token_index order.
-
- procedure Insert (Config : in out Configuration; IDs : in Token_ID_Array);
- -- Call Insert for each item in IDs.
-
- function Next_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out Base_Token_Index;
- Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
- Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
- return Base_Token;
- -- Return the next token, from either Terminals or Insert_Delete;
- -- update Terminals_Current or Current_Insert_Delete.
- --
- -- If result is Insert_Delete.Last_Index, Current_Insert_Delete =
- -- Last_Index; Insert_Delete is cleared and Current_Insert_Delete
- -- reset on next call.
- --
- -- When done parsing, reset actual Terminals_Current to
- -- Restore_Terminals_Current.
- --
- -- Insert_Delete contains only Insert and Delete ops, in token_index
- -- order. Those ops are applied when Terminals_Current =
- -- op.token_index.
- --
- -- Prev_Deleted contains tokens deleted in previous recover
- -- operations; those are skipped.
-
- procedure Push_Back (Config : in out Configuration);
- -- Pop the top Config.Stack item, set Config.Current_Shared_Token to
- -- the first terminal in that item. If the item is empty,
- -- Config.Current_Shared_Token is unchanged.
- --
- -- If any earlier Insert or Delete items in Config.Ops are for a
- -- token_index after that first terminal, they are added to
- -- Config.Insert_Delete in token_index order.
-
- procedure Push_Back_Check (Config : in out Configuration; Expected_ID : in
Token_ID);
- -- In effect, call Check and Push_Back.
-
- procedure Push_Back_Check (Config : in out Configuration; Expected : in
Token_ID_Array);
- -- Call Push_Back_Check for each item in Expected.
-
- procedure Put
- (Message : in String;
- Trace : in out WisiToken.Trace'Class;
- Parser_Label : in Natural;
- Terminals : in Base_Token_Arrays.Vector;
- Config : in Configuration;
- Task_ID : in Boolean := True);
- -- Put Message and an image of Config to Trace.
-
- procedure Put_Line
- (Trace : in out WisiToken.Trace'Class;
- Parser_Label : in Natural;
- Message : in String;
- Task_ID : in Boolean := True);
- -- Put message to Trace, with parser and task info.
-
- function Undo_Reduce
- (Stack : in out Recover_Stacks.Stack;
- Tree : in Syntax_Trees.Tree)
- return Ada.Containers.Count_Type
- with Pre => Tree.Is_Nonterm (Stack (1).Tree_Index);
- -- Undo the reduction that produced the top stack item, return the
- -- token count for that reduction.
-
- procedure Undo_Reduce_Check
- (Config : in out Configuration;
- Tree : in Syntax_Trees.Tree;
- Expected : in Token_ID)
- with Inline => True;
- -- Call Check, Undo_Reduce.
-
- procedure Undo_Reduce_Check
- (Config : in out Configuration;
- Tree : in Syntax_Trees.Tree;
- Expected : in Token_ID_Array);
- -- Call Undo_Reduce_Check for each item in Expected.
-
-end WisiToken.Parse.LR.McKenzie_Recover;
+-- Abstract :
+--
+-- Implement [McKenzie] error recovery, extended to parallel parsers.
+--
+-- References:
+--
+-- [McKenzie] McKenzie, Bruce J., Yeatman, Corey, and De Vere,
+-- Lorraine. Error repair in shift reduce parsers. ACM Trans. Prog.
+-- Lang. Syst., 17(4):672-689, July 1995. Described in [Grune 2008] ref 321.
+--
+-- [Grune 2008] Parsing Techniques, A Practical Guide, Second
+-- Edition. Dick Grune, Ceriel J.H. Jacobs.
+--
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Task_Attributes;
+with WisiToken.Parse.LR.Parser;
+with WisiToken.Lexer;
+package WisiToken.Parse.LR.McKenzie_Recover is
+
+ Bad_Config : exception;
+ -- Raised when a config is determined to violate some programming
+ -- convention; abandon it.
+
+ type Recover_Status is (Fail_Check_Delta, Fail_Enqueue_Limit,
Fail_No_Configs_Left, Fail_Programmer_Error, Success);
+
+ function Recover (Shared_Parser : in out WisiToken.Parse.LR.Parser.Parser)
return Recover_Status;
+ -- Attempt to modify Parser.Parsers state and Parser.Lookahead to
+ -- allow recovering from an error state.
+
+ Force_Full_Explore : Boolean := False;
+ -- Sometimes recover throws an exception in a race condition case
+ -- that is hard to reproduce. Setting this True ignores all Success,
+ -- so all configs are checked.
+
+ Force_High_Cost_Solutions : Boolean := False;
+ -- Similarly, setting this true keeps all solutions that are found,
+ -- and forces at least three.
+
+private
+ use all type WisiToken.Syntax_Trees.Node_Index;
+
+ ----------
+ -- Visible for language-specific child packages. Alphabetical.
+
+ procedure Check (ID : Token_ID; Expected_ID : in Token_ID)
+ with Inline => True;
+ -- Check that ID = Expected_ID; raise Assertion_Error if not.
+ -- Implemented using 'pragma Assert'.
+
+ function Current_Token
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out Base_Token_Index;
+ Restore_Terminals_Current : out WisiToken.Base_Token_Index;
+ Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type;
+ Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
+ return Base_Token;
+ -- Return the current token, from either Terminals or Insert_Delete;
+ -- set up for Next_Token.
+ --
+ -- See Next_Token for more info.
+
+ function Current_Token_ID_Peek
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in SAL.Base_Peek_Type)
+ return Token_ID;
+ -- Return the current token from either Terminals or
+ -- Insert_Delete, without setting up for Next_Token.
+
+ procedure Current_Token_ID_Peek_3
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in SAL.Base_Peek_Type;
+ Prev_Deleted : in Recover_Token_Index_Arrays.Vector;
+ Tokens : out Token_ID_Array_1_3);
+ -- Return the current token (in Tokens (1)) from either Terminals or
+ -- Insert_Delete, without setting up for Next_Token. Return the two
+ -- following tokens in Tokens (2 .. 3).
+
+ procedure Delete_Check
+ (Terminals : in Base_Token_Arrays.Vector;
+ Config : in out Configuration;
+ ID : in Token_ID);
+ -- Check that Terminals (Config.Current_Shared_Token) = ID. Append a
+ -- Delete op to Config.Ops, and insert it in Config.Insert_Delete in
+ -- token_index order.
+ --
+ -- This or the next routine must be used instead of Config.Ops.Append
+ -- (Delete...) unless the code also takes care of changing
+ -- Config.Current_Shared_Token. Note that this routine does _not_
+ -- increment Config.Current_Shared_Token, so it can only be used to
+ -- delete one token.
+
+ procedure Delete_Check
+ (Terminals : in Base_Token_Arrays.Vector;
+ Config : in out Configuration;
+ Index : in out WisiToken.Token_Index;
+ ID : in Token_ID);
+ -- Check that Terminals (Index) = ID. Append a Delete op to
+ -- Config.Ops, and insert it in Config.Insert_Delete in token_index
+ -- order. Increments Index, for convenience when deleting several
+ -- tokens.
+
+ procedure Find_ID
+ (Config : in Configuration;
+ ID : in Token_ID;
+ Matching_Index : in out SAL.Peek_Type);
+ -- Search Config.Stack for a token with ID, starting at
+ -- Matching_Index. If found, Matching_Index points to it.
+ -- If not found, Matching_Index = Config.Stack.Depth.
+
+ procedure Find_ID
+ (Config : in Configuration;
+ IDs : in Token_ID_Set;
+ Matching_Index : in out SAL.Peek_Type);
+ -- Search Config.Stack for a token with ID in IDs, starting at
+ -- Matching_Index. If found, Matching_Index points to it.
+ -- If not found, Matching_Index = Config.Stack.Depth.
+
+ procedure Find_Descendant_ID
+ (Tree : in Syntax_Trees.Tree;
+ Config : in Configuration;
+ ID : in Token_ID;
+ ID_Set : in Token_ID_Set;
+ Matching_Index : in out SAL.Peek_Type);
+ -- Search Config.Stack for a token with id in ID_Set, with a
+ -- descendant with id = ID, starting at Matching_Index. If found,
+ -- Matching_Index points to it. If not found, Matching_Index =
+ -- Config.Stack.Depth.
+
+ procedure Find_Matching_Name
+ (Config : in Configuration;
+ Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Name : in String;
+ Matching_Name_Index : in out SAL.Peek_Type;
+ Case_Insensitive : in Boolean);
+ -- Search Config.Stack for a token matching Name, starting at
+ -- Matching_Name_Index. If found, Matching_Name_Index points to it.
+ -- If not found, Matching_Name_Index = Config.Stack.Depth.
+
+ procedure Find_Matching_Name
+ (Config : in Configuration;
+ Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Name : in String;
+ Matching_Name_Index : in out SAL.Peek_Type;
+ Other_ID : in Token_ID;
+ Other_Count : out Integer;
+ Case_Insensitive : in Boolean);
+ -- Search Config.Stack for a token matching Name, starting at
+ -- Matching_Name_Index. If found, Matching_Name_Index points to it.
+ -- If not found, Matching_Name_Index = Config.Stack.Depth.
+ --
+ -- Also count tokens with ID = Other_ID.
+
+ procedure Insert (Config : in out Configuration; ID : in Token_ID);
+ -- Append an Insert op to Config.Ops, and insert it in
+ -- Config.Insert_Deleted in token_index order.
+
+ procedure Insert (Config : in out Configuration; IDs : in Token_ID_Array);
+ -- Call Insert for each item in IDs.
+
+ function Next_Token
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out Base_Token_Index;
+ Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
+ Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type;
+ Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
+ return Base_Token;
+ -- Return the next token, from either Terminals or Insert_Delete;
+ -- update Terminals_Current or Current_Insert_Delete.
+ --
+ -- If result is Insert_Delete.Last_Index, Current_Insert_Delete =
+ -- Last_Index; Insert_Delete is cleared and Current_Insert_Delete
+ -- reset on next call.
+ --
+ -- When done parsing, caller must reset actual Terminals_Current to
+ -- Restore_Terminals_Current.
+ --
+ -- Insert_Delete contains only Insert and Delete ops, in token_index
+ -- order. Those ops are applied when Terminals_Current =
+ -- op.token_index.
+ --
+ -- Prev_Deleted contains tokens deleted in previous recover
+ -- operations; those are skipped.
+
+ procedure Push_Back (Config : in out Configuration);
+ -- Pop the top Config.Stack item, set Config.Current_Shared_Token to
+ -- the first terminal in that item. If the item is empty,
+ -- Config.Current_Shared_Token is unchanged.
+ --
+ -- If any earlier Insert or Delete items in Config.Ops are for a
+ -- token_index after that first terminal, they are added to
+ -- Config.Insert_Delete in token_index order.
+
+ procedure Push_Back_Check (Config : in out Configuration; Expected_ID : in
Token_ID);
+ -- In effect, call Check and Push_Back.
+
+ procedure Push_Back_Check (Config : in out Configuration; Expected : in
Token_ID_Array);
+ -- Call Push_Back_Check for each item in Expected.
+
+ procedure Put
+ (Message : in String;
+ Trace : in out WisiToken.Trace'Class;
+ Parser_Label : in Natural;
+ Terminals : in Base_Token_Arrays.Vector;
+ Config : in Configuration;
+ Task_ID : in Boolean := True;
+ Strategy : in Boolean := False);
+ -- Put Message and an image of Config to Trace.
+
+ procedure Put_Line
+ (Trace : in out WisiToken.Trace'Class;
+ Parser_Label : in Natural;
+ Message : in String;
+ Task_ID : in Boolean := True);
+ -- Put message to Trace, with parser and task info.
+
+ function Undo_Reduce_Valid
+ (Stack : in out Recover_Stacks.Stack;
+ Tree : in Syntax_Trees.Tree)
+ return Boolean
+ is ((Stack.Peek.Tree_Index /= WisiToken.Syntax_Trees.Invalid_Node_Index
and then
+ Tree.Is_Nonterm (Stack.Peek.Tree_Index)) or
+ (Stack.Peek.Tree_Index = WisiToken.Syntax_Trees.Invalid_Node_Index
and
+ (not Stack.Peek.Token.Virtual and
+ Stack.Peek.Token.Byte_Region = Null_Buffer_Region)));
+ -- Undo_Reduce needs to know what tokens the nonterm contains, to
+ -- push them on the stack. Thus we need either a valid Tree index, or
+ -- an empty nonterm. If Token.Virtual, we can't trust
+ -- Token.Byte_Region to determine empty.
+
+ function Undo_Reduce
+ (Stack : in out Recover_Stacks.Stack;
+ Tree : in Syntax_Trees.Tree)
+ return Ada.Containers.Count_Type
+ with Pre => Undo_Reduce_Valid (Stack, Tree);
+ -- Undo the reduction that produced the top stack item, return the
+ -- token count for that reduction.
+
+ procedure Undo_Reduce_Check
+ (Config : in out Configuration;
+ Tree : in Syntax_Trees.Tree;
+ Expected : in Token_ID)
+ with Inline => True;
+ -- Call Check, Undo_Reduce.
+
+ procedure Undo_Reduce_Check
+ (Config : in out Configuration;
+ Tree : in Syntax_Trees.Tree;
+ Expected : in Token_ID_Array);
+ -- Call Undo_Reduce_Check for each item in Expected.
+
+ package Task_Attributes is new Ada.Task_Attributes (Integer, 0);
+
+end WisiToken.Parse.LR.McKenzie_Recover;
diff --git a/wisitoken-parse-lr-parser.adb b/wisitoken-parse-lr-parser.adb
index 09df9ed..986675d 100644
--- a/wisitoken-parse-lr-parser.adb
+++ b/wisitoken-parse-lr-parser.adb
@@ -1,1121 +1,1161 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Calendar.Formatting;
-with Ada.Exceptions;
-with GNAT.Traceback.Symbolic;
-with WisiToken.Parse.LR.McKenzie_Recover;
-package body WisiToken.Parse.LR.Parser is
-
- function Reduce_Stack_1
- (Current_Parser : in Parser_Lists.Cursor;
- Action : in Reduce_Action_Rec;
- Nonterm : out WisiToken.Syntax_Trees.Valid_Node_Index;
- Lexer : in WisiToken.Lexer.Handle;
- Trace : in out WisiToken.Trace'Class)
- return WisiToken.Semantic_Checks.Check_Status_Label
- is
- -- We treat semantic check errors as parse errors here, to allow
- -- error recovery to take better advantage of them. One recovery
- -- strategy is to fix things so the semantic check passes.
-
- use all type SAL.Base_Peek_Type;
- use all type Semantic_Checks.Check_Status_Label;
- use all type Semantic_Checks.Semantic_Check;
-
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
- Children_Tree : Syntax_Trees.Valid_Node_Index_Array (1 ..
SAL.Base_Peek_Type (Action.Token_Count));
- begin
- for I in reverse Children_Tree'Range loop
- Children_Tree (I) := Parser_State.Stack.Pop.Token;
- end loop;
-
- Nonterm := Parser_State.Tree.Add_Nonterm
- (Action.Production, Children_Tree, Action.Action,
- Default_Virtual => Parser_State.Tree.Is_Virtual
(Parser_State.Current_Token));
- -- Computes Nonterm.Byte_Region, Virtual
-
- if Trace_Parse > Detail then
- Trace.Put_Line (Parser_State.Tree.Image (Nonterm,
Trace.Descriptor.all, Include_Children => True));
- end if;
-
- if Action.Check = null then
- return Ok;
-
- else
- declare
- Nonterm_Token : Recover_Token :=
Parser_State.Tree.Recover_Token (Nonterm);
- Children_Token : constant Recover_Token_Array :=
Parser_State.Tree.Recover_Token_Array (Children_Tree);
- Status : Semantic_Checks.Check_Status;
- begin
- Status := Action.Check (Lexer, Nonterm_Token, Children_Token,
Recover_Active => False);
-
- Parser_State.Tree.Set_Name_Region (Nonterm, Nonterm_Token.Name);
-
- if Trace_Parse > Detail then
- Trace.Put_Line ("semantic check " & Semantic_Checks.Image
(Status, Trace.Descriptor.all));
- end if;
-
- case Status.Label is
- when Ok =>
- return Ok;
-
- when Semantic_Checks.Error =>
- if Parser_State.Resume_Active then
- -- Ignore this error; that's how McKenzie_Recover decided
to fix it
- return Ok;
-
- else
- Parser_State.Errors.Append
- ((Label => Check,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Check_Status => Status,
- Recover => (others => <>)));
- return Status.Label;
- end if;
- end case;
- exception
- when Partial_Parse =>
- -- From Action.Check
- Parser_State.Tree.Set_Root (Nonterm);
- raise;
- end;
- end if;
- end Reduce_Stack_1;
-
- procedure Do_Action
- (Action : in Parse_Action_Rec;
- Current_Parser : in Parser_Lists.Cursor;
- Shared_Parser : in LR.Parser.Parser)
- is
- use all type Semantic_Checks.Check_Status_Label;
-
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
- Nonterm : WisiToken.Syntax_Trees.Valid_Node_Index;
- Status : Semantic_Checks.Check_Status_Label;
- begin
- if Trace_Parse > Detail then
- Trace.Put
- (Integer'Image (Current_Parser.Label) & ": " &
- Trimmed_Image (Parser_State.Stack.Peek.State) & ": " &
- Parser_State.Tree.Image (Parser_State.Current_Token,
Trace.Descriptor.all) & " : ");
- Put (Trace, Action);
- Trace.New_Line;
- end if;
-
- case Action.Verb is
- when Shift =>
- Current_Parser.Set_Verb (Shift);
- Parser_State.Stack.Push ((Action.State, Parser_State.Current_Token));
- Parser_State.Tree.Set_State (Parser_State.Current_Token,
Action.State);
-
- when Reduce =>
- Status := Reduce_Stack_1 (Current_Parser, Action, Nonterm,
Shared_Parser.Lexer, Trace);
-
- -- Even when Reduce_Stack_1 returns Error, it did reduce the stack,
so
- -- push Nonterm.
- Parser_State.Stack.Push
- ((State => Goto_For
- (Table => Shared_Parser.Table.all,
- State => Parser_State.Stack (1).State,
- ID => Action.Production.LHS),
- Token => Nonterm));
-
- Parser_State.Tree.Set_State (Nonterm, Parser_State.Stack (1).State);
-
- case Status is
- when Ok =>
- Current_Parser.Set_Verb (Reduce);
-
- if Trace_Parse > Detail then
- Trace.Put_Line (" ... goto state " & Trimmed_Image
(Parser_State.Stack.Peek.State));
- end if;
-
- when Semantic_Checks.Error =>
- Current_Parser.Set_Verb (Error);
- Parser_State.Zombie_Token_Count := 1;
- end case;
-
- when Accept_It =>
- case Reduce_Stack_1
- (Current_Parser,
- (Reduce, Action.Production, Action.Action, Action.Check,
Action.Token_Count),
- Nonterm, Shared_Parser.Lexer, Trace)
- is
- when Ok =>
- Current_Parser.Set_Verb (Action.Verb);
-
- Parser_State.Tree.Set_Root (Nonterm);
-
- when Semantic_Checks.Error =>
- Current_Parser.Set_Verb (Error);
- Parser_State.Zombie_Token_Count := 1;
- end case;
-
- when Error =>
- Current_Parser.Set_Verb (Action.Verb);
-
- Parser_State.Zombie_Token_Count := 1;
-
- declare
- Expecting : constant Token_ID_Set := LR.Expecting
- (Shared_Parser.Table.all, Parser_State.Stack.Peek.State);
- begin
- Parser_State.Errors.Append
- ((Label => LR.Action,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Error_Token => Parser_State.Current_Token,
- Expecting => Expecting,
- Recover => (others => <>)));
-
- if Trace_Parse > Outline then
- Put
- (Trace,
- Integer'Image (Current_Parser.Label) & ":" &
- Unknown_State_Index'Image (Parser_State.Stack.Peek.State)
& ": expecting: " &
- Image (Expecting, Trace.Descriptor.all));
- Trace.New_Line;
- end if;
- end;
- end case;
- end Do_Action;
-
- procedure Do_Deletes
- (Shared_Parser : in out LR.Parser.Parser;
- Parser_State : in out Parser_Lists.Parser_State)
- is
- use all type SAL.Base_Peek_Type;
- begin
- if Trace_Parse > Extra then
- Shared_Parser.Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ": shared_token:" &
Token_Index'Image (Parser_State.Shared_Token) &
- " inc_shared_token: " & Boolean'Image
(Parser_State.Inc_Shared_Token) &
- " recover_insert_delete: " &
- Image (Parser_State.Recover_Insert_Delete,
Shared_Parser.Trace.Descriptor.all));
- end if;
-
- loop
- if Parser_State.Recover_Insert_Delete.Length > 0 and then
- Parser_State.Recover_Insert_Delete.Peek.Op = Delete and then
- Parser_State.Recover_Insert_Delete.Peek.Token_Index =
- (if Parser_State.Inc_Shared_Token
- then Parser_State.Shared_Token + 1
- else Parser_State.Shared_Token)
- then
- Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
- -- We don't reset Inc_Shared_Token here; only after the next
token is
- -- actually used.
- Parser_State.Prev_Deleted.Append
(Parser_State.Recover_Insert_Delete.Peek.Token_Index);
- Parser_State.Recover_Insert_Delete.Drop;
-
- elsif Parser_State.Prev_Deleted.Contains
- ((if Parser_State.Inc_Shared_Token
- then Parser_State.Shared_Token + 1
- else Parser_State.Shared_Token))
- then
- Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
-
- else
- exit;
- end if;
- end loop;
- end Do_Deletes;
-
- -- Verb: the type of parser cycle to execute;
- --
- -- Accept : all Parsers.Verb return Accept - done parsing.
- --
- -- Shift : some Parsers.Verb return Shift, all with the same current
- -- token in Shared_Parser.Terminals.
- --
- -- Pause : Resume is active, and this parser has reached Resume_Goal,
- -- so it is waiting for the others to catch up.
- --
- -- Reduce : some Parsers.Verb return Reduce.
- --
- -- Error : all Parsers.Verb return Error.
- --
- -- Zombie_Count: count of parsers in Error state
- procedure Parse_Verb
- (Shared_Parser : in out LR.Parser.Parser;
- Verb : out All_Parse_Action_Verbs;
- Zombie_Count : out SAL.Base_Peek_Type)
- is
- use all type SAL.Base_Peek_Type;
-
- Shift_Count : SAL.Base_Peek_Type := 0;
- Accept_Count : SAL.Base_Peek_Type := 0;
- Error_Count : SAL.Base_Peek_Type := 0;
- Resume_Active : Boolean := False;
- begin
- Zombie_Count := 0;
-
- for Parser_State of Shared_Parser.Parsers loop
- case Parser_State.Verb is
- when Pause | Shift =>
- Do_Deletes (Shared_Parser, Parser_State);
-
- Shift_Count := Shift_Count + 1;
- Parser_State.Set_Verb (Shift);
-
- if Parser_State.Resume_Active then
- if Parser_State.Resume_Token_Goal <= Parser_State.Shared_Token
then
- Parser_State.Resume_Active := False;
- if Trace_Parse > Detail then
- Shared_Parser.Trace.Put_Line (Integer'Image
(Parser_State.Label) & ": resume_active: False");
- end if;
- else
- Resume_Active := True;
- end if;
- end if;
-
- when Reduce =>
- Verb := Reduce;
- return;
-
- when Accept_It =>
- Accept_Count := Accept_Count + 1;
-
- when Error =>
- if Shared_Parser.Enable_McKenzie_Recover then
- -- This parser is waiting for others to error; they can
continue
- -- parsing.
- Zombie_Count := Zombie_Count + 1;
- else
- Error_Count := Error_Count + 1;
- end if;
- end case;
- end loop;
-
- if Accept_Count > 0 and Shared_Parser.Parsers.Count = Accept_Count +
Zombie_Count then
- Verb := Accept_It;
-
- elsif Shared_Parser.Parsers.Count = Error_Count + Zombie_Count then
- Verb := Error;
-
- elsif Shift_Count > 0 then
- Verb := Shift;
-
- else
- raise SAL.Programmer_Error;
- end if;
-
- if Resume_Active then
- for Parser_State of Shared_Parser.Parsers loop
- if Parser_State.Verb = Shift and not Parser_State.Resume_Active
then
- Parser_State.Set_Verb (Pause);
- end if;
- end loop;
- end if;
- end Parse_Verb;
-
- ----------
- -- Public subprograms, declaration order
-
- overriding procedure Finalize (Object : in out LR.Parser.Parser)
- is begin
- Free_Table (Object.Table);
- end Finalize;
-
- procedure New_Parser
- (Parser : out LR.Parser.Parser;
- Trace : not null access
WisiToken.Trace'Class;
- Lexer : in
WisiToken.Lexer.Handle;
- Table : in Parse_Table_Ptr;
- Language_Fixes : in
Language_Fixes_Access;
- Language_Use_Minimal_Complete_Actions : in
Language_Use_Minimal_Complete_Actions_Access;
- Language_String_ID_Set : in
Language_String_ID_Set_Access;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
- Max_Parallel : in
SAL.Base_Peek_Type := Default_Max_Parallel;
- Terminate_Same_State : in Boolean
:= True)
- is
- use all type Syntax_Trees.User_Data_Access;
- begin
- Parser.Lexer := Lexer;
- Parser.Trace := Trace;
- Parser.Table := Table;
- Parser.Language_Fixes := Language_Fixes;
- Parser.Language_Use_Minimal_Complete_Actions :=
Language_Use_Minimal_Complete_Actions;
- Parser.Language_String_ID_Set := Language_String_ID_Set;
- Parser.User_Data := User_Data;
-
- -- We can't use Table.McKenzie_Param /= Default_McKenzie_Param here,
- -- because the discriminants are different. We also can't use just
- -- Table.McKenzie_Param.Cost_Limit /=
- -- Default_McKenzie_Param.Cost_Limit, because some grammars don't set
- -- a Cost_Limit, just some other limit.
- Parser.Enable_McKenzie_Recover :=
- Table.McKenzie_Param.Cost_Limit /= Default_McKenzie_Param.Cost_Limit or
- Table.McKenzie_Param.Check_Limit /=
Default_McKenzie_Param.Check_Limit or
- Table.McKenzie_Param.Check_Delta_Limit /=
Default_McKenzie_Param.Check_Delta_Limit or
- Table.McKenzie_Param.Enqueue_Limit /=
Default_McKenzie_Param.Enqueue_Limit;
-
- Parser.Max_Parallel := Max_Parallel;
- Parser.Terminate_Same_State := Terminate_Same_State;
-
- if User_Data /= null then
- User_Data.Set_Lexer_Terminals (Lexer,
Parser.Terminals'Unchecked_Access);
- end if;
- end New_Parser;
-
- overriding procedure Parse (Shared_Parser : aliased in out LR.Parser.Parser)
- is
- use all type Ada.Strings.Unbounded.Unbounded_String;
- use all type Syntax_Trees.User_Data_Access;
- use all type Ada.Containers.Count_Type;
- use all type SAL.Base_Peek_Type;
-
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
-
- Current_Verb : All_Parse_Action_Verbs;
- Error_Recovered : Boolean := False;
- Current_Parser : Parser_Lists.Cursor;
- Action : Parse_Action_Node_Ptr;
- Zombie_Count : SAL.Base_Peek_Type;
-
- procedure Check_Error (Check_Parser : in out Parser_Lists.Cursor)
- is begin
- if Check_Parser.Verb = Error then
- -- This parser errored on last input. This is how grammar
conflicts
- -- are resolved when the input text is valid, in which case we
should
- -- just terminate this parser. However, this may be due to invalid
- -- input text, so we keep the parser alive but suspended for a few
- -- tokens, to see if the other parsers also error, in which case
they
- -- all participate in error recovery.
-
- -- We do not create zombie parsers during resume.
- if not Check_Parser.State_Ref.Resume_Active then
- -- Parser is now a zombie
- if Trace_Parse > Detail then
- Trace.Put_Line (Integer'Image (Check_Parser.Label) & ":
zombie");
- end if;
- Check_Parser.Next;
-
- else
- if Shared_Parser.Parsers.Count = 1 then
- if Trace_Parse > Outline then
- Trace.Put_Line (Integer'Image (Check_Parser.Label) & ":
error during resume");
- end if;
- Shared_Parser.Parsers.First_State_Ref.Errors.Append
- ((Label => LR.Message,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Recover => <>,
- Msg => +"error during resume"));
- raise Syntax_Error;
-
- else
- -- This is ok if a conflict occured during resume - we
assume this is
- -- a branch that failed during recover as well. Otherwise
it's a
- -- programmer error.
- if Check_Parser.State_Ref.Conflict_During_Resume then
- Shared_Parser.Parsers.Terminate_Parser
- (Check_Parser, "error in conflict during resume",
Shared_Parser.Trace.all,
- Shared_Parser.Terminals);
- else
- raise SAL.Programmer_Error with "error during resume";
- end if;
- end if;
- end if;
- else
- Check_Parser.Next;
- end if;
- end Check_Error;
-
- begin
- if Debug_Mode then
- Trace.Put_Clock ("start");
- end if;
-
- if Shared_Parser.User_Data /= null then
- Shared_Parser.User_Data.Reset;
- end if;
-
- Shared_Parser.Lex_All;
-
- Shared_Parser.String_Quote_Checked := Invalid_Line_Number;
- Shared_Parser.Shared_Tree.Clear;
- Shared_Parser.Parsers := Parser_Lists.New_List
- (Shared_Tree => Shared_Parser.Shared_Tree'Unchecked_Access);
-
- Shared_Parser.Parsers.First.State_Ref.Stack.Push
((Shared_Parser.Table.State_First, others => <>));
-
- Main_Loop :
- loop
- -- exit on Accept_It action or syntax error.
-
- Parse_Verb (Shared_Parser, Current_Verb, Zombie_Count);
-
- if Trace_Parse > Extra then
- Trace.Put_Line ("cycle start; current_verb: " &
Parse_Action_Verbs'Image (Current_Verb));
- end if;
-
- case Current_Verb is
- when Pause =>
- null;
-
- when Shift =>
- -- We just shifted a token; get the next token from
- -- Shared_Parser.Terminals.
-
- for Parser_State of Shared_Parser.Parsers loop
- if Parser_State.Verb = Error then
- if Shared_Parser.Enable_McKenzie_Recover then
- Parser_State.Zombie_Token_Count :=
Parser_State.Zombie_Token_Count + 1;
- if Trace_Parse > Extra then
- Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ": zombie (" &
- Token_Index'Image
- (Shared_Parser.Table.McKenzie_Param.Check_Limit
- Parser_State.Zombie_Token_Count) &
- " tokens remaining)");
- end if;
- end if;
-
- elsif Parser_State.Verb = Shift then
- if Parser_State.Recover_Insert_Delete.Length > 0 and then
- Parser_State.Recover_Insert_Delete.Peek.Op = Insert and
then
- Parser_State.Recover_Insert_Delete.Peek.Token_Index =
- (if Parser_State.Inc_Shared_Token
- then Parser_State.Shared_Token + 1
- else Parser_State.Shared_Token)
- then
- Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
- (Parser_State.Recover_Insert_Delete.Get.ID);
-
- elsif (if Parser_State.Inc_Shared_Token
- then Parser_State.Shared_Token + 1
- else Parser_State.Shared_Token) <=
Shared_Parser.Terminals.Last_Index
- then
- if Parser_State.Inc_Shared_Token then
- -- Inc_Shared_Token is only set False by
McKenzie_Recover; see there
- -- for when/why. Don't increment past wisi_eoi
(happens when input
- -- buffer is empty; test_mckenzie_recover.adb
Empty_Comments).
- Parser_State.Shared_Token := Parser_State.Shared_Token
+ 1;
- else
- Parser_State.Inc_Shared_Token := True;
- end if;
-
- Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
- (Parser_State.Shared_Token, Shared_Parser.Terminals);
-
- end if;
-
- if Trace_Parse > Extra then
- Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ": current_token"
& Parser_State.Tree.Image
- (Parser_State.Current_Token, Trace.Descriptor.all));
- end if;
- end if;
- end loop;
-
- when Accept_It =>
- -- All parsers accepted or are zombies.
- declare
- Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
- Temp : Parser_Lists.Cursor;
- begin
- if Count = 1 then
- -- Nothing more to do
- if Trace_Parse > Outline then
- Trace.Put_Line (Integer'Image
(Shared_Parser.Parsers.First.Label) & ": succeed");
- end if;
- exit Main_Loop;
-
- elsif Zombie_Count + 1 = Count then
- -- All but one are zombies
- Current_Parser := Shared_Parser.Parsers.First;
- loop
- if Current_Parser.Verb = Accept_It then
- if Trace_Parse > Outline then
- Trace.Put_Line (Integer'Image
(Current_Parser.Label) & ": succeed with zombies");
- end if;
- Current_Parser.Next;
- else
- Temp := Current_Parser;
- Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser
- (Temp, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end if;
- exit when Current_Parser.Is_Done;
- end loop;
-
- exit Main_Loop;
-
- else
- -- More than one parser is active.
- declare
- use all type Parser_Lists.Cursor;
- Error_Parser_Count : Integer := (if
Shared_Parser.Lexer.Errors.Length > 0 then 1 else 0);
- Recover_Ops_Length : Ada.Containers.Count_Type;
- Min_Recover_Ops_Length : Ada.Containers.Count_Type :=
Ada.Containers.Count_Type'Last;
- Min_Recover_Ops_Cur : Parser_Lists.Cursor;
- begin
- Current_Parser := Shared_Parser.Parsers.First;
- loop
- if Current_Parser.Verb = Accept_It then
- if Current_Parser.State_Ref.Errors.Length > 0 then
- Error_Parser_Count := Error_Parser_Count + 1;
- end if;
- Current_Parser.Next;
- else
- Temp := Current_Parser;
- Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser
- (Temp, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end if;
- exit when Current_Parser.Is_Done;
- end loop;
-
- if Error_Parser_Count > 0 then
- -- There was at least one error. We assume that
caused the ambiguous
- -- parse, and we pick the parser with the minimum
recover ops length
- -- to allow the parse to succeed. We terminate the
other parsers so
- -- the first parser executes actions.
- --
- -- Note all surviving parsers must have the same
error count, or only
- -- the one with the lowest would get here.
- Current_Parser := Shared_Parser.Parsers.First;
- loop
- Recover_Ops_Length :=
Current_Parser.Max_Recover_Ops_Length;
- if Recover_Ops_Length < Min_Recover_Ops_Length then
- Min_Recover_Ops_Length := Recover_Ops_Length;
- Min_Recover_Ops_Cur := Current_Parser;
- end if;
- Current_Parser.Next;
- exit when Current_Parser.Is_Done;
- end loop;
-
- Current_Parser := Shared_Parser.Parsers.First;
- loop
- if Current_Parser = Min_Recover_Ops_Cur then
- Current_Parser.Next;
- else
- Temp := Current_Parser;
- Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser
- (Temp, "errors", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end if;
- exit when Current_Parser.Is_Done;
- end loop;
-
- exit Main_Loop;
-
- else
- -- There were no previous errors. We allow the parse
to fail, on the
- -- assumption that an otherwise correct input should
not yield an
- -- ambiguous parse.
- declare
- Token : Base_Token renames Shared_Parser.Terminals
(Shared_Parser.Terminals.Last_Index);
- begin
- raise WisiToken.Parse_Error with Error_Message
- (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
- "Ambiguous parse:" & SAL.Base_Peek_Type'Image
(Count) & " parsers active.");
- end;
- end if;
- end;
- end if;
- end;
-
- when Reduce =>
- null;
-
- when Error =>
- -- All parsers errored; attempt recovery
- declare
- use all type McKenzie_Recover.Recover_Status;
-
- Recover_Result : McKenzie_Recover.Recover_Status :=
McKenzie_Recover.Recover_Status'First;
-
- Pre_Recover_Parser_Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
- begin
- -- Recover algorithms expect current token at
- -- Parsers(*).Current_Token, will set
- -- Parsers(*).Recover_Insert_Delete with new input tokens and
- -- deletions, adjust Parsers(*).Stack, and set
- -- Parsers(*).Current_Token and Parsers(*).Verb.
-
- if Shared_Parser.Enable_McKenzie_Recover then
- if Trace_Parse > Outline then
- Trace.Put_Line ("recover");
- end if;
- if Debug_Mode then
- Trace.Put_Clock ("pre-recover" &
Shared_Parser.Parsers.Count'Img & " active");
- end if;
- Recover_Result := McKenzie_Recover.Recover (Shared_Parser);
- if Debug_Mode then
- Trace.Put_Clock ("post-recover" &
Shared_Parser.Parsers.Count'Img & " active");
- end if;
-
- if Trace_Parse > Outline then
- if Recover_Result = Success then
- Trace.Put_Line
- ("recover: succeed, parser count" &
SAL.Base_Peek_Type'Image (Shared_Parser.Parsers.Count));
- else
- Trace.Put_Line
- ("recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result) &
- ", parser count" & SAL.Base_Peek_Type'Image
(Shared_Parser.Parsers.Count));
- end if;
- end if;
-
- if Ada.Text_IO.Is_Open (Shared_Parser.Recover_Log_File) then
- declare
- use Ada.Text_IO;
- Strategy_Counts : LR.Strategy_Counts := (others => 0);
- begin
- Put
- (Shared_Parser.Recover_Log_File,
- Ada.Calendar.Formatting.Image (Ada.Calendar.Clock)
& " " &
- McKenzie_Recover.Recover_Status'Image
(Recover_Result) & " " &
- SAL.Base_Peek_Type'Image
(Pre_Recover_Parser_Count) & " '" &
- Shared_Parser.Lexer.File_Name & "'");
-
- Put (Shared_Parser.Recover_Log_File, '(');
- for Parser of Shared_Parser.Parsers loop
- Accumulate (Parser.Recover, Strategy_Counts);
- Put
- (Shared_Parser.Recover_Log_File,
- Integer'Image (Parser.Recover.Enqueue_Count) &
- Integer'Image (Parser.Recover.Check_Count) & "
" &
- Boolean'Image (Parser.Recover.Success));
- end loop;
- Put (Shared_Parser.Recover_Log_File, ')');
-
- Put (Shared_Parser.Recover_Log_File, Image
(Strategy_Counts));
- New_Line (Shared_Parser.Recover_Log_File);
- Flush (Shared_Parser.Recover_Log_File);
- end;
- end if;
- else
- if Trace_Parse > Outline then
- Trace.Put_Line ("recover disabled");
- end if;
- end if;
-
- if Recover_Result = Success then
- for Parser_State of Shared_Parser.Parsers loop
- Parser_State.Resume_Active := True;
- Parser_State.Conflict_During_Resume := False;
-
- if Trace_Parse > Outline then
- Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ":
Current_Token " &
- Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) &
- " Shared_Token " & Image
- (Parser_State.Shared_Token,
Shared_Parser.Terminals, Trace.Descriptor.all));
-
- if Trace_Parse > Detail then
- Shared_Parser.Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ":
resume_active: True, token goal" &
- Token_Index'Image
(Parser_State.Resume_Token_Goal));
- end if;
- end if;
-
- Parser_State.Zombie_Token_Count := 0;
-
- case Parser_State.Verb is
- when Reduce =>
- null;
-
- when Error =>
- -- Force this parser to be terminated.
- if Shared_Parser.Enable_McKenzie_Recover then
- Parser_State.Zombie_Token_Count :=
Shared_Parser.Table.McKenzie_Param.Check_Limit + 1;
- end if;
-
- when Shift =>
- null;
-
- when Pause | Accept_It =>
- raise SAL.Programmer_Error;
- end case;
- end loop;
-
- else
- -- Terminate with error. Parser_State has all the required
info on
- -- the original error (recorded by Error in Do_Action);
report reason
- -- recover failed.
- for Parser_State of Shared_Parser.Parsers loop
- Parser_State.Errors.Append
- ((Label => LR.Message,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Recover => <>,
- Msg => +"recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result)));
- end loop;
- raise WisiToken.Syntax_Error;
- end if;
-
- -- Immediately execute Do_Action for Current_Token, since it
changed
- -- in error recovery; this sets Parser.Verb. This replaces the
- -- execution of Do_Action that resulted in Error.
- Error_Recovered := True;
-
- end;
- end case;
-
- -- We don't use 'for Parser_State of Parsers loop' here,
- -- because terminate on error and spawn on conflict require
- -- changing the parser list.
- Current_Parser := Shared_Parser.Parsers.First;
- Action_Loop :
- loop
- exit Action_Loop when Current_Parser.Is_Done;
-
- -- We don't check duplicate state during resume, because the
tokens
- -- inserted/deleted by error recover may cause initially duplicate
- -- states to diverge.
- if not Current_Parser.State_Ref.Resume_Active and
- Shared_Parser.Terminate_Same_State and
- Current_Verb = Shift and
- (for all Parser of Shared_Parser.Parsers =>
Parser.Recover_Insert_Delete.Count = 0)
- then
- Shared_Parser.Parsers.Duplicate_State
- (Current_Parser, Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- -- If Duplicate_State terminated Current_Parser,
Current_Parser now
- -- points to the next parser. Otherwise it is unchanged.
- end if;
-
- exit Action_Loop when Current_Parser.Is_Done;
-
- if Trace_Parse > Extra then
- if Error_Recovered then
- Trace.Put_Line (Integer'Image (Current_Parser.Label) &
".error_recovered");
- else
- Trace.Put_Line
- ("current_verb: " & Parse_Action_Verbs'Image
(Current_Verb) &
- "," & Integer'Image (Current_Parser.Label) &
- ".verb: " & Parse_Action_Verbs'Image
(Current_Parser.Verb));
- end if;
- end if;
-
- -- Each branch of the following 'if' calls either
Current_Parser.Free
- -- (which advances to the next parser) or Current_Parser.Next.
-
- if Current_Parser.Verb = Error then
- -- This parser is a zombie; see Check_Error above.
- --
- -- Check to see if it is time to terminate it
- if Shared_Parser.Enable_McKenzie_Recover and then
- Current_Parser.State_Ref.Zombie_Token_Count <=
Shared_Parser.Table.McKenzie_Param.Check_Limit
- then
- if Trace_Parse > Detail then
- Trace.Put_Line (Integer'Image (Current_Parser.Label) & ":
zombie");
- end if;
-
- Current_Parser.Next;
- else
- Shared_Parser.Parsers.Terminate_Parser
- (Current_Parser, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end if;
-
- elsif Current_Parser.Verb = Current_Verb or Error_Recovered then
-
- if Trace_Parse > Extra then
- Parser_Lists.Put_Top_10 (Trace, Current_Parser);
- end if;
-
- declare
- State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
- begin
- Action := Action_For
- (Table => Shared_Parser.Table.all,
- State => State.Stack.Peek.State,
- ID => State.Tree.ID (State.Current_Token));
- end;
-
- if Action.Next /= null then
- -- Conflict; spawn a new parser (before modifying
Current_Parser
- -- stack).
-
- Current_Parser.State_Ref.Conflict_During_Resume :=
Current_Parser.State_Ref.Resume_Active;
-
- if Shared_Parser.Parsers.Count = Shared_Parser.Max_Parallel
then
- -- If errors were recovered, terminate a parser that
used the
- -- highest cost solution.
- declare
- use all type WisiToken.Parse.LR.Parser_Lists.Cursor;
- Max_Recover_Cost : Integer := 0;
- Max_Parser : Parser_Lists.Cursor;
- Cur : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
- begin
- loop
- exit when Cur.Is_Done;
- if Cur.Total_Recover_Cost > Max_Recover_Cost then
- Max_Parser := Cur;
- Max_Recover_Cost := Cur.Total_Recover_Cost;
- end if;
- Cur.Next;
- end loop;
-
- if Max_Recover_Cost > 0 then
- if Max_Parser = Current_Parser then
- Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser
- (Current_Parser, "too many parsers; max error
repair cost", Trace,
- Shared_Parser.Terminals);
- exit Action_Loop;
- else
- Shared_Parser.Parsers.Terminate_Parser
- (Max_Parser, "too many parsers; max error
repair cost", Trace,
- Shared_Parser.Terminals);
- end if;
- end if;
- end;
- end if;
-
- if Shared_Parser.Parsers.Count = Shared_Parser.Max_Parallel
then
- declare
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
- Token : Base_Token renames Shared_Parser.Terminals
(Parser_State.Shared_Token);
- begin
- raise WisiToken.Parse_Error with Error_Message
- (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
- "too many parallel parsers required in grammar
state" &
- State_Index'Image (Parser_State.Stack.Peek.State)
&
- "; simplify grammar, or increase max-parallel (" &
- SAL.Base_Peek_Type'Image
(Shared_Parser.Max_Parallel) & ")");
- end;
-
- else
- if Trace_Parse > Outline then
- declare
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
- begin
- Trace.Put_Line
- (Integer'Image (Current_Parser.Label) & ": " &
- Trimmed_Image (Parser_State.Stack.Peek.State)
& ": " &
- Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) & " : " &
- "spawn" & Integer'Image
(Shared_Parser.Parsers.Last_Label + 1) & ", (" &
- Trimmed_Image (1 + Integer
(Shared_Parser.Parsers.Count)) & " active)");
- end;
- end if;
-
- Shared_Parser.Parsers.Prepend_Copy (Current_Parser);
- Do_Action (Action.Next.Item, Shared_Parser.Parsers.First,
Shared_Parser);
-
- -- We must terminate error parsers immediately in order
to avoid
- -- zombie parsers during recovery.
- declare
- Temp : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
- begin
- Check_Error (Temp);
- end;
- end if;
- end if;
-
- Do_Action (Action.Item, Current_Parser, Shared_Parser);
- Check_Error (Current_Parser);
-
- else
- -- Current parser is waiting for others to catch up
- Current_Parser.Next;
- end if;
- end loop Action_Loop;
- Error_Recovered := False;
- end loop Main_Loop;
- if Debug_Mode then
- Trace.Put_Clock ("finish");
- end if;
-
- -- We don't raise Syntax_Error for lexer errors, since they are all
- -- recovered, either by inserting a quote, or by ignoring the
- -- character.
- exception
- when Syntax_Error | WisiToken.Parse_Error | Partial_Parse =>
- if Debug_Mode then
- Trace.Put_Clock ("finish - error");
- end if;
- raise;
-
- when E : others =>
- declare
- Msg : constant String := Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E);
- begin
- if Shared_Parser.Parsers.Count > 0 then
- -- Emacs displays errors in the *syntax-errors* buffer
- Shared_Parser.Parsers.First_State_Ref.Errors.Append
- ((Label => LR.Message,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Recover => <>,
- Msg => +Msg));
- end if;
-
- if Debug_Mode then
- Ada.Text_IO.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback
(E));
- end if;
-
- -- Emacs displays the exception message in the echo area; easy to
miss
- raise WisiToken.Parse_Error with Msg;
- end;
- end Parse;
-
- overriding function Tree (Shared_Parser : in Parser) return
Syntax_Trees.Tree
- is
- use all type SAL.Base_Peek_Type;
- begin
- if Shared_Parser.Parsers.Count > 1 then
- raise WisiToken.Parse_Error with "ambigous parse";
- else
- return Shared_Parser.Parsers.First_State_Ref.Tree;
- end if;
- end Tree;
-
- overriding
- procedure Execute_Actions (Parser : in out LR.Parser.Parser)
- is
- use all type SAL.Base_Peek_Type;
- use all type Syntax_Trees.User_Data_Access;
- use all type WisiToken.Syntax_Trees.Semantic_Action;
-
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- procedure Process_Node
- (Tree : in out Syntax_Trees.Tree;
- Node : in Syntax_Trees.Valid_Node_Index)
- is
- use all type Syntax_Trees.Node_Label;
- begin
- if Tree.Label (Node) /= Nonterm then
- return;
- end if;
-
- declare
- Tree_Children : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Children (Node);
- begin
- Parser.User_Data.Reduce (Tree, Node, Tree_Children);
- if Tree.Action (Node) /= null then
- Tree.Action (Node) (Parser.User_Data.all, Tree, Node,
Tree_Children);
- end if;
- end;
- end Process_Node;
-
- begin
- if Parser.User_Data /= null then
- if Parser.Parsers.Count > 1 then
- raise Syntax_Error with "ambiguous parse; can't execute actions";
- end if;
-
- declare
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_State_Ref.Element.all;
- begin
- if Trace_Action > Outline then
- Parser.Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ": root node: " &
Parser_State.Tree.Image
- (Parser_State.Tree.Root, Descriptor));
- end if;
-
- if (for some Err of Parser_State.Errors => Any (Err.Recover.Ops,
Delete)) then
- for Err of Parser_State.Errors loop
- for Op of Err.Recover.Ops loop
- case Op.Op is
- when Delete =>
- Parser.User_Data.Delete_Token (Op.Token_Index);
- when others =>
- null;
- end case;
- end loop;
- end loop;
- end if;
-
- Parser_State.Tree.Process_Tree (Process_Node'Access);
- end;
- end if;
- end Execute_Actions;
-
- overriding function Any_Errors (Parser : in LR.Parser.Parser) return Boolean
- is
- use all type SAL.Base_Peek_Type;
- use all type Ada.Containers.Count_Type;
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
- begin
- pragma Assert (Parser_State.Tree.Flushed);
- return Parser.Parsers.Count > 1 or Parser_State.Errors.Length > 0 or
Parser.Lexer.Errors.Length > 0;
- end Any_Errors;
-
- overriding procedure Put_Errors (Parser : in LR.Parser.Parser)
- is
- use all type SAL.Base_Peek_Type;
- use Ada.Text_IO;
-
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
- begin
- for Item of Parser.Lexer.Errors loop
- Put_Line
- (Current_Error,
- Parser.Lexer.File_Name & ":0:0: lexer unrecognized character at" &
Buffer_Pos'Image (Item.Char_Pos));
- end loop;
-
- for Item of Parser_State.Errors loop
- case Item.Label is
- when Action =>
- declare
- Index : constant Base_Token_Index :=
Parser_State.Tree.Min_Terminal_Index (Item.Error_Token);
- begin
- if Index = Invalid_Token_Index then
- -- Error_Token is virtual
- Put_Line
- (Current_Error,
- Error_Message
- (Parser.Lexer.File_Name, 1, 0,
- "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
- ", found " & Image (Parser_State.Tree.ID
(Item.Error_Token), Descriptor)));
- else
- declare
- Token : Base_Token renames Parser.Terminals (Index);
- begin
- Put_Line
- (Current_Error,
- Error_Message
- (Parser.Lexer.File_Name, Token.Line, Token.Column,
- "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
- ", found '" & Parser.Lexer.Buffer_Text
(Token.Byte_Region) & "'"));
- end;
- end if;
- end;
- when Check =>
- Put_Line
- (Current_Error,
- Parser.Lexer.File_Name & ":0:0: semantic check error: " &
- Semantic_Checks.Image (Item.Check_Status, Descriptor));
- when Message =>
- Put_Line (Current_Error, -Item.Msg);
- end case;
-
- if Item.Recover.Stack.Depth /= 0 then
- Put_Line (Current_Error, " recovered: " & Image
(Item.Recover.Ops, Descriptor));
- end if;
- end loop;
- end Put_Errors;
-
-end WisiToken.Parse.LR.Parser;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Calendar.Formatting;
+with Ada.Exceptions;
+with GNAT.Traceback.Symbolic;
+with WisiToken.Parse.LR.McKenzie_Recover;
+package body WisiToken.Parse.LR.Parser is
+
+ function Reduce_Stack_1
+ (Current_Parser : in Parser_Lists.Cursor;
+ Action : in Reduce_Action_Rec;
+ Nonterm : out WisiToken.Syntax_Trees.Valid_Node_Index;
+ Lexer : in WisiToken.Lexer.Handle;
+ Trace : in out WisiToken.Trace'Class)
+ return WisiToken.Semantic_Checks.Check_Status_Label
+ is
+ -- We treat semantic check errors as parse errors here, to allow
+ -- error recovery to take better advantage of them. One recovery
+ -- strategy is to fix things so the semantic check passes.
+
+ use all type SAL.Base_Peek_Type;
+ use all type Semantic_Checks.Check_Status_Label;
+ use all type Semantic_Checks.Semantic_Check;
+
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
+ Children_Tree : Syntax_Trees.Valid_Node_Index_Array (1 ..
SAL.Base_Peek_Type (Action.Token_Count));
+ begin
+ for I in reverse Children_Tree'Range loop
+ Children_Tree (I) := Parser_State.Stack.Pop.Token;
+ end loop;
+
+ Nonterm := Parser_State.Tree.Add_Nonterm
+ (Action.Production, Children_Tree, Action.Action,
+ Default_Virtual => Parser_State.Tree.Is_Virtual
(Parser_State.Current_Token));
+ -- Computes Nonterm.Byte_Region, Virtual
+
+ if Trace_Parse > Detail then
+ Trace.Put_Line (Parser_State.Tree.Image (Nonterm,
Trace.Descriptor.all, Include_Children => True));
+ end if;
+
+ if Action.Check = null then
+ return Ok;
+
+ else
+ declare
+ Nonterm_Token : Recover_Token :=
Parser_State.Tree.Recover_Token (Nonterm);
+ Children_Token : constant Recover_Token_Array :=
Parser_State.Tree.Recover_Token_Array (Children_Tree);
+ Status : Semantic_Checks.Check_Status;
+ begin
+ Status := Action.Check (Lexer, Nonterm_Token, Children_Token,
Recover_Active => False);
+
+ Parser_State.Tree.Set_Name_Region (Nonterm, Nonterm_Token.Name);
+
+ if Trace_Parse > Detail then
+ Trace.Put_Line ("semantic check " & Semantic_Checks.Image
(Status, Trace.Descriptor.all));
+ end if;
+
+ case Status.Label is
+ when Ok =>
+ return Ok;
+
+ when Semantic_Checks.Error =>
+ if Parser_State.Resume_Active then
+ -- Ignore this error; that's how McKenzie_Recover decided
to fix it
+ return Ok;
+
+ else
+ Parser_State.Errors.Append
+ ((Label => Check,
+ First_Terminal => Trace.Descriptor.First_Terminal,
+ Last_Terminal => Trace.Descriptor.Last_Terminal,
+ Check_Status => Status,
+ Recover => (others => <>)));
+ return Status.Label;
+ end if;
+ end case;
+ exception
+ when Partial_Parse =>
+ -- From Action.Check
+ Parser_State.Tree.Set_Root (Nonterm);
+ raise;
+ end;
+ end if;
+ end Reduce_Stack_1;
+
+ procedure Do_Action
+ (Action : in Parse_Action_Rec;
+ Current_Parser : in Parser_Lists.Cursor;
+ Shared_Parser : in LR.Parser.Parser)
+ is
+ use all type Semantic_Checks.Check_Status_Label;
+
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+ Nonterm : WisiToken.Syntax_Trees.Valid_Node_Index;
+ Status : Semantic_Checks.Check_Status_Label;
+ begin
+ if Trace_Parse > Detail then
+ Trace.Put
+ (Integer'Image (Current_Parser.Label) & ": " &
+ Trimmed_Image (Parser_State.Stack.Peek.State) & ": " &
+ Parser_State.Tree.Image (Parser_State.Current_Token,
Trace.Descriptor.all) & " : ");
+ Put (Trace, Action);
+ Trace.New_Line;
+ end if;
+
+ case Action.Verb is
+ when Shift =>
+ Current_Parser.Set_Verb (Shift);
+ Parser_State.Stack.Push ((Action.State, Parser_State.Current_Token));
+ Parser_State.Tree.Set_State (Parser_State.Current_Token,
Action.State);
+
+ when Reduce =>
+ declare
+ use all type SAL.Base_Peek_Type;
+
+ New_State : constant Unknown_State_Index := Goto_For
+ (Table => Shared_Parser.Table.all,
+ State => Parser_State.Stack (SAL.Base_Peek_Type
(Action.Token_Count) + 1).State,
+ ID => Action.Production.LHS);
+ begin
+ if New_State = Unknown_State then
+ -- This is due to a bug in the LALR parser generator (see
+ -- lalr_generator_bug_01.wy); we treat it as a syntax error.
+ Current_Parser.Set_Verb (Error);
+ if Trace_Parse > Detail then
+ Trace.Put_Line (" ... error");
+ end if;
+
+ else
+ Status := Reduce_Stack_1 (Current_Parser, Action, Nonterm,
Shared_Parser.Lexer, Trace);
+
+ -- Even when Reduce_Stack_1 returns Error, it did reduce the
stack, so
+ -- push Nonterm.
+ Parser_State.Stack.Push ((New_State, Nonterm));
+
+ Parser_State.Tree.Set_State (Nonterm, New_State);
+
+ case Status is
+ when Ok =>
+ Current_Parser.Set_Verb (Reduce);
+
+ if Trace_Parse > Detail then
+ Trace.Put_Line (" ... goto state " & Trimmed_Image
(New_State));
+ end if;
+
+ when Semantic_Checks.Error =>
+ Current_Parser.Set_Verb (Error);
+ Parser_State.Zombie_Token_Count := 1;
+ end case;
+ end if;
+ end;
+
+ when Accept_It =>
+ case Reduce_Stack_1
+ (Current_Parser,
+ (Reduce, Action.Production, Action.Action, Action.Check,
Action.Token_Count),
+ Nonterm, Shared_Parser.Lexer, Trace)
+ is
+ when Ok =>
+ Current_Parser.Set_Verb (Action.Verb);
+
+ Parser_State.Tree.Set_Root (Nonterm);
+
+ when Semantic_Checks.Error =>
+ Current_Parser.Set_Verb (Error);
+ Parser_State.Zombie_Token_Count := 1;
+ end case;
+
+ when Error =>
+ Current_Parser.Set_Verb (Action.Verb);
+
+ Parser_State.Zombie_Token_Count := 1;
+
+ declare
+ Expecting : constant Token_ID_Set := LR.Expecting
+ (Shared_Parser.Table.all, Parser_State.Stack.Peek.State);
+ begin
+ Parser_State.Errors.Append
+ ((Label => LR.Action,
+ First_Terminal => Trace.Descriptor.First_Terminal,
+ Last_Terminal => Trace.Descriptor.Last_Terminal,
+ Error_Token => Parser_State.Current_Token,
+ Expecting => Expecting,
+ Recover => (others => <>)));
+
+ if Trace_Parse > Outline then
+ Put
+ (Trace,
+ Integer'Image (Current_Parser.Label) & ":" &
+ Unknown_State_Index'Image (Parser_State.Stack.Peek.State)
& ": expecting: " &
+ Image (Expecting, Trace.Descriptor.all));
+ Trace.New_Line;
+ end if;
+ end;
+ end case;
+ end Do_Action;
+
+ procedure Do_Deletes
+ (Shared_Parser : in out LR.Parser.Parser;
+ Parser_State : in out Parser_Lists.Parser_State)
+ is
+ use all type SAL.Base_Peek_Type;
+ begin
+ if Trace_Parse > Extra then
+ Shared_Parser.Trace.Put_Line
+ (Integer'Image (Parser_State.Label) & ": shared_token:" &
+ WisiToken.Token_Index'Image (Parser_State.Shared_Token) &
+ " inc_shared_token: " & Boolean'Image
(Parser_State.Inc_Shared_Token) &
+ " recover_insert_delete: " &
+ Image (Parser_State.Recover_Insert_Delete,
Shared_Parser.Trace.Descriptor.all));
+ end if;
+
+ loop
+ if Parser_State.Recover_Insert_Delete.Length > 0 and then
+ Parser_State.Recover_Insert_Delete.Peek.Op = Delete and then
+ Parser_State.Recover_Insert_Delete.Peek.Del_Token_Index =
+ (if Parser_State.Inc_Shared_Token
+ then Parser_State.Shared_Token + 1
+ else Parser_State.Shared_Token)
+ then
+ Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
+ -- We don't reset Inc_Shared_Token here; only after the next
token is
+ -- actually used.
+ Parser_State.Prev_Deleted.Append
(Parser_State.Recover_Insert_Delete.Peek.Del_Token_Index);
+ Parser_State.Recover_Insert_Delete.Drop;
+
+ elsif Parser_State.Prev_Deleted.Contains
+ ((if Parser_State.Inc_Shared_Token
+ then Parser_State.Shared_Token + 1
+ else Parser_State.Shared_Token))
+ then
+ Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
+
+ else
+ exit;
+ end if;
+ end loop;
+ end Do_Deletes;
+
+ -- Verb: the type of parser cycle to execute;
+ --
+ -- Accept : all Parsers.Verb return Accept - done parsing.
+ --
+ -- Shift : some Parsers.Verb return Shift, all with the same current
+ -- token in Shared_Parser.Terminals.
+ --
+ -- Pause : Resume is active, and this parser has reached Resume_Goal,
+ -- so it is waiting for the others to catch up.
+ --
+ -- Reduce : some Parsers.Verb return Reduce.
+ --
+ -- Error : all Parsers.Verb return Error.
+ --
+ -- Zombie_Count: count of parsers in Error state
+ procedure Parse_Verb
+ (Shared_Parser : in out LR.Parser.Parser;
+ Verb : out All_Parse_Action_Verbs;
+ Zombie_Count : out SAL.Base_Peek_Type)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ Shift_Count : SAL.Base_Peek_Type := 0;
+ Accept_Count : SAL.Base_Peek_Type := 0;
+ Error_Count : SAL.Base_Peek_Type := 0;
+ Resume_Active : Boolean := False;
+ begin
+ Zombie_Count := 0;
+
+ for Parser_State of Shared_Parser.Parsers loop
+ case Parser_State.Verb is
+ when Pause | Shift =>
+ Do_Deletes (Shared_Parser, Parser_State);
+
+ Shift_Count := Shift_Count + 1;
+ Parser_State.Set_Verb (Shift);
+
+ if Parser_State.Resume_Active then
+ if Parser_State.Resume_Token_Goal <= Parser_State.Shared_Token
then
+ Parser_State.Resume_Active := False;
+ if Trace_Parse > Detail then
+ Shared_Parser.Trace.Put_Line (Integer'Image
(Parser_State.Label) & ": resume_active: False");
+ end if;
+ else
+ Resume_Active := True;
+ end if;
+ end if;
+
+ when Reduce =>
+ Verb := Reduce;
+ return;
+
+ when Accept_It =>
+ Accept_Count := Accept_Count + 1;
+
+ when Error =>
+ if Shared_Parser.Enable_McKenzie_Recover then
+ -- This parser is waiting for others to error; they can
continue
+ -- parsing.
+ Zombie_Count := Zombie_Count + 1;
+ else
+ Error_Count := Error_Count + 1;
+ end if;
+ end case;
+ end loop;
+
+ if Accept_Count > 0 and Shared_Parser.Parsers.Count = Accept_Count +
Zombie_Count then
+ Verb := Accept_It;
+
+ elsif Shared_Parser.Parsers.Count = Error_Count + Zombie_Count then
+ Verb := Error;
+
+ elsif Shift_Count > 0 then
+ Verb := Shift;
+
+ else
+ raise SAL.Programmer_Error;
+ end if;
+
+ if Resume_Active then
+ for Parser_State of Shared_Parser.Parsers loop
+ if Parser_State.Verb = Shift and not Parser_State.Resume_Active
then
+ Parser_State.Set_Verb (Pause);
+ end if;
+ end loop;
+ end if;
+ end Parse_Verb;
+
+ ----------
+ -- Public subprograms, declaration order
+
+ overriding procedure Finalize (Object : in out LR.Parser.Parser)
+ is begin
+ Free_Table (Object.Table);
+ end Finalize;
+
+ procedure New_Parser
+ (Parser : out LR.Parser.Parser;
+ Trace : not null access WisiToken.Trace'Class;
+ Lexer : in WisiToken.Lexer.Handle;
+ Table : in Parse_Table_Ptr;
+ Language_Fixes : in Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
Language_String_ID_Set_Access;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
+ Max_Parallel : in SAL.Base_Peek_Type :=
Default_Max_Parallel;
+ Terminate_Same_State : in Boolean :=
True)
+ is
+ use all type Syntax_Trees.User_Data_Access;
+ begin
+ Parser.Lexer := Lexer;
+ Parser.Trace := Trace;
+ Parser.Table := Table;
+ Parser.Language_Fixes := Language_Fixes;
+ Parser.Language_Matching_Begin_Tokens := Language_Matching_Begin_Tokens;
+ Parser.Language_String_ID_Set := Language_String_ID_Set;
+ Parser.User_Data := User_Data;
+
+ -- We can't use Table.McKenzie_Param /= Default_McKenzie_Param here,
+ -- because the discriminants are different.
+ Parser.Enable_McKenzie_Recover :=
+ Table.McKenzie_Param.Check_Limit /= Default_McKenzie_Param.Check_Limit
or
+ Table.McKenzie_Param.Check_Delta_Limit /=
Default_McKenzie_Param.Check_Delta_Limit or
+ Table.McKenzie_Param.Enqueue_Limit /=
Default_McKenzie_Param.Enqueue_Limit;
+
+ Parser.Max_Parallel := Max_Parallel;
+ Parser.Terminate_Same_State := Terminate_Same_State;
+
+ if User_Data /= null then
+ User_Data.Set_Lexer_Terminals (Lexer,
Parser.Terminals'Unchecked_Access);
+ end if;
+ end New_Parser;
+
+ overriding procedure Parse (Shared_Parser : aliased in out LR.Parser.Parser)
+ is
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+ use all type Syntax_Trees.User_Data_Access;
+ use all type Ada.Containers.Count_Type;
+ use all type SAL.Base_Peek_Type;
+
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+
+ Current_Verb : All_Parse_Action_Verbs;
+ Error_Recovered : Boolean := False;
+ Current_Parser : Parser_Lists.Cursor;
+ Action : Parse_Action_Node_Ptr;
+ Zombie_Count : SAL.Base_Peek_Type;
+
+ procedure Check_Error (Check_Parser : in out Parser_Lists.Cursor)
+ is begin
+ if Check_Parser.Verb = Error then
+ -- This parser errored on last input. This is how grammar
conflicts
+ -- are resolved when the input text is valid, in which case we
should
+ -- just terminate this parser. However, this may be due to invalid
+ -- input text, so we keep the parser alive but suspended for a few
+ -- tokens, to see if the other parsers also error, in which case
they
+ -- all participate in error recovery.
+
+ -- We do not create zombie parsers during resume.
+ if not Check_Parser.State_Ref.Resume_Active then
+ -- Parser is now a zombie
+ if Trace_Parse > Detail then
+ Trace.Put_Line (Integer'Image (Check_Parser.Label) & ":
zombie");
+ end if;
+ Check_Parser.Next;
+
+ else
+ if Shared_Parser.Parsers.Count = 1 then
+ if Trace_Parse > Outline then
+ Trace.Put_Line (Integer'Image (Check_Parser.Label) & ":
error during resume");
+ end if;
+ Shared_Parser.Parsers.First_State_Ref.Errors.Append
+ ((Label => LR.Message,
+ First_Terminal => Trace.Descriptor.First_Terminal,
+ Last_Terminal => Trace.Descriptor.Last_Terminal,
+ Recover => <>,
+ Msg => +"error during resume"));
+ raise Syntax_Error;
+
+ else
+ -- This is ok if a conflict occured during resume - we
assume this is
+ -- a branch that failed during recover as well. Otherwise
it's a
+ -- programmer error.
+ if Check_Parser.State_Ref.Conflict_During_Resume then
+ Shared_Parser.Parsers.Terminate_Parser
+ (Check_Parser, "error in conflict during resume",
Shared_Parser.Trace.all,
+ Shared_Parser.Terminals);
+ else
+ raise SAL.Programmer_Error with "error during resume";
+ end if;
+ end if;
+ end if;
+ else
+ Check_Parser.Next;
+ end if;
+ end Check_Error;
+
+ begin
+ if Debug_Mode then
+ Trace.Put_Clock ("start");
+ end if;
+
+ if Shared_Parser.User_Data /= null then
+ Shared_Parser.User_Data.Reset;
+ end if;
+
+ Shared_Parser.Lex_All;
+
+ Shared_Parser.String_Quote_Checked := Invalid_Line_Number;
+ Shared_Parser.Shared_Tree.Clear;
+ Shared_Parser.Parsers := Parser_Lists.New_List
+ (Shared_Tree => Shared_Parser.Shared_Tree'Unchecked_Access);
+
+ Shared_Parser.Parsers.First.State_Ref.Stack.Push
((Shared_Parser.Table.State_First, others => <>));
+
+ Main_Loop :
+ loop
+ -- exit on Accept_It action or syntax error.
+
+ Parse_Verb (Shared_Parser, Current_Verb, Zombie_Count);
+
+ if Trace_Parse > Extra then
+ Trace.Put_Line ("cycle start; current_verb: " &
Parse_Action_Verbs'Image (Current_Verb));
+ end if;
+
+ case Current_Verb is
+ when Pause =>
+ null;
+
+ when Shift =>
+ -- We just shifted a token; get the next token from
+ -- Shared_Parser.Terminals.
+
+ for Parser_State of Shared_Parser.Parsers loop
+ if Parser_State.Verb = Error then
+ if Shared_Parser.Enable_McKenzie_Recover then
+ Parser_State.Zombie_Token_Count :=
Parser_State.Zombie_Token_Count + 1;
+ if Trace_Parse > Extra then
+ Trace.Put_Line
+ (Integer'Image (Parser_State.Label) & ": zombie (" &
+ WisiToken.Token_Index'Image
+ (Shared_Parser.Table.McKenzie_Param.Check_Limit
- Parser_State.Zombie_Token_Count) &
+ " tokens remaining)");
+ end if;
+ end if;
+
+ elsif Parser_State.Verb = Shift then
+ if Parser_State.Recover_Insert_Delete.Length > 0 and then
+ Parser_State.Recover_Insert_Delete.Peek.Op = Insert and
then
+ Parser_State.Recover_Insert_Delete.Peek.Ins_Token_Index =
+ (if Parser_State.Inc_Shared_Token
+ then Parser_State.Shared_Token + 1
+ else Parser_State.Shared_Token)
+ then
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
+ (Parser_State.Recover_Insert_Delete.Get.Ins_ID);
+
+ elsif (if Parser_State.Inc_Shared_Token
+ then Parser_State.Shared_Token + 1
+ else Parser_State.Shared_Token) <=
Shared_Parser.Terminals.Last_Index
+ then
+ if Parser_State.Inc_Shared_Token then
+ -- Inc_Shared_Token is only set False by
McKenzie_Recover; see there
+ -- for when/why. Don't increment past wisi_eoi
(happens when input
+ -- buffer is empty; test_mckenzie_recover.adb
Empty_Comments).
+ Parser_State.Shared_Token := Parser_State.Shared_Token
+ 1;
+ else
+ Parser_State.Inc_Shared_Token := True;
+ end if;
+
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
+ (Parser_State.Shared_Token, Shared_Parser.Terminals);
+
+ end if;
+
+ if Trace_Parse > Extra then
+ Trace.Put_Line
+ (Integer'Image (Parser_State.Label) & ": current_token"
& Parser_State.Tree.Image
+ (Parser_State.Current_Token, Trace.Descriptor.all));
+ end if;
+ end if;
+ end loop;
+
+ when Accept_It =>
+ -- All parsers accepted or are zombies.
+ declare
+ Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
+ Temp : Parser_Lists.Cursor;
+ begin
+ if Count = 1 then
+ -- Nothing more to do
+ exit Main_Loop;
+
+ elsif Zombie_Count + 1 = Count then
+ -- All but one are zombies
+ Current_Parser := Shared_Parser.Parsers.First;
+ loop
+ if Current_Parser.Verb = Accept_It then
+ Current_Parser.Next;
+ else
+ Temp := Current_Parser;
+ Current_Parser.Next;
+ Shared_Parser.Parsers.Terminate_Parser
+ (Temp, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
+ end if;
+ exit when Current_Parser.Is_Done;
+ end loop;
+
+ exit Main_Loop;
+
+ else
+ -- More than one parser is active.
+ declare
+ use all type Parser_Lists.Cursor;
+ Error_Parser_Count : Integer := (if
Shared_Parser.Lexer.Errors.Length > 0 then 1 else 0);
+
+ Recover_Cost : Integer;
+ Min_Recover_Cost : Integer :=
Integer'Last;
+ Recover_Ops_Length : Ada.Containers.Count_Type;
+ Max_Recover_Ops_Length : Ada.Containers.Count_Type :=
Ada.Containers.Count_Type'First;
+ Recover_Cur : Parser_Lists.Cursor;
+ begin
+ Current_Parser := Shared_Parser.Parsers.First;
+ loop
+ if Current_Parser.Verb = Accept_It then
+ if Current_Parser.State_Ref.Errors.Length > 0 then
+ Error_Parser_Count := Error_Parser_Count + 1;
+ end if;
+ Current_Parser.Next;
+ else
+ Temp := Current_Parser;
+ Current_Parser.Next;
+ Shared_Parser.Parsers.Terminate_Parser
+ (Temp, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
+ end if;
+ exit when Current_Parser.Is_Done;
+ end loop;
+
+ if Error_Parser_Count > 0 then
+ -- There was at least one error. We assume that
caused the ambiguous
+ -- parse, and we pick the parser with the minimum
cost and maximum
+ -- recover ops length to allow the parse to succeed.
We terminate the
+ -- other parsers so the remaining parser executes
actions. Among
+ -- equal costs, we pick the maximum recover ops
length because it's
+ -- probably due to Minimal_Complete_Actions finishing
a
+ -- statement/declaration.
+ --
+ -- If there are multiple errors, this metric is not
very meaningful.
+ --
+ -- Note all surviving parsers must have the same
error count.
+ Current_Parser := Shared_Parser.Parsers.First;
+ loop
+ Recover_Cost := Current_Parser.Min_Recover_Cost;
+ if Recover_Cost < Min_Recover_Cost then
+ Min_Recover_Cost := Recover_Cost;
+ Max_Recover_Ops_Length :=
Current_Parser.Max_Recover_Ops_Length;
+ Recover_Cur := Current_Parser;
+
+ elsif Recover_Cost = Min_Recover_Cost then
+ Recover_Ops_Length :=
Current_Parser.Max_Recover_Ops_Length;
+ if Recover_Ops_Length > Max_Recover_Ops_Length
then
+ Max_Recover_Ops_Length := Recover_Ops_Length;
+ Recover_Cur := Current_Parser;
+ end if;
+ end if;
+ Current_Parser.Next;
+ exit when Current_Parser.Is_Done;
+ end loop;
+
+ Current_Parser := Shared_Parser.Parsers.First;
+ loop
+ if Current_Parser = Recover_Cur then
+ Current_Parser.Next;
+ else
+ Temp := Current_Parser;
+ Current_Parser.Next;
+ Shared_Parser.Parsers.Terminate_Parser
+ (Temp, "recover cost/length",
Shared_Parser.Trace.all, Shared_Parser.Terminals);
+ end if;
+ exit when Current_Parser.Is_Done;
+ end loop;
+
+ exit Main_Loop;
+
+ else
+ -- There were no previous errors. We allow the parse
to fail, on the
+ -- assumption that an otherwise correct input should
not yield an
+ -- ambiguous parse.
+ declare
+ Token : Base_Token renames Shared_Parser.Terminals
(Shared_Parser.Terminals.Last_Index);
+ begin
+ raise WisiToken.Parse_Error with Error_Message
+ (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
+ "Ambiguous parse:" & SAL.Base_Peek_Type'Image
(Count) & " parsers active.");
+ end;
+ end if;
+ end;
+ end if;
+ end;
+
+ when Reduce =>
+ null;
+
+ when Error =>
+ -- All parsers errored; attempt recovery
+ declare
+ use all type McKenzie_Recover.Recover_Status;
+
+ Recover_Result : McKenzie_Recover.Recover_Status :=
McKenzie_Recover.Recover_Status'First;
+
+ Pre_Recover_Parser_Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
+ begin
+ -- Recover algorithms expect current token at
+ -- Parsers(*).Current_Token, will set
+ -- Parsers(*).Recover_Insert_Delete with new input tokens and
+ -- deletions, adjust Parsers(*).Stack, and set
+ -- Parsers(*).Current_Token and Parsers(*).Verb.
+
+ if Shared_Parser.Enable_McKenzie_Recover then
+ if Debug_Mode then
+ Trace.Put_Clock ("pre-recover" &
Shared_Parser.Parsers.Count'Img & " active");
+ end if;
+ Recover_Result := McKenzie_Recover.Recover (Shared_Parser);
+ if Debug_Mode then
+ Trace.Put_Clock ("post-recover" &
Shared_Parser.Parsers.Count'Img & " active");
+ end if;
+
+ if Trace_Parse > Outline then
+ if Recover_Result = Success then
+ Trace.Put_Line
+ ("recover: succeed, parser count" &
SAL.Base_Peek_Type'Image (Shared_Parser.Parsers.Count));
+ else
+ Trace.Put_Line
+ ("recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result) &
+ ", parser count" & SAL.Base_Peek_Type'Image
(Shared_Parser.Parsers.Count));
+ end if;
+ end if;
+
+ if Ada.Text_IO.Is_Open (Shared_Parser.Recover_Log_File) then
+ declare
+ use Ada.Text_IO;
+ Strategy_Counts : LR.Strategy_Counts := (others => 0);
+ begin
+ Put
+ (Shared_Parser.Recover_Log_File,
+ Ada.Calendar.Formatting.Image (Ada.Calendar.Clock)
& " " &
+ McKenzie_Recover.Recover_Status'Image
(Recover_Result) & " " &
+ SAL.Base_Peek_Type'Image
(Pre_Recover_Parser_Count) & " '" &
+ Shared_Parser.Lexer.File_Name & "'");
+
+ Put (Shared_Parser.Recover_Log_File, '(');
+ for Parser of Shared_Parser.Parsers loop
+ Accumulate (Parser.Recover, Strategy_Counts);
+ Put
+ (Shared_Parser.Recover_Log_File,
+ Integer'Image (Parser.Recover.Enqueue_Count) &
+ Integer'Image (Parser.Recover.Check_Count) & "
" &
+ Boolean'Image (Parser.Recover.Success));
+ end loop;
+ Put (Shared_Parser.Recover_Log_File, ')');
+
+ Put (Shared_Parser.Recover_Log_File, Image
(Strategy_Counts));
+ New_Line (Shared_Parser.Recover_Log_File);
+ Flush (Shared_Parser.Recover_Log_File);
+ end;
+ end if;
+ else
+ if Trace_Parse > Outline then
+ Trace.Put_Line ("recover disabled");
+ end if;
+ end if;
+
+ if Recover_Result = Success then
+ for Parser_State of Shared_Parser.Parsers loop
+ Parser_State.Resume_Active := True;
+ Parser_State.Conflict_During_Resume := False;
+
+ if Trace_Parse > Outline then
+ Trace.Put_Line
+ (Integer'Image (Parser_State.Label) & ":
Current_Token " &
+ Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) &
+ " Shared_Token " & Image
+ (Parser_State.Shared_Token,
Shared_Parser.Terminals, Trace.Descriptor.all));
+
+ if Trace_Parse > Detail then
+ Shared_Parser.Trace.Put_Line
+ (Integer'Image (Parser_State.Label) & ":
resume_active: True, token goal" &
+ WisiToken.Token_Index'Image
(Parser_State.Resume_Token_Goal));
+ end if;
+ end if;
+
+ Parser_State.Zombie_Token_Count := 0;
+
+ case Parser_State.Verb is
+ when Reduce =>
+ null;
+
+ when Error =>
+ -- Force this parser to be terminated.
+ if Shared_Parser.Enable_McKenzie_Recover then
+ Parser_State.Zombie_Token_Count :=
Shared_Parser.Table.McKenzie_Param.Check_Limit + 1;
+ end if;
+
+ when Shift =>
+ null;
+
+ when Pause | Accept_It =>
+ raise SAL.Programmer_Error;
+ end case;
+ end loop;
+
+ else
+ -- Terminate with error. Parser_State has all the required
info on
+ -- the original error (recorded by Error in Do_Action);
report reason
+ -- recover failed.
+ for Parser_State of Shared_Parser.Parsers loop
+ Parser_State.Errors.Append
+ ((Label => LR.Message,
+ First_Terminal => Trace.Descriptor.First_Terminal,
+ Last_Terminal => Trace.Descriptor.Last_Terminal,
+ Recover => <>,
+ Msg => +"recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result)));
+ end loop;
+ raise WisiToken.Syntax_Error;
+ end if;
+
+ -- Immediately execute Do_Action for Current_Token, since it
changed
+ -- in error recovery; this sets Parser.Verb. This replaces the
+ -- execution of Do_Action that resulted in Error.
+ Error_Recovered := True;
+
+ end;
+ end case;
+
+ -- We don't use 'for Parser_State of Parsers loop' here,
+ -- because terminate on error and spawn on conflict require
+ -- changing the parser list.
+ Current_Parser := Shared_Parser.Parsers.First;
+ Action_Loop :
+ loop
+ exit Action_Loop when Current_Parser.Is_Done;
+
+ -- We don't check duplicate state during resume, because the
tokens
+ -- inserted/deleted by error recover may cause initially duplicate
+ -- states to diverge.
+ if not Current_Parser.State_Ref.Resume_Active and
+ Shared_Parser.Terminate_Same_State and
+ Current_Verb = Shift and
+ (for all Parser of Shared_Parser.Parsers =>
Parser.Recover_Insert_Delete.Count = 0)
+ then
+ Shared_Parser.Parsers.Duplicate_State
+ (Current_Parser, Shared_Parser.Trace.all,
Shared_Parser.Terminals);
+ -- If Duplicate_State terminated Current_Parser,
Current_Parser now
+ -- points to the next parser. Otherwise it is unchanged.
+ end if;
+
+ exit Action_Loop when Current_Parser.Is_Done;
+
+ if Trace_Parse > Extra then
+ if Error_Recovered then
+ Trace.Put_Line (Integer'Image (Current_Parser.Label) &
".error_recovered");
+ else
+ Trace.Put_Line
+ ("current_verb: " & Parse_Action_Verbs'Image
(Current_Verb) &
+ "," & Integer'Image (Current_Parser.Label) &
+ ".verb: " & Parse_Action_Verbs'Image
(Current_Parser.Verb));
+ end if;
+ end if;
+
+ -- Each branch of the following 'if' calls either
Current_Parser.Free
+ -- (which advances to the next parser) or Current_Parser.Next.
+
+ if Current_Parser.Verb = Error then
+ -- This parser is a zombie; see Check_Error above.
+ --
+ -- Check to see if it is time to terminate it
+ if Shared_Parser.Enable_McKenzie_Recover and then
+ Current_Parser.State_Ref.Zombie_Token_Count <=
Shared_Parser.Table.McKenzie_Param.Check_Limit
+ then
+ if Trace_Parse > Detail then
+ Trace.Put_Line (Integer'Image (Current_Parser.Label) & ":
zombie");
+ end if;
+
+ Current_Parser.Next;
+ else
+ Shared_Parser.Parsers.Terminate_Parser
+ (Current_Parser, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
+ end if;
+
+ elsif Current_Parser.Verb = Current_Verb or Error_Recovered then
+
+ if Trace_Parse > Extra then
+ Parser_Lists.Put_Top_10 (Trace, Current_Parser);
+ end if;
+
+ declare
+ State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
+ begin
+ Action := Action_For
+ (Table => Shared_Parser.Table.all,
+ State => State.Stack.Peek.State,
+ ID => State.Tree.ID (State.Current_Token));
+ end;
+
+ declare
+ Conflict : Parse_Action_Node_Ptr := Action.Next;
+ begin
+ loop
+ exit when Conflict = null;
+ -- Spawn a new parser (before modifying Current_Parser
stack).
+
+ Current_Parser.State_Ref.Conflict_During_Resume :=
Current_Parser.State_Ref.Resume_Active;
+
+ if Shared_Parser.Parsers.Count =
Shared_Parser.Max_Parallel then
+ -- If errors were recovered, terminate a parser that
used the
+ -- highest cost solution.
+ declare
+ use all type WisiToken.Parse.LR.Parser_Lists.Cursor;
+ Max_Recover_Cost : Integer := 0;
+ Max_Parser : Parser_Lists.Cursor;
+ Cur : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
+ begin
+ loop
+ exit when Cur.Is_Done;
+ if Cur.Total_Recover_Cost > Max_Recover_Cost then
+ Max_Parser := Cur;
+ Max_Recover_Cost := Cur.Total_Recover_Cost;
+ end if;
+ Cur.Next;
+ end loop;
+
+ if Max_Recover_Cost > 0 then
+ if Max_Parser = Current_Parser then
+ Current_Parser.Next;
+ Shared_Parser.Parsers.Terminate_Parser
+ (Current_Parser, "too many parsers; max
error repair cost", Trace,
+ Shared_Parser.Terminals);
+ exit Action_Loop;
+ else
+ Shared_Parser.Parsers.Terminate_Parser
+ (Max_Parser, "too many parsers; max error
repair cost", Trace,
+ Shared_Parser.Terminals);
+ end if;
+ end if;
+ end;
+ end if;
+
+ if Shared_Parser.Parsers.Count =
Shared_Parser.Max_Parallel then
+ declare
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+ Token : Base_Token renames Shared_Parser.Terminals
(Parser_State.Shared_Token);
+ begin
+ raise WisiToken.Parse_Error with Error_Message
+ (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
+ "too many parallel parsers required in grammar
state" &
+ State_Index'Image
(Parser_State.Stack.Peek.State) &
+ "; simplify grammar, or increase max-parallel
(" &
+ SAL.Base_Peek_Type'Image
(Shared_Parser.Max_Parallel) & ")");
+ end;
+
+ else
+ if Trace_Parse > Outline then
+ declare
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+ begin
+ Trace.Put_Line
+ (Integer'Image (Current_Parser.Label) & ": " &
+ Trimmed_Image
(Parser_State.Stack.Peek.State) & ": " &
+ Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) & " : " &
+ "spawn" & Integer'Image
(Shared_Parser.Parsers.Last_Label + 1) & ", (" &
+ Trimmed_Image (1 + Integer
(Shared_Parser.Parsers.Count)) & " active)");
+ end;
+ end if;
+
+ Shared_Parser.Parsers.Prepend_Copy (Current_Parser);
+ Do_Action (Conflict.Item, Shared_Parser.Parsers.First,
Shared_Parser);
+
+ -- We must terminate error parsers immediately in
order to avoid
+ -- zombie parsers during recovery.
+ declare
+ Temp : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
+ begin
+ Check_Error (Temp);
+ end;
+ end if;
+
+ Conflict := Conflict.Next;
+ end loop;
+ end;
+ Do_Action (Action.Item, Current_Parser, Shared_Parser);
+ Check_Error (Current_Parser);
+
+ else
+ -- Current parser is waiting for others to catch up
+ Current_Parser.Next;
+ end if;
+ end loop Action_Loop;
+ Error_Recovered := False;
+ end loop Main_Loop;
+
+ if Trace_Parse > Outline then
+ Trace.Put_Line (Shared_Parser.Parsers.First.Label'Image & ":
succeed");
+ end if;
+
+ if Debug_Mode then
+ Trace.Put_Clock ("finish");
+ end if;
+
+ -- We don't raise Syntax_Error for lexer errors, since they are all
+ -- recovered, either by inserting a quote, or by ignoring the
+ -- character.
+ exception
+ when Syntax_Error | WisiToken.Parse_Error | Partial_Parse =>
+ if Debug_Mode then
+ Trace.Put_Clock ("finish - error");
+ end if;
+ raise;
+
+ when E : others =>
+ declare
+ Msg : constant String := Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E);
+ begin
+ if Shared_Parser.Parsers.Count > 0 then
+ -- Emacs displays errors in the *syntax-errors* buffer
+ Shared_Parser.Parsers.First_State_Ref.Errors.Append
+ ((Label => LR.Message,
+ First_Terminal => Trace.Descriptor.First_Terminal,
+ Last_Terminal => Trace.Descriptor.Last_Terminal,
+ Recover => <>,
+ Msg => +Msg));
+ end if;
+
+ if Debug_Mode then
+ Ada.Text_IO.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback
(E));
+ end if;
+
+ -- Emacs displays the exception message in the echo area; easy to
miss
+ raise WisiToken.Parse_Error with Msg;
+ end;
+ end Parse;
+
+ overriding function Tree (Shared_Parser : in Parser) return
Syntax_Trees.Tree
+ is
+ use all type SAL.Base_Peek_Type;
+ begin
+ if Shared_Parser.Parsers.Count > 1 then
+ raise WisiToken.Parse_Error with "ambigous parse";
+ else
+ return Shared_Parser.Parsers.First_State_Ref.Tree;
+ end if;
+ end Tree;
+
+ overriding
+ procedure Execute_Actions (Parser : in out LR.Parser.Parser)
+ is
+ use all type SAL.Base_Peek_Type;
+ use all type Syntax_Trees.User_Data_Access;
+ use all type WisiToken.Syntax_Trees.Semantic_Action;
+
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ procedure Process_Node
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Syntax_Trees.Valid_Node_Index)
+ is
+ use all type Syntax_Trees.Node_Label;
+ begin
+ if Tree.Label (Node) /= Nonterm then
+ return;
+ end if;
+
+ declare
+ Tree_Children : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Children (Node);
+ begin
+ Parser.User_Data.Reduce (Tree, Node, Tree_Children);
+ if Tree.Action (Node) /= null then
+ begin
+ Tree.Action (Node) (Parser.User_Data.all, Tree, Node,
Tree_Children);
+ exception
+ when E : others =>
+ declare
+ Token : Base_Token renames Parser.Terminals
(Tree.Min_Terminal_Index (Node));
+ begin
+ raise WisiToken.Parse_Error with Error_Message
+ (Parser.Lexer.File_Name, Token.Line, Token.Column,
+ "action raised exception " &
Ada.Exceptions.Exception_Name (E) & ": " &
+ Ada.Exceptions.Exception_Message (E));
+ end;
+ end;
+ end if;
+ end;
+ end Process_Node;
+
+ begin
+ if Parser.User_Data /= null then
+ if Parser.Parsers.Count > 1 then
+ raise Syntax_Error with "ambiguous parse; can't execute actions";
+ end if;
+
+ declare
+ Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_State_Ref.Element.all;
+ begin
+ if Trace_Action > Outline then
+ Parser.Trace.Put_Line
+ (Integer'Image (Parser_State.Label) & ": root node: " &
Parser_State.Tree.Image
+ (Parser_State.Tree.Root, Descriptor));
+ end if;
+
+ if (for some Err of Parser_State.Errors => Any (Err.Recover.Ops,
Delete)) then
+ for Err of Parser_State.Errors loop
+ for Op of Err.Recover.Ops loop
+ case Op.Op is
+ when Delete =>
+ Parser.User_Data.Delete_Token (Op.Del_Token_Index);
+ when others =>
+ null;
+ end case;
+ end loop;
+ end loop;
+ end if;
+
+ Parser.User_Data.Initialize_Actions (Parser_State.Tree);
+ Parser_State.Tree.Process_Tree (Process_Node'Access);
+ end;
+ end if;
+ end Execute_Actions;
+
+ overriding function Any_Errors (Parser : in LR.Parser.Parser) return Boolean
+ is
+ use all type SAL.Base_Peek_Type;
+ use all type Ada.Containers.Count_Type;
+ Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
+ begin
+ pragma Assert (Parser_State.Tree.Flushed);
+ return Parser.Parsers.Count > 1 or Parser_State.Errors.Length > 0 or
Parser.Lexer.Errors.Length > 0;
+ end Any_Errors;
+
+ overriding procedure Put_Errors (Parser : in LR.Parser.Parser)
+ is
+ use all type SAL.Base_Peek_Type;
+ use Ada.Text_IO;
+
+ Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+ begin
+ for Item of Parser.Lexer.Errors loop
+ Put_Line
+ (Current_Error,
+ Parser.Lexer.File_Name & ":0:0: lexer unrecognized character at" &
Buffer_Pos'Image (Item.Char_Pos));
+ end loop;
+
+ for Item of Parser_State.Errors loop
+ case Item.Label is
+ when Action =>
+ declare
+ Index : constant Base_Token_Index :=
Parser_State.Tree.Min_Terminal_Index (Item.Error_Token);
+ begin
+ if Index = Invalid_Token_Index then
+ -- Error_Token is virtual
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Parser.Lexer.File_Name, 1, 0,
+ "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
+ ", found " & Image (Parser_State.Tree.ID
(Item.Error_Token), Descriptor)));
+ else
+ declare
+ Token : Base_Token renames Parser.Terminals (Index);
+ begin
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Parser.Lexer.File_Name, Token.Line, Token.Column,
+ "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
+ ", found '" & Parser.Lexer.Buffer_Text
(Token.Byte_Region) & "'"));
+ end;
+ end if;
+ end;
+ when Check =>
+ Put_Line
+ (Current_Error,
+ Parser.Lexer.File_Name & ":0:0: semantic check error: " &
+ Semantic_Checks.Image (Item.Check_Status, Descriptor));
+ when Message =>
+ Put_Line (Current_Error, -Item.Msg);
+ end case;
+
+ if Item.Recover.Stack.Depth /= 0 then
+ Put_Line (Current_Error, " recovered: " & Image
(Item.Recover.Ops, Descriptor));
+ end if;
+ end loop;
+ end Put_Errors;
+
+end WisiToken.Parse.LR.Parser;
diff --git a/wisitoken-parse-lr-parser.ads b/wisitoken-parse-lr-parser.ads
index 3324165..a88e3af 100644
--- a/wisitoken-parse-lr-parser.ads
+++ b/wisitoken-parse-lr-parser.ads
@@ -53,19 +53,21 @@ package WisiToken.Parse.LR.Parser is
-- For an Error action, Config.Error_Token gives the terminal that
-- caused the error.
- type Language_Use_Minimal_Complete_Actions_Access is access procedure
- (Current_Token : in Token_ID;
- Next_Token : in Token_ID;
- Config : in Configuration;
- Use_Complete : out Boolean;
- Matching_Begin_Token : out Token_ID);
- -- Set Use_Complete True if using Minimal_Complete_Actions is
- -- appropriate. Set Matching_Begin_Token to token that starts a production
- -- matching Next_Token (and following tokens, if any).
+ type Language_Matching_Begin_Tokens_Access is access procedure
+ (Tokens : in Token_ID_Array_1_3;
+ Config : in Configuration;
+ Matching_Tokens : out Token_ID_Arrays.Vector;
+ Forbid_Minimal_Complete : out Boolean);
+ -- Tokens (1) caused a parse error; Tokens (2 .. 3) are the following
+ -- tokens (Invalid_Token_ID if none). Set Matching_Tokens to a token
+ -- sequence that starts a production matching Tokens. If
+ -- Minimal_Complete would produce a bad solution at this error point,
+ -- set Forbid_Minimal_Complete True.
--
- -- For example, if Next_Token is a block end, return True to complete
- -- the current statement/declaration as quickly as possible, and
- -- Matching_Begin_Token to the corresponding block begin.
+ -- For example, if Tokens is a block end, return tokens that are the
+ -- corresponding block begin. If the error point is inside a
+ -- multi-token 'end' (ie 'end if;', or 'end <name>;'), set
+ -- Forbid_Minimal_Complete True.
type Language_String_ID_Set_Access is access function
(Descriptor : in WisiToken.Descriptor;
@@ -73,14 +75,14 @@ package WisiToken.Parse.LR.Parser is
return Token_ID_Set;
-- Return a Token_ID_Set containing String_Literal_ID and
-- nonterminals that can contain String_Literal_ID as part of an
- -- expression.
+ -- expression. Used in placing a missing string quote.
type Post_Recover_Access is access procedure;
type Parser is new WisiToken.Parse.Base_Parser with record
Table : Parse_Table_Ptr;
Language_Fixes : Language_Fixes_Access;
- Language_Use_Minimal_Complete_Actions :
Language_Use_Minimal_Complete_Actions_Access;
+ Language_Matching_Begin_Tokens : Language_Matching_Begin_Tokens_Access;
Language_String_ID_Set : Language_String_ID_Set_Access;
String_Quote_Checked : Line_Number_Type := Invalid_Line_Number;
@@ -113,16 +115,16 @@ package WisiToken.Parse.LR.Parser is
-- Deep free Object.Table.
procedure New_Parser
- (Parser : out LR.Parser.Parser;
- Trace : not null access
WisiToken.Trace'Class;
- Lexer : in
WisiToken.Lexer.Handle;
- Table : in Parse_Table_Ptr;
- Language_Fixes : in
Language_Fixes_Access;
- Language_Use_Minimal_Complete_Actions : in
Language_Use_Minimal_Complete_Actions_Access;
- Language_String_ID_Set : in
Language_String_ID_Set_Access;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
- Max_Parallel : in
SAL.Base_Peek_Type := Default_Max_Parallel;
- Terminate_Same_State : in Boolean
:= True);
+ (Parser : out LR.Parser.Parser;
+ Trace : not null access WisiToken.Trace'Class;
+ Lexer : in WisiToken.Lexer.Handle;
+ Table : in Parse_Table_Ptr;
+ Language_Fixes : in Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
Language_String_ID_Set_Access;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
+ Max_Parallel : in SAL.Base_Peek_Type :=
Default_Max_Parallel;
+ Terminate_Same_State : in Boolean :=
True);
overriding procedure Parse (Shared_Parser : aliased in out
LR.Parser.Parser);
-- Attempt a parse. Calls Parser.Lexer.Reset, runs lexer to end of
diff --git a/wisitoken-parse-lr-parser_lists.adb
b/wisitoken-parse-lr-parser_lists.adb
index 590af07..e2a0918 100644
--- a/wisitoken-parse-lr-parser_lists.adb
+++ b/wisitoken-parse-lr-parser_lists.adb
@@ -27,7 +27,6 @@ package body WisiToken.Parse.LR.Parser_Lists is
Depth : in SAL.Base_Peek_Type := 0)
return String
is
- use all type Syntax_Trees.Node_Index;
use all type SAL.Base_Peek_Type;
use Ada.Strings.Unbounded;
@@ -40,6 +39,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
begin
for I in 1 .. Last loop
declare
+ use all type WisiToken.Syntax_Trees.Node_Index;
Item : Parser_Stack_Item renames Stack.Peek (I);
begin
Result := Result &
@@ -131,6 +131,19 @@ package body WisiToken.Parse.LR.Parser_Lists is
return Result;
end Max_Recover_Ops_Length;
+ function Min_Recover_Cost (Cursor : in Parser_Lists.Cursor) return Integer
+ is
+ Result : Integer := Integer'Last;
+ Errors : Parse_Error_Lists.List renames
Parser_State_Lists.Constant_Reference (Cursor.Ptr).Errors;
+ begin
+ for Error of Errors loop
+ if Error.Recover.Cost < Result then
+ Result := Error.Recover.Cost;
+ end if;
+ end loop;
+ return Result;
+ end Min_Recover_Cost;
+
procedure Set_Verb (Cursor : in Parser_Lists.Cursor; Verb : in
All_Parse_Action_Verbs)
is begin
Parser_State_Lists.Reference (Cursor.Ptr).Verb := Verb;
@@ -292,7 +305,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
-- We specify all items individually, rather copy Item and then
-- override a few, to avoid copying large items like Recover.
- -- We copy Recover.Enqueue_Count, .Check_Count for unit tests.
+ -- We copy Recover.Enqueue_Count .. Check_Count for unit tests.
New_Item :=
(Shared_Token => Item.Shared_Token,
Recover_Insert_Delete => Item.Recover_Insert_Delete,
@@ -303,6 +316,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
Tree => Item.Tree,
Recover =>
(Enqueue_Count => Item.Recover.Enqueue_Count,
+ Config_Full_Count => Item.Recover.Config_Full_Count,
Check_Count => Item.Recover.Check_Count,
others => <>),
Resume_Active => Item.Resume_Active,
diff --git a/wisitoken-parse-lr-parser_lists.ads
b/wisitoken-parse-lr-parser_lists.ads
index 0dae578..a5af546 100644
--- a/wisitoken-parse-lr-parser_lists.ads
+++ b/wisitoken-parse-lr-parser_lists.ads
@@ -131,6 +131,7 @@ package WisiToken.Parse.LR.Parser_Lists is
function Label (Cursor : in Parser_Lists.Cursor) return Natural;
function Total_Recover_Cost (Cursor : in Parser_Lists.Cursor) return
Integer;
function Max_Recover_Ops_Length (Cursor : in Parser_Lists.Cursor) return
Ada.Containers.Count_Type;
+ function Min_Recover_Cost (Cursor : in Parser_Lists.Cursor) return Integer;
procedure Set_Verb (Cursor : in Parser_Lists.Cursor; Verb : in
All_Parse_Action_Verbs);
function Verb (Cursor : in Parser_Lists.Cursor) return
All_Parse_Action_Verbs;
diff --git a/wisitoken-parse-lr-parser_no_recover.adb
b/wisitoken-parse-lr-parser_no_recover.adb
index d8ce31e..67371f1 100644
--- a/wisitoken-parse-lr-parser_no_recover.adb
+++ b/wisitoken-parse-lr-parser_no_recover.adb
@@ -1,511 +1,549 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Parse.LR.Parser_No_Recover is
-
- procedure Reduce_Stack_1
- (Current_Parser : in Parser_Lists.Cursor;
- Action : in Reduce_Action_Rec;
- Nonterm : out WisiToken.Syntax_Trees.Valid_Node_Index;
- Trace : in out WisiToken.Trace'Class)
- is
- use all type SAL.Base_Peek_Type;
-
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
- Children_Tree : Syntax_Trees.Valid_Node_Index_Array (1 ..
SAL.Base_Peek_Type (Action.Token_Count));
- -- for Set_Children.
- begin
- for I in reverse Children_Tree'Range loop
- Children_Tree (I) := Parser_State.Stack.Pop.Token;
- end loop;
-
- Nonterm := Parser_State.Tree.Add_Nonterm
- (Action.Production, Children_Tree, Action.Action, Default_Virtual =>
False);
- -- Computes Nonterm.Byte_Region
-
- if Trace_Parse > Detail then
- Trace.Put_Line (Parser_State.Tree.Image (Nonterm,
Trace.Descriptor.all, Include_Children => True));
- end if;
- end Reduce_Stack_1;
-
- procedure Do_Action
- (Action : in Parse_Action_Rec;
- Current_Parser : in Parser_Lists.Cursor;
- Shared_Parser : in Parser)
- is
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
- Nonterm : WisiToken.Syntax_Trees.Valid_Node_Index;
- begin
- if Trace_Parse > Detail then
- Trace.Put
- (Integer'Image (Current_Parser.Label) & ": " &
- Trimmed_Image (Parser_State.Stack.Peek.State) & ": " &
- Parser_State.Tree.Image (Parser_State.Current_Token,
Trace.Descriptor.all) & " : ");
- Put (Trace, Action);
- Trace.New_Line;
- end if;
-
- case Action.Verb is
- when Shift =>
- Current_Parser.Set_Verb (Shift);
- Parser_State.Stack.Push ((Action.State, Parser_State.Current_Token));
- Parser_State.Tree.Set_State (Parser_State.Current_Token,
Action.State);
-
- when Reduce =>
- Current_Parser.Set_Verb (Reduce);
-
- Reduce_Stack_1 (Current_Parser, Action, Nonterm, Trace);
-
- Parser_State.Stack.Push
- ((State => Goto_For
- (Table => Shared_Parser.Table.all,
- State => Parser_State.Stack (1).State,
- ID => Action.Production.LHS),
- Token => Nonterm));
-
- Parser_State.Tree.Set_State (Nonterm, Parser_State.Stack (1).State);
-
- if Trace_Parse > Detail then
- Trace.Put_Line (" ... goto state " & Trimmed_Image
(Parser_State.Stack.Peek.State));
- end if;
-
- when Accept_It =>
- Current_Parser.Set_Verb (Accept_It);
- Reduce_Stack_1
- (Current_Parser,
- (Reduce, Action.Production, Action.Action, Action.Check,
Action.Token_Count),
- Nonterm, Trace);
-
- Parser_State.Tree.Set_Root (Nonterm);
-
- when Error =>
- Current_Parser.Set_Verb (Action.Verb);
-
- -- We don't raise Syntax_Error here; another parser may be able to
- -- continue.
-
- declare
- Expecting : constant Token_ID_Set := LR.Expecting
- (Shared_Parser.Table.all,
Current_Parser.State_Ref.Stack.Peek.State);
- begin
- Parser_State.Errors.Append
- ((Label => LR.Action,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Error_Token => Parser_State.Current_Token,
- Expecting => Expecting,
- Recover => (others => <>)));
-
- if Trace_Parse > Outline then
- Put
- (Trace,
- Integer'Image (Current_Parser.Label) & ": expecting: " &
- Image (Expecting, Trace.Descriptor.all));
- Trace.New_Line;
- end if;
- end;
- end case;
- end Do_Action;
-
- -- Return the type of parser cycle to execute.
- --
- -- Accept : all Parsers.Verb return Accept - done parsing.
- --
- -- Shift : some Parsers.Verb return Shift.
- --
- -- Reduce : some Parsers.Verb return Reduce.
- --
- -- Error : all Parsers.Verb return Error.
- procedure Parse_Verb
- (Shared_Parser : in out Parser;
- Verb : out All_Parse_Action_Verbs)
- is
- use all type SAL.Base_Peek_Type;
-
- Shift_Count : SAL.Base_Peek_Type := 0;
- Accept_Count : SAL.Base_Peek_Type := 0;
- Error_Count : SAL.Base_Peek_Type := 0;
- begin
- for Parser_State of Shared_Parser.Parsers loop
- case Parser_State.Verb is
- when Shift =>
- Shift_Count := Shift_Count + 1;
-
- when Reduce =>
- Verb := Reduce;
- return;
-
- when Accept_It =>
- Accept_Count := Accept_Count + 1;
-
- when Error =>
- Error_Count := Error_Count + 1;
-
- when Pause =>
- -- This is parser_no_recover
- raise SAL.Programmer_Error;
- end case;
- end loop;
-
- if Shared_Parser.Parsers.Count = Accept_Count then
- Verb := Accept_It;
-
- elsif Shared_Parser.Parsers.Count = Error_Count then
- Verb := Error;
-
- elsif Shift_Count > 0 then
- Verb := Shift;
-
- else
- raise SAL.Programmer_Error;
- end if;
- end Parse_Verb;
-
- ----------
- -- Public subprograms, declaration order
-
- overriding procedure Finalize (Object : in out Parser)
- is begin
- Free_Table (Object.Table);
- end Finalize;
-
- procedure New_Parser
- (Parser : out LR.Parser_No_Recover.Parser;
- Trace : not null access WisiToken.Trace'Class;
- Lexer : in WisiToken.Lexer.Handle;
- Table : in Parse_Table_Ptr;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
- Max_Parallel : in SAL.Base_Peek_Type :=
Default_Max_Parallel;
- First_Parser_Label : in Integer := 1;
- Terminate_Same_State : in Boolean := True)
- is
- use all type Syntax_Trees.User_Data_Access;
- begin
- Parser.Lexer := Lexer;
- Parser.Trace := Trace;
- Parser.Table := Table;
- Parser.User_Data := User_Data;
- Parser.Max_Parallel := Max_Parallel;
- Parser.First_Parser_Label := First_Parser_Label;
- Parser.Terminate_Same_State := Terminate_Same_State;
-
- if User_Data /= null then
- User_Data.Set_Lexer_Terminals (Lexer,
Parser.Terminals'Unchecked_Access);
- end if;
- end New_Parser;
-
- overriding procedure Parse (Shared_Parser : aliased in out Parser)
- is
- use all type Syntax_Trees.User_Data_Access;
- use all type SAL.Base_Peek_Type;
-
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
-
- Current_Verb : All_Parse_Action_Verbs;
- Current_Parser : Parser_Lists.Cursor;
- Action : Parse_Action_Node_Ptr;
-
- procedure Check_Error (Check_Parser : in out Parser_Lists.Cursor)
- is begin
- if Check_Parser.Verb = Error then
- -- This parser errored on last input. This is how grammar
conflicts
- -- are resolved when the input text is valid, so we terminate this
- -- parser.
-
- if Shared_Parser.Parsers.Count = 1 then
- raise Syntax_Error;
- else
- Shared_Parser.Parsers.Terminate_Parser
- (Check_Parser, "", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end if;
- else
- Check_Parser.Next;
- end if;
- end Check_Error;
-
- begin
- if Shared_Parser.User_Data /= null then
- Shared_Parser.User_Data.Reset;
- end if;
-
- Shared_Parser.Lex_All;
-
- Shared_Parser.Shared_Tree.Clear;
-
- Shared_Parser.Parsers := Parser_Lists.New_List
- (Shared_Tree => Shared_Parser.Shared_Tree'Unchecked_Access);
-
- Shared_Parser.Parsers.First.State_Ref.Stack.Push
((Shared_Parser.Table.State_First, others => <>));
-
- Main_Loop :
- loop
- -- exit on Accept_It action or syntax error.
-
- Parse_Verb (Shared_Parser, Current_Verb);
-
- case Current_Verb is
- when Shift =>
- -- All parsers just shifted a token; get the next token
-
- for Parser_State of Shared_Parser.Parsers loop
- Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
- Parser_State.Current_Token := Parser_State.Tree.Add_Terminal
- (Parser_State.Shared_Token, Shared_Parser.Terminals);
- end loop;
-
- when Accept_It =>
- -- All parsers accepted.
- declare
- Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
- begin
- if Count = 1 then
- -- Nothing more to do
- if Trace_Parse > Outline then
- Trace.Put_Line (Integer'Image
(Shared_Parser.Parsers.First.Label) & ": succeed");
- end if;
- exit Main_Loop;
-
- else
- -- More than one parser is active; ambiguous parse.
- declare
- Token : Base_Token renames Shared_Parser.Terminals
(Shared_Parser.Terminals.Last_Index);
- begin
- raise WisiToken.Parse_Error with Error_Message
- (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
- "Ambiguous parse:" & SAL.Base_Peek_Type'Image (Count)
& " parsers active.");
- end;
- end if;
- end;
-
- when Reduce =>
- null;
-
- when Error =>
- -- All parsers errored; terminate with error. Semantic_State has
all
- -- the required info (recorded by Error in Do_Action), so we just
- -- raise the exception.
- raise Syntax_Error;
-
- when Pause =>
- -- This is parser_no_recover
- raise SAL.Programmer_Error;
- end case;
-
- -- We don't use 'for Parser_State of Parsers loop' here,
- -- because terminate on error and spawn on conflict require
- -- changing the parser list.
- Current_Parser := Shared_Parser.Parsers.First;
- loop
- exit when Current_Parser.Is_Done;
-
- if Shared_Parser.Terminate_Same_State and
- Current_Verb = Shift
- then
- Shared_Parser.Parsers.Duplicate_State
- (Current_Parser, Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- -- If Duplicate_State terminated Current_Parser,
Current_Parser now
- -- points to the next parser. Otherwise it is unchanged.
- end if;
-
- exit when Current_Parser.Is_Done;
-
- if Trace_Parse > Extra then
- Trace.Put_Line
- ("current_verb: " & Parse_Action_Verbs'Image (Current_Verb) &
- "," & Integer'Image (Current_Parser.Label) &
- ".verb: " & Parse_Action_Verbs'Image
(Current_Parser.Verb));
- end if;
-
- -- Each branch of the following 'if' calls either
Current_Parser.Free
- -- (which advances to the next parser) or Current_Parser.Next.
-
- if Current_Parser.Verb = Current_Verb then
- if Trace_Parse > Extra then
- Parser_Lists.Put_Top_10 (Trace, Current_Parser);
- end if;
-
- declare
- State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
- begin
- Action := Action_For
- (Table => Shared_Parser.Table.all,
- State => State.Stack.Peek.State,
- ID => State.Tree.ID (State.Current_Token));
- end;
-
- if Action.Next /= null then
- -- Conflict; spawn a new parser (before modifying
Current_Parser
- -- stack).
-
- if Shared_Parser.Parsers.Count = Shared_Parser.Max_Parallel
then
- declare
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
- Token : Base_Token renames Shared_Parser.Terminals
(Parser_State.Shared_Token);
- begin
- raise WisiToken.Parse_Error with Error_Message
- (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
- ": too many parallel parsers required in grammar
state" &
- State_Index'Image (Parser_State.Stack.Peek.State)
&
- "; simplify grammar, or increase max-parallel (" &
- SAL.Base_Peek_Type'Image
(Shared_Parser.Max_Parallel) & ")");
- end;
- else
- if Trace_Parse > Outline then
- Trace.Put_Line
- ("spawn parser from " & Trimmed_Image
(Current_Parser.Label) &
- " (" & Trimmed_Image (1 + Integer
(Shared_Parser.Parsers.Count)) & " active)");
- end if;
-
- Shared_Parser.Parsers.Prepend_Copy (Current_Parser);
- Do_Action (Action.Next.Item, Shared_Parser.Parsers.First,
Shared_Parser);
-
- declare
- Temp : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
- begin
- Check_Error (Temp);
- end;
- end if;
- end if;
-
- Do_Action (Action.Item, Current_Parser, Shared_Parser);
- Check_Error (Current_Parser);
-
- else
- -- Current parser is waiting for others to catch up
- Current_Parser.Next;
- end if;
- end loop;
- end loop Main_Loop;
-
- -- We don't raise Syntax_Error for lexer errors, since they are all
- -- recovered, either by inserting a quote, or by ignoring the
- -- character.
- end Parse;
-
- overriding procedure Execute_Actions (Parser : in out
LR.Parser_No_Recover.Parser)
- is
- use all type SAL.Base_Peek_Type;
- use all type Syntax_Trees.User_Data_Access;
-
- procedure Process_Node
- (Tree : in out Syntax_Trees.Tree;
- Node : in Syntax_Trees.Valid_Node_Index)
- is
- use all type Syntax_Trees.Node_Label;
- begin
- if Tree.Label (Node) /= Nonterm then
- return;
- end if;
-
- declare
- use all type Syntax_Trees.Semantic_Action;
- Tree_Children : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Children (Node);
- begin
- Parser.User_Data.Reduce (Tree, Node, Tree_Children);
-
- if Tree.Action (Node) /= null then
- Tree.Action (Node) (Parser.User_Data.all, Tree, Node,
Tree_Children);
- end if;
- end;
- end Process_Node;
-
- begin
- if Parser.User_Data /= null then
- if Parser.Parsers.Count > 1 then
- raise Syntax_Error with "ambiguous parse; can't execute actions";
- end if;
-
- declare
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_State_Ref.Element.all;
- begin
- Parser_State.Tree.Process_Tree (Process_Node'Access);
- end;
- end if;
- end Execute_Actions;
-
- overriding function Tree (Parser : in LR.Parser_No_Recover.Parser) return
Syntax_Trees.Tree
- is
- use all type SAL.Base_Peek_Type;
- begin
- if Parser.Parsers.Count > 1 then
- raise WisiToken.Parse_Error with "ambigous parse";
- else
- return Parser.Parsers.First_State_Ref.Tree;
- end if;
- end Tree;
-
- overriding function Any_Errors (Parser : in LR.Parser_No_Recover.Parser)
return Boolean
- is
- use all type SAL.Base_Peek_Type;
- use all type Ada.Containers.Count_Type;
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
- begin
- pragma Assert (Parser_State.Tree.Flushed);
- return Parser.Parsers.Count > 1 or Parser_State.Errors.Length > 0 or
Parser.Lexer.Errors.Length > 0;
- end Any_Errors;
-
- overriding procedure Put_Errors (Parser : in LR.Parser_No_Recover.Parser)
- is
- use Ada.Text_IO;
-
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
- begin
- for Item of Parser.Lexer.Errors loop
- Put_Line
- (Current_Error,
- Parser.Lexer.File_Name & ":0:0: lexer unrecognized character at" &
Buffer_Pos'Image (Item.Char_Pos));
- end loop;
-
- for Item of Parser_State.Errors loop
- case Item.Label is
- when Action =>
- declare
- Token : Base_Token renames Parser.Terminals
(Parser_State.Tree.Min_Terminal_Index (Item.Error_Token));
- begin
- Put_Line
- (Current_Error,
- Error_Message
- (Parser.Lexer.File_Name, Token.Line, Token.Column,
- "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
- ", found '" & Parser.Lexer.Buffer_Text
(Token.Byte_Region) & "'"));
- end;
-
- when Check =>
- null;
-
- when Message =>
- Put_Line (Current_Error, -Item.Msg);
- end case;
-
- end loop;
- end Put_Errors;
-
-end WisiToken.Parse.LR.Parser_No_Recover;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Exceptions;
+package body WisiToken.Parse.LR.Parser_No_Recover is
+
+ procedure Reduce_Stack_1
+ (Current_Parser : in Parser_Lists.Cursor;
+ Action : in Reduce_Action_Rec;
+ Nonterm : out WisiToken.Syntax_Trees.Valid_Node_Index;
+ Trace : in out WisiToken.Trace'Class)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
+ Children_Tree : Syntax_Trees.Valid_Node_Index_Array (1 ..
SAL.Base_Peek_Type (Action.Token_Count));
+ -- for Set_Children.
+ begin
+ for I in reverse Children_Tree'Range loop
+ Children_Tree (I) := Parser_State.Stack.Pop.Token;
+ end loop;
+
+ Nonterm := Parser_State.Tree.Add_Nonterm
+ (Action.Production, Children_Tree, Action.Action, Default_Virtual =>
False);
+ -- Computes Nonterm.Byte_Region
+
+ if Trace_Parse > Detail then
+ Trace.Put_Line (Parser_State.Tree.Image (Nonterm,
Trace.Descriptor.all, Include_Children => True));
+ end if;
+ end Reduce_Stack_1;
+
+ procedure Do_Action
+ (Action : in Parse_Action_Rec;
+ Current_Parser : in Parser_Lists.Cursor;
+ Shared_Parser : in Parser)
+ is
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+ Nonterm : WisiToken.Syntax_Trees.Valid_Node_Index;
+ begin
+ if Trace_Parse > Detail then
+ Trace.Put
+ (Integer'Image (Current_Parser.Label) & ": " &
+ Trimmed_Image (Parser_State.Stack.Peek.State) & ": " &
+ Parser_State.Tree.Image (Parser_State.Current_Token,
Trace.Descriptor.all) & " : ");
+ Put (Trace, Action);
+ Trace.New_Line;
+ end if;
+
+ case Action.Verb is
+ when Shift =>
+ Current_Parser.Set_Verb (Shift);
+ Parser_State.Stack.Push ((Action.State, Parser_State.Current_Token));
+ Parser_State.Tree.Set_State (Parser_State.Current_Token,
Action.State);
+
+ when Reduce =>
+ Current_Parser.Set_Verb (Reduce);
+
+ declare
+ use all type SAL.Base_Peek_Type;
+
+ New_State : constant Unknown_State_Index := Goto_For
+ (Table => Shared_Parser.Table.all,
+ State => Parser_State.Stack (SAL.Base_Peek_Type
(Action.Token_Count) + 1).State,
+ ID => Action.Production.LHS);
+ begin
+ if New_State = Unknown_State then
+ -- This is due to a bug in the LALR parser generator (see
+ -- lalr_generator_bug_01.wy); we treat it as a syntax error.
+ Current_Parser.Set_Verb (Error);
+ if Trace_Parse > Detail then
+ Trace.Put_Line (" ... error");
+ end if;
+ else
+ Reduce_Stack_1 (Current_Parser, Action, Nonterm, Trace);
+ Parser_State.Stack.Push ((New_State, Nonterm));
+ Parser_State.Tree.Set_State (Nonterm, New_State);
+
+ if Trace_Parse > Detail then
+ Trace.Put_Line (" ... goto state " & Trimmed_Image
(New_State));
+ end if;
+ end if;
+ end;
+
+ when Accept_It =>
+ Current_Parser.Set_Verb (Accept_It);
+ Reduce_Stack_1
+ (Current_Parser,
+ (Reduce, Action.Production, Action.Action, Action.Check,
Action.Token_Count),
+ Nonterm, Trace);
+
+ Parser_State.Tree.Set_Root (Nonterm);
+
+ when Error =>
+ Current_Parser.Set_Verb (Action.Verb);
+
+ -- We don't raise Syntax_Error here; another parser may be able to
+ -- continue.
+
+ declare
+ Expecting : constant Token_ID_Set := LR.Expecting
+ (Shared_Parser.Table.all,
Current_Parser.State_Ref.Stack.Peek.State);
+ begin
+ Parser_State.Errors.Append
+ ((Label => LR.Action,
+ First_Terminal => Trace.Descriptor.First_Terminal,
+ Last_Terminal => Trace.Descriptor.Last_Terminal,
+ Error_Token => Parser_State.Current_Token,
+ Expecting => Expecting,
+ Recover => (others => <>)));
+
+ if Trace_Parse > Outline then
+ Put
+ (Trace,
+ Integer'Image (Current_Parser.Label) & ": expecting: " &
+ Image (Expecting, Trace.Descriptor.all));
+ Trace.New_Line;
+ end if;
+ end;
+ end case;
+ end Do_Action;
+
+ -- Return the type of parser cycle to execute.
+ --
+ -- Accept : all Parsers.Verb return Accept - done parsing.
+ --
+ -- Shift : some Parsers.Verb return Shift.
+ --
+ -- Reduce : some Parsers.Verb return Reduce.
+ --
+ -- Error : all Parsers.Verb return Error.
+ procedure Parse_Verb
+ (Shared_Parser : in out Parser;
+ Verb : out All_Parse_Action_Verbs)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ Shift_Count : SAL.Base_Peek_Type := 0;
+ Accept_Count : SAL.Base_Peek_Type := 0;
+ Error_Count : SAL.Base_Peek_Type := 0;
+ begin
+ for Parser_State of Shared_Parser.Parsers loop
+ case Parser_State.Verb is
+ when Shift =>
+ Shift_Count := Shift_Count + 1;
+
+ when Reduce =>
+ Verb := Reduce;
+ return;
+
+ when Accept_It =>
+ Accept_Count := Accept_Count + 1;
+
+ when Error =>
+ Error_Count := Error_Count + 1;
+
+ when Pause =>
+ -- This is parser_no_recover
+ raise SAL.Programmer_Error;
+ end case;
+ end loop;
+
+ if Shared_Parser.Parsers.Count = Accept_Count then
+ Verb := Accept_It;
+
+ elsif Shared_Parser.Parsers.Count = Error_Count then
+ Verb := Error;
+
+ elsif Shift_Count > 0 then
+ Verb := Shift;
+
+ else
+ raise SAL.Programmer_Error;
+ end if;
+ end Parse_Verb;
+
+ ----------
+ -- Public subprograms, declaration order
+
+ overriding procedure Finalize (Object : in out Parser)
+ is begin
+ Free_Table (Object.Table);
+ end Finalize;
+
+ procedure New_Parser
+ (Parser : out LR.Parser_No_Recover.Parser;
+ Trace : not null access WisiToken.Trace'Class;
+ Lexer : in WisiToken.Lexer.Handle;
+ Table : in Parse_Table_Ptr;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
+ Max_Parallel : in SAL.Base_Peek_Type :=
Default_Max_Parallel;
+ First_Parser_Label : in Integer := 1;
+ Terminate_Same_State : in Boolean := True)
+ is
+ use all type Syntax_Trees.User_Data_Access;
+ begin
+ Parser.Lexer := Lexer;
+ Parser.Trace := Trace;
+ Parser.Table := Table;
+ Parser.User_Data := User_Data;
+ Parser.Max_Parallel := Max_Parallel;
+ Parser.First_Parser_Label := First_Parser_Label;
+ Parser.Terminate_Same_State := Terminate_Same_State;
+
+ if User_Data /= null then
+ User_Data.Set_Lexer_Terminals (Lexer,
Parser.Terminals'Unchecked_Access);
+ end if;
+ end New_Parser;
+
+ overriding procedure Parse (Shared_Parser : aliased in out Parser)
+ is
+ use all type Syntax_Trees.User_Data_Access;
+ use all type SAL.Base_Peek_Type;
+
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+
+ Current_Verb : All_Parse_Action_Verbs;
+ Current_Parser : Parser_Lists.Cursor;
+ Action : Parse_Action_Node_Ptr;
+
+ procedure Check_Error (Check_Parser : in out Parser_Lists.Cursor)
+ is begin
+ if Check_Parser.Verb = Error then
+ -- This parser errored on last input. This is how grammar
conflicts
+ -- are resolved when the input text is valid, so we terminate this
+ -- parser.
+
+ if Shared_Parser.Parsers.Count = 1 then
+ raise Syntax_Error;
+ else
+ Shared_Parser.Parsers.Terminate_Parser
+ (Check_Parser, "", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
+ end if;
+ else
+ Check_Parser.Next;
+ end if;
+ end Check_Error;
+
+ begin
+ if Shared_Parser.User_Data /= null then
+ Shared_Parser.User_Data.Reset;
+ end if;
+
+ Shared_Parser.Lex_All;
+
+ Shared_Parser.Shared_Tree.Clear;
+
+ Shared_Parser.Parsers := Parser_Lists.New_List
+ (Shared_Tree => Shared_Parser.Shared_Tree'Unchecked_Access);
+
+ Shared_Parser.Parsers.First.State_Ref.Stack.Push
((Shared_Parser.Table.State_First, others => <>));
+
+ Main_Loop :
+ loop
+ -- exit on Accept_It action or syntax error.
+
+ Parse_Verb (Shared_Parser, Current_Verb);
+
+ case Current_Verb is
+ when Shift =>
+ -- All parsers just shifted a token; get the next token
+
+ for Parser_State of Shared_Parser.Parsers loop
+ Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
+ Parser_State.Current_Token := Parser_State.Tree.Add_Terminal
+ (Parser_State.Shared_Token, Shared_Parser.Terminals);
+ end loop;
+
+ when Accept_It =>
+ -- All parsers accepted.
+ declare
+ Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
+ begin
+ if Count = 1 then
+ -- Nothing more to do
+ if Trace_Parse > Outline then
+ Trace.Put_Line (Integer'Image
(Shared_Parser.Parsers.First.Label) & ": succeed");
+ end if;
+ exit Main_Loop;
+
+ else
+ -- More than one parser is active; ambiguous parse.
+ declare
+ Token : Base_Token renames Shared_Parser.Terminals
(Shared_Parser.Terminals.Last_Index);
+ begin
+ raise WisiToken.Parse_Error with Error_Message
+ (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
+ "Ambiguous parse:" & SAL.Base_Peek_Type'Image (Count)
& " parsers active.");
+ end;
+ end if;
+ end;
+
+ when Reduce =>
+ null;
+
+ when Error =>
+ -- All parsers errored; terminate with error. Semantic_State has
all
+ -- the required info (recorded by Error in Do_Action), so we just
+ -- raise the exception.
+ raise Syntax_Error;
+
+ when Pause =>
+ -- This is parser_no_recover
+ raise SAL.Programmer_Error;
+ end case;
+
+ -- We don't use 'for Parser_State of Parsers loop' here,
+ -- because terminate on error and spawn on conflict require
+ -- changing the parser list.
+ Current_Parser := Shared_Parser.Parsers.First;
+ loop
+ exit when Current_Parser.Is_Done;
+
+ if Shared_Parser.Terminate_Same_State and
+ Current_Verb = Shift
+ then
+ Shared_Parser.Parsers.Duplicate_State
+ (Current_Parser, Shared_Parser.Trace.all,
Shared_Parser.Terminals);
+ -- If Duplicate_State terminated Current_Parser,
Current_Parser now
+ -- points to the next parser. Otherwise it is unchanged.
+ end if;
+
+ exit when Current_Parser.Is_Done;
+
+ if Trace_Parse > Extra then
+ Trace.Put_Line
+ ("current_verb: " & Parse_Action_Verbs'Image (Current_Verb) &
+ "," & Integer'Image (Current_Parser.Label) &
+ ".verb: " & Parse_Action_Verbs'Image
(Current_Parser.Verb));
+ end if;
+
+ -- Each branch of the following 'if' calls either
Current_Parser.Free
+ -- (which advances to the next parser) or Current_Parser.Next.
+
+ if Current_Parser.Verb = Current_Verb then
+ if Trace_Parse > Extra then
+ Parser_Lists.Put_Top_10 (Trace, Current_Parser);
+ end if;
+
+ declare
+ State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
+ begin
+ Action := Action_For
+ (Table => Shared_Parser.Table.all,
+ State => State.Stack.Peek.State,
+ ID => State.Tree.ID (State.Current_Token));
+ end;
+
+ declare
+ Conflict : Parse_Action_Node_Ptr := Action.Next;
+ begin
+ loop
+ exit when Conflict = null;
+ -- Spawn a new parser (before modifying Current_Parser
stack).
+
+ if Shared_Parser.Parsers.Count =
Shared_Parser.Max_Parallel then
+ declare
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+ Token : Base_Token renames Shared_Parser.Terminals
(Parser_State.Shared_Token);
+ begin
+ raise WisiToken.Parse_Error with Error_Message
+ (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
+ ": too many parallel parsers required in grammar
state" &
+ State_Index'Image
(Parser_State.Stack.Peek.State) &
+ "; simplify grammar, or increase max-parallel
(" &
+ SAL.Base_Peek_Type'Image
(Shared_Parser.Max_Parallel) & ")");
+ end;
+ else
+ if Trace_Parse > Outline then
+ declare
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+ begin
+ Trace.Put_Line
+ (Integer'Image (Current_Parser.Label) & ": " &
+ Trimmed_Image
(Parser_State.Stack.Peek.State) & ": " &
+ Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) & " : " &
+ "spawn" & Integer'Image
(Shared_Parser.Parsers.Last_Label + 1) & ", (" &
+ Trimmed_Image (1 + Integer
(Shared_Parser.Parsers.Count)) & " active)");
+ end;
+ end if;
+
+ Shared_Parser.Parsers.Prepend_Copy (Current_Parser);
+ Do_Action (Conflict.Item, Shared_Parser.Parsers.First,
Shared_Parser);
+
+ declare
+ Temp : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
+ begin
+ Check_Error (Temp);
+ end;
+ end if;
+
+ Conflict := Conflict.Next;
+ end loop;
+ end;
+
+ Do_Action (Action.Item, Current_Parser, Shared_Parser);
+ Check_Error (Current_Parser);
+
+ else
+ -- Current parser is waiting for others to catch up
+ Current_Parser.Next;
+ end if;
+ end loop;
+ end loop Main_Loop;
+
+ -- We don't raise Syntax_Error for lexer errors, since they are all
+ -- recovered, either by inserting a quote, or by ignoring the
+ -- character.
+ end Parse;
+
+ overriding procedure Execute_Actions (Parser : in out
LR.Parser_No_Recover.Parser)
+ is
+ use all type SAL.Base_Peek_Type;
+ use all type Syntax_Trees.User_Data_Access;
+
+ procedure Process_Node
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Syntax_Trees.Valid_Node_Index)
+ is
+ use all type Syntax_Trees.Node_Label;
+ begin
+ if Tree.Label (Node) /= Nonterm then
+ return;
+ end if;
+
+ declare
+ use all type Syntax_Trees.Semantic_Action;
+ Tree_Children : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Children (Node);
+ begin
+ Parser.User_Data.Reduce (Tree, Node, Tree_Children);
+
+ if Tree.Action (Node) /= null then
+ begin
+ Tree.Action (Node) (Parser.User_Data.all, Tree, Node,
Tree_Children);
+ exception
+ when E : others =>
+ declare
+ Token : Base_Token renames Parser.Terminals
(Tree.Min_Terminal_Index (Node));
+ begin
+ raise WisiToken.Parse_Error with Error_Message
+ (Parser.Lexer.File_Name, Token.Line, Token.Column,
+ "action raised exception " &
Ada.Exceptions.Exception_Name (E) & ": " &
+ Ada.Exceptions.Exception_Message (E));
+ end;
+ end;
+ end if;
+ end;
+ end Process_Node;
+
+ begin
+ if Parser.User_Data /= null then
+ if Parser.Parsers.Count > 1 then
+ raise Syntax_Error with "ambiguous parse; can't execute actions";
+ end if;
+
+ declare
+ Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_State_Ref.Element.all;
+ begin
+ Parser.User_Data.Initialize_Actions (Parser_State.Tree);
+ Parser_State.Tree.Process_Tree (Process_Node'Access);
+ end;
+ end if;
+ end Execute_Actions;
+
+ overriding function Tree (Parser : in LR.Parser_No_Recover.Parser) return
Syntax_Trees.Tree
+ is
+ use all type SAL.Base_Peek_Type;
+ begin
+ if Parser.Parsers.Count > 1 then
+ raise WisiToken.Parse_Error with "ambigous parse";
+ else
+ return Parser.Parsers.First_State_Ref.Tree;
+ end if;
+ end Tree;
+
+ overriding function Any_Errors (Parser : in LR.Parser_No_Recover.Parser)
return Boolean
+ is
+ use all type SAL.Base_Peek_Type;
+ use all type Ada.Containers.Count_Type;
+ Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
+ begin
+ pragma Assert (Parser_State.Tree.Flushed);
+ return Parser.Parsers.Count > 1 or Parser_State.Errors.Length > 0 or
Parser.Lexer.Errors.Length > 0;
+ end Any_Errors;
+
+ overriding procedure Put_Errors (Parser : in LR.Parser_No_Recover.Parser)
+ is
+ use Ada.Text_IO;
+
+ Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+ begin
+ for Item of Parser.Lexer.Errors loop
+ Put_Line
+ (Current_Error,
+ Parser.Lexer.File_Name & ":0:0: lexer unrecognized character at" &
Buffer_Pos'Image (Item.Char_Pos));
+ end loop;
+
+ for Item of Parser_State.Errors loop
+ case Item.Label is
+ when Action =>
+ declare
+ Token : Base_Token renames Parser.Terminals
(Parser_State.Tree.Min_Terminal_Index (Item.Error_Token));
+ begin
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Parser.Lexer.File_Name, Token.Line, Token.Column,
+ "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
+ ", found '" & Parser.Lexer.Buffer_Text
(Token.Byte_Region) & "'"));
+ end;
+
+ when Check =>
+ null;
+
+ when Message =>
+ Put_Line (Current_Error, -Item.Msg);
+ end case;
+
+ end loop;
+ end Put_Errors;
+
+end WisiToken.Parse.LR.Parser_No_Recover;
diff --git a/wisitoken-parse-lr.adb b/wisitoken-parse-lr.adb
index 79f4f2e..8900d4c 100644
--- a/wisitoken-parse-lr.adb
+++ b/wisitoken-parse-lr.adb
@@ -1,874 +1,890 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2013-2015, 2017, 2018, 2019 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (GPL);
-
-with Ada.Exceptions;
-with Ada.Strings.Maps;
-with Ada.Strings.Fixed;
-with Ada.Text_IO;
-with GNATCOLL.Mmap;
-package body WisiToken.Parse.LR is
-
- ----------
- -- Public subprograms, declaration order
-
- function Image (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor) return String
- is
- use Ada.Containers;
- begin
- case Item.Verb is
- when Shift =>
- return "(Shift," & State_Index'Image (Item.State) & ")";
-
- when Reduce =>
- return "(Reduce," & Count_Type'Image (Item.Token_Count) & ", " &
- Image (Item.Production.LHS, Descriptor) & "," & Trimmed_Image
(Item.Production.RHS) & ")";
- when Accept_It =>
- return "(Accept It)";
- when Error =>
- return "(Error)";
- end case;
- end Image;
-
- procedure Put (Trace : in out WisiToken.Trace'Class; Item : in
Parse_Action_Rec)
- is
- use Ada.Containers;
- begin
- case Item.Verb is
- when Shift =>
- Trace.Put ("shift and goto state" & State_Index'Image (Item.State),
Prefix => False);
-
- when Reduce =>
- Trace.Put
- ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
- Image (Item.Production.LHS, Trace.Descriptor.all),
- Prefix => False);
- when Accept_It =>
- Trace.Put ("accept it", Prefix => False);
- when Error =>
- Trace.Put ("ERROR", Prefix => False);
- end case;
- end Put;
-
- function Equal (Left, Right : in Parse_Action_Rec) return Boolean
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Left.Verb = Right.Verb then
- case Left.Verb is
- when Shift =>
- return Left.State = Right.State;
-
- when Reduce | Accept_It =>
- return Left.Production.LHS = Right.Production.LHS and
Left.Token_Count = Right.Token_Count;
-
- when Error =>
- return True;
- end case;
- else
- return False;
- end if;
- end Equal;
-
- procedure Add
- (List : in out Action_Node_Ptr;
- Symbol : in Token_ID;
- Action : in Parse_Action_Rec)
- is
- New_Item : constant Action_Node_Ptr := new Action_Node'(Symbol, new
Parse_Action_Node'(Action, null), null);
- I : Action_Node_Ptr := List;
- begin
- if I = null then
- List := New_Item;
- else
- if List.Symbol > Symbol then
- New_Item.Next := List;
- List := New_Item;
- else
- if List.Next = null then
- List.Next := New_Item;
- else
- I := List;
- loop
- exit when I.Next = null or else I.Next.Symbol > Symbol;
- I := I.Next;
- end loop;
- New_Item.Next := I.Next;
- I.Next := New_Item;
- end if;
- end if;
- end if;
- end Add;
-
- function Symbol (List : in Goto_Node_Ptr) return Token_ID
- is begin
- return List.Symbol;
- end Symbol;
-
- function State (List : in Goto_Node_Ptr) return State_Index
- is begin
- return List.State;
- end State;
-
- function Next (List : in Goto_Node_Ptr) return Goto_Node_Ptr
- is begin
- return List.Next;
- end Next;
-
- function Strict_Image (Item : in Minimal_Action) return String
- is begin
- case Item.Verb is
- when Pause =>
- return "(Verb => Shift)";
- when Shift =>
- return "(Shift," & Token_ID'Image (Item.ID) & "," & State_Index'Image
(Item.State) & ")";
- when Reduce =>
- return "(Reduce," & Token_ID'Image (Item.Nonterm) & "," &
- Ada.Containers.Count_Type'Image (Item.Token_Count) & ")";
- end case;
- end Strict_Image;
-
- function First (State : in Parse_State) return Action_List_Iterator
- is begin
- return Iter : Action_List_Iterator := (Node => State.Action_List, Item
=> null) do
- loop
- exit when Iter.Node = null;
- Iter.Item := Iter.Node.Action;
- exit when Iter.Item /= null;
- Iter.Node := Iter.Node.Next;
- end loop;
- end return;
- end First;
-
- function Is_Done (Iter : in Action_List_Iterator) return Boolean
- is begin
- return Iter.Node = null;
- end Is_Done;
-
- procedure Next (Iter : in out Action_List_Iterator)
- is begin
- if Iter.Node = null then
- return;
- end if;
-
- if Iter.Item.Next = null then
- loop
- Iter.Node := Iter.Node.Next;
- exit when Iter.Node = null;
- Iter.Item := Iter.Node.Action;
- exit when Iter.Item /= null;
- end loop;
- else
- Iter.Item := Iter.Item.Next; -- a conflict
- end if;
- end Next;
-
- function Symbol (Iter : in Action_List_Iterator) return Token_ID
- is begin
- return Iter.Node.Symbol;
- end Symbol;
-
- function Action (Iter : in Action_List_Iterator) return Parse_Action_Rec
- is begin
- return Iter.Item.Item;
- end Action;
-
- procedure Add_Action
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- State_Index : in WisiToken.State_Index)
- is
- Action : constant Parse_Action_Rec := (Shift, State_Index);
- New_Node : constant Action_Node_Ptr := new Action_Node'(Symbol, new
Parse_Action_Node'(Action, null), null);
- Node : Action_Node_Ptr;
- begin
- if State.Action_List = null then
- State.Action_List := New_Node;
- else
- Node := State.Action_List;
- loop
- exit when Node.Next = null;
- Node := Node.Next;
- end loop;
- Node.Next := New_Node;
- end if;
- end Add_Action;
-
- procedure Add_Action
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- Verb : in LR.Parse_Action_Verbs;
- Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in Semantic_Checks.Semantic_Check)
- is
- Action : Parse_Action_Rec;
- New_Node : Action_Node_Ptr;
- Node : Action_Node_Ptr;
- begin
- case Verb is
- when Reduce =>
- Action := (Reduce, Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
- when Accept_It =>
- Action := (Accept_It, Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
- when others =>
- null;
- end case;
- New_Node := new Action_Node'(Symbol, new Parse_Action_Node'(Action,
null), null);
- if State.Action_List = null then
- State.Action_List := New_Node;
- else
- Node := State.Action_List;
- loop
- exit when Node.Next = null;
- Node := Node.Next;
- end loop;
- Node.Next := New_Node;
- end if;
- end Add_Action;
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbols : in Token_ID_Array;
- Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check)
- is begin
- -- We assume Duplicate_Reduce is True for this state; no
- -- conflicts, all the same action.
- for Symbol of Symbols loop
- Add_Action
- (State, Symbol, Reduce, Production, RHS_Token_Count,
- Semantic_Action, Semantic_Check);
- end loop;
- Add_Error (State);
- end Add_Action;
-
- procedure Add_Action
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- State_Index : in WisiToken.State_Index;
- Reduce_Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in Semantic_Checks.Semantic_Check)
- is
- Action_1 : constant Parse_Action_Rec := (Shift, State_Index);
- Action_2 : constant Parse_Action_Rec :=
- (Reduce, Reduce_Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
- begin
- State.Action_List := new Action_Node'
- (Symbol, new Parse_Action_Node'(Action_1, new
Parse_Action_Node'(Action_2, null)), State.Action_List);
- end Add_Action;
-
- procedure Add_Action
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- Verb : in LR.Parse_Action_Verbs;
- Production_1 : in Production_ID;
- RHS_Token_Count_1 : in Ada.Containers.Count_Type;
- Semantic_Action_1 : in Syntax_Trees.Semantic_Action;
- Semantic_Check_1 : in Semantic_Checks.Semantic_Check;
- Production_2 : in Production_ID;
- RHS_Token_Count_2 : in Ada.Containers.Count_Type;
- Semantic_Action_2 : in Syntax_Trees.Semantic_Action;
- Semantic_Check_2 : in Semantic_Checks.Semantic_Check)
- is
- Action_1 : constant Parse_Action_Rec :=
- (case Verb is
- when Reduce =>
- (Reduce, Production_1, Semantic_Action_1, Semantic_Check_1,
RHS_Token_Count_1),
- when Accept_It =>
- (Accept_It, Production_1, Semantic_Action_1, Semantic_Check_1,
RHS_Token_Count_1),
- when others => raise SAL.Programmer_Error);
-
- Action_2 : constant Parse_Action_Rec :=
- (Reduce, Production_2, Semantic_Action_2, Semantic_Check_2,
RHS_Token_Count_2);
- begin
- State.Action_List := new Action_Node'
- (Symbol, new Parse_Action_Node'(Action_1, new
Parse_Action_Node'(Action_2, null)), State.Action_List);
- end Add_Action;
-
- procedure Add_Error (State : in out LR.Parse_State)
- is
- Action : constant Parse_Action_Rec := (Verb => Error);
- Node : Action_Node_Ptr := State.Action_List;
- begin
- if Node = null then
- raise SAL.Programmer_Error with "adding an error action to a parse
table state before other actions.";
- end if;
- loop
- exit when Node.Next = null;
- Node := Node.Next;
- end loop;
- Node.Next := new Action_Node'(Invalid_Token_ID, new
Parse_Action_Node'(Action, null), null);
- end Add_Error;
-
- procedure Add_Goto
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- To_State : in State_Index)
- is
- List : Goto_Node_Ptr renames State.Goto_List;
- New_Item : constant Goto_Node_Ptr := new Goto_Node'(Symbol, To_State,
null);
- I : Goto_Node_Ptr := List;
- begin
- if I = null then
- List := New_Item;
- else
- if List.Symbol > Symbol then
- New_Item.Next := List;
- List := New_Item;
- else
- if List.Next = null then
- List.Next := New_Item;
- else
- I := List;
- loop
- exit when I.Next = null or List.Symbol > Symbol;
- I := I.Next;
- end loop;
- New_Item.Next := I.Next;
- I.Next := New_Item;
- end if;
- end if;
- end if;
- end Add_Goto;
-
- procedure Set_Production
- (Prod : in out Productions.Instance;
- LHS : in Token_ID;
- RHS_Last : in Natural)
- is begin
- Prod.LHS := LHS;
- Prod.RHSs.Set_First (0);
- Prod.RHSs.Set_Last (RHS_Last);
- end Set_Production;
-
- procedure Set_RHS
- (Prod : in out Productions.Instance;
- RHS_Index : in Natural;
- Tokens : in Token_ID_Array;
- Action : in WisiToken.Syntax_Trees.Semantic_Action := null;
- Check : in WisiToken.Semantic_Checks.Semantic_Check := null)
- is begin
- if Tokens'Length > 0 then
- Prod.RHSs (RHS_Index).Tokens.Set_First (1);
- Prod.RHSs (RHS_Index).Tokens.Set_Last (Tokens'Length);
- for I in Tokens'Range loop
- Prod.RHSs (RHS_Index).Tokens (I) := Tokens (I);
- end loop;
- Prod.RHSs (RHS_Index).Action := Action;
- Prod.RHSs (RHS_Index).Check := Check;
- end if;
- end Set_RHS;
-
- function Goto_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Unknown_State_Index
- is
- Goto_Node : constant Goto_Node_Ptr := Goto_For (Table, State, ID);
- begin
- if Goto_Node = null then
- -- We can only get here during error recovery.
- return Unknown_State;
- else
- return Goto_Node.State;
- end if;
- end Goto_For;
-
- function Goto_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Goto_Node_Ptr
- is
- Goto_Node : Goto_Node_Ptr := Table.States (State).Goto_List;
- begin
- while Goto_Node /= null and then Goto_Node.Symbol /= ID loop
- Goto_Node := Goto_Node.Next;
- end loop;
-
- return Goto_Node;
- end Goto_For;
-
- function Action_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Parse_Action_Node_Ptr
- is
- Action_Node : Action_Node_Ptr := Table.States (State).Action_List;
- begin
- if Action_Node = null then
- raise SAL.Programmer_Error with "no actions for state" &
Unknown_State_Index'Image (State);
- end if;
-
- while Action_Node.Next /= null and Action_Node.Symbol /= ID loop
- Action_Node := Action_Node.Next;
- end loop;
-
- return Action_Node.Action;
- end Action_For;
-
- function Expecting (Table : in Parse_Table; State : in State_Index) return
Token_ID_Set
- is
- Result : Token_ID_Set := (Table.First_Terminal .. Table.Last_Terminal
=> False);
- Action : Action_Node_Ptr := Table.States (State).Action_List;
- begin
- loop
- -- Last action is error; don't include it.
- exit when Action.Next = null;
-
- Result (Action.Symbol) := True;
- Action := Action.Next;
- end loop;
- return Result;
- end Expecting;
-
- procedure Free_Table (Table : in out Parse_Table_Ptr)
- is
-
- procedure Free is new Ada.Unchecked_Deallocation (Parse_Table,
Parse_Table_Ptr);
- Action : Action_Node_Ptr;
- Temp_Action : Action_Node_Ptr;
- Parse_Action : Parse_Action_Node_Ptr;
- Temp_Parse_Action : Parse_Action_Node_Ptr;
- Got : Goto_Node_Ptr;
- Temp_Got : Goto_Node_Ptr;
- begin
- if Table = null then
- return;
- end if;
-
- for State of Table.States loop
- Action := State.Action_List;
- loop
- exit when Action = null;
- Parse_Action := Action.Action;
- loop
- exit when Parse_Action = null;
- Temp_Parse_Action := Parse_Action;
- Parse_Action := Parse_Action.Next;
- Free (Temp_Parse_Action);
- end loop;
-
- Temp_Action := Action;
- Action := Action.Next;
- Free (Temp_Action);
- end loop;
-
- Got := State.Goto_List;
- loop
- exit when Got = null;
- Temp_Got := Got;
- Got := Got.Next;
- Free (Temp_Got);
- end loop;
- end loop;
-
- Free (Table);
- end Free_Table;
-
- function Get_Action
- (Prod : in Production_ID;
- Productions : in WisiToken.Productions.Prod_Arrays.Vector)
- return WisiToken.Syntax_Trees.Semantic_Action
- is begin
- return Productions (Prod.LHS).RHSs (Prod.RHS).Action;
- end Get_Action;
-
- function Get_Check
- (Prod : in Production_ID;
- Productions : in WisiToken.Productions.Prod_Arrays.Vector)
- return WisiToken.Semantic_Checks.Semantic_Check
- is begin
- return Productions (Prod.LHS).RHSs (Prod.RHS).Check;
- end Get_Check;
-
- function Get_Text_Rep
- (File_Name : in String;
- McKenzie_Param : in McKenzie_Param_Type;
- Productions : in WisiToken.Productions.Prod_Arrays.Vector)
- return Parse_Table_Ptr
- is
- use Ada.Text_IO;
-
- File : GNATCOLL.Mmap.Mapped_File;
- Region : GNATCOLL.Mmap.Mapped_Region;
- Buffer : GNATCOLL.Mmap.Str_Access;
- Buffer_Abs_Last : Integer; -- Buffer'Last, except Buffer has no bounds
- Buffer_Last : Integer := 0; -- Last char read from Buffer
-
- Delimiters : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set (" ;" & ASCII.LF);
-
- function Check_Semicolon return Boolean
- is begin
- if Buffer (Buffer_Last) = ';' then
- -- There is a space, newline, or newline and space after ';'.
Leave
- -- Buffer_Last on newline for Check_New_Line.
- Buffer_Last := Buffer_Last + 1;
- return True;
- else
- return False;
- end if;
- end Check_Semicolon;
-
- procedure Check_Semicolon
- is begin
- if Buffer (Buffer_Last) = ';' then
- -- There is a space, newline, or newline and space after ';'.
Leave
- -- Buffer_Last on newline for Check_New_Line.
- Buffer_Last := Buffer_Last + 1;
- else
- raise SAL.Programmer_Error with Error_Message
- (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
- "expecting semicolon, found '" & Buffer (Buffer_Last) & "'");
- end if;
- end Check_Semicolon;
-
- function Check_EOI return Boolean
- is begin
- return Buffer_Last >= Buffer_Abs_Last;
- end Check_EOI;
-
- procedure Check_New_Line
- is
- use Ada.Strings.Maps;
- begin
- if Buffer (Buffer_Last) = ASCII.LF then
- -- There is a space or semicolon after some newlines.
- if Is_In (Buffer (Buffer_Last + 1), Delimiters) then
- Buffer_Last := Buffer_Last + 1;
- end if;
- else
- raise SAL.Programmer_Error with Error_Message
- (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
- "expecting new_line, found '" & Buffer (Buffer_Last) & "'");
- end if;
- end Check_New_Line;
-
- type Buffer_Region is record
- First : Integer;
- Last : Integer;
- end record;
-
- function Next_Value return Buffer_Region;
- pragma Inline (Next_Value);
-
- function Next_Value return Buffer_Region
- is
- use Ada.Strings.Fixed;
- First : constant Integer := Buffer_Last + 1;
- begin
- Buffer_Last := Index (Buffer.all, Delimiters, First);
- return (First, Buffer_Last - 1);
- end Next_Value;
-
- procedure Raise_Gen_Next_Value_Constraint_Error (Name : String; Region :
Buffer_Region);
- pragma No_Return (Raise_Gen_Next_Value_Constraint_Error);
-
- procedure Raise_Gen_Next_Value_Constraint_Error (Name : String; Region :
Buffer_Region)
- is begin
- -- Factored out from Gen_Next_Value to make Inline efficient.
- raise SAL.Programmer_Error with Error_Message
- (File_Name, 1, Ada.Text_IO.Count (Region.First),
- "expecting " & Name & ", found '" & Buffer (Region.First ..
Region.Last) & "'");
- end Raise_Gen_Next_Value_Constraint_Error;
-
- generic
- type Value_Type is (<>);
- Name : in String;
- function Gen_Next_Value return Value_Type;
- pragma Inline (Gen_Next_Value);
-
- function Gen_Next_Value return Value_Type
- is
- Region : constant Buffer_Region := Next_Value;
- begin
- return Value_Type'Value (Buffer (Region.First .. Region.Last));
- exception
- when Constraint_Error =>
- Raise_Gen_Next_Value_Constraint_Error (Name, Region);
- end Gen_Next_Value;
-
- function Next_State_Index is new Gen_Next_Value (State_Index,
"State_Index");
- function Next_Token_ID is new Gen_Next_Value (Token_ID, "Token_ID");
- function Next_Integer is new Gen_Next_Value (Integer, "Integer");
- function Next_Parse_Action_Verbs is new Gen_Next_Value
(Parse_Action_Verbs, "Parse_Action_Verbs");
- function Next_Boolean is new Gen_Next_Value (Boolean, "Boolean");
- function Next_Count_Type is new Gen_Next_Value
(Ada.Containers.Count_Type, "Count_Type");
- begin
- File := GNATCOLL.Mmap.Open_Read (File_Name);
- Region := GNATCOLL.Mmap.Read (File);
- Buffer := GNATCOLL.Mmap.Data (Region);
- Buffer_Abs_Last := GNATCOLL.Mmap.Last (Region);
-
- declare
- -- We don't read the discriminants in the aggregate, because
- -- aggregate evaluation order is not guaranteed.
- State_First : constant State_Index := Next_State_Index;
- State_Last : constant State_Index := Next_State_Index;
- First_Terminal : constant Token_ID := Next_Token_ID;
- Last_Terminal : constant Token_ID := Next_Token_ID;
- First_Nonterminal : constant Token_ID := Next_Token_ID;
- Last_Nonterminal : constant Token_ID := Next_Token_ID;
-
- Table : constant Parse_Table_Ptr := new Parse_Table
- (State_First, State_Last, First_Terminal, Last_Terminal,
First_Nonterminal, Last_Nonterminal);
- begin
- Check_New_Line;
-
- Table.McKenzie_Param := McKenzie_Param;
-
- for State of Table.States loop
- State.Productions.Set_First (Next_Integer);
- State.Productions.Set_Last (Next_Integer);
- for I in State.Productions.First_Index ..
State.Productions.Last_Index loop
- State.Productions (I).LHS := Next_Token_ID;
- State.Productions (I).RHS := Next_Integer;
- end loop;
- Check_New_Line;
-
- declare
- Node_I : Action_Node_Ptr := new Action_Node;
- Actions_Done : Boolean := False;
- begin
- State.Action_List := Node_I;
- loop
- declare
- Node_J : Parse_Action_Node_Ptr := new
Parse_Action_Node;
- Action_Done : Boolean := False;
- Verb : Parse_Action_Verbs;
- begin
- Node_I.Action := Node_J;
- loop
- Verb := Next_Parse_Action_Verbs;
- Node_J.Item :=
- (case Verb is
- when Shift => (Verb => Shift, others => <>),
- when Reduce => (Verb => Reduce, others => <>),
- when Accept_It => (Verb => Accept_It, others => <>),
- when Error => (Verb => Error));
-
- case Verb is
- when Shift =>
- Node_J.Item.State := Next_State_Index;
-
- when Reduce | Accept_It =>
- Node_J.Item.Production.LHS := Next_Token_ID;
- Node_J.Item.Production.RHS := Next_Integer;
- if Next_Boolean then
- Node_J.Item.Action := Get_Action
(Node_J.Item.Production, Productions);
- else
- Node_J.Item.Action := null;
- end if;
- if Next_Boolean then
- Node_J.Item.Check := Get_Check
(Node_J.Item.Production, Productions);
- else
- Node_J.Item.Check := null;
- end if;
- Node_J.Item.Token_Count := Next_Count_Type;
-
- when Error =>
- Actions_Done := True;
- end case;
-
- if Check_Semicolon then
- Action_Done := True;
-
- if not Actions_Done then
- Node_I.Symbol := Next_Token_ID;
- end if;
- end if;
-
- exit when Action_Done;
-
- Node_J.Next := new Parse_Action_Node;
- Node_J := Node_J.Next;
- end loop;
-
- Check_New_Line;
- end;
-
- exit when Actions_Done;
- Node_I.Next := new Action_Node;
- Node_I := Node_I.Next;
- end loop;
- end;
-
- if Check_Semicolon then
- -- No Gotos
- null;
- else
- declare
- Node_I : Goto_Node_Ptr := new Goto_Node;
- begin
- State.Goto_List := Node_I;
- loop
- Node_I.Symbol := Next_Token_ID;
- Node_I.State := Next_State_Index;
- exit when Check_Semicolon;
- Node_I.Next := new Goto_Node;
- Node_I := Node_I.Next;
- end loop;
- end;
- end if;
- Check_New_Line;
-
- if Check_Semicolon then
- -- No minimal action
- null;
- else
- declare
- Verb : constant Minimal_Verbs :=
Next_Parse_Action_Verbs;
- ID : Token_ID;
- Action_State : State_Index;
- Count : Ada.Containers.Count_Type;
- begin
- case Verb is
- when Pause =>
- null; -- Generate.LR.Put_Text_Rep does not output this
-
- when Shift =>
- ID := Next_Token_ID;
- Action_State := Next_State_Index;
- State.Minimal_Complete_Action := (Shift, ID,
Action_State);
- when Reduce =>
- ID := Next_Token_ID;
- Count := Next_Count_Type;
- State.Minimal_Complete_Action := (Reduce, ID, Count);
- end case;
- end;
- Check_Semicolon;
- end if;
- Check_New_Line;
-
- exit when Check_EOI;
- end loop;
- return Table;
- end;
- exception
- when Name_Error =>
- raise User_Error with "parser table text file '" & File_Name & "' not
found.";
-
- when SAL.Programmer_Error =>
- raise;
-
- when E : others =>
- raise SAL.Programmer_Error with Error_Message
- (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
- Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
- end Get_Text_Rep;
-
- function Compare (Left, Right : in Insert_Delete_Op) return
SAL.Compare_Result
- is begin
- if Left.Token_Index < Right.Token_Index then
- return SAL.Less;
- elsif Left.Token_Index = Right.Token_Index then
- return SAL.Equal;
- else
- return SAL.Greater;
- end if;
- end Compare;
-
- function None_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
- is begin
- for O of reverse Ops loop
- exit when O.Op = Fast_Forward;
- if O.Op = Op then
- return False;
- end if;
- end loop;
- return True;
- end None_Since_FF;
-
- function Match_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op) return Boolean
- is begin
- for O of reverse Ops loop
- exit when O.Op = Fast_Forward;
- if O = Op then
- return True;
- end if;
- end loop;
- return False;
- end Match_Since_FF;
-
- function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean
- is
- use all type Syntax_Trees.Node_Index;
- begin
- for I in 1 .. Depth loop
- if Stack (I).Tree_Index = Syntax_Trees.Invalid_Node_Index then
- return False;
- end if;
- end loop;
- return True;
- end Valid_Tree_Indices;
-
- procedure Set_Key (Item : in out Configuration; Key : in Integer)
- is begin
- Item.Cost := Key;
- end Set_Key;
-
- procedure Accumulate (Data : in McKenzie_Data; Counts : in out
Strategy_Counts)
- is
- procedure Proc (Config : in Configuration)
- is begin
- for I in Config.Strategy_Counts'Range loop
- Counts (I) := Counts (I) + Config.Strategy_Counts (I);
- end loop;
- end Proc;
- begin
- Data.Results.Process (Proc'Unrestricted_Access);
- end Accumulate;
-
- function Image
- (Item : in Parse_Error;
- Tree : in Syntax_Trees.Tree;
- Descriptor : in WisiToken.Descriptor)
- return String
- is begin
- case Item.Label is
- when Action =>
- return "Action, expecting: " & Image (Item.Expecting, Descriptor) &
- ", found" & Tree.Image (Item.Error_Token, Descriptor);
-
- when Check =>
- return "Check, " & Semantic_Checks.Image (Item.Check_Status,
Descriptor);
-
- when Message =>
- return -Item.Msg;
- end case;
- end Image;
-
-end WisiToken.Parse.LR;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2013-2015, 2017, 2018, 2019 Free Software Foundation, Inc.
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (GPL);
+
+with Ada.Exceptions;
+with Ada.Strings.Maps;
+with Ada.Strings.Fixed;
+with Ada.Text_IO;
+with GNATCOLL.Mmap;
+package body WisiToken.Parse.LR is
+
+ ----------
+ -- Public subprograms, declaration order
+
+ function Image (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor) return String
+ is
+ use Ada.Containers;
+ begin
+ case Item.Verb is
+ when Shift =>
+ return "(Shift," & State_Index'Image (Item.State) & ")";
+
+ when Reduce =>
+ return "(Reduce," & Count_Type'Image (Item.Token_Count) & ", " &
+ Image (Item.Production.LHS, Descriptor) & "," & Trimmed_Image
(Item.Production.RHS) & ")";
+ when Accept_It =>
+ return "(Accept It)";
+ when Error =>
+ return "(Error)";
+ end case;
+ end Image;
+
+ procedure Put (Trace : in out WisiToken.Trace'Class; Item : in
Parse_Action_Rec)
+ is
+ use Ada.Containers;
+ begin
+ case Item.Verb is
+ when Shift =>
+ Trace.Put ("shift and goto state" & State_Index'Image (Item.State),
Prefix => False);
+
+ when Reduce =>
+ Trace.Put
+ ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
+ Image (Item.Production.LHS, Trace.Descriptor.all),
+ Prefix => False);
+ when Accept_It =>
+ Trace.Put ("accept it", Prefix => False);
+ when Error =>
+ Trace.Put ("ERROR", Prefix => False);
+ end case;
+ end Put;
+
+ function Equal (Left, Right : in Parse_Action_Rec) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Left.Verb = Right.Verb then
+ case Left.Verb is
+ when Shift =>
+ return Left.State = Right.State;
+
+ when Reduce | Accept_It =>
+ return Left.Production.LHS = Right.Production.LHS and
Left.Token_Count = Right.Token_Count;
+
+ when Error =>
+ return True;
+ end case;
+ else
+ return False;
+ end if;
+ end Equal;
+
+ function Is_In (Item : in Parse_Action_Rec; List : in
Parse_Action_Node_Ptr) return Boolean
+ is
+ Node : Parse_Action_Node_Ptr := List;
+ begin
+ loop
+ exit when Node = null;
+ if Equal (Item, Node.Item) then
+ return True;
+ end if;
+ Node := Node.Next;
+ end loop;
+ return False;
+ end Is_In;
+
+ function Find
+ (Symbol : in Token_ID;
+ Action_List : in Action_Node_Ptr)
+ return Action_Node_Ptr
+ is
+ Action_Node : Action_Node_Ptr := Action_List;
+ begin
+ while Action_Node /= null loop
+ if Action_Node.Symbol = Symbol then
+ return Action_Node;
+ end if;
+ Action_Node := Action_Node.Next;
+ end loop;
+
+ return null;
+ end Find;
+
+ procedure Add
+ (List : in out Action_Node_Ptr;
+ Symbol : in Token_ID;
+ Action : in Parse_Action_Rec)
+ is
+ New_Item : constant Action_Node_Ptr := new Action_Node'(Symbol, new
Parse_Action_Node'(Action, null), null);
+ I : Action_Node_Ptr := List;
+ begin
+ if I = null then
+ List := New_Item;
+ else
+ if List.Symbol > Symbol then
+ New_Item.Next := List;
+ List := New_Item;
+ else
+ if List.Next = null then
+ List.Next := New_Item;
+ else
+ I := List;
+ loop
+ exit when I.Next = null or else I.Next.Symbol > Symbol;
+ I := I.Next;
+ end loop;
+ New_Item.Next := I.Next;
+ I.Next := New_Item;
+ end if;
+ end if;
+ end if;
+ end Add;
+
+ function Symbol (List : in Goto_Node_Ptr) return Token_ID
+ is begin
+ return List.Symbol;
+ end Symbol;
+
+ function State (List : in Goto_Node_Ptr) return State_Index
+ is begin
+ return List.State;
+ end State;
+
+ function Next (List : in Goto_Node_Ptr) return Goto_Node_Ptr
+ is begin
+ return List.Next;
+ end Next;
+
+ function To_Vector (Item : in Kernel_Info_Array) return
Kernel_Info_Arrays.Vector
+ is begin
+ return Result : Kernel_Info_Arrays.Vector do
+ Result.Set_First_Last (Item'First, Item'Last);
+ for I in Item'Range loop
+ Result (I) := Item (I);
+ end loop;
+ end return;
+ end To_Vector;
+
+ function Strict_Image (Item : in Kernel_Info) return String
+ is begin
+ return "(" & Trimmed_Image (Item.LHS) & "," & Token_ID'Image
(Item.Before_Dot) & "," &
+ Ada.Containers.Count_Type'Image (Item.Length_After_Dot) & ", " &
+ (if Item.Recursive then "True" else "False") & ")";
+ end Strict_Image;
+
+ function Strict_Image (Item : in Minimal_Action) return String
+ is begin
+ case Item.Verb is
+ when Shift =>
+ return "(Shift," & Token_ID'Image (Item.ID) & "," & State_Index'Image
(Item.State) & ")";
+ when Reduce =>
+ return "(Reduce," & Token_ID'Image (Item.Nonterm) & "," &
+ Ada.Containers.Count_Type'Image (Item.Token_Count) & ")";
+ end case;
+ end Strict_Image;
+
+ function Image (Item : in Minimal_Action; Descriptor : in
WisiToken.Descriptor) return String
+ is begin
+ case Item.Verb is
+ when Shift =>
+ return "Shift " & Image (Item.ID, Descriptor);
+ when Reduce =>
+ return "Reduce to " & Image (Item.Nonterm, Descriptor);
+ end case;
+ end Image;
+
+ function To_Vector (Item : in Minimal_Action_Array) return
Minimal_Action_Arrays.Vector
+ is begin
+ return Result : Minimal_Action_Arrays.Vector do
+ Result.Set_First_Last (Item'First, Item'Last);
+ for I in Item'Range loop
+ Result.Replace_Element (I, Item (I));
+ end loop;
+ end return;
+ end To_Vector;
+
+ function First (State : in Parse_State) return Action_List_Iterator
+ is begin
+ return Iter : Action_List_Iterator := (Node => State.Action_List, Item
=> null) do
+ loop
+ exit when Iter.Node = null;
+ Iter.Item := Iter.Node.Action;
+ exit when Iter.Item /= null;
+ Iter.Node := Iter.Node.Next;
+ end loop;
+ end return;
+ end First;
+
+ function Is_Done (Iter : in Action_List_Iterator) return Boolean
+ is begin
+ return Iter.Node = null;
+ end Is_Done;
+
+ procedure Next (Iter : in out Action_List_Iterator)
+ is begin
+ if Iter.Node = null then
+ return;
+ end if;
+
+ if Iter.Item.Next = null then
+ loop
+ Iter.Node := Iter.Node.Next;
+ exit when Iter.Node = null;
+ Iter.Item := Iter.Node.Action;
+ exit when Iter.Item /= null;
+ end loop;
+ else
+ Iter.Item := Iter.Item.Next; -- a conflict
+ end if;
+ end Next;
+
+ function Symbol (Iter : in Action_List_Iterator) return Token_ID
+ is begin
+ return Iter.Node.Symbol;
+ end Symbol;
+
+ function Action (Iter : in Action_List_Iterator) return Parse_Action_Rec
+ is begin
+ return Iter.Item.Item;
+ end Action;
+
+ procedure Add_Action
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ State_Index : in WisiToken.State_Index)
+ is
+ Action : constant Parse_Action_Rec := (Shift, State_Index);
+ New_Node : constant Action_Node_Ptr := new Action_Node'(Symbol, new
Parse_Action_Node'(Action, null), null);
+ Node : Action_Node_Ptr;
+ begin
+ if State.Action_List = null then
+ State.Action_List := New_Node;
+ else
+ Node := State.Action_List;
+ loop
+ exit when Node.Next = null;
+ Node := Node.Next;
+ end loop;
+ Node.Next := New_Node;
+ end if;
+ end Add_Action;
+
+ procedure Add_Action
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ Verb : in LR.Parse_Action_Verbs;
+ Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in Semantic_Checks.Semantic_Check)
+ is
+ Action : Parse_Action_Rec;
+ New_Node : Action_Node_Ptr;
+ Node : Action_Node_Ptr;
+ begin
+ case Verb is
+ when Reduce =>
+ Action := (Reduce, Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
+ when Accept_It =>
+ Action := (Accept_It, Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
+ when others =>
+ null;
+ end case;
+ New_Node := new Action_Node'(Symbol, new Parse_Action_Node'(Action,
null), null);
+ if State.Action_List = null then
+ State.Action_List := New_Node;
+ else
+ Node := State.Action_List;
+ loop
+ exit when Node.Next = null;
+ Node := Node.Next;
+ end loop;
+ Node.Next := New_Node;
+ end if;
+ end Add_Action;
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbols : in Token_ID_Array;
+ Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check)
+ is begin
+ -- We assume Duplicate_Reduce is True for this state; no
+ -- conflicts, all the same action.
+ for Symbol of Symbols loop
+ Add_Action
+ (State, Symbol, Reduce, Production, RHS_Token_Count,
+ Semantic_Action, Semantic_Check);
+ end loop;
+ Add_Error (State);
+ end Add_Action;
+
+ procedure Add_Conflict
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ Reduce_Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in Semantic_Checks.Semantic_Check)
+ is
+ Conflict : constant Parse_Action_Rec :=
+ (Reduce, Reduce_Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
+ Node : Parse_Action_Node_Ptr := Find (Symbol, State.Action_List).Action;
+ begin
+ loop
+ exit when Node.Next = null;
+ Node := Node.Next;
+ end loop;
+ Node.Next := new Parse_Action_Node'(Conflict, null);
+ end Add_Conflict;
+
+ procedure Add_Error (State : in out LR.Parse_State)
+ is
+ Action : constant Parse_Action_Rec := (Verb => Error);
+ Node : Action_Node_Ptr := State.Action_List;
+ begin
+ if Node = null then
+ raise SAL.Programmer_Error with "adding an error action to a parse
table state before other actions.";
+ end if;
+ loop
+ exit when Node.Next = null;
+ Node := Node.Next;
+ end loop;
+ Node.Next := new Action_Node'(Invalid_Token_ID, new
Parse_Action_Node'(Action, null), null);
+ end Add_Error;
+
+ procedure Add_Goto
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ To_State : in State_Index)
+ is
+ List : Goto_Node_Ptr renames State.Goto_List;
+ New_Item : constant Goto_Node_Ptr := new Goto_Node'(Symbol, To_State,
null);
+ I : Goto_Node_Ptr := List;
+ begin
+ if I = null then
+ List := New_Item;
+ else
+ if List.Symbol > Symbol then
+ New_Item.Next := List;
+ List := New_Item;
+ else
+ if List.Next = null then
+ List.Next := New_Item;
+ else
+ I := List;
+ loop
+ exit when I.Next = null or List.Symbol > Symbol;
+ I := I.Next;
+ end loop;
+ New_Item.Next := I.Next;
+ I.Next := New_Item;
+ end if;
+ end if;
+ end if;
+ end Add_Goto;
+
+ function Goto_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Unknown_State_Index
+ is
+ Goto_Node : constant Goto_Node_Ptr := Goto_For (Table, State, ID);
+ begin
+ if Goto_Node = null then
+ -- We can only get here during error recovery.
+ return Unknown_State;
+ else
+ return Goto_Node.State;
+ end if;
+ end Goto_For;
+
+ function Goto_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Goto_Node_Ptr
+ is
+ Goto_Node : Goto_Node_Ptr := Table.States (State).Goto_List;
+ begin
+ while Goto_Node /= null and then Goto_Node.Symbol /= ID loop
+ Goto_Node := Goto_Node.Next;
+ end loop;
+
+ return Goto_Node;
+ end Goto_For;
+
+ function Action_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Parse_Action_Node_Ptr
+ is
+ Action_Node : Action_Node_Ptr := Table.States (State).Action_List;
+ begin
+ if Action_Node = null then
+ raise SAL.Programmer_Error with "no actions for state" &
Unknown_State_Index'Image (State);
+ end if;
+
+ while Action_Node.Next /= null and Action_Node.Symbol /= ID loop
+ Action_Node := Action_Node.Next;
+ end loop;
+
+ return Action_Node.Action;
+ end Action_For;
+
+ function Expecting (Table : in Parse_Table; State : in State_Index) return
Token_ID_Set
+ is
+ Result : Token_ID_Set := (Table.First_Terminal .. Table.Last_Terminal
=> False);
+ Action : Action_Node_Ptr := Table.States (State).Action_List;
+ begin
+ loop
+ -- Last action is error; don't include it.
+ exit when Action.Next = null;
+
+ Result (Action.Symbol) := True;
+ Action := Action.Next;
+ end loop;
+ return Result;
+ end Expecting;
+
+ procedure Free_Table (Table : in out Parse_Table_Ptr)
+ is
+
+ procedure Free is new Ada.Unchecked_Deallocation (Parse_Table,
Parse_Table_Ptr);
+ Action : Action_Node_Ptr;
+ Temp_Action : Action_Node_Ptr;
+ Parse_Action : Parse_Action_Node_Ptr;
+ Temp_Parse_Action : Parse_Action_Node_Ptr;
+ Got : Goto_Node_Ptr;
+ Temp_Got : Goto_Node_Ptr;
+ begin
+ if Table = null then
+ return;
+ end if;
+
+ for State of Table.States loop
+ Action := State.Action_List;
+ loop
+ exit when Action = null;
+ Parse_Action := Action.Action;
+ loop
+ exit when Parse_Action = null;
+ Temp_Parse_Action := Parse_Action;
+ Parse_Action := Parse_Action.Next;
+ Free (Temp_Parse_Action);
+ end loop;
+
+ Temp_Action := Action;
+ Action := Action.Next;
+ Free (Temp_Action);
+ end loop;
+
+ Got := State.Goto_List;
+ loop
+ exit when Got = null;
+ Temp_Got := Got;
+ Got := Got.Next;
+ Free (Temp_Got);
+ end loop;
+ end loop;
+
+ Free (Table);
+ end Free_Table;
+
+ function Get_Text_Rep
+ (File_Name : in String;
+ McKenzie_Param : in McKenzie_Param_Type;
+ Actions : in Semantic_Action_Array_Arrays.Vector)
+ return Parse_Table_Ptr
+ is
+ use Ada.Text_IO;
+
+ File : GNATCOLL.Mmap.Mapped_File;
+ Region : GNATCOLL.Mmap.Mapped_Region;
+ Buffer : GNATCOLL.Mmap.Str_Access;
+ Buffer_Abs_Last : Integer; -- Buffer'Last, except Buffer has no bounds
+ Buffer_Last : Integer := 0; -- Last char read from Buffer
+
+ Delimiters : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set (" ;" & ASCII.LF);
+
+ function Check_Semicolon return Boolean
+ is begin
+ if Buffer (Buffer_Last) = ';' then
+ -- There is a space, newline, or newline and space after ';'.
Leave
+ -- Buffer_Last on newline for Check_New_Line.
+ Buffer_Last := Buffer_Last + 1;
+ return True;
+ else
+ return False;
+ end if;
+ end Check_Semicolon;
+
+ procedure Check_Semicolon
+ is begin
+ if Buffer (Buffer_Last) = ';' then
+ -- There is a space, newline, or newline and space after ';'.
Leave
+ -- Buffer_Last on newline for Check_New_Line.
+ Buffer_Last := Buffer_Last + 1;
+ else
+ raise SAL.Programmer_Error with Error_Message
+ (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
+ "expecting semicolon, found '" & Buffer (Buffer_Last) & "'");
+ end if;
+ end Check_Semicolon;
+
+ function Check_EOI return Boolean
+ is begin
+ return Buffer_Last >= Buffer_Abs_Last;
+ end Check_EOI;
+
+ procedure Check_New_Line
+ is
+ use Ada.Strings.Maps;
+ begin
+ if Buffer (Buffer_Last) = ASCII.LF then
+ -- There is a space or semicolon after some newlines.
+ if Is_In (Buffer (Buffer_Last + 1), Delimiters) then
+ Buffer_Last := Buffer_Last + 1;
+ end if;
+ else
+ raise SAL.Programmer_Error with Error_Message
+ (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
+ "expecting new_line, found '" & Buffer (Buffer_Last) & "'");
+ end if;
+ end Check_New_Line;
+
+ type Buffer_Region is record
+ First : Integer;
+ Last : Integer;
+ end record;
+
+ function Next_Value return Buffer_Region;
+ pragma Inline (Next_Value);
+
+ function Next_Value return Buffer_Region
+ is
+ use Ada.Strings.Fixed;
+ First : constant Integer := Buffer_Last + 1;
+ begin
+ Buffer_Last := Index (Buffer.all, Delimiters, First);
+ return (First, Buffer_Last - 1);
+ end Next_Value;
+
+ procedure Raise_Gen_Next_Value_Constraint_Error (Name : String; Region :
Buffer_Region);
+ pragma No_Return (Raise_Gen_Next_Value_Constraint_Error);
+
+ procedure Raise_Gen_Next_Value_Constraint_Error (Name : String; Region :
Buffer_Region)
+ is begin
+ -- Factored out from Gen_Next_Value to make Inline efficient.
+ raise SAL.Programmer_Error with Error_Message
+ (File_Name, 1, Ada.Text_IO.Count (Region.First),
+ "expecting " & Name & ", found '" & Buffer (Region.First ..
Region.Last) & "'");
+ end Raise_Gen_Next_Value_Constraint_Error;
+
+ generic
+ type Value_Type is (<>);
+ Name : in String;
+ function Gen_Next_Value return Value_Type;
+ pragma Inline (Gen_Next_Value);
+
+ function Gen_Next_Value return Value_Type
+ is
+ Region : constant Buffer_Region := Next_Value;
+ begin
+ return Value_Type'Value (Buffer (Region.First .. Region.Last));
+ exception
+ when Constraint_Error =>
+ Raise_Gen_Next_Value_Constraint_Error (Name, Region);
+ end Gen_Next_Value;
+
+ function Next_State_Index is new Gen_Next_Value (State_Index,
"State_Index");
+ function Next_Token_ID is new Gen_Next_Value (Token_ID, "Token_ID");
+ function Next_Integer is new Gen_Next_Value (Integer, "Integer");
+ function Next_Parse_Action_Verbs is new Gen_Next_Value
(Parse_Action_Verbs, "Parse_Action_Verbs");
+ function Next_Boolean is new Gen_Next_Value (Boolean, "Boolean");
+ function Next_Count_Type is new Gen_Next_Value
(Ada.Containers.Count_Type, "Count_Type");
+ begin
+ File := GNATCOLL.Mmap.Open_Read (File_Name);
+ Region := GNATCOLL.Mmap.Read (File);
+ Buffer := GNATCOLL.Mmap.Data (Region);
+ Buffer_Abs_Last := GNATCOLL.Mmap.Last (Region);
+
+ declare
+ use Ada.Containers;
+
+ -- We don't read the discriminants in the aggregate, because
+ -- aggregate evaluation order is not guaranteed.
+ State_First : constant State_Index := Next_State_Index;
+ State_Last : constant State_Index := Next_State_Index;
+ First_Terminal : constant Token_ID := Next_Token_ID;
+ Last_Terminal : constant Token_ID := Next_Token_ID;
+ First_Nonterminal : constant Token_ID := Next_Token_ID;
+ Last_Nonterminal : constant Token_ID := Next_Token_ID;
+
+ Table : constant Parse_Table_Ptr := new Parse_Table
+ (State_First, State_Last, First_Terminal, Last_Terminal,
First_Nonterminal, Last_Nonterminal);
+ begin
+ Check_New_Line;
+
+ Table.McKenzie_Param := McKenzie_Param;
+
+ for State of Table.States loop
+ declare
+ Node_I : Action_Node_Ptr := new Action_Node;
+ Actions_Done : Boolean := False;
+ begin
+ State.Action_List := Node_I;
+ loop
+ declare
+ Node_J : Parse_Action_Node_Ptr := new
Parse_Action_Node;
+ Action_Done : Boolean := False;
+ Verb : Parse_Action_Verbs;
+ begin
+ Node_I.Action := Node_J;
+ loop
+ Verb := Next_Parse_Action_Verbs;
+ Node_J.Item :=
+ (case Verb is
+ when Shift => (Verb => Shift, others => <>),
+ when Reduce => (Verb => Reduce, others => <>),
+ when Accept_It => (Verb => Accept_It, others => <>),
+ when Error => (Verb => Error));
+
+ case Verb is
+ when Shift =>
+ Node_J.Item.State := Next_State_Index;
+
+ when Reduce | Accept_It =>
+ Node_J.Item.Production.LHS := Next_Token_ID;
+ Node_J.Item.Production.RHS := Next_Integer;
+ if Next_Boolean then
+ Node_J.Item.Action := Actions
+
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS).Action;
+ else
+ Node_J.Item.Action := null;
+ end if;
+ if Next_Boolean then
+ Node_J.Item.Check := Actions
+
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS).Check;
+ else
+ Node_J.Item.Check := null;
+ end if;
+ Node_J.Item.Token_Count := Next_Count_Type;
+
+ when Error =>
+ Actions_Done := True;
+ end case;
+
+ if Check_Semicolon then
+ Action_Done := True;
+
+ if not Actions_Done then
+ Node_I.Symbol := Next_Token_ID;
+ end if;
+ end if;
+
+ exit when Action_Done;
+
+ Node_J.Next := new Parse_Action_Node;
+ Node_J := Node_J.Next;
+ end loop;
+
+ Check_New_Line;
+ end;
+
+ exit when Actions_Done;
+ Node_I.Next := new Action_Node;
+ Node_I := Node_I.Next;
+ end loop;
+ end;
+
+ if Check_Semicolon then
+ -- No Gotos
+ null;
+ else
+ declare
+ Node_I : Goto_Node_Ptr := new Goto_Node;
+ begin
+ State.Goto_List := Node_I;
+ loop
+ Node_I.Symbol := Next_Token_ID;
+ Node_I.State := Next_State_Index;
+ exit when Check_Semicolon;
+ Node_I.Next := new Goto_Node;
+ Node_I := Node_I.Next;
+ end loop;
+ end;
+ end if;
+ Check_New_Line;
+
+ declare
+ First : constant Integer := Next_Integer;
+ Last : constant Integer := Next_Integer;
+ begin
+ if Last = -1 then
+ -- State.Kernel not set for state 0
+ null;
+ else
+ State.Kernel.Set_First (Count_Type (First));
+ State.Kernel.Set_Last (Count_Type (Last));
+
+ for I in State.Kernel.First_Index .. State.Kernel.Last_Index
loop
+ State.Kernel (I).LHS := Next_Token_ID;
+ State.Kernel (I).Before_Dot := Next_Token_ID;
+ State.Kernel (I).Length_After_Dot := Count_Type
(Next_Integer);
+ end loop;
+ end if;
+ end;
+ Check_New_Line;
+
+ if Check_Semicolon then
+ -- No minimal action
+ null;
+ else
+ State.Minimal_Complete_Actions.Set_First (Count_Type
(Next_Integer));
+ State.Minimal_Complete_Actions.Set_Last (Count_Type
(Next_Integer));
+ for I in State.Minimal_Complete_Actions.First_Index ..
State.Minimal_Complete_Actions.Last_Index loop
+ declare
+ Verb : constant Minimal_Verbs :=
Next_Parse_Action_Verbs;
+ ID : Token_ID;
+ Action_State : State_Index;
+ Count : Ada.Containers.Count_Type;
+ begin
+ case Verb is
+ when Shift =>
+ ID := Next_Token_ID;
+ Action_State := Next_State_Index;
+ State.Minimal_Complete_Actions.Replace_Element (I,
(Shift, ID, Action_State));
+ when Reduce =>
+ ID := Next_Token_ID;
+ Count := Next_Count_Type;
+ State.Minimal_Complete_Actions.Replace_Element (I,
(Reduce, ID, Count));
+ end case;
+ end;
+ end loop;
+ Check_Semicolon;
+ end if;
+ Check_New_Line;
+
+ exit when Check_EOI;
+ end loop;
+ return Table;
+ end;
+ exception
+ when Name_Error =>
+ raise User_Error with "parser table text file '" & File_Name & "' not
found.";
+
+ when SAL.Programmer_Error =>
+ raise;
+
+ when E : others =>
+ raise SAL.Programmer_Error with Error_Message
+ (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
+ Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
+ end Get_Text_Rep;
+
+ function Compare (Left, Right : in Insert_Delete_Op) return
SAL.Compare_Result
+ is
+ Left_Token_Index : constant WisiToken.Token_Index :=
+ (case Insert_Delete_Op_Label'(Left.Op) is
+ when Insert => Left.Ins_Token_Index,
+ when Delete => Left.Del_Token_Index);
+ Right_Token_Index : constant WisiToken.Token_Index :=
+ (case Insert_Delete_Op_Label'(Right.Op) is
+ when Insert => Right.Ins_Token_Index,
+ when Delete => Right.Del_Token_Index);
+ begin
+ if Left_Token_Index < Right_Token_Index then
+ return SAL.Less;
+ elsif Left_Token_Index = Right_Token_Index then
+ return SAL.Equal;
+ else
+ return SAL.Greater;
+ end if;
+ end Compare;
+
+ function Equal (Left : in Config_Op; Right : in Insert_Op) return Boolean
+ is begin
+ return Left.Op = Insert and then
+ Left.Ins_ID = Right.Ins_ID and then
+ Left.Ins_Token_Index = Right.Ins_Token_Index;
+ end Equal;
+
+ function None_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
+ is begin
+ for O of reverse Ops loop
+ exit when O.Op = Fast_Forward;
+ if O.Op = Op then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end None_Since_FF;
+
+ function Only_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Ops.Length = 0 or else Ops (Ops.Last_Index).Op /= Op then
+ return False;
+ else
+ for O of reverse Ops loop
+ exit when O.Op = Fast_Forward;
+ if O.Op /= Op then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end if;
+ end Only_Since_FF;
+
+ function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean
+ is
+ use all type WisiToken.Syntax_Trees.Node_Index;
+ begin
+ for I in 1 .. Depth loop
+ if Stack (I).Tree_Index = Syntax_Trees.Invalid_Node_Index then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end Valid_Tree_Indices;
+
+ procedure Set_Key (Item : in out Configuration; Key : in Integer)
+ is begin
+ Item.Cost := Key;
+ end Set_Key;
+
+ procedure Accumulate (Data : in McKenzie_Data; Counts : in out
Strategy_Counts)
+ is
+ procedure Proc (Config : in Configuration)
+ is begin
+ for I in Config.Strategy_Counts'Range loop
+ Counts (I) := Counts (I) + Config.Strategy_Counts (I);
+ end loop;
+ end Proc;
+ begin
+ Data.Results.Process (Proc'Unrestricted_Access);
+ end Accumulate;
+
+end WisiToken.Parse.LR;
diff --git a/wisitoken-parse-lr.ads b/wisitoken-parse-lr.ads
index 24ca512..91b55c8 100644
--- a/wisitoken-parse-lr.ads
+++ b/wisitoken-parse-lr.ads
@@ -1,627 +1,683 @@
--- Abstract :
---
--- Root package of an implementation of an LR (Left-to-right scanning
--- Rightmost-deriving) parser. Includes operations for building the
--- parse table at runtime. See the child packages .Parse and
--- .Parse_No_Recover for running the parser.
---
--- References :
---
--- See wisitoken.ads
---
--- Copyright (C) 2002, 2003, 2009, 2010, 2013 - 2015, 2017 - 2019 Free
Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers.Indefinite_Doubly_Linked_Lists;
-with Ada.Unchecked_Deallocation;
-with SAL.Gen_Array_Image;
-with SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux;
-with SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted;
-with SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci;
-with SAL.Gen_Unbounded_Definite_Queues.Gen_Image_Aux;
-with SAL.Gen_Unbounded_Definite_Stacks.Gen_Image_Aux;
-with System.Multiprocessors;
-with WisiToken.Productions;
-with WisiToken.Semantic_Checks;
-with WisiToken.Syntax_Trees;
-package WisiToken.Parse.LR is
-
- type All_Parse_Action_Verbs is (Pause, Shift, Reduce, Accept_It, Error);
- subtype Parse_Action_Verbs is All_Parse_Action_Verbs range Shift .. Error;
- subtype Minimal_Verbs is All_Parse_Action_Verbs range Pause .. Reduce;
- -- Pause is only used for error recovery.
-
- type Parse_Action_Rec (Verb : Parse_Action_Verbs := Shift) is record
- case Verb is
- when Shift =>
- State : State_Index := State_Index'Last;
-
- when Reduce | Accept_It =>
- Production : Production_ID;
- -- The result nonterm and production index. Most uses need only
- -- Production.LHS; elisp code generation, and debug output, needs
- -- Production.RHS
-
- Action : WisiToken.Syntax_Trees.Semantic_Action := null;
- Check : WisiToken.Semantic_Checks.Semantic_Check := null;
- Token_Count : Ada.Containers.Count_Type := 0;
-
- when Error =>
- null;
- end case;
- end record;
- subtype Shift_Action_Rec is Parse_Action_Rec (Shift);
- subtype Reduce_Action_Rec is Parse_Action_Rec (Reduce);
-
- function Image (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor) return String;
- -- Ada aggregate syntax, leaving out Action, Check in reduce; for debug
output
-
- procedure Put (Trace : in out WisiToken.Trace'Class; Item : in
Parse_Action_Rec);
- -- Put a line for Item in parse trace format, with no prefix.
-
- function Equal (Left, Right : in Parse_Action_Rec) return Boolean;
- -- Ignore Action, Check.
-
- type Parse_Action_Node;
- type Parse_Action_Node_Ptr is access Parse_Action_Node;
-
- type Parse_Action_Node is record
- Item : Parse_Action_Rec;
- Next : Parse_Action_Node_Ptr; -- non-null only for conflicts
- end record;
- procedure Free is new Ada.Unchecked_Deallocation (Parse_Action_Node,
Parse_Action_Node_Ptr);
-
- type Action_Node;
- type Action_Node_Ptr is access Action_Node;
-
- type Action_Node is record
- Symbol : Token_ID := Invalid_Token_ID; -- ignored if Action is Error
- Action : Parse_Action_Node_Ptr;
- Next : Action_Node_Ptr;
- end record;
- procedure Free is new Ada.Unchecked_Deallocation (Action_Node,
Action_Node_Ptr);
-
- procedure Add
- (List : in out Action_Node_Ptr;
- Symbol : in Token_ID;
- Action : in Parse_Action_Rec);
- -- Add action to List, sorted on ascending Symbol.
-
- type Goto_Node is private;
- type Goto_Node_Ptr is access Goto_Node;
-
- function Symbol (List : in Goto_Node_Ptr) return Token_ID;
- function State (List : in Goto_Node_Ptr) return State_Index;
- function Next (List : in Goto_Node_Ptr) return Goto_Node_Ptr;
-
- type Minimal_Action (Verb : Minimal_Verbs := Pause) is record
- case Verb is
- when Pause =>
- -- In this case, 'Pause' means no minimal action.
- null;
-
- when Shift =>
- ID : Token_ID;
- State : State_Index;
-
- when Reduce =>
- Nonterm : Token_ID;
- Token_Count : Ada.Containers.Count_Type;
- end case;
- end record;
-
- function Strict_Image (Item : in Minimal_Action) return String;
- -- Strict Ada aggregate syntax, for generated code.
-
- type Parse_State is record
- Productions : Production_ID_Arrays.Vector;
- -- Used in some language-specfic error recovery.
- Action_List : Action_Node_Ptr;
- Goto_List : Goto_Node_Ptr;
-
- Minimal_Complete_Action : Minimal_Action;
- -- Parse action that will most quickly complete a
- -- production in this state; used in error recovery
- end record;
-
- type Parse_State_Array is array (State_Index range <>) of Parse_State;
-
- type Action_List_Iterator is tagged private;
- -- Iterates over all shift/reduce actions for a state, including
- -- conflicts.
-
- function First (State : in Parse_State) return Action_List_Iterator;
- function Is_Done (Iter : in Action_List_Iterator) return Boolean;
- procedure Next (Iter : in out Action_List_Iterator);
-
- function Symbol (Iter : in Action_List_Iterator) return Token_ID;
- function Action (Iter : in Action_List_Iterator) return Parse_Action_Rec;
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbol : in Token_ID;
- State_Index : in WisiToken.State_Index);
- -- Add a Shift action to tail of State action list.
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbol : in Token_ID;
- Verb : in Parse_Action_Verbs;
- Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
- -- Add a Reduce or Accept_It action to tail of State action list.
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbols : in Token_ID_Array;
- Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
- -- Add duplicate Reduce actions, and final Error action, to tail of
- -- State action list.
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbol : in Token_ID;
- State_Index : in WisiToken.State_Index;
- Reduce_Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
- -- Add a Shift/Reduce conflict to State.
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbol : in Token_ID;
- Verb : in Parse_Action_Verbs;
- Production_1 : in Production_ID;
- RHS_Token_Count_1 : in Ada.Containers.Count_Type;
- Semantic_Action_1 : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check_1 : in WisiToken.Semantic_Checks.Semantic_Check;
- Production_2 : in Production_ID;
- RHS_Token_Count_2 : in Ada.Containers.Count_Type;
- Semantic_Action_2 : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check_2 : in WisiToken.Semantic_Checks.Semantic_Check);
- -- Add an Accept/Reduce or Reduce/Reduce conflict action to State.
-
- procedure Add_Error (State : in out Parse_State);
- -- Add an Error action to State, at tail of action list.
-
- procedure Add_Goto
- (State : in out Parse_State;
- Symbol : in Token_ID;
- To_State : in State_Index);
- -- Add a goto item to State goto list; keep goto list sorted in ascending
order on Symbol.
-
- type McKenzie_Param_Type
- (First_Terminal : Token_ID;
- Last_Terminal : Token_ID;
- First_Nonterminal : Token_ID;
- Last_Nonterminal : Token_ID)
- is record
- Insert : Token_ID_Array_Natural (First_Terminal .. Last_Terminal);
- Delete : Token_ID_Array_Natural (First_Terminal .. Last_Terminal);
- Push_Back : Token_ID_Array_Natural (First_Terminal .. Last_Nonterminal);
- -- Cost of operations on config stack, input.
-
- Ignore_Check_Fail : Natural;
- -- Cost of ignoring a semantic check failure. Should be at least the
- -- cost of a typical fix for such a failure.
-
- Task_Count : System.Multiprocessors.CPU_Range;
- -- Number of parallel tasks during recovery. If 0, use
- -- System.Multiprocessors.Number_Of_CPUs - 1.
-
- Cost_Limit : Natural; -- max cost of configurations to look at
- Check_Limit : Token_Index; -- max tokens to parse ahead when
checking a configuration.
- Check_Delta_Limit : Natural; -- max configs checked, delta over
successful parser.
- Enqueue_Limit : Natural; -- max configs enqueued.
- end record;
-
- Default_McKenzie_Param : constant McKenzie_Param_Type :=
- (First_Terminal => Token_ID'Last,
- Last_Terminal => Token_ID'First,
- First_Nonterminal => Token_ID'Last,
- Last_Nonterminal => Token_ID'First,
- Insert => (others => 0),
- Delete => (others => 0),
- Push_Back => (others => 0),
- Ignore_Check_Fail => 0,
- Task_Count => System.Multiprocessors.CPU_Range'Last,
- Cost_Limit => Natural'Last,
- Check_Limit => Token_Index'Last,
- Check_Delta_Limit => Natural'Last,
- Enqueue_Limit => Natural'Last);
-
- procedure Set_Production
- (Prod : in out Productions.Instance;
- LHS : in Token_ID;
- RHS_Last : in Natural);
-
- procedure Set_RHS
- (Prod : in out Productions.Instance;
- RHS_Index : in Natural;
- Tokens : in Token_ID_Array;
- Action : in WisiToken.Syntax_Trees.Semantic_Action := null;
- Check : in WisiToken.Semantic_Checks.Semantic_Check := null);
-
- type Parse_Table
- (State_First : State_Index;
- State_Last : State_Index;
- First_Terminal : Token_ID;
- Last_Terminal : Token_ID;
- First_Nonterminal : Token_ID;
- Last_Nonterminal : Token_ID)
- is tagged
- record
- States : Parse_State_Array (State_First .. State_Last);
- McKenzie_Param : McKenzie_Param_Type (First_Terminal, Last_Terminal,
First_Nonterminal, Last_Nonterminal);
- end record;
-
- function Goto_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Unknown_State_Index;
- function Goto_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Goto_Node_Ptr;
- -- Return next state after reducing stack by nonterminal ID;
- -- Unknown_State if none (only possible during error recovery).
- -- Second form allows retrieving Production.
-
- function Action_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Parse_Action_Node_Ptr;
- -- Return the action for State, terminal ID.
-
- function Expecting (Table : in Parse_Table; State : in State_Index) return
Token_ID_Set;
-
- type Parse_Table_Ptr is access Parse_Table;
- procedure Free_Table (Table : in out Parse_Table_Ptr);
-
- function Get_Action
- (Prod : in Production_ID;
- Productions : in WisiToken.Productions.Prod_Arrays.Vector)
- return WisiToken.Syntax_Trees.Semantic_Action;
-
- function Get_Check
- (Prod : in Production_ID;
- Productions : in WisiToken.Productions.Prod_Arrays.Vector)
- return WisiToken.Semantic_Checks.Semantic_Check;
-
- function Get_Text_Rep
- (File_Name : in String;
- McKenzie_Param : in McKenzie_Param_Type;
- Productions : in WisiToken.Productions.Prod_Arrays.Vector)
- return Parse_Table_Ptr;
- -- Read machine-readable text format of states (as output by
- -- WisiToken.Generate.LR.Put_Text_Rep) from file File_Name. Result
- -- has actions, checks from Productions.
-
- ----------
- -- For McKenzie_Recover. Declared here because Parser_Lists needs
- -- these, Mckenzie_Recover needs Parser_Lists.
- --
- -- We don't maintain a syntax tree during recover; it's too slow, and
- -- not needed for any operations. The parser syntax tree is used for
- -- Undo_Reduce, which is only done on nonterms reduced by the main
- -- parser, not virtual nonterms produced by recover.
-
- package Fast_Token_ID_Arrays is new SAL.Gen_Bounded_Definite_Vectors
- (SAL.Peek_Type, Token_ID, Capacity => 20);
-
- No_Insert_Delete : constant SAL.Base_Peek_Type := 0;
-
- function Image
- (Index : in SAL.Peek_Type;
- Tokens : in Fast_Token_ID_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return String
- is (SAL.Peek_Type'Image (Index) & ":" & SAL.Peek_Type'Image
(Tokens.Last_Index) & ":" &
- Image (Tokens (Index), Descriptor));
-
- type Config_Op_Label is (Fast_Forward, Undo_Reduce, Push_Back, Insert,
Delete);
- subtype Insert_Delete_Op_Label is Config_Op_Label range Insert .. Delete;
- -- Fast_Forward is a placeholder to mark a fast_forward parse; that
- -- resets what operations are allowed to be done on a config.
- --
- -- Undo_Reduce is the inverse of Reduce.
- --
- -- Push_Back pops the top stack item, and moves the input stream
- -- pointer back to the first shared_terminal contained by that item.
- --
- -- Insert inserts a new token in the token input stream, before the
- -- given point in Terminals.
- --
- -- Delete deletes one item from the token input stream, at the given
- -- point.
-
- type Config_Op (Op : Config_Op_Label := Fast_Forward) is record
- -- We store enough information to perform the operation on the main
- -- parser stack and input stream point when the config is the result
- -- of a successful recover.
- --
- -- After a recover, the main parser must reparse any inserted tokens,
- -- and skip any deleted tokens. Therefore, when all the recover ops
- -- are applied, the main parser stack will be the same or shorter
- -- than it was, so we only need to store token counts for stack
- -- operations (Unknown_State is pushed when a state is needed; none
- -- will be left on the main stack). We also store IDs, so we can
- -- check that everything is in sync, and for debugging.
-
- case Op is
- when Fast_Forward =>
- FF_Token_Index : WisiToken.Token_Index;
- -- Config.Current_Shared_Token after the operation is done; the last
- -- token shifted.
-
- when Undo_Reduce =>
- Nonterm : Token_ID;
- -- The nonterminal popped off the stack.
-
- Token_Count : Ada.Containers.Count_Type;
- -- The number of tokens pushed on the stack.
-
- when Push_Back | Insert | Delete =>
- ID : Token_ID;
- -- For Push_Back, ID is the nonterm ID popped off the stack.
- -- For Insert | Delete, ID is the token inserted or deleted.
-
- Token_Index : WisiToken.Base_Token_Index;
- -- For Push_Back, Token_Index is Config.Current_Shared_Token after
- -- the operation is done. If the token is empty, Token_Index is
- -- Invalid_Token_Index.
- --
- -- For Insert, ID is inserted before Token_Index.
- --
- -- For Delete, token at Token_Index is deleted.
-
- end case;
- end record;
- subtype Insert_Delete_Op is Config_Op with Dynamic_Predicate =>
(Insert_Delete_Op.Op in Insert_Delete_Op_Label);
-
- function Compare (Left, Right : in Insert_Delete_Op) return
SAL.Compare_Result;
-
- package Config_Op_Queues is new SAL.Gen_Unbounded_Definite_Queues
(Config_Op);
-
- package Config_Op_Arrays is new SAL.Gen_Bounded_Definite_Vectors
- (Positive_Index_Type, Config_Op, Capacity => 80);
- -- Using a fixed size vector significantly speeds up
- -- McKenzie_Recover. The capacity is determined by the maximum number
- -- of repair operations, which is limited by the cost_limit McKenzie
- -- parameter plus an arbitrary number from the language-specific
- -- repairs; in practice, a capacity of 80 is enough so far. If a
- -- config does hit that limit, it is abandoned; some other config is
- -- likely to be cheaper.
-
- package Insert_Delete_Arrays is new SAL.Gen_Bounded_Definite_Vectors
- (Positive_Index_Type, Insert_Delete_Op, Capacity => 80);
-
- package Sorted_Insert_Delete_Arrays is new Insert_Delete_Arrays.Gen_Sorted
(Compare);
-
- function Config_Op_Image (Item : in Config_Op; Descriptor : in
WisiToken.Descriptor) return String
- is ("(" & Config_Op_Label'Image (Item.Op) & ", " &
- (case Item.Op is
- when Fast_Forward => WisiToken.Token_Index'Image
(Item.FF_Token_Index),
- when Undo_Reduce => Image (Item.Nonterm, Descriptor) & "," &
- Ada.Containers.Count_Type'Image (Item.Token_Count),
- when Push_Back | Insert | Delete => Image (Item.ID, Descriptor) &
"," &
- WisiToken.Token_Index'Image (Item.Token_Index))
- & ")");
-
- function Image (Item : in Config_Op; Descriptor : in WisiToken.Descriptor)
return String
- renames Config_Op_Image;
-
- function Image is new Config_Op_Queues.Gen_Image_Aux (WisiToken.Descriptor,
Image);
- function Config_Op_Array_Image is new Config_Op_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
- function Image (Item : in Config_Op_Arrays.Vector; Descriptor : in
WisiToken.Descriptor) return String
- renames Config_Op_Array_Image;
-
- function None (Ops : in Config_Op_Arrays.Vector; Op : in Config_Op_Label)
return Boolean
- is (for all O of Ops => O.Op /= Op);
- -- True if Ops contains no Op.
-
- function None_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
- -- True if Ops contains no Op after the last Fast_Forward (or ops.first, if
- -- no Fast_Forward).
-
- function Match_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op) return Boolean;
- -- True if Ops contains an Op after the last Fast_Forward (or ops.first, if
- -- no Fast_Forward) that equals Op.
-
- function Any (Ops : in Config_Op_Arrays.Vector; Op : in Config_Op_Label)
return Boolean
- is (for some O of Ops => O.Op = Op);
- -- True if Ops contains at least one Op.
-
- type Recover_Stack_Item is record
- State : Unknown_State_Index;
- Tree_Index : Syntax_Trees.Node_Index;
- Token : Recover_Token;
- end record;
-
- package Recover_Stacks is new SAL.Gen_Unbounded_Definite_Stacks
(Recover_Stack_Item);
-
- function Image (Item : in Recover_Stack_Item; Descriptor : in
WisiToken.Descriptor) return String
- is ((if Item.State = Unknown_State then " " else Trimmed_Image
(Item.State)) & " : " &
- Image (Item.Token, Descriptor));
-
- function Recover_Stack_Image is new Recover_Stacks.Gen_Image_Aux
(WisiToken.Descriptor, Image);
- -- Unique name for calling from debugger
-
- function Image
- (Stack : in Recover_Stacks.Stack;
- Descriptor : in WisiToken.Descriptor;
- Depth : in SAL.Base_Peek_Type := 0)
- return String
- renames Recover_Stack_Image;
-
- function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean;
- -- Return True if Stack top Depth items have valid Tree_Indices,
- -- which is true if they were copied from the parser stack, and not
- -- pushed by recover.
-
- type Strategies is (Language_Fix, Minimal_Complete, Matching_Begin,
Explore_Table, String_Quote);
-
- type Strategy_Counts is array (Strategies) of Natural;
- function Image is new SAL.Gen_Array_Image (Strategies, Natural,
Strategy_Counts, Trimmed_Image);
-
- type Configuration is record
- Stack : Recover_Stacks.Stack;
- -- Initially built from the parser stack, then the stack after the
- -- Ops below have been performed.
-
- Resume_Token_Goal : Token_Index := Token_Index'Last;
- -- A successful solution shifts this token. Per-config because it
- -- increases with Delete; we increase Shared_Parser.Resume_Token_Goal
- -- only from successful configs.
-
- Current_Shared_Token : Base_Token_Index := Token_Index'Last;
- -- Index into Shared_Parser.Terminals for current input token, after
- -- all of Inserted is input. Initially the error token.
-
- String_Quote_Checked : Line_Number_Type := Invalid_Line_Number;
- -- Max line checked for missing string quote.
-
- Insert_Delete : Sorted_Insert_Delete_Arrays.Vector;
- -- Edits to the input stream that are not yet parsed; contains only
- -- Insert and Delete ops, in token_index order.
-
- Current_Insert_Delete : SAL.Base_Peek_Type := No_Insert_Delete;
- -- Index of the next op in Insert_Delete. If No_Insert_Delete, use
- -- Current_Shared_Token.
-
- Error_Token : Recover_Token;
- Check_Token_Count : Ada.Containers.Count_Type;
- Check_Status : Semantic_Checks.Check_Status;
- -- If parsing this config ended with a parse error, Error_Token is
- -- the token that failed to shift, Check_Status.Label is Ok.
- --
- -- If parsing this config ended with a semantic check fail,
- -- Error_Token is the nonterm created by the reduction,
- -- Check_Token_Count the number of tokens in the right hand side, and
- -- Check_Status is the error.
- --
- -- Error_Token is set to Invalid_Token_ID when Config is parsed
- -- successfully, or modified so the error is no longer meaningful (ie
- -- in explore when adding an op, or in language_fixes when adding a
- -- fix).
-
- Ops : Config_Op_Arrays.Vector;
- -- Record of operations applied to this Config, in application order.
- -- Insert and Delete ops that are not yet parsed are reflected in
- -- Insert_Delete, in token_index order.
-
- Current_Ops : SAL.Base_Peek_Type := No_Insert_Delete;
- -- If No_Insert_Delete, append new ops to Ops. Otherwise insert
- -- before Current_Ops. This happens when Fast_Forward fails with the
- -- remaining ops at Current_Shared_Token.
-
- Cost : Natural := 0;
-
- Strategy_Counts : LR.Strategy_Counts := (others => 0);
- -- Count of strategies that produced Ops.
- end record;
- type Configuration_Access is access all Configuration;
- for Configuration_Access'Storage_Size use 0;
-
- function Key (A : in Configuration) return Integer is (A.Cost);
-
- procedure Set_Key (Item : in out Configuration; Key : in Integer);
-
- package Config_Heaps is new SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci
- (Element_Type => Configuration,
- Element_Access => Configuration_Access,
- Key_Type => Integer,
- Key => Key,
- Set_Key => Set_Key);
-
- type Check_Status is (Success, Abandon, Continue);
- subtype Non_Success_Status is Check_Status range Abandon .. Continue;
-
- type McKenzie_Data is tagged record
- Config_Heap : Config_Heaps.Heap_Type;
- Enqueue_Count : Integer := 0;
- Check_Count : Integer := 0;
- Results : Config_Heaps.Heap_Type;
- Success : Boolean := False;
- end record;
- type McKenzie_Access is access all McKenzie_Data;
-
- procedure Accumulate (Data : in McKenzie_Data; Counts : in out
Strategy_Counts);
- -- Sum Results.Strategy_Counts.
-
- type Parse_Error_Label is (Action, Check, Message);
-
- type Parse_Error
- (Label : Parse_Error_Label;
- First_Terminal : Token_ID;
- Last_Terminal : Token_ID)
- is record
- Recover : Configuration;
-
- case Label is
- when Action =>
- Error_Token : Syntax_Trees.Valid_Node_Index; -- index into Parser.Tree
- Expecting : Token_ID_Set (First_Terminal .. Last_Terminal);
-
- when Check =>
- Check_Status : Semantic_Checks.Check_Status;
-
- when Message =>
- Msg : Ada.Strings.Unbounded.Unbounded_String;
- end case;
- end record;
-
- package Parse_Error_Lists is new
Ada.Containers.Indefinite_Doubly_Linked_Lists (Parse_Error);
-
- function Image
- (Item : in Parse_Error;
- Tree : in Syntax_Trees.Tree;
- Descriptor : in WisiToken.Descriptor)
- return String;
-
-private
-
- type Goto_Node is record
- Symbol : Token_ID;
- State : State_Index;
- Next : Goto_Node_Ptr;
- end record;
- procedure Free is new Ada.Unchecked_Deallocation (Goto_Node, Goto_Node_Ptr);
-
- type Action_List_Iterator is tagged record
- Node : Action_Node_Ptr;
- Item : Parse_Action_Node_Ptr;
- end record;
-
-end WisiToken.Parse.LR;
+-- Abstract :
+--
+-- Root package of an implementation of an LR (Left-to-right scanning
+-- Rightmost-deriving) parser. Includes operations for building the
+-- parse table at runtime. See the child packages .Parse and
+-- .Parse_No_Recover for running the parser.
+--
+-- References :
+--
+-- See wisitoken.ads
+--
+-- Copyright (C) 2002, 2003, 2009, 2010, 2013 - 2015, 2017 - 2019 Free
Software Foundation, Inc.
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers.Indefinite_Doubly_Linked_Lists;
+with Ada.Unchecked_Deallocation;
+with SAL.Gen_Array_Image;
+with SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux;
+with SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted;
+with SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci;
+with SAL.Gen_Unbounded_Definite_Queues.Gen_Image_Aux;
+with SAL.Gen_Unbounded_Definite_Stacks.Gen_Image_Aux;
+with System.Multiprocessors;
+with WisiToken.Semantic_Checks;
+with WisiToken.Syntax_Trees;
+package WisiToken.Parse.LR is
+
+ type All_Parse_Action_Verbs is (Pause, Shift, Reduce, Accept_It, Error);
+ subtype Parse_Action_Verbs is All_Parse_Action_Verbs range Shift .. Error;
+ subtype Minimal_Verbs is All_Parse_Action_Verbs range Shift .. Reduce;
+ -- Pause is only used for error recovery, to allow parallel parsers
+ -- to re-sync on the same input terminal.
+
+ subtype Token_ID_Array_1_3 is Token_ID_Array (1 .. 3);
+ -- For Use_Minimal_Complete_Actions in McDenzie_Recover.
+
+ type Parse_Action_Rec (Verb : Parse_Action_Verbs := Shift) is record
+ case Verb is
+ when Shift =>
+ State : State_Index := State_Index'Last;
+
+ when Reduce | Accept_It =>
+ Production : Production_ID;
+ -- The result nonterm and production index. Most uses need only
+ -- Production.LHS; elisp code generation, and debug output, needs
+ -- Production.RHS
+
+ Action : WisiToken.Syntax_Trees.Semantic_Action := null;
+ Check : WisiToken.Semantic_Checks.Semantic_Check := null;
+ Token_Count : Ada.Containers.Count_Type := 0;
+
+ when Error =>
+ null;
+ end case;
+ end record;
+ subtype Shift_Action_Rec is Parse_Action_Rec (Shift);
+ subtype Reduce_Action_Rec is Parse_Action_Rec (Reduce);
+
+ function Image (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor) return String;
+ -- Ada aggregate syntax, leaving out Action, Check in reduce; for debug
output
+
+ procedure Put (Trace : in out WisiToken.Trace'Class; Item : in
Parse_Action_Rec);
+ -- Put a line for Item in parse trace format, with no prefix.
+
+ function Equal (Left, Right : in Parse_Action_Rec) return Boolean;
+ -- Ignore Action, Check.
+
+ type Parse_Action_Node;
+ type Parse_Action_Node_Ptr is access Parse_Action_Node;
+
+ type Parse_Action_Node is record
+ Item : Parse_Action_Rec;
+ Next : Parse_Action_Node_Ptr; -- non-null only for conflicts
+ end record;
+ procedure Free is new Ada.Unchecked_Deallocation (Parse_Action_Node,
Parse_Action_Node_Ptr);
+
+ function Is_In (Item : in Parse_Action_Rec; List : in
Parse_Action_Node_Ptr) return Boolean;
+ -- True if Item is Equal to any element of List.
+
+ type Action_Node;
+ type Action_Node_Ptr is access Action_Node;
+
+ type Action_Node is record
+ Symbol : Token_ID := Invalid_Token_ID; -- ignored if Action is Error
+ Action : Parse_Action_Node_Ptr;
+ Next : Action_Node_Ptr;
+ end record;
+ procedure Free is new Ada.Unchecked_Deallocation (Action_Node,
Action_Node_Ptr);
+
+ function Find
+ (Symbol : in Token_ID;
+ Action_List : in Action_Node_Ptr)
+ return Action_Node_Ptr;
+
+ procedure Add
+ (List : in out Action_Node_Ptr;
+ Symbol : in Token_ID;
+ Action : in Parse_Action_Rec);
+ -- Add action to List, sorted on ascending Symbol.
+
+ type Goto_Node is private;
+ type Goto_Node_Ptr is access Goto_Node;
+
+ function Symbol (List : in Goto_Node_Ptr) return Token_ID;
+ function State (List : in Goto_Node_Ptr) return State_Index;
+ function Next (List : in Goto_Node_Ptr) return Goto_Node_Ptr;
+
+ type Kernel_Info is record
+ LHS : Token_ID := Token_ID'First;
+ Before_Dot : Token_ID := Token_ID'First;
+ Length_After_Dot : Ada.Containers.Count_Type := 0;
+ Recursive : Boolean := False;
+ end record;
+
+ function Strict_Image (Item : in Kernel_Info) return String;
+
+ type Kernel_Info_Array is array (Ada.Containers.Count_Type range <>) of
Kernel_Info;
+ package Kernel_Info_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Ada.Containers.Count_Type, Kernel_Info, (others => <>));
+
+ function To_Vector (Item : in Kernel_Info_Array) return
Kernel_Info_Arrays.Vector;
+
+ function Image is new Kernel_Info_Arrays.Gen_Image (Strict_Image);
+
+ type Minimal_Action (Verb : Minimal_Verbs := Shift) is record
+ case Verb is
+ when Shift =>
+ ID : Token_ID := Invalid_Token_ID;
+ State : State_Index := State_Index'Last;
+
+ when Reduce =>
+ Nonterm : Token_ID;
+ Token_Count : Ada.Containers.Count_Type;
+ end case;
+ end record;
+
+ function Strict_Image (Item : in Minimal_Action) return String;
+ -- Strict Ada aggregate syntax, for generated code.
+
+ function Image (Item : in Minimal_Action; Descriptor : in
WisiToken.Descriptor) return String;
+ -- For debugging
+
+ type Minimal_Action_Array is array (Ada.Containers.Count_Type range <>) of
Minimal_Action;
+ package Minimal_Action_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Ada.Containers.Count_Type, Minimal_Action, (others => <>));
+
+ function To_Vector (Item : in Minimal_Action_Array) return
Minimal_Action_Arrays.Vector;
+
+ function Image is new Minimal_Action_Arrays.Gen_Image_Aux (Descriptor,
Trimmed_Image, Image);
+ function Strict_Image is new Minimal_Action_Arrays.Gen_Image (Strict_Image);
+
+ type Parse_State is record
+ Action_List : Action_Node_Ptr;
+ Goto_List : Goto_Node_Ptr;
+
+ -- The following are used in error recovery.
+ Kernel : Kernel_Info_Arrays.Vector;
+
+ Minimal_Complete_Actions : Minimal_Action_Arrays.Vector;
+ Minimal_Complete_Actions_Recursive : Boolean := False;
+ -- Parse actions that will most quickly complete a production in this
+ -- state. If more than one, resolved at runtime using Kernels. If
+ -- Minimal_Complete_Actions_Recursive, at least one of the minimal
+ -- actions is recursive; this changes the algorithm.
+ end record;
+
+ type Parse_State_Array is array (State_Index range <>) of Parse_State;
+
+ type Action_List_Iterator is tagged private;
+ -- Iterates over all shift/reduce actions for a state, including
+ -- conflicts.
+
+ function First (State : in Parse_State) return Action_List_Iterator;
+ function Is_Done (Iter : in Action_List_Iterator) return Boolean;
+ procedure Next (Iter : in out Action_List_Iterator);
+
+ function Symbol (Iter : in Action_List_Iterator) return Token_ID;
+ function Action (Iter : in Action_List_Iterator) return Parse_Action_Rec;
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbol : in Token_ID;
+ State_Index : in WisiToken.State_Index);
+ -- Add a Shift action to tail of State action list.
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbol : in Token_ID;
+ Verb : in Parse_Action_Verbs;
+ Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
+ -- Add a Reduce or Accept_It action to tail of State action list.
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbols : in Token_ID_Array;
+ Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
+ -- Add duplicate Reduce actions, and final Error action, to tail of
+ -- State action list.
+
+ procedure Add_Conflict
+ (State : in out Parse_State;
+ Symbol : in Token_ID;
+ Reduce_Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
+ -- Add a Reduce conflict to State.
+
+ procedure Add_Error (State : in out Parse_State);
+ -- Add an Error action to State, at tail of action list.
+
+ procedure Add_Goto
+ (State : in out Parse_State;
+ Symbol : in Token_ID;
+ To_State : in State_Index);
+ -- Add a goto item to State goto list; keep goto list sorted in ascending
order on Symbol.
+
+ type McKenzie_Param_Type
+ (First_Terminal : Token_ID;
+ Last_Terminal : Token_ID;
+ First_Nonterminal : Token_ID;
+ Last_Nonterminal : Token_ID)
+ is record
+ Insert : Token_ID_Array_Natural (First_Terminal .. Last_Terminal);
+ Delete : Token_ID_Array_Natural (First_Terminal .. Last_Terminal);
+ Push_Back : Token_ID_Array_Natural (First_Terminal ..
Last_Nonterminal);
+ Undo_Reduce : Token_ID_Array_Natural (First_Nonterminal ..
Last_Nonterminal);
+ -- Cost of operations on config stack, input.
+
+ Minimal_Complete_Cost_Delta : Integer;
+ -- Reduction in cost due to using Minimal_Complete_Action.
+
+ Matching_Begin : Integer;
+ -- Cost of Matching_Begin strategy (applied once, independent of
+ -- token count).
+
+ Fast_Forward : Integer;
+ -- Cost of moving the edit point forward over input tokens.
+
+ Ignore_Check_Fail : Natural;
+ -- Cost of ignoring a semantic check failure. Should be at least the
+ -- cost of a typical fix for such a failure.
+
+ Task_Count : System.Multiprocessors.CPU_Range;
+ -- Number of parallel tasks during recovery. If 0, use
+ -- System.Multiprocessors.Number_Of_CPUs - 1.
+
+ Check_Limit : Token_Index; -- max tokens to parse ahead when
checking a configuration.
+ Check_Delta_Limit : Natural; -- max configs checked, delta over
successful parser.
+ Enqueue_Limit : Natural; -- max configs enqueued.
+ end record;
+
+ Default_McKenzie_Param : constant McKenzie_Param_Type :=
+ (First_Terminal => Token_ID'Last,
+ Last_Terminal => Token_ID'First,
+ First_Nonterminal => Token_ID'Last,
+ Last_Nonterminal => Token_ID'First,
+ Insert => (others => 0),
+ Delete => (others => 0),
+ Push_Back => (others => 0),
+ Undo_Reduce => (others => 0),
+ Minimal_Complete_Cost_Delta => -1,
+ Fast_Forward => 0,
+ Matching_Begin => 0,
+ Ignore_Check_Fail => 0,
+ Task_Count => System.Multiprocessors.CPU_Range'Last,
+ Check_Limit => 4,
+ Check_Delta_Limit => Natural'Last,
+ Enqueue_Limit => Natural'Last);
+
+ type Parse_Table
+ (State_First : State_Index;
+ State_Last : State_Index;
+ First_Terminal : Token_ID;
+ Last_Terminal : Token_ID;
+ First_Nonterminal : Token_ID;
+ Last_Nonterminal : Token_ID)
+ is tagged
+ record
+ States : Parse_State_Array (State_First .. State_Last);
+ McKenzie_Param : McKenzie_Param_Type (First_Terminal, Last_Terminal,
First_Nonterminal, Last_Nonterminal);
+ end record;
+
+ function Goto_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Unknown_State_Index;
+ function Goto_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Goto_Node_Ptr;
+ -- Return next state after reducing stack by nonterminal ID;
+ -- Unknown_State if none (only possible during error recovery).
+ -- Second form allows retrieving Production.
+
+ function Action_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Parse_Action_Node_Ptr;
+ -- Return the action for State, terminal ID.
+
+ function Expecting (Table : in Parse_Table; State : in State_Index) return
Token_ID_Set;
+
+ type Parse_Table_Ptr is access Parse_Table;
+ procedure Free_Table (Table : in out Parse_Table_Ptr);
+
+ type Semantic_Action is record
+ Action : WisiToken.Syntax_Trees.Semantic_Action := null;
+ Check : WisiToken.Semantic_Checks.Semantic_Check := null;
+ end record;
+
+ package Semantic_Action_Arrays is new SAL.Gen_Unbounded_Definite_vectors
(Natural, Semantic_Action, (others => <>));
+ package Semantic_Action_Array_Arrays is new
SAL.Gen_Unbounded_Definite_Vectors
+ (Token_ID, Semantic_Action_Arrays.Vector,
Semantic_Action_Arrays.Empty_Vector);
+
+ function Get_Text_Rep
+ (File_Name : in String;
+ McKenzie_Param : in McKenzie_Param_Type;
+ Actions : in Semantic_Action_Array_Arrays.Vector)
+ return Parse_Table_Ptr;
+ -- Read machine-readable text format of states (as output by
+ -- WisiToken.Generate.LR.Put_Text_Rep) from file File_Name. Result
+ -- has actions, checks from Productions.
+
+ ----------
+ -- For McKenzie_Recover. Declared here because Parser_Lists needs
+ -- these, Mckenzie_Recover needs Parser_Lists.
+ --
+ -- We don't maintain a syntax tree during recover; it's too slow, and
+ -- not needed for any operations. The parser syntax tree is used for
+ -- Undo_Reduce, which is only done on nonterms reduced by the main
+ -- parser, not virtual nonterms produced by recover.
+
+ package Fast_Token_ID_Arrays is new SAL.Gen_Bounded_Definite_Vectors
+ (SAL.Peek_Type, Token_ID, Capacity => 20);
+
+ No_Insert_Delete : constant SAL.Base_Peek_Type := 0;
+
+ function Image
+ (Index : in SAL.Peek_Type;
+ Tokens : in Fast_Token_ID_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is (SAL.Peek_Type'Image (Index) & ":" & SAL.Peek_Type'Image
(Tokens.Last_Index) & ":" &
+ Image (Tokens (Index), Descriptor));
+
+ type Config_Op_Label is (Fast_Forward, Undo_Reduce, Push_Back, Insert,
Delete);
+ subtype Insert_Delete_Op_Label is Config_Op_Label range Insert .. Delete;
+ -- Fast_Forward is a placeholder to mark a fast_forward parse; that
+ -- resets what operations are allowed to be done on a config.
+ --
+ -- Undo_Reduce is the inverse of Reduce.
+ --
+ -- Push_Back pops the top stack item, and moves the input stream
+ -- pointer back to the first shared_terminal contained by that item.
+ --
+ -- Insert inserts a new token in the token input stream, before the
+ -- given point in Terminals.
+ --
+ -- Delete deletes one item from the token input stream, at the given
+ -- point.
+
+ type Config_Op (Op : Config_Op_Label := Fast_Forward) is record
+ -- We store enough information to perform the operation on the main
+ -- parser stack and input stream when the config is the result
+ -- of a successful recover.
+
+ case Op is
+ when Fast_Forward =>
+ FF_Token_Index : WisiToken.Token_Index;
+ -- Config.Current_Shared_Token after the operation is done; the last
+ -- token shifted.
+
+ when Undo_Reduce =>
+ Nonterm : Token_ID;
+ -- The nonterminal popped off the stack.
+
+ Token_Count : Ada.Containers.Count_Type;
+ -- The number of tokens pushed on the stack.
+
+ when Push_Back =>
+ PB_ID : Token_ID;
+ -- The nonterm ID popped off the stack.
+
+ PB_Token_Index : WisiToken.Base_Token_Index;
+ -- Config.Current_Shared_Token after
+ -- the operation is done. If the token is empty, Token_Index is
+ -- Invalid_Token_Index.
+
+ when Insert =>
+ Ins_ID : Token_ID;
+ -- The token ID inserted.
+
+ Ins_Token_Index : WisiToken.Base_Token_Index;
+ -- Ins_ID is inserted before Token_Index.
+
+ State : Unknown_State_Index;
+ Stack_Depth : SAL.Base_Peek_Type;
+ -- Used in Minimal_Completion_Actions to detect cycles; only set for
+ -- Insert by Minimal_Completion_Actions.
+
+ when Delete =>
+ Del_ID : Token_ID;
+ -- The token ID deleted.
+
+ Del_Token_Index : WisiToken.Base_Token_Index;
+ -- Token at Token_Index is deleted.
+
+ end case;
+ end record;
+ subtype Insert_Delete_Op is Config_Op with Dynamic_Predicate =>
(Insert_Delete_Op.Op in Insert_Delete_Op_Label);
+ subtype Insert_Op is Config_Op with Dynamic_Predicate => (Insert_Op.Op =
Insert);
+
+ function Token_Index (Op : in Insert_Delete_Op) return WisiToken.Token_Index
+ is (case Insert_Delete_Op_Label'(Op.Op) is
+ when Insert => Op.Ins_Token_Index,
+ when Delete => Op.Del_Token_Index);
+
+ function ID (Op : in Insert_Delete_Op) return WisiToken.Token_ID
+ is (case Insert_Delete_Op_Label'(Op.Op) is
+ when Insert => Op.Ins_ID,
+ when Delete => Op.Del_ID);
+
+ function Compare (Left, Right : in Insert_Delete_Op) return
SAL.Compare_Result;
+ -- Compare token_index.
+
+ function Equal (Left : in Config_Op; Right : in Insert_Op) return Boolean;
+ -- Ignore state, stack_depth
+
+ package Config_Op_Queues is new SAL.Gen_Unbounded_Definite_Queues
(Config_Op);
+
+ package Config_Op_Arrays is new SAL.Gen_Bounded_Definite_Vectors
+ (Positive_Index_Type, Config_Op, Capacity => 80);
+ -- Using a fixed size vector significantly speeds up
+ -- McKenzie_Recover. The capacity is determined by the maximum number
+ -- of repair operations, which is limited by the cost_limit McKenzie
+ -- parameter plus an arbitrary number from the language-specific
+ -- repairs; in practice, a capacity of 80 is enough so far. If a
+ -- config does hit that limit, it is abandoned; some other config is
+ -- likely to be cheaper.
+
+ function Config_Op_Image (Item : in Config_Op; Descriptor : in
WisiToken.Descriptor) return String
+ is ("(" & Config_Op_Label'Image (Item.Op) & ", " &
+ (case Item.Op is
+ when Fast_Forward => WisiToken.Token_Index'Image
(Item.FF_Token_Index),
+ when Undo_Reduce => Image (Item.Nonterm, Descriptor) & "," &
+ Ada.Containers.Count_Type'Image (Item.Token_Count),
+ when Push_Back => Image (Item.PB_ID, Descriptor) & "," &
+ WisiToken.Token_Index'Image (Item.PB_Token_Index),
+ when Insert => Image (Item.Ins_ID, Descriptor) & "," &
+ WisiToken.Token_Index'Image (Item.Ins_Token_Index) &
+ (if Item.State = Unknown_State or Trace_McKenzie <= Detail
then ""
+ else "," & State_Index'Image (Item.State) &
+ SAL.Base_Peek_Type'Image (Item.Stack_Depth)),
+ when Delete => Image (Item.Del_ID, Descriptor) & "," &
+ WisiToken.Token_Index'Image (Item.Del_Token_Index))
+ & ")");
+
+ function Image (Item : in Config_Op; Descriptor : in WisiToken.Descriptor)
return String
+ renames Config_Op_Image;
+
+ function Image is new Config_Op_Queues.Gen_Image_Aux (WisiToken.Descriptor,
Image);
+ function Config_Op_Array_Image is new Config_Op_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
+ function Image (Item : in Config_Op_Arrays.Vector; Descriptor : in
WisiToken.Descriptor) return String
+ renames Config_Op_Array_Image;
+
+ function None (Ops : in Config_Op_Arrays.Vector; Op : in Config_Op_Label)
return Boolean
+ is (for all O of Ops => O.Op /= Op);
+ -- True if Ops contains no Op.
+
+ function None_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
+ -- True if Ops contains no Op after the last Fast_Forward (or ops.first, if
+ -- no Fast_Forward).
+
+ function Only_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
+ -- True if Ops contains only Op (at least one) after the last Fast_Forward
(or ops.first, if
+ -- no Fast_Forward).
+
+ function Any (Ops : in Config_Op_Arrays.Vector; Op : in Config_Op_Label)
return Boolean
+ is (for some O of Ops => O.Op = Op);
+ -- True if Ops contains at least one Op.
+
+ package Insert_Delete_Arrays is new SAL.Gen_Bounded_Definite_Vectors
+ (Positive_Index_Type, Insert_Delete_Op, Capacity => 80);
+
+ package Sorted_Insert_Delete_Arrays is new Insert_Delete_Arrays.Gen_Sorted
(Compare);
+
+ function Image is new Insert_Delete_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
+
+ type Recover_Stack_Item is record
+ State : Unknown_State_Index;
+
+ Tree_Index : Syntax_Trees.Node_Index;
+ -- Valid if copied at recover initialize, Invalid if pushed during
+ -- recover.
+
+ Token : Recover_Token;
+ -- Virtual is False if token is from input text; True if inserted
+ -- during recover.
+ end record;
+
+ package Recover_Stacks is new SAL.Gen_Unbounded_Definite_Stacks
(Recover_Stack_Item);
+
+ function Image (Item : in Recover_Stack_Item; Descriptor : in
WisiToken.Descriptor) return String
+ is ((if Item.State = Unknown_State then " " else Trimmed_Image
(Item.State)) & " : " &
+ Image (Item.Token, Descriptor));
+
+ function Recover_Stack_Image is new Recover_Stacks.Gen_Image_Aux
(WisiToken.Descriptor, Image);
+ -- Unique name for calling from debugger
+
+ function Image
+ (Stack : in Recover_Stacks.Stack;
+ Descriptor : in WisiToken.Descriptor;
+ Depth : in SAL.Base_Peek_Type := 0)
+ return String
+ renames Recover_Stack_Image;
+
+ function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean;
+ -- Return True if Stack top Depth items have valid Tree_Indices,
+ -- which is true if they were copied from the parser stack, and not
+ -- pushed by recover.
+
+ type Strategies is (Language_Fix, Minimal_Complete, Matching_Begin,
Explore_Table, String_Quote);
+
+ type Strategy_Counts is array (Strategies) of Natural;
+ function Image is new SAL.Gen_Array_Image (Strategies, Natural,
Strategy_Counts, Trimmed_Image);
+
+ type Minimal_Complete_State is (None, Active, Done);
+
+ type Configuration is record
+ Stack : Recover_Stacks.Stack;
+ -- Initially built from the parser stack, then the stack after the
+ -- Ops below have been performed.
+
+ Resume_Token_Goal : WisiToken.Token_Index := WisiToken.Token_Index'Last;
+ -- A successful solution shifts this token. Per-config because it
+ -- increases with Delete; we increase Shared_Parser.Resume_Token_Goal
+ -- only from successful configs.
+
+ Current_Shared_Token : Base_Token_Index := WisiToken.Token_Index'Last;
+ -- Index into Shared_Parser.Terminals for current input token, after
+ -- all of Inserted is input. Initially the error token.
+
+ String_Quote_Checked : Line_Number_Type := Invalid_Line_Number;
+ -- Max line checked for missing string quote.
+
+ Insert_Delete : Sorted_Insert_Delete_Arrays.Vector;
+ -- Edits to the input stream that are not yet parsed; contains only
+ -- Insert and Delete ops, in token_index order.
+
+ Current_Insert_Delete : SAL.Base_Peek_Type := No_Insert_Delete;
+ -- Index of the next op in Insert_Delete. If No_Insert_Delete, use
+ -- Current_Shared_Token.
+
+ Error_Token : Recover_Token;
+ Check_Token_Count : Ada.Containers.Count_Type;
+ Check_Status : Semantic_Checks.Check_Status;
+ -- If parsing this config ended with a parse error, Error_Token is
+ -- the token that failed to shift, Check_Status.Label is Ok.
+ --
+ -- If parsing this config ended with a semantic check fail,
+ -- Error_Token is the nonterm created by the reduction,
+ -- Check_Token_Count the number of tokens in the right hand side, and
+ -- Check_Status is the error.
+ --
+ -- Error_Token is set to Invalid_Token_ID when Config is parsed
+ -- successfully, or modified so the error is no longer meaningful (ie
+ -- in explore when adding an op, or in language_fixes when adding a
+ -- fix).
+
+ Ops : Config_Op_Arrays.Vector;
+ -- Record of operations applied to this Config, in application order.
+ -- Insert and Delete ops that are not yet parsed are reflected in
+ -- Insert_Delete, in token_index order.
+
+ Cost : Natural := 0;
+
+ Strategy_Counts : LR.Strategy_Counts := (others => 0);
+ -- Count of strategies that produced Ops.
+
+ Minimal_Complete_State : LR.Minimal_Complete_State := None;
+ Matching_Begin_Done : Boolean := False;
+ end record;
+ type Configuration_Access is access all Configuration;
+ for Configuration_Access'Storage_Size use 0;
+
+ function Key (A : in Configuration) return Integer is (A.Cost);
+
+ procedure Set_Key (Item : in out Configuration; Key : in Integer);
+
+ package Config_Heaps is new SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci
+ (Element_Type => Configuration,
+ Element_Access => Configuration_Access,
+ Key_Type => Integer,
+ Key => Key,
+ Set_Key => Set_Key);
+
+ type Check_Status is (Success, Abandon, Continue);
+ subtype Non_Success_Status is Check_Status range Abandon .. Continue;
+
+ type McKenzie_Data is tagged record
+ Config_Heap : Config_Heaps.Heap_Type;
+ Enqueue_Count : Integer := 0;
+ Config_Full_Count : Integer := 0;
+ Check_Count : Integer := 0;
+ Results : Config_Heaps.Heap_Type;
+ Success : Boolean := False;
+ end record;
+ type McKenzie_Access is access all McKenzie_Data;
+
+ procedure Accumulate (Data : in McKenzie_Data; Counts : in out
Strategy_Counts);
+ -- Sum Results.Strategy_Counts.
+
+ type Parse_Error_Label is (Action, Check, Message);
+
+ type Parse_Error
+ (Label : Parse_Error_Label;
+ First_Terminal : Token_ID;
+ Last_Terminal : Token_ID)
+ is record
+ Recover : Configuration;
+
+ case Label is
+ when Action =>
+ Error_Token : Syntax_Trees.Valid_Node_Index; -- index into Parser.Tree
+ Expecting : Token_ID_Set (First_Terminal .. Last_Terminal);
+
+ when Check =>
+ Check_Status : Semantic_Checks.Check_Status;
+
+ when Message =>
+ Msg : Ada.Strings.Unbounded.Unbounded_String;
+ end case;
+ end record;
+
+ package Parse_Error_Lists is new
Ada.Containers.Indefinite_Doubly_Linked_Lists (Parse_Error);
+
+private
+
+ type Goto_Node is record
+ Symbol : Token_ID;
+ State : State_Index;
+ Next : Goto_Node_Ptr;
+ end record;
+ procedure Free is new Ada.Unchecked_Deallocation (Goto_Node, Goto_Node_Ptr);
+
+ type Action_List_Iterator is tagged record
+ Node : Action_Node_Ptr;
+ Item : Parse_Action_Node_Ptr;
+ end record;
+
+end WisiToken.Parse.LR;
diff --git a/wisitoken-parse-packrat-procedural.adb
b/wisitoken-parse-packrat-procedural.adb
index 5dc4ef1..1f00e48 100644
--- a/wisitoken-parse-packrat-procedural.adb
+++ b/wisitoken-parse-packrat-procedural.adb
@@ -1,256 +1,256 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Parse.Packrat.Procedural is
-
- function Apply_Rule
- (Parser : in out Procedural.Parser;
- R : in Token_ID;
- Last_Pos : in Base_Token_Index)
- return Memo_Entry
- with Post => Apply_Rule'Result.State in Failure .. Success;
-
- function Eval
- (Parser : in out Procedural.Parser;
- R : in Token_ID;
- Last_Pos : in Base_Token_Index)
- return Memo_Entry
- with Post => Eval'Result.State in Failure .. Success;
-
- ----------
- -- bodies
-
- function Eval
- (Parser : in out Procedural.Parser;
- R : in Token_ID;
- Last_Pos : in Base_Token_Index)
- return Memo_Entry
- is
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
-
- Pos : Base_Token_Index := Last_Pos; -- last token parsed.
- begin
- for RHS_Index in Parser.Grammar (R).RHSs.First_Index .. Parser.Grammar
(R).RHSs.Last_Index loop
- declare
- use all type Ada.Containers.Count_Type;
- RHS : WisiToken.Productions.Right_Hand_Side renames
Parser.Grammar (R).RHSs (RHS_Index);
- Memo : Memo_Entry; -- for temporary or intermediate results
- begin
- if RHS.Tokens.Length = 0 then
- return
- (State => Success,
- Result => Parser.Tree.Add_Nonterm
- (Production => (R, RHS_Index),
- Action => RHS.Action,
- Children => (1 .. 0 =>
Syntax_Trees.Invalid_Node_Index),
- Default_Virtual => False),
- Last_Pos => Pos);
- else
- declare
- Children : Syntax_Trees.Valid_Node_Index_Array
- (SAL.Base_Peek_Type (RHS.Tokens.First_Index) ..
SAL.Base_Peek_Type (RHS.Tokens.Last_Index));
- begin
- for I in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index loop
- if RHS.Tokens (I) in Terminal then
- if Pos = Parser.Terminals.Last_Index then
- goto Fail_RHS;
-
- elsif Parser.Terminals (Pos + 1).ID = RHS.Tokens (I)
then
- Pos := Pos + 1;
- Children (SAL.Base_Peek_Type (I)) := Tree_Index
(Pos);
- else
- goto Fail_RHS;
- end if;
- else
- Memo := Apply_Rule (Parser, RHS.Tokens (I), Pos);
- case Memo.State is
- when Success =>
- Children (SAL.Base_Peek_Type (I)) := Memo.Result;
- Pos := Memo.Last_Pos;
-
- when Failure =>
- goto Fail_RHS;
- when No_Result =>
- raise SAL.Programmer_Error;
- end case;
- end if;
- end loop;
-
- return
- (State => Success,
- Result => Parser.Tree.Add_Nonterm
- (Production => (R, RHS_Index),
- Action => RHS.Action,
- Children => Children,
- Default_Virtual => False),
- Last_Pos => Pos);
-
- <<Fail_RHS>>
- Pos := Last_Pos;
- end;
- end if;
- end;
- end loop;
- -- get here when all RHSs fail
-
- return (State => Failure);
- end Eval;
-
- function Apply_Rule
- (Parser : in out Procedural.Parser;
- R : in Token_ID;
- Last_Pos : in Base_Token_Index)
- return Memo_Entry
- is
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- Pos : Base_Token_Index := Last_Pos; -- last token parsed.
- Start_Pos : constant Token_Index := Last_Pos + 1; -- first token in
current nonterm
- Memo : Memo_Entry := Parser.Derivs (R)(Start_Pos);
-
- Pos_Recurse_Last : Base_Token_Index := Last_Pos;
- Result_Recurse : Memo_Entry;
- begin
- case Memo.State is
- when Success =>
- return Memo;
-
- when Failure =>
- return (State => Failure);
-
- when No_Result =>
- if Parser.Direct_Left_Recursive (R) then
- Parser.Derivs (R).Replace_Element (Start_Pos, (State => Failure));
- else
- Memo := Eval (Parser, R, Last_Pos);
- if Trace_Parse > Detail and then Memo.State = Success then
- Parser.Trace.Put_Line (Parser.Tree.Image (Memo.Result,
Descriptor, Include_Children => True));
- end if;
- Parser.Derivs (R).Replace_Element (Start_Pos, Memo);
- return Memo;
- end if;
- end case;
-
- loop
- Pos := Last_Pos;
-
- if Pos > Parser.Terminals.Last_Index then -- FIXME: this can't pass
here; Last_Pos never > last_index
- -- There might be an empty nonterm after the last token
- return (State => Failure);
- end if;
-
- Result_Recurse := Eval (Parser, R, Pos);
-
- if Result_Recurse.State = Success then
- if Result_Recurse.Last_Pos > Pos_Recurse_Last then
- Parser.Derivs (R).Replace_Element (Start_Pos, Result_Recurse);
- Pos := Result_Recurse.Last_Pos;
- Pos_Recurse_Last := Pos;
-
- if WisiToken.Trace_Parse > Detail then
- Parser.Trace.Put_Line
- (Parser.Tree.Image (Result_Recurse.Result, Descriptor,
Include_Children => True));
- end if;
- -- continue looping
-
- elsif Result_Recurse.Last_Pos = Pos_Recurse_Last then
- if Parser.Tree.Is_Empty (Result_Recurse.Result) then
- Parser.Derivs (R).Replace_Element (Start_Pos,
Result_Recurse);
- end if;
- exit;
- else
- -- Result_Recurse.Last_Pos < Pos_Recurse_Last
- exit;
- end if;
- else
- exit;
- end if;
- end loop;
- return Parser.Derivs (R)(Start_Pos);
- end Apply_Rule;
-
- ----------
- -- Public subprograms
-
- function Create
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Direct_Left_Recursive : in Token_ID_Set;
- Start_ID : in Token_ID;
- Trace : access WisiToken.Trace'Class;
- Lexer : WisiToken.Lexer.Handle;
- User_Data : WisiToken.Syntax_Trees.User_Data_Access)
- return Procedural.Parser
- is begin
- return Parser : Procedural.Parser (Grammar.First_Index,
Grammar.Last_Index) do
- Parser.Trace := Trace;
- Parser.Lexer := Lexer;
- Parser.User_Data := User_Data;
- Parser.Grammar := Grammar;
- Parser.Start_ID := Start_ID;
- Parser.Direct_Left_Recursive := Direct_Left_Recursive;
- end return;
- end Create;
-
- overriding procedure Parse (Parser : aliased in out Procedural.Parser)
- is
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- Junk : WisiToken.Syntax_Trees.Valid_Node_Index;
- pragma Unreferenced (Junk);
-
- Result : Memo_Entry;
- begin
- Parser.Base_Tree.Clear;
- Parser.Tree.Initialize (Parser.Base_Tree'Unchecked_Access, Flush =>
True);
- Parser.Lex_All;
-
- for Nonterm in Descriptor.First_Nonterminal ..
Parser.Trace.Descriptor.Last_Nonterminal loop
- Parser.Derivs (Nonterm).Clear;
- Parser.Derivs (Nonterm).Set_First (Parser.Terminals.First_Index);
-
- -- There might be an empty nonterm after the last token
- Parser.Derivs (Nonterm).Set_Last (Parser.Terminals.Last_Index + 1);
- end loop;
-
- for Token_Index in Parser.Terminals.First_Index ..
Parser.Terminals.Last_Index loop
- Junk := Parser.Tree.Add_Terminal (Token_Index, Parser.Terminals);
- -- FIXME: move this into Lex_All, delete Terminals, just use
Syntax_Tree
- end loop;
-
- Result := Apply_Rule (Parser, Parser.Start_ID,
Parser.Terminals.First_Index - 1);
-
- if Result.State /= Success then
- if Trace_Parse > Outline then
- Parser.Trace.Put_Line ("parse failed");
- end if;
-
- raise Syntax_Error with "parse failed"; -- FIXME: need better error
message!
- else
- Parser.Tree.Set_Root (Result.Result);
- end if;
- end Parse;
-
- overriding function Tree (Parser : in Procedural.Parser) return
Syntax_Trees.Tree
- is begin
- return Parser.Tree;
- end Tree;
-
-end WisiToken.Parse.Packrat.Procedural;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Parse.Packrat.Procedural is
+
+ function Apply_Rule
+ (Parser : in out Procedural.Parser;
+ R : in Token_ID;
+ Last_Pos : in Base_Token_Index)
+ return Memo_Entry
+ with Post => Apply_Rule'Result.State in Failure .. Success;
+
+ function Eval
+ (Parser : in out Procedural.Parser;
+ R : in Token_ID;
+ Last_Pos : in Base_Token_Index)
+ return Memo_Entry
+ with Post => Eval'Result.State in Failure .. Success;
+
+ ----------
+ -- bodies
+
+ function Eval
+ (Parser : in out Procedural.Parser;
+ R : in Token_ID;
+ Last_Pos : in Base_Token_Index)
+ return Memo_Entry
+ is
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+
+ Pos : Base_Token_Index := Last_Pos; -- last token parsed.
+ begin
+ for RHS_Index in Parser.Grammar (R).RHSs.First_Index .. Parser.Grammar
(R).RHSs.Last_Index loop
+ declare
+ use all type Ada.Containers.Count_Type;
+ RHS : WisiToken.Productions.Right_Hand_Side renames
Parser.Grammar (R).RHSs (RHS_Index);
+ Memo : Memo_Entry; -- for temporary or intermediate results
+ begin
+ if RHS.Tokens.Length = 0 then
+ return
+ (State => Success,
+ Result => Parser.Tree.Add_Nonterm
+ (Production => (R, RHS_Index),
+ Action => RHS.Action,
+ Children => (1 .. 0 =>
Syntax_Trees.Invalid_Node_Index),
+ Default_Virtual => False),
+ Last_Pos => Pos);
+ else
+ declare
+ Children : Syntax_Trees.Valid_Node_Index_Array
+ (SAL.Base_Peek_Type (RHS.Tokens.First_Index) ..
SAL.Base_Peek_Type (RHS.Tokens.Last_Index));
+ begin
+ for I in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index loop
+ if RHS.Tokens (I) in Terminal then
+ if Pos = Parser.Terminals.Last_Index then
+ goto Fail_RHS;
+
+ elsif Parser.Terminals (Pos + 1).ID = RHS.Tokens (I)
then
+ Pos := Pos + 1;
+ Children (SAL.Base_Peek_Type (I)) := Tree_Index
(Pos);
+ else
+ goto Fail_RHS;
+ end if;
+ else
+ Memo := Apply_Rule (Parser, RHS.Tokens (I), Pos);
+ case Memo.State is
+ when Success =>
+ Children (SAL.Base_Peek_Type (I)) := Memo.Result;
+ Pos := Memo.Last_Pos;
+
+ when Failure =>
+ goto Fail_RHS;
+ when No_Result =>
+ raise SAL.Programmer_Error;
+ end case;
+ end if;
+ end loop;
+
+ return
+ (State => Success,
+ Result => Parser.Tree.Add_Nonterm
+ (Production => (R, RHS_Index),
+ Action => RHS.Action,
+ Children => Children,
+ Default_Virtual => False),
+ Last_Pos => Pos);
+
+ <<Fail_RHS>>
+ Pos := Last_Pos;
+ end;
+ end if;
+ end;
+ end loop;
+ -- get here when all RHSs fail
+
+ return (State => Failure);
+ end Eval;
+
+ function Apply_Rule
+ (Parser : in out Procedural.Parser;
+ R : in Token_ID;
+ Last_Pos : in Base_Token_Index)
+ return Memo_Entry
+ is
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ Pos : Base_Token_Index := Last_Pos; -- last token parsed.
+ Start_Pos : constant Token_Index := Last_Pos + 1; -- first token in
current nonterm
+ Memo : Memo_Entry := Parser.Derivs (R)(Start_Pos);
+
+ Pos_Recurse_Last : Base_Token_Index := Last_Pos;
+ Result_Recurse : Memo_Entry;
+ begin
+ case Memo.State is
+ when Success =>
+ return Memo;
+
+ when Failure =>
+ return (State => Failure);
+
+ when No_Result =>
+ if Parser.Direct_Left_Recursive (R) then
+ Parser.Derivs (R).Replace_Element (Start_Pos, (State => Failure));
+ else
+ Memo := Eval (Parser, R, Last_Pos);
+ if Trace_Parse > Detail and then Memo.State = Success then
+ Parser.Trace.Put_Line (Parser.Tree.Image (Memo.Result,
Descriptor, Include_Children => True));
+ end if;
+ Parser.Derivs (R).Replace_Element (Start_Pos, Memo);
+ return Memo;
+ end if;
+ end case;
+
+ loop
+ Pos := Last_Pos;
+
+ if Pos > Parser.Terminals.Last_Index then -- FIXME: this can't pass
here; Last_Pos never > last_index
+ -- There might be an empty nonterm after the last token
+ return (State => Failure);
+ end if;
+
+ Result_Recurse := Eval (Parser, R, Pos);
+
+ if Result_Recurse.State = Success then
+ if Result_Recurse.Last_Pos > Pos_Recurse_Last then
+ Parser.Derivs (R).Replace_Element (Start_Pos, Result_Recurse);
+ Pos := Result_Recurse.Last_Pos;
+ Pos_Recurse_Last := Pos;
+
+ if WisiToken.Trace_Parse > Detail then
+ Parser.Trace.Put_Line
+ (Parser.Tree.Image (Result_Recurse.Result, Descriptor,
Include_Children => True));
+ end if;
+ -- continue looping
+
+ elsif Result_Recurse.Last_Pos = Pos_Recurse_Last then
+ if Parser.Tree.Is_Empty (Result_Recurse.Result) then
+ Parser.Derivs (R).Replace_Element (Start_Pos,
Result_Recurse);
+ end if;
+ exit;
+ else
+ -- Result_Recurse.Last_Pos < Pos_Recurse_Last
+ exit;
+ end if;
+ else
+ exit;
+ end if;
+ end loop;
+ return Parser.Derivs (R)(Start_Pos);
+ end Apply_Rule;
+
+ ----------
+ -- Public subprograms
+
+ function Create
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Direct_Left_Recursive : in Token_ID_Set;
+ Start_ID : in Token_ID;
+ Trace : access WisiToken.Trace'Class;
+ Lexer : WisiToken.Lexer.Handle;
+ User_Data : WisiToken.Syntax_Trees.User_Data_Access)
+ return Procedural.Parser
+ is begin
+ return Parser : Procedural.Parser (Grammar.First_Index,
Grammar.Last_Index) do
+ Parser.Trace := Trace;
+ Parser.Lexer := Lexer;
+ Parser.User_Data := User_Data;
+ Parser.Grammar := Grammar;
+ Parser.Start_ID := Start_ID;
+ Parser.Direct_Left_Recursive := Direct_Left_Recursive;
+ end return;
+ end Create;
+
+ overriding procedure Parse (Parser : aliased in out Procedural.Parser)
+ is
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ Junk : WisiToken.Syntax_Trees.Valid_Node_Index;
+ pragma Unreferenced (Junk);
+
+ Result : Memo_Entry;
+ begin
+ Parser.Base_Tree.Clear;
+ Parser.Tree.Initialize (Parser.Base_Tree'Unchecked_Access, Flush =>
True);
+ Parser.Lex_All;
+
+ for Nonterm in Descriptor.First_Nonterminal ..
Parser.Trace.Descriptor.Last_Nonterminal loop
+ Parser.Derivs (Nonterm).Clear;
+ Parser.Derivs (Nonterm).Set_First (Parser.Terminals.First_Index);
+
+ -- There might be an empty nonterm after the last token
+ Parser.Derivs (Nonterm).Set_Last (Parser.Terminals.Last_Index + 1);
+ end loop;
+
+ for Token_Index in Parser.Terminals.First_Index ..
Parser.Terminals.Last_Index loop
+ Junk := Parser.Tree.Add_Terminal (Token_Index, Parser.Terminals);
+ -- FIXME: move this into Lex_All, delete Terminals, just use
Syntax_Tree
+ end loop;
+
+ Result := Apply_Rule (Parser, Parser.Start_ID,
Parser.Terminals.First_Index - 1);
+
+ if Result.State /= Success then
+ if Trace_Parse > Outline then
+ Parser.Trace.Put_Line ("parse failed");
+ end if;
+
+ raise Syntax_Error with "parse failed"; -- FIXME: need better error
message!
+ else
+ Parser.Tree.Set_Root (Result.Result);
+ end if;
+ end Parse;
+
+ overriding function Tree (Parser : in Procedural.Parser) return
Syntax_Trees.Tree
+ is begin
+ return Parser.Tree;
+ end Tree;
+
+end WisiToken.Parse.Packrat.Procedural;
diff --git a/wisitoken-parse-packrat-procedural.ads
b/wisitoken-parse-packrat-procedural.ads
index 76c1aee..107fead 100644
--- a/wisitoken-parse-packrat-procedural.ads
+++ b/wisitoken-parse-packrat-procedural.ads
@@ -1,83 +1,83 @@
--- Abstract :
---
--- Procedural packrat parser, supporting only direct left recursion.
---
--- Coding style, algorithm is the same as generated by
--- wisi-generate_packrat, but in procedural form.
---
--- References:
---
--- See parent.
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Productions;
-package WisiToken.Parse.Packrat.Procedural is
-
- -- These types duplicate Packrat.Generated. We keep them separate so
- -- we can experiment with ways of implementing indirect left
- -- recursion.
-
- type Memo_State is (No_Result, Failure, Success);
- subtype Result_States is Memo_State range Failure .. Success;
-
- type Memo_Entry (State : Memo_State := No_Result) is record
- case State is
- when No_Result =>
- null;
-
- when Failure =>
- null;
-
- when Success =>
- Result : WisiToken.Syntax_Trees.Valid_Node_Index;
- Last_Pos : Base_Token_Index;
-
- end case;
- end record;
-
- package Memos is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_Index, Memo_Entry, Default_Element => (others => <>));
- type Derivs is array (Token_ID range <>) of Memos.Vector;
-
- type Parser (First_Nonterminal, Last_Nonterminal : Token_ID) is new
Packrat.Parser with
- record
- Grammar : WisiToken.Productions.Prod_Arrays.Vector;
- Start_ID : Token_ID;
- Direct_Left_Recursive : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
- Derivs : Procedural.Derivs (First_Nonterminal ..
Last_Nonterminal);
- end record;
-
- function Create
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Direct_Left_Recursive : in Token_ID_Set;
- Start_ID : in Token_ID;
- Trace : access WisiToken.Trace'Class;
- Lexer : WisiToken.Lexer.Handle;
- User_Data : WisiToken.Syntax_Trees.User_Data_Access)
- return Procedural.Parser;
-
- overriding procedure Parse (Parser : aliased in out Procedural.Parser);
- overriding function Tree (Parser : in Procedural.Parser) return
Syntax_Trees.Tree;
-
- overriding function Any_Errors (Parser : in Procedural.Parser) return
Boolean
- is (False);
- -- All errors are reported by Parse raising Syntax_Error.
-
- overriding procedure Put_Errors (Parser : in Procedural.Parser)
- is null;
-
-end WisiToken.Parse.Packrat.Procedural;
+-- Abstract :
+--
+-- Procedural packrat parser, supporting only direct left recursion.
+--
+-- Coding style, algorithm is the same as generated by
+-- wisi-generate_packrat, but in procedural form.
+--
+-- References:
+--
+-- See parent.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Productions;
+package WisiToken.Parse.Packrat.Procedural is
+
+ -- These types duplicate Packrat.Generated. We keep them separate so
+ -- we can experiment with ways of implementing indirect left
+ -- recursion.
+
+ type Memo_State is (No_Result, Failure, Success);
+ subtype Result_States is Memo_State range Failure .. Success;
+
+ type Memo_Entry (State : Memo_State := No_Result) is record
+ case State is
+ when No_Result =>
+ null;
+
+ when Failure =>
+ null;
+
+ when Success =>
+ Result : WisiToken.Syntax_Trees.Valid_Node_Index;
+ Last_Pos : Base_Token_Index;
+
+ end case;
+ end record;
+
+ package Memos is new SAL.Gen_Unbounded_Definite_Vectors
+ (Token_Index, Memo_Entry, Default_Element => (others => <>));
+ type Derivs is array (Token_ID range <>) of Memos.Vector;
+
+ type Parser (First_Nonterminal, Last_Nonterminal : Token_ID) is new
Packrat.Parser with
+ record
+ Grammar : WisiToken.Productions.Prod_Arrays.Vector;
+ Start_ID : Token_ID;
+ Direct_Left_Recursive : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
+ Derivs : Procedural.Derivs (First_Nonterminal ..
Last_Nonterminal);
+ end record;
+
+ function Create
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Direct_Left_Recursive : in Token_ID_Set;
+ Start_ID : in Token_ID;
+ Trace : access WisiToken.Trace'Class;
+ Lexer : WisiToken.Lexer.Handle;
+ User_Data : WisiToken.Syntax_Trees.User_Data_Access)
+ return Procedural.Parser;
+
+ overriding procedure Parse (Parser : aliased in out Procedural.Parser);
+ overriding function Tree (Parser : in Procedural.Parser) return
Syntax_Trees.Tree;
+
+ overriding function Any_Errors (Parser : in Procedural.Parser) return
Boolean
+ is (False);
+ -- All errors are reported by Parse raising Syntax_Error.
+
+ overriding procedure Put_Errors (Parser : in Procedural.Parser)
+ is null;
+
+end WisiToken.Parse.Packrat.Procedural;
diff --git a/wisitoken-parse_table-mode.el b/wisitoken-parse_table-mode.el
index 5cce27a..13a727c 100644
--- a/wisitoken-parse_table-mode.el
+++ b/wisitoken-parse_table-mode.el
@@ -47,7 +47,8 @@
(cond
((save-excursion
(end-of-line)
- (or (looking-back "goto state \\([0-9]+\\),?" (line-beginning-position))
+ ;; "go to" for bison output
+ (or (looking-back "go ?to state \\([0-9]+\\),?"
(line-beginning-position))
(looking-back "( \\([0-9]+\\))" (line-beginning-position))))
(match-string 1))
diff --git a/wisitoken-semantic_checks.adb b/wisitoken-semantic_checks.adb
index 26dcb49..d69ac77 100644
--- a/wisitoken-semantic_checks.adb
+++ b/wisitoken-semantic_checks.adb
@@ -1,152 +1,152 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Characters.Handling;
-package body WisiToken.Semantic_Checks is
-
- function Image (Item : in Check_Status; Descriptor : in
WisiToken.Descriptor) return String
- is begin
- case Item.Label is
- when Ok =>
- return Check_Status_Label'Image (Item.Label);
- when Error =>
- return '(' & Check_Status_Label'Image (Item.Label) & ", " &
- Image (Item.Begin_Name, Descriptor) & ',' &
- Image (Item.End_Name, Descriptor) & ')';
- end case;
- end Image;
-
- function Match_Names
- (Lexer : access constant WisiToken.Lexer.Instance'Class;
- Descriptor : in WisiToken.Descriptor;
- Tokens : in Recover_Token_Array;
- Start_Index : in Positive_Index_Type;
- End_Index : in Positive_Index_Type;
- End_Optional : in Boolean)
- return Check_Status
- is
- Start_Name_Region : constant Buffer_Region :=
- (if Tokens (Start_Index).Name = Null_Buffer_Region
- then Tokens (Start_Index).Byte_Region
- else Tokens (Start_Index).Name);
- End_Name_Region : constant Buffer_Region :=
- (if Tokens (End_Index).Name = Null_Buffer_Region
- then Tokens (End_Index).Byte_Region
- else Tokens (End_Index).Name);
-
- function Equal return Boolean
- is
- use Ada.Characters.Handling;
- begin
- if Descriptor.Case_Insensitive then
- return To_Lower (Lexer.Buffer_Text (Start_Name_Region)) =
- To_Lower (Lexer.Buffer_Text (End_Name_Region));
- else
- return Lexer.Buffer_Text (Start_Name_Region) = Lexer.Buffer_Text
(End_Name_Region);
- end if;
- end Equal;
-
- begin
- if Tokens (Start_Index).Virtual or Tokens (End_Index).Virtual then
- return (Label => Ok);
-
- elsif End_Optional then
- if End_Name_Region = Null_Buffer_Region then
- return (Label => Ok);
- elsif Start_Name_Region = Null_Buffer_Region then
- return (Extra_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
- else
- if Equal then
- return (Label => Ok);
- else
- return (Match_Names_Error, Tokens (Start_Index), Tokens
(End_Index));
- end if;
- end if;
-
- else
- if Start_Name_Region = Null_Buffer_Region then
- if End_Name_Region = Null_Buffer_Region then
- return (Label => Ok);
- else
- return (Extra_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
- end if;
-
- elsif End_Name_Region = Null_Buffer_Region then
- return (Missing_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
-
- else
- if Equal then
- return (Label => Ok);
- else
- return (Match_Names_Error, Tokens (Start_Index), Tokens
(End_Index));
- end if;
- end if;
- end if;
- end Match_Names;
-
- function Propagate_Name
- (Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- Name_Index : in Positive_Index_Type)
- return Check_Status
- is begin
- if Tokens (Name_Index).Name = Null_Buffer_Region then
- Nonterm.Name := Tokens (Name_Index).Byte_Region;
- else
- Nonterm.Name := Tokens (Name_Index).Name;
- end if;
- return (Label => Ok);
- end Propagate_Name;
-
- function Merge_Names
- (Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- First_Index : in Positive_Index_Type;
- Last_Index : in Positive_Index_Type)
- return Check_Status
- is
- First_Name : Buffer_Region renames Tokens (First_Index).Name;
- Last_Name : Buffer_Region renames Tokens (Last_Index).Name;
- begin
- Nonterm.Name :=
- First_Name and
- (if Last_Name = Null_Buffer_Region
- then Tokens (Last_Index).Byte_Region
- else Last_Name);
- return (Label => Ok);
- end Merge_Names;
-
- function Terminate_Partial_Parse
- (Partial_Parse_Active : in Boolean;
- Partial_Parse_Byte_Goal : in Buffer_Pos;
- Recover_Active : in Boolean;
- Nonterm : in Recover_Token)
- return Check_Status
- is begin
- if Partial_Parse_Active and then
- (not Recover_Active) and then
- Nonterm.Byte_Region.Last >= Partial_Parse_Byte_Goal
- then
- raise WisiToken.Partial_Parse;
- else
- return (Label => Ok);
- end if;
- end Terminate_Partial_Parse;
-
-end WisiToken.Semantic_Checks;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Characters.Handling;
+package body WisiToken.Semantic_Checks is
+
+ function Image (Item : in Check_Status; Descriptor : in
WisiToken.Descriptor) return String
+ is begin
+ case Item.Label is
+ when Ok =>
+ return Check_Status_Label'Image (Item.Label);
+ when Error =>
+ return '(' & Check_Status_Label'Image (Item.Label) & ", " &
+ Image (Item.Begin_Name, Descriptor) & ',' &
+ Image (Item.End_Name, Descriptor) & ')';
+ end case;
+ end Image;
+
+ function Match_Names
+ (Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Descriptor : in WisiToken.Descriptor;
+ Tokens : in Recover_Token_Array;
+ Start_Index : in Positive_Index_Type;
+ End_Index : in Positive_Index_Type;
+ End_Optional : in Boolean)
+ return Check_Status
+ is
+ Start_Name_Region : constant Buffer_Region :=
+ (if Tokens (Start_Index).Name = Null_Buffer_Region
+ then Tokens (Start_Index).Byte_Region
+ else Tokens (Start_Index).Name);
+ End_Name_Region : constant Buffer_Region :=
+ (if Tokens (End_Index).Name = Null_Buffer_Region
+ then Tokens (End_Index).Byte_Region
+ else Tokens (End_Index).Name);
+
+ function Equal return Boolean
+ is
+ use Ada.Characters.Handling;
+ begin
+ if Descriptor.Case_Insensitive then
+ return To_Lower (Lexer.Buffer_Text (Start_Name_Region)) =
+ To_Lower (Lexer.Buffer_Text (End_Name_Region));
+ else
+ return Lexer.Buffer_Text (Start_Name_Region) = Lexer.Buffer_Text
(End_Name_Region);
+ end if;
+ end Equal;
+
+ begin
+ if Tokens (Start_Index).Virtual or Tokens (End_Index).Virtual then
+ return (Label => Ok);
+
+ elsif End_Optional then
+ if End_Name_Region = Null_Buffer_Region then
+ return (Label => Ok);
+ elsif Start_Name_Region = Null_Buffer_Region then
+ return (Extra_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
+ else
+ if Equal then
+ return (Label => Ok);
+ else
+ return (Match_Names_Error, Tokens (Start_Index), Tokens
(End_Index));
+ end if;
+ end if;
+
+ else
+ if Start_Name_Region = Null_Buffer_Region then
+ if End_Name_Region = Null_Buffer_Region then
+ return (Label => Ok);
+ else
+ return (Extra_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
+ end if;
+
+ elsif End_Name_Region = Null_Buffer_Region then
+ return (Missing_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
+
+ else
+ if Equal then
+ return (Label => Ok);
+ else
+ return (Match_Names_Error, Tokens (Start_Index), Tokens
(End_Index));
+ end if;
+ end if;
+ end if;
+ end Match_Names;
+
+ function Propagate_Name
+ (Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ Name_Index : in Positive_Index_Type)
+ return Check_Status
+ is begin
+ if Tokens (Name_Index).Name = Null_Buffer_Region then
+ Nonterm.Name := Tokens (Name_Index).Byte_Region;
+ else
+ Nonterm.Name := Tokens (Name_Index).Name;
+ end if;
+ return (Label => Ok);
+ end Propagate_Name;
+
+ function Merge_Names
+ (Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ First_Index : in Positive_Index_Type;
+ Last_Index : in Positive_Index_Type)
+ return Check_Status
+ is
+ First_Name : Buffer_Region renames Tokens (First_Index).Name;
+ Last_Name : Buffer_Region renames Tokens (Last_Index).Name;
+ begin
+ Nonterm.Name :=
+ First_Name and
+ (if Last_Name = Null_Buffer_Region
+ then Tokens (Last_Index).Byte_Region
+ else Last_Name);
+ return (Label => Ok);
+ end Merge_Names;
+
+ function Terminate_Partial_Parse
+ (Partial_Parse_Active : in Boolean;
+ Partial_Parse_Byte_Goal : in Buffer_Pos;
+ Recover_Active : in Boolean;
+ Nonterm : in Recover_Token)
+ return Check_Status
+ is begin
+ if Partial_Parse_Active and then
+ (not Recover_Active) and then
+ Nonterm.Byte_Region.Last >= Partial_Parse_Byte_Goal
+ then
+ raise WisiToken.Partial_Parse;
+ else
+ return (Label => Ok);
+ end if;
+ end Terminate_Partial_Parse;
+
+end WisiToken.Semantic_Checks;
diff --git a/wisitoken-semantic_checks.ads b/wisitoken-semantic_checks.ads
index acb0ce8..09517e1 100644
--- a/wisitoken-semantic_checks.ads
+++ b/wisitoken-semantic_checks.ads
@@ -1,99 +1,105 @@
--- Abstract :
---
--- Grammar semantic check routines.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Lexer;
-package WisiToken.Semantic_Checks is
-
- type Check_Status_Label is
- (Ok,
- Missing_Name_Error, -- block start has name, required block end name
missing
- Extra_Name_Error, -- block start has no name, end has one
- Match_Names_Error); -- both names present, but don't match
-
- subtype Error is Check_Status_Label range Check_Status_Label'Succ (Ok) ..
Check_Status_Label'Last;
-
- type Check_Status (Label : Check_Status_Label := Ok) is record
- case Label is
- when Ok =>
- null;
-
- when Error =>
- Begin_Name : Recover_Token;
- End_Name : Recover_Token;
- end case;
- end record;
-
- subtype Error_Check_Status is Check_Status
- with Dynamic_Predicate => Error_Check_Status.Label /= Ok;
-
- function Image (Item : in Check_Status; Descriptor : WisiToken.Descriptor)
return String;
-
- type Semantic_Check is access function
- (Lexer : access constant WisiToken.Lexer.Instance'Class;
- Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- Recover_Active : in Boolean)
- return Check_Status;
- -- Called during parsing and error recovery to implement higher level
- -- checks, such as block name matching in Ada.
-
- Null_Check : constant Semantic_Check := null;
-
- function Match_Names
- (Lexer : access constant WisiToken.Lexer.Instance'Class;
- Descriptor : in WisiToken.Descriptor;
- Tokens : in Recover_Token_Array;
- Start_Index : in Positive_Index_Type;
- End_Index : in Positive_Index_Type;
- End_Optional : in Boolean)
- return Check_Status;
- -- Check that buffer text at Tokens (Start_Index).Name matches buffer
- -- text at Tokens (End_Index).Name. Comparison is controlled by
- -- Descriptor.Case_Insensitive.
-
- function Propagate_Name
- (Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- Name_Index : in Positive_Index_Type)
- return Check_Status;
- -- Set Nonterm.Name to Tokens (Name_Index).Name, or .Byte_Region, if
- -- .Name is Null_Buffer_Region. Return Ok.
-
- function Merge_Names
- (Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- First_Index : in Positive_Index_Type;
- Last_Index : in Positive_Index_Type)
- return Check_Status;
- -- Then set Nonterm.Name to the merger of Tokens (First_Index ..
- -- Last_Index).Name, return Ok.
- --
- -- If Tokens (Last_Index).Name is Null_Buffer_Region, use Tokens
- -- (Last_Index).Byte_Region instead.
-
- function Terminate_Partial_Parse
- (Partial_Parse_Active : in Boolean;
- Partial_Parse_Byte_Goal : in Buffer_Pos;
- Recover_Active : in Boolean;
- Nonterm : in Recover_Token)
- return Check_Status;
- pragma Inline (Terminate_Partial_Parse);
- -- If Active, raise Wisitoken.Partial_Parse; otherwise return Ok.
-
-end WisiToken.Semantic_Checks;
+-- Abstract :
+--
+-- Grammar semantic check routines.
+--
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Lexer;
+package WisiToken.Semantic_Checks is
+
+ type Check_Status_Label is
+ (Ok,
+ Missing_Name_Error, -- block start has name, required block end name
missing
+ Extra_Name_Error, -- block start has no name, end has one
+ Match_Names_Error); -- both names present, but don't match
+
+ subtype Error is Check_Status_Label range Check_Status_Label'Succ (Ok) ..
Check_Status_Label'Last;
+
+ type Check_Status (Label : Check_Status_Label := Ok) is record
+ case Label is
+ when Ok =>
+ null;
+
+ when Error =>
+ Begin_Name : Recover_Token;
+ End_Name : Recover_Token;
+ end case;
+ end record;
+
+ subtype Error_Check_Status is Check_Status
+ with Dynamic_Predicate => Error_Check_Status.Label /= Ok;
+
+ function Image (Item : in Check_Status; Descriptor : WisiToken.Descriptor)
return String;
+
+ type Semantic_Check is access function
+ (Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ Recover_Active : in Boolean)
+ return Check_Status;
+ -- Called during parsing and error recovery to implement higher level
+ -- checks, such as block name matching in Ada.
+
+ Null_Check : constant Semantic_Check := null;
+
+ function Match_Names
+ (Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Descriptor : in WisiToken.Descriptor;
+ Tokens : in Recover_Token_Array;
+ Start_Index : in Positive_Index_Type;
+ End_Index : in Positive_Index_Type;
+ End_Optional : in Boolean)
+ return Check_Status;
+ -- Check that buffer text at Tokens (Start_Index).Name matches buffer
+ -- text at Tokens (End_Index).Name. Comparison is controlled by
+ -- Descriptor.Case_Insensitive.
+
+ function Propagate_Name
+ (Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ Name_Index : in Positive_Index_Type)
+ return Check_Status;
+ function Merge_Names
+ (Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ Name_Index : in Positive_Index_Type)
+ return Check_Status
+ renames Propagate_Name;
+ -- Set Nonterm.Name to Tokens (Name_Index).Name, or .Byte_Region, if
+ -- .Name is Null_Buffer_Region. Return Ok.
+
+ function Merge_Names
+ (Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ First_Index : in Positive_Index_Type;
+ Last_Index : in Positive_Index_Type)
+ return Check_Status;
+ -- Then set Nonterm.Name to the merger of Tokens (First_Index ..
+ -- Last_Index).Name, return Ok.
+ --
+ -- If Tokens (Last_Index).Name is Null_Buffer_Region, use Tokens
+ -- (Last_Index).Byte_Region instead.
+
+ function Terminate_Partial_Parse
+ (Partial_Parse_Active : in Boolean;
+ Partial_Parse_Byte_Goal : in Buffer_Pos;
+ Recover_Active : in Boolean;
+ Nonterm : in Recover_Token)
+ return Check_Status;
+ pragma Inline (Terminate_Partial_Parse);
+ -- If Active, raise Wisitoken.Partial_Parse; otherwise return Ok.
+
+end WisiToken.Semantic_Checks;
diff --git a/wisitoken-syntax_trees.adb b/wisitoken-syntax_trees.adb
index ac780a3..e8ac152 100644
--- a/wisitoken-syntax_trees.adb
+++ b/wisitoken-syntax_trees.adb
@@ -1,1195 +1,1643 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-package body WisiToken.Syntax_Trees is
-
- -- Body specs, alphabetical, as needed
-
- function Image
- (Tree : in Syntax_Trees.Tree;
- N : in Syntax_Trees.Node;
- Descriptor : in WisiToken.Descriptor;
- Include_Children : in Boolean)
- return String;
-
- function Min (Item : in Valid_Node_Index_Array) return Valid_Node_Index;
-
- procedure Move_Branch_Point (Tree : in out Syntax_Trees.Tree; Required_Node
: in Valid_Node_Index);
-
- type Visit_Parent_Mode is (Before, After);
-
- function Process_Tree
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Visit_Parent : in Visit_Parent_Mode;
- Process_Node : access function
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Boolean)
- return Boolean;
- -- Call Process_Node on nodes in tree rooted at Node. Return when
- -- Process_Node returns False (Process_Tree returns False), or when
- -- all nodes have been processed (Process_Tree returns True).
-
- procedure Set_Children
- (Nodes : in out Node_Arrays.Vector;
- Parent : in Valid_Node_Index;
- Children : in Valid_Node_Index_Array);
-
- ----------
- -- Public and body operations, alphabetical
-
- function Action
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Semantic_Action
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).Action
- else Tree.Branched_Nodes (Node).Action);
- end Action;
-
- function Add_Nonterm
- (Tree : in out Syntax_Trees.Tree;
- Production : in Production_ID;
- Children : in Valid_Node_Index_Array;
- Action : in Semantic_Action;
- Default_Virtual : in Boolean)
- return Valid_Node_Index
- is
- Nonterm_Node : Valid_Node_Index;
- begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes.Append
- ((Label => Syntax_Trees.Nonterm,
- ID => Production.LHS,
- Action => Action,
- RHS_Index => Production.RHS,
- Virtual => (if Children'Length = 0 then Default_Virtual else
False),
- others => <>));
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- Nonterm_Node := Tree.Last_Shared_Node;
- else
- Tree.Branched_Nodes.Append
- ((Label => Syntax_Trees.Nonterm,
- ID => Production.LHS,
- Action => Action,
- RHS_Index => Production.RHS,
- Virtual => (if Children'Length = 0 then Default_Virtual else
False),
- others => <>));
- Nonterm_Node := Tree.Branched_Nodes.Last_Index;
- end if;
-
- if Children'Length = 0 then
- return Nonterm_Node;
- end if;
-
- if Tree.Flush then
- Set_Children (Tree.Shared_Tree.Nodes, Nonterm_Node, Children);
-
- else
- declare
- Min_Child_Node : constant Valid_Node_Index := Min (Children);
- begin
- if Min_Child_Node <= Tree.Last_Shared_Node then
- Move_Branch_Point (Tree, Min_Child_Node);
- end if;
- end;
-
- Set_Children (Tree.Branched_Nodes, Nonterm_Node, Children);
- end if;
-
- return Nonterm_Node;
- end Add_Nonterm;
-
- function Add_Terminal
- (Tree : in out Syntax_Trees.Tree;
- Terminal : in Token_Index;
- Terminals : in Base_Token_Arrays.Vector)
- return Valid_Node_Index
- is begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes.Append
- ((Label => Shared_Terminal,
- ID => Terminals (Terminal).ID,
- Byte_Region => Terminals (Terminal).Byte_Region,
- Terminal => Terminal,
- others => <>));
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- return Tree.Last_Shared_Node;
- else
- Tree.Branched_Nodes.Append
- ((Label => Shared_Terminal,
- ID => Terminals (Terminal).ID,
- Byte_Region => Terminals (Terminal).Byte_Region,
- Terminal => Terminal,
- others => <>));
- return Tree.Branched_Nodes.Last_Index;
- end if;
- end Add_Terminal;
-
- function Add_Terminal
- (Tree : in out Syntax_Trees.Tree;
- Terminal : in Token_ID)
- return Valid_Node_Index
- is begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes.Append
- ((Label => Virtual_Terminal,
- ID => Terminal,
- others => <>));
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- return Tree.Last_Shared_Node;
- else
- Tree.Branched_Nodes.Append
- ((Label => Virtual_Terminal,
- ID => Terminal,
- others => <>));
- return Tree.Branched_Nodes.Last_Index;
- end if;
- end Add_Terminal;
-
- overriding procedure Adjust (Tree : in out Base_Tree)
- is begin
- if Tree.Augmented_Present then
- -- Augmented is only set after parsing is complete; trees are never
copied then.
- raise SAL.Not_Implemented;
- end if;
- end Adjust;
-
- function Augmented
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Base_Token_Class_Access
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Augmented;
- else
- return Tree.Branched_Nodes (Node).Augmented;
- end if;
- end Augmented;
-
- function Byte_Region
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Buffer_Region
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).Byte_Region
- else Tree.Branched_Nodes (Node).Byte_Region);
- end Byte_Region;
-
- function Children (N : in Syntax_Trees.Node) return Valid_Node_Index_Array
- is
- use all type Ada.Containers.Count_Type;
- begin
- if N.Children.Length = 0 then
- return (1 .. 0 => <>);
- else
- return Result : Valid_Node_Index_Array (N.Children.First_Index ..
N.Children.Last_Index) do
- for I in Result'Range loop
- Result (I) := N.Children (I);
- end loop;
- end return;
- end if;
- end Children;
-
- function Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Valid_Node_Index_Array
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Children (Tree.Shared_Tree.Nodes (Node));
- else
- return Children (Tree.Branched_Nodes (Node));
- end if;
- end Children;
-
- procedure Clear (Tree : in out Syntax_Trees.Base_Tree)
- is begin
- Tree.Finalize;
- end Clear;
-
- procedure Clear (Tree : in out Syntax_Trees.Tree)
- is begin
- if Tree.Shared_Tree.Augmented_Present then
- for Node of Tree.Branched_Nodes loop
- if Node.Label = Nonterm then
- Free (Node.Augmented);
- end if;
- end loop;
- end if;
- Tree.Shared_Tree.Finalize;
- Tree.Last_Shared_Node := Invalid_Node_Index;
- Tree.Branched_Nodes.Clear;
- end Clear;
-
- function Count_Terminals
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Natural
- is
- function Compute (N : in Syntax_Trees.Node) return Natural
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal =>
- return 1;
-
- when Nonterm =>
- return Result : Natural := 0 do
- for I of N.Children loop
- Result := Result + Count_Terminals (Tree, I);
- end loop;
- end return;
- end case;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Count_Terminals;
-
- overriding procedure Finalize (Tree : in out Base_Tree)
- is begin
- Tree.Traversing := False;
- if Tree.Augmented_Present then
- for Node of Tree.Nodes loop
- if Node.Label = Nonterm then
- Free (Node.Augmented);
- end if;
- end loop;
- Tree.Augmented_Present := False;
- end if;
- Tree.Nodes.Finalize;
- end Finalize;
-
- function Find_Ancestor
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- is
- N : Node_Index := Node;
- begin
- loop
- N :=
- (if N <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (N).Parent
- else Tree.Branched_Nodes (N).Parent);
-
- exit when N = Invalid_Node_Index;
- exit when ID =
- (if N <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (N).ID
- else Tree.Branched_Nodes (N).ID);
- end loop;
- return N;
- end Find_Ancestor;
-
- function Find_Child
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- is
- function Compute (N : in Syntax_Trees.Node) return Node_Index
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal =>
- return Invalid_Node_Index;
- when Nonterm =>
- for C of N.Children loop
- if ID =
- (if C <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (C).ID
- else Tree.Branched_Nodes (C).ID)
- then
- return C;
- end if;
- end loop;
- return Invalid_Node_Index;
- end case;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Find_Child;
-
- function Find_Descendant
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- is
- Found : Node_Index := Invalid_Node_Index;
-
- function Process (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is
- Node_ID : constant Token_ID :=
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).ID
- else Tree.Branched_Nodes (Node).ID);
- begin
- if Node_ID = ID then
- Found := Node;
- return False;
- else
- return True;
- end if;
- end Process;
-
- Junk : constant Boolean := Process_Tree (Tree, Node, After,
Process'Access);
- pragma Unreferenced (Junk);
- begin
- return Found;
- end Find_Descendant;
-
- function Find_Min_Terminal_Index
- (Tree : in Syntax_Trees.Tree;
- Index : in Token_Index)
- return Node_Index
- is
- Found : Node_Index := Invalid_Node_Index;
-
- function Process (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is
- function Compute (N : in Syntax_Trees.Node) return Boolean
- is begin
- if N.Label /= Nonterm then
- return True;
- elsif Index = N.Min_Terminal_Index then
- Found := Node;
- return False;
- else
- return True;
- end if;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Process;
-
- Junk : constant Boolean := Process_Tree (Tree, Tree.Root, Before,
Process'Access);
- pragma Unreferenced (Junk);
- begin
- return Found;
- end Find_Min_Terminal_Index;
-
- function Find_Max_Terminal_Index
- (Tree : in Syntax_Trees.Tree;
- Index : in Token_Index)
- return Node_Index
- is
- Found : Node_Index := Invalid_Node_Index;
-
- function Process (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is
- function Compute (N : in Syntax_Trees.Node) return Boolean
- is begin
- if N.Label /= Nonterm then
- return True;
- elsif Index = N.Max_Terminal_Index then
- Found := Node;
- return False;
- else
- return True;
- end if;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Process;
-
- Junk : constant Boolean := Process_Tree (Tree, Tree.Root, Before,
Process'Access);
- pragma Unreferenced (Junk);
- begin
- return Found;
- end Find_Max_Terminal_Index;
-
- function Find_Sibling
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- is
- function Compute_2 (N : in Syntax_Trees.Node) return Node_Index
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal =>
- return Invalid_Node_Index;
-
- when Nonterm =>
- for C of N.Children loop
- if ID =
- (if C <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (C).ID
- else Tree.Branched_Nodes (C).ID)
- then
- return C;
- end if;
- end loop;
- return Invalid_Node_Index;
- end case;
- end Compute_2;
-
- function Compute_1 (Parent : in Node_Index) return Node_Index
- is begin
- if Parent = Invalid_Node_Index then
- return Invalid_Node_Index;
-
- else
- return Compute_2
- ((if Parent <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Parent)
- else Tree.Branched_Nodes (Parent)));
- end if;
- end Compute_1;
- begin
- return Compute_1
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).Parent
- else Tree.Branched_Nodes (Node).Parent));
- end Find_Sibling;
-
- procedure Flush (Tree : in out Syntax_Trees.Tree)
- is begin
- -- This is the opposite of Move_Branch_Point
- Tree.Shared_Tree.Nodes.Merge (Tree.Branched_Nodes);
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- Tree.Flush := True;
- end Flush;
-
- procedure Get_Terminals
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Result : in out Valid_Node_Index_Array;
- Last : in out SAL.Base_Peek_Type)
- is
- use all type SAL.Base_Peek_Type;
-
- procedure Compute (N : in Syntax_Trees.Node)
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal =>
- Last := Last + 1;
- Result (Last) := Node;
-
- when Nonterm =>
- for I of N.Children loop
- Get_Terminals (Tree, I, Result, Last);
- end loop;
- end case;
- end Compute;
- begin
- Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Get_Terminals;
-
- procedure Get_Terminal_IDs
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Result : in out Token_ID_Array;
- Last : in out Natural)
- is
- procedure Compute (N : in Syntax_Trees.Node)
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal =>
- Last := Last + 1;
- Result (Last) := N.ID;
-
- when Nonterm =>
- for I of N.Children loop
- Get_Terminal_IDs (Tree, I, Result, Last);
- end loop;
- end case;
- end Compute;
- begin
- Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Get_Terminal_IDs;
-
- function Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index_Array
- is
- Last : SAL.Base_Peek_Type := 0;
- begin
- Tree.Shared_Tree.Traversing := True;
- return Result : Valid_Node_Index_Array (1 .. SAL.Base_Peek_Type
(Count_Terminals (Tree, Node))) do
- Get_Terminals (Tree, Node, Result, Last);
- Tree.Shared_Tree.Traversing := False;
- end return;
- end Get_Terminals;
-
- function Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID_Array
- is
- Last : Natural := 0;
- begin
- Tree.Shared_Tree.Traversing := True;
- return Result : Token_ID_Array (1 .. Count_Terminals (Tree, Node)) do
- Get_Terminal_IDs (Tree, Node, Result, Last);
- Tree.Shared_Tree.Traversing := False;
- end return;
- end Get_Terminal_IDs;
-
- function Has_Branched_Nodes (Tree : in Syntax_Trees.Tree) return Boolean
- is
- use all type Ada.Containers.Count_Type;
- begin
- return Tree.Branched_Nodes.Length > 0;
- end Has_Branched_Nodes;
-
- function Has_Children (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Children.Length > 0;
- else
- return Tree.Branched_Nodes (Node).Children.Length > 0;
- end if;
- end Has_Children;
-
- function Has_Parent (Tree : in Syntax_Trees.Tree; Child : in
Valid_Node_Index) return Boolean
- is begin
- return
- (if Child <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Child).Parent /= Invalid_Node_Index
- else Tree.Branched_Nodes (Child).Parent /= Invalid_Node_Index);
- end Has_Parent;
-
- function Has_Parent (Tree : in Syntax_Trees.Tree; Children : in
Valid_Node_Index_Array) return Boolean
- is begin
- return
- (for some Child of Children =>
- (if Child <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Child).Parent /= Invalid_Node_Index
- else Tree.Branched_Nodes (Child).Parent /= Invalid_Node_Index));
- end Has_Parent;
-
- function ID
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Token_ID
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).ID
- else Tree.Branched_Nodes (Node).ID);
- end ID;
-
- function Image
- (Tree : in Syntax_Trees.Tree;
- Children : in Valid_Node_Index_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return String
- is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := +"(";
- Need_Comma : Boolean := False;
- begin
- for I of Children loop
- Result := Result & (if Need_Comma then ", " else "") &
- Tree.Image (I, Descriptor, Include_Children => False);
- Need_Comma := True;
- end loop;
- Result := Result & ")";
- return -Result;
- end Image;
-
- function Image
- (Tree : in Syntax_Trees.Tree;
- N : in Syntax_Trees.Node;
- Descriptor : in WisiToken.Descriptor;
- Include_Children : in Boolean)
- return String
- is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String;
- begin
- if Include_Children and N.Label = Nonterm then
- Result := +Image (N.ID, Descriptor) & '_' & Trimmed_Image
(N.RHS_Index) & ": ";
- end if;
-
- if N.Label = Shared_Terminal then
- Result := Result & (+Token_Index'Image (N.Terminal)) & ":";
- end if;
-
- Result := Result & "(" & Image (N.ID, Descriptor) &
- (if N.Byte_Region = Null_Buffer_Region then "" else ", " & Image
(N.Byte_Region)) & ")";
-
- if Include_Children and N.Label = Nonterm then
- Result := Result & " <= " & Image (Tree, N.Children, Descriptor);
- end if;
-
- return -Result;
- end Image;
-
- function Image
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Descriptor : in WisiToken.Descriptor;
- Include_Children : in Boolean := False)
- return String
- is begin
- return Tree.Image
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)),
- Descriptor, Include_Children);
- end Image;
-
- function Image
- (Tree : in Syntax_Trees.Tree;
- Nodes : in Valid_Node_Index_Array;
- Descriptor : in WisiToken.Descriptor)
- return String
- is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := +"(";
- Need_Comma : Boolean := False;
- begin
- for I in Nodes'Range loop
- Result := Result & (if Need_Comma then ", " else "") &
- Tree.Image (Nodes (I), Descriptor, Include_Children => False);
- Need_Comma := True;
- end loop;
- Result := Result & ")";
- return -Result;
- end Image;
-
- procedure Initialize
- (Branched_Tree : in out Syntax_Trees.Tree;
- Shared_Tree : in Base_Tree_Access;
- Flush : in Boolean)
- is begin
- Branched_Tree :=
- (Shared_Tree => Shared_Tree,
- Last_Shared_Node => Shared_Tree.Nodes.Last_Index,
- Branched_Nodes => <>,
- Flush => Flush,
- Root => <>);
- end Initialize;
-
- function Is_Empty (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Boolean
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Byte_Region = Null_Buffer_Region;
- else
- return Tree.Branched_Nodes (Node).Byte_Region = Null_Buffer_Region;
- end if;
- end Is_Empty;
-
- function Is_Nonterm (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Label = Nonterm;
- else
- return Tree.Branched_Nodes (Node).Label = Nonterm;
- end if;
- end Is_Nonterm;
-
- function Is_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Label = Shared_Terminal;
- else
- return Tree.Branched_Nodes (Node).Label = Shared_Terminal;
- end if;
- end Is_Terminal;
-
- function Is_Virtual (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is
- function Compute (N : in Syntax_Trees.Node) return Boolean
- is begin
- return N.Label = Virtual_Terminal or (N.Label = Nonterm and then
N.Virtual);
- end Compute;
- begin
- if Node <= Tree.Last_Shared_Node then
- return Compute (Tree.Shared_Tree.Nodes (Node));
- else
- return Compute (Tree.Branched_Nodes (Node));
- end if;
- end Is_Virtual;
-
- function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Label
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Label;
- else
- return Tree.Branched_Nodes (Node).Label;
- end if;
- end Label;
-
- function Min (Item : in Valid_Node_Index_Array) return Valid_Node_Index
- is
- Result : Node_Index := Item (Item'First);
- begin
- for I in Item'Range loop
- if Item (I) < Result then
- Result := Item (I);
- end if;
- end loop;
- return Result;
- end Min;
-
- function Min_Descendant (Nodes : in Node_Arrays.Vector; Node : in
Valid_Node_Index) return Valid_Node_Index
- is
- N : Syntax_Trees.Node renames Nodes (Node);
- begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal =>
- return Node;
-
- when Nonterm =>
- declare
- Min : Node_Index := Node;
- begin
- for C of N.Children loop
- Min := Node_Index'Min (Min, Min_Descendant (Nodes, C));
- end loop;
- return Min;
- end;
- end case;
- end Min_Descendant;
-
- function Min_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index
- is
- function Compute (N : in Syntax_Trees.Node) return Base_Token_Index
- is begin
- return
- (case N.Label is
- when Shared_Terminal => N.Terminal,
- when Virtual_Terminal => Invalid_Token_Index,
- when Nonterm => N.Min_Terminal_Index);
- end Compute;
-
- begin
- if Node <= Tree.Last_Shared_Node then
- return Compute (Tree.Shared_Tree.Nodes (Node));
- else
- return Compute (Tree.Branched_Nodes (Node));
- end if;
- end Min_Terminal_Index;
-
- function Max_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index
- is
- function Compute (N : in Syntax_Trees.Node) return Base_Token_Index
- is begin
- return
- (case N.Label is
- when Shared_Terminal => N.Terminal,
- when Virtual_Terminal => Invalid_Token_Index,
- when Nonterm => N.Max_Terminal_Index);
- end Compute;
-
- begin
- if Node <= Tree.Last_Shared_Node then
- return Compute (Tree.Shared_Tree.Nodes (Node));
- else
- return Compute (Tree.Branched_Nodes (Node));
- end if;
- end Max_Terminal_Index;
-
- procedure Move_Branch_Point (Tree : in out Syntax_Trees.Tree; Required_Node
: in Valid_Node_Index)
- is begin
- -- Note that this preserves all stored indices in Branched_Nodes.
- Tree.Branched_Nodes.Prepend (Tree.Shared_Tree.Nodes, Required_Node,
Tree.Last_Shared_Node);
- Tree.Last_Shared_Node := Required_Node - 1;
- end Move_Branch_Point;
-
- function Parent (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Index
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Parent;
- else
- return Tree.Branched_Nodes (Node).Parent;
- end if;
- end Parent;
-
- procedure Print_Tree (Tree : in Syntax_Trees.Tree; Descriptor : in
WisiToken.Descriptor)
- is
- use Ada.Text_IO;
- procedure Print_Node (Node : in Valid_Node_Index; Level : in Integer)
- is
- N : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Node);
- begin
- for I in 1 .. Level loop
- Put ("| ");
- end loop;
- Put_Line (Image (Tree, N, Descriptor, Include_Children => False));
-
- if N.Label = Nonterm then
- for Child of N.Children loop
- Print_Node (Child, Level + 1);
- end loop;
- end if;
- end Print_Node;
-
- begin
- Print_Node (Tree.Root, 0);
- end Print_Tree;
-
- function Process_Tree
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Visit_Parent : in Visit_Parent_Mode;
- Process_Node : access function
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Boolean)
- return Boolean
- is
- function Compute (N : in Syntax_Trees.Node) return Boolean
- is begin
- if Visit_Parent = Before then
- if not Process_Node (Tree, Node) then
- return False;
- end if;
- end if;
-
- if N.Label = Nonterm then
- for Child of N.Children loop
- if not Process_Tree (Tree, Child, Visit_Parent, Process_Node)
then
- return False;
- end if;
- end loop;
- end if;
-
- if Visit_Parent = After then
- return Process_Node (Tree, Node);
- else
- return True;
- end if;
- end Compute;
- begin
- if Node <= Tree.Last_Shared_Node then
- return Compute (Tree.Shared_Tree.Nodes (Node));
- else
- return Compute (Tree.Branched_Nodes (Node));
- end if;
- end Process_Tree;
-
- procedure Process_Tree
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Process_Node : access procedure
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index))
- is
- procedure Compute (N : in Syntax_Trees.Node)
- is begin
- if N.Label = Nonterm then
- for Child of N.Children loop
- Process_Tree (Tree, Child, Process_Node);
- end loop;
- end if;
-
- Process_Node (Tree, Node);
- end Compute;
- begin
- if Node <= Tree.Last_Shared_Node then
- Compute (Tree.Shared_Tree.Nodes (Node));
- else
- Compute (Tree.Branched_Nodes (Node));
- end if;
- end Process_Tree;
-
- procedure Process_Tree
- (Tree : in out Syntax_Trees.Tree;
- Process_Node : access procedure
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index))
- is begin
- if Tree.Root = Invalid_Node_Index then
- raise SAL.Programmer_Error with "Tree.Root not set";
- end if;
- Tree.Shared_Tree.Traversing := True;
- if Tree.Flush then
- Process_Tree (Tree, Tree.Root, Process_Node);
- else
- Process_Tree (Tree, Tree.Root, Process_Node);
- end if;
- Tree.Shared_Tree.Traversing := False;
- exception
- when others =>
- Tree.Shared_Tree.Traversing := False;
- raise;
- end Process_Tree;
-
- procedure Set_Root (Tree : in out Syntax_Trees.Tree; Root : in
Valid_Node_Index)
- is begin
- Tree.Root := Root;
- end Set_Root;
-
- function Root (Tree : in Syntax_Trees.Tree) return Node_Index
- is begin
- if Tree.Root /= Invalid_Node_Index then
- return Tree.Root;
- else
- if Tree.Flush then
- return Tree.Shared_Tree.Nodes.Last_Index;
- else
- return Tree.Branched_Nodes.Last_Index;
- end if;
- end if;
- end Root;
-
- function Same_Token
- (Tree_1 : in Syntax_Trees.Tree'Class;
- Index_1 : in Valid_Node_Index;
- Tree_2 : in Syntax_Trees.Tree'Class;
- Index_2 : in Valid_Node_Index)
- return Boolean
- is
- function Compute (N_1, N_2 : in Syntax_Trees.Node) return Boolean
- is begin
- return N_1.Label = N_2.Label and
- N_1.ID = N_2.ID and
- N_1.Byte_Region = N_2.Byte_Region;
- end Compute;
- begin
- return Compute
- ((if Index_1 <= Tree_1.Last_Shared_Node
- then Tree_1.Shared_Tree.Nodes (Index_1)
- else Tree_1.Branched_Nodes (Index_1)),
- (if Index_2 <= Tree_2.Last_Shared_Node
- then Tree_2.Shared_Tree.Nodes (Index_2)
- else Tree_2.Branched_Nodes (Index_2)));
- end Same_Token;
-
- procedure Set_Augmented
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Value : in Base_Token_Class_Access)
- is begin
- if Node <= Tree.Last_Shared_Node then
- Tree.Shared_Tree.Nodes (Node).Augmented := Value;
- else
- Tree.Branched_Nodes (Node).Augmented := Value;
- end if;
- Tree.Shared_Tree.Augmented_Present := True;
- end Set_Augmented;
-
- procedure Set_Children
- (Nodes : in out Node_Arrays.Vector;
- Parent : in Valid_Node_Index;
- Children : in Valid_Node_Index_Array)
- is
- use all type SAL.Base_Peek_Type;
-
- N : Nonterm_Node renames Nodes (Parent);
- J : Positive_Index_Type := Positive_Index_Type'First;
-
- Min_Terminal_Index_Set : Boolean := False;
- begin
- N.Children.Set_Length (Children'Length);
- for I in Children'Range loop
- N.Children (J) := Children (I);
- declare
- K : Syntax_Trees.Node renames Nodes (Children (I));
- begin
- K.Parent := Parent;
-
- N.Virtual := N.Virtual or
- (case K.Label is
- when Shared_Terminal => False,
- when Virtual_Terminal => True,
- when Nonterm => K.Virtual);
-
- if N.Byte_Region.First > K.Byte_Region.First then
- N.Byte_Region.First := K.Byte_Region.First;
- end if;
-
- if N.Byte_Region.Last < K.Byte_Region.Last then
- N.Byte_Region.Last := K.Byte_Region.Last;
- end if;
-
- if not Min_Terminal_Index_Set then
- case K.Label is
- when Shared_Terminal =>
- Min_Terminal_Index_Set := True;
- N.Min_Terminal_Index := K.Terminal;
-
- when Virtual_Terminal =>
- null;
-
- when Nonterm =>
- if K.Min_Terminal_Index /= Invalid_Token_Index then
- -- not an empty nonterm
- Min_Terminal_Index_Set := True;
- N.Min_Terminal_Index := K.Min_Terminal_Index;
- end if;
- end case;
- end if;
-
- case K.Label is
- when Shared_Terminal =>
- if N.Max_Terminal_Index < K.Terminal then
- N.Max_Terminal_Index := K.Terminal;
- end if;
-
- when Virtual_Terminal =>
- null;
-
- when Nonterm =>
- if K.Max_Terminal_Index /= Invalid_Token_Index and then
- -- not an empty nonterm
- N.Max_Terminal_Index < K.Max_Terminal_Index
- then
- N.Max_Terminal_Index := K.Max_Terminal_Index;
- end if;
- end case;
- end;
-
- J := J + 1;
- end loop;
- end Set_Children;
-
- procedure Set_State
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- State : in State_Index)
- is begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes (Node).State := State;
- else
- if Node <= Tree.Last_Shared_Node then
- Tree.Shared_Tree.Nodes (Node).State := State;
- else
- Tree.Branched_Nodes (Node).State := State;
- end if;
- end if;
- end Set_State;
-
- procedure Set_Flush_False (Tree : in out Syntax_Trees.Tree)
- is begin
- Tree.Flush := False;
- Tree.Branched_Nodes.Set_First (Tree.Last_Shared_Node + 1);
- end Set_Flush_False;
-
- function Flushed (Tree : in Syntax_Trees.Tree) return Boolean
- is begin
- return Tree.Flush;
- end Flushed;
-
- procedure Set_Name_Region
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Region : in Buffer_Region)
- is begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes (Node).Name := Region;
-
- else
- if Node <= Tree.Last_Shared_Node then
- Move_Branch_Point (Tree, Node);
- end if;
-
- Tree.Branched_Nodes (Node).Name := Region;
- end if;
- end Set_Name_Region;
-
- function Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Base_Token_Index
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Terminal;
- else
- return Tree.Branched_Nodes (Node).Terminal;
- end if;
- end Terminal;
-
- function Traversing (Tree : in Syntax_Trees.Tree) return Boolean
- is begin
- return Tree.Shared_Tree.Traversing;
- end Traversing;
-
- function Recover_Token
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Recover_Token
- is
- function Compute (N : Syntax_Trees.Node) return WisiToken.Recover_Token
- is begin
- case N.Label is
- when Shared_Terminal =>
- return
- (ID => N.ID,
- Byte_Region => N.Byte_Region,
- Min_Terminal_Index => N.Terminal,
- Name => Null_Buffer_Region,
- Virtual => False);
-
- when Virtual_Terminal =>
- return
- (ID => N.ID,
- Byte_Region => Null_Buffer_Region,
- Min_Terminal_Index => Invalid_Token_Index,
- Name => Null_Buffer_Region,
- Virtual => True);
-
- when Nonterm =>
- return
- (ID => N.ID,
- Byte_Region => N.Byte_Region,
- Min_Terminal_Index => N.Min_Terminal_Index,
- Name => N.Name,
- Virtual => N.Virtual);
- end case;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Recover_Token;
-
- function Recover_Token_Array
- (Tree : in Syntax_Trees.Tree;
- Nodes : in Valid_Node_Index_Array)
- return WisiToken.Recover_Token_Array
- is begin
- return Result : WisiToken.Recover_Token_Array (Nodes'First ..
Nodes'Last) do
- for I in Result'Range loop
- Result (I) := Tree.Recover_Token (Nodes (I));
- end loop;
- end return;
- end Recover_Token_Array;
-
- function State (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Unknown_State_Index
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).State;
- else
- return Tree.Branched_Nodes (Node).State;
- end if;
- end State;
-
-end WisiToken.Syntax_Trees;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers;
+with Ada.Text_IO;
+with SAL.Generic_Decimal_Image;
+package body WisiToken.Syntax_Trees is
+
+ -- Body specs, alphabetical, as needed
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ N : in Syntax_Trees.Node;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean;
+ Include_RHS_Index : in Boolean := False)
+ return String;
+
+ function Min (Item : in Valid_Node_Index_Array) return Valid_Node_Index;
+
+ procedure Move_Branch_Point (Tree : in out Syntax_Trees.Tree; Required_Node
: in Valid_Node_Index);
+
+ type Visit_Parent_Mode is (Before, After);
+
+ function Process_Tree
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Visit_Parent : in Visit_Parent_Mode;
+ Process_Node : access function
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Boolean)
+ return Boolean;
+ -- Call Process_Node on nodes in tree rooted at Node. Return when
+ -- Process_Node returns False (Process_Tree returns False), or when
+ -- all nodes have been processed (Process_Tree returns True).
+
+ procedure Set_Children
+ (Nodes : in out Node_Arrays.Vector;
+ Parent : in Valid_Node_Index;
+ Children : in Valid_Node_Index_Array);
+
+ ----------
+ -- Public and body operations, alphabetical
+
+ function Action
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Semantic_Action
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).Action
+ else Tree.Branched_Nodes (Node).Action);
+ end Action;
+
+ procedure Add_Child
+ (Tree : in out Syntax_Trees.Tree;
+ Parent : in Valid_Node_Index;
+ Child : in Valid_Node_Index)
+ is
+ Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Parent);
+ begin
+ Node.Children.Append (Child);
+ -- We don't update Min/Max_terminal_index; they are no longer needed.
+ end Add_Child;
+
+ function Add_Identifier
+ (Tree : in out Syntax_Trees.Tree;
+ ID : in Token_ID;
+ Identifier : in Identifier_Index;
+ Byte_Region : in WisiToken.Buffer_Region)
+ return Valid_Node_Index
+ is begin
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Virtual_Identifier,
+ Byte_Region => Byte_Region,
+ ID => ID,
+ Identifier => Identifier,
+ others => <>));
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ return Tree.Last_Shared_Node;
+ end Add_Identifier;
+
+ function Add_Nonterm
+ (Tree : in out Syntax_Trees.Tree;
+ Production : in WisiToken.Production_ID;
+ Children : in Valid_Node_Index_Array;
+ Action : in Semantic_Action := null;
+ Default_Virtual : in Boolean := False)
+ return Valid_Node_Index
+ is
+ Nonterm_Node : Valid_Node_Index;
+ begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Syntax_Trees.Nonterm,
+ ID => Production.LHS,
+ Action => Action,
+ RHS_Index => Production.RHS,
+ Virtual => (if Children'Length = 0 then Default_Virtual else
False),
+ others => <>));
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ Nonterm_Node := Tree.Last_Shared_Node;
+ else
+ Tree.Branched_Nodes.Append
+ ((Label => Syntax_Trees.Nonterm,
+ ID => Production.LHS,
+ Action => Action,
+ RHS_Index => Production.RHS,
+ Virtual => (if Children'Length = 0 then Default_Virtual else
False),
+ others => <>));
+ Nonterm_Node := Tree.Branched_Nodes.Last_Index;
+ end if;
+
+ if Children'Length = 0 then
+ return Nonterm_Node;
+ end if;
+
+ if Tree.Flush then
+ Set_Children (Tree.Shared_Tree.Nodes, Nonterm_Node, Children);
+
+ else
+ declare
+ Min_Child_Node : constant Valid_Node_Index := Min (Children);
+ begin
+ if Min_Child_Node <= Tree.Last_Shared_Node then
+ Move_Branch_Point (Tree, Min_Child_Node);
+ end if;
+ end;
+
+ Set_Children (Tree.Branched_Nodes, Nonterm_Node, Children);
+ end if;
+
+ return Nonterm_Node;
+ end Add_Nonterm;
+
+ function Add_Terminal
+ (Tree : in out Syntax_Trees.Tree;
+ Terminal : in Token_Index;
+ Terminals : in Base_Token_Arrays.Vector)
+ return Valid_Node_Index
+ is begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Shared_Terminal,
+ ID => Terminals (Terminal).ID,
+ Byte_Region => Terminals (Terminal).Byte_Region,
+ Terminal => Terminal,
+ others => <>));
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ return Tree.Last_Shared_Node;
+ else
+ Tree.Branched_Nodes.Append
+ ((Label => Shared_Terminal,
+ ID => Terminals (Terminal).ID,
+ Byte_Region => Terminals (Terminal).Byte_Region,
+ Terminal => Terminal,
+ others => <>));
+ return Tree.Branched_Nodes.Last_Index;
+ end if;
+ end Add_Terminal;
+
+ function Add_Terminal
+ (Tree : in out Syntax_Trees.Tree;
+ Terminal : in Token_ID)
+ return Valid_Node_Index
+ is begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Virtual_Terminal,
+ ID => Terminal,
+ others => <>));
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ return Tree.Last_Shared_Node;
+ else
+ Tree.Branched_Nodes.Append
+ ((Label => Virtual_Terminal,
+ ID => Terminal,
+ others => <>));
+ return Tree.Branched_Nodes.Last_Index;
+ end if;
+ end Add_Terminal;
+
+ function Augmented
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Base_Token_Class_Access
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Augmented;
+ else
+ return Tree.Branched_Nodes (Node).Augmented;
+ end if;
+ end Augmented;
+
+ function Byte_Region
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Buffer_Region
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).Byte_Region
+ else Tree.Branched_Nodes (Node).Byte_Region);
+ end Byte_Region;
+
+ function Child
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Child_Index : in Positive_Index_Type)
+ return Node_Index
+ is
+ function Compute (N : in Syntax_Trees.Node) return Node_Index
+ is begin
+ if Child_Index in N.Children.First_Index .. N.Children.Last_Index then
+ return N.Children (Child_Index);
+ else
+ return Invalid_Node_Index;
+ end if;
+ end Compute;
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Child;
+
+ function Children (N : in Syntax_Trees.Node) return Valid_Node_Index_Array
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if N.Children.Length = 0 then
+ return (1 .. 0 => <>);
+ else
+ return Result : Valid_Node_Index_Array (N.Children.First_Index ..
N.Children.Last_Index) do
+ for I in Result'Range loop
+ Result (I) := N.Children (I);
+ end loop;
+ end return;
+ end if;
+ end Children;
+
+ function Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Valid_Node_Index_Array
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Children (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Children (Tree.Branched_Nodes (Node));
+ end if;
+ end Children;
+
+ procedure Clear (Tree : in out Syntax_Trees.Base_Tree)
+ is begin
+ Tree.Finalize;
+ end Clear;
+
+ procedure Clear (Tree : in out Syntax_Trees.Tree)
+ is begin
+ if Tree.Shared_Tree.Augmented_Present then
+ for Node of Tree.Branched_Nodes loop
+ if Node.Label = Nonterm then
+ Free (Node.Augmented);
+ end if;
+ end loop;
+ end if;
+ Tree.Shared_Tree.Finalize;
+ Tree.Last_Shared_Node := Invalid_Node_Index;
+ Tree.Branched_Nodes.Clear;
+ end Clear;
+
+ function Copy_Subtree
+ (Tree : in out Syntax_Trees.Tree;
+ Root : in Valid_Node_Index;
+ Last : in Valid_Node_Index)
+ return Valid_Node_Index
+ is
+ function Copy_Node
+ (Tree : in out Syntax_Trees.Tree;
+ Index : in Valid_Node_Index;
+ Parent : in Node_Index)
+ return Valid_Node_Index
+ is begin
+ case Tree.Shared_Tree.Nodes (Index).Label is
+ when Shared_Terminal =>
+ declare
+ Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Index);
+ begin
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Shared_Terminal,
+ ID => Node.ID,
+ Byte_Region => Node.Byte_Region,
+ Parent => Parent,
+ State => Unknown_State,
+ Terminal => Node.Terminal));
+ end;
+
+ when Virtual_Terminal =>
+ declare
+ Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Index);
+ begin
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Virtual_Terminal,
+ ID => Node.ID,
+ Byte_Region => Node.Byte_Region,
+ Parent => Parent,
+ State => Unknown_State));
+ end;
+
+ when Virtual_Identifier =>
+ declare
+ Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Index);
+ begin
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Virtual_Identifier,
+ ID => Node.ID,
+ Byte_Region => Node.Byte_Region,
+ Parent => Parent,
+ State => Unknown_State,
+ Identifier => Node.Identifier));
+ end;
+
+ when Nonterm =>
+ declare
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Index);
+ Parent : Node_Index :=
Invalid_Node_Index;
+ New_Children : Valid_Node_Index_Arrays.Vector;
+ begin
+ if Children'Length > 0 then
+ declare
+ use all type SAL.Base_Peek_Type;
+ Last_Index : SAL.Base_Peek_Type :=
SAL.Base_Peek_Type'Last;
+ begin
+ for I in Children'Range loop
+ if Children (I) = Last then
+ Last_Index := I;
+ end if;
+ end loop;
+
+ if Last_Index = SAL.Base_Peek_Type'Last then
+ New_Children.Set_Length (Children'Length);
+ for I in Children'Range loop
+ New_Children (I) := Copy_Node (Tree, Children (I),
Parent);
+ end loop;
+ else
+ for I in Last_Index .. Children'Last loop
+ New_Children.Append (Copy_Node (Tree, Children (I),
Parent));
+ end loop;
+ end if;
+ end;
+ end if;
+
+ declare
+ Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes
(Index);
+ begin
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Nonterm,
+ ID => Node.ID,
+ Byte_Region => Node.Byte_Region,
+ Parent => Parent,
+ State => Unknown_State,
+ Virtual => Node.Virtual,
+ RHS_Index => Node.RHS_Index,
+ Action => Node.Action,
+ Name => Node.Name,
+ Children => New_Children,
+ Min_Terminal_Index => Node.Min_Terminal_Index,
+ Max_Terminal_Index => Node.Max_Terminal_Index,
+ Augmented => Node.Augmented));
+ end;
+
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ Parent := Tree.Last_Shared_Node;
+ for I in New_Children.First_Index .. New_Children.Last_Index
loop
+ Tree.Shared_Tree.Nodes (New_Children (I)).Parent := Parent;
+ end loop;
+
+ return Parent;
+ end;
+ end case;
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ return Tree.Last_Shared_Node;
+ end Copy_Node;
+
+ begin
+ return Copy_Node (Tree, Root, Invalid_Node_Index);
+ end Copy_Subtree;
+
+ function Count_IDs
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return SAL.Base_Peek_Type
+ is
+ function Compute (N : in Syntax_Trees.Node) return SAL.Base_Peek_Type
+ is
+ use all type SAL.Base_Peek_Type;
+ begin
+ return Result : SAL.Base_Peek_Type := 0 do
+ if N.ID = ID then
+ Result := 1;
+ end if;
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
+ null;
+ when Nonterm =>
+ for I of N.Children loop
+ Result := Result + Count_IDs (Tree, I, ID);
+ end loop;
+ end case;
+ end return;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Count_IDs;
+
+ function Count_Terminals
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Integer
+ -- Count_Terminals must return Integer for Get_Terminals,
+ -- Positive_Index_Type for Get_Terminal_IDs.
+ is
+ function Compute (N : in Syntax_Trees.Node) return Integer
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
+ return 1;
+
+ when Nonterm =>
+ return Result : Integer := 0 do
+ for I of N.Children loop
+ Result := Result + Count_Terminals (Tree, I);
+ end loop;
+ end return;
+ end case;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Count_Terminals;
+
+ overriding procedure Finalize (Tree : in out Base_Tree)
+ is begin
+ Tree.Traversing := False;
+ if Tree.Augmented_Present then
+ for Node of Tree.Nodes loop
+ if Node.Label = Nonterm then
+ Free (Node.Augmented);
+ end if;
+ end loop;
+ Tree.Augmented_Present := False;
+ end if;
+ Tree.Nodes.Finalize;
+ end Finalize;
+
+ overriding procedure Finalize (Tree : in out Syntax_Trees.Tree)
+ is begin
+ if Tree.Last_Shared_Node /= Invalid_Node_Index then
+ if Tree.Shared_Tree.Augmented_Present then
+ for Node of Tree.Branched_Nodes loop
+ Free (Node.Augmented);
+ end loop;
+ -- We don't clear Tree.Shared_Tree.Augmented_Present here; other
+ -- branched trees may need to be finalized.
+ end if;
+ Tree.Branched_Nodes.Finalize;
+ Tree.Last_Shared_Node := Invalid_Node_Index;
+ end if;
+ end Finalize;
+
+ function Find_Ancestor
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ is
+ N : Node_Index := Node;
+ begin
+ loop
+ N :=
+ (if N <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (N).Parent
+ else Tree.Branched_Nodes (N).Parent);
+
+ exit when N = Invalid_Node_Index;
+ exit when ID =
+ (if N <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (N).ID
+ else Tree.Branched_Nodes (N).ID);
+ end loop;
+ return N;
+ end Find_Ancestor;
+
+ function Find_Ancestor
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ IDs : in Token_ID_Array)
+ return Node_Index
+ is
+ N : Node_Index := Node;
+ begin
+ loop
+ N :=
+ (if N <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (N).Parent
+ else Tree.Branched_Nodes (N).Parent);
+
+ exit when N = Invalid_Node_Index;
+ exit when
+ (for some ID of IDs => ID =
+ (if N <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (N).ID
+ else Tree.Branched_Nodes (N).ID));
+ end loop;
+ return N;
+ end Find_Ancestor;
+
+ function Find_Child
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ is
+ function Compute (N : in Syntax_Trees.Node) return Node_Index
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
+ return Invalid_Node_Index;
+ when Nonterm =>
+ for C of N.Children loop
+ if ID =
+ (if C <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (C).ID
+ else Tree.Branched_Nodes (C).ID)
+ then
+ return C;
+ end if;
+ end loop;
+ return Invalid_Node_Index;
+ end case;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Find_Child;
+
+ function Find_Descendant
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ is
+ Found : Node_Index := Invalid_Node_Index;
+
+ function Process (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is
+ Node_ID : constant Token_ID :=
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).ID
+ else Tree.Branched_Nodes (Node).ID);
+ begin
+ if Node_ID = ID then
+ Found := Node;
+ return False;
+ else
+ return True;
+ end if;
+ end Process;
+
+ Junk : constant Boolean := Process_Tree (Tree, Node, After,
Process'Access);
+ pragma Unreferenced (Junk);
+ begin
+ return Found;
+ end Find_Descendant;
+
+ function Find_Min_Terminal_Index
+ (Tree : in Syntax_Trees.Tree;
+ Index : in Token_Index)
+ return Node_Index
+ is
+ Found : Node_Index := Invalid_Node_Index;
+
+ function Process (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is
+ function Compute (N : in Syntax_Trees.Node) return Boolean
+ is begin
+ if N.Label /= Nonterm then
+ return True;
+ elsif Index = N.Min_Terminal_Index then
+ Found := Node;
+ return False;
+ else
+ return True;
+ end if;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Process;
+
+ Junk : constant Boolean := Process_Tree (Tree, Tree.Root, Before,
Process'Access);
+ pragma Unreferenced (Junk);
+ begin
+ return Found;
+ end Find_Min_Terminal_Index;
+
+ function Find_Max_Terminal_Index
+ (Tree : in Syntax_Trees.Tree;
+ Index : in Token_Index)
+ return Node_Index
+ is
+ Found : Node_Index := Invalid_Node_Index;
+
+ function Process (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is
+ function Compute (N : in Syntax_Trees.Node) return Boolean
+ is begin
+ if N.Label /= Nonterm then
+ return True;
+ elsif Index = N.Max_Terminal_Index then
+ Found := Node;
+ return False;
+ else
+ return True;
+ end if;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Process;
+
+ Junk : constant Boolean := Process_Tree (Tree, Tree.Root, Before,
Process'Access);
+ pragma Unreferenced (Junk);
+ begin
+ return Found;
+ end Find_Max_Terminal_Index;
+
+ function Find_Sibling
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ is
+ function Compute_2 (N : in Syntax_Trees.Node) return Node_Index
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
+ return Invalid_Node_Index;
+
+ when Nonterm =>
+ for C of N.Children loop
+ if ID =
+ (if C <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (C).ID
+ else Tree.Branched_Nodes (C).ID)
+ then
+ return C;
+ end if;
+ end loop;
+ return Invalid_Node_Index;
+ end case;
+ end Compute_2;
+
+ function Compute_1 (Parent : in Node_Index) return Node_Index
+ is begin
+ if Parent = Invalid_Node_Index then
+ return Invalid_Node_Index;
+
+ else
+ return Compute_2
+ ((if Parent <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Parent)
+ else Tree.Branched_Nodes (Parent)));
+ end if;
+ end Compute_1;
+ begin
+ return Compute_1
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).Parent
+ else Tree.Branched_Nodes (Node).Parent));
+ end Find_Sibling;
+
+ function First_Index (Tree : in Syntax_Trees.Tree) return Node_Index
+ is begin
+ return Tree.Shared_Tree.Nodes.First_Index;
+ end First_Index;
+
+ procedure Flush (Tree : in out Syntax_Trees.Tree)
+ is begin
+ -- This is the opposite of Move_Branch_Point
+ Tree.Shared_Tree.Nodes.Merge (Tree.Branched_Nodes);
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ Tree.Flush := True;
+ end Flush;
+
+ function Flushed (Tree : in Syntax_Trees.Tree) return Boolean
+ is begin
+ return Tree.Flush;
+ end Flushed;
+
+ procedure Get_IDs
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID;
+ Result : in out Valid_Node_Index_Array;
+ Last : in out SAL.Base_Peek_Type)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ procedure Compute (N : in Syntax_Trees.Node)
+ is begin
+ if N.ID = ID then
+ Last := Last + 1;
+ Result (Last) := Node;
+ end if;
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
+ null;
+ when Nonterm =>
+ for I of N.Children loop
+ Get_IDs (Tree, I, ID, Result, Last);
+ end loop;
+ end case;
+ end Compute;
+ begin
+ Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Get_IDs;
+
+ function Get_IDs
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Valid_Node_Index_Array
+ is
+ Last : SAL.Base_Peek_Type := 0;
+ begin
+ Tree.Shared_Tree.Traversing := True;
+ return Result : Valid_Node_Index_Array (1 .. Count_IDs (Tree, Node, ID))
do
+ Get_IDs (Tree, Node, ID, Result, Last);
+ Tree.Shared_Tree.Traversing := False;
+ end return;
+ end Get_IDs;
+
+ procedure Get_Terminals
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Result : in out Valid_Node_Index_Array;
+ Last : in out SAL.Base_Peek_Type)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ procedure Compute (N : in Syntax_Trees.Node)
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
+ Last := Last + 1;
+ Result (Last) := Node;
+
+ when Nonterm =>
+ for I of N.Children loop
+ Get_Terminals (Tree, I, Result, Last);
+ end loop;
+ end case;
+ end Compute;
+ begin
+ Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Get_Terminals;
+
+ function Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index_Array
+ is
+ Last : SAL.Base_Peek_Type := 0;
+ begin
+ Tree.Shared_Tree.Traversing := True;
+ return Result : Valid_Node_Index_Array (1 .. SAL.Base_Peek_Type
(Count_Terminals (Tree, Node))) do
+ Get_Terminals (Tree, Node, Result, Last);
+ Tree.Shared_Tree.Traversing := False;
+ end return;
+ end Get_Terminals;
+
+ procedure Get_Terminal_IDs
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Result : in out Token_ID_Array;
+ Last : in out SAL.Base_Peek_Type)
+ is
+ procedure Compute (N : in Syntax_Trees.Node)
+ is
+ use all type SAL.Base_Peek_Type;
+ begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
+ Last := Last + 1;
+ Result (Integer (Last)) := N.ID;
+
+ when Nonterm =>
+ for I of N.Children loop
+ Get_Terminal_IDs (Tree, I, Result, Last);
+ end loop;
+ end case;
+ end Compute;
+ begin
+ Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Get_Terminal_IDs;
+
+ function Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID_Array
+ is
+ Last : SAL.Base_Peek_Type := 0;
+ begin
+ Tree.Shared_Tree.Traversing := True;
+ return Result : Token_ID_Array (1 .. Count_Terminals (Tree, Node)) do
+ Get_Terminal_IDs (Tree, Node, Result, Last);
+ Tree.Shared_Tree.Traversing := False;
+ end return;
+ end Get_Terminal_IDs;
+
+ function First_Terminal_ID (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID
+ is
+ function Compute (N : in Syntax_Trees.Node) return Token_ID
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
+ return N.ID;
+
+ when Nonterm =>
+ return First_Terminal_ID (Tree, N.Children (1));
+ end case;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end First_Terminal_ID;
+
+ function Has_Branched_Nodes (Tree : in Syntax_Trees.Tree) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ return Tree.Branched_Nodes.Length > 0;
+ end Has_Branched_Nodes;
+
+ function Has_Children (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Children.Length > 0;
+ else
+ return Tree.Branched_Nodes (Node).Children.Length > 0;
+ end if;
+ end Has_Children;
+
+ function Has_Parent (Tree : in Syntax_Trees.Tree; Child : in
Valid_Node_Index) return Boolean
+ is begin
+ return
+ (if Child <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Child).Parent /= Invalid_Node_Index
+ else Tree.Branched_Nodes (Child).Parent /= Invalid_Node_Index);
+ end Has_Parent;
+
+ function Has_Parent (Tree : in Syntax_Trees.Tree; Children : in
Valid_Node_Index_Array) return Boolean
+ is begin
+ return
+ (for some Child of Children =>
+ (if Child <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Child).Parent /= Invalid_Node_Index
+ else Tree.Branched_Nodes (Child).Parent /= Invalid_Node_Index));
+ end Has_Parent;
+
+ function ID
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Token_ID
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).ID
+ else Tree.Branched_Nodes (Node).ID);
+ end ID;
+
+ function Identifier (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Identifier_Index
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).Identifier
+ else Tree.Branched_Nodes (Node).Identifier);
+ end Identifier;
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Children : in Valid_Node_Index_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := +"(";
+ Need_Comma : Boolean := False;
+ begin
+ for I of Children loop
+ Result := Result & (if Need_Comma then ", " else "") &
+ Tree.Image (I, Descriptor, Include_Children => False);
+ Need_Comma := True;
+ end loop;
+ Result := Result & ")";
+ return -Result;
+ end Image;
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ N : in Syntax_Trees.Node;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean;
+ Include_RHS_Index : in Boolean := False)
+ return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String;
+ begin
+ if Include_Children and N.Label = Nonterm then
+ Result := +Image (N.ID, Descriptor) & '_' & Trimmed_Image
(N.RHS_Index) & ": ";
+ end if;
+
+ case N.Label is
+ when Shared_Terminal =>
+ Result := Result & (+Token_Index'Image (N.Terminal)) & ":";
+
+ when Virtual_Identifier =>
+ Result := Result & (+Identifier_Index'Image (N.Identifier)) & ";";
+
+ when others =>
+ null;
+ end case;
+
+ Result := Result & "(" & Image (N.ID, Descriptor) &
+ (if Include_RHS_Index and N.Label = Nonterm then "_" & Trimmed_Image
(N.RHS_Index) else "") &
+ (if N.Byte_Region = Null_Buffer_Region then "" else ", " & Image
(N.Byte_Region)) & ")";
+
+ if Include_Children and N.Label = Nonterm then
+ Result := Result & " <= " & Image (Tree, N.Children, Descriptor);
+ end if;
+
+ return -Result;
+ end Image;
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean := False)
+ return String
+ is begin
+ return Tree.Image
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)),
+ Descriptor, Include_Children);
+ end Image;
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Nodes : in Valid_Node_Index_Array;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := +"(";
+ Need_Comma : Boolean := False;
+ begin
+ for I in Nodes'Range loop
+ Result := Result & (if Need_Comma then ", " else "") &
+ Tree.Image (Nodes (I), Descriptor, Include_Children => False);
+ Need_Comma := True;
+ end loop;
+ Result := Result & ")";
+ return -Result;
+ end Image;
+
+ function Image
+ (Item : in Node_Sets.Vector;
+ Inverted : in Boolean := False)
+ return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String;
+ begin
+ for I in Item.First_Index .. Item.Last_Index loop
+ if (if Inverted then not Item (I) else Item (I)) then
+ Result := Result & Node_Index'Image (I);
+ end if;
+ end loop;
+ return -Result;
+ end Image;
+
+ procedure Initialize
+ (Branched_Tree : in out Syntax_Trees.Tree;
+ Shared_Tree : in Base_Tree_Access;
+ Flush : in Boolean)
+ is begin
+ Branched_Tree :=
+ (Ada.Finalization.Controlled with
+ Shared_Tree => Shared_Tree,
+ Last_Shared_Node => Shared_Tree.Nodes.Last_Index,
+ Branched_Nodes => <>,
+ Flush => Flush,
+ Root => <>);
+ end Initialize;
+
+ function Is_Empty (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Boolean
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Byte_Region = Null_Buffer_Region;
+ else
+ return Tree.Branched_Nodes (Node).Byte_Region = Null_Buffer_Region;
+ end if;
+ end Is_Empty;
+
+ function Is_Nonterm (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Label = Nonterm;
+ else
+ return Tree.Branched_Nodes (Node).Label = Nonterm;
+ end if;
+ end Is_Nonterm;
+
+ function Is_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Label = Shared_Terminal;
+ else
+ return Tree.Branched_Nodes (Node).Label = Shared_Terminal;
+ end if;
+ end Is_Terminal;
+
+ function Is_Virtual (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is
+ function Compute (N : in Syntax_Trees.Node) return Boolean
+ is begin
+ return N.Label = Virtual_Terminal or (N.Label = Nonterm and then
N.Virtual);
+ end Compute;
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Is_Virtual;
+
+ function Is_Virtual_Identifier (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).Label = Virtual_Identifier
+ else Tree.Branched_Nodes (Node).Label = Virtual_Identifier);
+ end Is_Virtual_Identifier;
+
+ function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Label
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Label;
+ else
+ return Tree.Branched_Nodes (Node).Label;
+ end if;
+ end Label;
+
+ function Last_Index (Tree : in Syntax_Trees.Tree) return Node_Index
+ is begin
+ return
+ (if Tree.Flush
+ then Tree.Shared_Tree.Nodes.Last_Index
+ else Tree.Branched_Nodes.Last_Index);
+ end Last_Index;
+
+ function Min (Item : in Valid_Node_Index_Array) return Valid_Node_Index
+ is
+ Result : Node_Index := Item (Item'First);
+ begin
+ for I in Item'Range loop
+ if Item (I) < Result then
+ Result := Item (I);
+ end if;
+ end loop;
+ return Result;
+ end Min;
+
+ function Min_Descendant (Nodes : in Node_Arrays.Vector; Node : in
Valid_Node_Index) return Valid_Node_Index
+ is
+ N : Syntax_Trees.Node renames Nodes (Node);
+ begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
+ return Node;
+
+ when Nonterm =>
+ declare
+ Min : Node_Index := Node;
+ begin
+ for C of N.Children loop
+ Min := Node_Index'Min (Min, Min_Descendant (Nodes, C));
+ end loop;
+ return Min;
+ end;
+ end case;
+ end Min_Descendant;
+
+ function Min_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index
+ is
+ function Compute (N : in Syntax_Trees.Node) return Base_Token_Index
+ is begin
+ return
+ (case N.Label is
+ when Shared_Terminal => N.Terminal,
+ when Virtual_Terminal | Virtual_Identifier => Invalid_Token_Index,
+ when Nonterm =>
N.Min_Terminal_Index);
+ end Compute;
+
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Min_Terminal_Index;
+
+ function Max_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index
+ is
+ function Compute (N : in Syntax_Trees.Node) return Base_Token_Index
+ is begin
+ return
+ (case N.Label is
+ when Shared_Terminal => N.Terminal,
+ when Virtual_Terminal | Virtual_Identifier => Invalid_Token_Index,
+ when Nonterm =>
N.Max_Terminal_Index);
+ end Compute;
+
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Max_Terminal_Index;
+
+ procedure Move_Branch_Point (Tree : in out Syntax_Trees.Tree; Required_Node
: in Valid_Node_Index)
+ is begin
+ -- Note that this preserves all stored indices in Branched_Nodes.
+ Tree.Branched_Nodes.Prepend (Tree.Shared_Tree.Nodes, Required_Node,
Tree.Last_Shared_Node);
+ Tree.Last_Shared_Node := Required_Node - 1;
+ end Move_Branch_Point;
+
+ function Parent
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Count : in Positive := 1)
+ return Node_Index
+ is
+ Result : Node_Index := Node;
+ N : Natural := 0;
+ begin
+ loop
+ if Result <= Tree.Last_Shared_Node then
+ Result := Tree.Shared_Tree.Nodes (Result).Parent;
+ else
+ Result := Tree.Branched_Nodes (Result).Parent;
+ end if;
+ N := N + 1;
+ exit when N = Count or Result = Invalid_Node_Index;
+ end loop;
+ return Result;
+ end Parent;
+
+ procedure Print_Tree
+ (Tree : in Syntax_Trees.Tree;
+ Descriptor : in WisiToken.Descriptor;
+ Root : in Node_Index := Invalid_Node_Index)
+ is
+ use Ada.Text_IO;
+
+ Node_Printed : Node_Sets.Vector;
+
+ procedure Print_Node (Node : in Valid_Node_Index; Level : in Integer)
+ is
+ function Image is new SAL.Generic_Decimal_Image (Node_Index);
+
+ N : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Node);
+ begin
+ if Node_Printed (Node) then
+ -- This does not catch all possible tree edit errors, but it does
+ -- catch circles.
+ raise SAL.Programmer_Error with "Print_Tree: invalid tree" &
Node_Index'Image (Node);
+ else
+ Node_Printed (Node) := True;
+ end if;
+
+ Put (Image (Node, Width => 4) & ": ");
+ for I in 1 .. Level loop
+ Put ("| ");
+ end loop;
+ Put_Line (Image (Tree, N, Descriptor, Include_Children => False,
Include_RHS_Index => True));
+
+ if N.Label = Nonterm then
+ for Child of N.Children loop
+ Print_Node (Child, Level + 1);
+ end loop;
+ end if;
+ end Print_Node;
+
+ begin
+ Node_Printed.Set_First_Last (Tree.First_Index, Tree.Last_Index);
+ Print_Node ((if Root = Invalid_Node_Index then Tree.Root else Root), 0);
+ end Print_Tree;
+
+ function Process_Tree
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Visit_Parent : in Visit_Parent_Mode;
+ Process_Node : access function
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Boolean)
+ return Boolean
+ is
+ function Compute (N : in Syntax_Trees.Node) return Boolean
+ is begin
+ if Visit_Parent = Before then
+ if not Process_Node (Tree, Node) then
+ return False;
+ end if;
+ end if;
+
+ if N.Label = Nonterm then
+ for Child of N.Children loop
+ if not Process_Tree (Tree, Child, Visit_Parent, Process_Node)
then
+ return False;
+ end if;
+ end loop;
+ end if;
+
+ if Visit_Parent = After then
+ return Process_Node (Tree, Node);
+ else
+ return True;
+ end if;
+ end Compute;
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Process_Tree;
+
+ procedure Process_Tree
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Process_Node : access procedure
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index))
+ is
+ procedure Compute (N : in Syntax_Trees.Node)
+ is begin
+ if N.Label = Nonterm then
+ for Child of N.Children loop
+ Process_Tree (Tree, Child, Process_Node);
+ end loop;
+ end if;
+
+ Process_Node (Tree, Node);
+ end Compute;
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Process_Tree;
+
+ procedure Process_Tree
+ (Tree : in out Syntax_Trees.Tree;
+ Process_Node : access procedure
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index);
+ Root : in Node_Index := Invalid_Node_Index)
+ is begin
+ if Root = Invalid_Node_Index and Tree.Root = Invalid_Node_Index then
+ raise SAL.Programmer_Error with "Tree.Root not set";
+ end if;
+ Tree.Shared_Tree.Traversing := True;
+ Process_Tree (Tree, (if Root = Invalid_Node_Index then Tree.Root else
Root), Process_Node);
+ Tree.Shared_Tree.Traversing := False;
+ exception
+ when others =>
+ Tree.Shared_Tree.Traversing := False;
+ raise;
+ end Process_Tree;
+
+ function Production_ID
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Production_ID
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then (Tree.Shared_Tree.Nodes (Node).ID, Tree.Shared_Tree.Nodes
(Node).RHS_Index)
+ else (Tree.Branched_Nodes (Node).ID, Tree.Branched_Nodes
(Node).RHS_Index));
+ end Production_ID;
+
+ function RHS_Index
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Natural
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).RHS_Index
+ else Tree.Branched_Nodes (Node).RHS_Index);
+ end RHS_Index;
+
+ procedure Set_Node_Identifier
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID;
+ Identifier : in Identifier_Index)
+ is
+ Current : constant Syntax_Trees.Node := Tree.Shared_Tree.Nodes (Node);
+ begin
+ Tree.Shared_Tree.Nodes.Replace_Element
+ (Node,
+ (Label => Virtual_Identifier,
+ ID => ID,
+ Identifier => Identifier,
+ Byte_Region => Current.Byte_Region,
+ Parent => Current.Parent,
+ State => Unknown_State));
+ end Set_Node_Identifier;
+
+ procedure Set_Root (Tree : in out Syntax_Trees.Tree; Root : in
Valid_Node_Index)
+ is begin
+ Tree.Root := Root;
+ end Set_Root;
+
+ function Root (Tree : in Syntax_Trees.Tree) return Node_Index
+ is begin
+ if Tree.Root /= Invalid_Node_Index then
+ return Tree.Root;
+ else
+ if Tree.Flush then
+ return Tree.Shared_Tree.Nodes.Last_Index;
+ else
+ return Tree.Branched_Nodes.Last_Index;
+ end if;
+ end if;
+ end Root;
+
+ function Same_Token
+ (Tree_1 : in Syntax_Trees.Tree'Class;
+ Index_1 : in Valid_Node_Index;
+ Tree_2 : in Syntax_Trees.Tree'Class;
+ Index_2 : in Valid_Node_Index)
+ return Boolean
+ is
+ function Compute (N_1, N_2 : in Syntax_Trees.Node) return Boolean
+ is begin
+ return N_1.Label = N_2.Label and
+ N_1.ID = N_2.ID and
+ N_1.Byte_Region = N_2.Byte_Region;
+ end Compute;
+ begin
+ return Compute
+ ((if Index_1 <= Tree_1.Last_Shared_Node
+ then Tree_1.Shared_Tree.Nodes (Index_1)
+ else Tree_1.Branched_Nodes (Index_1)),
+ (if Index_2 <= Tree_2.Last_Shared_Node
+ then Tree_2.Shared_Tree.Nodes (Index_2)
+ else Tree_2.Branched_Nodes (Index_2)));
+ end Same_Token;
+
+ procedure Set_Augmented
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Value : in Base_Token_Class_Access)
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ Tree.Shared_Tree.Nodes (Node).Augmented := Value;
+ else
+ Tree.Branched_Nodes (Node).Augmented := Value;
+ end if;
+ Tree.Shared_Tree.Augmented_Present := True;
+ end Set_Augmented;
+
+ procedure Set_Children
+ (Nodes : in out Node_Arrays.Vector;
+ Parent : in Valid_Node_Index;
+ Children : in Valid_Node_Index_Array)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ N : Nonterm_Node renames Nodes (Parent);
+ J : Positive_Index_Type := Positive_Index_Type'First;
+
+ Min_Terminal_Index_Set : Boolean := False;
+ begin
+ N.Children.Set_Length (Children'Length);
+ for I in Children'Range loop
+ N.Children (J) := Children (I);
+ declare
+ K : Node renames Nodes (Children (I));
+ begin
+ K.Parent := Parent;
+
+ N.Virtual := N.Virtual or
+ (case K.Label is
+ when Shared_Terminal => False,
+ when Virtual_Terminal | Virtual_Identifier => True,
+ when Nonterm => K.Virtual);
+
+ if N.Byte_Region.First > K.Byte_Region.First then
+ N.Byte_Region.First := K.Byte_Region.First;
+ end if;
+
+ if N.Byte_Region.Last < K.Byte_Region.Last then
+ N.Byte_Region.Last := K.Byte_Region.Last;
+ end if;
+
+ if not Min_Terminal_Index_Set then
+ case K.Label is
+ when Shared_Terminal =>
+ Min_Terminal_Index_Set := True;
+ N.Min_Terminal_Index := K.Terminal;
+
+ when Virtual_Terminal | Virtual_Identifier =>
+ null;
+
+ when Nonterm =>
+ if K.Min_Terminal_Index /= Invalid_Token_Index then
+ -- not an empty nonterm
+ Min_Terminal_Index_Set := True;
+ N.Min_Terminal_Index := K.Min_Terminal_Index;
+ end if;
+ end case;
+ end if;
+
+ case K.Label is
+ when Shared_Terminal =>
+ if N.Max_Terminal_Index < K.Terminal then
+ N.Max_Terminal_Index := K.Terminal;
+ end if;
+
+ when Virtual_Terminal | Virtual_Identifier =>
+ null;
+
+ when Nonterm =>
+ if K.Max_Terminal_Index /= Invalid_Token_Index and then
+ -- not an empty nonterm
+ N.Max_Terminal_Index < K.Max_Terminal_Index
+ then
+ N.Max_Terminal_Index := K.Max_Terminal_Index;
+ end if;
+ end case;
+ end;
+
+ J := J + 1;
+ end loop;
+ end Set_Children;
+
+ procedure Set_Children
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ New_ID : in WisiToken.Production_ID;
+ Children : in Valid_Node_Index_Array)
+ is
+ use all type SAL.Base_Peek_Type;
+ Parent_Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Node);
+
+ J : Positive_Index_Type := Positive_Index_Type'First;
+ begin
+ Parent_Node.ID := New_ID.LHS;
+ Parent_Node.RHS_Index := New_ID.RHS;
+ Parent_Node.Action := null;
+
+ Parent_Node.Children.Set_Length (Children'Length);
+ for I in Children'Range loop
+ -- We don't update Min/Max_terminal_index; we assume Set_Children is
+ -- only called after parsing is done, so they are no longer needed.
+ Parent_Node.Children (J) := Children (I);
+ Tree.Shared_Tree.Nodes (Children (I)).Parent := Node;
+ J := J + 1;
+ end loop;
+ end Set_Children;
+
+ procedure Set_State
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ State : in State_Index)
+ is begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes (Node).State := State;
+ else
+ if Node <= Tree.Last_Shared_Node then
+ Tree.Shared_Tree.Nodes (Node).State := State;
+ else
+ Tree.Branched_Nodes (Node).State := State;
+ end if;
+ end if;
+ end Set_State;
+
+ procedure Set_Flush_False (Tree : in out Syntax_Trees.Tree)
+ is begin
+ Tree.Flush := False;
+ Tree.Branched_Nodes.Set_First (Tree.Last_Shared_Node + 1);
+ end Set_Flush_False;
+
+ procedure Set_Name_Region
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Region : in Buffer_Region)
+ is begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes (Node).Name := Region;
+
+ else
+ if Node <= Tree.Last_Shared_Node then
+ Move_Branch_Point (Tree, Node);
+ end if;
+
+ Tree.Branched_Nodes (Node).Name := Region;
+ end if;
+ end Set_Name_Region;
+
+ function Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Base_Token_Index
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Terminal;
+ else
+ return Tree.Branched_Nodes (Node).Terminal;
+ end if;
+ end Terminal;
+
+ function Traversing (Tree : in Syntax_Trees.Tree) return Boolean
+ is begin
+ return Tree.Shared_Tree.Traversing;
+ end Traversing;
+
+ function Recover_Token
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Recover_Token
+ is
+ function Compute (N : Syntax_Trees.Node) return WisiToken.Recover_Token
+ is begin
+ case N.Label is
+ when Shared_Terminal =>
+ return
+ (ID => N.ID,
+ Byte_Region => N.Byte_Region,
+ Min_Terminal_Index => N.Terminal,
+ Name => Null_Buffer_Region,
+ Virtual => False);
+
+ when Virtual_Terminal | Virtual_Identifier =>
+ return
+ (ID => N.ID,
+ Byte_Region => Null_Buffer_Region,
+ Min_Terminal_Index => Invalid_Token_Index,
+ Name => Null_Buffer_Region,
+ Virtual => True);
+
+ when Nonterm =>
+ return
+ (ID => N.ID,
+ Byte_Region => N.Byte_Region,
+ Min_Terminal_Index => N.Min_Terminal_Index,
+ Name => N.Name,
+ Virtual => N.Virtual);
+ end case;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Recover_Token;
+
+ function Recover_Token_Array
+ (Tree : in Syntax_Trees.Tree;
+ Nodes : in Valid_Node_Index_Array)
+ return WisiToken.Recover_Token_Array
+ is begin
+ return Result : WisiToken.Recover_Token_Array (Nodes'First ..
Nodes'Last) do
+ for I in Result'Range loop
+ Result (I) := Tree.Recover_Token (Nodes (I));
+ end loop;
+ end return;
+ end Recover_Token_Array;
+
+ function State (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Unknown_State_Index
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).State;
+ else
+ return Tree.Branched_Nodes (Node).State;
+ end if;
+ end State;
+
+end WisiToken.Syntax_Trees;
diff --git a/wisitoken-syntax_trees.ads b/wisitoken-syntax_trees.ads
index d5cbec1..dcca9b4 100644
--- a/wisitoken-syntax_trees.ads
+++ b/wisitoken-syntax_trees.ads
@@ -1,431 +1,567 @@
--- Abstract :
---
--- Syntax tree type and operations.
---
--- Rationale :
---
--- We provide Base_Tree and Tree in one package, because only Tree
--- needs an API; the only way Base_Tree is accessed is via Tree.
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
-
--- There is one syntax tree for each parser. There is one shared
--- Terminals array, matching the actual input text.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with SAL.Gen_Unbounded_Definite_Vectors;
-with WisiToken.Lexer;
-package WisiToken.Syntax_Trees is
-
- type Base_Tree is new Ada.Finalization.Controlled with private;
-
- type Base_Tree_Access is access all Base_Tree;
-
- overriding procedure Finalize (Tree : in out Base_Tree);
- -- Free any allocated storage.
-
- overriding procedure Adjust (Tree : in out Base_Tree);
- -- Copy any allocated storage.
-
- type Tree is tagged private;
-
- procedure Initialize
- (Branched_Tree : in out Tree;
- Shared_Tree : in Base_Tree_Access;
- Flush : in Boolean);
- -- Set Branched_Tree to refer to Shared_Tree.
-
- type Node_Index is range 0 .. Integer'Last;
- subtype Valid_Node_Index is Node_Index range 1 .. Node_Index'Last;
-
- Invalid_Node_Index : constant Node_Index := Node_Index'First;
-
- type Valid_Node_Index_Array is array (Positive_Index_Type range <>) of
Valid_Node_Index;
- -- Index matches Base_Token_Array, Augmented_Token_Array
-
- package Valid_Node_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive_Index_Type, Valid_Node_Index, Default_Element =>
Valid_Node_Index'First);
- -- Index matches Valid_Node_Index_Array.
-
- type Node_Label is (Shared_Terminal, Virtual_Terminal, Nonterm);
-
- type User_Data_Type is tagged limited null record;
- -- Many test languages don't need this, so we default the procedures
- -- to null.
-
- type User_Data_Access is access all User_Data_Type'Class;
-
- procedure Set_Lexer_Terminals
- (User_Data : in out User_Data_Type;
- Lexer : in WisiToken.Lexer.Handle;
- Terminals : in Base_Token_Array_Access)
- is null;
-
- procedure Reset (User_Data : in out User_Data_Type) is null;
- -- Reset to start a new parse.
-
- procedure Lexer_To_Augmented
- (User_Data : in out User_Data_Type;
- Token : in Base_Token;
- Lexer : not null access WisiToken.Lexer.Instance'Class)
- is null;
- -- Read auxiliary data from Lexer, create an Augmented_Token, store
- -- it in User_Data. Called before parsing, once for each token in the
- -- input stream.
-
- procedure Delete_Token
- (User_Data : in out User_Data_Type;
- Token_Index : in WisiToken.Token_Index)
- is null;
- -- Token at Token_Index was deleted in error recovery; update
- -- remaining tokens and Tree as needed. Called from Execute_Actions
- -- for each deleted token, before processing the syntax tree.
-
- procedure Reduce
- (User_Data : in out User_Data_Type;
- Tree : in out Syntax_Trees.Tree'Class;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array)
- is null;
- -- Reduce Tokens to Nonterm. Nonterm.Byte_Region is computed by
- -- caller.
-
- type Semantic_Action is access procedure
- (User_Data : in out User_Data_Type'Class;
- Tree : in out Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array);
- -- Routines of this type are called by
- -- WisiToken.LR.Parser.Execute_Actions when it processes a Nonterm
- -- node in the syntax tree. Tokens are the children of Nonterm.
-
- Null_Action : constant Semantic_Action := null;
-
- procedure Clear (Tree : in out Syntax_Trees.Base_Tree);
- procedure Clear (Tree : in out Syntax_Trees.Tree);
- -- Delete all Elements and free associated memory; keep results of
- -- Initialize.
-
- procedure Flush (Tree : in out Syntax_Trees.Tree);
- -- Move all nodes in branched part to shared tree, set Flush mode
- -- True.
-
- procedure Set_Flush_False (Tree : in out Syntax_Trees.Tree);
- -- Set Flush mode False; use Flush to set True.
-
- function Flushed (Tree : in Syntax_Trees.Tree) return Boolean;
-
- function Add_Nonterm
- (Tree : in out Syntax_Trees.Tree;
- Production : in Production_ID;
- Children : in Valid_Node_Index_Array;
- Action : in Semantic_Action;
- Default_Virtual : in Boolean)
- return Valid_Node_Index
- with
- Pre => not Tree.Traversing,
- Post => Tree.Is_Empty (Add_Nonterm'Result) or
- Tree.Min_Terminal_Index (Add_Nonterm'Result) /=
Invalid_Token_Index;
- -- Add a new Nonterm node, which can be empty. Result points to the
- -- added node. If Children'Length = 0, set Nonterm.Virtual :=
- -- Default_Virtual.
-
- function Add_Terminal
- (Tree : in out Syntax_Trees.Tree;
- Terminal : in Token_Index;
- Terminals : in Base_Token_Arrays.Vector)
- return Valid_Node_Index
- with Pre => not Tree.Traversing;
- -- Add a new Terminal node. Terminal must be an index into Terminals.
- -- Result points to the added node.
-
- function Add_Terminal
- (Tree : in out Syntax_Trees.Tree;
- Terminal : in Token_ID)
- return Valid_Node_Index
- with Pre => not Tree.Traversing;
- -- Add a new virtual terminal node with no parent. Result points to
- -- the added node.
-
- procedure Set_State
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- State : in State_Index);
-
- function State (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Unknown_State_Index;
-
- function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Label;
-
- function Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Valid_Node_Index_Array
- with Pre => Tree.Is_Nonterm (Node);
-
- function Has_Branched_Nodes (Tree : in Syntax_Trees.Tree) return Boolean;
- function Has_Children (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
- function Has_Parent (Tree : in Syntax_Trees.Tree; Child : in
Valid_Node_Index) return Boolean;
- function Has_Parent (Tree : in Syntax_Trees.Tree; Children : in
Valid_Node_Index_Array) return Boolean;
- function Is_Empty (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Boolean;
- function Is_Nonterm (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
- function Is_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
- function Is_Virtual (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
- function Traversing (Tree : in Syntax_Trees.Tree) return Boolean;
-
- function Parent (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Index;
-
- procedure Set_Name_Region
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Region : in Buffer_Region)
- with Pre => Tree.Is_Nonterm (Node);
-
- function ID
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Token_ID;
-
- function Byte_Region
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Buffer_Region;
-
- function Same_Token
- (Tree_1 : in Syntax_Trees.Tree'Class;
- Index_1 : in Valid_Node_Index;
- Tree_2 : in Syntax_Trees.Tree'Class;
- Index_2 : in Valid_Node_Index)
- return Boolean;
- -- True if the two tokens have the same ID and Byte_Region.
-
- function Recover_Token
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Recover_Token;
-
- function Recover_Token_Array
- (Tree : in Syntax_Trees.Tree;
- Nodes : in Valid_Node_Index_Array)
- return WisiToken.Recover_Token_Array;
- -- For non-virtual terminals, copied from Tree.Terminals. For others,
- -- constructed from Tree data.
-
- procedure Set_Augmented
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Value : in Base_Token_Class_Access)
- with Pre => Tree.Is_Nonterm (Node);
- -- Value will be deallocated when Tree is finalized.
-
- function Augmented
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Base_Token_Class_Access
- with Pre => Tree.Is_Nonterm (Node);
- -- Returns result of Set_Augmented.
-
- function Action
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Semantic_Action
- with Pre => Tree.Is_Nonterm (Node);
-
- function Find_Ancestor
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index;
- -- Return the ancestor of Node that contains ID, or Invalid_Node_Index if
- -- none match.
-
- function Find_Sibling
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- with Pre => Tree.Has_Parent (Node);
- -- Return the sibling of Node that contains ID, or Invalid_Node_Index if
- -- none match.
-
- function Find_Child
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- with Pre => Tree.Is_Nonterm (Node);
- -- Return the child of Node whose ID is ID, or Invalid_Node_Index if
- -- none match.
-
- function Find_Descendant
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index;
- -- Return the descendant of Node (may be Node) whose ID is ID, or
- -- Invalid_Node_Index if none match.
-
- function Find_Min_Terminal_Index
- (Tree : in Syntax_Trees.Tree;
- Index : in Token_Index)
- return Node_Index
- with Post => Find_Min_Terminal_Index'Result = Invalid_Node_Index or else
- Tree.Is_Nonterm (Find_Min_Terminal_Index'Result);
- -- Return the first node whose Min_Terminal_Index is Index, or
- -- Invalid_Node_Index if none match.
-
- function Find_Max_Terminal_Index
- (Tree : in Syntax_Trees.Tree;
- Index : in Token_Index)
- return Node_Index
- with Post => Find_Max_Terminal_Index'Result = Invalid_Node_Index or else
- Tree.Is_Nonterm (Find_Max_Terminal_Index'Result);
- -- Return the first node whose Max_Terminal_Index is Index, or
- -- Invalid_Node_Index if none match.
-
- procedure Set_Root (Tree : in out Syntax_Trees.Tree; Root : in
Valid_Node_Index);
-
- function Root (Tree : in Syntax_Trees.Tree) return Node_Index;
- -- Return value set by Set_Root; defaults to the last node added.
- -- returns Invalid_Node_Index if Tree is empty.
-
- procedure Process_Tree
- (Tree : in out Syntax_Trees.Tree;
- Process_Node : access procedure
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index));
- -- Traverse Tree in depth-first order, calling Process_Node on each
- -- node, starting at Tree.Root.
-
- function Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Base_Token_Index
- with Pre => Tree.Is_Terminal (Node);
-
- function Min_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index;
- function Max_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index;
- -- Returns lowest/highest index of shared terminal in subtree under
- -- Node. If result is Invalid_Token_Index, all terminals are virtual,
- -- or a nonterm is empty.
-
- function Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index_Array;
-
- function Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID_Array;
-
- function Image
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Descriptor : in WisiToken.Descriptor;
- Include_Children : in Boolean := False)
- return String;
- function Image
- (Tree : in Syntax_Trees.Tree;
- Nodes : in Valid_Node_Index_Array;
- Descriptor : in WisiToken.Descriptor)
- return String;
- -- For debug and error messages.
-
- procedure Print_Tree (Tree : in Syntax_Trees.Tree; Descriptor : in
WisiToken.Descriptor)
- with Pre => Tree.Flushed;
- -- To Text_IO.Current_Output, for debugging.
-
-private
-
- type Node (Label : Node_Label := Virtual_Terminal) is
- -- Label has a default to allow use with Ada.Containers.Vectors; all
- -- entries are the same size.
- record
- ID : WisiToken.Token_ID := Invalid_Token_ID;
-
- Byte_Region : Buffer_Region := Null_Buffer_Region;
- -- Computed by Set_Children, used in Semantic_Check actions and debug
- -- messages.
-
- Parent : Node_Index := Invalid_Node_Index;
-
- State : Unknown_State_Index := Unknown_State;
- -- Parse state that was on stack with this token, to allow undoing a
- -- reduce.
-
- case Label is
- when Shared_Terminal =>
- Terminal : Token_Index;
-
- when Virtual_Terminal =>
- null;
-
- when Nonterm =>
- Virtual : Boolean := False;
- -- True if any child node is Virtual_Terminal or Nonterm with Virtual
- -- set. Used by Semantic_Check actions.
-
- RHS_Index : Natural;
- -- With ID, index into Productions.
- -- Used for debug output, keep for future use.
-
- Action : Semantic_Action := null;
-
- Name : Buffer_Region := Null_Buffer_Region;
- -- Name is set and checked by Semantic_Check actions.
-
- Children : Valid_Node_Index_Arrays.Vector;
-
- Min_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
- -- Cached for push_back of nonterminals during recovery
-
- Max_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
- -- Cached for building a WisiToken tree from a libadalang tree.
-
- Augmented : Base_Token_Class_Access := null;
- end case;
- end record;
-
- subtype Nonterm_Node is Node (Nonterm);
-
- package Node_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Valid_Node_Index, Node, Default_Element => (others => <>));
-
- type Base_Tree is new Ada.Finalization.Controlled with record
- Nodes : Node_Arrays.Vector;
- -- During normal parsing, tokens are added to Nodes by "parallel"
- -- LALR parsers, but they are all run from one Ada task, so there's
- -- no need for Nodes to be Protected. Packrat parsing also has a
- -- single Ada task.
- --
- -- During McKenzie_Recover, the syntax tree is not modified.
-
- Augmented_Present : Boolean := False;
- -- True if Set_Augmented has been called on any node.
- -- Declared in Base_Tree because used by Base_Tree.Adjust.
-
- Traversing : Boolean := False;
- -- True while traversing tree in Process_Tree.
- -- Declared in Base_Tree so it is cleared by Finalize.
-
- end record;
-
- type Tree is tagged record
- Shared_Tree : Base_Tree_Access;
- -- If we need to set anything (ie parent) in Shared_Tree, we move the
- -- branch point instead, unless Flush = True.
-
- Last_Shared_Node : Node_Index := Invalid_Node_Index;
- Branched_Nodes : Node_Arrays.Vector;
- Flush : Boolean := False;
- -- We maintain Last_Shared_Node when Flush is True, so subprograms
- -- that have no reason to check Flush can rely on Last_Shared_Node.
-
- Root : Node_Index := Invalid_Node_Index;
- end record with
- Type_Invariant => (if Tree.Flush then not Tree.Has_Branched_Nodes);
-
-end WisiToken.Syntax_Trees;
+-- Abstract :
+--
+-- Syntax tree type and operations.
+--
+-- Rationale :
+--
+-- We provide Base_Tree and Tree in one package, because only Tree
+-- needs an API; the only way Base_Tree is accessed is via Tree.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+
+-- There is one syntax tree for each parser. There is one shared
+-- Terminals array, matching the actual input text.
+--
+-- Copyright (C) 2018 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with SAL.Gen_Unbounded_Definite_Vectors;
+with WisiToken.Lexer;
+package WisiToken.Syntax_Trees is
+
+ type Base_Tree is new Ada.Finalization.Controlled with private;
+
+ type Base_Tree_Access is access all Base_Tree;
+
+ overriding procedure Finalize (Tree : in out Base_Tree);
+ -- Free any allocated storage.
+
+ type Tree is new Ada.Finalization.Controlled with private;
+
+ procedure Initialize
+ (Branched_Tree : in out Tree;
+ Shared_Tree : in Base_Tree_Access;
+ Flush : in Boolean);
+ -- Set Branched_Tree to refer to Shared_Tree.
+
+ overriding procedure Finalize (Tree : in out Syntax_Trees.Tree);
+ -- Free any allocated storage.
+
+ type Node_Index is range 0 .. Integer'Last;
+ subtype Valid_Node_Index is Node_Index range 1 .. Node_Index'Last;
+
+ Invalid_Node_Index : constant Node_Index := Node_Index'First;
+
+ type Valid_Node_Index_Array is array (Positive_Index_Type range <>) of
Valid_Node_Index;
+ -- Index matches Base_Token_Array, Augmented_Token_Array
+
+ package Valid_Node_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Positive_Index_Type, Valid_Node_Index, Default_Element =>
Valid_Node_Index'First);
+ -- Index matches Valid_Node_Index_Array.
+
+ type Node_Label is
+ (Shared_Terminal, -- text is user input, accessed via Parser.Terminals
+ Virtual_Terminal, -- no text; inserted during error recovery
+ Virtual_Identifier, -- text in user data, created during tree rewrite
+ Nonterm -- contains terminals/nonterminals/identifiers
+ );
+
+ type User_Data_Type is tagged limited null record;
+ -- Many test languages don't need this, so we default the procedures
+ -- to null.
+
+ type User_Data_Access is access all User_Data_Type'Class;
+
+ procedure Set_Lexer_Terminals
+ (User_Data : in out User_Data_Type;
+ Lexer : in WisiToken.Lexer.Handle;
+ Terminals : in Base_Token_Array_Access)
+ is null;
+
+ procedure Reset (User_Data : in out User_Data_Type) is null;
+ -- Reset to start a new parse.
+
+ procedure Initialize_Actions
+ (User_Data : in out User_Data_Type;
+ Tree : in Syntax_Trees.Tree'Class)
+ is null;
+ -- Called by Execute_Actions, before processing the tree.
+
+ procedure Lexer_To_Augmented
+ (User_Data : in out User_Data_Type;
+ Token : in Base_Token;
+ Lexer : not null access WisiToken.Lexer.Instance'Class)
+ is null;
+ -- Read auxiliary data from Lexer, do something useful with it.
+ -- Called before parsing, once for each token in the input stream.
+
+ procedure Delete_Token
+ (User_Data : in out User_Data_Type;
+ Token_Index : in WisiToken.Token_Index)
+ is null;
+ -- Token at Token_Index was deleted in error recovery; update
+ -- remaining tokens and Tree as needed. Called from Execute_Actions
+ -- for each deleted token, before processing the syntax tree.
+
+ procedure Reduce
+ (User_Data : in out User_Data_Type;
+ Tree : in out Syntax_Trees.Tree'Class;
+ Nonterm : in Valid_Node_Index;
+ Tokens : in Valid_Node_Index_Array)
+ is null;
+ -- Reduce Tokens to Nonterm. Nonterm.Byte_Region is computed by
+ -- caller.
+
+ type Semantic_Action is access procedure
+ (User_Data : in out User_Data_Type'Class;
+ Tree : in out Syntax_Trees.Tree;
+ Nonterm : in Valid_Node_Index;
+ Tokens : in Valid_Node_Index_Array);
+ -- Routines of this type are called by
+ -- WisiToken.LR.Parser.Execute_Actions when it processes a Nonterm
+ -- node in the syntax tree. Tokens are the children of Nonterm.
+
+ Null_Action : constant Semantic_Action := null;
+
+ procedure Clear (Tree : in out Syntax_Trees.Base_Tree);
+ procedure Clear (Tree : in out Syntax_Trees.Tree);
+ -- Delete all Elements and free associated memory; keep results of
+ -- Initialize.
+
+ procedure Flush (Tree : in out Syntax_Trees.Tree);
+ -- Move all nodes in branched part to shared tree, set Flush mode
+ -- True.
+
+ procedure Set_Flush_False (Tree : in out Syntax_Trees.Tree);
+ -- Set Flush mode False; use Flush to set True.
+
+ function Flushed (Tree : in Syntax_Trees.Tree) return Boolean;
+
+ function Copy_Subtree
+ (Tree : in out Syntax_Trees.Tree;
+ Root : in Valid_Node_Index;
+ Last : in Valid_Node_Index)
+ return Valid_Node_Index
+ with Pre => Tree.Flushed;
+ -- Deep copy (into Tree) subtree of Tree rooted at Root. Stop copying
+ -- after children of Last are copied. Return root of new subtree.
+ --
+ -- Node index order is preserved. References to objects external to
+ -- tree are shallow copied.
+
+ function Add_Nonterm
+ (Tree : in out Syntax_Trees.Tree;
+ Production : in Production_ID;
+ Children : in Valid_Node_Index_Array;
+ Action : in Semantic_Action := null;
+ Default_Virtual : in Boolean := False)
+ return Valid_Node_Index
+ with Pre => not Tree.Traversing;
+ -- Add a new Nonterm node, which can be empty. Result points to the
+ -- added node. If Children'Length = 0, set Nonterm.Virtual :=
+ -- Default_Virtual.
+
+ function Add_Terminal
+ (Tree : in out Syntax_Trees.Tree;
+ Terminal : in Token_Index;
+ Terminals : in Base_Token_Arrays.Vector)
+ return Valid_Node_Index
+ with Pre => not Tree.Traversing;
+ -- Add a new Terminal node. Terminal must be an index into Terminals.
+ -- Result points to the added node.
+
+ function Add_Terminal
+ (Tree : in out Syntax_Trees.Tree;
+ Terminal : in Token_ID)
+ return Valid_Node_Index
+ with Pre => not Tree.Traversing;
+ -- Add a new Virtual_Terminal node with no parent. Result points to
+ -- the added node.
+
+ function Add_Identifier
+ (Tree : in out Syntax_Trees.Tree;
+ ID : in Token_ID;
+ Identifier : in Identifier_Index;
+ Byte_Region : in WisiToken.Buffer_Region)
+ return Valid_Node_Index
+ with Pre => Tree.Flushed and (not Tree.Traversing);
+ -- Add a new Virtual_Identifier node with no parent. Byte_Region
+ -- should point to an area in the source buffer related to the new
+ -- identifier, to aid debugging. Result points to the added node.
+
+ procedure Add_Child
+ (Tree : in out Syntax_Trees.Tree;
+ Parent : in Valid_Node_Index;
+ Child : in Valid_Node_Index)
+ with
+ Pre => Tree.Flushed and
+ (not Tree.Traversing) and
+ Tree.Is_Nonterm (Parent);
+ -- Child.Parent must already be set.
+
+ procedure Set_Children
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ New_ID : in WisiToken.Production_ID;
+ Children : in Valid_Node_Index_Array)
+ with
+ Pre => Tree.Flushed and
+ (not Tree.Traversing) and
+ Tree.Is_Nonterm (Node);
+ -- Set ID of Node to New_ID, and children to Children; set parent of
+ -- Children to Node. Remove any Action.
+ --
+ -- New_ID is required, and Action removed, because this is most
+ -- likely a different production.
+
+ procedure Set_Node_Identifier
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID;
+ Identifier : in Identifier_Index)
+ with Pre => Tree.Flushed and
+ Tree.Is_Nonterm (Node);
+ -- Change Node to a Virtual_Identifier.
+
+ procedure Set_State
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ State : in State_Index);
+
+ function State (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Unknown_State_Index;
+
+ function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Label;
+
+ function Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Valid_Node_Index_Array
+ with Pre => Tree.Is_Nonterm (Node);
+
+ function Child
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Child_Index : in Positive_Index_Type)
+ return Node_Index
+ with Pre => Tree.Is_Nonterm (Node);
+
+ function Has_Branched_Nodes (Tree : in Syntax_Trees.Tree) return Boolean;
+ function Has_Children (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Has_Parent (Tree : in Syntax_Trees.Tree; Child : in
Valid_Node_Index) return Boolean;
+ function Has_Parent (Tree : in Syntax_Trees.Tree; Children : in
Valid_Node_Index_Array) return Boolean;
+ function Is_Empty (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Boolean;
+ function Is_Nonterm (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Is_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Is_Virtual (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Is_Virtual_Identifier (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Traversing (Tree : in Syntax_Trees.Tree) return Boolean;
+
+ function Parent
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Count : in Positive := 1)
+ return Node_Index;
+ -- Return Count parent of Node.
+
+ procedure Set_Name_Region
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Region : in Buffer_Region)
+ with Pre => Tree.Is_Nonterm (Node);
+
+ function ID
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Token_ID;
+
+ function Production_ID
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Production_ID
+ with Pre => Tree.Is_Nonterm (Node);
+
+ function Byte_Region
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Buffer_Region;
+
+ function RHS_Index
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Natural
+ with Pre => Tree.Is_Nonterm (Node);
+
+ function Same_Token
+ (Tree_1 : in Syntax_Trees.Tree'Class;
+ Index_1 : in Valid_Node_Index;
+ Tree_2 : in Syntax_Trees.Tree'Class;
+ Index_2 : in Valid_Node_Index)
+ return Boolean;
+ -- True if the two tokens have the same ID and Byte_Region.
+
+ function Recover_Token
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Recover_Token;
+
+ function Recover_Token_Array
+ (Tree : in Syntax_Trees.Tree;
+ Nodes : in Valid_Node_Index_Array)
+ return WisiToken.Recover_Token_Array;
+ -- For non-virtual terminals, copied from Tree.Terminals. For others,
+ -- constructed from Tree data.
+
+ procedure Set_Augmented
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Value : in Base_Token_Class_Access)
+ with Pre => Tree.Is_Nonterm (Node);
+ -- Value will be deallocated when Tree is finalized.
+
+ function Augmented
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Base_Token_Class_Access
+ with Pre => Tree.Is_Nonterm (Node);
+ -- Returns result of Set_Augmented.
+
+ function Action
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Semantic_Action
+ with Pre => Tree.Is_Nonterm (Node);
+
+ function Find_Ancestor
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index;
+ function Find_Ancestor
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ IDs : in Token_ID_Array)
+ return Node_Index;
+ -- Return the ancestor of Node that contains ID, or Invalid_Node_Index if
+ -- none match.
+
+ function Find_Sibling
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ with Pre => Tree.Has_Parent (Node);
+ -- Return the sibling of Node that contains ID, or Invalid_Node_Index if
+ -- none match.
+
+ function Find_Child
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ with Pre => Tree.Is_Nonterm (Node);
+ -- Return the child of Node whose ID is ID, or Invalid_Node_Index if
+ -- none match.
+
+ function Find_Descendant
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index;
+ -- Return the descendant of Node (may be Node) whose ID is ID, or
+ -- Invalid_Node_Index if none match.
+
+ function Find_Min_Terminal_Index
+ (Tree : in Syntax_Trees.Tree;
+ Index : in Token_Index)
+ return Node_Index
+ with Post => Find_Min_Terminal_Index'Result = Invalid_Node_Index or else
+ Tree.Is_Nonterm (Find_Min_Terminal_Index'Result);
+ -- Return the first node whose Min_Terminal_Index is Index, or
+ -- Invalid_Node_Index if none match.
+
+ function Find_Max_Terminal_Index
+ (Tree : in Syntax_Trees.Tree;
+ Index : in Token_Index)
+ return Node_Index
+ with Post => Find_Max_Terminal_Index'Result = Invalid_Node_Index or else
+ Tree.Is_Nonterm (Find_Max_Terminal_Index'Result);
+ -- Return the first node whose Max_Terminal_Index is Index, or
+ -- Invalid_Node_Index if none match.
+
+ procedure Set_Root (Tree : in out Syntax_Trees.Tree; Root : in
Valid_Node_Index);
+
+ function Root (Tree : in Syntax_Trees.Tree) return Node_Index;
+ -- Return value set by Set_Root; defaults to the last node added.
+ -- returns Invalid_Node_Index if Tree is empty.
+
+ procedure Process_Tree
+ (Tree : in out Syntax_Trees.Tree;
+ Process_Node : access procedure
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index);
+ Root : in Node_Index := Invalid_Node_Index);
+ -- Traverse subtree of Tree rooted at Root (default Tree.Root) in
+ -- depth-first order, calling Process_Node on each node.
+
+ function Identifier (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Identifier_Index
+ with Pre => Tree.Is_Virtual_Identifier (Node);
+
+ function Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Base_Token_Index
+ with Pre => Tree.Is_Terminal (Node);
+
+ function Min_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index;
+ function Max_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index;
+ -- Returns lowest/highest index of shared terminal in subtree under
+ -- Node. If result is Invalid_Token_Index, all terminals are virtual,
+ -- or a nonterm is empty.
+
+ function Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index_Array;
+ -- Return sequence of terminals in Node.
+ --
+ -- "Terminals" can be Shared_Terminal, Virtual_Terminal,
+ -- Virtual_Identifier.
+
+ function Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID_Array;
+ -- Same as Get_Terminals, but return the IDs.
+
+ function First_Terminal_ID (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID;
+ -- First of Get_Terminal_IDs
+
+ function Get_IDs
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Valid_Node_Index_Array;
+ -- Return all descendants of Node matching ID.
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean := False)
+ return String;
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Nodes : in Valid_Node_Index_Array;
+ Descriptor : in WisiToken.Descriptor)
+ return String;
+ -- For debug and error messages.
+
+ function First_Index (Tree : in Syntax_Trees.Tree) return Node_Index;
+ function Last_Index (Tree : in Syntax_Trees.Tree) return Node_Index;
+
+ package Node_Sets is new SAL.Gen_Unbounded_Definite_Vectors
(Valid_Node_Index, Boolean, Default_Element => False);
+
+ function Image
+ (Item : in Node_Sets.Vector;
+ Inverted : in Boolean := False)
+ return String;
+ -- Simple list of numbers, for debugging
+
+ procedure Print_Tree
+ (Tree : in Syntax_Trees.Tree;
+ Descriptor : in WisiToken.Descriptor;
+ Root : in Node_Index := Invalid_Node_Index)
+ with Pre => Tree.Flushed;
+ -- Print tree rooted at Root (default Tree.Root) to
+ -- Text_IO.Current_Output, for debugging.
+
+private
+
+ type Node (Label : Node_Label := Virtual_Terminal) is
+ -- Label has a default to allow changing the label during tree editing.
+ record
+ ID : WisiToken.Token_ID := Invalid_Token_ID;
+
+ Byte_Region : Buffer_Region := Null_Buffer_Region;
+ -- Computed by Set_Children, used in Semantic_Check actions and debug
+ -- messages.
+
+ Parent : Node_Index := Invalid_Node_Index;
+
+ State : Unknown_State_Index := Unknown_State;
+ -- Parse state that was on stack with this token, to allow undoing a
+ -- reduce.
+
+ case Label is
+ when Shared_Terminal =>
+ Terminal : Token_Index; -- into Parser.Terminals
+
+ when Virtual_Terminal =>
+ null;
+
+ when Virtual_Identifier =>
+ Identifier : Identifier_Index; -- into user data
+
+ when Nonterm =>
+ Virtual : Boolean := False;
+ -- True if any child node is Virtual_Terminal or Nonterm with Virtual
+ -- set. Used by Semantic_Check actions.
+
+ RHS_Index : Natural;
+ -- With ID, index into Productions.
+ -- Used for debug output, keep for future use.
+
+ Action : Semantic_Action := null;
+
+ Name : Buffer_Region := Null_Buffer_Region;
+ -- Name is set and checked by Semantic_Check actions.
+
+ Children : Valid_Node_Index_Arrays.Vector;
+
+ Min_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
+ -- Cached for push_back of nonterminals during recovery
+
+ Max_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
+ -- Cached for building a WisiToken tree from a libadalang tree.
+
+ Augmented : Base_Token_Class_Access := null;
+ end case;
+ end record;
+
+ subtype Nonterm_Node is Node (Nonterm);
+
+ package Node_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Valid_Node_Index, Node, Default_Element => (others => <>));
+
+ type Base_Tree is new Ada.Finalization.Controlled with record
+ Nodes : Node_Arrays.Vector;
+ -- During normal parsing, tokens are added to Nodes by "parallel"
+ -- LALR parsers, but they are all run from one Ada task, so there's
+ -- no need for Nodes to be Protected. Packrat parsing also has a
+ -- single Ada task.
+ --
+ -- During McKenzie_Recover, which has multiple Ada tasks, the syntax
+ -- tree is read but not modified.
+
+ Augmented_Present : Boolean := False;
+ -- True if Set_Augmented has been called on any node. Declared in
+ -- Base_Tree so it can be checked by Finalize (Base_Tree) and
+ -- Finalize (Tree).
+
+ Traversing : Boolean := False;
+ -- True while traversing tree in Process_Tree.
+ -- Declared in Base_Tree so it is cleared by Finalize.
+
+ end record;
+
+ type Tree is new Ada.Finalization.Controlled with record
+ Shared_Tree : Base_Tree_Access;
+ -- If we need to set anything (ie parent) in Shared_Tree, we move the
+ -- branch point instead, unless Flush = True.
+
+ Last_Shared_Node : Node_Index := Invalid_Node_Index;
+ Branched_Nodes : Node_Arrays.Vector;
+ Flush : Boolean := False;
+ -- If Flush is True, all nodes are in Shared_Tree. Otherwise, all
+ -- greater than Last_Shared_Node are in Branched_Nodes.
+ --
+ -- We maintain Last_Shared_Node when Flush is True or False, so
+ -- subprograms that have no reason to check Flush can rely on
+ -- Last_Shared_Node.
+
+ Root : Node_Index := Invalid_Node_Index;
+ end record with
+ Type_Invariant => (if Tree.Flush then not Tree.Has_Branched_Nodes);
+
+end WisiToken.Syntax_Trees;
diff --git a/wisitoken.adb b/wisitoken.adb
index 698c18e..16d9249 100644
--- a/wisitoken.adb
+++ b/wisitoken.adb
@@ -72,6 +72,16 @@ package body WisiToken is
end loop;
end To_Vector;
+ function To_Vector (Item : in Token_ID_Array) return Token_ID_Arrays.Vector
+ is begin
+ return Result : Token_ID_Arrays.Vector do
+ Result.Set_First_Last (Item'First, Item'Last);
+ for I in Item'Range loop
+ Result (I) := Item (I);
+ end loop;
+ end return;
+ end To_Vector;
+
function Shared_Prefix (A, B : in Token_ID_Arrays.Vector) return Natural
is
use all type Ada.Containers.Count_Type;
@@ -214,6 +224,26 @@ package body WisiToken is
end return;
end To_Vector;
+ function Net_Recursion (A, B : in Recursion) return Recursion
+ is begin
+ return
+ (case A is
+ when None => B,
+ when Single =>
+ (case B is
+ when None => Single,
+ when others => B),
+ when Right =>
+ (case B is
+ when None | Single => Right,
+ when others => B),
+ when Left =>
+ (case B is
+ when None | Single | Left => Left,
+ when others => B),
+ when Middle => Middle);
+ end Net_Recursion;
+
function Slice (Item : in Token_Array_Token_Set; I : in Token_ID) return
Token_ID_Set
is
Result : Token_ID_Set := (Item'First (2) .. Item'Last (2) => False);
diff --git a/wisitoken.ads b/wisitoken.ads
index 4e9d88b..d4652b8 100644
--- a/wisitoken.ads
+++ b/wisitoken.ads
@@ -1,450 +1,472 @@
--- Abstract:
---
--- Root of WisiToken lexer/parser generator and exector.
---
--- The token type is an integer subtype, not an enumeration type, to
--- avoid making this package generic, which would make all other
--- packages generic.
---
--- Additional information about a token can be stored in the
--- 'augmented' field of the syntax tree; see
--- wisitoken-syntax_trees.ads.
---
--- References:
---
--- [dragon] "Compilers Principles, Techniques, and Tools" by Aho,
--- Sethi, and Ullman (aka: "The [Red] Dragon Book" due to the dragon
--- on the cover).
---
--- Copyright (C) 2009, 2010, 2013 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
---
--- This software was originally developed with the name OpenToken by
--- the following company, and was released as open-source software as
--- a service to the community:
---
--- FlightSafety International Simulation Systems Division
--- Broken Arrow, OK USA 918-259-4000
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-with Ada.Strings.Unbounded;
-with Ada.Text_IO;
-with Ada.Unchecked_Deallocation;
-with SAL.Gen_Trimmed_Image;
-with SAL.Gen_Unbounded_Definite_Queues;
-with SAL.Gen_Unbounded_Definite_Vectors.Gen_Image;
-with SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux;
-package WisiToken is
-
- Partial_Parse : exception; -- a partial parse terminated.
-
- Syntax_Error : exception; -- no recovery for a syntax error was found
-
- Parse_Error : exception; -- a non-recoverable non-fatal error was
encountered; editing the input can fix the error.
-
- Fatal_Error : exception; -- Error in code or grammar; editing input cannot
fix error.
-
- Grammar_Error : exception;
- -- Grammar file has bad syntax, or grammar is not consistent (ie
- -- unused tokens, missing productions, invalid actions)
-
- User_Error : exception; -- other user error (ie command line parameter)
-
- -- SAL.Programmer_Error : exception; -- a programming convention has been
violated
-
- subtype Positive_Index_Type is SAL.Peek_Type;
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (SAL.Base_Peek_Type);
-
- type Unknown_State_Index is new Integer range -1 .. Integer'Last;
- subtype State_Index is Unknown_State_Index range 0 ..
Unknown_State_Index'Last;
- Unknown_State : constant Unknown_State_Index := -1;
-
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Unknown_State_Index);
-
- package State_Index_Queues is new SAL.Gen_Unbounded_Definite_Queues
(State_Index);
- package State_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive, State_Index, Default_Element => State_Index'Last);
- function Image is new State_Index_Arrays.Gen_Image (Trimmed_Image);
-
- ----------
- -- Token IDs
-
- type Token_ID is range 0 .. Integer'Last; -- 0 origin to match elisp array
-
- Invalid_Token_ID : constant Token_ID := Token_ID'Last;
-
- type Token_ID_Array_String is array (Token_ID range <>) of access constant
String;
- type Token_ID_Array_Natural is array (Token_ID range <>) of Natural;
-
- type Descriptor
- (First_Terminal : Token_ID;
- Last_Terminal : Token_ID;
- First_Nonterminal : Token_ID;
- Last_Nonterminal : Token_ID;
- EOI_ID : Token_ID;
- Accept_ID : Token_ID)
- is record
- -- Tokens in the range Token_ID'First .. First_Terminal - 1 are
- -- non-reporting (comments, whitespace), and thus are not used in
- -- generating parse tables.
- --
- -- Tokens in the range Last_Terminal + 1 .. Last_Nonterminal are
- -- the nonterminals of a grammar.
- --
- -- Components are discriminants if they can be specified statically.
-
- Case_Insensitive : Boolean; -- keywords and names
- New_Line_ID : Token_ID;
- Comment_ID : Token_ID;
- Left_Paren_ID : Token_ID;
- Right_Paren_ID : Token_ID;
- -- If the language does not define these tokens, set them to
- -- Invalid_Token_ID.
-
- String_1_ID : Token_ID; -- delimited by ', error if New_Line_ID
- String_2_ID : Token_ID; -- delimited by ", error if New_Line_ID
- --
- -- Support for missing quote error recovery. If the language does not
- -- have two kinds of string literals, set one or both of these to
- -- Invalid_Token_ID.
-
- Embedded_Quote_Escape_Doubled : Boolean;
- -- True if quote characters embedded in strings are escaped by
- -- doubling (as in Ada); false if by preceding with backslash (as in
- -- C).
-
- Image : Token_ID_Array_String (Token_ID'First .. Last_Nonterminal);
- -- User names for tokens.
-
- Terminal_Image_Width : Integer;
- Image_Width : Integer; -- max width of Image
-
- -- LALR generate needs a 'Propagate_ID' lookahead that is distinct
- -- from all terminals. Since lookaheads are Token_ID_Set, we need to
- -- allocate First_Terminal .. Last_Terminal for LR1 generate, and
- -- First_Terminal .. Propagate_ID for LALR generate, so we define
- -- Last_Lookahead. After the LR table is generated, Last_Lookahead is
- -- no longer used.
- Last_Lookahead : Token_ID;
- end record;
-
- function Padded_Image (Item : in Token_ID; Desc : in Descriptor) return
String;
- -- Return Desc.Image (Item), padded to Terminal_Image_Width (if Item
- -- is a terminal) or to Image_Width.
-
- function Image (Item : in Token_ID; Desc : in Descriptor) return String;
- -- Return Desc.Image (Item), or empty string for Invalid_Token_ID.
-
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Token_ID);
-
- procedure Put_Tokens (Descriptor : in WisiToken.Descriptor);
- -- Put user readable token list (token_id'first ..
- -- descriptor.last_nonterminal) to Ada.Text_IO.Current_Output
-
- function Find_ID (Descriptor : in WisiToken.Descriptor; Name : in String)
return Token_ID;
- -- Return index of Name in Descriptor.Image. If not found, raise
Programmer_Error.
-
- type Token_ID_Array is array (Positive range <>) of Token_ID;
-
- package Token_ID_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive, Token_ID, Default_Element => Invalid_Token_ID);
-
- function Image is new Token_ID_Arrays.Gen_Image_Aux (Descriptor, Image);
- function Trimmed_Image is new Token_ID_Arrays.Gen_Image (Trimmed_Image);
-
- procedure To_Vector (Item : in Token_ID_Array; Vector : in out
Token_ID_Arrays.Vector);
-
- function Shared_Prefix (A, B : in Token_ID_Arrays.Vector) return Natural;
- -- Return last index in A of a prefix shared between A, B; 0 if none.
-
- type Token_ID_Set is array (Token_ID range <>) of Boolean;
-
- function "&" (Left : in Token_ID_Set; Right : in Token_ID) return
Token_ID_Set;
- -- Include Left and Right in result.
-
- function To_Token_ID_Set (First, Last : in Token_ID; Item : in
Token_ID_Array) return Token_ID_Set;
- -- First, Last determine size of result.
- -- For each element in Item, set result (element) True.
-
- procedure To_Set (Item : in Token_ID_Arrays.Vector; Set : out Token_ID_Set);
- -- For each element of Item, set Set (element) True.
-
- function To_Array (Item : in Token_ID_Set) return Token_ID_Arrays.Vector;
-
- function Any (Item : in Token_ID_Set) return Boolean;
-
- function Count (Item : in Token_ID_Set) return Integer;
- -- Count of True elements.
-
- function Image
- (Item : in Token_ID_Set;
- Desc : in Descriptor;
- Max_Count : in Integer := Integer'Last;
- Inverted : in Boolean := False)
- return String;
- -- For diagnostics; not Ada syntax.
-
- type Token_Array_Token_Set is array (Token_ID range <>, Token_ID range <>)
of Boolean;
-
- function Slice (Item : in Token_Array_Token_Set; I : in Token_ID) return
Token_ID_Set;
- function Any (Item : in Token_Array_Token_Set; I : in Token_ID) return
Boolean;
- function Any (Item : in Token_Array_Token_Set) return Boolean;
- procedure Or_Slice (Item : in out Token_Array_Token_Set; I : in Token_ID;
Value : in Token_ID_Set);
-
- procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Token_Array_Token_Set);
- -- Put Item to Ada.Text_IO.Current_Output, using valid Ada aggregate
- -- syntax.
-
- type Token_Array_Token_ID is array (Token_ID range <>) of Token_ID;
-
- package Token_Sequence_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_ID, Token_ID_Arrays.Vector, Default_Element =>
Token_ID_Arrays.Empty_Vector);
-
- ----------
- -- Production IDs; see wisitoken-productions.ads for more
-
- type Production_ID is record
- LHS : Token_ID := Invalid_Token_ID;
- RHS : Natural := 0;
- -- Index into the production table.
- end record;
-
- Invalid_Production_ID : constant Production_ID := (others => <>);
-
- function Image (Item : in Production_ID) return String;
- -- Ada positional aggregate syntax, for code generation.
-
- function Trimmed_Image (Item : in Production_ID) return String;
- -- Nonterm.rhs_index, both integers, no leading or trailing space;
- -- for parse table output and diagnostics.
-
- Prod_ID_Image_Width : constant Integer := 7;
- -- Max width of Trimmed_Image
-
- function Padded_Image (Item : in Production_ID; Width : in Integer) return
String;
- -- Trimmed_Image padded with leading spaces to Width
-
- package Production_ID_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive, Production_ID, Default_Element => Invalid_Production_ID);
- function Image is new Production_ID_Arrays.Gen_Image (Image);
- function Trimmed_Image is new Production_ID_Arrays.Gen_Image
(Trimmed_Image);
-
- type Production_ID_Array is array (Natural range <>) of Production_ID;
-
- function To_Vector (Item : in Production_ID_Array) return
Production_ID_Arrays.Vector;
- function "+" (Item : in Production_ID_Array) return
Production_ID_Arrays.Vector renames To_Vector;
- function "+" (Item : in Production_ID) return Production_ID_Arrays.Vector
is (To_Vector ((1 => Item)));
-
- ----------
- -- Tokens
-
- type Base_Buffer_Pos is range 0 .. Integer'Last;
- subtype Buffer_Pos is Base_Buffer_Pos range 1 .. Base_Buffer_Pos'Last; --
match Emacs buffer origin.
- type Buffer_Region is record
- First : Buffer_Pos;
- Last : Base_Buffer_Pos; -- allow representing null range.
- end record;
-
- Invalid_Buffer_Pos : constant Buffer_Pos := Buffer_Pos'Last;
- Null_Buffer_Region : constant Buffer_Region := (Buffer_Pos'Last,
Buffer_Pos'First);
-
- function Length (Region : in Buffer_Region) return Natural is (Natural
(Region.Last - Region.First + 1));
-
- function Inside (Pos : in Buffer_Pos; Region : in Buffer_Region) return
Boolean
- is (Region.First <= Pos and Pos <= Region.Last);
-
- function Image (Item : in Buffer_Region) return String;
-
- function "and" (Left, Right : in Buffer_Region) return Buffer_Region;
- -- Return region enclosing both Left and Right.
-
- type Line_Number_Type is range 1 .. Natural'Last; -- Match Emacs buffer
line numbers.
-
- Invalid_Line_Number : constant Line_Number_Type := Line_Number_Type'Last;
-
- type Base_Token is tagged record
- -- Base_Token is used in the core parser. The parser only needs ID;
- -- semantic checks need Byte_Region to compare names. Line, Col, and
- -- Char_Region are included for error messages.
- ID : Token_ID := Invalid_Token_ID;
-
- Byte_Region : Buffer_Region := Null_Buffer_Region;
- -- Index into the Lexer buffer for the token text.
-
- Line : Line_Number_Type := Invalid_Line_Number;
- Column : Ada.Text_IO.Count := 0;
- -- At start of token.
-
- Char_Region : Buffer_Region := Null_Buffer_Region;
- -- Character position, useful for finding the token location in Emacs
- -- buffers.
- end record;
-
- type Base_Token_Class_Access is access all Base_Token'Class;
- type Base_Token_Class_Access_Array is array (Positive_Index_Type range <>)
of Base_Token_Class_Access;
-
- function Image
- (Item : in Base_Token;
- Descriptor : in WisiToken.Descriptor)
- return String;
- -- For debug/test messages.
-
- procedure Free is new Ada.Unchecked_Deallocation (Base_Token'Class,
Base_Token_Class_Access);
-
- Invalid_Token : constant Base_Token := (others => <>);
-
- type Base_Token_Index is range 0 .. Integer'Last;
- subtype Token_Index is Base_Token_Index range 1 .. Base_Token_Index'Last;
-
- Invalid_Token_Index : constant Base_Token_Index := Base_Token_Index'First;
-
- type Token_Index_Array is array (Natural range <>) of Token_Index;
-
- package Recover_Token_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Natural, Base_Token_Index, Default_Element => Invalid_Token_Index);
-
- type Base_Token_Array is array (Positive_Index_Type range <>) of Base_Token;
-
- package Base_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_Index, Base_Token, Default_Element => (others => <>));
- type Base_Token_Array_Access is access all Base_Token_Arrays.Vector;
-
- package Line_Begin_Token_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
- (Line_Number_Type, Base_Token_Index, Default_Element =>
Invalid_Token_Index);
-
- function Image is new Base_Token_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
-
- function Image
- (Token : in Base_Token_Index;
- Terminals : in Base_Token_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return String;
-
- type Recover_Token is record
- -- Maintaining a syntax tree during recover is too slow, so we store
- -- enough information in the recover stack to perform semantic_checks
- -- and to apply the solution to the main parser state. We make
- -- thousands of copies of the parse stack during recover, so
- -- minimizing size is critical.
- ID : Token_ID := Invalid_Token_ID;
-
- Byte_Region : Buffer_Region := Null_Buffer_Region;
- -- Byte_Region is used to detect empty tokens, for cost and other
issues.
-
- Min_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
- -- For terminals, index of this token in Shared_Parser.Terminals. For
- -- nonterminals, minimum of contained tokens. For virtuals,
- -- Invalid_Token_Index. Used for push_back of nonterminals.
-
- Name : Buffer_Region := Null_Buffer_Region;
- -- Set and used by semantic_checks.
-
- Virtual : Boolean := False;
- -- For terminals, True if inserted by recover. For nonterminals, True
- -- if any contained token has Virtual = True. Used by Semantic_Checks
- -- and push_back.
- end record;
-
- function Image
- (Item : in Recover_Token;
- Descriptor : in WisiToken.Descriptor)
- return String;
-
- type Recover_Token_Array is array (Positive_Index_Type range <>) of
Recover_Token;
-
- package Recover_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_Index, Recover_Token, Default_Element => (others => <>));
-
- function Image is new Recover_Token_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
-
- ----------
- -- Trace, debug
-
- Trace_Parse : Integer := 0;
- -- If Trace_Parse > 0, Parse prints messages helpful for debugging
- -- the grammar and/or the parser; higher value prints more.
- --
- -- Trace_Parse levels; output info if Trace_Parse > than:
- --
- Outline : constant := 0; -- spawn/terminate parallel parsers, error
recovery enter/exit
- Detail : constant := 1; -- add each parser cycle
- Extra : constant := 2; -- add pending semantic state operations
- Lexer_Debug : constant := 3; -- add lexer debug
-
- Trace_McKenzie : Integer := 0;
- -- If Trace_McKenzie > 0, Parse prints messages helpful for debugging
error recovery.
- --
- -- Outline - error recovery enter/exit
- -- Detail - add each error recovery configuration
- -- Extra - add error recovery parse actions
-
- Trace_Action : Integer := 0;
- -- Output during Execute_Action, and unit tests.
-
- Trace_Generate : Integer := 0;
- -- Output during grammar generation.
-
- Debug_Mode : Boolean := False;
- -- If True, Output stack traces, propagate exceptions to top level.
- -- Otherwise, be robust to errors, so user does not notice them.
-
- type Trace (Descriptor : not null access constant WisiToken.Descriptor) is
abstract tagged limited null record;
- -- Output for tests/debugging. Descriptor included here because many
- -- uses of Trace will use Image (Item, Descriptor);
-
- procedure Set_Prefix (Trace : in out WisiToken.Trace; Prefix : in String)
is abstract;
- -- Prepend Prefix to all subsequent messages. Usefull for adding
- -- comment syntax.
-
- procedure Put (Trace : in out WisiToken.Trace; Item : in String; Prefix :
in Boolean := True) is abstract;
- -- Put Item to the Trace display. If Prefix is True, prepend the stored
prefix.
-
- procedure Put_Line (Trace : in out WisiToken.Trace; Item : in String) is
abstract;
- -- Put Item to the Trace display, followed by a newline.
-
- procedure New_Line (Trace : in out WisiToken.Trace) is abstract;
- -- Put a newline to the Trace display.
-
- procedure Put_Clock (Trace : in out WisiToken.Trace; Label : in String) is
abstract;
- -- Put Ada.Calendar.Clock to Trace.
-
- ----------
- -- Misc
-
- function "+" (Item : in String) return
Ada.Strings.Unbounded.Unbounded_String
- renames Ada.Strings.Unbounded.To_Unbounded_String;
-
- function "-" (Item : in Ada.Strings.Unbounded.Unbounded_String) return
String
- renames Ada.Strings.Unbounded.To_String;
-
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Integer);
- function Trimmed_Image is new SAL.Gen_Trimmed_Image
(Ada.Containers.Count_Type);
-
- function Error_Message
- (File_Name : in String;
- Line : in Line_Number_Type;
- Column : in Ada.Text_IO.Count;
- Message : in String)
- return String;
- -- Return Gnu-formatted error message.
-
- type Names_Array is array (Integer range <>) of access constant String;
- type Names_Array_Access is access Names_Array;
- type Names_Array_Array is array (WisiToken.Token_ID range <>) of
Names_Array_Access;
-
-end WisiToken;
+-- Abstract:
+--
+-- Root of WisiToken lexer/parser generator and exector.
+--
+-- The token type is an integer subtype, not an enumeration type, to
+-- avoid making this package generic, which would make all other
+-- packages generic.
+--
+-- Additional information about a token can be stored in the
+-- 'augmented' field of the syntax tree; see
+-- wisitoken-syntax_trees.ads.
+--
+-- References:
+--
+-- [dragon] "Compilers Principles, Techniques, and Tools" by Aho,
+-- Sethi, and Ullman (aka: "The [Red] Dragon Book" due to the dragon
+-- on the cover).
+--
+-- Copyright (C) 2009, 2010, 2013 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
+--
+-- This file is part of the WisiToken package.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+--
+-- This software was originally developed with the name OpenToken by
+-- the following company, and was released as open-source software as
+-- a service to the community:
+--
+-- FlightSafety International Simulation Systems Division
+-- Broken Arrow, OK USA 918-259-4000
+
+pragma License (Modified_GPL);
+
+with Ada.Containers;
+with Ada.Strings.Unbounded;
+with Ada.Text_IO;
+with Ada.Unchecked_Deallocation;
+with SAL.Gen_Trimmed_Image;
+with SAL.Gen_Unbounded_Definite_Queues;
+with SAL.Gen_Unbounded_Definite_Vectors.Gen_Image;
+with SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux;
+package WisiToken is
+
+ Partial_Parse : exception; -- a partial parse terminated.
+
+ Syntax_Error : exception; -- no recovery for a syntax error was found
+
+ Parse_Error : exception; -- a non-recoverable non-fatal error was
encountered; editing the input can fix the error.
+
+ Fatal_Error : exception; -- Error in code or grammar; editing input cannot
fix error.
+
+ Grammar_Error : exception;
+ -- Grammar file has bad syntax, or grammar is not consistent (ie
+ -- unused tokens, missing productions, invalid actions)
+
+ User_Error : exception; -- other user error (ie command line parameter)
+
+ -- SAL.Programmer_Error : exception; -- a programming convention has been
violated
+
+ subtype Positive_Index_Type is SAL.Peek_Type;
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image (SAL.Base_Peek_Type);
+
+ type Unknown_State_Index is new Integer range -1 .. Integer'Last;
+ subtype State_Index is Unknown_State_Index range 0 ..
Unknown_State_Index'Last;
+ Unknown_State : constant Unknown_State_Index := -1;
+
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image (Unknown_State_Index);
+
+ package State_Index_Queues is new SAL.Gen_Unbounded_Definite_Queues
(State_Index);
+ package State_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Positive, State_Index, Default_Element => State_Index'Last);
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image (Integer);
+ function Image is new State_Index_Arrays.Gen_Image (Trimmed_Image);
+
+ ----------
+ -- Token IDs
+
+ type Token_ID is range 0 .. Integer'Last; -- 0 origin to match elisp array
+
+ Invalid_Token_ID : constant Token_ID := Token_ID'Last;
+
+ type String_Access_Constant is access constant String;
+ type Token_ID_Array_String is array (Token_ID range <>) of
String_Access_Constant;
+ type Token_ID_Array_Natural is array (Token_ID range <>) of Natural;
+
+ type Descriptor
+ (First_Terminal : Token_ID;
+ Last_Terminal : Token_ID;
+ First_Nonterminal : Token_ID;
+ Last_Nonterminal : Token_ID;
+ EOI_ID : Token_ID;
+ Accept_ID : Token_ID)
+ is record
+ -- Tokens in the range Token_ID'First .. First_Terminal - 1 are
+ -- non-reporting (comments, whitespace), and thus are not used in
+ -- generating parse tables.
+ --
+ -- Tokens in the range Last_Terminal + 1 .. Last_Nonterminal are
+ -- the nonterminals of a grammar.
+ --
+ -- Components are discriminants if they can be specified statically.
+
+ Case_Insensitive : Boolean; -- keywords and names
+ New_Line_ID : Token_ID;
+
+ String_1_ID : Token_ID;
+ String_2_ID : Token_ID;
+ -- String_1 delimited by '; String_2 by ".
+ --
+ -- Used by missing quote error recovery. If the language does not
+ -- have two kinds of string literals, set one or both of these to
+ -- Invalid_Token_ID.
+
+ Image : Token_ID_Array_String (Token_ID'First .. Last_Nonterminal);
+ -- User names for tokens.
+
+ Terminal_Image_Width : Integer;
+ Image_Width : Integer; -- max width of Image
+
+ Last_Lookahead : Token_ID;
+ -- LALR generate needs a 'Propagate_ID' lookahead that is distinct
+ -- from all terminals. Since lookaheads are Token_ID_Set, we need to
+ -- allocate First_Terminal .. Last_Terminal for LR1 generate, and
+ -- First_Terminal .. Propagate_ID for LALR generate, so we define
+ -- Last_Lookahead. After the LR table is generated, Last_Lookahead is
+ -- no longer used.
+ end record;
+ type Descriptor_Access is access Descriptor;
+ type Descriptor_Access_Constant is access constant Descriptor;
+
+ function Padded_Image (Item : in Token_ID; Desc : in Descriptor) return
String;
+ -- Return Desc.Image (Item), padded to Terminal_Image_Width (if Item
+ -- is a terminal) or to Image_Width.
+
+ function Image (Item : in Token_ID; Desc : in Descriptor) return String;
+ -- Return Desc.Image (Item), or empty string for Invalid_Token_ID.
+
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image (Token_ID);
+
+ procedure Put_Tokens (Descriptor : in WisiToken.Descriptor);
+ -- Put user readable token list (token_id'first ..
+ -- descriptor.last_nonterminal) to Ada.Text_IO.Current_Output
+
+ function Find_ID (Descriptor : in WisiToken.Descriptor; Name : in String)
return Token_ID;
+ -- Return index of Name in Descriptor.Image. If not found, raise
Programmer_Error.
+
+ type Token_ID_Array is array (Positive range <>) of Token_ID;
+ -- Index is not Positive_Index_Type, mostly for historical reasons.
+
+ package Token_ID_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Positive, Token_ID, Default_Element => Invalid_Token_ID);
+
+ function Image is new Token_ID_Arrays.Gen_Image_Aux (Descriptor,
Trimmed_Image, Image);
+ function Trimmed_Image is new Token_ID_Arrays.Gen_Image (Trimmed_Image);
+
+ procedure To_Vector (Item : in Token_ID_Array; Vector : in out
Token_ID_Arrays.Vector);
+ function To_Vector (Item : in Token_ID_Array) return Token_ID_Arrays.Vector;
+
+ function Shared_Prefix (A, B : in Token_ID_Arrays.Vector) return Natural;
+ -- Return last index in A of a prefix shared between A, B; 0 if none.
+
+ type Token_ID_Set is array (Token_ID range <>) of Boolean;
+ type Token_ID_Set_Access is access Token_ID_Set;
+
+ function "&" (Left : in Token_ID_Set; Right : in Token_ID) return
Token_ID_Set;
+ -- Include Left and Right in result.
+
+ function To_Token_ID_Set (First, Last : in Token_ID; Item : in
Token_ID_Array) return Token_ID_Set;
+ -- First, Last determine size of result.
+ -- For each element in Item, set result (element) True.
+
+ procedure To_Set (Item : in Token_ID_Arrays.Vector; Set : out Token_ID_Set);
+ -- For each element of Item, set Set (element) True.
+
+ function To_Array (Item : in Token_ID_Set) return Token_ID_Arrays.Vector;
+
+ function Any (Item : in Token_ID_Set) return Boolean;
+
+ function Count (Item : in Token_ID_Set) return Integer;
+ -- Count of True elements.
+
+ function Image
+ (Item : in Token_ID_Set;
+ Desc : in Descriptor;
+ Max_Count : in Integer := Integer'Last;
+ Inverted : in Boolean := False)
+ return String;
+ -- For diagnostics; not Ada syntax.
+
+ type Token_Array_Token_Set is array (Token_ID range <>, Token_ID range <>)
of Boolean;
+
+ function Slice (Item : in Token_Array_Token_Set; I : in Token_ID) return
Token_ID_Set;
+ function Any (Item : in Token_Array_Token_Set; I : in Token_ID) return
Boolean;
+ function Any (Item : in Token_Array_Token_Set) return Boolean;
+ procedure Or_Slice (Item : in out Token_Array_Token_Set; I : in Token_ID;
Value : in Token_ID_Set);
+
+ procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Token_Array_Token_Set);
+ -- Put Item to Ada.Text_IO.Current_Output, using valid Ada aggregate
+ -- syntax.
+
+ type Token_Array_Token_ID is array (Token_ID range <>) of Token_ID;
+
+ package Token_Sequence_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Token_ID, Token_ID_Arrays.Vector, Default_Element =>
Token_ID_Arrays.Empty_Vector);
+
+ ----------
+ -- Production IDs; see wisitoken-productions.ads for more
+
+ type Production_ID is record
+ LHS : Token_ID := Invalid_Token_ID;
+ RHS : Natural := 0;
+ -- Index into the production table.
+ end record;
+
+ Invalid_Production_ID : constant Production_ID := (others => <>);
+
+ function Image (Item : in Production_ID) return String;
+ -- Ada positional aggregate syntax, for code generation.
+
+ function Trimmed_Image (Item : in Production_ID) return String;
+ -- Nonterm.rhs_index, both integers, no leading or trailing space;
+ -- for parse table output and diagnostics.
+
+ Prod_ID_Image_Width : constant Integer := 7;
+ -- Max width of Trimmed_Image
+
+ function Padded_Image (Item : in Production_ID; Width : in Integer) return
String;
+ -- Trimmed_Image padded with leading spaces to Width
+
+ package Production_ID_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Positive, Production_ID, Default_Element => Invalid_Production_ID);
+ function Image is new Production_ID_Arrays.Gen_Image (Image);
+ function Trimmed_Image is new Production_ID_Arrays.Gen_Image
(Trimmed_Image);
+
+ type Production_ID_Array is array (Natural range <>) of Production_ID;
+
+ function To_Vector (Item : in Production_ID_Array) return
Production_ID_Arrays.Vector;
+ function "+" (Item : in Production_ID_Array) return
Production_ID_Arrays.Vector renames To_Vector;
+ function "+" (Item : in Production_ID) return Production_ID_Arrays.Vector
is (To_Vector ((1 => Item)));
+
+ type Recursion is
+ (None,
+ Single, -- Single token in right hand side is recursive.
+ Middle, -- Multiple tokens in right hand side, recursive token not at
either end.
+ Right, -- Multiple tokens in right hand side, recursive token not at
right end.
+ Left -- Multiple tokens in right hand side, recursive token not at
left end.
+ );
+ -- In worst-case order; Left recursion causes the most
+ -- problems in LR error recovery, and in Packrat.
+
+ function Worst_Recursion (A, B : in Recursion) return Recursion
+ is (Recursion'Max (A, B));
+
+ function Net_Recursion (A, B : in Recursion) return Recursion;
+ -- For finding the net recursion of a chain; Middle dominates.
+
+ ----------
+ -- Tokens
+
+ type Base_Buffer_Pos is range 0 .. Integer'Last;
+ subtype Buffer_Pos is Base_Buffer_Pos range 1 .. Base_Buffer_Pos'Last; --
match Emacs buffer origin.
+ type Buffer_Region is record
+ First : Buffer_Pos;
+ Last : Base_Buffer_Pos; -- allow representing null range.
+ end record;
+
+ Invalid_Buffer_Pos : constant Buffer_Pos := Buffer_Pos'Last;
+ Null_Buffer_Region : constant Buffer_Region := (Buffer_Pos'Last,
Buffer_Pos'First);
+
+ function Length (Region : in Buffer_Region) return Natural is (Natural
(Region.Last - Region.First + 1));
+
+ function Inside (Pos : in Buffer_Pos; Region : in Buffer_Region) return
Boolean
+ is (Region.First <= Pos and Pos <= Region.Last);
+
+ function Image (Item : in Buffer_Region) return String;
+
+ function "and" (Left, Right : in Buffer_Region) return Buffer_Region;
+ -- Return region enclosing both Left and Right.
+
+ type Line_Number_Type is range 1 .. Natural'Last; -- Match Emacs buffer
line numbers.
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image (Line_Number_Type);
+
+ Invalid_Line_Number : constant Line_Number_Type := Line_Number_Type'Last;
+
+ type Base_Token is tagged record
+ -- Base_Token is used in the core parser. The parser only needs ID;
+ -- semantic checks need Byte_Region to compare names. Line, Col, and
+ -- Char_Region are included for error messages.
+ ID : Token_ID := Invalid_Token_ID;
+
+ Byte_Region : Buffer_Region := Null_Buffer_Region;
+ -- Index into the Lexer buffer for the token text.
+
+ Line : Line_Number_Type := Invalid_Line_Number;
+ Column : Ada.Text_IO.Count := 0;
+ -- At start of token.
+
+ Char_Region : Buffer_Region := Null_Buffer_Region;
+ -- Character position, useful for finding the token location in Emacs
+ -- buffers.
+ end record;
+
+ type Base_Token_Class_Access is access all Base_Token'Class;
+
+ function Image
+ (Item : in Base_Token;
+ Descriptor : in WisiToken.Descriptor)
+ return String;
+ -- For debug/test messages.
+
+ procedure Free is new Ada.Unchecked_Deallocation (Base_Token'Class,
Base_Token_Class_Access);
+
+ Invalid_Token : constant Base_Token := (others => <>);
+
+ type Base_Token_Index is range 0 .. Integer'Last;
+ subtype Token_Index is Base_Token_Index range 1 .. Base_Token_Index'Last;
+
+ Invalid_Token_Index : constant Base_Token_Index := Base_Token_Index'First;
+
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image (Base_Token_Index);
+
+ type Token_Index_Array is array (Natural range <>) of Token_Index;
+
+ package Recover_Token_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Natural, Base_Token_Index, Default_Element => Invalid_Token_Index);
+
+ type Base_Token_Array is array (Positive_Index_Type range <>) of Base_Token;
+
+ package Base_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Token_Index, Base_Token, Default_Element => (others => <>));
+ type Base_Token_Array_Access is access all Base_Token_Arrays.Vector;
+
+ function Image is new Base_Token_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Trimmed_Image, Image);
+
+ function Image
+ (Token : in Base_Token_Index;
+ Terminals : in Base_Token_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return String;
+
+ package Line_Begin_Token_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
+ (Line_Number_Type, Base_Token_Index, Default_Element =>
Invalid_Token_Index);
+
+ type Recover_Token is record
+ -- Maintaining a syntax tree during recover is too slow, so we store
+ -- enough information in the recover stack to perform semantic_checks
+ -- and to apply the solution to the main parser state. We make
+ -- thousands of copies of the parse stack during recover, so
+ -- minimizing size is critical.
+ ID : Token_ID := Invalid_Token_ID;
+
+ Byte_Region : Buffer_Region := Null_Buffer_Region;
+ -- Byte_Region is used to detect empty tokens, for cost and other
issues.
+
+ Min_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
+ -- For terminals, index of this token in Shared_Parser.Terminals. For
+ -- nonterminals, minimum of contained tokens (Invalid_Token_Index if
+ -- empty). For virtuals, Invalid_Token_Index. Used for push_back of
+ -- nonterminals.
+
+ Name : Buffer_Region := Null_Buffer_Region;
+ -- Set and used by semantic_checks.
+
+ Virtual : Boolean := True;
+ -- For terminals, True if inserted by recover. For nonterminals, True
+ -- if any contained token has Virtual = True. Used by Semantic_Checks
+ -- and push_back.
+ end record;
+
+ function Image
+ (Item : in Recover_Token;
+ Descriptor : in WisiToken.Descriptor)
+ return String;
+
+ type Recover_Token_Array is array (Positive_Index_Type range <>) of
Recover_Token;
+
+ package Recover_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Token_Index, Recover_Token, Default_Element => (others => <>));
+
+ function Image is new Recover_Token_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Trimmed_Image, Image);
+
+ type Base_Identifier_Index is range 0 .. Integer'Last;
+ subtype Identifier_Index is Base_Identifier_Index range 1 ..
Base_Identifier_Index'Last;
+ -- For virtual identifiers created during syntax tree rewrite.
+
+ Invalid_Identifier_Index : constant Base_Identifier_Index :=
Base_Identifier_Index'First;
+
+ ----------
+ -- Trace, debug
+
+ Trace_Parse : Integer := 0;
+ -- If Trace_Parse > 0, Parse prints messages helpful for debugging
+ -- the grammar and/or the parser; higher value prints more.
+ --
+ -- Trace_Parse levels; output info if Trace_Parse > than:
+ --
+ Outline : constant := 0; -- spawn/terminate parallel parsers, error
recovery enter/exit
+ Detail : constant := 1; -- add each parser cycle
+ Extra : constant := 2; -- add pending semantic state operations
+ Lexer_Debug : constant := 3; -- add lexer debug
+
+ Trace_McKenzie : Integer := 0;
+ -- If Trace_McKenzie > 0, Parse prints messages helpful for debugging
error recovery.
+ --
+ -- Outline - error recovery enter/exit
+ -- Detail - add each error recovery configuration
+ -- Extra - add error recovery parse actions
+
+ Trace_Action : Integer := 0;
+ -- Output during Execute_Action, and unit tests.
+
+ Trace_Generate : Integer := 0;
+ -- Output during grammar generation.
+
+ Debug_Mode : Boolean := False;
+ -- If True, Output stack traces, propagate exceptions to top level.
+ -- Otherwise, be robust to errors, so user does not notice them.
+
+ type Trace (Descriptor : not null access constant WisiToken.Descriptor) is
abstract tagged limited null record;
+ -- Output for tests/debugging. Descriptor included here because many
+ -- uses of Trace will use Image (Item, Descriptor);
+
+ procedure Set_Prefix (Trace : in out WisiToken.Trace; Prefix : in String)
is abstract;
+ -- Prepend Prefix to all subsequent messages. Usefull for adding
+ -- comment syntax.
+
+ procedure Put (Trace : in out WisiToken.Trace; Item : in String; Prefix :
in Boolean := True) is abstract;
+ -- Put Item to the Trace display. If Prefix is True, prepend the stored
prefix.
+
+ procedure Put_Line (Trace : in out WisiToken.Trace; Item : in String) is
abstract;
+ -- Put Item to the Trace display, followed by a newline.
+
+ procedure New_Line (Trace : in out WisiToken.Trace) is abstract;
+ -- Put a newline to the Trace display.
+
+ procedure Put_Clock (Trace : in out WisiToken.Trace; Label : in String) is
abstract;
+ -- Put Ada.Calendar.Clock to Trace.
+
+ ----------
+ -- Misc
+
+ function "+" (Item : in String) return
Ada.Strings.Unbounded.Unbounded_String
+ renames Ada.Strings.Unbounded.To_Unbounded_String;
+
+ function "-" (Item : in Ada.Strings.Unbounded.Unbounded_String) return
String
+ renames Ada.Strings.Unbounded.To_String;
+
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image
(Ada.Containers.Count_Type);
+
+ function Error_Message
+ (File_Name : in String;
+ Line : in Line_Number_Type;
+ Column : in Ada.Text_IO.Count;
+ Message : in String)
+ return String;
+ -- Return Gnu-formatted error message.
+
+ type Names_Array is array (Integer range <>) of String_Access_Constant;
+ type Names_Array_Access is access Names_Array;
+ type Names_Array_Array is array (WisiToken.Token_ID range <>) of
Names_Array_Access;
+ type Names_Array_Array_Access is access Names_Array_Array;
+
+end WisiToken;
diff --git a/wisitoken_grammar_actions.adb b/wisitoken_grammar_actions.adb
index c9970d9..8f4faf7 100644
--- a/wisitoken_grammar_actions.adb
+++ b/wisitoken_grammar_actions.adb
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
--
@@ -102,4 +102,81 @@ package body Wisitoken_Grammar_Actions is
Add_Nonterminal (User_Data, Tree, Tokens);
end nonterminal_0;
+ procedure nonterminal_1
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Add_Nonterminal (User_Data, Tree, Tokens);
+ end nonterminal_1;
+
+ procedure rhs_item_1
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Check_EBNF (User_Data, Tree, Tokens, 1);
+ end rhs_item_1;
+
+ procedure rhs_item_2
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Check_EBNF (User_Data, Tree, Tokens, 1);
+ end rhs_item_2;
+
+ procedure rhs_item_3
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Check_EBNF (User_Data, Tree, Tokens, 1);
+ end rhs_item_3;
+
+ procedure rhs_item_4
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Check_EBNF (User_Data, Tree, Tokens, 1);
+ end rhs_item_4;
+
+ procedure rhs_item_5
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Check_EBNF (User_Data, Tree, Tokens, 1);
+ end rhs_item_5;
+
+ procedure rhs_optional_item_3
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Check_EBNF (User_Data, Tree, Tokens, 1);
+ end rhs_optional_item_3;
+
end Wisitoken_Grammar_Actions;
diff --git a/wisitoken_grammar_actions.ads b/wisitoken_grammar_actions.ads
index 359a73d..5e346e8 100644
--- a/wisitoken_grammar_actions.ads
+++ b/wisitoken_grammar_actions.ads
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c PROCESS
wisitoken_grammar.wy
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
--
@@ -25,21 +25,17 @@ with WisiToken.Syntax_Trees;
package Wisitoken_Grammar_Actions is
Descriptor : aliased WisiToken.Descriptor :=
- (First_Terminal => 3,
- Last_Terminal => 25,
- First_Nonterminal => 26,
- Last_Nonterminal => 37,
- EOI_ID => 25,
- Accept_ID => 26,
- Case_Insensitive => False,
- New_Line_ID => 1,
- Comment_ID => 2,
- Left_Paren_ID => 2147483647,
- Right_Paren_ID => 2147483647,
- String_1_ID => 24,
- String_2_ID => 23,
- Embedded_Quote_Escape_Doubled => False,
- Image =>
+ (First_Terminal => 3,
+ Last_Terminal => 36,
+ First_Nonterminal => 37,
+ Last_Nonterminal => 56,
+ EOI_ID => 36,
+ Accept_ID => 37,
+ Case_Insensitive => False,
+ New_Line_ID => 1,
+ String_1_ID => 35,
+ String_2_ID => 34,
+ Image =>
(new String'("WHITESPACE"),
new String'("NEW_LINE"),
new String'("COMMENT"),
@@ -54,17 +50,28 @@ package Wisitoken_Grammar_Actions is
new String'("ACTION"),
new String'("BAR"),
new String'("COLON"),
+ new String'("COLON_COLON_EQUAL"),
new String'("COMMA"),
new String'("EQUAL"),
new String'("GREATER"),
+ new String'("LEFT_BRACE"),
+ new String'("LEFT_BRACKET"),
+ new String'("LEFT_PAREN"),
new String'("LESS"),
+ new String'("MINUS"),
new String'("PERCENT"),
+ new String'("PLUS"),
+ new String'("QUESTION"),
+ new String'("RIGHT_BRACE"),
+ new String'("RIGHT_BRACKET"),
+ new String'("RIGHT_PAREN"),
new String'("SEMICOLON"),
new String'("SLASH"),
+ new String'("STAR"),
new String'("NUMERIC_LITERAL"),
new String'("IDENTIFIER"),
- new String'("STRING_LITERAL"),
- new String'("STRING_LITERAL_CASE_INS"),
+ new String'("STRING_LITERAL_1"),
+ new String'("STRING_LITERAL_2"),
new String'("Wisi_EOI"),
new String'("wisitoken_accept"),
new String'("declaration"),
@@ -73,14 +80,22 @@ package Wisitoken_Grammar_Actions is
new String'("declaration_item_list"),
new String'("declaration_item"),
new String'("nonterminal"),
+ new String'("semicolon_opt"),
new String'("rhs_list"),
new String'("rhs"),
- new String'("token_list"),
+ new String'("rhs_attribute"),
+ new String'("rhs_element"),
+ new String'("rhs_item_list"),
+ new String'("rhs_item"),
+ new String'("rhs_group_item"),
+ new String'("rhs_optional_item"),
+ new String'("rhs_multiple_item"),
+ new String'("rhs_alternative_list"),
new String'("compilation_unit"),
new String'("compilation_unit_list")),
- Terminal_Image_Width => 23,
+ Terminal_Image_Width => 17,
Image_Width => 25,
- Last_Lookahead => 26);
+ Last_Lookahead => 37);
type Token_Enum_ID is
(WHITESPACE_ID,
@@ -97,17 +112,28 @@ package Wisitoken_Grammar_Actions is
ACTION_ID,
BAR_ID,
COLON_ID,
+ COLON_COLON_EQUAL_ID,
COMMA_ID,
EQUAL_ID,
GREATER_ID,
+ LEFT_BRACE_ID,
+ LEFT_BRACKET_ID,
+ LEFT_PAREN_ID,
LESS_ID,
+ MINUS_ID,
PERCENT_ID,
+ PLUS_ID,
+ QUESTION_ID,
+ RIGHT_BRACE_ID,
+ RIGHT_BRACKET_ID,
+ RIGHT_PAREN_ID,
SEMICOLON_ID,
SLASH_ID,
+ STAR_ID,
NUMERIC_LITERAL_ID,
IDENTIFIER_ID,
- STRING_LITERAL_ID,
- STRING_LITERAL_CASE_INS_ID,
+ STRING_LITERAL_1_ID,
+ STRING_LITERAL_2_ID,
Wisi_EOI_ID,
wisitoken_accept_ID,
declaration_ID,
@@ -116,9 +142,17 @@ package Wisitoken_Grammar_Actions is
declaration_item_list_ID,
declaration_item_ID,
nonterminal_ID,
+ semicolon_opt_ID,
rhs_list_ID,
rhs_ID,
- token_list_ID,
+ rhs_attribute_ID,
+ rhs_element_ID,
+ rhs_item_list_ID,
+ rhs_item_ID,
+ rhs_group_item_ID,
+ rhs_optional_item_ID,
+ rhs_multiple_item_ID,
+ rhs_alternative_list_ID,
compilation_unit_ID,
compilation_unit_list_ID);
@@ -165,4 +199,39 @@ package Wisitoken_Grammar_Actions is
Tree : in out WisiToken.Syntax_Trees.Tree;
Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure nonterminal_1
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure rhs_item_1
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure rhs_item_2
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure rhs_item_3
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure rhs_item_4
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure rhs_item_5
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure rhs_optional_item_3
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
end Wisitoken_Grammar_Actions;
diff --git a/wisitoken_grammar_main.adb b/wisitoken_grammar_main.adb
index b8cb1c5..7a2bb22 100644
--- a/wisitoken_grammar_main.adb
+++ b/wisitoken_grammar_main.adb
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
--
@@ -33,199 +33,545 @@ package body Wisitoken_Grammar_Main is
wisitoken_grammar_re2c_c.Next_Token);
procedure Create_Parser
- (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;
+ (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;
Trace : not null access WisiToken.Trace'Class;
User_Data : in
WisiToken.Syntax_Trees.User_Data_Access)
is
use WisiToken.Parse.LR;
Table : constant Parse_Table_Ptr := new Parse_Table
(State_First => 0,
- State_Last => 61,
+ State_Last => 102,
First_Terminal => 3,
- Last_Terminal => 25,
- First_Nonterminal => 26,
- Last_Nonterminal => 37);
+ Last_Terminal => 36,
+ First_Nonterminal => 37,
+ Last_Nonterminal => 56);
begin
declare
procedure Subr_1
is begin
- Add_Action (Table.States (0), 18, 1);
- Add_Action (Table.States (0), 22, 2);
+ Add_Action (Table.States (0), 23, 1);
+ Add_Action (Table.States (0), 33, 2);
Add_Error (Table.States (0));
- Add_Goto (Table.States (0), 27, 3);
- Add_Goto (Table.States (0), 32, 4);
- Add_Goto (Table.States (0), 36, 5);
- Add_Goto (Table.States (0), 37, 6);
+ Add_Goto (Table.States (0), 38, 3);
+ Add_Goto (Table.States (0), 43, 4);
+ Add_Goto (Table.States (0), 55, 5);
+ Add_Goto (Table.States (0), 56, 6);
Add_Action (Table.States (1), 3, 7);
Add_Action (Table.States (1), 4, 8);
Add_Action (Table.States (1), 5, 9);
Add_Action (Table.States (1), 6, 10);
Add_Action (Table.States (1), 7, 11);
Add_Action (Table.States (1), 8, 12);
- Add_Action (Table.States (1), 22, 13);
+ Add_Action (Table.States (1), 33, 13);
Add_Error (Table.States (1));
- Add_Goto (Table.States (1), 28, 14);
+ Add_Goto (Table.States (1), 39, 14);
Add_Action (Table.States (2), 13, 15);
+ Add_Action (Table.States (2), 14, 16);
Add_Error (Table.States (2));
- Add_Action (Table.States (3), (18, 22, 25), (36, 0), 1, null,
null);
- Add_Action (Table.States (4), (18, 22, 25), (36, 1), 1, null,
null);
- Add_Action (Table.States (5), (18, 22, 25), (37, 0), 1, null,
null);
- Add_Action (Table.States (6), 18, 1);
- Add_Action (Table.States (6), 22, 2);
- Add_Action (Table.States (6), 25, Accept_It, (26, 0), 1, null,
null);
+ Add_Action (Table.States (3), (23, 33, 36), (55, 0), 1, null,
null);
+ Add_Action (Table.States (4), (23, 33, 36), (55, 1), 1, null,
null);
+ Add_Action (Table.States (5), (23, 33, 36), (56, 0), 1, null,
null);
+ Add_Action (Table.States (6), 23, 1);
+ Add_Action (Table.States (6), 33, 2);
+ Add_Action (Table.States (6), 36, Accept_It, (37, 0), 1, null,
null);
Add_Error (Table.States (6));
- Add_Goto (Table.States (6), 27, 3);
- Add_Goto (Table.States (6), 32, 4);
- Add_Goto (Table.States (6), 36, 16);
- Add_Action (Table.States (7), 22, 17);
+ Add_Goto (Table.States (6), 38, 3);
+ Add_Goto (Table.States (6), 43, 4);
+ Add_Goto (Table.States (6), 55, 17);
+ Add_Action (Table.States (7), 33, 18);
Add_Error (Table.States (7));
- Add_Goto (Table.States (7), 29, 18);
- Add_Action (Table.States (8), 5, 19);
+ Add_Goto (Table.States (7), 40, 19);
+ Add_Action (Table.States (8), 5, 20);
Add_Error (Table.States (8));
- Add_Action (Table.States (9), 22, 20);
+ Add_Action (Table.States (9), 33, 21);
Add_Error (Table.States (9));
- Add_Action (Table.States (10), (1 => 22), (28, 0), 1, null, null);
- Add_Action (Table.States (11), 17, 21);
+ Add_Action (Table.States (10), (1 => 33), (39, 0), 1, null, null);
+ Add_Action (Table.States (11), 21, 22);
Add_Error (Table.States (11));
- Add_Action (Table.States (12), 17, 22);
+ Add_Action (Table.States (12), 21, 23);
Add_Error (Table.States (12));
- Add_Action (Table.States (13), 8, 23);
- Add_Action (Table.States (13), 10, 24);
- Add_Action (Table.States (13), 14, 25);
+ Add_Action (Table.States (13), 8, 24);
+ Add_Action (Table.States (13), 10, 25);
Add_Action (Table.States (13), 15, 26);
- Add_Action (Table.States (13), 18, Reduce, (27, 3), 2,
declaration_3'Access, null);
- Add_Action (Table.States (13), 20, 27);
- Add_Action (Table.States (13), 21, 28);
- Add_Action (Table.States (13), 22, 29, (27, 3), 2,
declaration_3'Access, null);
- Add_Action (Table.States (13), 23, 30);
- Add_Action (Table.States (13), 24, 31);
- Add_Action (Table.States (13), 25, Reduce, (27, 3), 2,
declaration_3'Access, null);
+ Add_Action (Table.States (13), 16, 27);
+ Add_Action (Table.States (13), 20, 28);
+ Add_Action (Table.States (13), 23, Reduce, (38, 3), 2,
declaration_3'Access, null);
+ Add_Action (Table.States (13), 28, 29);
+ Add_Action (Table.States (13), 30, 30);
+ Add_Action (Table.States (13), 32, 31);
+ Add_Action (Table.States (13), 33, 32);
+ Add_Conflict (Table.States (13), 33, (38, 3), 2,
declaration_3'Access, null);
+ Add_Action (Table.States (13), 34, 33);
+ Add_Action (Table.States (13), 35, 34);
+ Add_Action (Table.States (13), 36, Reduce, (38, 3), 2,
declaration_3'Access, null);
Add_Error (Table.States (13));
- Add_Goto (Table.States (13), 30, 32);
- Add_Goto (Table.States (13), 31, 33);
- Add_Action (Table.States (14), 22, 34);
+ Add_Goto (Table.States (13), 41, 35);
+ Add_Goto (Table.States (13), 42, 36);
+ Add_Action (Table.States (14), 33, 37);
Add_Error (Table.States (14));
- Add_Action (Table.States (15), 12, Reduce, (34, 0), 0, null, null);
- Add_Action (Table.States (15), 18, Reduce, (34, 0), 0, null, null);
- Add_Action (Table.States (15), 19, Reduce, (34, 0), 0, null, null);
- Add_Action (Table.States (15), 22, 35);
+ Add_Action (Table.States (15), 12, Reduce, (46, 0), 0, null, null);
+ Add_Action (Table.States (15), 18, 38);
+ Add_Action (Table.States (15), 19, 39);
+ Add_Action (Table.States (15), 20, 40);
+ Add_Action (Table.States (15), 21, 41);
+ Add_Action (Table.States (15), 23, Reduce, (46, 0), 0, null, null);
+ Add_Action (Table.States (15), 29, Reduce, (46, 0), 0, null, null);
+ Add_Action (Table.States (15), 33, 42);
+ Add_Conflict (Table.States (15), 33, (46, 0), 0, null, null);
+ Add_Action (Table.States (15), 35, 43);
+ Add_Action (Table.States (15), 36, Reduce, (46, 0), 0, null, null);
Add_Error (Table.States (15));
- Add_Goto (Table.States (15), 33, 36);
- Add_Goto (Table.States (15), 34, 37);
- Add_Goto (Table.States (15), 35, 38);
- Add_Action (Table.States (16), (18, 22, 25), (37, 1), 2, null,
null);
- Add_Action (Table.States (17), (9, 22), (29, 0), 1, null, null);
- Add_Action (Table.States (18), 9, 39);
- Add_Action (Table.States (18), 22, 40);
- Add_Error (Table.States (18));
- Add_Action (Table.States (19), (18, 22, 25), (27, 5), 3,
declaration_5'Access, null);
- Add_Action (Table.States (20), 15, 41);
- Add_Error (Table.States (20));
- Add_Action (Table.States (21), 22, 42);
+ Add_Goto (Table.States (15), 45, 44);
+ Add_Goto (Table.States (15), 46, 45);
+ Add_Goto (Table.States (15), 47, 46);
+ Add_Goto (Table.States (15), 48, 47);
+ Add_Goto (Table.States (15), 49, 48);
+ Add_Goto (Table.States (15), 50, 49);
+ Add_Goto (Table.States (15), 51, 50);
+ Add_Goto (Table.States (15), 52, 51);
+ Add_Goto (Table.States (15), 53, 52);
+ Add_Action (Table.States (16), 12, Reduce, (46, 0), 0, null, null);
+ Add_Action (Table.States (16), 18, 38);
+ Add_Action (Table.States (16), 19, 39);
+ Add_Action (Table.States (16), 20, 40);
+ Add_Action (Table.States (16), 21, 41);
+ Add_Action (Table.States (16), 23, Reduce, (46, 0), 0, null, null);
+ Add_Action (Table.States (16), 29, Reduce, (46, 0), 0, null, null);
+ Add_Action (Table.States (16), 33, 42);
+ Add_Conflict (Table.States (16), 33, (46, 0), 0, null, null);
+ Add_Action (Table.States (16), 35, 43);
+ Add_Action (Table.States (16), 36, Reduce, (46, 0), 0, null, null);
+ Add_Error (Table.States (16));
+ Add_Goto (Table.States (16), 45, 53);
+ Add_Goto (Table.States (16), 46, 45);
+ Add_Goto (Table.States (16), 47, 46);
+ Add_Goto (Table.States (16), 48, 47);
+ Add_Goto (Table.States (16), 49, 48);
+ Add_Goto (Table.States (16), 50, 49);
+ Add_Goto (Table.States (16), 51, 50);
+ Add_Goto (Table.States (16), 52, 51);
+ Add_Goto (Table.States (16), 53, 52);
+ Add_Action (Table.States (17), (23, 33, 36), (56, 1), 2, null,
null);
+ Add_Action (Table.States (18), (9, 33), (40, 0), 1, null, null);
+ Add_Action (Table.States (19), 9, 54);
+ Add_Action (Table.States (19), 33, 55);
+ Add_Error (Table.States (19));
+ Add_Action (Table.States (20), (23, 33, 36), (38, 5), 3,
declaration_5'Access, null);
+ Add_Action (Table.States (21), 16, 56);
Add_Error (Table.States (21));
- Add_Action (Table.States (22), 22, 43);
+ Add_Action (Table.States (22), 33, 57);
Add_Error (Table.States (22));
- Add_Action (Table.States (23), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 8), 1, null, null);
- Add_Action (Table.States (24), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 4), 1, null, null);
- Add_Action (Table.States (25), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 0), 1, null, null);
- Add_Action (Table.States (26), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 2), 1, null, null);
- Add_Action (Table.States (27), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 5), 1, null, null);
- Add_Action (Table.States (28), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 3), 1, null, null);
- Add_Action (Table.States (29), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 1), 1, null, null);
- Add_Action (Table.States (30), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 6), 1, null, null);
- Add_Action (Table.States (31), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 7), 1, null, null);
- Add_Action (Table.States (32), 8, 23);
- Add_Action (Table.States (32), 10, 24);
- Add_Action (Table.States (32), 14, 25);
- Add_Action (Table.States (32), 15, 26);
- Add_Action (Table.States (32), 18, Reduce, (27, 2), 3,
declaration_2'Access, null);
- Add_Action (Table.States (32), 20, 27);
- Add_Action (Table.States (32), 21, 28);
- Add_Action (Table.States (32), 22, 29, (27, 2), 3,
declaration_2'Access, null);
- Add_Action (Table.States (32), 23, 30);
- Add_Action (Table.States (32), 24, 31);
- Add_Action (Table.States (32), 25, Reduce, (27, 2), 3,
declaration_2'Access, null);
- Add_Error (Table.States (32));
- Add_Goto (Table.States (32), 31, 44);
- Add_Action (Table.States (33), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (30, 0), 1, null, null);
- Add_Action (Table.States (34), 8, 23);
- Add_Action (Table.States (34), 10, 24);
- Add_Action (Table.States (34), 14, 25);
- Add_Action (Table.States (34), 15, 26);
- Add_Action (Table.States (34), 20, 27);
- Add_Action (Table.States (34), 21, 28);
- Add_Action (Table.States (34), 22, 29);
- Add_Action (Table.States (34), 23, 30);
- Add_Action (Table.States (34), 24, 31);
- Add_Error (Table.States (34));
- Add_Goto (Table.States (34), 30, 45);
- Add_Goto (Table.States (34), 31, 33);
- Add_Action (Table.States (35), (11, 12, 18, 19, 22), (35, 0), 1,
null, null);
- Add_Action (Table.States (36), 12, 46);
- Add_Action (Table.States (36), 18, 47);
- Add_Action (Table.States (36), 19, 48);
- Add_Error (Table.States (36));
- Add_Action (Table.States (37), (12, 18, 19), (33, 0), 1, null,
null);
- Add_Action (Table.States (38), 11, 49);
- Add_Action (Table.States (38), 12, Reduce, (34, 1), 1, null, null);
- Add_Action (Table.States (38), 18, Reduce, (34, 1), 1, null, null);
- Add_Action (Table.States (38), 19, Reduce, (34, 1), 1, null, null);
- Add_Action (Table.States (38), 22, 50);
+ Add_Action (Table.States (23), 33, 58);
+ Add_Error (Table.States (23));
+ Add_Action (Table.States (24), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 10), 1, null,
+ null);
+ Add_Action (Table.States (25), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 5), 1, null,
+ null);
+ Add_Action (Table.States (26), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 0), 1, null,
+ null);
+ Add_Action (Table.States (27), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 2), 1, null,
+ null);
+ Add_Action (Table.States (28), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 3), 1, null,
+ null);
+ Add_Action (Table.States (29), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 6), 1, null,
+ null);
+ Add_Action (Table.States (30), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 7), 1, null,
+ null);
+ Add_Action (Table.States (31), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 4), 1, null,
+ null);
+ Add_Action (Table.States (32), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 1), 1, null,
+ null);
+ Add_Action (Table.States (33), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 8), 1, null,
+ null);
+ Add_Action (Table.States (34), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 9), 1, null,
+ null);
+ Add_Action (Table.States (35), 8, 24);
+ Add_Action (Table.States (35), 10, 25);
+ Add_Action (Table.States (35), 15, 26);
+ Add_Action (Table.States (35), 16, 27);
+ Add_Action (Table.States (35), 20, 28);
+ Add_Action (Table.States (35), 23, Reduce, (38, 2), 3,
declaration_2'Access, null);
+ Add_Action (Table.States (35), 28, 29);
+ Add_Action (Table.States (35), 30, 30);
+ Add_Action (Table.States (35), 32, 31);
+ Add_Action (Table.States (35), 33, 32);
+ Add_Conflict (Table.States (35), 33, (38, 2), 3,
declaration_2'Access, null);
+ Add_Action (Table.States (35), 34, 33);
+ Add_Action (Table.States (35), 35, 34);
+ Add_Action (Table.States (35), 36, Reduce, (38, 2), 3,
declaration_2'Access, null);
+ Add_Error (Table.States (35));
+ Add_Goto (Table.States (35), 42, 59);
+ Add_Action (Table.States (36), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (41, 0), 1, null,
+ null);
+ Add_Action (Table.States (37), 8, 24);
+ Add_Action (Table.States (37), 10, 25);
+ Add_Action (Table.States (37), 15, 26);
+ Add_Action (Table.States (37), 16, 27);
+ Add_Action (Table.States (37), 20, 28);
+ Add_Action (Table.States (37), 28, 29);
+ Add_Action (Table.States (37), 30, 30);
+ Add_Action (Table.States (37), 32, 31);
+ Add_Action (Table.States (37), 33, 32);
+ Add_Action (Table.States (37), 34, 33);
+ Add_Action (Table.States (37), 35, 34);
+ Add_Error (Table.States (37));
+ Add_Goto (Table.States (37), 41, 60);
+ Add_Goto (Table.States (37), 42, 36);
+ Add_Action (Table.States (38), 18, 38);
+ Add_Action (Table.States (38), 19, 39);
+ Add_Action (Table.States (38), 20, 40);
+ Add_Action (Table.States (38), 21, 41);
+ Add_Action (Table.States (38), 33, 42);
+ Add_Action (Table.States (38), 35, 43);
Add_Error (Table.States (38));
- Add_Action (Table.States (39), (18, 22, 25), (27, 1), 4,
declaration_1'Access, null);
- Add_Action (Table.States (40), (9, 22), (29, 1), 2, null, null);
- Add_Action (Table.States (41), 22, 51);
+ Add_Goto (Table.States (38), 47, 46);
+ Add_Goto (Table.States (38), 48, 47);
+ Add_Goto (Table.States (38), 49, 61);
+ Add_Goto (Table.States (38), 50, 49);
+ Add_Goto (Table.States (38), 51, 50);
+ Add_Goto (Table.States (38), 52, 51);
+ Add_Goto (Table.States (38), 53, 52);
+ Add_Goto (Table.States (38), 54, 62);
+ Add_Action (Table.States (39), 18, 38);
+ Add_Action (Table.States (39), 19, 39);
+ Add_Action (Table.States (39), 20, 40);
+ Add_Action (Table.States (39), 21, 41);
+ Add_Action (Table.States (39), 33, 42);
+ Add_Action (Table.States (39), 35, 43);
+ Add_Error (Table.States (39));
+ Add_Goto (Table.States (39), 47, 46);
+ Add_Goto (Table.States (39), 48, 47);
+ Add_Goto (Table.States (39), 49, 61);
+ Add_Goto (Table.States (39), 50, 49);
+ Add_Goto (Table.States (39), 51, 50);
+ Add_Goto (Table.States (39), 52, 51);
+ Add_Goto (Table.States (39), 53, 52);
+ Add_Goto (Table.States (39), 54, 63);
+ Add_Action (Table.States (40), 18, 38);
+ Add_Action (Table.States (40), 19, 39);
+ Add_Action (Table.States (40), 20, 40);
+ Add_Action (Table.States (40), 21, 41);
+ Add_Action (Table.States (40), 33, 42);
+ Add_Action (Table.States (40), 35, 43);
+ Add_Error (Table.States (40));
+ Add_Goto (Table.States (40), 47, 46);
+ Add_Goto (Table.States (40), 48, 47);
+ Add_Goto (Table.States (40), 49, 61);
+ Add_Goto (Table.States (40), 50, 49);
+ Add_Goto (Table.States (40), 51, 50);
+ Add_Goto (Table.States (40), 52, 51);
+ Add_Goto (Table.States (40), 53, 52);
+ Add_Goto (Table.States (40), 54, 64);
+ Add_Action (Table.States (41), 33, 65);
Add_Error (Table.States (41));
- Add_Action (Table.States (42), 16, 52);
+ Add_Action (Table.States (42), 11, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 12, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 16, 66);
+ Add_Action (Table.States (42), 18, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 19, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 20, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 21, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 23, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 24, 67);
+ Add_Action (Table.States (42), 25, 68);
+ Add_Action (Table.States (42), 26, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 27, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 28, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 29, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 31, 69);
+ Add_Action (Table.States (42), 33, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 35, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (42), 36, Reduce, (50, 0), 1, null, null);
Add_Error (Table.States (42));
- Add_Action (Table.States (43), 16, 53);
+ Add_Action (Table.States (43), 11, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 12, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 18, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 19, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 20, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 21, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 23, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 25, 70);
+ Add_Action (Table.States (43), 26, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 27, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 28, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 29, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 33, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 35, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
+ Add_Action (Table.States (43), 36, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
Add_Error (Table.States (43));
- Add_Action (Table.States (44), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (30, 1), 2, null, null);
- Add_Action (Table.States (45), 8, 23);
- Add_Action (Table.States (45), 10, 24);
- Add_Action (Table.States (45), 14, 25);
- Add_Action (Table.States (45), 15, 26);
- Add_Action (Table.States (45), 18, Reduce, (27, 0), 4,
declaration_0'Access, null);
- Add_Action (Table.States (45), 20, 27);
- Add_Action (Table.States (45), 21, 28);
- Add_Action (Table.States (45), 22, 29, (27, 0), 4,
declaration_0'Access, null);
- Add_Action (Table.States (45), 23, 30);
- Add_Action (Table.States (45), 24, 31);
- Add_Action (Table.States (45), 25, Reduce, (27, 0), 4,
declaration_0'Access, null);
- Add_Error (Table.States (45));
- Add_Goto (Table.States (45), 31, 44);
- Add_Action (Table.States (46), 12, Reduce, (34, 0), 0, null, null);
- Add_Action (Table.States (46), 18, Reduce, (34, 0), 0, null, null);
- Add_Action (Table.States (46), 19, Reduce, (34, 0), 0, null, null);
- Add_Action (Table.States (46), 22, 35);
- Add_Error (Table.States (46));
- Add_Goto (Table.States (46), 34, 54);
- Add_Goto (Table.States (46), 35, 38);
- Add_Action (Table.States (47), 4, 55);
- Add_Action (Table.States (47), 5, 56);
- Add_Error (Table.States (47));
- Add_Action (Table.States (48), (18, 22, 25), (32, 0), 4,
nonterminal_0'Access, null);
- Add_Action (Table.States (49), 11, 57);
- Add_Action (Table.States (49), 12, Reduce, (34, 2), 2, null, null);
- Add_Action (Table.States (49), 18, Reduce, (34, 2), 2, null, null);
- Add_Action (Table.States (49), 19, Reduce, (34, 2), 2, null, null);
- Add_Error (Table.States (49));
- Add_Action (Table.States (50), (11, 12, 18, 19, 22), (35, 1), 2,
null, null);
- Add_Action (Table.States (51), (18, 22, 25), (27, 4), 5,
declaration_4'Access, null);
- Add_Action (Table.States (52), (1 => 22), (28, 1), 4, null, null);
- Add_Action (Table.States (53), (1 => 22), (28, 2), 4, null, null);
- Add_Action (Table.States (54), (12, 18, 19), (33, 1), 3, null,
null);
- Add_Action (Table.States (55), 5, 58);
- Add_Error (Table.States (55));
- Add_Action (Table.States (56), 22, 59);
+ Add_Action (Table.States (44), 12, 71);
+ Add_Action (Table.States (44), 23, 72);
+ Add_Conflict (Table.States (44), 23, (44, 1), 0, null, null);
+ Add_Action (Table.States (44), 29, 73);
+ Add_Action (Table.States (44), 33, Reduce, (44, 1), 0, null, null);
+ Add_Action (Table.States (44), 36, Reduce, (44, 1), 0, null, null);
+ Add_Error (Table.States (44));
+ Add_Goto (Table.States (44), 44, 74);
+ Add_Action (Table.States (45), (12, 23, 29, 33, 36), (45, 0), 1,
null, null);
+ Add_Action (Table.States (46), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 2), 1,
+ rhs_item_2'Access, null);
+ Add_Action (Table.States (47), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (49, 0), 1, null,
+ null);
+ Add_Action (Table.States (48), 11, 75);
+ Add_Action (Table.States (48), 12, Reduce, (46, 1), 1, null, null);
+ Add_Action (Table.States (48), 18, 38);
+ Add_Action (Table.States (48), 19, 39);
+ Add_Action (Table.States (48), 20, 40);
+ Add_Action (Table.States (48), 21, 41);
+ Add_Action (Table.States (48), 23, Reduce, (46, 1), 1, null, null);
+ Add_Action (Table.States (48), 29, Reduce, (46, 1), 1, null, null);
+ Add_Action (Table.States (48), 33, 42);
+ Add_Conflict (Table.States (48), 33, (46, 1), 1, null, null);
+ Add_Action (Table.States (48), 35, 43);
+ Add_Action (Table.States (48), 36, Reduce, (46, 1), 1, null, null);
+ Add_Error (Table.States (48));
+ Add_Goto (Table.States (48), 47, 46);
+ Add_Goto (Table.States (48), 48, 76);
+ Add_Goto (Table.States (48), 50, 49);
+ Add_Goto (Table.States (48), 51, 50);
+ Add_Goto (Table.States (48), 52, 51);
+ Add_Goto (Table.States (48), 53, 52);
+ Add_Action (Table.States (49), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (48, 0), 1, null,
+ null);
+ Add_Action (Table.States (50), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 5), 1,
+ rhs_item_5'Access, null);
+ Add_Action (Table.States (51), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 3), 1,
+ rhs_item_3'Access, null);
+ Add_Action (Table.States (52), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 4), 1,
+ rhs_item_4'Access, null);
+ Add_Action (Table.States (53), 12, 71);
+ Add_Action (Table.States (53), 23, 72);
+ Add_Conflict (Table.States (53), 23, (44, 1), 0, null, null);
+ Add_Action (Table.States (53), 29, 73);
+ Add_Action (Table.States (53), 33, Reduce, (44, 1), 0, null, null);
+ Add_Action (Table.States (53), 36, Reduce, (44, 1), 0, null, null);
+ Add_Error (Table.States (53));
+ Add_Goto (Table.States (53), 44, 77);
+ Add_Action (Table.States (54), (23, 33, 36), (38, 1), 4,
declaration_1'Access, null);
+ Add_Action (Table.States (55), (9, 33), (40, 1), 2, null, null);
+ Add_Action (Table.States (56), 33, 78);
Add_Error (Table.States (56));
- Add_Action (Table.States (57), (12, 18, 19), (34, 3), 3, null,
null);
- Add_Action (Table.States (58), (12, 18, 19), (33, 3), 4, null,
null);
- Add_Action (Table.States (59), 15, 60);
- Add_Error (Table.States (59));
- Add_Action (Table.States (60), 22, 61);
+ Add_Action (Table.States (57), 17, 79);
+ Add_Error (Table.States (57));
+ Add_Action (Table.States (58), 17, 80);
+ Add_Error (Table.States (58));
+ Add_Action (Table.States (59), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (41, 1), 2, null,
+ null);
+ Add_Action (Table.States (60), 8, 24);
+ Add_Action (Table.States (60), 10, 25);
+ Add_Action (Table.States (60), 15, 26);
+ Add_Action (Table.States (60), 16, 27);
+ Add_Action (Table.States (60), 20, 28);
+ Add_Action (Table.States (60), 23, Reduce, (38, 0), 4,
declaration_0'Access, null);
+ Add_Action (Table.States (60), 28, 29);
+ Add_Action (Table.States (60), 30, 30);
+ Add_Action (Table.States (60), 32, 31);
+ Add_Action (Table.States (60), 33, 32);
+ Add_Conflict (Table.States (60), 33, (38, 0), 4,
declaration_0'Access, null);
+ Add_Action (Table.States (60), 34, 33);
+ Add_Action (Table.States (60), 35, 34);
+ Add_Action (Table.States (60), 36, Reduce, (38, 0), 4,
declaration_0'Access, null);
Add_Error (Table.States (60));
- Add_Action (Table.States (61), (12, 18, 19), (33, 2), 6, null,
null);
+ Add_Goto (Table.States (60), 42, 59);
+ Add_Action (Table.States (61), 12, Reduce, (54, 0), 1, null, null);
+ Add_Action (Table.States (61), 18, 38);
+ Add_Action (Table.States (61), 19, 39);
+ Add_Action (Table.States (61), 20, 40);
+ Add_Action (Table.States (61), 21, 41);
+ Add_Action (Table.States (61), 26, Reduce, (54, 0), 1, null, null);
+ Add_Action (Table.States (61), 27, Reduce, (54, 0), 1, null, null);
+ Add_Action (Table.States (61), 28, Reduce, (54, 0), 1, null, null);
+ Add_Action (Table.States (61), 33, 42);
+ Add_Action (Table.States (61), 35, 43);
+ Add_Error (Table.States (61));
+ Add_Goto (Table.States (61), 47, 46);
+ Add_Goto (Table.States (61), 48, 76);
+ Add_Goto (Table.States (61), 50, 49);
+ Add_Goto (Table.States (61), 51, 50);
+ Add_Goto (Table.States (61), 52, 51);
+ Add_Goto (Table.States (61), 53, 52);
+ Add_Action (Table.States (62), 12, 81);
+ Add_Action (Table.States (62), 26, 82);
+ Add_Error (Table.States (62));
+ Add_Action (Table.States (63), 12, 81);
+ Add_Action (Table.States (63), 27, 83);
+ Add_Error (Table.States (63));
+ Add_Action (Table.States (64), 12, 81);
+ Add_Action (Table.States (64), 28, 84);
+ Add_Error (Table.States (64));
+ Add_Action (Table.States (65), 16, 85);
+ Add_Error (Table.States (65));
+ Add_Action (Table.States (66), 18, 38);
+ Add_Action (Table.States (66), 19, 39);
+ Add_Action (Table.States (66), 20, 40);
+ Add_Action (Table.States (66), 21, 41);
+ Add_Action (Table.States (66), 33, 86);
+ Add_Action (Table.States (66), 35, 43);
+ Add_Error (Table.States (66));
+ Add_Goto (Table.States (66), 47, 46);
+ Add_Goto (Table.States (66), 50, 87);
+ Add_Goto (Table.States (66), 51, 50);
+ Add_Goto (Table.States (66), 52, 51);
+ Add_Goto (Table.States (66), 53, 52);
+ Add_Action (Table.States (67), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 4), 2, null,
+ null);
+ Add_Action (Table.States (68), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 2), 2, null,
+ null);
+ Add_Action (Table.States (69), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 5), 2, null,
+ null);
+ Add_Action (Table.States (70), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 3), 2,
+ rhs_optional_item_3'Access, null);
+ Add_Action (Table.States (71), 12, Reduce, (46, 0), 0, null, null);
+ Add_Action (Table.States (71), 18, 38);
+ Add_Action (Table.States (71), 19, 39);
+ Add_Action (Table.States (71), 20, 40);
+ Add_Action (Table.States (71), 21, 41);
+ Add_Action (Table.States (71), 23, Reduce, (46, 0), 0, null, null);
+ Add_Action (Table.States (71), 29, Reduce, (46, 0), 0, null, null);
+ Add_Action (Table.States (71), 33, 42);
+ Add_Conflict (Table.States (71), 33, (46, 0), 0, null, null);
+ Add_Action (Table.States (71), 35, 43);
+ Add_Action (Table.States (71), 36, Reduce, (46, 0), 0, null, null);
+ Add_Error (Table.States (71));
+ Add_Goto (Table.States (71), 46, 88);
+ Add_Goto (Table.States (71), 47, 46);
+ Add_Goto (Table.States (71), 48, 47);
+ Add_Goto (Table.States (71), 49, 48);
+ Add_Goto (Table.States (71), 50, 49);
+ Add_Goto (Table.States (71), 51, 50);
+ Add_Goto (Table.States (71), 52, 51);
+ Add_Goto (Table.States (71), 53, 52);
+ Add_Action (Table.States (72), 4, 89);
+ Add_Action (Table.States (72), 5, 90);
+ Add_Error (Table.States (72));
+ Add_Action (Table.States (73), (23, 33, 36), (44, 0), 1, null,
null);
+ Add_Action (Table.States (74), (23, 33, 36), (43, 0), 4,
nonterminal_0'Access, null);
+ Add_Action (Table.States (75), 11, 91);
+ Add_Action (Table.States (75), 12, Reduce, (46, 2), 2, null, null);
+ Add_Action (Table.States (75), 23, Reduce, (46, 2), 2, null, null);
+ Add_Action (Table.States (75), 29, Reduce, (46, 2), 2, null, null);
+ Add_Action (Table.States (75), 33, Reduce, (46, 2), 2, null, null);
+ Add_Action (Table.States (75), 36, Reduce, (46, 2), 2, null, null);
+ Add_Error (Table.States (75));
+ Add_Action (Table.States (76), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (49, 1), 2, null,
+ null);
+ Add_Action (Table.States (77), (23, 33, 36), (43, 1), 4,
nonterminal_1'Access, null);
+ Add_Action (Table.States (78), (23, 33, 36), (38, 4), 5,
declaration_4'Access, null);
+ Add_Action (Table.States (79), (1 => 33), (39, 1), 4, null, null);
+ Add_Action (Table.States (80), (1 => 33), (39, 2), 4, null, null);
+ Add_Action (Table.States (81), 18, 38);
+ Add_Action (Table.States (81), 19, 39);
+ Add_Action (Table.States (81), 20, 40);
+ Add_Action (Table.States (81), 21, 41);
+ Add_Action (Table.States (81), 33, 42);
+ Add_Action (Table.States (81), 35, 43);
+ Add_Error (Table.States (81));
+ Add_Goto (Table.States (81), 47, 46);
+ Add_Goto (Table.States (81), 48, 47);
+ Add_Goto (Table.States (81), 49, 92);
+ Add_Goto (Table.States (81), 50, 49);
+ Add_Goto (Table.States (81), 51, 50);
+ Add_Goto (Table.States (81), 52, 51);
+ Add_Goto (Table.States (81), 53, 52);
+ Add_Action (Table.States (82), 11, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 12, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 18, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 19, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 20, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 21, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 22, 93);
+ Add_Action (Table.States (82), 23, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 26, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 27, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 28, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 29, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 33, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 35, Reduce, (53, 0), 3, null, null);
+ Add_Action (Table.States (82), 36, Reduce, (53, 0), 3, null, null);
+ Add_Error (Table.States (82));
+ Add_Action (Table.States (83), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 0), 3, null,
+ null);
+ Add_Action (Table.States (84), 11, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 12, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 18, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 19, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 20, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 21, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 23, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 24, 94);
+ Add_Action (Table.States (84), 25, 95);
+ Add_Action (Table.States (84), 26, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 27, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 28, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 29, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 31, 96);
+ Add_Action (Table.States (84), 33, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 35, Reduce, (51, 0), 3, null, null);
+ Add_Action (Table.States (84), 36, Reduce, (51, 0), 3, null, null);
+ Add_Error (Table.States (84));
+ Add_Action (Table.States (85), 33, 97);
+ Add_Error (Table.States (85));
+ Add_Action (Table.States (86), 11, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 12, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 18, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 19, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 20, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 21, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 23, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 24, 67);
+ Add_Action (Table.States (86), 25, 68);
+ Add_Action (Table.States (86), 26, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 27, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 28, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 29, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 31, 69);
+ Add_Action (Table.States (86), 33, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 35, Reduce, (50, 0), 1, null, null);
+ Add_Action (Table.States (86), 36, Reduce, (50, 0), 1, null, null);
+ Add_Error (Table.States (86));
+ Add_Action (Table.States (87), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (48, 1), 3, null,
+ null);
+ Add_Action (Table.States (88), (12, 23, 29, 33, 36), (45, 1), 3,
null, null);
+ Add_Action (Table.States (89), 5, 98);
+ Add_Error (Table.States (89));
+ Add_Action (Table.States (90), 33, 99);
+ Add_Error (Table.States (90));
+ Add_Action (Table.States (91), (12, 23, 29, 33, 36), (46, 3), 3,
null, null);
+ Add_Action (Table.States (92), 12, Reduce, (54, 1), 3, null, null);
+ Add_Action (Table.States (92), 18, 38);
+ Add_Action (Table.States (92), 19, 39);
+ Add_Action (Table.States (92), 20, 40);
+ Add_Action (Table.States (92), 21, 41);
+ Add_Action (Table.States (92), 26, Reduce, (54, 1), 3, null, null);
+ Add_Action (Table.States (92), 27, Reduce, (54, 1), 3, null, null);
+ Add_Action (Table.States (92), 28, Reduce, (54, 1), 3, null, null);
+ Add_Action (Table.States (92), 33, 42);
+ Add_Action (Table.States (92), 35, 43);
+ Add_Error (Table.States (92));
+ Add_Goto (Table.States (92), 47, 46);
+ Add_Goto (Table.States (92), 48, 76);
+ Add_Goto (Table.States (92), 50, 49);
+ Add_Goto (Table.States (92), 51, 50);
+ Add_Goto (Table.States (92), 52, 51);
+ Add_Goto (Table.States (92), 53, 52);
+ Add_Action (Table.States (93), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 1), 4, null,
+ null);
+ Add_Action (Table.States (94), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 2), 4, null,
+ null);
+ Add_Action (Table.States (95), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 1), 4, null,
+ null);
+ Add_Action (Table.States (96), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 3), 4, null,
+ null);
+ Add_Action (Table.States (97), 17, 100);
+ Add_Error (Table.States (97));
+ Add_Action (Table.States (98), (12, 23, 29, 33, 36), (45, 3), 4,
null, null);
+ Add_Action (Table.States (99), 16, 101);
+ Add_Error (Table.States (99));
+ Add_Action (Table.States (100), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (47, 0), 5, null,
+ null);
+ Add_Action (Table.States (101), 33, 102);
+ Add_Error (Table.States (101));
+ Add_Action (Table.States (102), (12, 23, 29, 33, 36), (45, 2), 6,
null, null);
end Subr_1;
begin
Subr_1;
diff --git a/wisitoken_grammar_main.ads b/wisitoken_grammar_main.ads
index 7f28437..e07ed68 100644
--- a/wisitoken_grammar_main.ads
+++ b/wisitoken_grammar_main.ads
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c PROCESS
wisitoken_grammar.wy
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
--
diff --git a/wisitoken_grammar_re2c.c b/wisitoken_grammar_re2c.c
index 6ad6b86..f4185ee 100644
--- a/wisitoken_grammar_re2c.c
+++ b/wisitoken_grammar_re2c.c
@@ -4,7 +4,7 @@
// command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
//
-// Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+// Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
//
// Author: Stephen Leake <stephe-leake@stephe-leake.org>
//
@@ -154,7 +154,7 @@ int wisitoken_grammar_next_token
*id = -1;
if (lexer->cursor > lexer->buffer_last)
{
- *id = 25;
+ *id = 36;
*byte_position = lexer->buffer_last - lexer->buffer + 1;
*byte_length = 0;
*char_position = lexer->char_token_start;
@@ -188,8 +188,13 @@ int wisitoken_grammar_next_token
case '"': goto yy11;
case '%': goto yy12;
case '\'': goto yy14;
- case ',': goto yy15;
- case '/': goto yy17;
+ case '(': goto yy15;
+ case ')': goto yy17;
+ case '*': goto yy19;
+ case '+': goto yy21;
+ case ',': goto yy23;
+ case '-': goto yy25;
+ case '/': goto yy27;
case '0':
case '1':
case '2':
@@ -199,12 +204,13 @@ int wisitoken_grammar_next_token
case '6':
case '7':
case '8':
- case '9': goto yy19;
- case ':': goto yy22;
- case ';': goto yy24;
- case '<': goto yy26;
- case '=': goto yy28;
- case '>': goto yy30;
+ case '9': goto yy29;
+ case ':': goto yy32;
+ case ';': goto yy34;
+ case '<': goto yy36;
+ case '=': goto yy38;
+ case '>': goto yy40;
+ case '?': goto yy42;
case 'A':
case 'B':
case 'C':
@@ -250,14 +256,69 @@ int wisitoken_grammar_next_token
case 'w':
case 'x':
case 'y':
- case 'z': goto yy32;
- case 'c': goto yy35;
- case 'e': goto yy36;
- case 'i': goto yy37;
- case 'k': goto yy38;
- case 'n': goto yy39;
- case 't': goto yy40;
- case '|': goto yy41;
+ case 'z': goto yy44;
+ case '[': goto yy47;
+ case ']': goto yy49;
+ case 'c': goto yy51;
+ case 'e': goto yy52;
+ case 'i': goto yy53;
+ case 'k': goto yy54;
+ case 'n': goto yy55;
+ case 't': goto yy56;
+ case '{': goto yy57;
+ case '|': goto yy59;
+ case '}': goto yy61;
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF: goto yy63;
+ case 0xE0: goto yy64;
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF: goto yy65;
+ case 0xF0: goto yy66;
+ case 0xF1:
+ case 0xF2:
+ case 0xF3: goto yy67;
+ case 0xF4: goto yy68;
default: goto yy2;
}
yy2:
@@ -265,21 +326,21 @@ yy2:
YYSKIP ();
yy3:
YYDEBUG(3, YYPEEK ());
-#line 233 "../wisitoken_grammar.re2c"
+#line 255 "../wisitoken_grammar.re2c"
{status = ERROR_unrecognized_character; continue;}
-#line 271 "../wisitoken_grammar_re2c.c"
+#line 332 "../wisitoken_grammar_re2c.c"
yy4:
YYDEBUG(4, YYPEEK ());
YYSKIP ();
YYDEBUG(5, YYPEEK ());
-#line 231 "../wisitoken_grammar.re2c"
- {*id = 25; continue;}
-#line 278 "../wisitoken_grammar_re2c.c"
+#line 253 "../wisitoken_grammar.re2c"
+ {*id = 36; continue;}
+#line 339 "../wisitoken_grammar_re2c.c"
yy6:
YYDEBUG(6, YYPEEK ());
YYSKIP ();
YYDEBUG(7, YYPEEK ());
-#line 200 "../wisitoken_grammar.re2c"
+#line 211 "../wisitoken_grammar.re2c"
{ lexer->byte_token_start = lexer->cursor;
lexer->char_token_start = lexer->char_pos;
if (*lexer->cursor == 0x0A)
@@ -287,14 +348,14 @@ yy6:
else
lexer->line_token_start = lexer->line;
continue; }
-#line 291 "../wisitoken_grammar_re2c.c"
+#line 352 "../wisitoken_grammar_re2c.c"
yy8:
YYDEBUG(8, YYPEEK ());
YYSKIP ();
YYDEBUG(9, YYPEEK ());
-#line 207 "../wisitoken_grammar.re2c"
+#line 218 "../wisitoken_grammar.re2c"
{*id = 1; continue;}
-#line 298 "../wisitoken_grammar_re2c.c"
+#line 359 "../wisitoken_grammar_re2c.c"
yy10:
YYDEBUG(10, YYPEEK ());
YYSKIP ();
@@ -456,7 +517,7 @@ yy11:
case 0xF1:
case 0xF2:
case 0xF3:
- case 0xF4: goto yy44;
+ case 0xF4: goto yy70;
default: goto yy3;
}
yy12:
@@ -464,16 +525,16 @@ yy12:
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
- case '(': goto yy54;
- case '[': goto yy56;
- case '{': goto yy58;
+ case '(': goto yy80;
+ case '[': goto yy82;
+ case '{': goto yy84;
default: goto yy13;
}
yy13:
YYDEBUG(13, YYPEEK ());
-#line 224 "../wisitoken_grammar.re2c"
- {*id = 18; continue;}
-#line 477 "../wisitoken_grammar_re2c.c"
+#line 240 "../wisitoken_grammar.re2c"
+ {*id = 23; continue;}
+#line 538 "../wisitoken_grammar_re2c.c"
yy14:
YYDEBUG(14, YYPEEK ());
yyaccept = 0;
@@ -627,28 +688,48 @@ yy14:
case 0xF1:
case 0xF2:
case 0xF3:
- case 0xF4: goto yy61;
+ case 0xF4: goto yy87;
default: goto yy3;
}
yy15:
YYDEBUG(15, YYPEEK ());
YYSKIP ();
YYDEBUG(16, YYPEEK ());
-#line 220 "../wisitoken_grammar.re2c"
- {*id = 14; continue;}
-#line 640 "../wisitoken_grammar_re2c.c"
+#line 237 "../wisitoken_grammar.re2c"
+ {*id = 20; continue;}
+#line 701 "../wisitoken_grammar_re2c.c"
yy17:
YYDEBUG(17, YYPEEK ());
YYSKIP ();
YYDEBUG(18, YYPEEK ());
-#line 226 "../wisitoken_grammar.re2c"
- {*id = 20; continue;}
-#line 647 "../wisitoken_grammar_re2c.c"
+#line 245 "../wisitoken_grammar.re2c"
+ {*id = 28; continue;}
+#line 708 "../wisitoken_grammar_re2c.c"
yy19:
YYDEBUG(19, YYPEEK ());
YYSKIP ();
- yych = YYPEEK ();
YYDEBUG(20, YYPEEK ());
+#line 248 "../wisitoken_grammar.re2c"
+ {*id = 31; continue;}
+#line 715 "../wisitoken_grammar_re2c.c"
+yy21:
+ YYDEBUG(21, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(22, YYPEEK ());
+#line 241 "../wisitoken_grammar.re2c"
+ {*id = 24; continue;}
+#line 722 "../wisitoken_grammar_re2c.c"
+yy23:
+ YYDEBUG(23, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(24, YYPEEK ());
+#line 232 "../wisitoken_grammar.re2c"
+ {*id = 15; continue;}
+#line 729 "../wisitoken_grammar_re2c.c"
+yy25:
+ YYDEBUG(25, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
switch (yych) {
case '0':
case '1':
@@ -660,63 +741,27 @@ yy19:
case '7':
case '8':
case '9':
- case '_': goto yy19;
- default: goto yy21;
- }
-yy21:
- YYDEBUG(21, YYPEEK ());
-#line 227 "../wisitoken_grammar.re2c"
- {*id = 21; continue;}
-#line 671 "../wisitoken_grammar_re2c.c"
-yy22:
- YYDEBUG(22, YYPEEK ());
- YYSKIP ();
- YYDEBUG(23, YYPEEK ());
-#line 219 "../wisitoken_grammar.re2c"
- {*id = 13; continue;}
-#line 678 "../wisitoken_grammar_re2c.c"
-yy24:
- YYDEBUG(24, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case ';': goto yy70;
- default: goto yy25;
+ case '_': goto yy29;
+ default: goto yy26;
}
-yy25:
- YYDEBUG(25, YYPEEK ());
-#line 225 "../wisitoken_grammar.re2c"
- {*id = 19; continue;}
-#line 691 "../wisitoken_grammar_re2c.c"
yy26:
YYDEBUG(26, YYPEEK ());
- YYSKIP ();
+#line 239 "../wisitoken_grammar.re2c"
+ {*id = 22; continue;}
+#line 752 "../wisitoken_grammar_re2c.c"
+yy27:
YYDEBUG(27, YYPEEK ());
-#line 223 "../wisitoken_grammar.re2c"
- {*id = 17; continue;}
-#line 698 "../wisitoken_grammar_re2c.c"
-yy28:
- YYDEBUG(28, YYPEEK ());
YYSKIP ();
+ YYDEBUG(28, YYPEEK ());
+#line 247 "../wisitoken_grammar.re2c"
+ {*id = 30; continue;}
+#line 759 "../wisitoken_grammar_re2c.c"
+yy29:
YYDEBUG(29, YYPEEK ());
-#line 221 "../wisitoken_grammar.re2c"
- {*id = 15; continue;}
-#line 705 "../wisitoken_grammar_re2c.c"
-yy30:
- YYDEBUG(30, YYPEEK ());
- YYSKIP ();
- YYDEBUG(31, YYPEEK ());
-#line 222 "../wisitoken_grammar.re2c"
- {*id = 16; continue;}
-#line 712 "../wisitoken_grammar_re2c.c"
-yy32:
- YYDEBUG(32, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
-yy33:
- YYDEBUG(33, YYPEEK ());
+ YYDEBUG(30, YYPEEK ());
switch (yych) {
- case '-':
case '0':
case '1':
case '2':
@@ -727,143 +772,80 @@ yy33:
case '7':
case '8':
case '9':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z': goto yy32;
- default: goto yy34;
+ case '_': goto yy29;
+ default: goto yy31;
}
-yy34:
- YYDEBUG(34, YYPEEK ());
-#line 228 "../wisitoken_grammar.re2c"
- {*id = 22; continue;}
-#line 790 "../wisitoken_grammar_re2c.c"
-yy35:
- YYDEBUG(35, YYPEEK ());
+yy31:
+ YYDEBUG(31, YYPEEK ());
+#line 249 "../wisitoken_grammar.re2c"
+ {*id = 32; continue;}
+#line 783 "../wisitoken_grammar_re2c.c"
+yy32:
+ YYDEBUG(32, YYPEEK ());
+ yyaccept = 1;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'o': goto yy73;
+ case ':': goto yy96;
default: goto yy33;
}
-yy36:
- YYDEBUG(36, YYPEEK ());
+yy33:
+ YYDEBUG(33, YYPEEK ());
+#line 230 "../wisitoken_grammar.re2c"
+ {*id = 13; continue;}
+#line 798 "../wisitoken_grammar_re2c.c"
+yy34:
+ YYDEBUG(34, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
- case 'n': goto yy74;
- default: goto yy33;
+ case ';': goto yy97;
+ default: goto yy35;
}
-yy37:
- YYDEBUG(37, YYPEEK ());
+yy35:
+ YYDEBUG(35, YYPEEK ());
+#line 246 "../wisitoken_grammar.re2c"
+ {*id = 29; continue;}
+#line 811 "../wisitoken_grammar_re2c.c"
+yy36:
+ YYDEBUG(36, YYPEEK ());
YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'f': goto yy75;
- default: goto yy33;
- }
+ YYDEBUG(37, YYPEEK ());
+#line 238 "../wisitoken_grammar.re2c"
+ {*id = 21; continue;}
+#line 818 "../wisitoken_grammar_re2c.c"
yy38:
YYDEBUG(38, YYPEEK ());
YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'e': goto yy77;
- default: goto yy33;
- }
-yy39:
YYDEBUG(39, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'o': goto yy78;
- default: goto yy33;
- }
+#line 233 "../wisitoken_grammar.re2c"
+ {*id = 16; continue;}
+#line 825 "../wisitoken_grammar_re2c.c"
yy40:
YYDEBUG(40, YYPEEK ());
YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'o': goto yy79;
- default: goto yy33;
- }
-yy41:
YYDEBUG(41, YYPEEK ());
- YYSKIP ();
+#line 234 "../wisitoken_grammar.re2c"
+ {*id = 17; continue;}
+#line 832 "../wisitoken_grammar_re2c.c"
+yy42:
YYDEBUG(42, YYPEEK ());
-#line 218 "../wisitoken_grammar.re2c"
- {*id = 12; continue;}
-#line 845 "../wisitoken_grammar_re2c.c"
-yy43:
- YYDEBUG(43, YYPEEK ());
YYSKIP ();
- yych = YYPEEK ();
+ YYDEBUG(43, YYPEEK ());
+#line 242 "../wisitoken_grammar.re2c"
+ {*id = 25; continue;}
+#line 839 "../wisitoken_grammar_re2c.c"
yy44:
YYDEBUG(44, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+yy45:
+ YYDEBUG(45, YYPEEK ());
switch (yych) {
- case ' ':
- case '!':
- case '#':
- case '$':
- case '%':
- case '&':
- case '\'':
- case '(':
- case ')':
- case '*':
- case '+':
- case ',':
case '-':
- case '.':
- case '/':
case '0':
case '1':
case '2':
@@ -874,13 +856,6 @@ yy44:
case '7':
case '8':
case '9':
- case ':':
- case ';':
- case '<':
- case '=':
- case '>':
- case '?':
- case '@':
case 'A':
case 'B':
case 'C':
@@ -907,12 +882,7 @@ yy44:
case 'X':
case 'Y':
case 'Z':
- case '[':
- case '\\':
- case ']':
- case '^':
case '_':
- case '`':
case 'a':
case 'b':
case 'c':
@@ -938,13 +908,7 @@ yy44:
case 'w':
case 'x':
case 'y':
- case 'z':
- case '{':
- case '|':
- case '}':
- case '~':
- case 0x7F: goto yy43;
- case '"': goto yy46;
+ case 'z': goto yy44;
case 0xC2:
case 0xC3:
case 0xC4:
@@ -974,8 +938,8 @@ yy44:
case 0xDC:
case 0xDD:
case 0xDE:
- case 0xDF: goto yy48;
- case 0xE0: goto yy49;
+ case 0xDF: goto yy100;
+ case 0xE0: goto yy101;
case 0xE1:
case 0xE2:
case 0xE3:
@@ -990,40 +954,116 @@ yy44:
case 0xEC:
case 0xED:
case 0xEE:
- case 0xEF: goto yy50;
- case 0xF0: goto yy51;
+ case 0xEF: goto yy102;
+ case 0xF0: goto yy103;
case 0xF1:
case 0xF2:
- case 0xF3: goto yy52;
- case 0xF4: goto yy53;
- default: goto yy45;
- }
-yy45:
- YYDEBUG(45, YYPEEK ());
- YYRESTORE ();
- switch (yyaccept) {
- case 0: goto yy3;
- case 1: goto yy47;
- case 2: goto yy63;
- default: goto yy72;
+ case 0xF3: goto yy104;
+ case 0xF4: goto yy105;
+ default: goto yy46;
}
yy46:
YYDEBUG(46, YYPEEK ());
- yyaccept = 1;
+#line 250 "../wisitoken_grammar.re2c"
+ {*id = 33; continue;}
+#line 970 "../wisitoken_grammar_re2c.c"
+yy47:
+ YYDEBUG(47, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(48, YYPEEK ());
+#line 236 "../wisitoken_grammar.re2c"
+ {*id = 19; continue;}
+#line 977 "../wisitoken_grammar_re2c.c"
+yy49:
+ YYDEBUG(49, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(50, YYPEEK ());
+#line 244 "../wisitoken_grammar.re2c"
+ {*id = 27; continue;}
+#line 984 "../wisitoken_grammar_re2c.c"
+yy51:
+ YYDEBUG(51, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case '"': goto yy43;
- default: goto yy47;
+ case 'o': goto yy106;
+ default: goto yy45;
}
-yy47:
- YYDEBUG(47, YYPEEK ());
+yy52:
+ YYDEBUG(52, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'n': goto yy107;
+ default: goto yy45;
+ }
+yy53:
+ YYDEBUG(53, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'f': goto yy108;
+ default: goto yy45;
+ }
+yy54:
+ YYDEBUG(54, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'e': goto yy110;
+ default: goto yy45;
+ }
+yy55:
+ YYDEBUG(55, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'o': goto yy111;
+ default: goto yy45;
+ }
+yy56:
+ YYDEBUG(56, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'o': goto yy112;
+ default: goto yy45;
+ }
+yy57:
+ YYDEBUG(57, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(58, YYPEEK ());
+#line 235 "../wisitoken_grammar.re2c"
+ {*id = 18; continue;}
+#line 1051 "../wisitoken_grammar_re2c.c"
+yy59:
+ YYDEBUG(59, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(60, YYPEEK ());
#line 229 "../wisitoken_grammar.re2c"
- {*id = 23; continue;}
-#line 1025 "../wisitoken_grammar_re2c.c"
-yy48:
- YYDEBUG(48, YYPEEK ());
+ {*id = 12; continue;}
+#line 1058 "../wisitoken_grammar_re2c.c"
+yy61:
+ YYDEBUG(61, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(62, YYPEEK ());
+#line 243 "../wisitoken_grammar.re2c"
+ {*id = 26; continue;}
+#line 1065 "../wisitoken_grammar_re2c.c"
+yy63:
+ YYDEBUG(63, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -1090,12 +1130,14 @@ yy48:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy43;
- default: goto yy45;
+ case 0xBF: goto yy44;
+ default: goto yy3;
}
-yy49:
- YYDEBUG(49, YYPEEK ());
+yy64:
+ YYDEBUG(64, YYPEEK ());
+ yyaccept = 0;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
case 0xA0:
@@ -1129,12 +1171,14 @@ yy49:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy48;
- default: goto yy45;
+ case 0xBF: goto yy100;
+ default: goto yy3;
}
-yy50:
- YYDEBUG(50, YYPEEK ());
+yy65:
+ YYDEBUG(65, YYPEEK ());
+ yyaccept = 0;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
case 0x80:
@@ -1200,12 +1244,14 @@ yy50:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy48;
- default: goto yy45;
+ case 0xBF: goto yy100;
+ default: goto yy3;
}
-yy51:
- YYDEBUG(51, YYPEEK ());
+yy66:
+ YYDEBUG(66, YYPEEK ());
+ yyaccept = 0;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
case 0x90:
@@ -1255,12 +1301,14 @@ yy51:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy50;
- default: goto yy45;
+ case 0xBF: goto yy102;
+ default: goto yy3;
}
-yy52:
- YYDEBUG(52, YYPEEK ());
+yy67:
+ YYDEBUG(67, YYPEEK ());
+ yyaccept = 0;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
case 0x80:
@@ -1326,12 +1374,14 @@ yy52:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy50;
- default: goto yy45;
+ case 0xBF: goto yy102;
+ default: goto yy3;
}
-yy53:
- YYDEBUG(53, YYPEEK ());
+yy68:
+ YYDEBUG(68, YYPEEK ());
+ yyaccept = 0;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
case 0x80:
@@ -1349,44 +1399,23 @@ yy53:
case 0x8C:
case 0x8D:
case 0x8E:
- case 0x8F: goto yy50;
- default: goto yy45;
+ case 0x8F: goto yy102;
+ default: goto yy3;
}
-yy54:
- YYDEBUG(54, YYPEEK ());
- YYSKIP ();
- YYDEBUG(55, YYPEEK ());
-#line 217 "../wisitoken_grammar.re2c"
- {*id = 11; skip_to(lexer, ")%"); continue;}
-#line 1362 "../wisitoken_grammar_re2c.c"
-yy56:
- YYDEBUG(56, YYPEEK ());
- YYSKIP ();
- YYDEBUG(57, YYPEEK ());
-#line 216 "../wisitoken_grammar.re2c"
- {*id = 10; skip_to(lexer, "]%"); continue;}
-#line 1369 "../wisitoken_grammar_re2c.c"
-yy58:
- YYDEBUG(58, YYPEEK ());
- YYSKIP ();
- YYDEBUG(59, YYPEEK ());
-#line 215 "../wisitoken_grammar.re2c"
- {*id = 9; skip_to(lexer, "}%"); continue;}
-#line 1376 "../wisitoken_grammar_re2c.c"
-yy60:
- YYDEBUG(60, YYPEEK ());
+yy69:
+ YYDEBUG(69, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
-yy61:
- YYDEBUG(61, YYPEEK ());
+yy70:
+ YYDEBUG(70, YYPEEK ());
switch (yych) {
case ' ':
case '!':
- case '"':
case '#':
case '$':
case '%':
case '&':
+ case '\'':
case '(':
case ')':
case '*':
@@ -1474,8 +1503,8 @@ yy61:
case '|':
case '}':
case '~':
- case 0x7F: goto yy60;
- case '\'': goto yy62;
+ case 0x7F: goto yy69;
+ case '"': goto yy72;
case 0xC2:
case 0xC3:
case 0xC4:
@@ -1505,8 +1534,8 @@ yy61:
case 0xDC:
case 0xDD:
case 0xDE:
- case 0xDF: goto yy64;
- case 0xE0: goto yy65;
+ case 0xDF: goto yy74;
+ case 0xE0: goto yy75;
case 0xE1:
case 0xE2:
case 0xE3:
@@ -1521,31 +1550,48 @@ yy61:
case 0xEC:
case 0xED:
case 0xEE:
- case 0xEF: goto yy66;
- case 0xF0: goto yy67;
+ case 0xEF: goto yy76;
+ case 0xF0: goto yy77;
case 0xF1:
case 0xF2:
- case 0xF3: goto yy68;
- case 0xF4: goto yy69;
- default: goto yy45;
+ case 0xF3: goto yy78;
+ case 0xF4: goto yy79;
+ default: goto yy71;
}
-yy62:
- YYDEBUG(62, YYPEEK ());
- yyaccept = 2;
+yy71:
+ YYDEBUG(71, YYPEEK ());
+ YYRESTORE ();
+ switch (yyaccept) {
+ case 0: goto yy3;
+ case 1: goto yy33;
+ case 2: goto yy46;
+ case 3: goto yy73;
+ case 4: goto yy89;
+ case 5: goto yy99;
+ case 6: goto yy109;
+ case 7: goto yy123;
+ case 8: goto yy128;
+ case 9: goto yy135;
+ case 10: goto yy139;
+ default: goto yy145;
+ }
+yy72:
+ YYDEBUG(72, YYPEEK ());
+ yyaccept = 3;
YYSKIP ();
YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case '\'': goto yy60;
- default: goto yy63;
+ case '"': goto yy69;
+ default: goto yy73;
}
-yy63:
- YYDEBUG(63, YYPEEK ());
-#line 230 "../wisitoken_grammar.re2c"
- {*id = 24; continue;}
-#line 1547 "../wisitoken_grammar_re2c.c"
-yy64:
- YYDEBUG(64, YYPEEK ());
+yy73:
+ YYDEBUG(73, YYPEEK ());
+#line 251 "../wisitoken_grammar.re2c"
+ {*id = 34; continue;}
+#line 1593 "../wisitoken_grammar_re2c.c"
+yy74:
+ YYDEBUG(74, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -1612,11 +1658,11 @@ yy64:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy60;
- default: goto yy45;
+ case 0xBF: goto yy69;
+ default: goto yy71;
}
-yy65:
- YYDEBUG(65, YYPEEK ());
+yy75:
+ YYDEBUG(75, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -1651,11 +1697,11 @@ yy65:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy64;
- default: goto yy45;
+ case 0xBF: goto yy74;
+ default: goto yy71;
}
-yy66:
- YYDEBUG(66, YYPEEK ());
+yy76:
+ YYDEBUG(76, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -1722,11 +1768,11 @@ yy66:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy64;
- default: goto yy45;
+ case 0xBF: goto yy74;
+ default: goto yy71;
}
-yy67:
- YYDEBUG(67, YYPEEK ());
+yy77:
+ YYDEBUG(77, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -1777,11 +1823,11 @@ yy67:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy66;
- default: goto yy45;
+ case 0xBF: goto yy76;
+ default: goto yy71;
}
-yy68:
- YYDEBUG(68, YYPEEK ());
+yy78:
+ YYDEBUG(78, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -1848,11 +1894,11 @@ yy68:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy66;
- default: goto yy45;
+ case 0xBF: goto yy76;
+ default: goto yy71;
}
-yy69:
- YYDEBUG(69, YYPEEK ());
+yy79:
+ YYDEBUG(79, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -1871,47 +1917,37 @@ yy69:
case 0x8C:
case 0x8D:
case 0x8E:
- case 0x8F: goto yy66;
- default: goto yy45;
+ case 0x8F: goto yy76;
+ default: goto yy71;
}
-yy70:
- YYDEBUG(70, YYPEEK ());
- yyaccept = 3;
+yy80:
+ YYDEBUG(80, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(81, YYPEEK ());
+#line 228 "../wisitoken_grammar.re2c"
+ {*id = 11; skip_to(lexer, ")%"); continue;}
+#line 1930 "../wisitoken_grammar_re2c.c"
+yy82:
+ YYDEBUG(82, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(83, YYPEEK ());
+#line 227 "../wisitoken_grammar.re2c"
+ {*id = 10; skip_to(lexer, "]%"); continue;}
+#line 1937 "../wisitoken_grammar_re2c.c"
+yy84:
+ YYDEBUG(84, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(85, YYPEEK ());
+#line 226 "../wisitoken_grammar.re2c"
+ {*id = 9; skip_to(lexer, "}%"); continue;}
+#line 1944 "../wisitoken_grammar_re2c.c"
+yy86:
+ YYDEBUG(86, YYPEEK ());
YYSKIP ();
- YYBACKUP ();
yych = YYPEEK ();
- YYDEBUG(71, YYPEEK ());
+yy87:
+ YYDEBUG(87, YYPEEK ());
switch (yych) {
- case 0x00:
- case 0x01:
- case 0x02:
- case 0x03:
- case 0x05:
- case 0x06:
- case 0x07:
- case 0x08:
- case '\t':
- case '\v':
- case '\f':
- case '\r':
- case 0x0E:
- case 0x0F:
- case 0x10:
- case 0x11:
- case 0x12:
- case 0x13:
- case 0x14:
- case 0x15:
- case 0x16:
- case 0x17:
- case 0x18:
- case 0x19:
- case 0x1A:
- case 0x1B:
- case 0x1C:
- case 0x1D:
- case 0x1E:
- case 0x1F:
case ' ':
case '!':
case '"':
@@ -1919,7 +1955,6 @@ yy70:
case '$':
case '%':
case '&':
- case '\'':
case '(':
case ')':
case '*':
@@ -2007,7 +2042,8 @@ yy70:
case '|':
case '}':
case '~':
- case 0x7F: goto yy70;
+ case 0x7F: goto yy86;
+ case '\'': goto yy88;
case 0xC2:
case 0xC3:
case 0xC4:
@@ -2037,8 +2073,8 @@ yy70:
case 0xDC:
case 0xDD:
case 0xDE:
- case 0xDF: goto yy80;
- case 0xE0: goto yy81;
+ case 0xDF: goto yy90;
+ case 0xE0: goto yy91;
case 0xE1:
case 0xE2:
case 0xE3:
@@ -2053,137 +2089,31 @@ yy70:
case 0xEC:
case 0xED:
case 0xEE:
- case 0xEF: goto yy82;
- case 0xF0: goto yy83;
+ case 0xEF: goto yy92;
+ case 0xF0: goto yy93;
case 0xF1:
case 0xF2:
- case 0xF3: goto yy84;
- case 0xF4: goto yy85;
- default: goto yy72;
+ case 0xF3: goto yy94;
+ case 0xF4: goto yy95;
+ default: goto yy71;
}
-yy72:
- YYDEBUG(72, YYPEEK ());
-#line 208 "../wisitoken_grammar.re2c"
- {*id = 2; continue;}
-#line 2069 "../wisitoken_grammar_re2c.c"
-yy73:
- YYDEBUG(73, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'd': goto yy86;
- default: goto yy33;
- }
-yy74:
- YYDEBUG(74, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'd': goto yy87;
- default: goto yy33;
- }
-yy75:
- YYDEBUG(75, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case '-':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z': goto yy32;
- default: goto yy76;
- }
-yy76:
- YYDEBUG(76, YYPEEK ());
-#line 211 "../wisitoken_grammar.re2c"
- {*id = 5; continue;}
-#line 2161 "../wisitoken_grammar_re2c.c"
-yy77:
- YYDEBUG(77, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'y': goto yy89;
- default: goto yy33;
- }
-yy78:
- YYDEBUG(78, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'n': goto yy90;
- default: goto yy33;
- }
-yy79:
- YYDEBUG(79, YYPEEK ());
+yy88:
+ YYDEBUG(88, YYPEEK ());
+ yyaccept = 4;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'k': goto yy91;
- default: goto yy33;
+ case '\'': goto yy86;
+ default: goto yy89;
}
-yy80:
- YYDEBUG(80, YYPEEK ());
+yy89:
+ YYDEBUG(89, YYPEEK ());
+#line 252 "../wisitoken_grammar.re2c"
+ {*id = 35; continue;}
+#line 2115 "../wisitoken_grammar_re2c.c"
+yy90:
+ YYDEBUG(90, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -2250,11 +2180,11 @@ yy80:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy70;
- default: goto yy45;
+ case 0xBF: goto yy86;
+ default: goto yy71;
}
-yy81:
- YYDEBUG(81, YYPEEK ());
+yy91:
+ YYDEBUG(91, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -2289,11 +2219,11 @@ yy81:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy80;
- default: goto yy45;
+ case 0xBF: goto yy90;
+ default: goto yy71;
}
-yy82:
- YYDEBUG(82, YYPEEK ());
+yy92:
+ YYDEBUG(92, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -2360,11 +2290,11 @@ yy82:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy80;
- default: goto yy45;
+ case 0xBF: goto yy90;
+ default: goto yy71;
}
-yy83:
- YYDEBUG(83, YYPEEK ());
+yy93:
+ YYDEBUG(93, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -2415,11 +2345,11 @@ yy83:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy82;
- default: goto yy45;
+ case 0xBF: goto yy92;
+ default: goto yy71;
}
-yy84:
- YYDEBUG(84, YYPEEK ());
+yy94:
+ YYDEBUG(94, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -2486,11 +2416,11 @@ yy84:
case 0xBC:
case 0xBD:
case 0xBE:
- case 0xBF: goto yy82;
- default: goto yy45;
+ case 0xBF: goto yy92;
+ default: goto yy71;
}
-yy85:
- YYDEBUG(85, YYPEEK ());
+yy95:
+ YYDEBUG(95, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
@@ -2509,23 +2439,71 @@ yy85:
case 0x8C:
case 0x8D:
case 0x8E:
- case 0x8F: goto yy82;
- default: goto yy45;
+ case 0x8F: goto yy92;
+ default: goto yy71;
}
-yy86:
- YYDEBUG(86, YYPEEK ());
+yy96:
+ YYDEBUG(96, YYPEEK ());
YYSKIP ();
yych = YYPEEK ();
switch (yych) {
- case 'e': goto yy92;
- default: goto yy33;
+ case '=': goto yy113;
+ default: goto yy71;
}
-yy87:
- YYDEBUG(87, YYPEEK ());
+yy97:
+ YYDEBUG(97, YYPEEK ());
+ yyaccept = 5;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
+ YYDEBUG(98, YYPEEK ());
switch (yych) {
+ case 0x00:
+ case 0x01:
+ case 0x02:
+ case 0x03:
+ case 0x05:
+ case 0x06:
+ case 0x07:
+ case 0x08:
+ case '\t':
+ case '\v':
+ case '\f':
+ case '\r':
+ case 0x0E:
+ case 0x0F:
+ case 0x10:
+ case 0x11:
+ case 0x12:
+ case 0x13:
+ case 0x14:
+ case 0x15:
+ case 0x16:
+ case 0x17:
+ case 0x18:
+ case 0x19:
+ case 0x1A:
+ case 0x1B:
+ case 0x1C:
+ case 0x1D:
+ case 0x1E:
+ case 0x1F:
+ case ' ':
+ case '!':
+ case '"':
+ case '#':
+ case '$':
+ case '%':
+ case '&':
+ case '\'':
+ case '(':
+ case ')':
+ case '*':
+ case '+':
+ case ',':
case '-':
+ case '.':
+ case '/':
case '0':
case '1':
case '2':
@@ -2536,6 +2514,13 @@ yy87:
case '7':
case '8':
case '9':
+ case ':':
+ case ';':
+ case '<':
+ case '=':
+ case '>':
+ case '?':
+ case '@':
case 'A':
case 'B':
case 'C':
@@ -2562,7 +2547,12 @@ yy87:
case 'X':
case 'Y':
case 'Z':
+ case '[':
+ case '\\':
+ case ']':
+ case '^':
case '_':
+ case '`':
case 'a':
case 'b':
case 'c':
@@ -2588,41 +2578,1090 @@ yy87:
case 'w':
case 'x':
case 'y':
- case 'z': goto yy32;
- default: goto yy88;
+ case 'z':
+ case '{':
+ case '|':
+ case '}':
+ case '~':
+ case 0x7F: goto yy97;
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF: goto yy115;
+ case 0xE0: goto yy116;
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF: goto yy117;
+ case 0xF0: goto yy118;
+ case 0xF1:
+ case 0xF2:
+ case 0xF3: goto yy119;
+ case 0xF4: goto yy120;
+ default: goto yy99;
}
-yy88:
- YYDEBUG(88, YYPEEK ());
-#line 210 "../wisitoken_grammar.re2c"
- {*id = 4; continue;}
-#line 2599 "../wisitoken_grammar_re2c.c"
-yy89:
- YYDEBUG(89, YYPEEK ());
- YYSKIP ();
+yy99:
+ YYDEBUG(99, YYPEEK ());
+#line 219 "../wisitoken_grammar.re2c"
+ {*id = 2; continue;}
+#line 2645 "../wisitoken_grammar_re2c.c"
+yy100:
+ YYDEBUG(100, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy44;
+ default: goto yy71;
+ }
+yy101:
+ YYDEBUG(101, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy100;
+ default: goto yy71;
+ }
+yy102:
+ YYDEBUG(102, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy100;
+ default: goto yy71;
+ }
+yy103:
+ YYDEBUG(103, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy102;
+ default: goto yy71;
+ }
+yy104:
+ YYDEBUG(104, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy102;
+ default: goto yy71;
+ }
+yy105:
+ YYDEBUG(105, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F: goto yy102;
+ default: goto yy71;
+ }
+yy106:
+ YYDEBUG(106, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'd': goto yy121;
+ default: goto yy45;
+ }
+yy107:
+ YYDEBUG(107, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'd': goto yy122;
+ default: goto yy45;
+ }
+yy108:
+ YYDEBUG(108, YYPEEK ());
+ yyaccept = 6;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '_':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z':
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF:
+ case 0xE0:
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF:
+ case 0xF0:
+ case 0xF1:
+ case 0xF2:
+ case 0xF3:
+ case 0xF4: goto yy45;
+ default: goto yy109;
+ }
+yy109:
+ YYDEBUG(109, YYPEEK ());
+#line 222 "../wisitoken_grammar.re2c"
+ {*id = 5; continue;}
+#line 3124 "../wisitoken_grammar_re2c.c"
+yy110:
+ YYDEBUG(110, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'y': goto yy124;
+ default: goto yy45;
+ }
+yy111:
+ YYDEBUG(111, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'n': goto yy125;
+ default: goto yy45;
+ }
+yy112:
+ YYDEBUG(112, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'k': goto yy126;
+ default: goto yy45;
+ }
+yy113:
+ YYDEBUG(113, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(114, YYPEEK ());
+#line 231 "../wisitoken_grammar.re2c"
+ {*id = 14; continue;}
+#line 3161 "../wisitoken_grammar_re2c.c"
+yy115:
+ YYDEBUG(115, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy97;
+ default: goto yy71;
+ }
+yy116:
+ YYDEBUG(116, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy115;
+ default: goto yy71;
+ }
+yy117:
+ YYDEBUG(117, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy115;
+ default: goto yy71;
+ }
+yy118:
+ YYDEBUG(118, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy117;
+ default: goto yy71;
+ }
+yy119:
+ YYDEBUG(119, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy117;
+ default: goto yy71;
+ }
+yy120:
+ YYDEBUG(120, YYPEEK ());
+ YYSKIP ();
yych = YYPEEK ();
switch (yych) {
- case 'w': goto yy94;
- default: goto yy33;
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F: goto yy117;
+ default: goto yy71;
}
-yy90:
- YYDEBUG(90, YYPEEK ());
+yy121:
+ YYDEBUG(121, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case '_': goto yy95;
- default: goto yy33;
+ case 'e': goto yy127;
+ default: goto yy45;
}
-yy91:
- YYDEBUG(91, YYPEEK ());
+yy122:
+ YYDEBUG(122, YYPEEK ());
+ yyaccept = 7;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'e': goto yy96;
- default: goto yy33;
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '_':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z':
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF:
+ case 0xE0:
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF:
+ case 0xF0:
+ case 0xF1:
+ case 0xF2:
+ case 0xF3:
+ case 0xF4: goto yy45;
+ default: goto yy123;
}
-yy92:
- YYDEBUG(92, YYPEEK ());
+yy123:
+ YYDEBUG(123, YYPEEK ());
+#line 221 "../wisitoken_grammar.re2c"
+ {*id = 4; continue;}
+#line 3630 "../wisitoken_grammar_re2c.c"
+yy124:
+ YYDEBUG(124, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'w': goto yy129;
+ default: goto yy45;
+ }
+yy125:
+ YYDEBUG(125, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '_': goto yy130;
+ default: goto yy45;
+ }
+yy126:
+ YYDEBUG(126, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'e': goto yy131;
+ default: goto yy45;
+ }
+yy127:
+ YYDEBUG(127, YYPEEK ());
+ yyaccept = 8;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
case '-':
@@ -2688,57 +3727,120 @@ yy92:
case 'w':
case 'x':
case 'y':
- case 'z': goto yy32;
- default: goto yy93;
+ case 'z':
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF:
+ case 0xE0:
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF:
+ case 0xF0:
+ case 0xF1:
+ case 0xF2:
+ case 0xF3:
+ case 0xF4: goto yy45;
+ default: goto yy128;
}
-yy93:
- YYDEBUG(93, YYPEEK ());
-#line 209 "../wisitoken_grammar.re2c"
+yy128:
+ YYDEBUG(128, YYPEEK ());
+#line 220 "../wisitoken_grammar.re2c"
{*id = 3; continue;}
-#line 2699 "../wisitoken_grammar_re2c.c"
-yy94:
- YYDEBUG(94, YYPEEK ());
+#line 3789 "../wisitoken_grammar_re2c.c"
+yy129:
+ YYDEBUG(129, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'o': goto yy97;
- default: goto yy33;
+ case 'o': goto yy132;
+ default: goto yy45;
}
-yy95:
- YYDEBUG(95, YYPEEK ());
+yy130:
+ YYDEBUG(130, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'g': goto yy98;
- default: goto yy33;
+ case 'g': goto yy133;
+ default: goto yy45;
}
-yy96:
- YYDEBUG(96, YYPEEK ());
+yy131:
+ YYDEBUG(131, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'n': goto yy99;
- default: goto yy33;
+ case 'n': goto yy134;
+ default: goto yy45;
}
-yy97:
- YYDEBUG(97, YYPEEK ());
+yy132:
+ YYDEBUG(132, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'r': goto yy101;
- default: goto yy33;
+ case 'r': goto yy136;
+ default: goto yy45;
}
-yy98:
- YYDEBUG(98, YYPEEK ());
+yy133:
+ YYDEBUG(133, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'r': goto yy102;
- default: goto yy33;
+ case 'r': goto yy137;
+ default: goto yy45;
}
-yy99:
- YYDEBUG(99, YYPEEK ());
+yy134:
+ YYDEBUG(134, YYPEEK ());
+ yyaccept = 9;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
case '-':
@@ -2804,33 +3906,90 @@ yy99:
case 'w':
case 'x':
case 'y':
- case 'z': goto yy32;
- default: goto yy100;
+ case 'z':
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF:
+ case 0xE0:
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF:
+ case 0xF0:
+ case 0xF1:
+ case 0xF2:
+ case 0xF3:
+ case 0xF4: goto yy45;
+ default: goto yy135;
}
-yy100:
- YYDEBUG(100, YYPEEK ());
-#line 214 "../wisitoken_grammar.re2c"
+yy135:
+ YYDEBUG(135, YYPEEK ());
+#line 225 "../wisitoken_grammar.re2c"
{*id = 8; continue;}
-#line 2815 "../wisitoken_grammar_re2c.c"
-yy101:
- YYDEBUG(101, YYPEEK ());
+#line 3968 "../wisitoken_grammar_re2c.c"
+yy136:
+ YYDEBUG(136, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'd': goto yy103;
- default: goto yy33;
+ case 'd': goto yy138;
+ default: goto yy45;
}
-yy102:
- YYDEBUG(102, YYPEEK ());
+yy137:
+ YYDEBUG(137, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'a': goto yy105;
- default: goto yy33;
+ case 'a': goto yy140;
+ default: goto yy45;
}
-yy103:
- YYDEBUG(103, YYPEEK ());
+yy138:
+ YYDEBUG(138, YYPEEK ());
+ yyaccept = 10;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
case '-':
@@ -2896,49 +4055,110 @@ yy103:
case 'w':
case 'x':
case 'y':
- case 'z': goto yy32;
- default: goto yy104;
+ case 'z':
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF:
+ case 0xE0:
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF:
+ case 0xF0:
+ case 0xF1:
+ case 0xF2:
+ case 0xF3:
+ case 0xF4: goto yy45;
+ default: goto yy139;
}
-yy104:
- YYDEBUG(104, YYPEEK ());
-#line 212 "../wisitoken_grammar.re2c"
+yy139:
+ YYDEBUG(139, YYPEEK ());
+#line 223 "../wisitoken_grammar.re2c"
{*id = 6; continue;}
-#line 2907 "../wisitoken_grammar_re2c.c"
-yy105:
- YYDEBUG(105, YYPEEK ());
+#line 4117 "../wisitoken_grammar_re2c.c"
+yy140:
+ YYDEBUG(140, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'm': goto yy106;
- default: goto yy33;
+ case 'm': goto yy141;
+ default: goto yy45;
}
-yy106:
- YYDEBUG(106, YYPEEK ());
+yy141:
+ YYDEBUG(141, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'm': goto yy107;
- default: goto yy33;
+ case 'm': goto yy142;
+ default: goto yy45;
}
-yy107:
- YYDEBUG(107, YYPEEK ());
+yy142:
+ YYDEBUG(142, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'a': goto yy108;
- default: goto yy33;
+ case 'a': goto yy143;
+ default: goto yy45;
}
-yy108:
- YYDEBUG(108, YYPEEK ());
+yy143:
+ YYDEBUG(143, YYPEEK ());
+ yyaccept = 2;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
- case 'r': goto yy109;
- default: goto yy33;
+ case 'r': goto yy144;
+ default: goto yy45;
}
-yy109:
- YYDEBUG(109, YYPEEK ());
+yy144:
+ YYDEBUG(144, YYPEEK ());
+ yyaccept = 11;
YYSKIP ();
+ YYBACKUP ();
yych = YYPEEK ();
switch (yych) {
case '-':
@@ -3004,16 +4224,67 @@ yy109:
case 'w':
case 'x':
case 'y':
- case 'z': goto yy32;
- default: goto yy110;
+ case 'z':
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF:
+ case 0xE0:
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF:
+ case 0xF0:
+ case 0xF1:
+ case 0xF2:
+ case 0xF3:
+ case 0xF4: goto yy45;
+ default: goto yy145;
}
-yy110:
- YYDEBUG(110, YYPEEK ());
-#line 213 "../wisitoken_grammar.re2c"
+yy145:
+ YYDEBUG(145, YYPEEK ());
+#line 224 "../wisitoken_grammar.re2c"
{*id = 7; continue;}
-#line 3015 "../wisitoken_grammar_re2c.c"
+#line 4286 "../wisitoken_grammar_re2c.c"
}
-#line 234 "../wisitoken_grammar.re2c"
+#line 256 "../wisitoken_grammar.re2c"
}
*byte_position = lexer->byte_token_start - lexer->buffer + 1;
diff --git a/wisitoken_grammar_re2c_c.ads b/wisitoken_grammar_re2c_c.ads
index 0f96b59..d494b3f 100644
--- a/wisitoken_grammar_re2c_c.ads
+++ b/wisitoken_grammar_re2c_c.ads
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
--
diff --git a/wisitoken_grammar_runtime.adb b/wisitoken_grammar_runtime.adb
index 3795b1a..4841ada 100644
--- a/wisitoken_grammar_runtime.adb
+++ b/wisitoken_grammar_runtime.adb
@@ -17,14 +17,61 @@
pragma License (Modified_GPL);
+with Ada.Characters.Handling;
+with Ada.Exceptions;
with Ada.Strings.Unbounded;
-with SAL;
+with Ada.Text_IO;
+with GNAT.Regexp;
+with SAL.Generic_Decimal_Image;
+with System.Assertions;
with WisiToken.Generate; use WisiToken.Generate;
with Wisitoken_Grammar_Actions; use Wisitoken_Grammar_Actions;
package body WisiToken_Grammar_Runtime is
use WisiToken;
+ ----------
+ -- Body subprograms, misc order
+
+ procedure Raise_Programmer_Error
+ (Label : in String;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Node : in WisiToken.Syntax_Trees.Node_Index);
+ pragma No_Return (Raise_Programmer_Error);
+
+ procedure Raise_Programmer_Error
+ (Label : in String;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Node : in WisiToken.Syntax_Trees.Node_Index)
+ is begin
+ raise SAL.Programmer_Error with Label &
WisiToken.Syntax_Trees.Node_Index'Image (Node) &
+ ":" & Tree.Image (Node, Wisitoken_Grammar_Actions.Descriptor,
Include_Children => True);
+ end Raise_Programmer_Error;
+
+ function Get_Line
+ (Data : in User_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Node : in WisiToken.Syntax_Trees.Valid_Node_Index)
+ return WisiToken.Line_Number_Type
+ is
+ -- Find a source line for Node.
+
+ use WisiToken.Syntax_Trees;
+
+ Temp : Node_Index := Node;
+ begin
+ loop
+ if Tree.Min_Terminal_Index (Temp) = Invalid_Token_Index then
+ -- Node is empty or all virtual_identifiers; try parents.
+ Temp := Tree.Parent (Temp);
+ exit when Temp = Invalid_Node_Index;
+ else
+ return Data.Terminals.all (Tree.Min_Terminal_Index (Temp)).Line;
+ end if;
+ end loop;
+ return Invalid_Line_Number;
+ end Get_Line;
+
function Get_Text
(Data : in User_Data_Type;
Tree : in Syntax_Trees.Tree;
@@ -42,7 +89,7 @@ package body WisiToken_Grammar_Runtime is
-- Strip delimiters. We don't strip leading/trailing spaces to
preserve indent.
return Data.Grammar_Lexer.Buffer_Text ((Region.First + 2,
Region.Last - 2));
- elsif -Tree.ID (Tree_Index) in STRING_LITERAL_ID |
STRING_LITERAL_CASE_INS_ID and Strip_Quotes then
+ elsif -Tree.ID (Tree_Index) in STRING_LITERAL_1_ID |
STRING_LITERAL_2_ID and Strip_Quotes then
return Data.Grammar_Lexer.Buffer_Text ((Region.First + 1,
Region.Last - 1));
else
return Data.Grammar_Lexer.Buffer_Text (Region);
@@ -55,7 +102,20 @@ package body WisiToken_Grammar_Runtime is
return Strip_Delimiters (Tree_Index);
when Virtual_Terminal =>
- raise SAL.Programmer_Error;
+ -- Terminal keyword inserted during tree edit. We could check for
+ -- Identifier, but that will be caught later.
+ return Image (Tree.ID (Tree_Index),
Wisitoken_Grammar_Actions.Descriptor);
+
+ when Virtual_Identifier =>
+ if Strip_Quotes then
+ declare
+ Quoted : constant String := -Data.Tokens.Virtual_Identifiers
(Tree.Identifier (Tree_Index));
+ begin
+ return Quoted (Quoted'First + 1 .. Quoted'Last - 1);
+ end;
+ else
+ return -Data.Tokens.Virtual_Identifiers (Tree.Identifier
(Tree_Index));
+ end if;
when Nonterm =>
declare
@@ -65,7 +125,8 @@ package body WisiToken_Grammar_Runtime is
Need_Space : Boolean :=
False;
begin
for Tree_Index of Tree_Indices loop
- Result := Result & (if Need_Space then " " else "") &
Strip_Delimiters (Tree_Index);
+ Result := Result & (if Need_Space then " " else "") &
+ Get_Text (Data, Tree, Tree_Index, Strip_Quotes);
Need_Space := True;
end loop;
return -Result;
@@ -113,32 +174,52 @@ package body WisiToken_Grammar_Runtime is
end Start_If_1;
function Get_RHS
- (Data : in out User_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Token : in Syntax_Trees.Valid_Node_Index)
+ (Data : in out User_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Labels : in out WisiToken.BNF.String_Arrays.Vector;
+ Token : in Syntax_Trees.Valid_Node_Index)
return WisiToken.BNF.RHS_Type
is
+ use all type WisiToken.Syntax_Trees.Node_Index;
use all type SAL.Base_Peek_Type;
- Tokens : constant Syntax_Trees.Valid_Node_Index_Array := Tree.Children
(Token);
+ Children : constant Syntax_Trees.Valid_Node_Index_Array := Tree.Children
(Token);
begin
pragma Assert (-Tree.ID (Token) = rhs_ID);
return RHS : WisiToken.BNF.RHS_Type do
- if Tokens'Length = 0 then
- -- Token is an empty rhs; parent is a possibly empty rhs_list;
grandparent is
- -- a non-empty rhs_list or nonterminal.
- RHS.Source_Line := Data.Terminals.all (Tree.Min_Terminal_Index
(Tree.Parent (Tree.Parent (Token)))).Line;
+ RHS.Source_Line := Get_Line (Data, Tree, Token);
+
+ if Children'Length > 0 then
+ for I of Tree.Get_IDs (Children (1), +rhs_element_ID) loop
+ case Tree.RHS_Index (I) is
+ when 0 =>
+ -- rhs_item
+ RHS.Tokens.Append
+ ((Label => +"",
+ Identifier => +Get_Text (Data, Tree, Tree.Child (I,
1))));
+
+ when 1 =>
+ -- IDENTIFIER = rhs_item
+ declare
+ Label : constant String := Get_Text (Data, Tree,
Tree.Child (I, 1));
+ begin
+ RHS.Tokens.Append
+ ((Label => +Label,
+ Identifier => +Get_Text (Data, Tree, Tree.Child (I,
3))));
- else
- RHS.Source_Line := Data.Terminals.all (Tree.Min_Terminal_Index
(Token)).Line;
+ if (for all L of Labels => -L /= Label) then
+ Labels.Append (+Label);
+ end if;
+ end;
- for I of Tree.Get_Terminals (Tokens (1)) loop
- RHS.Tokens.Append (Get_Text (Data, Tree, I));
+ when others =>
+ Raise_Programmer_Error ("Get_RHS; unimplimented token",
Tree, I);
+ end case;
end loop;
- if Tokens'Last >= 2 then
+ if Children'Last >= 2 then
declare
- Text : constant String := Get_Text (Data, Tree, Tokens (2));
+ Text : constant String := Get_Text (Data, Tree, Children
(2));
begin
if Text'Length > 0 and (for some C of Text => C /= ' ') then
RHS.Action := +Text;
@@ -147,53 +228,62 @@ package body WisiToken_Grammar_Runtime is
end;
end if;
- if Tokens'Last >= 3 then
- RHS.Check := +Get_Text (Data, Tree, Tokens (3));
+ if Children'Last >= 3 then
+ RHS.Check := +Get_Text (Data, Tree, Children (3));
Data.Check_Count := Data.Check_Count + 1;
end if;
end if;
end return;
+ exception
+ when SAL.Programmer_Error =>
+ raise;
+ when E : others =>
+ declare
+ use Ada.Exceptions;
+ begin
+ Raise_Programmer_Error ("Get_RHS: " & Exception_Name (E) & ": " &
Exception_Message (E), Tree, Token);
+ end;
end Get_RHS;
procedure Get_Right_Hand_Sides
(Data : in out User_Data_Type;
Tree : in WisiToken.Syntax_Trees.Tree;
Right_Hand_Sides : in out WisiToken.BNF.RHS_Lists.List;
+ Labels : in out WisiToken.BNF.String_Arrays.Vector;
Token : in WisiToken.Syntax_Trees.Valid_Node_Index)
is
- use all type SAL.Base_Peek_Type;
-
Tokens : constant Syntax_Trees.Valid_Node_Index_Array := Tree.Children
(Token);
begin
pragma Assert (-Tree.ID (Token) = rhs_list_ID);
- if Tokens'Last = 1 then
+ case Tree.RHS_Index (Token) is
+ when 0 =>
-- | rhs
if not Data.Ignore_Lines then
- Right_Hand_Sides.Append (Get_RHS (Data, Tree, Tokens (1)));
+ Right_Hand_Sides.Append (Get_RHS (Data, Tree, Labels, Tokens (1)));
end if;
- else
+
+ when 1 =>
-- | rhs_list BAR rhs
- -- | rhs_list PERCENT IF IDENTIFIER EQUAL IDENTIFIER
- -- | rhs_list PERCENT END IF
- Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Tokens (1));
+ Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Labels, Tokens
(1));
- case Token_Enum_ID'(-Tree.ID (Tokens (3))) is
- when rhs_ID =>
- if not Data.Ignore_Lines then
- Right_Hand_Sides.Append (Get_RHS (Data, Tree, Tokens (3)));
- end if;
+ if not Data.Ignore_Lines then
+ Right_Hand_Sides.Append (Get_RHS (Data, Tree, Labels, Tokens (3)));
+ end if;
- when IF_ID =>
- Start_If_1 (Data, Tree, Tokens (4), Tokens (6));
+ when 2 =>
+ -- | rhs_list PERCENT IF IDENTIFIER EQUAL IDENTIFIER
+ Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Labels, Tokens
(1));
+ Start_If_1 (Data, Tree, Tokens (4), Tokens (6));
- when END_ID =>
- Data.Ignore_Lines := False;
+ when 3 =>
+ -- | rhs_list PERCENT END IF
+ Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Labels, Tokens
(1));
+ Data.Ignore_Lines := False;
- when others =>
- raise SAL.Programmer_Error;
- end case;
- end if;
+ when others =>
+ Raise_Programmer_Error ("Get_Right_Hand_Sides", Tree, Token);
+ end case;
end Get_Right_Hand_Sides;
----------
@@ -211,30 +301,74 @@ package body WisiToken_Grammar_Runtime is
overriding procedure Reset (Data : in out User_Data_Type)
is begin
+ -- Preserve data set in Phase Meta, or by Set_Lexer_Terminals, or by
+ -- wisitoken-bnf-generate.
+
-- Preserve Grammar_Lexer
-- Preserve User_Lexer
-- Preserve User_Parser
-- Perserve Generate_Set
+ -- Preserve Meta_Syntax
+ -- Preserve Phase
-- Preserve Terminals
+ -- Preserve Non_Grammar
+ -- EBNF_Nodes handled in Initialize_Actions
Data.Raw_Code := (others => <>);
- Data.Language_Params := (others => <>);
- WisiToken.BNF.Free (Data.Generate_Set);
- Data.Tokens := (others => <>);
+ Data.Language_Params :=
+ (Case_Insensitive => Data.Language_Params.Case_Insensitive,
+ others => <>);
+ Data.Tokens :=
+ (Virtual_Identifiers => Data.Tokens.Virtual_Identifiers,
+ others => <>);
Data.Conflicts.Clear;
Data.McKenzie_Recover := (others => <>);
Data.Rule_Count := 0;
Data.Action_Count := 0;
Data.Check_Count := 0;
+ Data.Label_Count := 0;
Data.If_Lexer_Present := False;
Data.If_Parser_Present := False;
Data.Ignore_Lines := False;
end Reset;
+ overriding procedure Initialize_Actions
+ (Data : in out User_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree'Class)
+ is begin
+ Data.EBNF_Nodes.Clear;
+ Data.EBNF_Nodes.Set_First_Last (Tree.First_Index, Tree.Last_Index);
+ end Initialize_Actions;
+
+ overriding
+ procedure Lexer_To_Augmented
+ (Data : in out User_Data_Type;
+ Token : in WisiToken.Base_Token;
+ Lexer : not null access WisiToken.Lexer.Instance'Class)
+ is
+ pragma Unreferenced (Lexer);
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Token.ID < Wisitoken_Grammar_Actions.Descriptor.First_Terminal then
+ -- Non-grammar token
+ if Data.Non_Grammar.Length = 0 then
+ Data.Non_Grammar.Set_First_Last (0, 0);
+ end if;
+
+ if Data.Terminals.Length = 0 then
+ Data.Non_Grammar (0).Append (Token);
+ else
+ Data.Non_Grammar.Set_Last (Data.Terminals.Last_Index);
+ Data.Non_Grammar (Data.Terminals.Last_Index).Append (Token);
+ end if;
+ end if;
+ end Lexer_To_Augmented;
+
procedure Start_If
(User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
Tree : in WisiToken.Syntax_Trees.Tree;
Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
is begin
+ -- all phases
Start_If_1 (User_Data_Type (User_Data), Tree, Tokens (3), Tokens (5));
end Start_If;
@@ -242,6 +376,7 @@ package body WisiToken_Grammar_Runtime is
is
Data : User_Data_Type renames User_Data_Type (User_Data);
begin
+ -- all phases
Data.Ignore_Lines := False;
end End_If;
@@ -250,28 +385,105 @@ package body WisiToken_Grammar_Runtime is
Tree : in WisiToken.Syntax_Trees.Tree;
Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
is
+ use all type WisiToken.Syntax_Trees.Node_Label;
use all type Ada.Strings.Unbounded.Unbounded_String;
Data : User_Data_Type renames User_Data_Type (User_Data);
function Token (Index : in SAL.Peek_Type) return Base_Token
is
- use all type WisiToken.Syntax_Trees.Node_Label;
use all type SAL.Base_Peek_Type;
begin
if Tokens'Last < Index then
raise SAL.Programmer_Error;
elsif Tree.Label (Tokens (Index)) /=
WisiToken.Syntax_Trees.Shared_Terminal then
- raise SAL.Programmer_Error;
+ raise SAL.Programmer_Error with "token at " & Image
(Tree.Byte_Region (Tokens (Index))) &
+ " is a " & WisiToken.Syntax_Trees.Node_Label'Image (Tree.Label
(Tokens (Index))) &
+ ", expecting Shared_Terminal";
else
return Data.Terminals.all (Tree.Terminal (Tokens (Index)));
end if;
end Token;
function Enum_ID (Index : in SAL.Peek_Type) return Token_Enum_ID
- is (Token_Enum_ID'(-Token (Index).ID));
+ is (To_Token_Enum (Token (Index).ID));
begin
+ if Data.Phase = Meta then
+ if Tree.Label (Tokens (2)) = WisiToken.Syntax_Trees.Shared_Terminal
then
+ case Enum_ID (2) is
+ when IDENTIFIER_ID =>
+ declare
+ Kind : constant String := Data.Grammar_Lexer.Buffer_Text
(Token (2).Byte_Region);
+ begin
+ if Kind = "case_insensitive" then
+ Data.Language_Params.Case_Insensitive := True;
+
+ elsif Kind = "generate" then
+ declare
+ use all type SAL.Base_Peek_Type;
+ Children : constant
Syntax_Trees.Valid_Node_Index_Array := Tree.Get_Terminals (Tokens (3));
+ Tuple : WisiToken.BNF.Generate_Tuple;
+ begin
+ Tuple.Gen_Alg := WisiToken.BNF.To_Generate_Algorithm
(Get_Text (Data, Tree, Children (1)));
+ if Children'Last >= 2 then
+ Tuple.Out_Lang := WisiToken.BNF.To_Output_Language
(Get_Text (Data, Tree, Children (2)));
+ end if;
+ for I in 3 .. SAL.Base_Peek_Type (Children'Length) loop
+ declare
+ Text : constant String := Get_Text (Data, Tree,
Children (I));
+ begin
+ if Text = "text_rep" then
+ Tuple.Text_Rep := True;
+
+ elsif (for some I of WisiToken.BNF.Lexer_Image
=> Text = I.all) then
+ Tuple.Lexer := WisiToken.BNF.To_Lexer (Text);
+
+ elsif (for some I in
WisiToken.BNF.Valid_Interface =>
+ WisiToken.BNF.To_Lower (Text) =
WisiToken.BNF.To_Lower
+ (WisiToken.BNF.Valid_Interface'Image
(I)))
+ then
+ Tuple.Interface_Kind :=
WisiToken.BNF.Valid_Interface'Value (Text);
+ else
+ declare
+ Token : Base_Token renames
Data.Terminals.all (Tree.Terminal (Children (I)));
+ begin
+ raise Grammar_Error with Error_Message
+ (Data.Grammar_Lexer.File_Name,
Token.Line, Token.Column,
+ "invalid generate param '" & Text &
"'");
+ end;
+ end if;
+ end;
+ end loop;
+ WisiToken.BNF.Add (Data.Generate_Set, Tuple);
+ end;
+
+ elsif Kind = "meta_syntax" then
+ if Data.Meta_Syntax = Unknown then
+ -- Don't overwrite; somebody set it for a reason.
+ declare
+ Value_Str : constant String :=
WisiToken.BNF.To_Lower (Get_Text (Data, Tree, Tokens (3)));
+ begin
+ if Value_Str = "bnf" then
+ Data.Meta_Syntax := BNF_Syntax;
+ elsif Value_Str = "ebnf" then
+ Data.Meta_Syntax := EBNF_Syntax;
+ Data.EBNF_Nodes (Tree.Find_Ancestor (Tokens (2),
+declaration_ID)) := True;
+
+ else
+ Put_Error ("invalid value for %meta_syntax; must
be BNF | EBNF.");
+ end if;
+ end;
+ end if;
+ end if;
+ end;
+ when others =>
+ null;
+ end case;
+ end if;
+ return;
+ end if;
+
-- Add declaration to User_Data.Generate_Set, Language_Params,
-- Tokens, Conflicts, or McKenzie_Recover.
@@ -283,10 +495,10 @@ package body WisiToken_Grammar_Runtime is
when Syntax_Trees.Nonterm =>
-- must be token_keyword_non_grammar
declare
- Children : Syntax_Trees.Valid_Node_Index_Array renames
Tree.Children (Tokens (2));
- Child_1 : Base_Token renames Data.Terminals.all (Tree.Terminal
(Children (1)));
+ Children : Syntax_Trees.Valid_Node_Index_Array renames
Tree.Children (Tokens (2));
+ Child_1_ID : constant Token_Enum_ID := To_Token_Enum (Tree.ID
(Children (1)));
begin
- case Token_Enum_ID'(-Child_1.ID) is
+ case Child_1_ID is
when Wisitoken_Grammar_Actions.TOKEN_ID =>
WisiToken.BNF.Add_Token
@@ -412,8 +624,11 @@ package body WisiToken_Grammar_Runtime is
declare
Kind : constant String := Data.Grammar_Lexer.Buffer_Text (Token
(2).Byte_Region);
begin
+ -- Alphabetical by Kind
+
if Kind = "case_insensitive" then
- Data.Language_Params.Case_Insensitive := True;
+ -- Not in phase Other
+ null;
elsif Kind = "conflict" then
declare
@@ -443,47 +658,23 @@ package body WisiToken_Grammar_Runtime is
((Name => +Get_Child_Text (Data, Tree, Tokens (3), 1,
Strip_Quotes => True),
Value => +Get_Child_Text (Data, Tree, Tokens (3), 2)));
- elsif Kind = "embedded_quote_escape_doubled" then
- Data.Language_Params.Embedded_Quote_Escape_Doubled := True;
+ elsif Kind = "elisp_action" then
+ Data.Tokens.Actions.Insert
+ (Key => +Get_Child_Text (Data, Tree, Tokens
(3), 2),
+ New_Item =>
+ (Action_Label => +Get_Child_Text (Data, Tree, Tokens
(3), 1),
+ Ada_Name => +Get_Child_Text (Data, Tree, Tokens
(3), 3)));
elsif Kind = "end_names_optional_option" then
Data.Language_Params.End_Names_Optional_Option := +Get_Text
(Data, Tree, Tokens (3));
elsif Kind = "generate" then
- declare
- Children : constant Syntax_Trees.Valid_Node_Index_Array
:= Tree.Get_Terminals (Tokens (3));
- Tuple : WisiToken.BNF.Generate_Tuple;
- begin
- Tuple.Gen_Alg := WisiToken.BNF.Generate_Algorithm'Value
(Get_Text (Data, Tree, Children (1)));
- Tuple.Out_Lang := WisiToken.BNF.To_Output_Language
(Get_Text (Data, Tree, Children (2)));
- for I in 3 .. SAL.Base_Peek_Type (Children'Length) loop
- declare
- Text : constant String := Get_Text (Data, Tree,
Children (I));
- begin
- if Text = "text_rep" then
- Tuple.Text_Rep := True;
-
- elsif (for some I of WisiToken.BNF.Lexer_Image =>
Text = I.all) then
- Tuple.Lexer := WisiToken.BNF.To_Lexer (Text);
+ -- Not in Other phase
+ null;
- elsif (for some I in WisiToken.BNF.Valid_Interface
=>
- WisiToken.BNF.To_Lower (Text) =
WisiToken.BNF.To_Lower
- (WisiToken.BNF.Valid_Interface'Image
(I)))
- then
- Tuple.Interface_Kind :=
WisiToken.BNF.Valid_Interface'Value (Text);
- else
- declare
- Token : Base_Token renames Data.Terminals.all
(Tree.Terminal (Children (I)));
- begin
- raise Grammar_Error with Error_Message
- (Data.Grammar_Lexer.File_Name, Token.Line,
Token.Column,
- "invalid generate param '" & Text & "'");
- end;
- end if;
- end;
- end loop;
- WisiToken.BNF.Add (Data.Generate_Set, Tuple);
- end;
+ elsif Kind = "language_runtime" then
+ Data.Language_Params.Language_Runtime_Name :=
+ +Get_Text (Data, Tree, Tokens (3), Strip_Quotes => True);
elsif Kind = "mckenzie_check_limit" then
Data.Language_Params.Error_Recover := True;
@@ -520,15 +711,21 @@ package body WisiToken_Grammar_Runtime is
((+Get_Child_Text (Data, Tree, Tokens (3), 1),
+Get_Child_Text (Data, Tree, Tokens (3), 2)));
+ elsif Kind = "mckenzie_cost_fast_forward" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Fast_Forward :=
+ Integer'Value (Get_Text (Data, Tree, Tokens (3)));
+
elsif Kind = "mckenzie_cost_insert" then
Data.Language_Params.Error_Recover := True;
Data.McKenzie_Recover.Insert.Append
((+Get_Child_Text (Data, Tree, Tokens (3), 1),
+Get_Child_Text (Data, Tree, Tokens (3), 2)));
- elsif Kind = "mckenzie_cost_limit" then
+ elsif Kind = "mckenzie_cost_matching_begin" then
Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Cost_Limit := Natural'Value (Get_Text
(Data, Tree, Tokens (3)));
+ Data.McKenzie_Recover.Matching_Begin :=
+ Integer'Value (Get_Text (Data, Tree, Tokens (3)));
elsif Kind = "mckenzie_cost_push_back" then
Data.Language_Params.Error_Recover := True;
@@ -536,16 +733,34 @@ package body WisiToken_Grammar_Runtime is
((+Get_Child_Text (Data, Tree, Tokens (3), 1),
+Get_Child_Text (Data, Tree, Tokens (3), 2)));
+ elsif Kind = "mckenzie_cost_undo_reduce" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Undo_Reduce.Append
+ ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
+ +Get_Child_Text (Data, Tree, Tokens (3), 2)));
+
elsif Kind = "mckenzie_enqueue_limit" then
Data.Language_Params.Error_Recover := True;
Data.McKenzie_Recover.Enqueue_Limit := Natural'Value
(Get_Text (Data, Tree, Tokens (3)));
- elsif Kind = "no_language_runtime" then
- Data.Language_Params.Language_Runtime := False;
+ elsif Kind = "mckenzie_minimal_complete_cost_delta" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Minimal_Complete_Cost_Delta :=
+ Integer'Value (Get_Text (Data, Tree, Tokens (3)));
+
+ elsif Kind = "meta_syntax" then
+ -- not in Other phase
+ null;
elsif Kind = "no_enum" then
Data.Language_Params.Declare_Enums := False;
+ elsif Kind = "no_language_runtime" then
+ Data.Language_Params.Use_Language_Runtime := False;
+
+ elsif Kind = "partial_recursion" then
+ Data.Language_Params.Partial_Recursion := True;
+
elsif Kind = "start" then
Data.Language_Params.Start_Token := +Get_Text (Data, Tree,
Tokens (3));
@@ -566,7 +781,7 @@ package body WisiToken_Grammar_Runtime is
(Data.Grammar_Lexer.File_Name, Token (2).Line, Token (2).Column,
"unexpected syntax");
end case;
- when Syntax_Trees.Virtual_Terminal =>
+ when Syntax_Trees.Virtual_Terminal | Syntax_Trees.Virtual_Identifier =>
raise SAL.Programmer_Error;
end case;
end Add_Declaration;
@@ -576,28 +791,2045 @@ package body WisiToken_Grammar_Runtime is
Tree : in WisiToken.Syntax_Trees.Tree;
Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
is
+ use all type Ada.Containers.Count_Type;
+ use WisiToken.Syntax_Trees;
+
Data : User_Data_Type renames User_Data_Type (User_Data);
- LHS : constant String := Get_Text (Data, Tree, Tokens (1));
+ LHS_Node : constant Valid_Node_Index := Tokens (1);
+ LHS_String : constant String := Get_Text (Data, Tree,
LHS_Node);
Right_Hand_Sides : WisiToken.BNF.RHS_Lists.List;
+ Labels : WisiToken.BNF.String_Arrays.Vector;
begin
+ if Data.Phase = Meta or Data.Ignore_Lines then
+ return;
+ end if;
+
Data.Rule_Count := Data.Rule_Count + 1;
- Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Tokens (3));
+ Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Labels, Tokens (3));
- if WisiToken.BNF.Is_Present (Data.Tokens.Rules, LHS) then
- declare
- LHS_Token : Base_Token renames Data.Terminals.all (Tree.Terminal
(Tokens (1)));
- begin
+ if WisiToken.BNF.Is_Present (Data.Tokens.Rules, LHS_String) then
+ case Tree.Label (LHS_Node) is
+ when Shared_Terminal =>
+ declare
+ LHS_Token : Base_Token renames Data.Terminals.all
(Tree.Terminal (LHS_Node));
+ begin
+ raise Grammar_Error with Error_Message
+ (Data.Grammar_Lexer.File_Name, LHS_Token.Line,
LHS_Token.Column, "duplicate nonterm");
+ end;
+
+ when Virtual_Identifier =>
raise Grammar_Error with Error_Message
- (Data.Grammar_Lexer.File_Name, LHS_Token.Line, LHS_Token.Column,
"duplicate nonterm");
- end;
+ (Data.Grammar_Lexer.File_Name, 1, 1, "duplicate virtual nonterm
'" & LHS_String & "'");
+
+ when others =>
+ Raise_Programmer_Error ("Add_Nonterminal", Tree, LHS_Node);
+ end case;
else
+ Data.Label_Count := Data.Label_Count + Labels.Length;
+
Data.Tokens.Rules.Append
- ((+LHS, Right_Hand_Sides,
- Source_Line => Data.Terminals.all (Tree.Min_Terminal_Index
(Tokens (1))).Line));
+ ((+LHS_String, Right_Hand_Sides, Labels,
+ Source_Line =>
+ (case Tree.Label (LHS_Node) is
+ when Shared_Terminal => Data.Terminals.all
(Tree.Min_Terminal_Index (LHS_Node)).Line,
+ when Virtual_Identifier => Invalid_Line_Number, -- IMPROVEME:
get line from Right_Hand_Sides
+ when others => raise SAL.Programmer_Error)));
end if;
end Add_Nonterminal;
+ procedure Check_EBNF
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Token : in WisiToken.Positive_Index_Type)
+ is
+ Data : User_Data_Type renames User_Data_Type (User_Data);
+ begin
+ case Data.Phase is
+ when Meta =>
+ Data.EBNF_Nodes (Tokens (Token)) := True;
+
+ if Data.Meta_Syntax /= EBNF_Syntax then
+ declare
+ Tok : Base_Token renames Data.Terminals.all
(Tree.Min_Terminal_Index (Tokens (Token)));
+ begin
+ raise Grammar_Error with Error_Message
+ (Data.Grammar_Lexer.File_Name, Tok.Line, Tok.Column,
+ "EBNF syntax used, but BNF specified; set '%meta_syntax
EBNF'");
+ end;
+ end if;
+ when Other =>
+ Raise_Programmer_Error ("untranslated EBNF node", Tree, Tree.Parent
(Tokens (Token)));
+ end case;
+ end Check_EBNF;
+
+ procedure Translate_EBNF_To_BNF
+ (Tree : in out WisiToken.Syntax_Trees.Tree;
+ Data : in out User_Data_Type)
+ is
+ use WisiToken.Syntax_Trees;
+
+ Copied_EBNF_Nodes :
WisiToken.Syntax_Trees.Valid_Node_Index_Arrays.Vector;
+
+ Symbol_Regexp : constant GNAT.Regexp.Regexp := GNAT.Regexp.Compile
+ ((if Data.Language_Params.Case_Insensitive
+ then "[A-Z0-9_]+"
+ else "[a-zA-Z0-9_]+"),
+ Case_Sensitive => not Data.Language_Params.Case_Insensitive);
+
+ procedure Clear_EBNF_Node (Node : in Valid_Node_Index)
+ is begin
+ if Node in Data.EBNF_Nodes.First_Index .. Data.EBNF_Nodes.Last_Index
then
+ Data.EBNF_Nodes (Node) := False;
+ -- else in Copied_EBNF_Nodes; don't need to delete from there.
+ end if;
+ end Clear_EBNF_Node;
+
+ function New_Identifier (Text : in String) return Identifier_Index
+ is
+ ID : constant Identifier_Index := Base_Identifier_Index
(Data.Tokens.Virtual_Identifiers.Length) + 1;
+ begin
+ Data.Tokens.Virtual_Identifiers.Append (+Text);
+ return ID;
+ end New_Identifier;
+
+ Keyword_Ident : constant Identifier_Index := New_Identifier ("keyword");
+ Percent_Ident : constant Identifier_Index := New_Identifier ("percent");
+
+ function Next_Nonterm_Name (Suffix : in String := "") return
Identifier_Index
+ is
+ function Image is new SAL.Generic_Decimal_Image (Identifier_Index);
+ ID : constant Identifier_Index := Identifier_Index
(Data.Tokens.Virtual_Identifiers.Length) + 1;
+ begin
+
+ if ID > 999 then
+ -- We assume 3 digits below
+ raise SAL.Programmer_Error with "more than 3 digits needed for
virtual identifiers in EBNF translate";
+ end if;
+
+ Data.Tokens.Virtual_Identifiers.Append (+("nonterminal_" & Image (ID,
Width => 3) & Suffix));
+
+ return ID;
+ end Next_Nonterm_Name;
+
+ function Tree_Add_Nonterminal
+ (Child_1 : in Valid_Node_Index;
+ Child_2 : in Valid_Node_Index;
+ Child_3 : in Valid_Node_Index;
+ Child_4 : in Valid_Node_Index)
+ return Valid_Node_Index
+ is begin
+ -- Work around GNAT error about arbitrary evaluation order in
+ -- aggregates (no error about the arbitrary order in subprogram
+ -- parameter_assocation_lists!).
+ return Tree.Add_Nonterm
+ (Production => (+nonterminal_ID, 0),
+ Children => (Child_1, Child_2, Child_3, Child_4),
+ Action => Wisitoken_Grammar_Actions.nonterminal_0'Access);
+ end Tree_Add_Nonterminal;
+
+ function List_Root (Item : in Valid_Node_Index) return Valid_Node_Index
+ is
+ List_ID : constant WisiToken.Token_ID := Tree.ID (Item);
+ Node : Valid_Node_Index := Item;
+ begin
+ loop
+ exit when Tree.ID (Tree.Parent (Node)) /= List_ID;
+ Node := Tree.Parent (Node);
+ end loop;
+ return Node;
+ end List_Root;
+
+ function List_Singleton (Root : in Valid_Node_Index) return Boolean
+ is begin
+ return Tree.RHS_Index (Root) = 0;
+ end List_Singleton;
+
+ function First_List_Element (Root : in Valid_Node_Index; Element_ID : in
WisiToken.Token_ID) return Node_Index
+ is
+ List_ID : constant WisiToken.Token_ID := Tree.ID (Root);
+
+ -- Return the first child with Element_ID in list of List_IDs. This
+ -- is not the same as Find_Descendant, because we check the children
+ -- first, and only the first child.
+ Node : Node_Index := Root;
+ begin
+ loop
+ declare
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
+ begin
+ if Tree.ID (Children (1)) = List_ID then
+ Node := Children (1);
+ elsif Tree.ID (Children (1)) = Element_ID then
+ Node := Children (1);
+ exit;
+ else
+ Raise_Programmer_Error ("first_list_element", Tree, Node);
+ end if;
+ end;
+ end loop;
+ return Node;
+ end First_List_Element;
+
+ function Last_List_Element (Root : in Valid_Node_Index) return Node_Index
+ is
+ -- Tree is one of:
+ --
+ -- case a: single element list
+ -- element_list : root
+ -- | element: Last
+ --
+ -- case c: no next
+ -- element_list: root
+ -- | element_list
+ -- | | element:
+ -- | element: Last
+ Children : constant Valid_Node_Index_Array := Tree.Children (Root);
+ begin
+ return Children (Children'Last);
+ end Last_List_Element;
+
+ function Next_List_Element
+ (Element : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID)
+ return Node_Index
+ with Pre => Tree.Parent (Element, 2) /= Invalid_Node_Index and then
+ Tree.ID (Tree.Parent (Element)) = List_ID
+ is
+ use all type SAL.Base_Peek_Type;
+ -- Tree is one of:
+ --
+ -- case a: first element, no next
+ -- rhs
+ -- | rhs_item_list
+ -- | | rhs_item: Element
+ -- | action
+ --
+ -- case b: first element, next
+ -- rhs_item_list
+ -- | rhs_item_list
+ -- | | rhs_item: Element
+ -- | rhs_item: next element
+ --
+ -- case c: non-first element, no next
+ -- rhs
+ -- | rhs_item_list
+ -- | | rhs_item_list
+ -- | | | rhs_item:
+ -- | | rhs_item: Element
+ -- | action
+ --
+ -- case d: non-first element, next
+ -- rhs_item_list
+ -- | rhs_item_list
+ -- | | rhs_item_list
+ -- | | | rhs_item:
+ -- | | rhs_item: Element
+ -- | rhs_item: next element
+
+ Element_ID : constant WisiToken.Token_ID := Tree.ID
(Element);
+ Grand_Parent : constant Valid_Node_Index := Tree.Parent
(Element, 2);
+ Aunts : constant Valid_Node_Index_Array := Tree.Children
(Grand_Parent);
+ Last_List_Child : SAL.Base_Peek_Type := Aunts'First - 1;
+ begin
+ if Tree.ID (Grand_Parent) /= List_ID then
+ -- No next
+ return Invalid_Node_Index;
+ end if;
+
+ -- Children may be non-list items; ACTION in an rhs_list, for
example.
+ for I in Aunts'Range loop
+ if Tree.ID (Aunts (I)) in List_ID | Element_ID then
+ Last_List_Child := I;
+ end if;
+ end loop;
+
+ if Last_List_Child = 1 then
+ -- No next
+ return Invalid_Node_Index;
+ else
+ return Aunts (2);
+ end if;
+ end Next_List_Element;
+
+ function Prev_List_Element
+ (Element : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID)
+ return Node_Index
+ with Pre => Tree.Parent (Element) /= Invalid_Node_Index and then
+ Tree.ID (Tree.Parent (Element)) = List_ID
+ is
+ -- Tree is one of:
+ --
+ -- case a: first element, no prev
+ -- ?
+ -- | rhs_item_list
+ -- | | rhs_item: Element
+ --
+ -- case b: second element
+ -- ?
+ -- | rhs_item_list
+ -- | | rhs_item: prev item
+ -- | rhs_item: Element
+ --
+ -- case c: nth element
+ -- ?
+ -- | rhs_item_list
+ -- | | rhs_item_list
+ -- | | | rhs_item:
+ -- | | rhs_item: prev element
+ -- | rhs_item: Element
+
+ Parent : constant Valid_Node_Index := Tree.Parent (Element);
+ begin
+ if Element = Tree.Child (Parent, 1) then
+ -- No prev
+ return Invalid_Node_Index;
+
+ else
+ declare
+ Prev_Children : constant Valid_Node_Index_Array :=
Tree.Children (Tree.Child (Parent, 1));
+ begin
+ return Prev_Children (Prev_Children'Last);
+ end;
+ end if;
+ end Prev_List_Element;
+
+ procedure Append_Element
+ (Tail_List : in Valid_Node_Index;
+ New_Element : in Valid_Node_Index;
+ Separator_ID : in WisiToken.Token_ID := Invalid_Token_ID)
+ is
+ -- Tail_List is preserved.
+
+ -- Current tree is one of:
+ --
+ -- case a:
+ -- rhs_list: Tail_List
+ -- | rhs: Orig_Element_1
+ --
+ -- case b:
+ -- rhs_list: Tail_List
+ -- | rhs_list: Orig_List_1
+ -- | | rhs: Orig_Element_1
+ -- | BAR
+ -- | rhs: Orig_Element_2
+
+ -- New tree:
+ --
+ -- case a:
+ -- rhs_list: keep Tail_List
+ -- | rhs_list: new
+ -- | | rhs: keep; Orig_Element_1
+ -- | BAR
+ -- | rhs: New_Element
+ --
+ -- case b:
+ -- rhs_list: keep Tail_List
+ -- | rhs_list: new;
+ -- | | rhs_list: keep Orig_List_1
+ -- | | | rhs: keep Orig_Element_1
+ -- | | BAR: keep
+ -- | | rhs: keep Orig_Element_2
+ -- | BAR: new
+ -- | rhs: New_Element
+
+ List_ID : constant WisiToken.Token_ID := Tree.ID
(Tail_List);
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Tail_List);
+ New_List_Item : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((List_ID, (if Children'Length = 1 then 0 else 1)), Children);
+ begin
+ if Separator_ID = Invalid_Token_ID then
+ Tree.Set_Children (Tail_List, (List_ID, 1), (New_List_Item,
New_Element));
+ else
+ Tree.Set_Children
+ (Tail_List, (List_ID, 1), (New_List_Item, Tree.Add_Terminal
(Separator_ID), New_Element));
+ end if;
+ end Append_Element;
+
+ procedure Insert_Optional_RHS (B : in Valid_Node_Index)
+ is
+ -- B is an optional item in an rhs_item_list :
+ -- | a b? c
+ --
+ -- Insert a second rhs_item_list without B
+ --
+ -- The containing elment may be rhs or rhs_alternative_list
+
+ Container : constant Valid_Node_Index :=
Tree.Find_Ancestor
+ (B, (+rhs_ID, +rhs_alternative_list_ID));
+ Orig_RHS_Element_C_Head : constant Node_Index :=
Next_List_Element
+ (Tree.Parent (B, 2), +rhs_item_list_ID);
+ Orig_RHS_Item_List_C_Root : constant Valid_Node_Index := List_Root
(Tree.Parent (B, 3));
+ Orig_RHS_Item_List_A_Root : constant Valid_Node_Index := Tree.Child
(Tree.Parent (B, 3), 1);
+ Orig_RHS_Element_A_Head : constant Node_Index :=
+ (if Orig_RHS_Item_List_A_Root = Tree.Parent (B, 2)
+ then Invalid_Node_Index -- a is empty
+ else First_List_Element (Orig_RHS_Item_List_A_Root,
+rhs_element_ID));
+ Container_List : constant Valid_Node_Index :=
+ (if Tree.ID (Container) = +rhs_ID then Tree.Parent (Container) else
Container);
+ New_RHS_Item_List_A : Node_Index :=
Invalid_Node_Index;
+ New_RHS_Item_List_C : Node_Index :=
Invalid_Node_Index;
+ New_RHS_AC : Valid_Node_Index;
+
+ function Add_Actions (RHS_Item_List : Valid_Node_Index) return
Valid_Node_Index
+ with Pre => Tree.ID (Container) = +rhs_ID
+ is
+ Orig_RHS_Children : constant Valid_Node_Index_Array :=
Tree.Children (Container);
+ begin
+ case Tree.RHS_Index (Container) is
+ when 1 =>
+ return Tree.Add_Nonterm ((+rhs_ID, 1), (1 => RHS_Item_List));
+
+ when 2 =>
+ return Tree.Add_Nonterm
+ ((+rhs_ID, 2),
+ (1 => RHS_Item_List,
+ 2 => Tree.Add_Terminal
+ (Tree.Min_Terminal_Index (Orig_RHS_Children (2)),
+ Data.Terminals.all)));
+
+ when 3 =>
+ return Tree.Add_Nonterm
+ ((+rhs_ID, 3),
+ (1 => RHS_Item_List,
+ 2 => Tree.Add_Terminal
+ (Tree.Min_Terminal_Index (Orig_RHS_Children (2)),
+ Data.Terminals.all),
+ 3 => Tree.Add_Terminal
+ (Tree.Min_Terminal_Index (Orig_RHS_Children (3)),
+ Data.Terminals.all)));
+
+ when others =>
+ Raise_Programmer_Error
+ ("translate_ebnf_to_bnf insert_optional_rhs unimplemented
RHS", Tree, Container);
+ end case;
+ end Add_Actions;
+ begin
+ if Orig_RHS_Element_A_Head /= Invalid_Node_Index then
+ -- a is not empty
+ New_RHS_Item_List_A := Tree.Copy_Subtree
+ (Last => Orig_RHS_Element_A_Head,
+ Root => Orig_RHS_Item_List_A_Root);
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("new a:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
New_RHS_Item_List_A);
+ end if;
+ end if;
+
+ if Orig_RHS_Element_C_Head /= Invalid_Node_Index then
+ -- c is not empty
+ New_RHS_Item_List_C := Tree.Copy_Subtree
+ (Last => Orig_RHS_Element_C_Head,
+ Root => Orig_RHS_Item_List_C_Root);
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("new c:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
New_RHS_Item_List_C);
+ end if;
+ end if;
+
+ if New_RHS_Item_List_C = Invalid_Node_Index then
+ if New_RHS_Item_List_A = Invalid_Node_Index then
+ -- a c is empty; there cannot be any actions.
+ New_RHS_AC :=
+ (if Tree.ID (Container) = +rhs_ID
+ then Tree.Add_Nonterm ((+rhs_ID, 0), (1 .. 0 =>
Invalid_Node_Index))
+ else Tree.Add_Nonterm ((+rhs_item_list_ID, 0), (1 .. 0 =>
Invalid_Node_Index)));
+ else
+ -- c is empty
+ New_RHS_AC :=
+ (if Tree.ID (Container) = +rhs_ID
+ then Add_Actions (New_RHS_Item_List_A)
+ else New_RHS_Item_List_A);
+ end if;
+ else
+ -- c is not empty
+ if New_RHS_Item_List_A = Invalid_Node_Index then
+ -- a is empty
+ New_RHS_AC :=
+ (if Tree.ID (Container) = +rhs_ID
+ then Add_Actions (New_RHS_Item_List_C)
+ else New_RHS_Item_List_C);
+ else
+ declare
+ Tail_Element_A : constant Valid_Node_Index :=
Last_List_Element (New_RHS_Item_List_A);
+ Head_Element_B : constant Valid_Node_Index :=
First_List_Element
+ (New_RHS_Item_List_C, +rhs_element_ID);
+ begin
+ Tree.Set_Children
+ (Tree.Parent (Head_Element_B),
+ (+rhs_item_list_ID, 1),
+ (Tree.Parent (Tail_Element_A), Head_Element_B));
+ end;
+
+ New_RHS_AC :=
+ (if Tree.ID (Container) = +rhs_ID
+ then Add_Actions (New_RHS_Item_List_C)
+ else New_RHS_Item_List_C);
+ end if;
+ end if;
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("new ac:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor, New_RHS_AC);
+ end if;
+
+ -- Record copied EBNF nodes
+ declare
+ procedure Record_Copied_Node
+ (Tree : in out WisiToken.Syntax_Trees.Tree;
+ Node : in WisiToken.Syntax_Trees.Valid_Node_Index)
+ is begin
+ if To_Token_Enum (Tree.ID (Node)) in
+ rhs_optional_item_ID |
+ rhs_multiple_item_ID |
+ rhs_group_item_ID |
+ rhs_attribute_ID |
+ STRING_LITERAL_2_ID
+ then
+ Copied_EBNF_Nodes.Append (Node);
+ end if;
+ end Record_Copied_Node;
+ begin
+ Tree.Process_Tree (Record_Copied_Node'Access, New_RHS_AC);
+ end;
+
+ Append_Element (Container_List, New_RHS_AC, +BAR_ID);
+ end Insert_Optional_RHS;
+
+ Compilation_Unit_List_Tail : constant Valid_Node_Index := Tree.Child
(Tree.Root, 1);
+
+ procedure Add_Compilation_Unit (Unit : in Valid_Node_Index; Prepend : in
Boolean := False)
+ is
+ Comp_Unit : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+compilation_unit_ID, (if Tree.ID (Unit) = +declaration_ID then 0
else 1)),
+ (1 => Unit));
+ begin
+ if Prepend then
+ Append_Element
+ (Tree.Parent (First_List_Element (Compilation_Unit_List_Tail,
+compilation_unit_ID)), Comp_Unit);
+ else
+ Append_Element (Compilation_Unit_List_Tail, Comp_Unit);
+ end if;
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("new comp_unit:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor, Unit);
+ end if;
+ end Add_Compilation_Unit;
+
+ function To_RHS_List (RHS_Element : in Valid_Node_Index) return
Valid_Node_Index
+ with Pre => Tree.ID (RHS_Element) = +rhs_element_ID
+ is
+ RHS_Item_List : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_item_list_ID, 0), (1 => RHS_Element));
+ RHS : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_ID, 1), (1 => RHS_Item_List));
+ begin
+ return Tree.Add_Nonterm ((+rhs_list_ID, 0), (1 => RHS));
+ end To_RHS_List;
+
+ function Convert_RHS_Alternative (Content : in Valid_Node_Index) return
Valid_Node_Index
+ is
+ -- Convert rhs_alternative_list rooted at Content to an rhs_list
+ Node : Valid_Node_Index := Content;
+ begin
+ loop
+ exit when Tree.RHS_Index (Node) = 0;
+
+ -- current tree:
+ -- rhs_alternative_list : Node
+ -- | rhs_alternative_list: Node.Child (1)
+ -- | | ...
+ -- | BAR: Node.child (2)
+ -- | rhs_item_list: Node.Child (3)
+
+ -- new tree:
+ -- rhs_list: Node
+ -- | rhs_alternative_list: keep Node.Child (1)
+ -- | | ...
+ -- | BAR: keep
+ -- | rhs: new
+ -- | | rhs_item_list: keep Node,Child (3)
+
+ Tree.Set_Children
+ (Node,
+ (+rhs_list_ID, 1),
+ (1 => Tree.Child (Node, 1),
+ 2 => Tree.Child (Node, 2),
+ 3 => Tree.Add_Nonterm
+ ((+rhs_ID, 1),
+ (1 => Tree.Child (Node, 3)))));
+
+ Clear_EBNF_Node (Node);
+ Node := Tree.Child (Node, 1);
+ end loop;
+
+ -- current tree:
+ -- rhs_alternative_list : Node
+ -- | rhs_item_list: Node.Child (1)
+
+ -- new tree:
+ -- rhs_list: Node
+ -- | rhs: new
+ -- | | rhs_item_list: Node.Child (1)
+
+ Tree.Set_Children
+ (Node,
+ (+rhs_list_ID, 0),
+ (1 => Tree.Add_Nonterm ((+rhs_ID, 1), (1 => Tree.Child (Node,
1)))));
+
+ Clear_EBNF_Node (Content);
+ return Content;
+ end Convert_RHS_Alternative;
+
+ procedure New_Nonterminal
+ (New_Identifier : in Identifier_Index;
+ Content : in Valid_Node_Index)
+ with Pre => To_Token_Enum (Tree.ID (Content)) in
rhs_alternative_list_ID | rhs_element_ID
+ is
+ -- Convert subtree rooted at Content to an rhs_list contained by a
new nonterminal
+ -- named New_Identifier.
+ New_Nonterm : constant Valid_Node_Index := Tree_Add_Nonterminal
+ (Child_1 => Tree.Add_Identifier (+IDENTIFIER_ID, New_Identifier,
Tree.Byte_Region (Content)),
+ Child_2 => Tree.Add_Terminal (+COLON_ID),
+ Child_3 =>
+ (case To_Token_Enum (Tree.ID (Content)) is
+ when rhs_element_ID => To_RHS_List (Content),
+ when rhs_alternative_list_ID => Convert_RHS_Alternative
(Content),
+ when others => raise SAL.Programmer_Error with "new_nonterminal
unimplemented content" &
+ Tree.Image (Content, Wisitoken_Grammar_Actions.Descriptor)),
+ Child_4 => Tree.Add_Nonterm
+ ((+semicolon_opt_ID, 0),
+ (1 => Tree.Add_Terminal (+SEMICOLON_ID))));
+ begin
+ Add_Compilation_Unit (New_Nonterm);
+ end New_Nonterminal;
+
+ procedure New_Nonterminal_List_1
+ (List_Nonterm : in Identifier_Index;
+ RHS_Element_1 : in Valid_Node_Index;
+ RHS_Element_3 : in Valid_Node_Index;
+ Byte_Region : in Buffer_Region)
+ is
+ -- nonterminal: foo_list
+ -- | IDENTIFIER: "foo_list" List_Nonterm
+ -- | COLON:
+ -- | rhs_list:
+ -- | | rhs_list: RHS_List_2
+ -- | | | rhs: RHS_2
+ -- | | | | rhs_item_list: RHS_Item_List_1
+ -- | | | | | rhs_element: RHS_Element_1
+ -- | | | | | | rhs_item: RHS_Item_1
+ -- | | | | | | | IDENTIFIER: List_Element
+ -- | | BAR:
+ -- | | rhs: RHS_3
+ -- | | | rhs_item_list: RHS_Item_List_2
+ -- | | | | | rhs_item_list: RHS_Item_List_3
+ -- | | | | | | rhs_element: RHS_Element_2
+ -- | | | | | | | rhs_item: RHS_Item_2
+ -- | | | | | | | | IDENTIFIER: List_Nonterm
+ -- | | | | rhs_element: RHS_Element_3
+ -- | | | | | rhs_item: RHS_Item_3
+ -- | | | | | | IDENTIFIER: List_Element
+ -- | semicolon_opt:
+ -- | | SEMICOLON:
+
+ RHS_Item_2 : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+rhs_item_ID, 0), (1 => Tree.Add_Identifier (+IDENTIFIER_ID,
List_Nonterm, Byte_Region)));
+
+ RHS_Element_2 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_2));
+
+ RHS_Item_List_1 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_item_list_ID, 0), (1 => RHS_Element_1));
+ RHS_Item_List_3 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_item_list_ID, 0), (1 => RHS_Element_2));
+ RHS_Item_List_2 : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+rhs_item_list_ID, 1), (1 => RHS_Item_List_3, 2 =>
RHS_Element_3));
+
+ RHS_2 : constant Valid_Node_Index := Tree.Add_Nonterm ((+rhs_ID, 1),
(1 => RHS_Item_List_1));
+ RHS_3 : constant Valid_Node_Index := Tree.Add_Nonterm ((+rhs_ID, 1),
(1 => RHS_Item_List_2));
+
+ Bar_1 : constant Valid_Node_Index := Tree.Add_Terminal (+BAR_ID);
+
+ RHS_List_2 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_list_ID, 0), (1 => RHS_2));
+
+ List_Nonterminal : constant Valid_Node_Index := Tree_Add_Nonterminal
+ (Child_1 => Tree.Add_Identifier (+IDENTIFIER_ID, List_Nonterm,
Byte_Region),
+ Child_2 => Tree.Add_Terminal (+COLON_ID),
+ Child_3 => Tree.Add_Nonterm
+ ((+rhs_list_ID, 1),
+ (1 => RHS_List_2,
+ 2 => Bar_1,
+ 3 => RHS_3)),
+ Child_4 => Tree.Add_Nonterm
+ ((+semicolon_opt_ID, 0),
+ (1 => Tree.Add_Terminal (+SEMICOLON_ID))));
+ begin
+ Add_Compilation_Unit (List_Nonterminal);
+ end New_Nonterminal_List_1;
+
+ procedure New_Nonterminal_List
+ (List_Nonterm : in Identifier_Index;
+ List_Element : in Identifier_Index;
+ Byte_Region : in Buffer_Region)
+ is
+ RHS_Item_1 : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+rhs_item_ID, 0), (1 => Tree.Add_Identifier (+IDENTIFIER_ID,
List_Element, Byte_Region)));
+ RHS_Item_3 : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+rhs_item_ID, 0), (1 => Tree.Add_Identifier (+IDENTIFIER_ID,
List_Element, Byte_Region)));
+ RHS_Element_1 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_1));
+ RHS_Element_3 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_3));
+ begin
+ New_Nonterminal_List_1 (List_Nonterm, RHS_Element_1, RHS_Element_3,
Byte_Region);
+ end New_Nonterminal_List;
+
+ procedure New_Nonterminal_List
+ (List_Nonterm : in Identifier_Index;
+ List_Element : in Token_Index;
+ Terminals : in Base_Token_Arrays.Vector;
+ Byte_Region : in Buffer_Region)
+ is
+ RHS_Item_1 : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+rhs_item_ID, 0), (1 => Tree.Add_Terminal (List_Element,
Terminals)));
+ RHS_Item_3 : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+rhs_item_ID, 0), (1 => Tree.Add_Terminal (List_Element,
Terminals)));
+ RHS_Element_1 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_1));
+ RHS_Element_3 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_3));
+ begin
+ New_Nonterminal_List_1 (List_Nonterm, RHS_Element_1, RHS_Element_3,
Byte_Region);
+ end New_Nonterminal_List;
+
+ procedure Process_Node (Node : in Valid_Node_Index)
+ is begin
+ if Trace_Generate > Detail then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("translate node" & Node_Index'Image (Node));
+ end if;
+
+ case To_Token_Enum (Tree.ID (Node)) is
+ -- Token_Enum_ID alphabetical order
+ when declaration_ID =>
+ -- Must be "%meta_syntax EBNF"; change to BNF
+ declare
+ Decl_Item : constant Valid_Node_Index := Tree.Find_Descendant
+ (Tree.Child (Node, 3), +declaration_item_ID);
+ Children : Valid_Node_Index_Array := Tree.Children (Decl_Item);
+ begin
+ Children (1) := Tree.Add_Identifier
+ (+IDENTIFIER_ID, New_Identifier ("BNF"), Tree.Byte_Region
(Decl_Item));
+ Tree.Set_Children (Decl_Item, (+declaration_item_ID, 1),
Children);
+ end;
+
+ when rhs_alternative_list_ID =>
+ -- All handled by New_Nonterminal*
+ raise SAL.Not_Implemented with Tree.Image (Node,
Wisitoken_Grammar_Actions.Descriptor);
+
+ when rhs_attribute_ID =>
+ -- Just delete it
+ --
+ -- Current tree (so far, attributes are always the first item in
an rhs):
+ --
+ -- rhs:
+ -- | ...
+ -- | rhs_item_list: RHS_Item_List.Parent 2
+ -- | | rhs_item_list: RHS_Item_List.Parent 1
+ -- | | | rhs_item_list: RHS_Item_List
+ -- | | | | rhs_element: Parent (Node, 2)
+ -- | | | | | rhs_item: Parent (Node, 1)
+ -- | | | | | | rhs_attribute: Node
+ -- | | | rhs_element: next_element 1
+ -- | | rhs_element: next_element 2
+ --
+ -- New tree:
+ --
+ -- rhs:
+ -- | ...
+ -- | rhs_item_list: keep RHS_Item_List.Parent
+ -- | | rhs_element: keep next_element 1
+ -- | rhs_element: kepp next_element 2
+ declare
+ RHS_Item_List : constant Valid_Node_Index := Tree.Parent
(Node, 3);
+ Parent : constant Valid_Node_Index := Tree.Parent
(RHS_Item_List);
+ begin
+ if Tree.RHS_Index (RHS_Item_List) /= 0 then
+ -- Not first
+ Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_attribute_id unimplemented", Tree, Node);
+ end if;
+
+ Tree.Set_Children
+ (Parent,
+ (+rhs_item_list_ID, 0),
+ (1 => Tree.Child (Parent, 2)));
+ end;
+
+ when rhs_group_item_ID =>
+ -- Current tree:
+ --
+ -- rhs_element: Parent (Node, 2)
+ -- | rhs_item: Parent (Node, 1)
+ -- | | rhs_group_item: Node
+ -- | | | LEFT_PAREN
+ -- | | | rhs_alternative_list: Child (Node, 2)
+ -- | | | RIGHT_PAREN
+
+ -- See if there's an existing nonterminal for this content.
+ declare
+ Element_Content : constant String := Get_Text (Data,
Tree, Tree.Child (Node, 2));
+ Temp : Node_Index := First_List_Element
+ (Tree.Child (Tree.Root, 1), +compilation_unit_ID);
+ Name_Node : Node_Index;
+ New_Ident : Base_Identifier_Index :=
Invalid_Identifier_Index;
+ begin
+ loop
+ pragma Assert (Tree.ID (Temp) = +compilation_unit_ID);
+
+ if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+nonterminal_ID, 0) then
+ -- Target nonterm is:
+ --
+ -- (compilation_unit_1, (111 . 128))
+ -- | (nonterminal_0, (111 . 128))
+ -- | | 7;(IDENTIFIER, (111 . 128))
+ -- | | (COLON)
+ -- | | (rhs_list_1, (111 . 128))
+ -- | | | ...
+ declare
+ RHS_List_1 : constant Node_Index := Tree.Child
(Tree.Child (Temp, 1), 3);
+ begin
+ if RHS_List_1 /= Invalid_Node_Index and then
+ Element_Content = Get_Text (Data, Tree, RHS_List_1)
+ then
+ Name_Node := Tree.Child (Tree.Child (Temp, 1), 1);
+ case Tree.Label (Name_Node) is
+ when Shared_Terminal =>
+ New_Ident := New_Identifier (Get_Text (Data,
Tree, Name_Node));
+ when Virtual_Identifier =>
+ New_Ident := Tree.Identifier (Name_Node);
+ when others =>
+ Raise_Programmer_Error ("process_node
rhs_group_item", Tree, Name_Node);
+ end case;
+
+ exit;
+ end if;
+ end;
+ end if;
+
+ Temp := Next_List_Element (Temp, +compilation_unit_list_ID);
+ exit when Temp = Invalid_Node_Index;
+ end loop;
+
+ if New_Ident = Invalid_Identifier_Index then
+ New_Ident := Next_Nonterm_Name;
+ New_Nonterminal (New_Ident, Tree.Child (Node, 2));
+ end if;
+
+ Tree.Set_Node_Identifier (Node, +IDENTIFIER_ID, New_Ident);
+ Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID, 0), (1 =>
Node));
+ Clear_EBNF_Node (Node);
+ end;
+
+ when rhs_multiple_item_ID =>
+ -- We have one of:
+ --
+ -- | a { b } c
+ -- | a { b } - c
+ -- | a ( b ) + c
+ -- | a ( b ) * c
+ -- | a b+ c
+ -- | a b* c
+ --
+ -- Replace it with a new canonical list nonterminal:
+ --
+ -- nonterminal_nnn
+ -- : b
+ -- | nonterminal_nnn_list b
+ --
+ -- and a second RHS if it can be empty:
+ -- | a c
+
+ -- Current tree:
+ --
+ -- rhs_item: Parent (Node, 1)
+ -- | rhs_multiple_item: Node
+ -- | | LEFT_BRACE | LEFT_PAREN
+ -- | | rhs_alternative_list
+ -- | | | ...
+ -- | | RIGHT_BRACE | RIGHT_PAREN
+ -- | | [MINUS | PLUS | STAR]
+
+ -- or:
+ --
+ -- rhs_item: Parent (Node, 1)
+ -- | rhs_multiple_item: Node
+ -- | | IDENTIFIER
+ -- | | PLUS | STAR
+
+ declare
+ Done : Boolean := False;
+ RHS_Index : constant Integer :=
Tree.RHS_Index (Node);
+ Plus_Minus_Star : constant Node_Index :=
Tree.Child
+ (Node, (if RHS_Index in 0 .. 3 then 4 else 2));
+ Allow_Empty : constant Boolean :=
Plus_Minus_Star = Invalid_Node_Index or else
+ Tree.ID (Plus_Minus_Star) in +STAR_ID;
+ Parent_RHS_Item : constant Valid_Node_Index :=
Tree.Parent (Node);
+ List_Nonterm_Virtual_Name : Base_Identifier_Index :=
Invalid_Identifier_Index;
+ List_Nonterm_Terminal_Name : Base_Token_Index :=
Invalid_Token_Index;
+ List_Element : Base_Identifier_Index :=
Invalid_Identifier_Index;
+
+ procedure Check_Canonical_List
+ is
+ -- In EBNF, a canonical list with a separator looks like:
+ --
+ -- enumConstants : enumConstant (',' enumConstant)* ;
+ --
+ -- or, with no separator:
+ --
+ -- SwitchLabels : SwitchLabel {SwitchLabel} ;
+ --
+ -- The tokens may have labels.
+ --
+ -- Handling these cases specially this eliminates a
conflict between
+ -- reducing to enumConstants and reducing to the introduced
nonterm
+ -- list.
+ --
+ -- Alternately, the no separator case can be:
+ --
+ -- enumConstants : enumConstant+ ;
+ --
+ -- Handling this no separator case specially would not
eliminate any conflicts.
+
+ use all type SAL.Base_Peek_Type;
+
+ Alt_List_Items : constant Valid_Node_Index_Array :=
Tree.Get_IDs (Node, +rhs_item_ID);
+ RHS_Element : constant Valid_Node_Index :=
Tree.Parent (Node, 2);
+ Element_1 : constant Node_Index :=
Prev_List_Element
+ (RHS_Element, +rhs_item_list_ID);
+ RHS_2 : constant Valid_Node_Index :=
Tree.Find_Ancestor
+ (Node, (+rhs_ID, +rhs_alternative_list_ID));
+ begin
+ if Tree.ID (RHS_2) = +rhs_alternative_list_ID then return;
end if;
+ if not (Alt_List_Items'Last in 1 .. 2) then return; end if;
+ if Element_1 = Invalid_Node_Index or else
+ Get_Text (Data, Tree, Tree.Get_IDs (Element_1,
+rhs_item_ID)(1)) /=
+ Get_Text (Data, Tree, Alt_List_Items (Alt_List_Items'Last))
+ then
+ return;
+ end if;
+ if Invalid_Node_Index /= Next_List_Element (RHS_Element,
+rhs_item_list_ID) then return; end if;
+ if Invalid_Node_Index /= Next_List_Element (RHS_2,
+rhs_list_ID) or
+ Invalid_Node_Index /= Prev_List_Element (RHS_2,
+rhs_list_ID)
+ then
+ return;
+ end if;
+
+ -- We have a canonical list declaration. Rewrite it to:
+ --
+ -- with separator:
+ -- rhs_list: keep
+ -- | rhs_list:
+ -- | | rhs: new, RHS_1
+ -- | | | rhs_item_list: new, RHS_Item_List_1
+ -- | | | | rhs_element: keep, Element_1
+ -- | | | | | rhs_item: keep
+ -- | | | | | | IDENTIFIER: keep; element name
+ -- | BAR: new
+ -- | rhs: keep, RHS_2
+ -- | | rhs_item_list: new, RHS_Item_List_2
+ -- | | | rhs_item_list: keep, rhs_item_list_3
+ -- | | | | rhs_item_list: keep, rhs_item_list_4
+ -- | | | | | rhs_element: new
+ -- | | | | | | rhs_item: new
+ -- | | | | | | | IDENTIFIER: new, list name
+ -- | | | | rhs_element: keep
+ -- | | | | | rhs_item: keep
+ -- | | | | | | IDENTIFIER: keep, separator
+ -- | | | rhs_element: keep, alt_list_elements (last)
+ -- | | | | rhs_item: keep
+ -- | | | | | IDENTIFIER: keep, element name
+ --
+ -- no separator:
+ -- rhs_list: keep
+ -- | rhs_list:
+ -- | | rhs: new, RHS_1
+ -- | | | rhs_item_list: new, RHS_Item_List_1
+ -- | | | | rhs_element: keep, Element_1
+ -- | | | | | rhs_item: keep
+ -- | | | | | | IDENTIFIER: keep; element name
+ -- | BAR: new
+ -- | rhs: keep, RHS_2
+ -- | | rhs_item_list: keep, rhs_item_list_3
+ -- | | | rhs_item_list: new, rhs_item_list_4
+ -- | | | | rhs_element: new
+ -- | | | | | rhs_item: new
+ -- | | | | | | IDENTIFIER: new, list name
+ -- | | | rhs_element: keep, alt_list_elements (last)
+ -- | | | | rhs_item: keep
+ -- | | | | | IDENTIFIER: keep, element name
+
+ declare
+ List_Name_Node : constant Valid_Node_Index :=
Tree.Find_Ancestor (RHS_2, +nonterminal_ID);
+ List_Name_Tok : constant Token_Index :=
Tree.Min_Terminal_Index (List_Name_Node);
+ List_Name_Region : constant Buffer_Region :=
Data.Terminals.all (List_Name_Tok).Byte_Region;
+ List_Name : constant String :=
Data.Grammar_Lexer.Buffer_Text (List_Name_Region);
+
+ RHS_2_Index : constant Integer := Tree.RHS_Index
(RHS_2);
+ RHS_2_Children : Valid_Node_Index_Array := Tree.Children
(RHS_2);
+
+ RHS_Item_List_1 : constant Valid_Node_Index :=
Tree.Add_Nonterm
+ ((+rhs_item_list_ID, 0), (1 => Element_1));
+
+ RHS_1_Action : constant Node_Index :=
+ (case RHS_2_Index is
+ when 2 | 3 => Tree.Add_Terminal
+ (Tree.Min_Terminal_Index (RHS_2_Children (2)),
Data.Terminals.all),
+ when others => Invalid_Node_Index);
+
+ RHS_1_Check : constant Node_Index :=
+ (case RHS_2_Index is
+ when 3 => Tree.Add_Terminal
+ (Tree.Min_Terminal_Index (RHS_2_Children (3)),
Data.Terminals.all),
+ when others => Invalid_Node_Index);
+
+ RHS_1 : constant Valid_Node_Index :=
+ (case RHS_2_Index is
+ when 1 => Tree.Add_Nonterm ((+rhs_ID, 1), (1 =>
RHS_Item_List_1)),
+ when 2 => Tree.Add_Nonterm ((+rhs_ID, 2), (1 =>
RHS_Item_List_1, 2 => RHS_1_Action)),
+ when 3 => Tree.Add_Nonterm
+ ((+rhs_ID, 3), (1 => RHS_Item_List_1, 2 =>
RHS_1_Action, 3 => RHS_1_Check)),
+ when others => raise SAL.Programmer_Error);
+
+ Bar : constant Valid_Node_Index :=
Tree.Add_Terminal (+BAR_ID);
+ RHS_Item_List_3 : constant Valid_Node_Index :=
Tree.Child (RHS_2, 1);
+ RHS_Item_List_4 : constant Valid_Node_Index :=
Tree.Child (RHS_Item_List_3, 1);
+ New_List_Name_Term : constant Valid_Node_Index :=
Tree.Add_Terminal
+ (List_Name_Tok, Data.Terminals.all);
+ New_List_Name_Item : constant Valid_Node_Index :=
Tree.Add_Nonterm
+ ((+rhs_item_ID, 0),
+ (1 => New_List_Name_Term));
+
+ New_List_Name_Label : constant Node_Index :=
+ (if Tree.RHS_Index (Element_1) = 1
+ then -- tokens have labels
+ Tree.Add_Identifier (+IDENTIFIER_ID, New_Identifier
(List_Name), List_Name_Region)
+ else Invalid_Node_Index);
+
+ New_List_Name_Element : constant Valid_Node_Index :=
+ (if Tree.RHS_Index (Element_1) = 1
+ then -- tokens have labels
+ Tree.Add_Nonterm
+ ((+rhs_element_ID, 1),
+ (1 => New_List_Name_Label,
+ 2 => Tree.Add_Terminal (+EQUAL_ID),
+ 3 => New_List_Name_Item))
+ else
+ Tree.Add_Nonterm ((+rhs_element_ID, 0), (1 =>
New_List_Name_Item)));
+
+ Alt_List_Elements : constant Valid_Node_Index_Array :=
Tree.Get_IDs (Node, +rhs_element_ID);
+ RHS_Item_List_2 : constant Node_Index :=
+ (if Alt_List_Elements'Last = 1
+ then Invalid_Node_Index -- no separator
+ else Tree.Add_Nonterm
+ ((+rhs_item_list_ID, 1),
+ (1 => RHS_Item_List_3,
+ 2 => Alt_List_Elements (Alt_List_Elements'Last))));
+
+ begin
+ Tree.Set_Children (RHS_Item_List_4, (+rhs_item_list_ID,
0), (1 => New_List_Name_Element));
+
+ Tree.Set_Children
+ (RHS_Item_List_3,
+ (+rhs_item_list_ID, 1),
+ (1 => RHS_Item_List_4,
+ 2 => Alt_List_Elements (1)));
+
+ RHS_2_Children (1) :=
+ (if Alt_List_Elements'Last = 1
+ then RHS_Item_List_3 -- no separator
+ else RHS_Item_List_2);
+ Tree.Set_Children (RHS_2, (+rhs_ID, Tree.RHS_Index
(RHS_2)), RHS_2_Children);
+
+ Tree.Set_Children
+ (Tree.Parent (RHS_2),
+ (+rhs_list_ID, 1),
+ (1 => Tree.Add_Nonterm ((+rhs_list_ID, 0), (1 =>
RHS_1)),
+ 2 => Bar,
+ 3 => RHS_2));
+ end;
+
+ Done := True;
+
+ Clear_EBNF_Node (Node);
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("edited rhs_list:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
Tree.Parent (RHS_2));
+ end if;
+ end Check_Canonical_List;
+
+ procedure Find_List_Nonterminal_2 (Element_Content : in String)
+ is
+ -- Look for a virtual pair of nonterms implementing a list
of Element_Content.
+ -- If found, set List_Nonterm_Virtual_Name, List_Element
+ Temp : Node_Index := First_List_Element (Tree.Child
(Tree.Root, 1), +compilation_unit_ID);
+ Name_Node : Node_Index;
+ begin
+ loop
+ pragma Assert (Tree.ID (Temp) = +compilation_unit_ID);
+
+ if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+nonterminal_ID, 0) and
+ Tree.Is_Virtual (Tree.Child (Temp, 1))
+ then
+ if Element_Content = Get_Text (Data, Tree, Tree.Child
(Tree.Child (Temp, 1), 3)) then
+ Name_Node := Tree.Child (Tree.Child (Temp, 1), 1);
+ case Tree.Label (Name_Node) is
+ when Virtual_Identifier =>
+ List_Element := Tree.Identifier (Name_Node);
+ when others =>
+ Raise_Programmer_Error
+ ("unimplemented Find_List_Nonterminal_2 case
'" & Element_Content & "'",
+ Tree, Name_Node);
+ end case;
+
+ -- list nonterm is the next nonterminal
+ Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
+ Name_Node := Tree.Child (Tree.Child (Temp, 1), 1);
+ case Tree.Label (Name_Node) is
+ when Virtual_Identifier =>
+ List_Nonterm_Virtual_Name := Tree.Identifier
(Name_Node);
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+ exit;
+ end if;
+ end if;
+
+ Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
+ exit when Temp = Invalid_Node_Index;
+ end loop;
+ end Find_List_Nonterminal_2;
+
+ procedure Find_List_Nonterminal_1 (Element_Content : in String)
+ is
+ -- Search for a nonterm (virtual or not) implementing a
list for
+ -- Element_Content, which is a single rhs_element; no
List_Element
+ -- Nonterminal. If found, set List_Nonterm_Virtual_Name or
+ -- List_Nonterm_Terminal_Name
+ Temp : Node_Index := First_List_Element (Tree.Child
(Tree.Root, 1), +compilation_unit_ID);
+ begin
+ loop
+ pragma Assert (Tree.ID (Temp) = +compilation_unit_ID);
+
+ if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+nonterminal_ID, 0) then
+ -- Target List_Nonterm is:
+ --
+ -- nonterminal_nnn_list
+ -- : element
+ -- | nonterminal_nnn_list element
+ --
+ -- compilation_unit
+ -- | nonterminal
+ -- | | IDENTIFIER : list_nonterm
+ -- | | COLON
+ -- | | rhs_list: rhs_list_1
+ -- | | | rhs_list: rhs_list_2
+ -- | | | | rhs
+ -- | | | | | ... List_element
+ -- | | | BAR
+ -- | | | rhs: ... list_nonterm list_element
+ declare
+ Name_Node : constant Node_Index := Tree.Child
(Tree.Child (Temp, 1), 1);
+ RHS_List_1 : constant Node_Index := Tree.Child
(Tree.Child (Temp, 1), 3);
+ RHS_List_2 : constant Node_Index :=
+ (if RHS_List_1 = Invalid_Node_Index
+ then Invalid_Node_Index
+ else Tree.Child (RHS_List_1, 1));
+ begin
+ if RHS_List_2 /= Invalid_Node_Index and
+ Tree.Child (RHS_List_1, 3) /= Invalid_Node_Index
and -- second rhs present
+ Tree.Child (RHS_List_2, 3) = Invalid_Node_Index
-- no third rhs
+ then
+ declare
+ RHS_1 : constant String := Get_Text (Data,
Tree, RHS_List_2);
+ RHS_2 : constant String := Get_Text (Data,
Tree, Tree.Child (RHS_List_1, 3));
+ Expected_RHS_2 : constant String := Get_Text
(Data, Tree, Name_Node) & " " &
+ Element_Content;
+ begin
+ if Element_Content = RHS_1 and RHS_2 =
Expected_RHS_2 then
+ case Tree.Label (Name_Node) is
+ when Shared_Terminal =>
+ List_Nonterm_Terminal_Name :=
Tree.Min_Terminal_Index (Name_Node);
+ when Virtual_Identifier =>
+ List_Nonterm_Virtual_Name :=
Tree.Identifier (Name_Node);
+ when others =>
+ Raise_Programmer_Error
+ ("unimplemented
Find_List_Nonterminal_1 case '" & Element_Content & "'",
+ Tree, Name_Node);
+ end case;
+
+ exit;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+
+ Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
+ exit when Temp = Invalid_Node_Index;
+ end loop;
+ end Find_List_Nonterminal_1;
+ begin
+ -- Check if this is a recognized pattern
+ Check_Canonical_List;
+ if Done then return; end if;
+
+ -- Check to see if there is an already declared nonterminal
+ -- list with the same content; if not, create one.
+ case Tree.RHS_Index (Node) is
+ when 0 .. 3 =>
+ -- { rhs_alternative_list } -?
+ -- ( rhs_alternative_list ) [+*]
+ if 0 = Tree.RHS_Index (Tree.Child (Node, 2)) and then
+ 0 = Tree.RHS_Index (Tree.Child (Tree.Child (Node, 2), 1))
+ then
+ -- Only one element in the rhs_alternative_list, and in
the rhs_item_list
+ Find_List_Nonterminal_1 (Get_Text (Data, Tree, Tree.Child
(Node, 2)));
+
+ if List_Nonterm_Virtual_Name = Invalid_Identifier_Index
and
+ List_Nonterm_Terminal_Name = Invalid_Token_Index
+ then
+ List_Nonterm_Virtual_Name := Next_Nonterm_Name
("_list");
+ New_Nonterminal_List
+ (List_Nonterm_Virtual_Name, Tree.Min_Terminal_Index
(Tree.Child (Node, 2)),
+ Data.Terminals.all, Tree.Byte_Region (Node));
+ end if;
+ else
+ Find_List_Nonterminal_2 (Get_Text (Data, Tree, Tree.Child
(Node, 2)));
+
+ if List_Nonterm_Virtual_Name = Invalid_Identifier_Index
then
+ List_Nonterm_Virtual_Name := Next_Nonterm_Name
("_list");
+ List_Element := Next_Nonterm_Name;
+ New_Nonterminal (List_Element, Tree.Child (Node, 2));
+ New_Nonterminal_List (List_Nonterm_Virtual_Name,
List_Element, Tree.Byte_Region (Node));
+ end if;
+ end if;
+
+ when 4 | 5 =>
+ -- IDENTIFIER + | *
+ Find_List_Nonterminal_1 (Get_Text (Data, Tree, Tree.Child
(Node, 1)));
+
+ if List_Nonterm_Virtual_Name = Invalid_Identifier_Index then
+ List_Nonterm_Virtual_Name := Next_Nonterm_Name ("_list");
+ New_Nonterminal_List
+ (List_Nonterm_Virtual_Name, Tree.Min_Terminal_Index
(Tree.Child (Node, 1)), Data.Terminals.all,
+ Tree.Byte_Region (Node));
+ end if;
+
+ when others =>
+ Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_multiple_item unimplmented", Tree, Node);
+ end case;
+
+ if Allow_Empty then
+ Insert_Optional_RHS (Node);
+ end if;
+
+ declare
+ Child : constant Valid_Node_Index :=
+ (if List_Nonterm_Virtual_Name /= Invalid_Identifier_Index
+ then Tree.Add_Identifier
+ (+IDENTIFIER_ID, List_Nonterm_Virtual_Name,
Tree.Byte_Region (Parent_RHS_Item))
+ elsif List_Nonterm_Terminal_Name /= Invalid_Token_Index
+ then Tree.Add_Terminal (List_Nonterm_Terminal_Name,
Data.Terminals.all)
+ else raise SAL.Programmer_Error);
+ begin
+ Tree.Set_Children (Parent_RHS_Item, (+rhs_item_ID, 0), (1 =>
Child));
+ end;
+
+ Clear_EBNF_Node (Node);
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("edited rhs_item:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
Parent_RHS_Item);
+ end if;
+ exception
+ when E : System.Assertions.Assert_Failure =>
+ Raise_Programmer_Error
+ ("translate_ebnf_to_bnf multiple_item assert: " &
Ada.Exceptions.Exception_Message (E), Tree, Node);
+ end;
+
+ when rhs_optional_item_ID =>
+ -- Source looks like:
+ --
+ -- | a [b] c
+ --
+ -- where 'a', 'b', 'c' are token sequences. Translate to:
+ --
+ -- | a nonterm_b c
+ -- | a c
+ --
+ -- where 'nonterm_b' is a new nonterminal containing b, unless b
is
+ -- simple enough to inline.
+ --
+ -- See nested_ebnf_optional.wy for an example of nested optional
+ -- items.
+ --
+ -- current tree:
+ --
+ -- | rhs_list:
+ -- | | rhs | rhs_alternative_list:
+ -- | | | rhs_item_list
+ -- | | | | rhs_item_list
+ -- | | | ...
+ -- | | | | | | rhs_element:
+ -- | | | | | | | rhs_item: contains a tail
+ -- | | | | | rhs_element:
+ -- | | | | | | rhs_item: contains b
+ -- | | | | | | | rhs_optional_item: Node
+ -- | | | | | | | | LEFT_BRACKET: Node.Children (1)
+ -- | | | | | | | | rhs_alternative_item_list: Node.Children (2) b
+ -- | | | | | | | | RIGHT_BRACKET: Node.Children (3)
+ -- | | | | rhs_element: head of c
+ -- | | | | | rhs_item: head of c
+
+ declare
+ Name_Ident : Base_Identifier_Index :=
Invalid_Identifier_Index;
+ Name_Terminal : Base_Token_Index := Invalid_Token_Index;
+ Name_Label : Base_Token_Index := Invalid_Token_Index;
+ Found : Boolean := False;
+ begin
+ case Tree.RHS_Index (Node) is
+ when 0 | 1 =>
+ -- : LEFT_BRACKET rhs_alternative_list RIGHT_BRACKET
+ -- | LEFT_PAREN rhs_alternative_list RIGHT_PAREN QUESTION
+
+ -- Check for special cases
+
+ if List_Singleton (Tree.Child (Node, 2)) then
+ if List_Singleton (Tree.Child (Tree.Child (Node, 2), 1))
then
+ -- Single item in rhs_alternative_list and
rhs_item_list; just use it.
+ --
+ -- Single alternative, multiple rhs_items handled
below
+ declare
+ Name_Element_Node : Valid_Node_Index;
+ Name_Identifier_Node : Node_Index;
+ begin
+ Found := True;
+ Name_Element_Node := First_List_Element
+ (Tree.Child (Tree.Child (Node, 2), 1),
+rhs_element_ID);
+
+ if Tree.RHS_Index (Name_Element_Node) = 0 then
+ Name_Identifier_Node := Tree.Child (Tree.Child
(Name_Element_Node, 1), 1);
+ else
+ -- Name has a label
+ Name_Label := Tree.Min_Terminal_Index
(Tree.Child (Name_Element_Node, 1));
+ Name_Identifier_Node := Tree.Child (Tree.Child
(Name_Element_Node, 3), 1);
+ end if;
+
+ case Tree.Label (Name_Identifier_Node) is
+ when Virtual_Identifier =>
+ Name_Ident := Tree.Identifier
(Name_Identifier_Node);
+ when Shared_Terminal =>
+ Name_Terminal := Tree.Min_Terminal_Index
(Name_Identifier_Node);
+ when others =>
+ Raise_Programmer_Error ("unhandled rhs_optional
case ", Tree, Name_Identifier_Node);
+ end case;
+ end;
+ end if;
+ else
+ -- See if we've already created a nonterminal for this.
+ declare
+ New_Text : constant String := Get_Text
(Data, Tree, Tree.Child (Node, 2));
+ Temp : Node_Index :=
First_List_Element
+ (Tree.Child (Tree.Root, 1), +compilation_unit_ID);
+ Name_Identifier_Node : Node_Index;
+ begin
+ loop
+ pragma Assert (Tree.ID (Temp) =
+compilation_unit_ID);
+
+ if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+nonterminal_ID, 0) then
+ if New_Text = Get_Text (Data, Tree, Tree.Child
(Tree.Child (Temp, 1), 3)) then
+ Found := True;
+ Name_Identifier_Node := Tree.Child
(Tree.Child (Temp, 1), 1);
+ case Tree.Label (Name_Identifier_Node) is
+ when Virtual_Identifier =>
+ Name_Ident := Tree.Identifier
(Name_Identifier_Node);
+ when others =>
+ Raise_Programmer_Error
+ ("unhandled rhs_optional case '" &
New_Text & "'", Tree, Name_Identifier_Node);
+ end case;
+ exit;
+ end if;
+ end if;
+
+ Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
+ exit when Found or Temp = Invalid_Node_Index;
+ end loop;
+ end;
+ end if;
+
+ if Found then
+ -- Use previously created nonterminal
+ if Name_Ident /= Invalid_Identifier_Index then
+ Tree.Set_Node_Identifier (Node, +IDENTIFIER_ID,
Name_Ident);
+
+ -- Change RHS_Index, delete Check_EBNF action
+ Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID,
0), (1 => Node));
+
+ elsif Name_Terminal /= Invalid_Token_Index then
+ Tree.Set_Children
+ (Tree.Parent (Node),
+ (+rhs_item_ID, 0),
+ (1 => Tree.Add_Terminal (Name_Terminal,
Data.Terminals.all)));
+
+ else
+ raise SAL.Programmer_Error;
+ end if;
+
+ if Name_Label /= Invalid_Token_Index then
+ declare
+ Label_Node : constant Valid_Node_Index :=
Tree.Add_Terminal
+ (Name_Label, Data.Terminals.all);
+ Equal_Node : constant Valid_Node_Index :=
Tree.Add_Terminal (+EQUAL_ID);
+ begin
+ Tree.Set_Children
+ (Tree.Parent (Tree.Parent (Node)),
+ (+rhs_element_ID, 1),
+ (1 => Label_Node,
+ 2 => Equal_Node,
+ 3 => Tree.Parent (Node)));
+ end;
+ end if;
+
+ else
+ -- Create a new nonterm, or handle more special cases
+
+ if List_Singleton (Tree.Child (Node, 2)) then
+ -- Single alternative, multiple rhs_items
+ --
+ -- No separate nonterminal, so token labels stay in
the same RHS for
+ -- actions. Splice together rhs_item_lists a, b, c
+ declare
+ Root_List_A : constant Valid_Node_Index :=
Tree.Child (Tree.Parent (Node, 3), 1);
+ Tail_Element_A : constant Node_Index :=
+ (if Root_List_A = Tree.Parent (Node, 2)
+ then Invalid_Node_Index -- a is empty
+ else Last_List_Element (Root_List_A));
+ Root_List_B : constant Valid_Node_Index :=
Tree.Child (Tree.Child (Node, 2), 1);
+ Head_Element_B : constant Valid_Node_Index :=
First_List_Element
+ (Root_List_B, +rhs_element_ID);
+ Tail_Element_B : constant Valid_Node_Index :=
Last_List_Element (Root_List_B);
+ Root_List_C : constant Valid_Node_Index :=
List_Root (Tree.Parent (Node, 3));
+ Head_Element_C : constant Node_Index :=
Next_List_Element
+ (Tree.Parent (Node, 2), +rhs_item_list_ID);
+ RHS : constant Valid_Node_Index :=
Tree.Parent (Root_List_C);
+ RHS_Children : Valid_Node_Index_Array :=
Tree.Children (RHS);
+ begin
+ if Tail_Element_A = Invalid_Node_Index and
Head_Element_C = Invalid_Node_Index then
+ -- A, C both empty
+ RHS_Children (1) := Tree.Child (Root_List_B, 1);
+ Tree.Set_Children (RHS, Tree.Production_ID
(RHS), RHS_Children);
+
+ elsif Tail_Element_A = Invalid_Node_Index then
+ -- A empty, C not empty
+ declare
+ Parent_B2 : constant Valid_Node_Index :=
Tree.Parent (Tail_Element_B);
+ Parent_C : constant Valid_Node_Index :=
Tree.Parent (Head_Element_C);
+ begin
+ Tree.Set_Children (Parent_C,
(+rhs_item_list_ID, 1), (Parent_B2, Head_Element_C));
+ -- Head_Element_C remains the list root.
+ end;
+
+ elsif Head_Element_C = Invalid_Node_Index then
+ -- A not empty, C empty.
+ declare
+ Parent_A : constant Valid_Node_Index :=
Tree.Parent (Tail_Element_A);
+ Parent_B : constant Valid_Node_Index :=
Tree.Parent (Head_Element_B);
+ begin
+ Tree.Set_Children (Parent_B,
(+rhs_item_list_ID, 1), (Parent_A, Head_Element_B));
+ RHS_Children (1) := Root_List_B;
+ Tree.Set_Children (RHS, Tree.Production_ID
(RHS), RHS_Children);
+ end;
+ else
+ -- A, C both not empty
+ declare
+ Parent_A : constant Valid_Node_Index :=
Tree.Parent (Tail_Element_A);
+ Parent_B1 : constant Valid_Node_Index :=
Tree.Parent (Head_Element_B);
+ Parent_B2 : constant Valid_Node_Index :=
Tree.Parent (Tail_Element_B);
+ Parent_C : constant Valid_Node_Index :=
Tree.Parent (Head_Element_C);
+ begin
+ Tree.Set_Children (Parent_B1,
(+rhs_item_list_ID, 1), (Parent_A, Head_Element_B));
+ Tree.Set_Children (Parent_C,
(+rhs_item_list_ID, 1), (Parent_B2, Head_Element_C));
+ -- Head_Element_C remains the list root.
+ end;
+ end if;
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("edited rhs:");
+ Tree.Print_Tree
(Wisitoken_Grammar_Actions.Descriptor, RHS);
+ end if;
+ end;
+ else
+ declare
+ Nonterm_B : constant Identifier_Index :=
Next_Nonterm_Name ("");
+ begin
+ New_Nonterminal (Nonterm_B, Tree.Child (Node, 2));
+ Tree.Set_Node_Identifier (Node, +IDENTIFIER_ID,
Nonterm_B);
+ end;
+ Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID,
0), (1 => Node));
+ end if;
+ end if;
+
+ when 2 =>
+ -- | IDENTIFIER QUESTION
+ Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID, 0), (1
=> Tree.Child (Node, 1)));
+
+ when 3 =>
+ -- | STRING_LITERAL_2 QUESTION
+ Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID, 1), (1
=> Tree.Child (Node, 1)));
+
+ when others =>
+ Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_optional_item unimplmented", Tree, Node);
+ end case;
+
+ Clear_EBNF_Node (Node);
+
+ Insert_Optional_RHS (Node);
+ end;
+
+ when STRING_LITERAL_2_ID =>
+ declare
+ Value : constant String := Get_Text (Data, Tree, Node,
Strip_Quotes => True);
+ Name_Ident : Identifier_Index;
+ Found : Boolean := False;
+ begin
+ -- See if Value is already declared
+ declare
+ Temp : Node_Index := First_List_Element (Tree.Child
(Tree.Root, 1), +compilation_unit_ID);
+ Decl : Node_Index;
+ begin
+ loop
+ pragma Assert (Tree.ID (Temp) = +compilation_unit_ID);
+
+ if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+declaration_ID, 0) then
+ Decl := Tree.Child (Temp, 1);
+ declare
+ Value_Node : constant Valid_Node_Index :=
Tree.Child (Tree.Child (Decl, 4), 1);
+ begin
+ if Tree.ID (Value_Node) = +declaration_item_ID and
then
+ Tree.ID (Tree.Child (Value_Node, 1)) in
+ +IDENTIFIER_ID | +STRING_LITERAL_1_ID |
+STRING_LITERAL_2_ID and then
+ Value = Get_Text (Data, Tree, Tree.Child
(Value_Node, 1), Strip_Quotes => True)
+ then
+ Found := True;
+ case Tree.Label (Tree.Child (Decl, 3)) is
+ when Shared_Terminal =>
+ Name_Ident := New_Identifier (Get_Text (Data,
Tree, Tree.Child (Decl, 3)));
+ when Virtual_Identifier =>
+ Name_Ident := Tree.Identifier (Tree.Child
(Decl, 3));
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+ end if;
+ end;
+ end if;
+
+ Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
+ exit when Temp = Invalid_Node_Index;
+ end loop;
+ end;
+
+ if not Found then
+ if GNAT.Regexp.Match (Value, Symbol_Regexp) then
+ Name_Ident := New_Identifier
(Ada.Characters.Handling.To_Upper (Value));
+ else
+ Put_Error
+ (Error_Message
+ (Data.Grammar_Lexer.File_Name, Get_Line (Data, Tree,
Node),
+ "punctuation token '" & Value & "' not declared"));
+ return;
+ end if;
+ end if;
+
+ declare
+ Parent : constant Valid_Node_Index := Tree.Parent (Node);
+ begin
+ case To_Token_Enum (Tree.ID (Parent)) is
+ when rhs_item_ID =>
+ Tree.Set_Children
+ (Tree.Parent (Node),
+ (+rhs_item_ID, 0),
+ (1 => Tree.Add_Identifier (+IDENTIFIER_ID, Name_Ident,
Tree.Byte_Region (Node))));
+
+ when rhs_optional_item_ID =>
+ Tree.Set_Children
+ (Tree.Parent (Node),
+ (+rhs_optional_item_ID, 2),
+ (1 => Tree.Add_Identifier (+IDENTIFIER_ID, Name_Ident,
Tree.Byte_Region (Node))));
+
+ when others =>
+ Raise_Programmer_Error ("translate_ebnf_to_bnf
string_literal_2 unimplemented", Tree, Node);
+ end case;
+ end;
+
+ Clear_EBNF_Node (Node);
+ if Found then return; end if;
+
+ -- Declare token for keyword string literal
+ declare
+ Keyword : constant Valid_Node_Index :=
Tree.Add_Identifier
+ (+KEYWORD_ID, Keyword_Ident, Tree.Byte_Region (Node));
+ Kind : constant Valid_Node_Index :=
Tree.Add_Nonterm
+ ((+token_keyword_non_grammar_ID, 0),
+ (1 => Keyword));
+ Value_Literal : constant Valid_Node_Index :=
Tree.Add_Identifier
+ (+STRING_LITERAL_1_ID, New_Identifier ('"' & Value & '"'),
Tree.Byte_Region (Node));
+ Decl_Item : constant Valid_Node_Index :=
Tree.Add_Nonterm
+ ((+declaration_item_ID, 1),
+ (1 => Value_Literal));
+ Decl_Item_List : constant Valid_Node_Index :=
Tree.Add_Nonterm
+ ((+declaration_item_list_ID, 0),
+ (1 => Decl_Item));
+
+ Percent : constant Valid_Node_Index := Tree.Add_Identifier
+ (+PERCENT_ID, Percent_Ident, Tree.Byte_Region (Node));
+ Name : constant Valid_Node_Index := Tree.Add_Identifier
+ (+IDENTIFIER_ID, Name_Ident, Tree.Byte_Region (Node));
+ Decl : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+declaration_ID, 0), (Percent, Kind, Name,
Decl_Item_List), Action => declaration_0'Access);
+ begin
+ Add_Compilation_Unit (Decl, Prepend => True);
+ end;
+ end;
+
+ when others =>
+ Raise_Programmer_Error ("unimplemented EBNF node", Tree, Node);
+ end case;
+ exception
+ when SAL.Programmer_Error =>
+ raise;
+ when E : others =>
+ Raise_Programmer_Error
+ ("unhandled exception " & Ada.Exceptions.Exception_Name (E) & ": " &
+ Ada.Exceptions.Exception_Message (E),
+ Tree, Node);
+ end Process_Node;
+
+ begin
+ -- Process nodes in node increasing order, so contained items are
+ -- translated first, so duplicates of the containing item can be found
+ for I in Data.EBNF_Nodes.First_Index .. Data.EBNF_Nodes.Last_Index loop
+ if Data.EBNF_Nodes (I) then
+ Process_Node (I);
+ end if;
+ end loop;
+
+ -- Processing copied nodes may produce more copied nodes, so we can't
+ -- use a 'for' loop.
+ declare
+ use all type SAL.Base_Peek_Type;
+ I : SAL.Base_Peek_Type := Copied_EBNF_Nodes.First_Index;
+ begin
+ loop
+ exit when I > Copied_EBNF_Nodes.Last_Index;
+ Process_Node (Copied_EBNF_Nodes (I));
+ I := I + 1;
+ end loop;
+ end;
+
+ Data.Meta_Syntax := BNF_Syntax;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Identifiers:");
+ for I in Data.Tokens.Virtual_Identifiers.First_Index ..
Data.Tokens.Virtual_Identifiers.Last_Index loop
+ Ada.Text_IO.Put_Line (Base_Identifier_Index'Image (I) & " " &
(-Data.Tokens.Virtual_Identifiers (I)));
+ end loop;
+ end if;
+ exception
+ when E : SAL.Not_Implemented =>
+ Ada.Text_IO.Put_Line
+ (Ada.Text_IO.Standard_Error, "Translate_EBNF_To_BNF not implemented: "
& Ada.Exceptions.Exception_Message (E));
+ end Translate_EBNF_To_BNF;
+
+ procedure Print_Source
+ (File_Name : in String;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Data : in User_Data_Type)
+ is
+ use Ada.Text_IO;
+ use WisiToken.Syntax_Trees;
+ File : File_Type;
+ Comments_Include_Newline : Boolean;
+
+ procedure Put_Comments (Node : in Valid_Node_Index)
+ is
+ Token : constant Base_Token_Index := Tree.Max_Terminal_Index (Node);
+ begin
+ -- Not all tokens have trailing non_grammar, so Data.Non_Grammar may
+ -- not have entries for every token.
+ Comments_Include_Newline := False;
+ if Token /= Invalid_Token_Index and then
+ Token in Data.Non_Grammar.First_Index .. Data.Non_Grammar.Last_Index
+ then
+ declare
+ Tokens : Base_Token_Arrays.Vector renames Data.Non_Grammar
(Token);
+ begin
+ for Token of Tokens loop
+ if Token.ID = +NEW_LINE_ID then
+ Comments_Include_Newline := True;
+ end if;
+ Put (File, Data.Grammar_Lexer.Buffer_Text
(Token.Byte_Region));
+ end loop;
+ end;
+ end if;
+ end Put_Comments;
+
+ procedure Put_Declaration_Item (Node : in Valid_Node_Index)
+ is
+ Children : constant Valid_Node_Index_Array := Tree.Children (Node);
+ begin
+ case To_Token_Enum (Tree.ID (Children (1))) is
+ when IDENTIFIER_ID | NUMERIC_LITERAL_ID | STRING_LITERAL_1_ID |
STRING_LITERAL_2_ID =>
+ Put (File, ' ' & Get_Text (Data, Tree, Children (1)));
+ when REGEXP_ID =>
+ Put (File, " %[" & Get_Text (Data, Tree, Children (1)) & "]%");
+ when others =>
+ Put (File, Image (Tree.ID (Children (1)),
Wisitoken_Grammar_Actions.Descriptor));
+ end case;
+ end Put_Declaration_Item;
+
+ procedure Put_Declaration_Item_List (Node : in Valid_Node_Index)
+ is
+ Children : constant Valid_Node_Index_Array := Tree.Children (Node);
+ begin
+ if Children'Length = 1 then
+ Put_Declaration_Item (Children (1));
+ else
+ Put_Declaration_Item_List (Children (1));
+ Put_Declaration_Item (Children (2));
+ end if;
+ end Put_Declaration_Item_List;
+
+ procedure Put_Identifier_List (Node : in Valid_Node_Index)
+ is
+ Children : constant Valid_Node_Index_Array := Tree.Children (Node);
+ begin
+ if Children'Length = 1 then
+ Put (File, Get_Text (Data, Tree, Children (1)));
+ else
+ Put_Identifier_List (Children (1));
+ Put (File, ' ');
+ Put (File, Get_Text (Data, Tree, Children (2)));
+ end if;
+ end Put_Identifier_List;
+
+ procedure Put_RHS_Element (Node : in Valid_Node_Index)
+ with Pre => Tree.ID (Node) = +rhs_element_ID
+ is begin
+ -- We don't raise an exception for errors here; it's easier to debug
from the
+ -- mangled source listing.
+
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ Put (File, Get_Text (Data, Tree, Node));
+
+ when 1 =>
+ -- Output no spaces around "="
+ declare
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
+ begin
+ Put (File, Get_Text (Data, Tree, Children (1)) & "=" & Get_Text
(Data, Tree, Children (3)));
+ end;
+
+ when others =>
+ New_Line (File);
+ Put (File, " ;; not translated: " & Node_Index'Image (Node) & ":" &
+ Tree.Image (Node, Wisitoken_Grammar_Actions.Descriptor,
Include_Children => True));
+ end case;
+ exception
+ when SAL.Programmer_Error =>
+ raise;
+
+ when E : others =>
+ declare
+ use Ada.Exceptions;
+ begin
+ Raise_Programmer_Error
+ ("Put_RHS_Element: " & Exception_Name (E) & ": " &
Exception_Message (E), Tree, Node);
+ end;
+ end Put_RHS_Element;
+
+ procedure Put_RHS_Item_List (Node : in Valid_Node_Index)
+ with Pre => Tree.ID (Node) = +rhs_item_list_ID
+ is
+ Children : constant Valid_Node_Index_Array := Tree.Children (Node);
+ begin
+ if Children'Length = 1 then
+ Put_RHS_Element (Children (1));
+ else
+ Put_RHS_Item_List (Children (1));
+ Put (File, ' ');
+ Put_RHS_Element (Children (2));
+ end if;
+ exception
+ when SAL.Programmer_Error =>
+ raise;
+
+ when E : others =>
+ declare
+ use Ada.Exceptions;
+ begin
+ Raise_Programmer_Error
+ ("Put_RHS_Item_List: " & Exception_Name (E) & ": " &
Exception_Message (E), Tree, Node);
+ end;
+ end Put_RHS_Item_List;
+
+ procedure Put_RHS
+ (Node : in Valid_Node_Index;
+ First : in Boolean;
+ Virtual : in Boolean)
+ with Pre => Tree.ID (Node) = +rhs_ID
+ is
+ Children : constant Valid_Node_Index_Array := Tree.Children (Node);
+ begin
+ Put (File, (if First then " : " else " | "));
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ if Virtual then
+ Put_Line (File, ";; empty");
+ else
+ Put_Comments (Tree.Parent (Node));
+ end if;
+
+ when 1 .. 3 =>
+ Put_RHS_Item_List (Children (1));
+ if Virtual then
+ New_Line (File);
+ else
+ Put_Comments (Children (1));
+ end if;
+
+ if Tree.RHS_Index (Node) > 1 then
+ Put (File, " %(" & Get_Text (Data, Tree, Children (2)) &
")%"); -- action
+ if Virtual then
+ New_Line (File);
+ else
+ Put_Comments (Children (2));
+ end if;
+ if Tree.RHS_Index (Node) > 2 then
+ Put (File, " %(" & Get_Text (Data, Tree, Children (3)) &
")%"); -- check
+ if Virtual then
+ New_Line (File);
+ else
+ Put_Comments (Children (3));
+ end if;
+ end if;
+ end if;
+
+ when others =>
+ Raise_Programmer_Error ("Put_RHS", Tree, Node);
+ end case;
+ exception
+ when SAL.Programmer_Error =>
+ raise;
+
+ when E : others =>
+ declare
+ use Ada.Exceptions;
+ begin
+ Raise_Programmer_Error ("Put_RHS: " & Exception_Name (E) & ": " &
Exception_Message (E), Tree, Node);
+ end;
+ end Put_RHS;
+
+ procedure Put_RHS_List
+ (Node : in Valid_Node_Index;
+ First : in out Boolean;
+ Virtual : in Boolean)
+ with Pre => Tree.ID (Node) = +rhs_list_ID
+ is
+ Children : constant Valid_Node_Index_Array := Tree.Children (Node);
+ begin
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ Put_RHS (Children (1), First, Virtual or Children (1) >
Data.EBNF_Nodes.Last_Index);
+ First := False;
+ when 1 =>
+ Put_RHS_List (Children (1), First, Virtual);
+ Put_RHS (Children (3), First => False, Virtual => Virtual or
Children (3) > Data.EBNF_Nodes.Last_Index);
+ when 2 =>
+ Put
+ (File, "%if " & Get_Text (Data, Tree, Children (3)) & " = " &
Get_Text (Data, Tree, Children (4)));
+ Put_Comments (Node);
+
+ when 3 =>
+ Put (File, "%end if");
+ Put_Comments (Node);
+
+ when others =>
+ Raise_Programmer_Error ("Put_RHS_List", Tree, Node);
+ end case;
+ exception
+ when SAL.Programmer_Error =>
+ raise;
+
+ when E : others =>
+ declare
+ use Ada.Exceptions;
+ begin
+ Raise_Programmer_Error ("Put_RHS_List: " & Exception_Name (E) & ":
" & Exception_Message (E), Tree, Node);
+ end;
+ end Put_RHS_List;
+
+ procedure Process_Node (Node : in Valid_Node_Index)
+ is begin
+ case To_Token_Enum (Tree.ID (Node)) is
+ -- Enum_Token_ID alphabetical order
+ when compilation_unit_ID =>
+ Process_Node (Tree.Child (Node, 1));
+
+ when compilation_unit_list_ID =>
+ declare
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
+ begin
+ case To_Token_Enum (Tree.ID (Children (1))) is
+ when compilation_unit_list_ID =>
+ Process_Node (Children (1));
+ Process_Node (Children (2));
+ when compilation_unit_ID =>
+ Process_Node (Children (1));
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+ end;
+
+ when declaration_ID =>
+ declare
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
+ begin
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ case Tree.RHS_Index (Children (2)) is
+ when 0 =>
+ Put (File, "%keyword");
+ when 1 =>
+ Put (File, "%non_grammar <" & Get_Text (Data, Tree,
Tree.Child (Children (2), 3)) & ">");
+ when 2 =>
+ Put (File, "%token <" & Get_Text (Data, Tree, Tree.Child
(Children (2), 3)) & ">");
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+
+ Put (File, " " & Get_Text (Data, Tree, Children (3)));
+ Put_Declaration_Item_List (Children (4));
+ if Tree.Is_Virtual (Children (4)) then
+ New_Line (File);
+ else
+ Put_Comments (Children (4));
+ end if;
+
+ when 1 =>
+ Put (File, "%code ");
+ Put_Identifier_List (Children (3));
+ Put (File, " %{" & Get_Text (Data, Tree, Children (4)) &
"}%"); -- RAW_CODE
+ Put_Comments (Node);
+
+ when 2 =>
+ declare
+ Key : constant String := Get_Text (Data, Tree, Children
(2));
+ begin
+ if Key = "conflict" then
+ Put (File, Data.Grammar_Lexer.Buffer_Text
(Tree.Byte_Region (Node)));
+ else
+ Put (File, "%" & Key);
+ Put_Declaration_Item_List (Children (3));
+ end if;
+ end;
+ Put_Comments (Children (3));
+
+ when 3 =>
+ Put (File, "%" & Get_Text (Data, Tree, Children (2)));
+ Put_Comments (Children (2));
+
+ when 4 =>
+ Put
+ (File, "%if" & Get_Text (Data, Tree, Children (2)) & " = "
& Get_Text (Data, Tree, Children (4)));
+ Put_Comments (Node);
+
+ when 5 =>
+ Put (File, "%end if");
+ Put_Comments (Node);
+
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+ end;
+
+ when nonterminal_ID =>
+ declare
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
+ Virtual : constant Boolean := Tree.Label
(Children (1)) = Virtual_Identifier;
+ First : Boolean := True;
+ begin
+ Put (File, Get_Text (Data, Tree, Children (1)));
+ if Virtual then
+ New_Line (File);
+ else
+ Put_Comments (Children (1));
+ if not Comments_Include_Newline then
+ New_Line (File);
+ end if;
+ end if;
+
+ Put_RHS_List (Children (3), First, Virtual);
+
+ if Tree.Children (Children (4))'Length > 0 then
+ if Virtual then
+ Put_Line (File, " ;");
+ else
+ Put (File, " ;");
+ Put_Comments (Children (4));
+ end if;
+ end if;
+ end;
+
+ when wisitoken_accept_ID =>
+ Process_Node (Tree.Child (Node, 1));
+
+ when others =>
+ raise SAL.Not_Implemented with Image (Tree.ID (Node),
Wisitoken_Grammar_Actions.Descriptor);
+ end case;
+ end Process_Node;
+ begin
+ Create (File, Out_File, File_Name);
+ Put_Line (File, ";;; generated from " & Data.Grammar_Lexer.File_Name & "
-*- buffer-read-only:t -*-");
+ Put_Line (File, ";;;");
+
+ declare
+ Tokens : Base_Token_Arrays.Vector renames Data.Non_Grammar (0);
+ begin
+ for Token of Tokens loop
+ Put (File, Data.Grammar_Lexer.Buffer_Text (Token.Byte_Region));
+ end loop;
+ end;
+
+ Process_Node (Tree.Root);
+
+ Close (File);
+ exception
+ when E : SAL.Not_Implemented =>
+ Close (File);
+ Ada.Text_IO.Put_Line
+ (Ada.Text_IO.Standard_Error, "Print_Source not implemented: " &
Ada.Exceptions.Exception_Message (E));
+ end Print_Source;
+
end WisiToken_Grammar_Runtime;
+-- Local Variables:
+-- ada-which-func-parse-size: 30000
+-- End:
diff --git a/wisitoken_grammar_runtime.ads b/wisitoken_grammar_runtime.ads
index 9c9d0ac..df848a9 100644
--- a/wisitoken_grammar_runtime.ads
+++ b/wisitoken_grammar_runtime.ads
@@ -2,7 +2,7 @@
--
-- Runtime utils for wisi_grammar.wy actions.
--
--- Copyright (C) 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -17,11 +17,22 @@
pragma License (Modified_GPL);
+with Ada.Containers;
+with SAL.Gen_Unbounded_Definite_Vectors;
with WisiToken.BNF;
with WisiToken.Lexer;
with WisiToken.Syntax_Trees;
package WisiToken_Grammar_Runtime is
+ type Meta_Syntax is (Unknown, BNF_Syntax, EBNF_Syntax);
+ -- Syntax used in grammar file.
+
+ type Action_Phase is (Meta, Other);
+
+ package Base_Token_Array_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (WisiToken.Base_Token_Index, WisiToken.Base_Token_Arrays.Vector,
+ Default_Element => WisiToken.Base_Token_Arrays.Empty_Vector);
+
type User_Data_Type is new WisiToken.Syntax_Trees.User_Data_Type with
record
Grammar_Lexer : WisiToken.Lexer.Handle; -- used to read the .wy file now.
@@ -37,6 +48,12 @@ package WisiToken_Grammar_Runtime is
Generate_Set : WisiToken.BNF.Generate_Set_Access;
-- As specified by %generate directives or command line.
+ Phase : Action_Phase := Meta;
+ -- Determines which actions Execute_Actions executes:
+ -- Meta - meta declarations, like %meta_syntax, %generate
+ -- Other - everything else
+
+ Meta_Syntax : WisiToken_Grammar_Runtime.Meta_Syntax := Unknown;
Terminals : WisiToken.Base_Token_Array_Access;
Raw_Code : WisiToken.BNF.Raw_Code;
Language_Params : WisiToken.BNF.Language_Param_Type;
@@ -44,16 +61,24 @@ package WisiToken_Grammar_Runtime is
Conflicts : WisiToken.BNF.Conflict_Lists.List;
McKenzie_Recover : WisiToken.BNF.McKenzie_Recover_Param_Type;
- Rule_Count : Integer := 0;
- Action_Count : Integer := 0;
- Check_Count : Integer := 0;
+ Non_Grammar : Base_Token_Array_Arrays.Vector;
+ -- Non_Grammar (0) contains leading blank lines and comments;
+ -- Non_Grammar (I) contains blank lines and comments following
+ -- Terminals (I). Only used in Print_Source.
+
+ Rule_Count : Integer := 0;
+ Action_Count : Integer := 0;
+ Check_Count : Integer := 0;
+ Label_Count : Ada.Containers.Count_Type := 0;
+
+ EBNF_Nodes : WisiToken.Syntax_Trees.Node_Sets.Vector;
If_Lexer_Present : Boolean := False;
If_Parser_Present : Boolean := False;
-- Set True by %if statements in Execute_Actions.
Ignore_Lines : Boolean := False;
- -- An '%if' specified a different lexer, during Excute_Actions
+ -- An '%if' specified a different lexer, during Execute_Actions
end record;
overriding
@@ -64,6 +89,17 @@ package WisiToken_Grammar_Runtime is
overriding procedure Reset (Data : in out User_Data_Type);
+ overriding
+ procedure Initialize_Actions
+ (Data : in out User_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree'Class);
+
+ overriding
+ procedure Lexer_To_Augmented
+ (Data : in out User_Data_Type;
+ Token : in WisiToken.Base_Token;
+ Lexer : not null access WisiToken.Lexer.Instance'Class);
+
procedure Start_If
(User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
Tree : in WisiToken.Syntax_Trees.Tree;
@@ -81,4 +117,25 @@ package WisiToken_Grammar_Runtime is
Tree : in WisiToken.Syntax_Trees.Tree;
Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure Check_EBNF
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Token : in WisiToken.Positive_Index_Type);
+
+ procedure Translate_EBNF_To_BNF
+ (Tree : in out WisiToken.Syntax_Trees.Tree;
+ Data : in out User_Data_Type);
+ -- Process EBNF nonterms, adding new nonterms as needed, resulting in
+ -- a BNF tree. Descriptor is used for error messages.
+ --
+ -- Generator.LR.*_Generate requires a BNF grammar.
+
+ procedure Print_Source
+ (File_Name : in String;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Data : in User_Data_Type);
+ -- Print the wisitoken grammar source represented by Tree, Terminals
+ -- to a new file File_Name.
+
end WisiToken_Grammar_Runtime;
- [elpa] externals/wisi bd1884c 02/35: Fix up copyright notices., (continued)
- [elpa] externals/wisi bd1884c 02/35: Fix up copyright notices., Stefan Monnier, 2020/11/28
- [elpa] externals/wisi c282a4b 13/35: update ada-mode, wisi, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 27db81d 17/35: Fix some quoting problems in doc strings, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 724a763 31/35: In wisi sal-gen_unbounded_definite_red_black_trees.adb, correct WORKAROUND, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi abbb0c2 19/35: Release wisi 1.1.4, ada-mode 5.2.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 5becb56 29/35: Release ada-mode 7.0.1, wisi 3.0.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 2114f5a 28/35: In ada-mode and wisi, release ada-mode 6.2.1, wisi 2.2.1; fix packaging bugs, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 2636b79 25/35: Release ada-mode 6.1.0, wisi 2.1.0, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi dd09dcf 35/35: * .gitignore: New file, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 232d669 18/35: Release: ada-mode: version 5.2.0. wisi: version 1.1.3, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi c7f61e5 26/35: In ada-mode, wisi; release ada-mode 6.1.1, wisi 2.1.1,
Stefan Monnier <=
- [elpa] externals/wisi 66d7e59 27/35: In ada-mode, wisi: release Ada mode 6.2.0, wisi 1.2.0., Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 1dc8c19 12/35: release ada-mode 5.1.7, wisi 1.1.0; minor format changes in ada-ref-man (take 2), Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 5934bfc 06/35: release ada-mode 5.1.0, wisi 1.0.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi d9cd208 32/35: In ada-mode, release 7.1.3; in wisi, release 3.1.2, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi c80e75d 30/35: Release ada-mode 7.1.0, wisi 3.1.0, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 4d8af96 05/35: update to Ada mode version 5.0.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 8a5302b 09/35: ada-mode 5.1.3, wisi 1.0.4, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 01c34d0 33/35: In wisi, missed a few files in 3.1.2 release, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 0e04e18 08/35: ada-mode, wisi: bump versions again; forgot to add some files to git, Stefan Monnier, 2020/11/28