[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/wisi 2636b79 25/35: Release ada-mode 6.1.0, wisi 2.1.0
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] externals/wisi 2636b79 25/35: Release ada-mode 6.1.0, wisi 2.1.0 |
|
Date: |
Sat, 28 Nov 2020 14:47:55 -0500 (EST) |
branch: externals/wisi
commit 2636b79193a948487a52be4c7b35e96a4e3be45d
Author: Stephen Leake <stephen_leake@stephe-leake.org>
Commit: Stephen Leake <stephen_leake@stephe-leake.org>
Release ada-mode 6.1.0, wisi 2.1.0
---
NEWS | 13 +
README | 4 +-
build-wisitoken-bnf-generate.sh | 0
sal-gen_array_image.adb | 34 +
sal-gen_array_image.ads | 24 +
sal-gen_bounded_definite_vectors.ads | 6 +-
sal-gen_definite_doubly_linked_lists.ads | 6 +-
sal-gen_definite_doubly_linked_lists_sorted.ads | 8 +-
sal-gen_indefinite_doubly_linked_lists.ads | 5 +-
sal-gen_unbounded_definite_min_heaps_fibonacci.adb | 33 +-
sal-gen_unbounded_definite_min_heaps_fibonacci.ads | 13 +-
sal-gen_unbounded_definite_queues.ads | 4 +-
sal-gen_unbounded_definite_red_black_trees.ads | 5 +-
sal-gen_unbounded_definite_stacks.ads | 3 +-
sal-gen_unbounded_definite_vectors.adb | 27 +-
sal-gen_unbounded_definite_vectors.ads | 23 +-
sal.adb | 4 +-
standard_common.gpr | 29 +-
wisi-elisp-parse.el | 46 +-
wisi-fringe.el | 10 +-
wisi-parse-common.el | 694 +++---
wisi-process-parse.el | 228 +-
wisi.adb | 404 +++-
wisi.ads | 56 +-
wisi.el | 581 +++--
wisitoken-bnf-generate.adb | 4 +-
wisitoken-bnf-generate_utils.adb | 14 +-
wisitoken-bnf-generate_utils.ads | 2 +-
wisitoken-bnf-output_ada.adb | 13 +-
wisitoken-bnf-output_ada_common.adb | 62 +-
wisitoken-bnf-output_ada_emacs.adb | 156 +-
wisitoken-bnf.ads | 15 +-
wisitoken-gen_token_enum.ads | 6 +-
wisitoken-generate-lr-lalr_generate.adb | 21 +-
wisitoken-generate-lr-lalr_generate.ads | 19 +-
wisitoken-generate-lr-lr1_generate.adb | 28 +-
wisitoken-generate-lr-lr1_generate.ads | 11 +-
wisitoken-generate-lr.adb | 2397 ++++++++++----------
wisitoken-generate-lr.ads | 59 +-
wisitoken-generate-lr1_items.adb | 30 +-
wisitoken-generate-lr1_items.ads | 17 +-
wisitoken-generate.adb | 63 +-
wisitoken-generate.ads | 17 +-
wisitoken-lexer-re2c.adb | 146 +-
wisitoken-lexer-re2c.ads | 35 +-
wisitoken-lexer-regexp.adb | 48 +-
wisitoken-lexer-regexp.ads | 34 +-
wisitoken-lexer.adb | 7 +-
wisitoken-lexer.ads | 52 +-
wisitoken-parse-lr-mckenzie_recover-base.ads | 5 +-
wisitoken-parse-lr-mckenzie_recover-explore.adb | 457 ++--
wisitoken-parse-lr-mckenzie_recover-parse.adb | 12 +-
wisitoken-parse-lr-mckenzie_recover.adb | 291 ++-
wisitoken-parse-lr-mckenzie_recover.ads | 25 +-
wisitoken-parse-lr-parser.adb | 387 ++--
wisitoken-parse-lr-parser.ads | 27 +-
wisitoken-parse-lr-parser_lists.adb | 31 +-
wisitoken-parse-lr-parser_lists.ads | 29 +-
wisitoken-parse-lr-parser_no_recover.adb | 1002 ++++----
wisitoken-parse-lr-parser_no_recover.ads | 4 +-
wisitoken-parse-lr.adb | 246 +-
wisitoken-parse-lr.ads | 56 +-
wisitoken-parse-packrat-generated.adb | 9 +-
wisitoken-parse-packrat-generated.ads | 9 +-
wisitoken-parse-packrat-procedural.adb | 7 +-
wisitoken-parse-packrat-procedural.ads | 7 +-
wisitoken-parse.adb | 6 +-
wisitoken-parse.ads | 7 +-
wisitoken-parse_table-mode.el | 96 +
wisitoken-productions.ads | 16 +-
wisitoken-semantic_checks.adb | 19 +-
wisitoken-semantic_checks.ads | 18 +-
wisitoken-syntax_trees.adb | 89 +-
wisitoken-syntax_trees.ads | 36 +-
wisitoken-text_io_trace.adb | 55 +-
wisitoken-text_io_trace.ads | 13 +-
wisitoken-user_guide.info | 16 +-
wisitoken.adb | 4 +-
wisitoken.ads | 881 +++----
wisitoken_grammar_actions.ads | 2 +-
wisitoken_grammar_main.adb | 64 +-
wisitoken_grammar_re2c.c | 143 +-
wisitoken_grammar_runtime.adb | 11 +-
wisitoken_grammar_runtime.ads | 1 -
84 files changed, 5494 insertions(+), 4103 deletions(-)
diff --git a/NEWS b/NEWS
index a594bea..22fe4e4 100644
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,19 @@ 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 2.1.0
+21 Mar 2019
+
+** Add support for partial parsing; useful in very large files. Files
+ larger than wisi-partial-parse-threshold (default 100_001) will be
+ parsed partially.
+
+** Miscellaneous speed-ups in the Ada code; 'pragma Inline', better use of Ada
tasks.
+
+** Better error correction in the Ada process parser; insert minimimal
+ tokens to complete a statement/declaration before or after the error
+ point.
+
* wisi 2.0.1
8 Dec 2018
diff --git a/README b/README
index 0435747..db1af26 100644
--- a/README
+++ b/README
@@ -1,7 +1,9 @@
-Emacs wisi package 2.0.0
+Emacs wisi package 2.1.0
The wisi package provides utilities for using generalized LALR parsers
(in elisp or external processes) to do indentation, fontification, and
navigation. See ada-mode for an example of its use.
+It also provides wisitoken-parse_table-mode, for navigating the
+diagnostic parse tables output by wisitoken-bnf-generate.
diff --git a/build-wisitoken-bnf-generate.sh b/build-wisitoken-bnf-generate.sh
old mode 100644
new mode 100755
diff --git a/sal-gen_array_image.adb b/sal-gen_array_image.adb
new file mode 100644
index 0000000..7f9097d
--- /dev/null
+++ b/sal-gen_array_image.adb
@@ -0,0 +1,34 @@
+-- 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; use Ada.Strings.Unbounded;
+function SAL.Gen_Array_Image (Item : in Array_Type) return String
+is
+ Result : Unbounded_String := To_Unbounded_String ("(");
+begin
+ for I in Item'Range loop
+ Result := Result & Element_Image (Item (I));
+ if I = Item'Last then
+ Result := Result & ")";
+ else
+ Result := Result & ", ";
+ end if;
+ end loop;
+ return To_String (Result);
+end SAL.Gen_Array_Image;
diff --git a/sal-gen_array_image.ads b/sal-gen_array_image.ads
new file mode 100644
index 0000000..53bd25f
--- /dev/null
+++ b/sal-gen_array_image.ads
@@ -0,0 +1,24 @@
+-- Abstract :
+--
+-- Image for normal Ada array types
+--
+-- 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);
+generic
+ type Index_Type is (<>);
+ type Element_Type is private;
+ type Array_Type is array (Index_Type) of Element_Type;
+ with function Element_Image (Item : in Element_Type) return String;
+function SAL.Gen_Array_Image (Item : in Array_Type) return String;
diff --git a/sal-gen_bounded_definite_vectors.ads
b/sal-gen_bounded_definite_vectors.ads
index 04a9ff1..9747704 100644
--- a/sal-gen_bounded_definite_vectors.ads
+++ b/sal-gen_bounded_definite_vectors.ads
@@ -3,7 +3,7 @@
-- A simple bounded vector of definite items, intended to be faster
-- than Ada.Containers.Bounded_Definite_Vectors.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -80,6 +80,7 @@ package SAL.Gen_Bounded_Definite_Vectors is
with Implicit_Dereference => Element;
function Constant_Reference (Container : aliased Vector; Index : in
Index_Type) return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
type Variable_Reference_Type (Element : not null access Element_Type) is
null record
with Implicit_Dereference => Element;
@@ -88,6 +89,7 @@ package SAL.Gen_Bounded_Definite_Vectors is
(Container : aliased in out Vector;
Index : in Index_Type)
return Variable_Reference_Type;
+ pragma Inline (Variable_Reference);
type Cursor is private;
@@ -98,11 +100,13 @@ package SAL.Gen_Bounded_Definite_Vectors is
function Iterate (Container : Vector) return
Vector_Iterator_Interfaces.Reversible_Iterator'Class;
function Constant_Reference (Container : aliased Vector; Position : in
Cursor) return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
function Variable_Reference
(Container : aliased in out Vector;
Position : in Cursor)
return Variable_Reference_Type;
+ pragma Inline (Variable_Reference);
private
diff --git a/sal-gen_definite_doubly_linked_lists.ads
b/sal-gen_definite_doubly_linked_lists.ads
index 04a10f1..fda94c4 100644
--- a/sal-gen_definite_doubly_linked_lists.ads
+++ b/sal-gen_definite_doubly_linked_lists.ads
@@ -3,7 +3,7 @@
-- A generic doubly linked list with definite elements, allowing
-- permanent references to elements.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -97,16 +97,20 @@ package SAL.Gen_Definite_Doubly_Linked_Lists is
function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type
with Pre => Position /= No_Element;
+ pragma Inline (Constant_Reference);
function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
with Pre => Position /= No_Element;
+ pragma Inline (Constant_Ref);
type Reference_Type (Element : not null access Element_Type) is null record
with Implicit_Dereference => Element;
function Reference (Container : in List; Position : in Cursor) return
Reference_Type
with Pre => Position /= No_Element;
+ pragma Inline (Reference);
function Ref (Position : in Cursor) return Reference_Type
with Pre => Position /= No_Element;
+ pragma Inline (Ref);
package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
diff --git a/sal-gen_definite_doubly_linked_lists_sorted.ads
b/sal-gen_definite_doubly_linked_lists_sorted.ads
index b3d5431..d57748b 100644
--- a/sal-gen_definite_doubly_linked_lists_sorted.ads
+++ b/sal-gen_definite_doubly_linked_lists_sorted.ads
@@ -2,7 +2,7 @@
--
-- A generic sorted doubly linked list with definite elements.
--
--- 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
@@ -47,6 +47,8 @@ package SAL.Gen_Definite_Doubly_Linked_Lists_Sorted is
overriding procedure Finalize (Container : in out List);
-- Free all items in List.
+ procedure Clear (Container : in out List) renames Finalize;
+
overriding function "=" (Left, Right : in List) return Boolean;
-- True if contents are the same.
@@ -113,15 +115,19 @@ package SAL.Gen_Definite_Doubly_Linked_Lists_Sorted is
with Implicit_Dereference => Element;
function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
function Constant_Ref (Position : in Cursor) return Constant_Reference_Type;
+ pragma Inline (Constant_Ref);
type Reference_Type (Element : not null access Element_Type) is null record
with Implicit_Dereference => Element;
function Reference (Container : in List; Position : in Cursor) return
Reference_Type
with Pre => Position /= No_Element;
+ pragma Inline (Reference);
function Ref (Position : in Cursor) return Reference_Type
with Pre => Position /= No_Element;
+ pragma Inline (Ref);
-- User must not change the element in a way that affects the sort order.
package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
diff --git a/sal-gen_indefinite_doubly_linked_lists.ads
b/sal-gen_indefinite_doubly_linked_lists.ads
index 5898bc7..0ebfc54 100644
--- a/sal-gen_indefinite_doubly_linked_lists.ads
+++ b/sal-gen_indefinite_doubly_linked_lists.ads
@@ -3,7 +3,7 @@
-- A generic doubly linked list with indefinite elements, allowing
-- permanent references to elements.
--
--- 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
@@ -71,15 +71,18 @@ package SAL.Gen_Indefinite_Doubly_Linked_Lists is
function Constant_Reference (Position : in Cursor) return
Constant_Reference_Type
with Pre => Has_Element (Position);
+ pragma Inline (Constant_Reference);
function Constant_Ref (Container : in List'Class; Position : in Peek_Type)
return Constant_Reference_Type
with Pre => Position <= Container.Length;
+ pragma Inline (Constant_Ref);
type Reference_Type (Element : not null access Element_Type) is null record
with Implicit_Dereference => Element;
function Reference (Position : in Cursor) return Reference_Type
with Pre => Has_Element (Position);
+ pragma Inline (Reference);
private
type Node_Type;
diff --git a/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
b/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
index e35219e..c58a9d4 100644
--- a/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
+++ b/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -337,4 +337,35 @@ package body
SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci is
return (Element => Heap.Min.all.Element'Access);
end Peek;
+ procedure Process (Heap : in Heap_Type; Process_Element : access procedure
(Element : in Element_Type))
+ is
+ type Cursor is record
+ -- Every node is in a circular list. List_Origin is the node where we
+ -- entered the list, so we know when we are done.
+ Node : Node_Access;
+ List_Origin : Node_Access;
+ end record;
+
+ Cur : Cursor := (Heap.Min, Heap.Min);
+
+ procedure Process_Node (Cur : in out Cursor)
+ is
+ Next_Cur : Cursor;
+ begin
+ loop
+ if Cur.Node.Child /= null then
+ Next_Cur := (Cur.Node.Child, Cur.Node.Child);
+ Process_Node (Next_Cur);
+ end if;
+ Process_Element (Cur.Node.Element);
+ Cur.Node := Cur.Node.Right;
+ exit when Cur.Node = Cur.List_Origin;
+ end loop;
+ end Process_Node;
+ begin
+ if Cur.Node /= null then
+ Process_Node (Cur);
+ end if;
+ end Process;
+
end SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci;
diff --git a/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
b/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
index 09b4e39..6f978e7 100644
--- a/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
+++ b/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
@@ -7,7 +7,7 @@
-- [1] Introduction to Algorithms, Third Edition. Thomas H. Cormen,
-- Charles E. Leiserson, Ronald L. Rivest, Clifford Stein. Chapter 19.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -88,6 +88,15 @@ package SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci is
function Peek (Heap : in Heap_Type) return Constant_Reference_Type;
-- Return a constant reference to the min element.
+ pragma Inline (Peek);
+
+ -- We don't provide a Cursor/Iterator interface; to complex to
+ -- implement. So far, we only need a read-only forward iterator,
+ -- which Process provides.
+
+ procedure Process (Heap : in Heap_Type; Process_Element : access procedure
(Element : in Element_Type));
+ -- Call Process_Element with each Element in Heap. Min is first; rest are
in
+ -- arbitrary order.
private
@@ -108,6 +117,8 @@ private
Min : Node_Access;
Count : Base_Peek_Type;
end record;
+ type Heap_Access_Constant is access constant Heap_Type;
+ for Heap_Access_Constant'Storage_Size use 0;
Empty_Heap : constant Heap_Type := (Ada.Finalization.Controlled with Min =>
null, Count => 0);
diff --git a/sal-gen_unbounded_definite_queues.ads
b/sal-gen_unbounded_definite_queues.ads
index 0e21be7..8e7163b 100644
--- a/sal-gen_unbounded_definite_queues.ads
+++ b/sal-gen_unbounded_definite_queues.ads
@@ -2,7 +2,7 @@
--
-- An unbounded queue of definite non-limited elements.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -59,6 +59,7 @@ package SAL.Gen_Unbounded_Definite_Queues is
Implicit_Dereference => Element;
function Peek (Queue : in Pkg.Queue; N : Peek_Type := 1) return
Constant_Reference_Type;
+ pragma Inline (Peek);
-- Return a constant reference to a queue item. N = 1 is the queue
-- head.
--
@@ -68,6 +69,7 @@ package SAL.Gen_Unbounded_Definite_Queues is
with Implicit_Dereference => Element;
function Variable_Peek (Queue : in out Pkg.Queue; N : Peek_Type := 1)
return Variable_Reference_Type;
+ pragma Inline (Variable_Peek);
-- Return a variable reference to a queue item. N = 1 is the queue
-- head.
--
diff --git a/sal-gen_unbounded_definite_red_black_trees.ads
b/sal-gen_unbounded_definite_red_black_trees.ads
index e9513c9..83c9c88 100644
--- a/sal-gen_unbounded_definite_red_black_trees.ads
+++ b/sal-gen_unbounded_definite_red_black_trees.ads
@@ -8,7 +8,7 @@
-- [1] Introduction to Algorithms, Thomas H. Cormen, Charles E.
-- Leiserson, Ronald L. Rivest, Clifford Stein.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -70,6 +70,7 @@ package SAL.Gen_Unbounded_Definite_Red_Black_Trees is
(Container : aliased in Tree;
Key : in Key_Type)
return Constant_Ref_Type;
+ pragma Inline (Constant_Ref);
type Variable_Ref_Type (Element : not null access Element_Type) is null
record
with Implicit_Dereference => Element;
@@ -78,11 +79,13 @@ package SAL.Gen_Unbounded_Definite_Red_Black_Trees is
(Container : aliased in Tree;
Position : in Cursor)
return Variable_Ref_Type;
+ pragma Inline (Variable_Ref);
function Variable_Ref
(Container : aliased in Tree;
Key : in Key_Type)
return Variable_Ref_Type;
+ pragma Inline (Variable_Ref);
-- Raises Not_Found if Key not found in Container.
package Iterators is new Ada.Iterator_Interfaces (Cursor, Has_Element);
diff --git a/sal-gen_unbounded_definite_stacks.ads
b/sal-gen_unbounded_definite_stacks.ads
index b0cb65c..954be19 100644
--- a/sal-gen_unbounded_definite_stacks.ads
+++ b/sal-gen_unbounded_definite_stacks.ads
@@ -2,7 +2,7 @@
--
-- Stack implementation.
--
--- Copyright (C) 1998-2000, 2002-2003, 2009, 2015, 2017, 2018 Free Software
Foundation, Inc.
+-- Copyright (C) 1998-2000, 2002-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
@@ -113,6 +113,7 @@ package SAL.Gen_Unbounded_Definite_Stacks is
(Container : aliased in Stack'Class;
Position : in Peek_Type)
return Constant_Ref_Type;
+ pragma Inline (Constant_Ref);
private
diff --git a/sal-gen_unbounded_definite_vectors.adb
b/sal-gen_unbounded_definite_vectors.adb
index 74f3497..49d59a6 100644
--- a/sal-gen_unbounded_definite_vectors.adb
+++ b/sal-gen_unbounded_definite_vectors.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
@@ -352,7 +352,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
if Container.Last >= First then
if Container.Elements = null then
- Container.Elements := new Array_Type'(J .. To_Peek_Type
(Container.Last) => <>);
+ Container.Elements := new Array_Type'(J .. To_Peek_Type
(Container.Last) => Default_Element);
elsif Container.Elements'First > J then
Grow (Container.Elements, J);
@@ -371,7 +371,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
if Last >= Container.First then
if Container.Elements = null then
- Container.Elements := new Array_Type'(To_Peek_Type
(Container.First) .. J => <>);
+ Container.Elements := new Array_Type'(To_Peek_Type
(Container.First) .. J => Default_Element);
elsif Container.Elements'Last < J then
Grow (Container.Elements, J);
@@ -379,7 +379,10 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
end if;
end Set_Last;
- procedure Set_First_Last (Container : in out Vector; First : in Index_Type;
Last : in Extended_Index)
+ procedure Set_First_Last
+ (Container : in out Vector;
+ First : in Index_Type;
+ Last : in Extended_Index)
is begin
Set_First (Container, First);
Set_Last (Container, Last);
@@ -398,22 +401,6 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
end if;
end Set_Length;
- procedure Set_Length
- (Container : in out Vector;
- Length : in Ada.Containers.Count_Type;
- Default : in Element_Type)
- is
- Old_First : constant Extended_Index := Container.First;
- Old_Last : constant Extended_Index := Container.Last;
- begin
- Set_Length (Container, Length);
- if Old_First = No_Index then
- Container.Elements.all := (others => Default);
- else
- Container.Elements (To_Peek_Type (Old_Last + 1) .. To_Peek_Type
(Container.Last)) := (others => Default);
- end if;
- end Set_Length;
-
procedure Delete (Container : in out Vector; Index : in Index_Type)
is
J : constant Peek_Type := To_Peek_Type (Index);
diff --git a/sal-gen_unbounded_definite_vectors.ads
b/sal-gen_unbounded_definite_vectors.ads
index 6ad1684..ae472d8 100644
--- a/sal-gen_unbounded_definite_vectors.ads
+++ b/sal-gen_unbounded_definite_vectors.ads
@@ -8,7 +8,7 @@
-- It provides no checking of cursor tampering; higher level code
-- must ensure that.
--
--- 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
@@ -29,6 +29,7 @@ with Ada.Unchecked_Deallocation;
generic
type Index_Type is range <>;
type Element_Type is private;
+ Default_Element : in Element_Type;
package SAL.Gen_Unbounded_Definite_Vectors is
subtype Extended_Index is Index_Type'Base
@@ -114,21 +115,17 @@ package SAL.Gen_Unbounded_Definite_Vectors is
procedure Set_First (Container : in out Vector; First : in Index_Type);
procedure Set_Last (Container : in out Vector; Last : in Extended_Index);
- procedure Set_First_Last (Container : in out Vector; First : in Index_Type;
Last : in Extended_Index);
+ procedure Set_First_Last
+ (Container : in out Vector;
+ First : in Index_Type;
+ Last : in Extended_Index);
-- Default First is Index_Type'First.
-- Elements with First <= index <= Last that have not been set have
- -- Element_Type default value.
+ -- Default_Element value.
procedure Set_Length (Container : in out Vector; Length : in
Ada.Containers.Count_Type);
-- Set Last so Container.Length returns Length. New elements have
- -- Element_Type default value.
-
- procedure Set_Length
- (Container : in out Vector;
- Length : in Ada.Containers.Count_Type;
- Default : in Element_Type);
- -- Set Last so Container.Length returns Length. New elements have
- -- Default value.
+ -- Default_Element value.
procedure Delete (Container : in out Vector; Index : in Index_Type);
-- Replace Index element contents with default. If Index =
@@ -142,12 +139,14 @@ package SAL.Gen_Unbounded_Definite_Vectors is
function Constant_Ref (Container : aliased in Vector; Index : in
Index_Type) return Constant_Reference_Type
with Pre => Index >= Container.First_Index and Index <=
Container.Last_Index;
+ pragma Inline (Constant_Ref);
type Variable_Reference_Type (Element : not null access Element_Type) is
null record
with Implicit_Dereference => Element;
function Variable_Ref (Container : aliased in Vector; Index : in
Index_Type) return Variable_Reference_Type
with Pre => Index >= Container.First_Index and Index <=
Container.Last_Index;
+ pragma Inline (Variable_Ref);
type Cursor is private;
@@ -173,9 +172,11 @@ package SAL.Gen_Unbounded_Definite_Vectors is
function Constant_Ref (Container : aliased in Vector; Position : in Cursor)
return Constant_Reference_Type
with Pre => Has_Element (Position);
+ pragma Inline (Constant_Ref);
function Variable_Ref (Container : aliased in Vector; Position : in
Cursor) return Variable_Reference_Type
with Pre => Has_Element (Position);
+ pragma Inline (Variable_Ref);
private
diff --git a/sal.adb b/sal.adb
index 13a5276..6a2dc71 100644
--- a/sal.adb
+++ b/sal.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 1997 - 2004, 2006, 2009 Free Software Foundation, Inc.
+-- Copyright (C) 1997 - 2004, 2006, 2009, 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
@@ -26,7 +26,7 @@ package body SAL is
function Version return String is
begin
- return "SAL 3.0";
+ return "SAL 3.1";
end Version;
end SAL;
diff --git a/standard_common.gpr b/standard_common.gpr
index b51f8ed..2ba758a 100644
--- a/standard_common.gpr
+++ b/standard_common.gpr
@@ -2,7 +2,7 @@
--
-- Standard settings for all of Stephe's Ada projects.
--
--- Copyright (C) 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2018, 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
@@ -27,6 +27,15 @@ project Standard_Common is
type Mem_Check_Type is ("On", "Off");
Mem_Check : Profile_Type := External ("Standard_Common_Mem_Check", "Off");
+ -- Note that Mem_Check requires Build_Type = Debug to be useful
+
+ -- In main project file, add:
+ -- case Standard_Common.Mem_Check is
+ -- when "On" =>
+ -- for Runtime ("Ada") use "adalib_debug";
+ -- when "Off" =>
+ -- null;
+ -- end case;
package Compiler is
-- Switches for gcc
@@ -41,10 +50,11 @@ project Standard_Common is
"-fstack-check",
"-g",
"-gnat2012",
- "-gnatfoqQ",
- "-gnatw.d",
- "-gnatwaBCeJL",
- "-gnatyO"
+ "-gnatfqQ", -- f = all error messages, qQ = process semantics,
generate .ali if syntax errors
+ "-gnatw.d", -- warnings about tags
+ "-gnatwaBCeJL", -- wa = most warnings, wB = no warn on bad fixed
values, wC = no warn on conditionals
+ -- we = error on warning, wJ = no warn on
obsolescent, wL = no warn on elaboration
+ "-gnatyO" -- warn on overriding
);
-- -gnatVa causes some inline procedures to be non-inlineable;
@@ -55,7 +65,7 @@ project Standard_Common is
"-gnata", -- assertions, pre/post-conditions
"-gnatVa", -- validity checks
"-gnateE", -- extra info in exceptions
- "-gnatwaP"
+ "-gnatwaP" -- no warn on Inline
);
-- -O3 is measurably faster than -O2 for wisitoken generate
@@ -92,6 +102,13 @@ project Standard_Common is
package Builder is
-- Switches for gnatmake
for Default_Switches ("Ada") use ("-C");
+
+ case Profile is
+ when "On" =>
+ for Global_Compilation_Switches ("Ada") use ("-pg");
+ when "Off" =>
+ null;
+ end case;
end Builder;
-- In project files, normally use this:
diff --git a/wisi-elisp-parse.el b/wisi-elisp-parse.el
index 83ddba2..e757ac8 100644
--- a/wisi-elisp-parse.el
+++ b/wisi-elisp-parse.el
@@ -1,6 +1,6 @@
;; wisi-elisp-parse.el --- Wisi parser -*- lexical-binding:t -*-
-;; Copyright (C) 2013-2015, 2017 - 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015, 2017 - 2019 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -85,7 +85,7 @@ point at which that max was spawned.")
(cl-defmethod wisi-parse-kill ((_parser wisi-elisp-parser))
nil)
-(defvar wisi-elisp-parse--indent
+(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:
@@ -103,25 +103,26 @@ Each element can be one of:
- list ('anchor (start-id ...) ('anchored id delta))
for nested anchors.")
-(cl-defmethod wisi-parse-current ((parser wisi-elisp-parser))
- "Parse current buffer from beginning."
-
- (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-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
@@ -270,6 +271,9 @@ Each element can be one of:
(wisi-elisp-parse--resolve-anchors))
(t nil))
+
+ ;; Return region parsed.
+ (cons (point-min) (point))
))
(defun wisi-elisp-parsers-active-index (parser-states)
diff --git a/wisi-fringe.el b/wisi-fringe.el
index 7f1c10b..82f4c6a 100644
--- a/wisi-fringe.el
+++ b/wisi-fringe.el
@@ -1,6 +1,6 @@
;;; wisi-fringe.el --- show approximate error locations in the fringe
;;
-;; Copyright (C) 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
;;
;; This file is part of GNU Emacs.
;;
@@ -115,12 +115,16 @@ in the window."
(rem (- error-line (floor (/ line scale)))))
(cons (+ window-line-first line) (lsh 1 (min 5 (floor (* rem (* 6
scale))))))))
+(defun wisi-fringe-clean ()
+ "Remove all wisi-fringe marks."
+ (remove-overlays (point-min) (point-max) 'wisi-fringe t))
+
(defun wisi-fringe-display-errors (positions)
- "Display a bar in the right fringe for each buffer position in POSITIONS.
+ "Display markers in the left and right fringe for each buffer position in
POSITIONS.
The buffer containing POSITIONS must be current, and the window
displaying that buffer must be current."
;; FIXME: recompute fringe display on scroll!
- (remove-overlays (point-min) (point-max) 'wisi-fringe t)
+ (wisi-fringe-clean)
(let (scaled-posns
(buffer-lines (line-number-at-pos (point-max)))
(window-lines (window-height))
diff --git a/wisi-parse-common.el b/wisi-parse-common.el
index 3aa2c92..bb559a6 100644
--- a/wisi-parse-common.el
+++ b/wisi-parse-common.el
@@ -1,341 +1,353 @@
-;;; wisi-parse-common.el --- declarations used by wisi-parse.el,
wisi-ada-parse.el, and wisi.el
-;;
-;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@member.fsf.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/>.
-
-;;; Code:
-
-(cl-defstruct (wisi--lexer-error)
- pos ;; position (integer) in buffer where error was detected.
- message ;; string error message
- inserted ;; char inserted after pos.
- )
-
-(cl-defstruct (wisi--parse-error-repair)
- pos ;; position (integer) in buffer where insert/delete is done.
- inserted ;; list of token IDs that were inserted before pos
- deleted ;; list of token IDs that were deleted after pos
- )
-
-(cl-defstruct (wisi--parse-error)
- ;; Includes information derived from compiler error recovery to edit
- ;; text to fix one error. Used by ’wisi-repair-error’ to edit buffer.
- pos ;; position (integer or marker) in buffer where error was detected.
- message ;; string error message
- repair ;; list of wisi--parse-error-repair.
- )
-
-(cl-defstruct wisi-parser
- ;; Separate lists for lexer and parse errors, because lexer errors
- ;; must be repaired first, before parse errors can be repaired. And
- ;; they have different structures.
- lexer-errors
- ;; list of wisi--lexer-errors from last parse. Can be more than one if
- ;; lexer supports error recovery.
- parse-errors
- ;; List of wisi--parse-errors from last parse. Can be more than one if
- ;; parser supports error recovery.
-)
-
-(cl-defgeneric wisi-parse-format-language-options ((parser wisi-parser))
- "Return a string to be sent to the parser, containing settings
-for the language-specific parser options."
- ;; not needed for the elisp parser, which can see the options directly.
- )
-
-(cl-defgeneric wisi-parse-current ((parser wisi-parser))
- "Parse current buffer.")
-
-(cl-defgeneric wisi-parse-kill ((parser wisi-parser))
- "Kill any external process associated with parser.")
-
-(cl-defgeneric wisi-parse-find-token ((parser wisi-parser) token-symbol)
- "Find token with TOKEN-SYMBOL on current parser stack, return token struct.
-For use in grammar actions.")
-
-(cl-defgeneric wisi-parse-stack-peek ((parser wisi-parser) n)
- "Return the Nth token on the parse stack.
-For use in grammar actions.")
-
-(cl-defstruct
- (wisi-cache
- (:constructor wisi-cache-create)
- (:copier nil))
- nonterm;; nonterminal from parse
-
- token
- ;; terminal symbol from wisi-keyword-table or
- ;; wisi-punctuation-table, or lower-level nonterminal from parse
-
- last ;; pos of last char in token, relative to first (0 indexed)
-
- class ;; one of wisi-class-list
-
- containing
- ;; Marker at the start of the containing statement for this token.
- ;; nil only for first token in buffer
-
- prev ;; marker at previous motion token in statement; nil if none
- next ;; marker at next motion token in statement; nil if none
- end ;; marker at token at end of current statement
- )
-
-(defun wisi-get-cache (pos)
- "Return `wisi-cache' struct from the `wisi-cache' text property at POS."
- (get-text-property pos 'wisi-cache))
-
-(defun wisi-backward-cache ()
- "Move point backward to the beginning of the first token preceding point
that has a cache.
-Returns cache, or nil if at beginning of buffer."
- ;; If point is not near cache, p-s-p-c will return pos just after
- ;; cache, so 1- is the beginning of cache.
- ;;
- ;; If point is just after end of cache, p-s-p-c will return pos at
- ;; start of cache.
- ;;
- ;; So we test for the property before subtracting 1.
- (let ((pos (previous-single-property-change (point) 'wisi-cache))
- cache)
- (cond
- ((null pos)
- (goto-char (point-min))
- nil)
-
- ((setq cache (get-text-property pos 'wisi-cache))
- (goto-char pos)
- cache)
-
- (t
- (setq pos (1- pos))
- (setq cache (get-text-property pos 'wisi-cache))
- (goto-char pos)
- cache)
- )))
-
-(defun wisi-forward-cache ()
- "Move point forward to the beginning of the first token after point that has
a cache.
-Returns cache, or nil if at end of buffer."
- (let (cache pos)
- (when (get-text-property (point) 'wisi-cache)
- ;; on a cache; get past it
- (goto-char (1+ (point))))
-
- (setq cache (get-text-property (point) 'wisi-cache))
- (if cache
- nil
-
- (setq pos (next-single-property-change (point) 'wisi-cache))
- (if pos
- (progn
- (goto-char pos)
- (setq cache (get-text-property pos 'wisi-cache)))
- ;; at eob
- (goto-char (point-max))
- (setq cache nil))
- )
- cache
- ))
-
-(defun wisi-cache-region (cache &optional start)
- "Return region designated by START (default point) to cache last."
- (unless start (setq start (point)))
- (cons start (+ start (wisi-cache-last cache))))
-
-(defvar wisi-debug 0
- "wisi debug mode:
-0 : normal - ignore parse errors, for indenting new code
-1 : report parse errors (for running tests)
-2 : show parse states, position point at parse errors
-3 : also show top 10 items of parser stack.")
-
-;; The following parameters are easily changeable for debugging.
-(defvar wisi-action-disable nil
- "If non-nil, disable all elisp actions during parsing.
-Allows timing parse separate from actions.")
-
-(defvar-local wisi-trace-mckenzie 0
- "McKenzie trace level; 0 for none")
-
-(defvar-local wisi-trace-action 0
- "Parse action trace level; 0 for none")
-
-(defvar-local wisi-mckenzie-disable nil
- "If non-nil, disable McKenzie error recovery. Otherwise, use parser
default.")
-
-(defcustom wisi-mckenzie-task-count nil
- "If integer, sets McKenzie error recovery task count.
-Higher value (up to system processor limit) runs error recovery
-faster, but may encounter race conditions. Using only one task
-makes error recovery repeatable; useful for tests. If nil, uses
-value from grammar file."
- :type 'integer
- :group 'wisi
- :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
-parsed successfully for a solution to be deemed successful.
-Higher value gives better solutions, but may fail if there are
-two errors close together. If nil, uses value from grammar
-file."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-mckenzie-check-limit)
-
-(defcustom wisi-mckenzie-enqueue-limit nil
- "If integer, sets McKenzie error recovery algorithm enqueue limit.
-This sets the maximum number of solutions that will be considered.
-Higher value has more recover power, but will be slower to fail.
-If nil, uses value from grammar file."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-mckenzie-enqueue-limit)
-
-(defvar 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.")
-
-(defvar wisi-parse-max-stack-size 500
- "Maximum parse stack size.
-Larger stack size allows more deeply nested constructs.")
-;; end of easily changeable parameters
-
-(defvar wisi--parse-action nil
- ;; not buffer-local; only let-bound in wisi-indent-region,
wisi-validate-cache
- "Reason current parse is begin run; one of
-{indent, face, navigate}.")
-
-(defvar-local wisi-indent-comment-col-0 nil
- "If non-nil, comments currently starting in column 0 are left in column 0.
-Otherwise, they are indented with previous comments or code.
-Normally set from a language-specific option.")
-
-(defvar-local wisi-end-caches nil
- "List of buffer positions of caches in current statement that need
wisi-cache-end set.")
-
-(defconst wisi-eoi-term 'Wisi_EOI
- ;; must match FastToken wisi-output_elisp.adb EOI_Name, which must
- ;; be part of a valid Ada identifer.
- "End Of Input token.")
-
-(defconst wisi-class-list
- [motion ;; motion-action
- name ;; for which-function
- statement-end
- statement-override
- statement-start
- misc ;; other stuff
- ]
- "array of valid token classes; checked in wisi-statement-action, used in
wisi-process-parse.")
-
-(defun wisi-error-msg (message &rest args)
- (let ((line (line-number-at-pos))
- (col (- (point) (line-beginning-position))))
- (format
- "%s:%d:%d: %s"
- (buffer-name) ;; buffer-file-name is sometimes nil here!?
- line col
- (apply 'format message args))))
-
-(defvar wisi-parse-error nil)
-(put 'wisi-parse-error
- 'error-conditions
- '(error wisi-parse-error))
-(put 'wisi-parse-error
- 'error-message
- "wisi parse error")
-
-(cl-defstruct wisi-tok
- token ;; symbol from a token table ;; IMPROVEME: rename to ’id’?
- region ;; cons giving buffer region containing token text
-
- nonterminal ;; t if a nonterminal
-
- line ;; Line number at start of token. Nil for empty nonterminals
-
- first
- ;; For terminals, t if token is the first token on a line.
- ;;
- ;; For nonterminals, line number of first contained line (not
- ;; including trailing comments) that needs indenting; it is a
- ;; comment, or begins with a contained token.
- ;;
- ;; Otherwise nil.
-
- ;; The following are non-nil if token (terminal or non-terminal) is
- ;; followed by blank or comment lines
- comment-line ;; first blank or comment line following token
- comment-end ;; position at end of blank or comment lines
- )
-
-(defun wisi-token-text (token)
- "Return buffer text from token range."
- (let ((region (wisi-tok-region token)))
- (and region
- (buffer-substring-no-properties (car region) (cdr region)))))
-
-(defun wisi-and-regions (left right)
- "Return region enclosing both LEFT and RIGHT."
- (if left
- (if right
- (cons (min (car left) (car right))
- (max (cdr left) (cdr right)))
- left)
- right))
-
-(defun wisi--set-line-begin (line-count)
- "Return a vector of line-beginning positions, with length LINE-COUNT."
- (let ((result (make-vector line-count 0)))
- (save-excursion
- (goto-char (point-min))
-
- (dotimes (i line-count)
- (aset result i (point))
- (forward-line 1)))
- result))
-
-;;;; debugging
-(defun wisi-tok-debug-image (tok)
- "Return id and region from TOK, as string."
- (cond
- ((wisi-tok-region tok)
- (format "(%s %d . %d)"
- (wisi-tok-token tok)
- (car (wisi-tok-region tok))
- (cdr (wisi-tok-region tok))))
- (t
- (format "(%s)" (wisi-tok-token tok)))
- ))
-
-(provide 'wisi-parse-common)
+;;; wisi-parse-common.el --- declarations used by wisi-parse.el,
wisi-ada-parse.el, and wisi.el
+;;
+;; Copyright (C) 2014, 2015, 2017 - 2019 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@member.fsf.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/>.
+
+;;; Code:
+
+(cl-defstruct (wisi--lexer-error)
+ pos ;; position (integer) in buffer where error was detected.
+ message ;; string error message
+ inserted ;; char inserted after pos.
+ )
+
+(cl-defstruct (wisi--parse-error-repair)
+ pos ;; position (integer) in buffer where insert/delete is done.
+ inserted ;; list of token IDs that were inserted before pos
+ deleted ;; list of token IDs that were deleted after pos
+ )
+
+(cl-defstruct (wisi--parse-error)
+ ;; Includes information derived from compiler error recovery to edit
+ ;; text to fix one error. Used by ’wisi-repair-error’ to edit buffer.
+ pos ;; position (integer or marker) in buffer where error was detected.
+ message ;; string error message
+ repair ;; list of wisi--parse-error-repair.
+ )
+
+(cl-defstruct wisi-parser
+ ;; Separate lists for lexer and parse errors, because lexer errors
+ ;; must be repaired first, before parse errors can be repaired. And
+ ;; they have different structures.
+ lexer-errors
+ ;; list of wisi--lexer-errors from last parse. Can be more than one if
+ ;; lexer supports error recovery.
+ parse-errors
+ ;; List of wisi--parse-errors from last parse. Can be more than one if
+ ;; parser supports error recovery.
+)
+
+(cl-defgeneric wisi-parse-format-language-options ((parser wisi-parser))
+ "Return a string to be sent to the parser, containing settings
+for the language-specific parser options."
+ ;; not needed for the elisp parser, which can see the options directly.
+ )
+
+(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."
+ (cons begin end))
+
+(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)
+
+(cl-defgeneric wisi-parse-current ((parser wisi-parser) begin send-end
parse-end)
+ "Parse current buffer starting at BEGIN, continuing at least thru PARSE-END.
+If using an external parser, send it BEGIN thru SEND-END.")
+
+(cl-defgeneric wisi-parse-kill ((parser wisi-parser))
+ "Kill any external process associated with parser.")
+
+(cl-defgeneric wisi-parse-find-token ((parser wisi-parser) token-symbol)
+ "Find token with TOKEN-SYMBOL on current parser stack, return token struct.
+For use in grammar actions.")
+
+(cl-defgeneric wisi-parse-stack-peek ((parser wisi-parser) n)
+ "Return the Nth token on the parse stack.
+For use in grammar actions.")
+
+(cl-defstruct
+ (wisi-cache
+ (:constructor wisi-cache-create)
+ (:copier nil))
+ nonterm;; nonterminal from parse
+
+ token
+ ;; terminal symbol from wisi-keyword-table or
+ ;; wisi-punctuation-table, or lower-level nonterminal from parse
+
+ last ;; pos of last char in token, relative to first (0 indexed)
+
+ class ;; one of wisi-class-list
+
+ containing
+ ;; Marker at the start of the containing statement for this token.
+ ;; nil only for first token in buffer
+
+ prev ;; marker at previous motion token in statement; nil if none
+ next ;; marker at next motion token in statement; nil if none
+ end ;; marker at token at end of current statement
+ )
+
+(defun wisi-get-cache (pos)
+ "Return `wisi-cache' struct from the `wisi-cache' text property at POS."
+ (get-text-property pos 'wisi-cache))
+
+(defun wisi-backward-cache ()
+ "Move point backward to the beginning of the first token preceding point
that has a cache.
+Returns cache, or nil if at beginning of buffer."
+ ;; If point is not near cache, p-s-p-c will return pos just after
+ ;; cache, so 1- is the beginning of cache.
+ ;;
+ ;; If point is just after end of cache, p-s-p-c will return pos at
+ ;; start of cache.
+ ;;
+ ;; So we test for the property before subtracting 1.
+ (let ((pos (previous-single-property-change (point) 'wisi-cache))
+ cache)
+ (cond
+ ((null pos)
+ (goto-char (point-min))
+ nil)
+
+ ((setq cache (get-text-property pos 'wisi-cache))
+ (goto-char pos)
+ cache)
+
+ (t
+ (setq pos (1- pos))
+ (setq cache (get-text-property pos 'wisi-cache))
+ (goto-char pos)
+ cache)
+ )))
+
+(defun wisi-forward-cache ()
+ "Move point forward to the beginning of the first token after point that has
a cache.
+Returns cache, or nil if at end of buffer."
+ (let (cache pos)
+ (when (get-text-property (point) 'wisi-cache)
+ ;; on a cache; get past it
+ (goto-char (1+ (point))))
+
+ (setq cache (get-text-property (point) 'wisi-cache))
+ (if cache
+ nil
+
+ (setq pos (next-single-property-change (point) 'wisi-cache))
+ (if pos
+ (progn
+ (goto-char pos)
+ (setq cache (get-text-property pos 'wisi-cache)))
+ ;; at eob
+ (goto-char (point-max))
+ (setq cache nil))
+ )
+ cache
+ ))
+
+(defun wisi-cache-region (cache &optional start)
+ "Return region designated by START (default point) to cache last."
+ (unless start (setq start (point)))
+ (cons start (+ start (wisi-cache-last cache))))
+
+(defvar wisi-debug 0
+ "wisi debug mode:
+0 : normal - ignore parse errors, for indenting new code
+1 : report parse errors (for running tests)
+2 : show parse states, position point at parse errors
+3 : also show top 10 items of parser stack.")
+
+;; The following parameters are easily changeable for debugging.
+(defvar wisi-action-disable nil
+ "If non-nil, disable all elisp actions during parsing.
+Allows timing parse separate from actions.")
+
+(defvar-local wisi-trace-mckenzie 0
+ "McKenzie trace level; 0 for none")
+
+(defvar-local wisi-trace-action 0
+ "Parse action trace level; 0 for none")
+
+(defvar-local wisi-mckenzie-disable nil
+ "If non-nil, disable McKenzie error recovery. Otherwise, use parser
default.")
+
+(defcustom wisi-mckenzie-task-count nil
+ "If integer, sets McKenzie error recovery task count.
+Higher value (up to system processor limit) runs error recovery
+faster, but may encounter race conditions. Using only one task
+makes error recovery repeatable; useful for tests. If nil, uses
+value from grammar file."
+ :type 'integer
+ :group 'wisi
+ :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
+parsed successfully for a solution to be deemed successful.
+Higher value gives better solutions, but may fail if there are
+two errors close together. If nil, uses value from grammar
+file."
+ :type 'integer
+ :group 'wisi
+ :safe 'integerp)
+(make-variable-buffer-local 'wisi-mckenzie-check-limit)
+
+(defcustom wisi-mckenzie-enqueue-limit nil
+ "If integer, sets McKenzie error recovery algorithm enqueue limit.
+This sets the maximum number of solutions that will be considered.
+Higher value has more recover power, but will be slower to fail.
+If nil, uses value from grammar file."
+ :type 'integer
+ :group 'wisi
+ :safe 'integerp)
+(make-variable-buffer-local 'wisi-mckenzie-enqueue-limit)
+
+(defvar 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.")
+
+(defvar wisi-parse-max-stack-size 500
+ "Maximum parse stack size.
+Larger stack size allows more deeply nested constructs.")
+;; end of easily changeable parameters
+
+(defvar wisi--parse-action nil
+ ;; not buffer-local; only let-bound in wisi-indent-region,
wisi-validate-cache
+ "Reason current parse is begin run; one of
+{indent, face, navigate}.")
+
+(defvar-local wisi-indent-comment-col-0 nil
+ "If non-nil, comments currently starting in column 0 are left in column 0.
+Otherwise, they are indented with previous comments or code.
+Normally set from a language-specific option.")
+
+(defvar-local wisi-end-caches nil
+ "List of buffer positions of caches in current statement that need
wisi-cache-end set.")
+
+(defconst wisi-eoi-term 'Wisi_EOI
+ ;; must match FastToken wisi-output_elisp.adb EOI_Name, which must
+ ;; be part of a valid Ada identifer.
+ "End Of Input token.")
+
+(defconst wisi-class-list
+ [motion ;; motion-action
+ name ;; for which-function
+ statement-end
+ statement-override
+ statement-start
+ misc ;; other stuff
+ ]
+ "array of valid token classes; checked in wisi-statement-action, used in
wisi-process-parse.")
+
+(defun wisi-error-msg (message &rest args)
+ (let ((line (line-number-at-pos))
+ (col (- (point) (line-beginning-position))))
+ (format
+ "%s:%d:%d: %s"
+ (buffer-name) ;; buffer-file-name is sometimes nil here!?
+ line col
+ (apply 'format message args))))
+
+(defvar wisi-parse-error nil)
+(put 'wisi-parse-error
+ 'error-conditions
+ '(error wisi-parse-error))
+(put 'wisi-parse-error
+ 'error-message
+ "wisi parse error")
+
+(cl-defstruct wisi-tok
+ token ;; symbol from a token table ;; IMPROVEME: rename to ’id’?
+ region ;; cons giving buffer region containing token text
+
+ nonterminal ;; t if a nonterminal
+
+ line ;; Line number at start of token. Nil for empty nonterminals
+
+ first
+ ;; For terminals, t if token is the first token on a line.
+ ;;
+ ;; For nonterminals, line number of first contained line (not
+ ;; including trailing comments) that needs indenting; it is a
+ ;; comment, or begins with a contained token.
+ ;;
+ ;; Otherwise nil.
+
+ ;; The following are non-nil if token (terminal or non-terminal) is
+ ;; followed by blank or comment lines
+ comment-line ;; first blank or comment line following token
+ comment-end ;; position at end of blank or comment lines
+ )
+
+(defun wisi-token-text (token)
+ "Return buffer text from token range."
+ (let ((region (wisi-tok-region token)))
+ (and region
+ (buffer-substring-no-properties (car region) (cdr region)))))
+
+(defun wisi-and-regions (left right)
+ "Return region enclosing both LEFT and RIGHT."
+ (if left
+ (if right
+ (cons (min (car left) (car right))
+ (max (cdr left) (cdr right)))
+ left)
+ right))
+
+(defun wisi--set-line-begin (line-count)
+ "Return a vector of line-beginning positions, with length LINE-COUNT."
+ (let ((result (make-vector line-count 0)))
+ (save-excursion
+ (goto-char (point-min))
+
+ (dotimes (i line-count)
+ (aset result i (point))
+ (forward-line 1)))
+ result))
+
+;;;; debugging
+(defun wisi-tok-debug-image (tok)
+ "Return id and region from TOK, as string."
+ (cond
+ ((wisi-tok-region tok)
+ (format "(%s %d . %d)"
+ (wisi-tok-token tok)
+ (car (wisi-tok-region tok))
+ (cdr (wisi-tok-region tok))))
+ (t
+ (format "(%s)" (wisi-tok-token tok)))
+ ))
+
+(provide 'wisi-parse-common)
diff --git a/wisi-process-parse.el b/wisi-process-parse.el
index cfc98eb..154b75f 100644
--- a/wisi-process-parse.el
+++ b/wisi-process-parse.el
@@ -1,6 +1,6 @@
;;; wisi-process-parse.el --- interface to external parse program
;;
-;; Copyright (C) 2014, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2014, 2017 - 2019 Free Software Foundation, Inc.
;;
;; Author: Stephen Leake <stephen_leake@member.fsf.org>
;;
@@ -22,6 +22,18 @@
(require 'cl-lib)
(require 'wisi-parse-common)
+(defgroup wisi nil
+ "Options for Wisi package."
+ :group 'programming)
+
+(defcustom wisi-process-time-out 1.0
+ "Time out waiting for parser response. An error occurs if there
+ is no response from the parser after waiting this amount 5
+ times."
+ :type 'float
+ :safe 'floatp)
+(make-variable-buffer-local 'wisi-process-time-out)
+
(defconst wisi-process-parse-prompt "^;;> "
"Regexp matching executable prompt; indicates previous command is complete.")
@@ -52,23 +64,12 @@
line-begin ;; vector of beginning-of-line positions in buffer
(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
)
(defvar wisi-process--alist nil
"Alist mapping string label to ‘wisi-process--session’ struct")
-(defgroup wisi nil
- "Options for Wisi package."
- :group 'programming)
-
-(defcustom wisi-process-time-out 1.0
- "Time out waiting for parser response. An error occurs if there
- is no response from the parser after waiting this amount 5
- times."
- :type 'float
- :safe 'floatp)
-(make-variable-buffer-local 'wisi-process-time-out)
-
;;;###autoload
(defun wisi-process-parse-get (parser)
"Return a ‘wisi-process--parser’ object matching PARSER label.
@@ -164,18 +165,29 @@ Otherwise add PARSER to ‘wisi-process--alist’, return it."
(pop-to-buffer (wisi-process--parser-buffer parser))
(error "wisi-process-parse process not active")))
-(defun wisi-process-parse--send-parse (parser line-count)
+(defun wisi-process-parse--send-parse (parser begin send-end parse-end)
"Send a parse command to PARSER external process, followed by
-the content of the current buffer. Does not wait for command to
-complete."
- ;; Must match "parse" command arguments in gen_emacs_wisi_parse.adb
- (let* ((cmd (format "parse %d \"%s\" %d %d %d %d %d %d %d %d %d %d %d %s"
+the content of the current buffer from BEGIN thru SEND-END. Does
+not wait for command to complete. PARSE-END is end of desired
+parse region."
+ ;; Must match "parse" command arguments read by
+ ;; emacs_wisi_common_parse,adb Get_Parse_Params.
+ (let* ((cmd (format "parse %d \"%s\" %d %d %d %d %d %d %d %d %d %d %d %d %d
%d %d %d %d %d %s"
(cl-ecase wisi--parse-action
(navigate 0)
(face 1)
(indent 2))
(if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
- line-count
+ (position-bytes begin)
+ (position-bytes send-end)
+ (position-bytes parse-end)
+ begin ;; char_pos
+ (line-number-at-pos begin)
+ (line-number-at-pos send-end)
+ (save-excursion (goto-char begin) (back-to-indentation)
(current-column));; indent-begin
+ (if (or (and (= begin (point-min)) (= parse-end
(point-max)))
+ (< (point-max) wisi-partial-parse-threshold))
+ 0 1) ;; partial parse active
(if (> wisi-debug 0) 1 0) ;; debug-mode
(1- wisi-debug) ;; trace_parse
wisi-trace-mckenzie
@@ -185,7 +197,7 @@ complete."
(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)
- (1- (position-bytes (point-max)))
+ (- (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))
@@ -196,7 +208,7 @@ complete."
(erase-buffer))
(process-send-string process msg)
- (process-send-string process (buffer-substring-no-properties (point-min)
(point-max)))
+ (process-send-string process (buffer-substring-no-properties begin
send-end))
;; We don’t wait for the send to complete; the external process
;; may start parsing and send an error message.
@@ -259,12 +271,13 @@ complete."
;; see ‘wisi-process-parse--execute’
(let ((pos (aref (wisi-process--parser-line-begin parser) (1- (aref sexp
1)))))
(with-silent-modifications
- (put-text-property
- (1- pos)
- pos
- 'wisi-indent
- (aref sexp 2)))
- ))
+ (when (< (point-min) pos)
+ (put-text-property
+ (1- pos)
+ pos
+ 'wisi-indent
+ (aref sexp 2)))
+ )))
(defun wisi-process-parse--Lexer_Error (parser sexp)
;; sexp is [Lexer_Error char-position <message> <repair-char>]
@@ -348,6 +361,11 @@ complete."
(wisi--parse-error-repair last-error)))
)))
+(defun wisi-process-parse--End (parser sexp)
+ ;; sexp is [End pos]
+ ;; see ‘wisi-process-parse--execute’
+ (setf (wisi-process--parser-end-pos parser) (aref sexp 1)))
+
(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
@@ -411,14 +429,16 @@ complete."
(5 (wisi-process-parse--Parser_Error parser sexp))
(6 (wisi-process-parse--Check_Error parser sexp))
(7 (wisi-process-parse--Recover parser sexp))
+ (8 (wisi-process-parse--End parser sexp))
))
;;;;; main
(cl-defmethod wisi-parse-kill ((parser wisi-process--parser))
(when (process-live-p (wisi-process--parser-process parser))
- (process-send-string (wisi-process--parser-process parser)
wisi-process-parse-quit-cmd)
- (sit-for 1.0)
+ ;; We used to send a quit command first, to be nice. But there's
+ ;; no timeout on that, so it would hang when the process
+ ;; executable is not reading command input.
(when (process-live-p (wisi-process--parser-process parser))
(kill-process (wisi-process--parser-process parser)))
)
@@ -427,8 +447,9 @@ complete."
(defvar wisi--lexer nil) ;; wisi-elisp-lexer.el
(declare-function wisi-elisp-lexer-reset "wisi-elisp-lexer")
-(cl-defmethod wisi-parse-current ((parser wisi-process--parser))
- "Run the external parser on the current buffer."
+(cl-defmethod wisi-parse-current ((parser wisi-process--parser) begin send-end
parse-end)
+ "Run the external parser on the current buffer, from BEGIN to at least
PARSE-END.
+Send BEGIN thru SEND-END to external parser."
(wisi-process-parse--require-process parser)
;; font-lock can trigger a face parse while navigate or indent parse
@@ -476,13 +497,13 @@ complete."
(setf (wisi-parser-lexer-errors parser) nil)
(setf (wisi-parser-parse-errors parser) nil)
- (let ((line-count (1+ (count-lines (point-min) (point-max)))))
- (setf (wisi-process--parser-line-begin parser)
(wisi--set-line-begin line-count))
- (wisi-process-parse--send-parse parser line-count)
+ (let ((total-line-count (1+ (count-lines (point-max) (point-min)))))
+ (setf (wisi-process--parser-line-begin parser)
(wisi--set-line-begin total-line-count))
+ (wisi-process-parse--send-parse parser begin send-end parse-end)
;; We reset the elisp lexer, because post-parse actions may use it.
(when wisi--lexer
- (wisi-elisp-lexer-reset line-count wisi--lexer))
+ (wisi-elisp-lexer-reset total-line-count wisi--lexer))
)
(set-buffer response-buffer)
@@ -520,49 +541,70 @@ complete."
(setq sexp-start (point))
(set-buffer source-buffer) ;; for put-text-property in actions
- (if (listp response)
- ;; error of some sort
- (cond
- ((equal '(parse_error) response)
- ;; Parser detected a syntax error, and recovery failed,
so signal it.
- (if (wisi-parser-parse-errors parser)
- (signal 'wisi-parse-error
- (wisi--parse-error-message (car
(wisi-parser-parse-errors parser))))
-
- ;; can have no errors when testing a new parser
- (push
- (make-wisi--parse-error :pos 0 :message "parser
failed with no message")
- (wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error "parser failed with no
message")))
-
- ((equal 'parse_error (car response))
- ;; Parser detected some other error non-fatal error, so
signal it.
- (signal 'wisi-parse-error (cdr response)))
-
- ((and (eq 'error (car response))
- (string-prefix-p "bad command:" (cadr response)))
- ;; Parser dropped bytes, is treating buffer
- ;; content bytes as commands. Kill the process
- ;; to kill the pipes; there is no other way to
- ;; flush them.
- (kill-process (wisi-process--parser-process parser))
- (signal 'wisi-parse-error "parser lost sync; killed"))
-
- (t
- ;; Some other error
- (condition-case-unless-debug err
- (eval response)
- (error
- (push (make-wisi--parse-error :pos (point) :message
(cadr err)) (wisi-parser-parse-errors parser))
- (signal (car err) (cdr err)))))
- )
-
- ;; else encoded action
+ (cond
+ ((listp response)
+ ;; error of some sort
+ (cond
+ ((equal '(parse_error) response)
+ ;; Parser detected a syntax error, and recovery failed,
so signal it.
+
+ (when (> wisi-debug 0)
+ ;; Save a copy of parser output; may be overwritten by
subsequent parse face attempts.
+ (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)))
+
+ (if (wisi-parser-parse-errors parser)
+ (signal 'wisi-parse-error
+ (wisi--parse-error-message (car
(wisi-parser-parse-errors parser))))
+
+ ;; can have no errors when testing a new parser
+ (push
+ (make-wisi--parse-error :pos 0 :message "parser failed
with no message")
+ (wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error "parser failed with no
message")))
+
+ ((equal 'parse_error (car response))
+ ;; Parser detected some other error non-fatal error, so
signal it.
+ (signal 'wisi-parse-error (cdr response)))
+
+ ((and (eq 'error (car response))
+ (string-prefix-p "bad command:" (cadr response)))
+ ;; Parser dropped bytes, is treating buffer
+ ;; content bytes as commands. Kill the process
+ ;; to kill the pipes; there is no other way to
+ ;; flush them.
+ (kill-process (wisi-process--parser-process parser))
+ (signal 'wisi-parse-error "parser lost sync; killed"))
+
+ (t
+ ;; Some other error
+ (condition-case-unless-debug err
+ (eval response)
+ (error
+ (push (make-wisi--parse-error :pos (point) :message
(cadr err)) (wisi-parser-parse-errors parser))
+ (signal (car err) (cdr err)))))
+ ))
+
+ ((arrayp response)
+ ;; encoded action
(condition-case-unless-debug err
(wisi-process-parse--execute parser response)
(wisi-parse-error
(push (make-wisi--parse-error :pos (point) :message
(cadr err)) (wisi-parser-parse-errors parser))
- (signal (car err) (cdr err)))))
+ (signal (car err) (cdr err)))
+
+ (error ;; ie from [C:\Windows\system32\KERNEL32.DLL]
+ (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)
+ (error "parser failed; error messages in %s"
buf-name)))
+ ))
+ )
(set-buffer response-buffer)
))
@@ -577,8 +619,12 @@ complete."
(unless done
;; end of response buffer
(unless (process-live-p process)
- (wisi-process-parse-show-buffer parser)
- (error "wisi-process-parse process died"))
+ (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)
+ (error "parser failed; error messages in %s" buf-name)))
(setq wait-count (1+ wait-count))
(setq start-wait-time (float-time))
@@ -600,7 +646,7 @@ complete."
(- (float-time) start-wait-time)))
(when (and (= (point-max) need-more)
- (> wait-count 5))
+ (> wait-count 5))
(error "wisi-process-parse not getting more text (or bad syntax
in process output)"))
(setq need-more nil))
@@ -616,9 +662,9 @@ complete."
(setf (wisi-process--parser-busy parser) nil)
(set-buffer source-buffer)
;; If we get here, the parse succeeded (possibly with error
- ;; recovery); move point to end of buffer as the elisp
- ;; parser does.
- (goto-char (point-max))
+ ;; recovery); move point to end of parsed region.
+ (goto-char (wisi-process--parser-end-pos parser))
+ (cons begin (point))
)
(wisi-parse-error
@@ -688,4 +734,26 @@ Returns reversed sequence."
(push (aref token-table i) enum-ids))
enum-ids))
+(defun wisi-process-parse-show-args ()
+ "Show the partial parse command-line args for run_ada_[lalr | lr1]_parse for
current region.
+Also add it to the kill ring."
+ (interactive)
+ (let* ((begin (region-beginning))
+ (end (region-end))
+ (parse-action (wisi-read-parse-action))
+ (msg
+ (format "%s %s %d %d %d %d %d %d %d"
+ (file-name-nondirectory (buffer-file-name))
+ parse-action
+ (position-bytes begin)
+ (position-bytes end)
+ (position-bytes end)
+ begin ;; char_pos
+ (line-number-at-pos begin)
+ (line-number-at-pos end)
+ (save-excursion (goto-char begin) (back-to-indentation)
(current-column));; indent-begin
+ )))
+ (kill-new msg)
+ (message msg)))
+
(provide 'wisi-process-parse)
diff --git a/wisi.adb b/wisi.adb
index 0c00735..4031df0 100644
--- a/wisi.adb
+++ b/wisi.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -18,6 +18,7 @@
pragma License (Modified_GPL);
with Ada.Strings.Bounded;
+with Ada.Text_IO;
with WisiToken.Semantic_Checks;
package body Wisi is
use WisiToken;
@@ -29,6 +30,7 @@ package body Wisi is
Parser_Error_Code : constant String := "5";
Check_Error_Code : constant String := "6";
Recover_Code : constant String := "7 ";
+ End_Code : constant String := "8";
Chars_Per_Int : constant Integer := Integer'Width;
@@ -236,8 +238,8 @@ package body Wisi is
Offset : in Integer)
return Integer
is
- Left_Paren_ID : WisiToken.Token_ID renames
Data.Descriptor.Left_Paren_ID;
- Right_Paren_ID : WisiToken.Token_ID renames
Data.Descriptor.Right_Paren_ID;
+ Left_Paren_ID : Token_ID renames Data.Descriptor.Left_Paren_ID;
+ Right_Paren_ID : Token_ID renames Data.Descriptor.Right_Paren_ID;
I : Base_Token_Index := Anchor_Token.First_Terminals_Index;
Paren_Count : Integer := 0;
@@ -294,8 +296,8 @@ package body Wisi is
begin
Append (Line, Navigate_Cache_Code);
Append (Line, Buffer_Pos'Image (Cache.Pos));
- Append (Line, WisiToken.Token_ID'Image (Cache.Statement_ID));
- Append (Line, WisiToken.Token_ID'Image (Cache.ID));
+ Append (Line, Token_ID'Image (Cache.Statement_ID));
+ Append (Line, Token_ID'Image (Cache.ID));
Append (Line, Integer'Image (Cache.Length));
Append (Line, Integer'Image (Navigate_Class_Type'Pos (Cache.Class)));
Append (Cache.Containing_Pos);
@@ -330,8 +332,8 @@ package body Wisi is
-- grammar indent rules or the algorithms in this package.
case Item.Label is
when Not_Set =>
- Ada.Text_IO.Put_Line
- ('[' & Indent_Code & Trimmed_Image (Integer (Line_Number)) & " 0]");
+ -- Especially with partial parse, we have no idea what this indent
should be.
+ null;
when Int =>
declare
@@ -354,14 +356,14 @@ package body Wisi is
is
use Ada.Containers;
use Ada.Strings.Unbounded;
- use WisiToken.Parse.LR;
+ use Parse.LR;
Line : Unbounded_String := To_Unbounded_String ("[");
Last_Op : Config_Op := (Fast_Forward, Token_Index'Last);
begin
if Trace_Action > Detail then
- Ada.Text_IO.Put_Line (Parse.LR.Image (Item.Ops, Descriptor));
+ Ada.Text_IO.Put_Line (";; " & Parse.LR.Image (Item.Ops, Descriptor));
end if;
Append (Line, Recover_Code);
@@ -465,47 +467,52 @@ package body Wisi is
procedure Resolve_Anchors (Data : in out Parse_Data_Type)
is
+ Begin_Indent : Integer renames Data.Begin_Indent;
Anchor_Indent : array (First_Anchor_ID .. Data.Max_Anchor_ID) of Integer;
begin
if Trace_Action > Outline then
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)));
end loop;
end if;
- if Data.Max_Anchor_ID >= First_Anchor_ID then
- for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop
- declare
- Indent : constant Indent_Type := Data.Indents (I);
- begin
- case Indent.Label is
- when Not_Set | Int =>
- null;
+ for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop
+ declare
+ Indent : constant Indent_Type := Data.Indents (I);
+ begin
+ case Indent.Label is
+ when Not_Set =>
+ -- Indent not computed, therefore not output.
+ null;
- when Anchor =>
- for I of Indent.Anchor_IDs loop
- Anchor_Indent (I) := Indent.Anchor_Indent;
- end loop;
- Data.Indents.Replace_Element (I, (Int,
Indent.Anchor_Indent));
+ when Int =>
+ Data.Indents.Replace_Element (I, (Int, Indent.Int_Indent +
Begin_Indent));
- when Anchored =>
- Data.Indents.Replace_Element (I, (Int, Anchor_Indent
(Indent.Anchored_ID) + Indent.Anchored_Delta));
+ when Anchor =>
+ for I of Indent.Anchor_IDs loop
+ Anchor_Indent (I) := Indent.Anchor_Indent + Begin_Indent;
+ end loop;
+ Data.Indents.Replace_Element (I, (Int, Indent.Anchor_Indent +
Begin_Indent));
- when Anchor_Anchored =>
- declare
- Temp : constant Integer :=
- Anchor_Indent (Indent.Anchor_Anchored_ID) +
Indent.Anchor_Anchored_Delta;
- begin
- for I of Indent.Anchor_Anchored_IDs loop
- Anchor_Indent (I) := Temp;
- end loop;
- Data.Indents.Replace_Element (I, (Int, Temp));
- end;
- end case;
- end;
- end loop;
- end if;
+ when Anchored =>
+ Data.Indents.Replace_Element
+ (I, (Int, Anchor_Indent (Indent.Anchored_ID) +
Indent.Anchored_Delta));
+
+ when Anchor_Anchored =>
+ declare
+ Temp : constant Integer :=
+ Anchor_Indent (Indent.Anchor_Anchored_ID) +
Indent.Anchor_Anchored_Delta;
+ begin
+ for I of Indent.Anchor_Anchored_IDs loop
+ Anchor_Indent (I) := Temp;
+ end loop;
+ Data.Indents.Replace_Element (I, (Int, Temp));
+ end;
+ end case;
+ end;
+ end loop;
end Resolve_Anchors;
procedure Set_End
@@ -550,14 +557,21 @@ package body Wisi is
Descriptor : access constant WisiToken.Descriptor;
Source_File_Name : in String;
Post_Parse_Action : in Post_Parse_Action_Type;
- Line_Count : in Line_Number_Type;
+ Begin_Line : in Line_Number_Type;
+ End_Line : in Line_Number_Type;
+ Begin_Indent : in Integer;
Params : in String)
is
pragma Unreferenced (Params);
begin
+ Data.Line_Begin_Pos.Set_First_Last
+ (First => Begin_Line,
+ Last => End_Line);
+
-- + 1 for data on line following last line; see Lexer_To_Augmented.
- Data.Line_Begin_Pos.Set_Length (Ada.Containers.Count_Type (Line_Count +
1), Default => Invalid_Buffer_Pos);
- Data.Line_Paren_State.Set_Length (Ada.Containers.Count_Type (Line_Count
+ 1));
+ Data.Line_Paren_State.Set_First_Last
+ (First => Begin_Line,
+ Last => End_Line + 1);
Data.Descriptor := Descriptor;
Data.Source_File_Name := +Source_File_Name;
@@ -567,7 +581,11 @@ package body Wisi is
when Navigate | Face =>
null;
when Indent =>
- Data.Indents.Set_Length (Ada.Containers.Count_Type (Line_Count));
+ Data.Indents.Set_First_Last
+ (First => Begin_Line,
+ Last => End_Line);
+
+ Data.Begin_Indent := Begin_Indent;
end case;
Data.Reset;
@@ -618,6 +636,25 @@ package body Wisi is
begin
if Lexer.First then
Data.Line_Begin_Pos (Token.Line) := Token.Char_Region.First;
+
+ if Token.Line > Data.Line_Begin_Pos.First_Index and then
+ Data.Line_Begin_Pos (Token.Line - 1) = Invalid_Buffer_Pos
+ then
+ -- Previous token contains multiple lines; ie %code in
wisitoken_grammar.wy
+ declare
+ First_Unset_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;
+ 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
+ end loop;
+ end;
+ end if;
end if;
if Token.ID < Data.Descriptor.First_Terminal then
@@ -628,7 +665,7 @@ package body Wisi is
end if;
if Data.Terminals.Length = 0 then
- Data.Leading_Non_Grammar.Append (Token);
+ Data.Leading_Non_Grammar.Append ((Token with Lexer.First));
else
declare
Containing_Token : Augmented_Token renames Data.Terminals
(Data.Terminals.Last_Index);
@@ -640,15 +677,13 @@ package body Wisi is
(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
- Containing_Token.First := True;
-
if Containing_Token.First_Trailing_Comment_Line =
Invalid_Line_Number then
Containing_Token.First_Trailing_Comment_Line :=
Token.Line;
end if;
Containing_Token.Last_Trailing_Comment_Line := Token.Line;
end if;
- Containing_Token.Non_Grammar.Append ((Token.ID, Token.Line,
Token.Column, Lexer.First));
+ Containing_Token.Non_Grammar.Append ((Token with Lexer.First));
end;
end if;
@@ -686,41 +721,98 @@ package body Wisi is
overriding
procedure Delete_Token
- (Data : in out Parse_Data_Type;
- Token_Index : in WisiToken.Token_Index)
+ (Data : in out Parse_Data_Type;
+ Deleted_Token_Index : in WisiToken.Token_Index)
is
use all type Ada.Containers.Count_Type;
- Deleted_Token : Augmented_Token renames Data.Terminals (Token_Index);
- Prev_Token_Index : WisiToken.Base_Token_Index := Token_Index - 1;
+ Deleted_Token : Augmented_Token renames Data.Terminals
(Deleted_Token_Index);
+ Prev_Token_Index : Base_Token_Index := Deleted_Token_Index - 1;
+ Next_Token_Index : Base_Token_Index := Deleted_Token_Index + 1;
begin
- pragma Assert (Deleted_Token.Deleted = False);
- Deleted_Token.Deleted := True;
- if Deleted_Token.Non_Grammar.Length = 0 then
+ if Deleted_Token.Deleted then
+ -- This can happen if error recovery screws up.
+ if WisiToken.Trace_Action > WisiToken.Detail then
+ Ada.Text_IO.Put_Line (";; delete token again; ignored " & Image
(Deleted_Token, Data.Descriptor.all));
+ end if;
return;
end if;
+ if WisiToken.Trace_Action > WisiToken.Detail then
+ Ada.Text_IO.Put_Line (";; delete token " & Image (Deleted_Token,
Data.Descriptor.all));
+ end if;
+
+ Deleted_Token.Deleted := True;
+
+ if Deleted_Token.Non_Grammar.Length > 0 then
+ -- Move Non_Grammar to previous non-deleted token
+
+ loop
+ exit when Prev_Token_Index = Base_Token_Index'First;
+ exit when Data.Terminals (Prev_Token_Index).Deleted = False;
+ Prev_Token_Index := Prev_Token_Index - 1;
+ end loop;
- loop
if Prev_Token_Index = Base_Token_Index'First then
- return;
+ Deleted_Token.Non_Grammar
(Deleted_Token.Non_Grammar.First_Index).First := Deleted_Token.First;
+ Data.Leading_Non_Grammar.Append (Deleted_Token.Non_Grammar);
+ else
+ declare
+ Prev_Token : Augmented_Token renames Data.Terminals
(Prev_Token_Index);
+ begin
+ Prev_Token.Non_Grammar.Append (Deleted_Token.Non_Grammar);
+
+ if Deleted_Token.First_Trailing_Comment_Line /=
Invalid_Line_Number then
+ if Prev_Token.First_Trailing_Comment_Line =
Invalid_Line_Number then
+ Prev_Token.First_Trailing_Comment_Line :=
Deleted_Token.First_Trailing_Comment_Line;
+ end if;
+ Prev_Token.Last_Trailing_Comment_Line :=
Deleted_Token.Last_Trailing_Comment_Line;
+ end if;
+ end;
end if;
- exit when Data.Terminals (Prev_Token_Index).Deleted = False;
- Prev_Token_Index := Prev_Token_Index - 1;
+ end if;
+
+ -- Data.Terminals.Last_Index is Wisi_EOI; it is never deleted
+ loop
+ exit when Data.Terminals (Next_Token_Index).Deleted = False;
+ Next_Token_Index := Next_Token_Index + 1;
+ exit when Next_Token_Index = Data.Terminals.Last_Index;
end loop;
- declare
- Prev_Token : Augmented_Token renames Data.Terminals
(Prev_Token_Index);
- begin
- Prev_Token.Non_Grammar.Append (Deleted_Token.Non_Grammar);
- if Deleted_Token.First_Trailing_Comment_Line /= Invalid_Line_Number
then
- if Prev_Token.First_Trailing_Comment_Line = Invalid_Line_Number
then
- if Deleted_Token.First then
- Prev_Token.First_Trailing_Comment_Line :=
Deleted_Token.First_Indent_Line;
+
+ if Deleted_Token.First and
+ (Next_Token_Index = Data.Terminals.Last_Index or else
+ Data.Terminals (Next_Token_Index).Line > Deleted_Token.Line)
+ then
+ -- Deleted_Token.Line is now blank; add to previous token non
+ -- grammar.
+ if Prev_Token_Index > Base_Token_Index'First then
+ declare
+ Prev_Token : Augmented_Token renames Data.Terminals
(Prev_Token_Index);
+ begin
+ if Prev_Token.First_Trailing_Comment_Line = Invalid_Line_Number
then
+ Prev_Token.First_Trailing_Comment_Line := Deleted_Token.Line;
+ Prev_Token.Last_Trailing_Comment_Line := Deleted_Token.Line;
else
- Prev_Token.First_Trailing_Comment_Line :=
Deleted_Token.First_Trailing_Comment_Line;
+ if Prev_Token.First_Trailing_Comment_Line >
Deleted_Token.Line then
+ Prev_Token.First_Trailing_Comment_Line :=
Deleted_Token.Line;
+ end if;
+ if Prev_Token.Last_Trailing_Comment_Line <
Deleted_Token.Line then
+ Prev_Token.Last_Trailing_Comment_Line :=
Deleted_Token.Line;
+ end if;
end if;
- end if;
- Prev_Token.Last_Trailing_Comment_Line :=
Deleted_Token.Last_Trailing_Comment_Line;
+ end;
end if;
- end;
+ end if;
+
+ if Deleted_Token.First and Next_Token_Index < Data.Terminals.Last_Index
then
+ if not Data.Terminals (Next_Token_Index).First then
+ declare
+ Next_Token : Augmented_Token renames Data.Terminals
(Next_Token_Index);
+ begin
+ Next_Token.First := True;
+ Next_Token.First_Indent_Line := Deleted_Token.First_Indent_Line;
+ Next_Token.Last_Indent_Line := Deleted_Token.Last_Indent_Line;
+ end;
+ end if;
+ end if;
end Delete_Token;
overriding
@@ -759,19 +851,17 @@ package body Wisi is
Aug_Nonterm.First := Aug_Nonterm.First or Aug_Token.First;
- if Aug_Token.First then
- if Aug_Token.First_Indent_Line /= Invalid_Line_Number then
- Aug_Nonterm.First_Indent_Line :=
Aug_Token.First_Indent_Line;
- elsif Trailing_Comment_Done and
Aug_Token.First_Trailing_Comment_Line /= Invalid_Line_Number then
- Aug_Nonterm.First_Indent_Line :=
Aug_Token.First_Trailing_Comment_Line;
- end if;
+ if Aug_Token.First_Indent_Line /= Invalid_Line_Number then
+ Aug_Nonterm.First_Indent_Line :=
Aug_Token.First_Indent_Line;
+ elsif Trailing_Comment_Done and
Aug_Token.First_Trailing_Comment_Line /= Invalid_Line_Number then
+ Aug_Nonterm.First_Indent_Line :=
Aug_Token.First_Trailing_Comment_Line;
+ end if;
- if Aug_Nonterm.Last_Indent_Line = Invalid_Line_Number then
- if Trailing_Comment_Done and
Aug_Token.Last_Trailing_Comment_Line /= Invalid_Line_Number then
- Aug_Nonterm.Last_Indent_Line :=
Aug_Token.Last_Trailing_Comment_Line;
- elsif Aug_Token.Last_Indent_Line /=
Invalid_Line_Number then
- Aug_Nonterm.Last_Indent_Line :=
Aug_Token.Last_Indent_Line;
- end if;
+ if Aug_Nonterm.Last_Indent_Line = Invalid_Line_Number then
+ if Trailing_Comment_Done and
Aug_Token.Last_Trailing_Comment_Line /= Invalid_Line_Number then
+ Aug_Nonterm.Last_Indent_Line :=
Aug_Token.Last_Trailing_Comment_Line;
+ elsif Aug_Token.Last_Indent_Line /= Invalid_Line_Number
then
+ Aug_Nonterm.Last_Indent_Line :=
Aug_Token.Last_Indent_Line;
end if;
end if;
@@ -876,7 +966,7 @@ package body Wisi is
Containing : in Positive_Index_Type;
Contained : in Positive_Index_Type)
is
- use all type WisiToken.Syntax_Trees.Node_Label;
+ use all type Syntax_Trees.Node_Label;
pragma Unreferenced (Nonterm);
-- [2] wisi-containing-action.
@@ -952,21 +1042,21 @@ package body Wisi is
end;
end Containing_Action;
- function "+" (Item : in WisiToken.Token_ID) return Token_ID_Lists.List
+ function "+" (Item : in Token_ID) return Token_ID_Lists.List
is begin
return Result : Token_ID_Lists.List do
Result.Append (Item);
end return;
end "+";
- function "&" (List : in Token_ID_Lists.List; Item : in WisiToken.Token_ID)
return Token_ID_Lists.List
+ function "&" (List : in Token_ID_Lists.List; Item : in Token_ID) return
Token_ID_Lists.List
is begin
return Result : Token_ID_Lists.List := List do
Result.Append (Item);
end return;
end "&";
- function "&" (Left, Right : in WisiToken.Token_ID) return
Token_ID_Lists.List
+ function "&" (Left, Right : in Token_ID) return Token_ID_Lists.List
is begin
return Result : Token_ID_Lists.List do
Result.Append (Left);
@@ -1284,7 +1374,7 @@ package body Wisi is
return "(" & Simple_Indent_Param_Label'Image (Item.Label) &
(case Item.Label is
when Int => Integer'Image (Item.Int_Delta),
- when Anchored_Label => WisiToken.Positive_Index_Type'Image
(Item.Anchored_Index) & "," &
+ when Anchored_Label => Positive_Index_Type'Image
(Item.Anchored_Index) & "," &
Integer'Image (Item.Anchored_Delta),
when Language => "<language_function>") & ")";
end Image;
@@ -1314,35 +1404,33 @@ package body Wisi is
Params : in Indent_Param_Array)
is begin
if Trace_Action > Outline then
- Ada.Text_IO.Put_Line ("indent_action_0: " & Tree.Image (Nonterm,
Data.Descriptor.all));
+ Ada.Text_IO.Put_Line (";; indent_action_0: " & Tree.Image (Nonterm,
Data.Descriptor.all));
end if;
-- [2] wisi-indent-action
for I in Tokens'Range loop
if Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region then
declare
+ use all type WisiToken.Syntax_Trees.Node_Index;
use all type SAL.Base_Peek_Type;
- Tree_Token : constant Syntax_Trees.Valid_Node_Index := Tokens
(I);
-
- Token : constant Aug_Token_Ref := Get_Aug_Token
(Data, Tree, Tree_Token);
+ Tree_Token : constant Syntax_Trees.Valid_Node_Index :=
Tokens (I);
+ Token : constant Aug_Token_Ref :=
Get_Aug_Token (Data, Tree, Tree_Token);
Pair : Indent_Pair renames Params (I);
Code_Delta : Delta_Type;
Comment_Param : Indent_Param;
- Comment_Param_Set : Boolean := False;
+ Comment_Param_Set : Boolean :=
False;
Comment_Delta : Delta_Type;
begin
if Trace_Action > Detail then
Ada.Text_IO.Put_Line
- ("indent_action_0 a: " & Tree.Image (Tree_Token,
Data.Descriptor.all) & ": " & Image (Pair));
+ (";; indent_action_0 a: " & Tree.Image (Tree_Token,
Data.Descriptor.all) & ": " & Image (Pair));
end if;
if Token.First_Indent_Line /= Invalid_Line_Number then
Code_Delta := Indent_Compute_Delta
(Data, Tree, Tokens, Pair.Code_Delta, Tree_Token,
Indenting_Comment => False);
- if Code_Delta /= Null_Delta then
- Indent_Token_1 (Data, Token, Code_Delta,
Indenting_Comment => False);
- end if;
+ Indent_Token_1 (Data, Token, Code_Delta, Indenting_Comment
=> False);
end if;
if Token.First_Trailing_Comment_Line /= Invalid_Line_Number then
@@ -1353,15 +1441,14 @@ package body Wisi is
elsif I < Tokens'Last then
Comment_Param := Params (I + 1).Code_Delta;
Comment_Param_Set := True;
+
end if;
if Comment_Param_Set then
Comment_Delta := Indent_Compute_Delta
(Data, Tree, Tokens, Comment_Param, Tree_Token,
Indenting_Comment => True);
- if Comment_Delta /= Null_Delta then
- Indent_Token_1 (Data, Token, Comment_Delta,
Indenting_Comment => True);
- end if;
+ Indent_Token_1 (Data, Token, Comment_Delta,
Indenting_Comment => True);
end if;
end if;
end;
@@ -1377,7 +1464,7 @@ package body Wisi is
N : in Positive_Index_Type;
Params : in Indent_Param_Array)
is
- use all type WisiToken.Syntax_Trees.Node_Label;
+ use all type Syntax_Trees.Node_Label;
begin
-- [2] wisi-indent-action*
for I in Tokens'First .. N loop
@@ -1426,8 +1513,62 @@ package body Wisi is
end if;
end Indent_Hanging_1;
- procedure Put (Data : in out Parse_Data_Type)
- is begin
+ procedure Put (Data : in out Parse_Data_Type; Parser : in
Parse.Base_Parser'Class)
+ is
+ use all type Ada.Containers.Count_Type;
+
+ Last_Term : constant Base_Token_Index := Parser.Tree.Max_Terminal_Index
(Parser.Tree.Root);
+
+ function Get_Last_Char_Pos return Buffer_Pos
+ is begin
+ if Parser.Terminals.Length = 0 then
+ -- All comments, or empty
+ if Data.Leading_Non_Grammar.Length > 0 then
+ return Data.Leading_Non_Grammar
(Data.Leading_Non_Grammar.Last_Index).Char_Region.Last;
+ else
+ return Buffer_Pos'First;
+ end if;
+ else
+ if Last_Term = Invalid_Token_Index then
+ -- All grammar tokens inserted by recover
+ if Data.Leading_Non_Grammar.Length > 0 then
+ return Data.Leading_Non_Grammar
(Data.Leading_Non_Grammar.Last_Index).Char_Region.Last;
+ else
+ return Buffer_Pos'First;
+ end if;
+ else
+ if Data.Terminals (Last_Term).Non_Grammar.Length > 0 then
+ return Data.Terminals (Last_Term).Non_Grammar
+ (Data.Terminals
(Last_Term).Non_Grammar.Last_Index).Char_Region.Last;
+ else
+ return Parser.Terminals (Last_Term).Char_Region.Last;
+ end if;
+ end if;
+ end if;
+ end Get_Last_Char_Pos;
+
+ Last_Char_Pos : constant Buffer_Pos := Get_Last_Char_Pos;
+
+ 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) > Last_Char_Pos then
+ return I - 1;
+ end if;
+ end loop;
+ return Data.Line_Begin_Pos.Last_Index;
+ end Get_Last_Line;
+
+ begin
+ if Trace_Action > Outline then
+ Ada.Text_IO.Put_Line
+ (";; last_char_pos:" & Buffer_Pos'Image (Last_Char_Pos + 1) &
+ " last_line:" & Line_Number_Type'Image (Get_Last_Line));
+ end if;
+
+ -- +1 to match Emacs region
+ Ada.Text_IO.Put_Line ('[' & End_Code & Buffer_Pos'Image (Last_Char_Pos +
1) & ']');
+
case Data.Post_Parse_Action is
when Navigate =>
for Cache of Data.Navigate_Caches loop
@@ -1440,18 +1581,46 @@ package body Wisi is
end loop;
when Indent =>
- -- We don't need "Indent_Leading_Comments"; they are indented to 0,
- -- which is the default.
Resolve_Anchors (Data);
- -- Can't set indent for first line
- for I in Data.Indents.First_Index + 1 .. Data.Indents.Last_Index loop
+ if Trace_Action > Outline then
+ Ada.Text_IO.Put_Line (";; indent leading non_grammar");
+ end if;
+ for Token of Data.Leading_Non_Grammar loop
+ if Token.First then
+ Put (Token.Line, (Int, Data.Begin_Indent));
+ end if;
+ end loop;
+
+ -- It may be that not all lines in Data.Indents were parsed.
+ if Trace_Action > Outline then
+ Ada.Text_IO.Put_Line (";; indent grammar");
+ end if;
+ for I in Data.Indents.First_Index .. Get_Last_Line loop
Put (I, Data.Indents (I));
end loop;
end case;
end Put;
+ procedure Put (Lexer_Errors : in Lexer.Error_Lists.List)
+ is begin
+ for Item of Lexer_Errors loop
+ Ada.Text_IO.Put_Line
+ ('[' & Lexer_Error_Code & Buffer_Pos'Image (Item.Char_Pos) &
+ " ""lexer error" &
+ (if Item.Recover_Char (1) = ASCII.NUL
+ then """"
+ elsif Item.Recover_Char (1) = '"'
+ then """ ?\"""
+ else """ ?" & Item.Recover_Char (1)) &
+ "]");
+ if Item.Recover_Char (2) /= ASCII.NUL then
+ raise SAL.Programmer_Error with "lexer error with non-ascii or
multiple repair char";
+ end if;
+ end loop;
+ end Put;
+
procedure Put
(Data : in Parse_Data_Type;
Lexer_Errors : in Lexer.Error_Lists.List;
@@ -1508,20 +1677,7 @@ package body Wisi is
end Safe_Pos;
begin
- for Item of Lexer_Errors loop
- Put_Line
- ('[' & Lexer_Error_Code & Buffer_Pos'Image (Item.Char_Pos) &
- " ""lexer error" &
- (if Item.Recover_Char (1) = ASCII.NUL
- then """"
- elsif Item.Recover_Char (1) = '"'
- then """ ?\"""
- else """ ?" & Item.Recover_Char (1)) &
- "]");
- if Item.Recover_Char (2) /= ASCII.NUL then
- raise SAL.Programmer_Error with "lexer error with non-ascii or
multiple repair char";
- end if;
- end loop;
+ Put (Lexer_Errors);
for Item of Parse_Errors loop
-- We don't include parser id here; not very useful.
@@ -1645,7 +1801,7 @@ package body Wisi is
Descriptor : in WisiToken.Descriptor)
return String
is
- ID_Image : constant String := WisiToken.Image (Item.ID, Descriptor);
+ ID_Image : constant String := Image (Item.ID, Descriptor);
begin
if Item.Line /= Invalid_Line_Number and Trace_Action <= Detail then
return "(" & ID_Image &
@@ -1839,7 +1995,7 @@ package body Wisi is
begin
if Trace_Action > Detail then
Ada.Text_IO.Put_Line
- ("indent_token_1: " & Indenting_Token.Image (Data.Descriptor.all) &
" " & Image (Delta_Indent) &
+ (";; indent_token_1: " & Indenting_Token.Image
(Data.Descriptor.all) & " " & Image (Delta_Indent) &
Line_Number_Type'Image (First_Line) & " .." &
Line_Number_Type'Image (Last_Line) &
(if Indenting_Comment then " comment" else ""));
end if;
@@ -1850,11 +2006,11 @@ package body Wisi is
use all type Ada.Text_IO.Count;
Indent : Boolean := True;
begin
- if Data.Line_Begin_Token.all (Line) /=
Augmented_Token_Arrays.No_Index then
+ 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.Col = 0
+ Tok.Column = 0
then
Indent := False;
exit;
@@ -1864,6 +2020,8 @@ package body Wisi is
if Indent then
Indent_Line (Data, Line, Delta_Indent);
+ else
+ Indent_Line (Data, Line, Null_Delta);
end if;
end;
else
diff --git a/wisi.ads b/wisi.ads
index 4203930..d3f1214 100644
--- a/wisi.ads
+++ b/wisi.ads
@@ -10,7 +10,7 @@
--
-- [3] wisi-process-parse.el - defines elisp/process API
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -28,7 +28,6 @@ pragma License (Modified_GPL);
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
-with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with SAL.Gen_Unbounded_Definite_Red_Black_Trees;
with SAL.Gen_Unbounded_Definite_Vectors;
@@ -49,16 +48,12 @@ package Wisi is
Descriptor : access constant WisiToken.Descriptor;
Source_File_Name : in String;
Post_Parse_Action : in Post_Parse_Action_Type;
- Line_Count : in WisiToken.Line_Number_Type;
+ Begin_Line : in WisiToken.Line_Number_Type;
+ End_Line : in WisiToken.Line_Number_Type;
+ Begin_Indent : in Integer;
Params : in String);
- -- Line_Count only used for Indent. Params contains language-specific
- -- indent parameter values.
- --
- -- It is possible to do without the Line_Count parameter, and grow
- -- the various vectors dynamically. However, doing that caused
- -- intermittent problems with too many lines; the Ada code saw more
- -- lines than the elisp code did. Using the elisp line count is more
- -- reliable.
+ -- Begin_Line, Begin_Indent, Line_Count only used for Indent. Params
+ -- contains language-specific indent parameter values.
overriding procedure Reset (Data : in out Parse_Data_Type);
-- Reset for a new parse, with data from previous Initialize.
@@ -74,8 +69,8 @@ package Wisi is
overriding
procedure Delete_Token
- (Data : in out Parse_Data_Type;
- Token_Index : in WisiToken.Token_Index);
+ (Data : in out Parse_Data_Type;
+ Deleted_Token_Index : in WisiToken.Token_Index);
overriding
procedure Reduce
@@ -318,11 +313,12 @@ package Wisi is
-- Language specific child packages override this to implement
-- wisi-elisp-parse-indent-hanging-function.
- procedure Put (Data : in out Parse_Data_Type);
- -- Perform post-parse actions, then put result to
+ 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]
-- wisi-process-parse--execute.
+ procedure Put (Lexer_Errors : in WisiToken.Lexer.Error_Lists.List);
procedure Put
(Data : in Parse_Data_Type;
Lexer_Errors : in WisiToken.Lexer.Error_Lists.List;
@@ -337,16 +333,12 @@ package Wisi is
private
- type Non_Grammar_Token is record
- ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
- Line : WisiToken.Line_Number_Type := WisiToken.Invalid_Line_Number;
- Col : Ada.Text_IO.Count := Ada.Text_IO.Count'Last;
- First : Boolean := False;
- -- Column is needed to detect comments in column 0.
+ type Non_Grammar_Token is new WisiToken.Base_Token with record
+ First : Boolean := False;
end record;
package Non_Grammar_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (WisiToken.Token_Index, Non_Grammar_Token);
+ (WisiToken.Token_Index, Non_Grammar_Token, Default_Element => (others =>
<>));
type Augmented_Token is new WisiToken.Base_Token with record
-- Most fields are set by Lexer_To_Augmented at parse time; others
@@ -359,11 +351,9 @@ private
-- The following fields are only needed for indent.
First : Boolean := False;
- -- For a terminal, True if the token is not empty and it is first on
- -- a line, or if it contains trailing blank or comment lines.
+ -- For a terminal, True if the token is first on a line.
--
- -- For a nonterminal, True if some contained token's First is True,
- -- including trailing comments and blank lines.
+ -- For a nonterminal, True if some contained token's First is True.
Paren_State : Integer := 0;
-- Parenthesis nesting count, before token.
@@ -431,12 +421,14 @@ private
Descriptor : in WisiToken.Descriptor)
return String;
- package Augmented_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(WisiToken.Token_Index, Augmented_Token);
+ package Augmented_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (WisiToken.Token_Index, Augmented_Token, Default_Element => (others =>
<>));
-- Index matches Base_Token_Arrays.
- package Line_Paren_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
(WisiToken.Line_Number_Type, Integer);
+ package Line_Paren_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
+ (WisiToken.Line_Number_Type, Integer, Default_Element => Integer'Last);
package Line_Begin_Pos_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
- (WisiToken.Line_Number_Type, WisiToken.Buffer_Pos);
+ (WisiToken.Line_Number_Type, WisiToken.Buffer_Pos, Default_Element =>
WisiToken.Invalid_Buffer_Pos);
type Nil_Buffer_Pos (Set : Boolean := False) is record
case Set is
@@ -520,7 +512,8 @@ private
end record;
First_Anchor_ID : constant Positive := Positive'First;
- package Indent_Vectors is new Ada.Containers.Vectors
(WisiToken.Line_Number_Type, Indent_Type);
+ package Indent_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
+ (WisiToken.Line_Number_Type, Indent_Type, Default_Element => (others =>
<>));
package Navigate_Cursor_Lists is new Ada.Containers.Doubly_Linked_Lists
(Navigate_Cache_Trees.Cursor, Navigate_Cache_Trees."=");
@@ -535,7 +528,7 @@ private
-- immediately following non-grammar tokens. Does not contain
-- nonterminal or virtual tokens.
- Leading_Non_Grammar : WisiToken.Base_Token_Arrays.Vector;
+ Leading_Non_Grammar : Non_Grammar_Token_Arrays.Vector;
-- non-grammar tokens before first grammar token.
Line_Begin_Pos : Line_Begin_Pos_Vectors.Vector;
@@ -558,6 +551,7 @@ private
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.
+ Begin_Indent : Integer; -- Indentation of line
at start of parse.
-- Copied from language-specific parameters
Indent_Comment_Col_0 : Boolean := False;
diff --git a/wisi.el b/wisi.el
index 4a6b7ad..3aa522c 100644
--- a/wisi.el
+++ b/wisi.el
@@ -1,15 +1,15 @@
;;; wisi.el --- Utilities for implementing an indentation/navigation engine
using a generalized LALR parser -*- lexical-binding:t -*-
;;
-;; Copyright (C) 2012 - 2018 Free Software Foundation, Inc.
+;; 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.0.1
+;; Version: 2.1.0
;; package-requires: ((cl-lib "1.0") (emacs "25.0") (seq "2.20"))
-;; URL: http://www.nongnu.org/ada-mode/wisi/wisi.html
+;; URL: http://stephe-leake.org/ada/wisitoken.html
;;
;; This file is part of GNU Emacs.
;;
@@ -47,6 +47,9 @@
;; 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
@@ -56,16 +59,23 @@
;; indentation (Python). Adding comments does not change a parse,
;; unless code is commented out.
;;
-;; For font-lock and navigate, keeping track of the point after which
-;; caches have been deleted is sufficent (see `wisi-cache-max').
+;; 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 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 (normally the whole buffer),
-;; but performs the indent only on the lines in the indent
+;; 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.
+;; 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.
@@ -85,7 +95,8 @@
;; 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.
+;; 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
@@ -120,13 +131,23 @@
(require 'wisi-elisp-lexer)
(require 'wisi-fringe)
-(defcustom wisi-size-threshold 100000
+(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
@@ -145,6 +166,14 @@ Useful when debugging parser or parser actions."
(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
@@ -163,100 +192,183 @@ Useful when debugging parser or parser actions."
(defun wisi-set-parse-try (value &optional parse-action)
(setcdr (assoc (or parse-action wisi--parse-action) wisi--parse-try) value))
-(defvar-local wisi--cache-max
+(defvar-local wisi--cached-regions
(list
(cons 'face nil)
(cons 'navigate nil)
(cons 'indent nil))
- "Alist of maximimum position in buffer where parser text properties are
valid.")
+ "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))
-(defun wisi-cache-max (&optional parse-action)
- ;; Don't need 'wisi-set-cache-max; (move-marker (wisi-cache-max) foo) works
- (let ((mark (cdr (assoc (or parse-action wisi--parse-action)
wisi--cache-max))))
- (unless (marker-position mark)
- ;; Sometimes marker gets set to <marker in no buffer>; not clear how.
- (move-marker mark (point-min)))
- mark))
+ ((> 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) '(wisi-face nil 'font-lock-face
nil))
- ))
+ (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 (< after (wisi-cache-max action))
+ (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)
- ;; 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))
- ))
+ (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)))
+ (setq after (point))))
(wisi--delete-navigate-cache after))
((eq 'indent action)
- ;; indent cache is stored on newline before line being indented.
+ ;; 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))))
)
- (move-marker (wisi-cache-max action) after)
))
(defun wisi-reset-parser ()
- "For ’ada-reset-parser’."
- (wisi-invalidate-cache 'indent 0)
- (wisi-invalidate-cache 'face 0)
- (wisi-invalidate-cache 'navigate 0))
+ "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
@@ -323,21 +435,35 @@ Used to ignore whitespace changes in before/after change
hooks.")
"For `after-change-functions'"
;; begin . end is range of text being inserted (empty if equal);
;; length is the size of the deleted text.
- ;;
- ;; This change might be changing to/from a keyword; trigger
- ;; font-lock. See test/ada_mode-interactive_common.adb Obj_1.
- (unless wisi-indenting-p
+
+ ;; 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
- (let (word-end)
- (goto-char end)
- (skip-syntax-forward "w_")
- (setq word-end (point))
- (goto-char begin)
- (skip-syntax-backward "w_")
+ (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 (point) word-end '(font-lock-face nil
fontified nil)))
- )
- )))
+ (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."
@@ -346,14 +472,6 @@ Used to ignore whitespace changes in before/after change
hooks.")
;; see comments above on syntax-propertize
(when (< emacs-major-version 25) (syntax-propertize end))
- ;; Remove caches on inserted text, which could have caches from
- ;; before the failed parse (or another buffer), and are in any case
- ;; invalid. No point in removing 'fontified; that's handled by
- ;; jit-lock.
-
- (with-silent-modifications
- (remove-text-properties begin end '(wisi-cache nil font-lock-face nil)))
-
(save-excursion
(let ((need-invalidate t)
(done nil)
@@ -547,19 +665,31 @@ Usefull if the parser appears to be hung."
;; also force re-parse
(dolist (parse-action '(face navigate indent))
(wisi-set-parse-try t parse-action)
- (move-marker (wisi-cache-max parse-action) (point-max));; force delete
caches
(wisi-invalidate-cache parse-action (point-min)))
)
-(defun wisi--run-parse ()
- "Run the parser."
- (unless (buffer-narrowed-p)
- (let ((msg (when (> wisi-debug 0)
- (format "wisi: parsing %s %s:%d ..."
- wisi--parse-action
- (buffer-name)
- (line-number-at-pos (point))))))
- (when (> wisi-debug 0)
+(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)
@@ -573,19 +703,25 @@ Usefull if the parser appears to be hung."
(condition-case-unless-debug err
(save-excursion
- (wisi-parse-current wisi--parser)
- (setq wisi-parse-failed nil)
- (move-marker (wisi-cache-max) (point))
- )
+ (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 parse are ok
- (wisi--delete-face-cache (wisi-cache-max)))
+ ;; caches set by failed elisp parse are ok
+ (wisi--delete-face-cache (cdr parsed-region)))
(navigate
- ;; parse partially resets caches before and after wisi-cache-max
- (move-marker (wisi-cache-max) (point-min))
+ ;; elisp parse partially resets caches
(wisi--delete-navigate-cache (point-min)))
(indent
@@ -600,12 +736,13 @@ Usefull if the parser appears to be hung."
(signal (car err) (cdr err)))
)
- (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))))
+ (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 0)
+ (when (> wisi-debug 1)
(if (or (wisi-parser-lexer-errors wisi--parser)
(wisi-parser-parse-errors wisi--parser))
(progn
@@ -632,23 +769,30 @@ Usefull if the parser appears to be hung."
(move-marker wisi--change-end (point-min))
))
-(defun wisi-validate-cache (pos error-on-fail parse-action)
- "Ensure cached data for PARSE-ACTION is valid at least up to POS in current
buffer."
- (if (< (point-max) wisi-size-threshold)
+(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-max.
-
- ;; If wisi-cache-max = pos, then there is no cache at pos; need parse
- (when (and (not wisi-inhibit-parse)
- (wisi-parse-try)
- (<= (wisi-cache-max) pos))
+ ;; Now we can rely on wisi-cache-covers-region
- ;; Don't keep retrying failed parse until text changes again.
- (wisi-set-parse-try nil)
-
- (wisi--run-parse))
+ (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.
@@ -656,11 +800,14 @@ Usefull if the parser appears to be hung."
(error "parse %s failed" parse-action))
)
(when (> wisi-debug 0)
- (message "parse skipped due to ‘wisi-size-threshold’"))))
+ (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)
+(defun wisi-fontify-region (begin end)
"For `jit-lock-functions'."
- (wisi-validate-cache end nil 'face))
+ (wisi-validate-cache begin end nil 'face))
(defun wisi-get-containing-cache (cache)
"Return cache from (wisi-cache-containing CACHE)."
@@ -746,7 +893,7 @@ If LIMIT (a buffer position) is reached, throw an error."
cache. Otherwise move to cache-next, or cache-end, or next cache
if both nil. Return cache found."
(unless (eobp)
- (wisi-validate-cache (point-max) t 'navigate) ;; ensure there is a next
cache to move to
+ (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)))
@@ -763,7 +910,7 @@ if both nil. Return cache found."
(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) t 'navigate)
+ (wisi-validate-cache (point-min) (point-max) t 'navigate)
(let ((cache (wisi-get-cache (point)))
prev)
(when cache
@@ -849,14 +996,14 @@ Return start cache."
"Move point to token at start of statement point is in or after.
Return start cache."
(interactive)
- (wisi-validate-cache (point) t 'navigate)
+ (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) t 'navigate)
+ (wisi-validate-cache (point-min) (point-max) t 'navigate)
(let ((cache (or (wisi-get-cache (point))
(wisi-forward-cache))))
(when (wisi-cache-end cache)
@@ -914,7 +1061,7 @@ the comment on the previous line."
(defun wisi-indent-statement ()
"Indent region given by `wisi-goto-start', `wisi-cache-end'."
- (wisi-validate-cache (point) t 'navigate)
+ (wisi-validate-cache (point-min) (point-max) t 'navigate)
(save-excursion
(let ((cache (or (wisi-get-cache (point))
@@ -965,8 +1112,43 @@ Called with BEGIN END.")
;; single line in buffer; terminate loop
(goto-char (point-max))))))
-(defun wisi-indent-region (begin end)
- "For `indent-region-function', using the wisi indentation engine."
+(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))
@@ -974,14 +1156,15 @@ Called with BEGIN END.")
(wisi--check-change)
- ;; Always indent the line containing BEGIN.
+ ;; 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)
- (<= (point) end)
+ (or (and (= begin end) (= (point) end))
+ (< (point) end))
(not (eobp)))
(unless (get-text-property (1- (point)) 'wisi-indent)
(setq parse-required t))
@@ -989,18 +1172,23 @@ Called with BEGIN END.")
)
;; A parse either succeeds and sets the indent cache on all
- ;; lines in the buffer, or fails and leaves valid caches
+ ;; lines in the parsed region, or fails and leaves valid caches
;; untouched.
(when (and parse-required
- (wisi-parse-try))
+ (or (not wisi-parse-failed)
+ (wisi-parse-try 'indent)))
(wisi-set-parse-try nil)
- (wisi--run-parse)
+
+ (wisi--run-parse begin end)
;; If there were errors corrected, the indentation is
- ;; potentially ambiguous; see test/ada_mode-interactive_2.adb
- (setq wisi-indent-failed (< 0 (+ (length (wisi-parser-lexer-errors
wisi--parser))
- (length (wisi-parser-parse-errors
wisi--parser)))))
+ ;; 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
@@ -1008,6 +1196,8 @@ Called with BEGIN END.")
;; 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
@@ -1015,22 +1205,28 @@ Called with BEGIN END.")
(goto-char begin)
(let ((wisi-indenting-p t))
(while (and (not (eobp))
- (<= (point) end-mark)) ;; end-mark can be at the start of
an empty line
- (indent-line-to (if (bobp) 0 (get-text-property (1- (point))
'wisi-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)))
+ (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
@@ -1038,6 +1234,8 @@ Called with BEGIN END.")
;; 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))
))
))
@@ -1050,7 +1248,7 @@ Called with BEGIN END.")
(when (>= (point) savep)
(setq to-indent t))
- (wisi-indent-region (line-beginning-position) (line-end-position))
+ (wisi-indent-region (line-beginning-position) (line-end-position) t)
(goto-char savep)
(when to-indent (back-to-indentation))
@@ -1093,7 +1291,6 @@ Called with BEGIN END.")
(if (buffer-live-p wisi-error-buffer)
(let ((err
(with-current-buffer wisi-error-buffer
- ;; FIXME: ensure at beginning of error message line.
(get-text-property (point) 'wisi-error-data))))
(wisi-repair-error-1 err))
(error "no current error found")
@@ -1122,6 +1319,24 @@ If non-nil, only repair errors in BEG END region."
;;;; 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)
@@ -1130,29 +1345,41 @@ If non-nil, only repair errors in BEG END region."
(define-key global-map "\M-j" 'wisi-show-cache)
)
-(defun wisi-parse-buffer (&optional parse-action)
+(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 'indent))
+ (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)
- (move-marker (wisi-cache-max parse-action) (point-max));; force delete caches
- (wisi-invalidate-cache parse-action (point-min))
+ (wisi-invalidate-cache parse-action begin)
(cl-ecase parse-action
(face
(with-silent-modifications
(remove-text-properties
- (point-min) (point-max)
+ begin end
(list
'font-lock-face nil
'fontified nil)))
- (wisi-validate-cache (point-max) t parse-action)
+ (wisi-validate-cache begin end t parse-action)
(when (fboundp 'font-lock-ensure) (font-lock-ensure))) ;; emacs < 25
(navigate
- (wisi-validate-cache (point-max) t parse-action))
+ (wisi-validate-cache begin end t parse-action))
(indent
- (wisi-indent-region (point-min) (point-max)))
+ (wisi-indent-region begin end))
))
(defun wisi-time (func count &optional report-wait-time)
@@ -1197,7 +1424,6 @@ If non-nil, only repair errors in BEG END region."
(wisi-time
(lambda ()
(wisi-set-parse-try t 'indent)
- (move-marker (wisi-cache-max 'indent) (point-max));; force delete caches
(wisi-invalidate-cache 'indent (point-min))
(wisi-indent-line)
(when (wisi-process--parser-p wisi--parser)
@@ -1208,7 +1434,6 @@ If non-nil, only repair errors in BEG END region."
(defun wisi-time-indent-middle-line-warm-cache (count)
(wisi-set-parse-try t 'indent)
- (move-marker (wisi-cache-max 'indent) (point-max));; force delete caches
(wisi-invalidate-cache 'indent (point-min))
(goto-char (point-min))
(forward-line (/ (count-lines (point-min) (point-max)) 2))
@@ -1221,11 +1446,10 @@ If non-nil, only repair errors in BEG END region."
(message "%s" (get-text-property (1- (line-beginning-position))
'wisi-indent)))
(defun wisi-show-cache ()
- "Show navigation and face caches, and applied faces, at point."
+ "Show navigation cache, and applied faces, at point."
(interactive)
- (message "%s:%s:%s:%s"
+ (message "%s:%s:%s"
(wisi-get-cache (point))
- (get-text-property (point) 'wisi-face)
(get-text-property (point) 'face)
(get-text-property (point) 'font-lock-face)
))
@@ -1238,10 +1462,6 @@ If non-nil, only repair errors in BEG END region."
(message "previous %s" (wisi-backward-cache)))
))
-(defun wisi-show-cache-max (action)
- (push-mark)
- (goto-char (wisi-cache-max action)))
-
;;;;; setup
(cl-defun wisi-setup (&key indent-calculate post-indent-fail parser lexer)
@@ -1251,12 +1471,11 @@ If non-nil, only repair errors in BEG END region."
(setq wisi--parser parser)
(setq wisi--lexer lexer)
-
- (setq wisi--cache-max
+ (setq wisi--cached-regions
(list
- (cons 'face (copy-marker (point-min)))
- (cons 'navigate (copy-marker (point-min)))
- (cons 'indent (copy-marker (point-min)))))
+ (cons 'face nil)
+ (cons 'navigate nil)
+ (cons 'indent nil)))
(setq wisi--parse-try
(list
diff --git a/wisitoken-bnf-generate.adb b/wisitoken-bnf-generate.adb
index 8d2da44..d74b4a5 100644
--- a/wisitoken-bnf-generate.adb
+++ b/wisitoken-bnf-generate.adb
@@ -3,7 +3,7 @@
-- Parser for Wisi grammar files, producing Ada or Elisp source
-- files for a parser.
--
--- 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
@@ -54,7 +54,7 @@ is
begin
-- verbosity meaning is actually determined by output choice;
-- they should be consistent with this description.
- Put_Line (Standard_Error, "version 1.0.1");
+ Put_Line (Standard_Error, "version 1.1.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);
diff --git a/wisitoken-bnf-generate_utils.adb b/wisitoken-bnf-generate_utils.adb
index 01bc419..8e52ca4 100644
--- a/wisitoken-bnf-generate_utils.adb
+++ b/wisitoken-bnf-generate_utils.adb
@@ -118,7 +118,7 @@ package body WisiToken.BNF.Generate_Utils is
begin
Data.Grammar (Descriptor.Accept_ID) :=
Descriptor.Accept_ID <= Only
- (Find_Token_ID (Data, Start_Token) & Descriptor.EOF_ID +
WisiToken.Syntax_Trees.Null_Action);
+ (Find_Token_ID (Data, Start_Token) & Descriptor.EOI_ID +
WisiToken.Syntax_Trees.Null_Action);
Data.Source_Line_Map (Descriptor.Accept_ID).Line :=
Line_Number_Type'First;
Data.Source_Line_Map (Descriptor.Accept_ID).RHS_Map.Set_First (0);
@@ -213,7 +213,7 @@ package body WisiToken.BNF.Generate_Utils is
function Initialize (Input_Data : aliased in
WisiToken_Grammar_Runtime.User_Data_Type) return Generate_Data
is
- EOF_ID : constant Token_ID := Token_ID
+ EOI_ID : constant Token_ID := Token_ID
(Count (Input_Data.Tokens.Non_Grammar) + Count
(Input_Data.Tokens.Tokens)) + Token_ID
(Input_Data.Tokens.Keywords.Length) + Token_ID'First;
begin
@@ -225,11 +225,11 @@ package body WisiToken.BNF.Generate_Utils is
(if Count (Input_Data.Tokens.Non_Grammar) > 0
then Token_ID (Count (Input_Data.Tokens.Non_Grammar)) +
Token_ID'First
else Token_ID'First),
- Last_Terminal => EOF_ID,
- EOF_ID => EOF_ID,
- Accept_ID => EOF_ID + 1,
- First_Nonterminal => EOF_ID + 1,
- Last_Nonterminal => EOF_ID + 1 + Token_ID
(Input_Data.Tokens.Rules.Length)),
+ Last_Terminal => EOI_ID,
+ EOI_ID => EOI_ID,
+ Accept_ID => EOI_ID + 1,
+ First_Nonterminal => EOI_ID + 1,
+ Last_Nonterminal => EOI_ID + 1 + Token_ID
(Input_Data.Tokens.Rules.Length)),
others => <>)
do
diff --git a/wisitoken-bnf-generate_utils.ads b/wisitoken-bnf-generate_utils.ads
index 9e2ff96..7720e21 100644
--- a/wisitoken-bnf-generate_utils.ads
+++ b/wisitoken-bnf-generate_utils.ads
@@ -27,7 +27,7 @@ with WisiToken_Grammar_Runtime;
package WisiToken.BNF.Generate_Utils is
EOI_Name : constant String := "Wisi_EOI";
- -- EOI_Name is used for EOF_ID token; it must match Emacs ada-mode
+ -- EOI_Name is used for Descriptor.EOI_ID token; it must match Emacs
ada-mode
-- wisi.el wisi-eoi-term. It must be a valid Ada identifier when
-- "_ID" is appended.
diff --git a/wisitoken-bnf-output_ada.adb b/wisitoken-bnf-output_ada.adb
index 0d99340..d27c602 100644
--- a/wisitoken-bnf-output_ada.adb
+++ b/wisitoken-bnf-output_ada.adb
@@ -4,7 +4,7 @@
-- parameters, and a parser for that grammar. The grammar parser
-- actions must be Ada.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 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
@@ -191,11 +191,13 @@ is
Unref_Lexer : constant Boolean := 0 = Index (Line,
"Lexer");
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");
begin
Indent_Line ("function " & Name);
- Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
- Indent_Line (" Nonterm : in out
WisiToken.Recover_Token;");
- Indent_Line (" Tokens : in
WisiToken.Recover_Token_Array)");
+ Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
+ Indent_Line (" Nonterm : in out
WisiToken.Recover_Token;");
+ Indent_Line (" Tokens : in
WisiToken.Recover_Token_Array;");
+ Indent_Line (" Recover_Active : in Boolean)");
Indent_Line (" return
WisiToken.Semantic_Checks.Check_Status");
Indent_Line ("is");
@@ -208,6 +210,9 @@ is
if Unref_Tokens then
Indent_Line (" pragma Unreferenced (Tokens);");
end if;
+ if Unref_Recover then
+ Indent_Line (" pragma Unreferenced
(Recover_Active);");
+ end if;
Indent_Line ("begin");
Indent := Indent + 3;
diff --git a/wisitoken-bnf-output_ada_common.adb
b/wisitoken-bnf-output_ada_common.adb
index de9db8c..cbd36b7 100644
--- a/wisitoken-bnf-output_ada_common.adb
+++ b/wisitoken-bnf-output_ada_common.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -138,7 +138,7 @@ package body WisiToken.BNF.Output_Ada_Common is
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 ("EOF_ID =>" &
WisiToken.Token_ID'Image (Descriptor.EOF_ID) & ",");
+ 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) & ",");
@@ -232,9 +232,10 @@ package body WisiToken.BNF.Output_Ada_Common is
for Name of Name_List.all loop
if Name /= null then
Indent_Line ("function " & Name.all);
- Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
- Indent_Line (" Nonterm : in out WisiToken.Recover_Token;");
- Indent_Line (" Tokens : in
WisiToken.Recover_Token_Array)");
+ Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
+ Indent_Line (" Nonterm : in out
WisiToken.Recover_Token;");
+ Indent_Line (" Tokens : in
WisiToken.Recover_Token_Array;");
+ Indent_Line (" Recover_Active : in Boolean)");
Indent_Line (" return
WisiToken.Semantic_Checks.Check_Status;");
end if;
end loop;
@@ -535,7 +536,7 @@ 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 Ada.Containers.Count_Type;
+ use all type WisiToken.Parse.LR.All_Parse_Action_Verbs;
use Ada.Strings.Unbounded;
Table : WisiToken.Parse.LR.Parse_Table_Ptr renames
Generate_Data.LR_Parse_Table;
@@ -711,10 +712,12 @@ package body WisiToken.BNF.Output_Ada_Common is
end loop;
end Gotos;
- if Table.States (State_Index).Minimal_Complete_Actions.Length > 0 then
+ if Input_Data.Language_Params.Error_Recover and
+ Table.States (State_Index).Minimal_Complete_Action.Verb /=
Parse.LR.Pause
+ then
Indent_Wrap
- ("Set_Minimal_Action (Table.States (" & Trimmed_Image
(State_Index) & ").Minimal_Complete_Actions, " &
- WisiToken.Parse.LR.Image (Table.States
(State_Index).Minimal_Complete_Actions, Strict => True) & ");");
+ ("Table.States (" & Trimmed_Image (State_Index) &
").Minimal_Complete_Action := " &
+ WisiToken.Parse.LR.Strict_Image (Table.States
(State_Index).Minimal_Complete_Action) & ";");
end if;
if Line_Count > Lines_Per_Subr then
@@ -834,7 +837,7 @@ package body WisiToken.BNF.Output_Ada_Common is
case Common_Data.Interface_Kind is
when Process =>
Indent_Line (" Trace,");
- Indent_Line (" Lexer.New_Lexer (Trace),");
+ Indent_Line (" Lexer.New_Lexer (Trace.Descriptor),");
Indent_Line (" Table,");
if Input_Data.Language_Params.Error_Recover then
Indent_Line (" Language_Fixes,");
@@ -876,7 +879,7 @@ package body WisiToken.BNF.Output_Ada_Common is
Indent_Line ("return Parser :
WisiToken.Parse.Packrat.Generated.Parser do");
Indent := Indent + 3;
Indent_Line ("Parser.Trace := Trace;");
- Indent_Line ("Parser.Lexer := Lexer.New_Lexer (Trace);");
+ Indent_Line ("Parser.Lexer := Lexer.New_Lexer (Trace.Descriptor);");
Indent_Line ("Parser.User_Data := User_Data;");
Indent_Line ("Parser.Parse_WisiToken_Accept :=
Parse_wisitoken_accept_1'Access;");
Indent := Indent - 3;
@@ -921,7 +924,7 @@ package body WisiToken.BNF.Output_Ada_Common is
Indent_Line ("return WisiToken.Parse.Packrat.Procedural.Create");
Indent_Line
(" (Grammar, Direct_Left_Recursive, " & Trimmed_Image
(Generate_Data.Descriptor.Accept_ID) &
- ", Trace, Lexer.New_Lexer (Trace), User_Data);");
+ ", Trace, Lexer.New_Lexer (Trace.Descriptor), User_Data);");
end case;
Indent := Indent - 3;
Indent_Line ("end Create_Parser;");
@@ -983,7 +986,7 @@ package body WisiToken.BNF.Output_Ada_Common is
Indent_Line ("int line_token_start; // line at start of
current token");
Indent_Line ("unsigned char* marker; // saved cursor");
Indent_Line ("size_t marker_pos; // saved character
position");
- Indent_Line ("size_t marker_line; // saved line ");
+ Indent_Line ("size_t marker_line; // saved line");
Indent_Line ("unsigned char* context; // saved cursor");
Indent_Line ("size_t context_pos; // saved character
position");
Indent_Line ("int context_line; // saved line");
@@ -1012,13 +1015,16 @@ package body WisiToken.BNF.Output_Ada_Common is
Indent_Line (" (unsigned char* input, size_t length, int verbosity)");
Indent_Line ("{");
Indent := Indent + 3;
- Indent_Line ("wisi_lexer* result = malloc (sizeof (wisi_lexer));");
- Indent_Line ("result->buffer = input;");
- Indent_Line ("result->buffer_last = input + length - 1;");
- Indent_Line ("result->cursor = input;");
- Indent_Line ("result->char_pos = 1;");
- Indent_Line ("result->line = (*result->cursor == 0x0A) ? 2 : 1;");
- Indent_Line ("result->verbosity = verbosity;");
+ Indent_Line ("wisi_lexer* result = malloc (sizeof
(wisi_lexer));");
+ Indent_Line ("result->buffer = input;");
+ Indent_Line ("result->buffer_last = input + length - 1;");
+ Indent_Line ("result->cursor = input;");
+ Indent_Line ("result->byte_token_start = input;");
+ Indent_Line ("result->char_pos = 1;");
+ Indent_Line ("result->char_token_start = 1;");
+ Indent_Line ("result->line = (*result->cursor == 0x0A) ? 2
: 1;");
+ Indent_Line ("result->line_token_start = result->line;");
+ Indent_Line ("result->verbosity = verbosity;");
Indent_Line ("return result;");
Indent := Indent - 3;
Indent_Line ("}");
@@ -1077,10 +1083,13 @@ package body WisiToken.BNF.Output_Ada_Common is
Indent_Line ("static void skip(wisi_lexer* lexer)");
Indent_Line ("{");
Indent := Indent + 3;
- Indent_Line ("if (lexer->cursor <= lexer->buffer_last)
++lexer->cursor;");
Indent_Line ("if (lexer->cursor <= lexer->buffer_last)");
+ Indent_Line ("{");
+ Indent_Line (" ++lexer->cursor;");
Indent_Line (" if (DO_COUNT) ++lexer->char_pos;");
- Indent_Line ("if (*lexer->cursor == 0x0A) ++lexer->line;");
+ Indent_Line (" if (lexer->cursor <= lexer->buffer_last)");
+ Indent_Line (" if (*lexer->cursor == 0x0A) ++lexer->line;");
+ Indent_Line ("}");
Indent := Indent - 3;
Indent_Line ("}");
Indent_Start ("#define YYSKIP() skip(lexer)");
@@ -1144,7 +1153,7 @@ package body WisiToken.BNF.Output_Ada_Common is
Indent_Line ("if (lexer->cursor > lexer->buffer_last)");
Indent_Line ("{");
Indent := Indent + 3;
- Indent_Line ("*id =" & WisiToken.Token_ID'Image
(Generate_Data.Descriptor.EOF_ID) & ";");
+ Indent_Line ("*id =" & WisiToken.Token_ID'Image
(Generate_Data.Descriptor.EOI_ID) & ";");
Indent_Line ("*byte_position = lexer->buffer_last - lexer->buffer + 1;");
Indent_Line ("*byte_length = 0;");
Indent_Line ("*char_position = lexer->char_token_start;");
@@ -1156,10 +1165,7 @@ package body WisiToken.BNF.Output_Ada_Common is
New_Line;
Indent_Line ("lexer->byte_token_start = lexer->cursor;");
- Indent_Line ("if (DO_COUNT)");
- Indent_Line (" lexer->char_token_start = lexer->char_pos;");
- Indent_Line ("else");
- Indent_Line (" lexer->char_token_start = lexer->char_pos + 1;");
+ Indent_Line ("lexer->char_token_start = lexer->char_pos;");
Indent_Line ("if (*lexer->cursor == 0x0A)");
Indent_Line (" lexer->line_token_start = lexer->line-1;");
Indent_Line ("else");
@@ -1239,7 +1245,7 @@ package body WisiToken.BNF.Output_Ada_Common is
end loop;
New_Line;
- -- Default action
+ -- Default action.
Indent_Line ("* {status = ERROR_unrecognized_character; continue;}");
Put_Line ("*/");
diff --git a/wisitoken-bnf-output_ada_emacs.adb
b/wisitoken-bnf-output_ada_emacs.adb
index 30da8c4..a16d289 100644
--- a/wisitoken-bnf-output_ada_emacs.adb
+++ b/wisitoken-bnf-output_ada_emacs.adb
@@ -12,7 +12,7 @@
-- If run in an Emacs dynamically loaded module, the parser actions
-- call the elisp actions directly.
--
--- 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
@@ -178,7 +178,7 @@ is
Navigate_Lines : String_Lists.List;
Face_Line : Unbounded_String;
Indent_Action_Line : Unbounded_String;
- Check_Lines : String_Lists.List;
+ Check_Line : Unbounded_String;
function Statement_Params (Params : in String) return String
is
@@ -320,7 +320,7 @@ is
First := Index_Non_Blank (Params, Last + 1);
Last := Index (Params, Delim, First);
Result := Result & ',' & Integer'Image
- (Find_Elisp_ID (Input_Data.User_Names.Faces, Params (First ..
Last - 1)));
+ (Find_Elisp_ID (Input_Data.Tokens.Faces, Params (First .. Last -
1)));
if Params (Last) = ']' then
Put_Error
@@ -332,7 +332,7 @@ is
First := Index_Non_Blank (Params, Last + 1);
Last := Index (Params, Delim, First);
Result := Result & ',' &
- Integer'Image (Find_Elisp_ID (Input_Data.User_Names.Faces,
Params (First .. Last - 1))) & ")";
+ Integer'Image (Find_Elisp_ID (Input_Data.Tokens.Faces, Params
(First .. Last - 1))) & ")";
Need_Comma := True;
end loop;
@@ -573,9 +573,9 @@ is
Last := Last + 1; -- get past ')'
return -Args;
- elsif Is_Present (Input_Data.User_Names.Indents,
-Function_Name) then
+ elsif Is_Present (Input_Data.Tokens.Indents, -Function_Name)
then
-- Language-specific function call
- Function_Name := +Value (Input_Data.User_Names.Indents,
-Function_Name);
+ Function_Name := +Value (Input_Data.Tokens.Indents,
-Function_Name);
Arg_Count := 0;
loop
exit when Params (Last) = ')';
@@ -735,7 +735,35 @@ is
procedure Translate_Line (Line : in String)
is
Last : constant Integer := Index (Line, Blank_Set);
- Elisp_Name : constant String := Line (Line'First + 1 .. Last - 1);
+ Elisp_Name : constant String := Line (Line'First + 1 .. (if Last = 0
then Line'Last else Last) - 1);
+
+ procedure Assert_Face_Empty
+ is begin
+ if Length (Face_Line) > 0 then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple face actions"));
+ end if;
+ end Assert_Face_Empty;
+
+ procedure Assert_Indent_Empty
+ is begin
+ if Length (Indent_Action_Line) > 0 then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple indent actions"));
+ end if;
+ end Assert_Indent_Empty;
+
+ procedure Assert_Check_Empty
+ is begin
+ if Length (Check_Line) > 0 then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple check actions"));
+ end if;
+ end Assert_Check_Empty;
+
begin
-- wisi action/check functions, in same order as typically used in
-- .wy files; Navigate, Face, Indent, Check.
@@ -755,101 +783,58 @@ is
Motion_Params (Line (Last + 1 .. Line'Last)) & ";");
elsif Elisp_Name = "wisi-face-apply-action" then
- if Length (Face_Line) = 0 then
+ Assert_Face_Empty;
Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
Face_Apply_Params (Line (Last + 1 .. Line'Last)) & ";";
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple face actions"));
- end if;
elsif Elisp_Name = "wisi-face-apply-list-action" then
- if Length (Face_Line) = 0 then
+ Assert_Face_Empty;
Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
Face_Apply_Params (Line (Last + 1 .. Line'Last)) & ";";
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple face actions"));
- end if;
elsif Elisp_Name = "wisi-face-mark-action" then
- if Length (Face_Line) = 0 then
+ Assert_Face_Empty;
Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
Face_Mark_Params (Line (Last + 1 .. Line'Last)) & ";";
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple face actions"));
- end if;
elsif Elisp_Name = "wisi-face-remove-action" then
- if Length (Face_Line) = 0 then
+ Assert_Face_Empty;
Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
Face_Remove_Params (Line (Last + 1 .. Line'Last)) & ";";
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple face actions"));
- end if;
elsif Elisp_Name = "wisi-indent-action" then
- if Length (Indent_Action_Line) = 0 then
+ Assert_Indent_Empty;
Indent_Action_Line := +"Indent_Action_0" &
Indent_Params (Line (Last + 1 .. Line'Last)) & ";";
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple indent actions"));
- end if;
elsif Elisp_Name = "wisi-indent-action*" then
- if Length (Indent_Action_Line) = 0 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;
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple indent actions"));
- end if;
elsif Elisp_Name = "wisi-propagate-name" then
- if not Check then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Elisp_Name & " used in action"));
- return;
- end if;
- Check_Lines.Append
- ("return " & Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
- " (Nonterm, Tokens, " & Line (Last + 1 .. Line'Last) & ";");
+ Assert_Check_Empty;
+ Check_Line := +"return " & Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) &
+ " (Nonterm, Tokens, " & Line (Last + 1 .. Line'Last) & ";";
elsif Elisp_Name = "wisi-merge-names" then
- if not Check then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Elisp_Name & " used in action"));
- return;
- end if;
- Check_Lines.Append
- ("return " & Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
- Merge_Names_Params (Line (Last + 1 .. Line'Last)) & ";");
+ Assert_Check_Empty;
+ Check_Line := +"return " & Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) &
+ Merge_Names_Params (Line (Last + 1 .. Line'Last)) & ";";
elsif Elisp_Name = "wisi-match-names" then
- if not Check then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Elisp_Name & " used in action"));
- return;
- end if;
- Check_Lines.Append
- ("return " & Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
- Match_Names_Params (Line (Last + 1 .. Line'Last)) & ";");
+ Assert_Check_Empty;
+ Check_Line := +"return " & Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) &
+ Match_Names_Params (Line (Last + 1 .. Line'Last)) & ";";
+
+ elsif Elisp_Name = "wisi-terminate-partial-parse" then
+ Assert_Check_Empty;
+ Check_Line := +"return Terminate_Partial_Parse
(Partial_Parse_Active, Partial_Parse_Byte_Goal, " &
+ "Recover_Active, Nonterm);";
else
Put_Error
@@ -874,16 +859,18 @@ is
if Check then
-- in a check
Indent_Line ("function " & Name);
- Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
- Indent_Line (" Nonterm : in out WisiToken.Recover_Token;");
- Indent_Line (" Tokens : in WisiToken.Recover_Token_Array)");
+ Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
+ Indent_Line (" Nonterm : in out WisiToken.Recover_Token;");
+ Indent_Line (" Tokens : in
WisiToken.Recover_Token_Array;");
+ Indent_Line (" Recover_Active : in Boolean)");
Indent_Line (" return WisiToken.Semantic_Checks.Check_Status");
declare
- -- Tokens is always referenced.
- Unref_Lexer : constant Boolean := (for all Line of Check_Lines
=> 0 = Index (Line, "Lexer"));
- Unref_Nonterm : constant Boolean := (for all Line of Check_Lines
=> 0 = Index (Line, "Nonterm"));
+ Unref_Lexer : constant Boolean := 0 = Index (Check_Line,
"Lexer");
+ 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");
begin
- if Unref_Lexer or Unref_Nonterm then
+ if Unref_Lexer or Unref_Nonterm or Unref_Tokens or Unref_Recover
then
Indent_Line ("is");
if Unref_Lexer then
Indent_Line (" pragma Unreferenced (Lexer);");
@@ -891,15 +878,20 @@ is
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);");
+ end if;
+
Indent_Line ("begin");
else
Indent_Line ("is begin");
end if;
end;
Indent := Indent + 3;
- for Line of Check_Lines loop
- Indent_Line (Line);
- end loop;
+ Indent_Line (-Check_Line);
else
-- In an action
Indent_Line ("procedure " & Name);
@@ -1179,7 +1171,7 @@ is
Indent_Line (" Elisp_Numbers (I) := Env.make_fixnum (Env,
emacs_module_h.int64_t (I));");
Indent_Line (" end loop;");
Indent_Line (" for I in Lexer_Elisp_Symbols'Range loop");
- Indent_Line (" Lexer_Elisp_Symbols (I) := Intern_Soft (Env,
Lexers.User_Names (I).all);");
+ Indent_Line (" Lexer_Elisp_Symbols (I) := Intern_Soft (Env,
Lexers.Tokens (I).all);");
Indent_Line (" end loop;");
Indent_Line (" Parser := Create_Parser (Env,
Lexer_Elisp_Symbols);");
Indent_Line (" return 0;");
@@ -1238,7 +1230,7 @@ is
New_Line;
Output_Elisp_Common.Indent_Name_Table
- (Output_File_Name_Root, "process-face-table",
Input_Data.User_Names.Faces);
+ (Output_File_Name_Root, "process-face-table", Input_Data.Tokens.Faces);
Put_Line ("(provide '" & Output_File_Name_Root & "-process)");
Set_Output (Standard_Output);
diff --git a/wisitoken-bnf.ads b/wisitoken-bnf.ads
index cd40975..3d46c45 100644
--- a/wisitoken-bnf.ads
+++ b/wisitoken-bnf.ads
@@ -13,7 +13,7 @@
-- [1] https://en.wikipedia.org/wiki/Backus%E2%80%93Naur_form
-- [2] http://www.nongnu.org/ada-mode/wisi/wisi-user_guide.html, (info
"(wisi-user_guide)Top")
--
--- 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
@@ -257,18 +257,13 @@ package WisiToken.BNF is
-- Rules included here because they define the nonterminal tokens, as
-- well as the productions.
- re2c_Regexps : String_Pair_Lists.List;
- -- From %re2c_regexp; included here because they are used in defining
- -- the Tokens.
- end record;
-
- type User_Names is record
- -- Specified in grammar file declarations, used in other declarations
+ -- 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.
- Faces : String_Lists.List; -- %elisp_face
- Indents : String_Pair_Lists.List; -- %elisp_indent
+ re2c_Regexps : String_Pair_Lists.List; -- %re2c_regexp
+ Faces : String_Lists.List; -- %elisp_face
+ Indents : String_Pair_Lists.List; -- %elisp_indent
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 cfd508b..36fca14 100644
--- a/wisitoken-gen_token_enum.ads
+++ b/wisitoken-gen_token_enum.ads
@@ -2,7 +2,7 @@
--
-- Support for an enumerated token type
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -47,7 +47,7 @@ package WisiToken.Gen_Token_Enum is
Last_Terminal => +Last_Terminal,
First_Nonterminal => +First_Nonterminal,
Last_Nonterminal => +Last_Nonterminal,
- EOF_ID => +EOF_ID,
+ EOI_ID => +EOF_ID,
Accept_ID => +Accept_ID,
Case_Insensitive => Case_Insensitive,
New_Line_ID => Invalid_Token_ID,
@@ -67,7 +67,7 @@ package WisiToken.Gen_Token_Enum is
Last_Terminal => +Last_Terminal,
First_Nonterminal => +First_Nonterminal,
Last_Nonterminal => +Last_Nonterminal,
- EOF_ID => +EOF_ID,
+ EOI_ID => +EOF_ID,
Accept_ID => +Accept_ID,
Case_Insensitive => Case_Insensitive,
New_Line_ID => Invalid_Token_ID,
diff --git a/wisitoken-generate-lr-lalr_generate.adb
b/wisitoken-generate-lr-lalr_generate.adb
index 0558f74..2a1f403 100644
--- a/wisitoken-generate-lr-lalr_generate.adb
+++ b/wisitoken-generate-lr-lalr_generate.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2002 - 2005, 2008 - 2015, 2017, 2018 Free Software
Foundation, Inc.
+-- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -98,7 +98,7 @@ package body WisiToken.Generate.LR.LALR_Generate is
-- 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.EOF_ID) and then
+ 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
@@ -494,10 +494,11 @@ package body WisiToken.Generate.LR.LALR_Generate is
Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Grammar);
- Minimal_Terminal_First : constant Token_Array_Token_ID :=
- WisiToken.Generate.LR.Minimal_Terminal_First (Grammar, Descriptor);
+ Minimal_Terminal_Sequences : constant Minimal_Sequence_Array :=
+ Compute_Minimal_Terminal_Sequences (Descriptor, Grammar);
- Ancestors : constant Token_Array_Token_Set :=
WisiToken.Generate.Ancestors (Grammar, Descriptor);
+ 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);
@@ -558,16 +559,20 @@ package body WisiToken.Generate.LR.LALR_Generate is
(Kernels, Grammar, Has_Empty_Production, First_Nonterm_Set,
First_Terminal_Sequence, Unknown_Conflicts,
Table.all, Descriptor);
- -- Set Table.States.Productions, Minimal_Terminal_First for
McKenzie_Recover
+ -- 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), Minimal_Terminal_First,
Ancestors, Descriptor, Grammar);
+ (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, Ancestors, Unknown_Conflicts,
Descriptor);
+ (Table, "LALR", Grammar, Kernels, Unknown_Conflicts, Descriptor);
end if;
Delete_Known (Unknown_Conflicts, Known_Conflicts_Edit);
diff --git a/wisitoken-generate-lr-lalr_generate.ads
b/wisitoken-generate-lr-lalr_generate.ads
index 80cc165..b4a109f 100644
--- a/wisitoken-generate-lr-lalr_generate.ads
+++ b/wisitoken-generate-lr-lalr_generate.ads
@@ -2,7 +2,7 @@
--
-- Generalized LALR parse table generator.
--
--- Copyright (C) 2002 - 2003, 2009 - 2010, 2013 - 2015, 2017, 2018 Free
Software Foundation, Inc.
+-- Copyright (C) 2002 - 2003, 2009 - 2010, 2013 - 2015, 2017 - 2019 Free
Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -63,4 +63,21 @@ package WisiToken.Generate.LR.LALR_Generate is
Descriptor : in WisiToken.Descriptor)
return LR1_Items.Item_Set_List;
+ 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);
+
+ 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);
+
end WisiToken.Generate.LR.LALR_Generate;
diff --git a/wisitoken-generate-lr-lr1_generate.adb
b/wisitoken-generate-lr-lr1_generate.adb
index 53507ba..62c20c1 100644
--- a/wisitoken-generate-lr-lr1_generate.adb
+++ b/wisitoken-generate-lr-lr1_generate.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -43,10 +43,10 @@ package body WisiToken.Generate.LR.LR1_Generate is
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 EOF in the
- -- accept production. EOF should only appear in the
+ -- We don't need a state with dot after EOI in the
+ -- accept production. EOI should only appear in the
-- accept production.
- Symbol /= Descriptor.EOF_ID
+ Symbol /= Descriptor.EOI_ID
then
Goto_Set.Set.Insert ((Item.Prod, Next (Item.Dot), new
Token_ID_Set'(Item.Lookaheads.all)));
end if;
@@ -91,7 +91,7 @@ package body WisiToken.Generate.LR.LR1_Generate is
((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.EOF_ID,
Descriptor)))),
+ Lookaheads => new Token_ID_Set'(To_Lookahead (Descriptor.EOI_ID,
Descriptor)))),
Goto_List => <>,
Dot_IDs => <>,
State => First_State_Index),
@@ -207,10 +207,11 @@ package body WisiToken.Generate.LR.LR1_Generate is
Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Grammar);
- Minimal_Terminal_First : constant Token_Array_Token_ID :=
- WisiToken.Generate.LR.Minimal_Terminal_First (Grammar, Descriptor);
+ Minimal_Terminal_Sequences : constant Minimal_Sequence_Array :=
+ Compute_Minimal_Terminal_Sequences (Descriptor, Grammar);
- Ancestors : constant Token_Array_Token_Set :=
WisiToken.Generate.Ancestors (Grammar, Descriptor);
+ 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);
@@ -261,19 +262,24 @@ package body WisiToken.Generate.LR.LR1_Generate is
Add_Actions
(Item_Sets, Grammar, Has_Empty_Production, First_Nonterm_Set,
Unknown_Conflicts, Table.all, Descriptor);
- -- Set Table.States.Productions, Minimal_Terminal_First for
McKenzie_Recover
+ -- 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),
- Minimal_Terminal_First, Ancestors, Descriptor, Grammar);
+ 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, Ancestors, Unknown_Conflicts,
Descriptor);
+ (Table, "LR1", Grammar, Item_Sets, Unknown_Conflicts, Descriptor);
end if;
if Trace_Generate > Outline then
diff --git a/wisitoken-generate-lr-lr1_generate.ads
b/wisitoken-generate-lr-lr1_generate.ads
index 7a3c6f6..92992cb 100644
--- a/wisitoken-generate-lr-lr1_generate.ads
+++ b/wisitoken-generate-lr-lr1_generate.ads
@@ -7,7 +7,7 @@
-- [dragon] "Compilers Principles, Techniques, and Tools" by Aho,
-- Sethi, and Ullman (aka: "The [Red] Dragon Book").
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -73,4 +73,13 @@ package WisiToken.Generate.LR.LR1_Generate is
return LR1_Items.Item_Set_List;
-- [dragon] algorithm 4.9 pg 231; figure 4.38 pg 232; procedure "items"
+ 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);
+
end WisiToken.Generate.LR.LR1_Generate;
diff --git a/wisitoken-generate-lr.adb b/wisitoken-generate-lr.adb
index c124327..f909fde 100644
--- a/wisitoken-generate-lr.adb
+++ b/wisitoken-generate-lr.adb
@@ -1,1141 +1,1256 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017, 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 (GPL);
-
-with Ada.Strings.Fixed;
-with Ada.Text_IO;
-with System.Multiprocessors;
-with WisiToken.Generate;
-package body WisiToken.Generate.LR is
-
- ----------
- -- Body subprograms, alphabetical
-
- function Count_Reduce (List : in Parse.LR.Minimal_Action_Lists.List) return
Integer
- is
- Count : Integer := 0;
- begin
- for Item of List loop
- if Item.Verb = Reduce then
- Count := Count + 1;
- end if;
- end loop;
- return Count;
- end Count_Reduce;
-
- 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 Terminal_Sequence
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- All_Sequences : in out Token_Sequence_Arrays.Vector;
- All_Set : in out Token_ID_Set;
- Recursing : in out Token_ID_Set;
- Nonterm : in Token_ID)
- is
- use Ada.Containers;
- Prod : Productions.Instance renames Grammar (Nonterm);
-
- Temp : Token_Sequence_Arrays.Vector;
- Min_Length : Count_Type := Count_Type'Last;
- Skipped_Recursive : Boolean := False;
- begin
- -- We get here because All_Sequences (Nonterm) has not been comptued
- -- yet. Attempt to compute All_Sequences (Nonterm); if successful, set
- -- All_Set (Nonterm) True.
-
- -- First fill Temp with terminals from each production for Nonterm.
- for L in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
-
- if Prod.RHSs (L).Tokens.Length = 0 then
- All_Set (Nonterm) := True;
-
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line (Image (Nonterm, Descriptor) & " => ()");
- end if;
-
- return;
- end if;
-
- if Prod.RHSs (L).Tokens (1) = Nonterm then
- -- The first RHS token = LHS; a recursive list. This will never be
- -- the shortest production, so just skip it.
- null;
-
- else
- declare
- Sequence : Token_ID_Arrays.Vector;
- begin
- for ID of Prod.RHSs (L).Tokens loop
- if ID in Descriptor.First_Terminal ..
Descriptor.Last_Terminal then
- Sequence.Append (ID);
-
- else
- if not All_Set (ID) then
- if Recursing (ID) then
- -- This nonterm is mutually recursive with some
other. This
- -- production will never be the shortest unless
it's the only one,
- -- so skip it.
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line (Image (ID, Descriptor) & "
mutual recurse skipped");
- end if;
- Skipped_Recursive := True;
- goto Skip;
- else
- Recursing (ID) := True;
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line (Image (ID, Descriptor) & "
recurse");
- end if;
- Terminal_Sequence (Grammar, Descriptor,
All_Sequences, All_Set, Recursing, ID);
- Recursing (ID) := False;
-
- if not All_Set (ID) then
- -- abandoned because of recursion
- Skipped_Recursive := True;
- goto Skip;
- end if;
- end if;
- end if;
- Sequence.Append (All_Sequences (ID));
- end if;
- end loop;
-
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line (Image (Nonterm, Descriptor) & " -> " &
Image (Sequence, Descriptor));
- end if;
- Temp.Append (Sequence);
- end;
- end if;
-
- <<Skip>>
- null;
- end loop;
-
- -- Now find the minimum length.
- if Temp.Length = 0 and Skipped_Recursive then
- -- better luck next time.
- return;
- end if;
-
- for S of Temp loop
- if S.Length <= Min_Length then
- Min_Length := S.Length;
-
- All_Sequences (Nonterm) := S;
- end if;
- end loop;
-
- if Trace_Generate > Detail then
- Ada.Text_IO.Put_Line (Image (Nonterm, Descriptor) & " ==> " & Image
(All_Sequences (Nonterm), Descriptor));
- end if;
-
- All_Set (Nonterm) := True;
- end Terminal_Sequence;
-
- ----------
- -- Public subprograms, declaration order
-
- procedure Put
- (Item : in Conflict_Lists.List;
- File : in Ada.Text_IO.File_Type;
- Descriptor : in WisiToken.Descriptor)
- is begin
- for Conflict of Item loop
- Ada.Text_IO.Put_Line (File, Image (Conflict, Descriptor));
- end loop;
- end Put;
-
- procedure Add_Action
- (Symbol : in Token_ID;
- Action : in Parse_Action_Rec;
- Action_List : in out Action_Node_Ptr;
- Closure : in LR1_Items.Item_Set;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- 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
- 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
- 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
- declare
- -- Enforce canonical Shift/Reduce or Accept/Reduce
- -- order, to simplify searching and code generation.
- Action_A : constant Parse_Action_Rec :=
- (if Action.Verb in Shift | Accept_It then Action else
Matching_Action.Action.Item);
-
- Action_B : constant Parse_Action_Rec :=
- (if Action.Verb in Shift | Accept_It then
Matching_Action.Action.Item else Action);
-
- New_Conflict : constant Conflict :=
- (Action_A => Action_A.Verb,
- Action_B => Action_B.Verb,
- LHS_A => Find
- (Closure, Action_A, Symbol, Grammar, Has_Empty_Production,
First_Nonterm_Set, Descriptor),
- LHS_B => Find
- (Closure, Action_B, Symbol, Grammar, Has_Empty_Production,
First_Nonterm_Set, Descriptor),
- State_Index => Closure.State,
- On => Symbol);
- begin
- 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
- Ada.Text_IO.Put_Line (" - conflict added: " & Image
(New_Conflict, Descriptor));
- end if;
- else
- if Trace_Generate > Outline 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
- Matching_Action.Action.Next := new
Parse_Action_Node'(Action, Matching_Action.Action.Next);
- end if;
- end;
- end if;
- else
- WisiToken.Parse.LR.Add (Action_List, Symbol, Action);
- end if;
- end Add_Action;
-
- procedure Add_Actions
- (Closure : in LR1_Items.Item_Set;
- Table : in out Parse_Table;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflicts : in out Conflict_Lists.List;
- Descriptor : in WisiToken.Descriptor)
- is
- use WisiToken.Token_ID_Arrays;
-
- State : constant State_Index := Closure.State;
- begin
- if Trace_Generate > Outline then
- Ada.Text_IO.Put_Line ("adding actions for state" & State_Index'Image
(State));
- end if;
-
- for Item of Closure.Set loop
- if Item.Dot = No_Element then
- -- Pointer is at the end of the production; add a reduce action.
-
- Add_Lookahead_Actions
- (Item, Table.States (State).Action_List, Grammar,
Has_Empty_Production, First_Nonterm_Set,
- Conflicts, Closure, Descriptor);
-
- elsif Element (Item.Dot) in Descriptor.First_Terminal ..
Descriptor.Last_Terminal then
- -- Dot is before a terminal token.
- declare
- use all type Ada.Containers.Count_Type;
-
- Dot_ID : constant Token_ID := Element (Item.Dot);
- -- ID of token after Item.Dot
-
- Goto_State : constant Unknown_State_Index :=
LR1_Items.Goto_State (Closure, Dot_ID);
- begin
- if Dot_ID = Descriptor.EOF_ID then
- -- This is the start symbol production with dot before EOF.
- declare
- P_ID : constant Production_ID := Item.Prod;
- RHS : Productions.Right_Hand_Side renames Grammar
(P_ID.LHS).RHSs (P_ID.RHS);
- begin
- Add_Action
- (Dot_ID,
- (Accept_It, P_ID, RHS.Action, RHS.Check,
RHS.Tokens.Length - 1),
- -- 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);
- end;
- else
- if Goto_State /= Unknown_State then
- Add_Action
- (Dot_ID,
- (Shift, Goto_State),
- Table.States (State).Action_List,
- Closure, Grammar, Has_Empty_Production,
First_Nonterm_Set, Conflicts, Descriptor);
- end if;
- end if;
- end;
- else
- -- Dot is before a non-terminal token; no action.
- if Trace_Generate > Outline then
- Ada.Text_IO.Put_Line (Image (Element (Item.Dot), Descriptor) &
" => no action");
- end if;
- end if;
- end loop;
-
- -- Place a default error action at the end of every state.
- -- (it should always have at least one action already).
- declare
- -- The default action, when nothing else matches an input
- Default_Action : constant Action_Node :=
- -- The symbol here is actually irrelevant; it is the
- -- position as the last on a state's action list that makes
- -- it the default.
- (Symbol => Invalid_Token_ID,
- Action => new Parse_Action_Node'(Parse_Action_Rec'(Verb =>
WisiToken.Parse.LR.Error), null),
- Next => null);
-
- Last_Action : Action_Node_Ptr := Table.States (State).Action_List;
- begin
- if Last_Action = null then
- -- This happens if the first production in the grammar is
- -- not the start symbol production.
- --
- -- It also happens when the start symbol production does
- -- not have an explicit EOF, or when there is more than
- -- one production that has the start symbol on the left
- -- hand side.
- --
- -- It also happens when the grammar is bad, for example:
- --
- -- declarations <= declarations & declaration
- --
- -- without 'declarations <= declaration'.
- --
- -- We continue generating the grammar, in order to help the user
- -- debug this issue.
- WisiToken.Generate.Error := True;
-
- Ada.Text_IO.Put_Line
- (Ada.Text_IO.Current_Error, "Error: state" & State_Index'Image
(State) &
- " has no actions; bad grammar, or " &
- "first production in grammar must be the only start symbol
production, " &
- "and it must must have an explicit EOF.");
- else
- while Last_Action.Next /= null loop
- Last_Action := Last_Action.Next;
- end loop;
- Last_Action.Next := new Action_Node'(Default_Action);
- end if;
- end;
-
- for Item of Closure.Goto_List loop
- if Item.Symbol in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal then
- Add_Goto (Table.States (State), Item.Symbol, Item.State); -- note
list is already sorted.
- end if;
- end loop;
- end Add_Actions;
-
- procedure Add_Lookahead_Actions
- (Item : in LR1_Items.Item;
- Action_List : in out Action_Node_Ptr;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflicts : in out Conflict_Lists.List;
- Closure : in LR1_Items.Item_Set;
- Descriptor : in WisiToken.Descriptor)
- is
- Prod : Productions.Instance renames Grammar (Item.Prod.LHS);
- 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
- Ada.Text_IO.Put_Line ("processing lookaheads");
- end if;
-
- -- We ignore propagate lookaheads here.
- for Lookahead in Item.Lookaheads'Range loop
- if Item.Lookaheads (Lookahead) then
- if Lookahead = Descriptor.First_Nonterminal then
- null;
- else
- Add_Action
- (Lookahead, Action, Action_List, Closure, Grammar,
- Has_Empty_Production, First_Nonterm_Set, Conflicts,
Descriptor);
- end if;
- end if;
- end loop;
- end Add_Lookahead_Actions;
-
- procedure Delete_Known
- (Conflicts : in out Conflict_Lists.List;
- Known_Conflicts : in out Conflict_Lists.List)
- is
- -- Delete all elements in Conflicts that match an element in
- -- Known_Conflicts. There can be more than one Conflict that
- -- match one Known_Conflict.
- use Conflict_Lists;
- Known : Cursor := Known_Conflicts.First;
- Next_Known : Cursor;
- begin
- loop
- exit when Known = No_Element;
- Next_Known := Next (Known);
- declare
- I : Cursor := Conflicts.First;
- Next_I : Cursor;
- Used : Boolean := False;
- begin
- loop
- exit when I = No_Element;
- Next_I := Next (I);
- if Match (Element (Known), Conflicts.Constant_Reference (I))
then
- Delete (Conflicts, I);
- Used := True;
- end if;
- I := Next_I;
- end loop;
-
- if Used then
- Delete (Known_Conflicts, Known);
- end if;
- end;
- Known := Next_Known;
- end loop;
- end Delete_Known;
-
- function Find
- (Closure : in LR1_Items.Item_Set;
- Action : in Parse_Action_Rec;
- Lookahead : in Token_ID;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return Token_ID
- is
- use WisiToken.Token_ID_Arrays;
-
- ID_I : Cursor;
- begin
- case Action.Verb is
- when Reduce | Accept_It =>
- -- If the nonterm produced by the reduce is the LHS of the state
- -- production, use it.
- for Item of Closure.Set loop
- if LR1_Items.In_Kernel (Grammar, Descriptor, Item) and
- Action.Production.LHS = Item.Prod.LHS
- then
- return Item.Prod.LHS;
- end if;
- end loop;
-
- -- The reduce nonterm is after Dot in a state production; find which
- -- one, use that.
- for Item of Closure.Set loop
- if LR1_Items.In_Kernel (Grammar, Descriptor, Item) then
- ID_I := Item.Dot;
- loop
- if ID_I = No_Element then
- if Item.Lookaheads (Lookahead) then
- return Item.Prod.LHS;
- end if;
- else
- declare
- Dot_ID : Token_ID renames Element (ID_I);
- begin
- if Dot_ID = Lookahead or
- (Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- First (Dot_ID, Lookahead))
- then
- return Item.Prod.LHS;
- end if;
- exit when Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- not Has_Empty_Production (Dot_ID);
- end;
- end if;
-
- exit when ID_I = No_Element;
- Next (ID_I);
- end loop;
- end if;
- end loop;
-
- when Shift =>
-
- for Item of Closure.Set loop
- -- Lookahead (the token shifted) is starting a nonterm in a state
- -- production; it is in First of that nonterm.
- if LR1_Items.In_Kernel (Grammar, Descriptor, Item) then
- ID_I := Item.Dot;
- loop
- exit when ID_I = No_Element;
- declare
- Dot_ID : Token_ID renames Element (ID_I);
- begin
- if Dot_ID = Lookahead or
- (Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- First (Dot_ID, Lookahead))
- then
- return Item.Prod.LHS;
- end if;
-
- exit when Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- not Has_Empty_Production (Dot_ID);
- end;
-
- Next (ID_I);
- end loop;
- end if;
- end loop;
-
- when WisiToken.Parse.LR.Error =>
- raise SAL.Programmer_Error;
- end case;
-
- Ada.Text_IO.Put_Line
- ("item for " & Image (Action, Descriptor) & " on " & Image (Lookahead,
Descriptor) & " not found in");
- LR1_Items.Put (Grammar, Descriptor, Closure, Kernel_Only => True);
- raise SAL.Programmer_Error;
- end Find;
-
- function Image (Item : in Conflict; Descriptor : in WisiToken.Descriptor)
return String
- is begin
- return
- ("%conflict " &
- Conflict_Parse_Actions'Image (Item.Action_A) & "/" &
- Conflict_Parse_Actions'Image (Item.Action_B) & " in state " &
- Image (Item.LHS_A, Descriptor) & ", " &
- Image (Item.LHS_B, Descriptor) &
- " on token " & Image (Item.On, Descriptor) &
- " (" & State_Index'Image (Item.State_Index) & ")"); -- state number
last for easier delete
- end Image;
-
- function Is_Present (Item : in Conflict; Conflicts : in
Conflict_Lists.List) return Boolean
- is
- use Conflict_Lists;
- I : Cursor := Conflicts.First;
- begin
- loop
- exit when I = No_Element;
- if Match (Item, Conflicts.Constant_Reference (I)) then
- return True;
- end if;
- I := Next (I);
- end loop;
- return False;
- end Is_Present;
-
- function Match (Known : in Conflict; Item : in
Conflict_Lists.Constant_Reference_Type) return Boolean
- is begin
- -- Ignore State_Index. Actions are in canonical order; enforced
- -- in Add_Action above. For reduce/reduce, LHS_A, LHS_B are not
- -- in canonical order.
- return
- Known.Action_A = Item.Action_A and
- Known.Action_B = Item.Action_B and
- ((Known.LHS_A = Item.LHS_A and Known.LHS_B = Item.LHS_B) or
- (Known.LHS_B = Item.LHS_A and Known.LHS_A = Item.LHS_B)) and
- Known.On = Item.On;
- end Match;
-
- procedure Compute_Minimal_Terminal_Sequences
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Result : in out Token_Sequence_Arrays.Vector)
- 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);
-
- Last_Count : Integer := 0;
- This_Count : Integer;
- begin
- Result.Set_First (Descriptor.First_Nonterminal);
- Result.Set_Last (Descriptor.Last_Nonterminal);
-
- 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,
Recursing, P.LHS);
- end if;
- end loop;
- This_Count := Count (All_Set);
- if This_Count = Last_Count then
- raise Grammar_Error with "nonterminals have no minimum terminal
sequence: " &
- Image (All_Set, Descriptor, Inverted => True);
- end if;
- Last_Count := This_Count;
- end loop;
- end Compute_Minimal_Terminal_Sequences;
-
- function Minimal_Terminal_First
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return Token_Array_Token_ID
- is
- use all type Ada.Containers.Count_Type;
- Minimal_Terminal_Sequences : Token_Sequence_Arrays.Vector;
- begin
- Compute_Minimal_Terminal_Sequences (Grammar, Descriptor,
Minimal_Terminal_Sequences);
-
- return Result : Token_Array_Token_ID (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal) do
- for ID in Result'Range loop
- if Minimal_Terminal_Sequences (ID).Length = 0 then
- Result (ID) := Invalid_Token_ID;
- else
- Result (ID) := Minimal_Terminal_Sequences
(ID)(Minimal_Terminal_Sequences (ID).First);
- end if;
- end loop;
- end return;
- end Minimal_Terminal_First;
-
- procedure Set_Minimal_Complete_Actions
- (State : in out Parse_State;
- Kernel : in LR1_Items.Item_Set;
- Minimal_Terminal_First : in Token_Array_Token_ID;
- Ancestors : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
- is
- use all type Ada.Containers.Count_Type;
- use LR1_Items.Item_Lists;
- use Token_ID_Arrays;
-
- subtype Terminals is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
-
- Del : LR1_Items.Item_Lists.Cursor;
-
- procedure Delete_Same_Ancestor (List : in out LR1_Items.Item_Lists.List;
Cur : in LR1_Items.Item_Lists.Cursor)
- is
- Cur_LHS : constant Token_ID := Element (Cur).Prod.LHS;
-
- J : LR1_Items.Item_Lists.Cursor := List.First;
- begin
- loop
- exit when not Has_Element (J);
- if J = Cur then
- Next (J);
- else
- declare
- Item : LR1_Items.Item renames Constant_Ref (J);
- begin
- if Cur_LHS = Item.Prod.LHS or else Ancestors (Cur_LHS,
Item.Prod.LHS) then
- Del := J;
- Next (J);
- List.Delete (Del);
- else
- Next (J);
- end if;
- end;
- end if;
- end loop;
- end Delete_Same_Ancestor;
-
- procedure Append_No_Dup (Item : in Minimal_Action)
- is begin
- if not State.Minimal_Complete_Actions.Contains (Item) then
- State.Minimal_Complete_Actions.Insert (Item);
- end if;
- end Append_No_Dup;
-
- function Find_Action (List : in Action_Node_Ptr; ID : in Token_ID)
return Minimal_Action
- is
- Node : Action_Node_Ptr := List;
- begin
- loop
- if Node.Symbol = ID then
- case Node.Action.Item.Verb is
- when Shift =>
- return (Shift, ID, Node.Action.Item.State);
- when Reduce =>
- -- Item.Dot is a nonterm that starts with a nullable
nonterm; reduce
- -- to that first.
- return (Reduce, Node.Action.Item.Production.LHS, 0);
- when Accept_It | WisiToken.Parse.LR.Error =>
- raise SAL.Programmer_Error;
- end case;
- end if;
- Node := Node.Next;
- exit when Node = null;
- end loop;
- raise SAL.Programmer_Error;
- end Find_Action;
-
- Working_Set : LR1_Items.Item_Lists.List := Kernel.Set;
- I : LR1_Items.Item_Lists.Cursor;
-
- begin
- -- First find items to delete.
- --
- -- This algorithm will return an empty Minimal_Complete_Actions in
- -- the top level accept state.
-
- I := Working_Set.First;
- loop
- exit when not Has_Element (I);
- declare
- Item : LR1_Items.Item renames Constant_Ref (I);
- Prod : WisiToken.Productions.Instance renames Grammar
(Item.Prod.LHS);
- begin
- if not Has_Element (Item.Dot) then
- -- Completing this item also completes items that share an
ancestor.
- Delete_Same_Ancestor (Working_Set, I);
- Next (I);
-
- elsif To_Index (Item.Dot) = 2 and then
- Prod.RHSs (Item.Prod.RHS).Tokens (1) = Item.Prod.LHS
- then
- -- Item is left-recursive; it can't be minimal.
- Del := I;
- Next (I);
- Working_Set.Delete (Del);
- else
- Next (I);
- end if;
- end;
- end loop;
-
- 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.
- Append_No_Dup
- ((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.EOF_ID then
-
- if ID in Terminals then
- Append_No_Dup (Find_Action (State.Action_List, ID));
-
- 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.
- Append_No_Dup ((Reduce, ID, Token_Count => 0));
-
- else
- Append_No_Dup (Find_Action (State.Action_List,
Minimal_Terminal_First (ID)));
- end if;
- end if;
- end if;
- end;
- end if;
- end loop;
- end Set_Minimal_Complete_Actions;
-
- ----------
- -- Parse table output
-
- procedure Put_Text_Rep
- (Table : in Parse_Table;
- File_Name : in String;
- Action_Names : in Names_Array_Array;
- Check_Names : in Names_Array_Array)
- is
- 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.
-
- Create (File, Out_File, File_Name);
-
- -- First the discriminants
- Put (File,
- Trimmed_Image (Table.State_First) & State_Index'Image
(Table.State_Last) &
- Token_ID'Image (Table.First_Terminal) & Token_ID'Image
(Table.Last_Terminal) &
- Token_ID'Image (Table.First_Nonterminal) & Token_ID'Image
(Table.Last_Nonterminal));
- 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
- loop
- exit when Node_I = null;
- -- Action first, so we know if Symbol is present (not when
Error)
- declare
- Node_J : Parse_Action_Node_Ptr := Node_I.Action;
- Put_Symbol : Boolean := True;
- begin
- loop
- Put (File, Parse_Action_Verbs'Image (Node_J.Item.Verb));
-
- case Node_J.Item.Verb is
- when Shift =>
- Put (File, State_Index'Image (Node_J.Item.State));
-
- when Reduce | Accept_It =>
- Put (File, Token_ID'Image (Node_J.Item.Production.LHS)
&
- Integer'Image (Node_J.Item.Production.RHS));
-
- if Action_Names (Node_J.Item.Production.LHS) /= null
and then
- Action_Names
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS) /= null
- then
- Put (File, " true");
- else
- Put (File, " false");
- end if;
- if Check_Names (Node_J.Item.Production.LHS) /= null
and then
- Check_Names
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS) /= null
- then
- Put (File, " true");
- else
- Put (File, " false");
- end if;
-
- Put (File, Ada.Containers.Count_Type'Image
(Node_J.Item.Token_Count));
-
- when Parse.LR.Error =>
- -- Error action terminates the action list
- Put_Symbol := False;
- end case;
-
- Node_J := Node_J.Next;
- exit when Node_J = null;
- Put (File, ' ');
- end loop;
- Put (File, ';');
- if Put_Symbol then
- Put (File, Token_ID'Image (Node_I.Symbol));
- end if;
- end;
- New_Line (File);
-
- Node_I := Node_I.Next;
- end loop;
- end;
-
- declare
- Node_I : Goto_Node_Ptr := State.Goto_List;
- begin
- loop
- exit when Node_I = null;
- Put (File, Token_ID'Image (Symbol (Node_I)) & State_Index'Image
(Parse.LR.State (Node_I)));
- Node_I := Next (Node_I);
- end loop;
- Put (File, ';');
- New_Line (File);
- end;
-
- for Action of State.Minimal_Complete_Actions loop
- Put (File, ' ' & Minimal_Verbs'Image (Action.Verb));
- case Action.Verb is
- when Shift =>
- Put (File, Token_ID'Image (Action.ID) & State_Index'Image
(Action.State));
- when Reduce =>
- Put (File, Token_ID'Image (Action.Nonterm) &
Ada.Containers.Count_Type'Image (Action.Token_Count));
- end case;
- end loop;
- Put (File, ';');
- New_Line (File);
- end loop;
- Close (File);
- end Put_Text_Rep;
-
- procedure Put (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor)
- is
- use Ada.Containers;
- use Ada.Text_IO;
- begin
- case Item.Verb is
- when Shift =>
- Put ("shift and goto state" & State_Index'Image (Item.State));
-
- when Reduce =>
- Put
- ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
- Image (Item.Production.LHS, Descriptor));
- when Accept_It =>
- Put ("accept it");
- when Parse.LR.Error =>
- Put ("ERROR");
- end case;
- end Put;
-
- procedure Put (Item : in McKenzie_Param_Type; Descriptor : in
WisiToken.Descriptor)
- is
- use Ada.Text_IO;
- begin
- Put_Line ("(Insert =>");
- for I in Item.Insert'Range loop
- Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Insert (I)));
- if I = Item.Insert'Last then
- Put_Line (")");
- else
- Put_Line (",");
- end if;
- end loop;
- Put_Line ("(Delete =>");
- for I in Item.Delete'Range loop
- Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Delete (I)));
- if I = Item.Delete'Last then
- Put_Line (")");
- else
- Put_Line (",");
- 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
- Put_Line (")");
- else
- Put_Line (",");
- end if;
- end loop;
- 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));
- end Put;
-
- procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Parse_Action_Rec)
- is
- use Ada.Containers;
- use Ada.Text_IO;
- begin
- case Item.Verb is
- when Shift =>
- Put ("shift and goto state" & State_Index'Image (Item.State));
- when Reduce =>
- Put
- ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
- Image (Item.Production.LHS, Descriptor));
- Put (" " & Trimmed_Image (Item.Production));
- when Accept_It =>
- Put ("accept it");
- Put (" " & Trimmed_Image (Item.Production));
- when Parse.LR.Error =>
- Put ("ERROR");
- end case;
- end Put;
-
- procedure Put (Descriptor : in WisiToken.Descriptor; Action : in
Parse_Action_Node_Ptr)
- is
- use Ada.Text_IO;
- Ptr : Parse_Action_Node_Ptr := Action;
- Column : constant Positive_Count := Col;
- begin
- loop
- Put (Descriptor, Ptr.Item);
- Ptr := Ptr.Next;
- exit when Ptr = null;
- Put_Line (",");
- Set_Col (Column);
- end loop;
- end Put;
-
- 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;
- Goto_Ptr : Goto_Node_Ptr := State.Goto_List;
- Need_Comma : Boolean := False;
- begin
- while Action_Ptr /= null loop
- Put (" ");
- if Action_Ptr.Next = null then
- Put ("default" & (Descriptor.Image_Width - 7) * ' ' & " => ");
-
- elsif Action_Ptr.Action.Item.Verb /= Parse.LR.Error then
- Put (Image (Action_Ptr.Symbol, Descriptor) &
- (Descriptor.Image_Width - Image (Action_Ptr.Symbol,
Descriptor)'Length) * ' '
- & " => ");
- end if;
- Put (Descriptor, Action_Ptr.Action);
- New_Line;
- Action_Ptr := Action_Ptr.Next;
- end loop;
-
- if Goto_Ptr /= null then
- New_Line;
- end if;
-
- while Goto_Ptr /= null loop
- Put_Line
- (" " & Image (Symbol (Goto_Ptr), Descriptor) &
- (Descriptor.Image_Width - Image (Symbol (Goto_Ptr),
Descriptor)'Length) * ' ' &
- " goto state" & State_Index'Image (Parse.LR.State (Goto_Ptr)));
- Goto_Ptr := Next (Goto_Ptr);
- end loop;
-
- if State.Minimal_Complete_Actions.Length > 0 then
- New_Line;
- Put (" Minimal_Complete_Actions => (");
- for Action of State.Minimal_Complete_Actions loop
- if Need_Comma then
- Put (", ");
- else
- Need_Comma := True;
- end if;
- case Action.Verb is
- when Shift =>
- Put (Image (Action.ID, Descriptor));
- when Reduce =>
- Put (Image (Action.Nonterm, Descriptor));
- end case;
- end loop;
- Put_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;
- Ancestors : in Token_Array_Token_Set;
- Conflicts : in Conflict_Lists.List;
- Descriptor : in WisiToken.Descriptor)
- is
- use all type Ada.Containers.Count_Type;
- use Ada.Text_IO;
- Minimal_Complete_Multiple_Reduce : State_Index_Arrays.Vector;
- begin
- Put_Line ("Tokens:");
- WisiToken.Put_Tokens (Descriptor);
-
- New_Line;
- Put_Line ("Productions:");
- WisiToken.Productions.Put (Grammar, Descriptor);
-
- if 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
- then
- New_Line;
- Put_Line ("McKenzie:");
- Put (Table.McKenzie_Param, Descriptor);
- end if;
-
- New_Line;
- Put_Line ("Ancestors:");
- for ID in Ancestors'Range (1) loop
- if Any (Ancestors, ID) then
- Put_Line (Image (ID, Descriptor) & " => " & Image (Slice
(Ancestors, ID), Descriptor));
- end if;
- end loop;
-
- New_Line;
- 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);
- New_Line;
- Put (Descriptor, Table.States (State_Index));
-
- if Count_Reduce (Table.States (State_Index).Minimal_Complete_Actions)
> 1 then
- Minimal_Complete_Multiple_Reduce.Append (State_Index);
- end if;
-
- if State_Index /= Table.States'Last then
- New_Line;
- end if;
- end loop;
-
- if Minimal_Complete_Multiple_Reduce.Length + Conflicts.Length > 0 then
- New_Line;
- end if;
-
- if Minimal_Complete_Multiple_Reduce.Length > 0 then
- Indent_Wrap
- ("States with multiple reduce in Minimal_Complete_Action: " & Image
(Minimal_Complete_Multiple_Reduce));
- end if;
-
- if Conflicts.Length > 0 then
- declare
- use Ada.Strings.Unbounded;
- Last_State : Unknown_State_Index := Unknown_State;
- Line : Unbounded_String := +"States with conflicts:";
- 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;
- end loop;
- Indent_Wrap (-Line);
- end;
- end if;
- end Put_Parse_Table;
-
-end WisiToken.Generate.LR;
+-- 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 (GPL);
+
+with Ada.Strings.Fixed;
+with Ada.Text_IO;
+with System.Multiprocessors;
+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;
+
+ ----------
+ -- 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)
+ return Integer
+ is
+ use all type Ada.Containers.Count_Type;
+ Min_Length : Ada.Containers.Count_Type := Ada.Containers.Count_Type'Last;
+ Min_RHS : Natural := Natural'Last;
+ begin
+ for RHS in Item.First_Index .. Item.Last_Index loop
+ if RHS_Set (RHS) and then Min_Length > Item (RHS).Sequence.Length then
+ Min_Length := Item (RHS).Sequence.Length;
+ Min_RHS := RHS;
+ end if;
+ end loop;
+ if Min_RHS = Natural'Last then
+ raise SAL.Programmer_Error with "nonterm has no minimum terminal
sequence";
+ else
+ return Min_RHS;
+ end if;
+ end Min;
+
+ 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)
+ is
+ use Ada.Containers;
+ use Token_ID_Arrays;
+
+ subtype Terminals is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+
+ Prod : Productions.Instance renames Grammar (Nonterm);
+
+ Skipped_Recursive : Boolean := False;
+ 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.
+ --
+ -- 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;
+
+ for RHS in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
+ if not RHS_Set (Nonterm)(RHS) then
+ if Prod.RHSs (RHS).Tokens.Length = 0 then
+ RHS_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
+ if ID in Terminals then
+ All_Sequences (Nonterm) (RHS).Sequence.Append (ID);
+
+ else
+ if not All_Set (ID) then
+ -- Need to compute some RHSs of ID
+
+ 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);
+
+ 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);
+ Recursing (ID) := False;
+
+ if All_Set (ID) or else (for some RHS of RHS_Set
(ID) => RHS) then
+ -- Found a minimal sequence for ID; use it
+ null;
+ else
+ All_Sequences (Nonterm)(RHS).Sequence.Clear;
+ goto Skip;
+ end if;
+ end if;
+ end if;
+ declare
+ Min_RHS : constant Integer := Min (All_Sequences
(ID), RHS_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;
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line
+ (Trimmed_Image (Production_ID'(Nonterm, RHS)) & " => " &
+ Image (All_Sequences (Nonterm)(RHS), Descriptor));
+ end if;
+ end if;
+ end if;
+ <<Skip>>
+ Skipped_Recursive := True;
+ end loop;
+
+ if Skipped_Recursive then
+ if (for some RHS of RHS_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
+ Ada.Text_IO.Put_Line
+ (Trimmed_Image (Nonterm) & " " & Image (Nonterm, Descriptor)
& " skipped some recursive");
+ end if;
+ return;
+ end if;
+ end if;
+
+ All_Set (Nonterm) := True;
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line
+ (Trimmed_Image (Nonterm) & " " & Image (Nonterm, Descriptor) & "
==> " &
+ Image (All_Sequences (Nonterm), Descriptor));
+ end if;
+ end Terminal_Sequence;
+
+ ----------
+ -- Public subprograms, declaration order
+
+ procedure Put
+ (Item : in Conflict_Lists.List;
+ File : in Ada.Text_IO.File_Type;
+ Descriptor : in WisiToken.Descriptor)
+ is begin
+ for Conflict of Item loop
+ Ada.Text_IO.Put_Line (File, Image (Conflict, Descriptor));
+ end loop;
+ end Put;
+
+ procedure Add_Action
+ (Symbol : in Token_ID;
+ Action : in Parse_Action_Rec;
+ Action_List : in out Action_Node_Ptr;
+ Closure : in LR1_Items.Item_Set;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ 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
+ 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
+ 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
+ declare
+ -- Enforce canonical Shift/Reduce or Accept/Reduce
+ -- order, to simplify searching and code generation.
+ Action_A : constant Parse_Action_Rec :=
+ (if Action.Verb in Shift | Accept_It then Action else
Matching_Action.Action.Item);
+
+ Action_B : constant Parse_Action_Rec :=
+ (if Action.Verb in Shift | Accept_It then
Matching_Action.Action.Item else Action);
+
+ New_Conflict : constant Conflict :=
+ (Action_A => Action_A.Verb,
+ Action_B => Action_B.Verb,
+ LHS_A => Find
+ (Closure, Action_A, Symbol, Grammar, Has_Empty_Production,
First_Nonterm_Set, Descriptor),
+ LHS_B => Find
+ (Closure, Action_B, Symbol, Grammar, Has_Empty_Production,
First_Nonterm_Set, Descriptor),
+ State_Index => Closure.State,
+ On => Symbol);
+ begin
+ 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
+ Ada.Text_IO.Put_Line (" - conflict added: " & Image
(New_Conflict, Descriptor));
+ end if;
+ else
+ if Trace_Generate > Outline 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
+ Matching_Action.Action.Next := new
Parse_Action_Node'(Action, Matching_Action.Action.Next);
+ end if;
+ end;
+ end if;
+ else
+ WisiToken.Parse.LR.Add (Action_List, Symbol, Action);
+ end if;
+ end Add_Action;
+
+ procedure Add_Actions
+ (Closure : in LR1_Items.Item_Set;
+ Table : in out Parse_Table;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflicts : in out Conflict_Lists.List;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ use WisiToken.Token_ID_Arrays;
+
+ State : constant State_Index := Closure.State;
+ begin
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line ("adding actions for state" & State_Index'Image
(State));
+ end if;
+
+ for Item of Closure.Set loop
+ if Item.Dot = No_Element then
+ -- Pointer is at the end of the production; add a reduce action.
+
+ Add_Lookahead_Actions
+ (Item, Table.States (State).Action_List, Grammar,
Has_Empty_Production, First_Nonterm_Set,
+ Conflicts, Closure, Descriptor);
+
+ elsif Element (Item.Dot) in Descriptor.First_Terminal ..
Descriptor.Last_Terminal then
+ -- Dot is before a terminal token.
+ declare
+ use all type Ada.Containers.Count_Type;
+
+ Dot_ID : constant Token_ID := Element (Item.Dot);
+ -- ID of token after Item.Dot
+
+ Goto_State : constant Unknown_State_Index :=
LR1_Items.Goto_State (Closure, Dot_ID);
+ begin
+ if Dot_ID = Descriptor.EOI_ID then
+ -- This is the start symbol production with dot before EOF.
+ declare
+ P_ID : constant Production_ID := Item.Prod;
+ RHS : Productions.Right_Hand_Side renames Grammar
(P_ID.LHS).RHSs (P_ID.RHS);
+ begin
+ Add_Action
+ (Dot_ID,
+ (Accept_It, P_ID, RHS.Action, RHS.Check,
RHS.Tokens.Length - 1),
+ -- 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);
+ end;
+ else
+ if Goto_State /= Unknown_State then
+ Add_Action
+ (Dot_ID,
+ (Shift, Goto_State),
+ Table.States (State).Action_List,
+ Closure, Grammar, Has_Empty_Production,
First_Nonterm_Set, Conflicts, Descriptor);
+ end if;
+ end if;
+ end;
+ else
+ -- Dot is before a non-terminal token; no action.
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line (Image (Element (Item.Dot), Descriptor) &
" => no action");
+ end if;
+ end if;
+ end loop;
+
+ -- Place a default error action at the end of every state.
+ -- (it should always have at least one action already).
+ declare
+ -- The default action, when nothing else matches an input
+ Default_Action : constant Action_Node :=
+ -- The symbol here is actually irrelevant; it is the
+ -- position as the last on a state's action list that makes
+ -- it the default.
+ (Symbol => Invalid_Token_ID,
+ Action => new Parse_Action_Node'(Parse_Action_Rec'(Verb =>
WisiToken.Parse.LR.Error), null),
+ Next => null);
+
+ Last_Action : Action_Node_Ptr := Table.States (State).Action_List;
+ begin
+ if Last_Action = null then
+ -- This happens if the first production in the grammar is
+ -- not the start symbol production.
+ --
+ -- It also happens when the start symbol production does
+ -- not have an explicit EOF, or when there is more than
+ -- one production that has the start symbol on the left
+ -- hand side.
+ --
+ -- It also happens when the grammar is bad, for example:
+ --
+ -- declarations <= declarations & declaration
+ --
+ -- without 'declarations <= declaration'.
+ --
+ -- We continue generating the grammar, in order to help the user
+ -- debug this issue.
+ WisiToken.Generate.Error := True;
+
+ Ada.Text_IO.Put_Line
+ (Ada.Text_IO.Current_Error, "Error: state" & State_Index'Image
(State) &
+ " has no actions; bad grammar, or " &
+ "first production in grammar must be the only start symbol
production, " &
+ "and it must must have an explicit EOF.");
+ else
+ while Last_Action.Next /= null loop
+ Last_Action := Last_Action.Next;
+ end loop;
+ Last_Action.Next := new Action_Node'(Default_Action);
+ end if;
+ end;
+
+ for Item of Closure.Goto_List loop
+ if Item.Symbol in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal then
+ Add_Goto (Table.States (State), Item.Symbol, Item.State); -- note
list is already sorted.
+ end if;
+ end loop;
+ end Add_Actions;
+
+ procedure Add_Lookahead_Actions
+ (Item : in LR1_Items.Item;
+ Action_List : in out Action_Node_Ptr;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflicts : in out Conflict_Lists.List;
+ Closure : in LR1_Items.Item_Set;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ Prod : Productions.Instance renames Grammar (Item.Prod.LHS);
+ 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
+ Ada.Text_IO.Put_Line ("processing lookaheads");
+ end if;
+
+ -- We ignore propagate lookaheads here.
+ for Lookahead in Item.Lookaheads'Range loop
+ if Item.Lookaheads (Lookahead) then
+ if Lookahead = Descriptor.First_Nonterminal then
+ null;
+ else
+ Add_Action
+ (Lookahead, Action, Action_List, Closure, Grammar,
+ Has_Empty_Production, First_Nonterm_Set, Conflicts,
Descriptor);
+ end if;
+ end if;
+ end loop;
+ end Add_Lookahead_Actions;
+
+ procedure Delete_Known
+ (Conflicts : in out Conflict_Lists.List;
+ Known_Conflicts : in out Conflict_Lists.List)
+ is
+ -- Delete all elements in Conflicts that match an element in
+ -- Known_Conflicts. There can be more than one Conflict that
+ -- match one Known_Conflict.
+ use Conflict_Lists;
+ Known : Cursor := Known_Conflicts.First;
+ Next_Known : Cursor;
+ begin
+ loop
+ exit when Known = No_Element;
+ Next_Known := Next (Known);
+ declare
+ I : Cursor := Conflicts.First;
+ Next_I : Cursor;
+ Used : Boolean := False;
+ begin
+ loop
+ exit when I = No_Element;
+ Next_I := Next (I);
+ if Match (Element (Known), Conflicts.Constant_Reference (I))
then
+ Delete (Conflicts, I);
+ Used := True;
+ end if;
+ I := Next_I;
+ end loop;
+
+ if Used then
+ Delete (Known_Conflicts, Known);
+ end if;
+ end;
+ Known := Next_Known;
+ end loop;
+ end Delete_Known;
+
+ function Find
+ (Closure : in LR1_Items.Item_Set;
+ Action : in Parse_Action_Rec;
+ Lookahead : in Token_ID;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First : in Token_Array_Token_Set;
+ Descriptor : in WisiToken.Descriptor)
+ return Token_ID
+ is
+ use WisiToken.Token_ID_Arrays;
+
+ ID_I : Cursor;
+ begin
+ case Action.Verb is
+ when Reduce | Accept_It =>
+ -- If the nonterm produced by the reduce is the LHS of the state
+ -- production, use it.
+ for Item of Closure.Set loop
+ if LR1_Items.In_Kernel (Grammar, Descriptor, Item) and
+ Action.Production.LHS = Item.Prod.LHS
+ then
+ return Item.Prod.LHS;
+ end if;
+ end loop;
+
+ -- The reduce nonterm is after Dot in a state production; find which
+ -- one, use that.
+ for Item of Closure.Set loop
+ if LR1_Items.In_Kernel (Grammar, Descriptor, Item) then
+ ID_I := Item.Dot;
+ loop
+ if ID_I = No_Element then
+ if Item.Lookaheads (Lookahead) then
+ return Item.Prod.LHS;
+ end if;
+ else
+ declare
+ Dot_ID : Token_ID renames Element (ID_I);
+ begin
+ if Dot_ID = Lookahead or
+ (Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
+ First (Dot_ID, Lookahead))
+ then
+ return Item.Prod.LHS;
+ end if;
+ exit when Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
+ not Has_Empty_Production (Dot_ID);
+ end;
+ end if;
+
+ exit when ID_I = No_Element;
+ Next (ID_I);
+ end loop;
+ end if;
+ end loop;
+
+ when Shift =>
+
+ for Item of Closure.Set loop
+ -- Lookahead (the token shifted) is starting a nonterm in a state
+ -- production; it is in First of that nonterm.
+ if LR1_Items.In_Kernel (Grammar, Descriptor, Item) then
+ ID_I := Item.Dot;
+ loop
+ exit when ID_I = No_Element;
+ declare
+ Dot_ID : Token_ID renames Element (ID_I);
+ begin
+ if Dot_ID = Lookahead or
+ (Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
+ First (Dot_ID, Lookahead))
+ then
+ return Item.Prod.LHS;
+ end if;
+
+ exit when Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
+ not Has_Empty_Production (Dot_ID);
+ end;
+
+ Next (ID_I);
+ end loop;
+ end if;
+ end loop;
+
+ when WisiToken.Parse.LR.Error =>
+ raise SAL.Programmer_Error;
+ end case;
+
+ Ada.Text_IO.Put_Line
+ ("item for " & Image (Action, Descriptor) & " on " & Image (Lookahead,
Descriptor) & " not found in");
+ LR1_Items.Put (Grammar, Descriptor, Closure, Kernel_Only => True);
+ raise SAL.Programmer_Error;
+ end Find;
+
+ function Image (Item : in Conflict; Descriptor : in WisiToken.Descriptor)
return String
+ is begin
+ return
+ ("%conflict " &
+ Conflict_Parse_Actions'Image (Item.Action_A) & "/" &
+ Conflict_Parse_Actions'Image (Item.Action_B) & " in state " &
+ Image (Item.LHS_A, Descriptor) & ", " &
+ Image (Item.LHS_B, Descriptor) &
+ " on token " & Image (Item.On, Descriptor) &
+ " (" & State_Index'Image (Item.State_Index) & ")"); -- state number
last for easier delete
+ end Image;
+
+ function Is_Present (Item : in Conflict; Conflicts : in
Conflict_Lists.List) return Boolean
+ is
+ use Conflict_Lists;
+ I : Cursor := Conflicts.First;
+ begin
+ loop
+ exit when I = No_Element;
+ if Match (Item, Conflicts.Constant_Reference (I)) then
+ return True;
+ end if;
+ I := Next (I);
+ end loop;
+ return False;
+ end Is_Present;
+
+ function Match (Known : in Conflict; Item : in
Conflict_Lists.Constant_Reference_Type) return Boolean
+ is begin
+ -- Ignore State_Index. Actions are in canonical order; enforced
+ -- in Add_Action above. For reduce/reduce, LHS_A, LHS_B are not
+ -- in canonical order.
+ return
+ Known.Action_A = Item.Action_A and
+ Known.Action_B = Item.Action_B and
+ ((Known.LHS_A = Item.LHS_A and Known.LHS_B = Item.LHS_B) or
+ (Known.LHS_B = Item.LHS_A and Known.LHS_A = Item.LHS_B)) and
+ Known.On = Item.On;
+ end Match;
+
+ function Image (Item : in RHS_Sequence; Descriptor : in
WisiToken.Descriptor) return String
+ is begin
+ return "(" & Boolean'Image (Item.Left_Recursive) & ", " & Image
(Item.Sequence, Descriptor) & ")";
+ end Image;
+
+ function Min (Item : in RHS_Sequence_Arrays.Vector) return RHS_Sequence
+ is
+ use all type Ada.Containers.Count_Type;
+ Min_Length : Ada.Containers.Count_Type := Ada.Containers.Count_Type'Last;
+ Min_RHS : Natural := Natural'Last;
+ begin
+ -- This version assumes all RHS are computed.
+ for RHS in Item.First_Index .. Item.Last_Index loop
+ if Min_Length > Item (RHS).Sequence.Length then
+ Min_Length := Item (RHS).Sequence.Length;
+ Min_RHS := RHS;
+ end if;
+ end loop;
+ if Min_RHS = Natural'Last then
+ raise Grammar_Error with "nonterm has no minimum terminal sequence";
+ else
+ return Item (Min_RHS);
+ end if;
+ end Min;
+
+ function Compute_Minimal_Terminal_Sequences
+ (Descriptor : in WisiToken.Descriptor;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
+ 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);
+
+ Recursing_Index : Token_ID_Array_Positive :=
+ (Descriptor.First_Nonterminal .. Descriptor.Last_Nonterminal =>
Positive'Last);
+
+ RHS_Set : Token_ID_RHS_Set :=
+ (Descriptor.First_Nonterminal .. Descriptor.Last_Nonterminal =>
LR.RHS_Set.Empty_Vector);
+
+ Last_Count : Integer := 0;
+ This_Count : Integer;
+ 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);
+ end if;
+ 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";
+ end if;
+ Last_Count := This_Count;
+ end loop;
+ end return;
+ end Compute_Minimal_Terminal_Sequences;
+
+ function Compute_Minimal_Terminal_First
+ (Descriptor : in WisiToken.Descriptor;
+ Minimal_Terminal_Sequences : in Minimal_Sequence_Array)
+ return Token_Array_Token_ID
+ is
+ use all type Ada.Containers.Count_Type;
+ use Token_ID_Arrays;
+ begin
+ return Result : Token_Array_Token_ID (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal) do
+ for ID in Result'Range loop
+ declare
+ Min_Seq : Token_ID_Arrays.Vector renames Min
(Minimal_Terminal_Sequences (ID)).Sequence;
+ begin
+ if Min_Seq.Length = 0 then
+ Result (ID) := Invalid_Token_ID;
+ else
+ Result (ID) := Element (Min_Seq.First);
+ end if;
+ end;
+ end loop;
+ end return;
+ end Compute_Minimal_Terminal_First;
+
+ procedure Set_Minimal_Complete_Actions
+ (State : in out Parse_State;
+ Kernel : in LR1_Items.Item_Set;
+ Descriptor : in WisiToken.Descriptor;
+ Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
+ Minimal_Terminal_Sequences : in Minimal_Sequence_Array;
+ Minimal_Terminal_First : in Token_Array_Token_ID)
+ is
+ use all type Ada.Containers.Count_Type;
+ use LR1_Items.Item_Lists;
+ use Token_ID_Arrays;
+
+ 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;
+
+ function Find_Action (List : in Action_Node_Ptr; ID : in Token_ID)
return Minimal_Action
+ is
+ Node : Action_Node_Ptr := List;
+ begin
+ loop
+ if Node.Symbol = ID then
+ case Node.Action.Item.Verb is
+ when Shift =>
+ return (Shift, ID, Node.Action.Item.State);
+ when Reduce =>
+ -- Item.Dot is a nonterm that starts with a nullable
nonterm; reduce
+ -- to that first.
+ return (Reduce, Node.Action.Item.Production.LHS, 0);
+ when Accept_It | WisiToken.Parse.LR.Error =>
+ raise SAL.Programmer_Error;
+ end case;
+ end if;
+ Node := Node.Next;
+ exit when Node = null;
+ end loop;
+ raise SAL.Programmer_Error;
+ end Find_Action;
+
+ 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;
+ 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:
+ -- aggregate <= LEFT_PAREN RIGHT_PAREN
+ -- but one state has:
+ -- 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
+
+ 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;
+ 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);
+ declare
+ Prod : constant WisiToken.Production_ID := Constant_Ref
(I).Prod;
+ 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);
+ end if;
+ end;
+ end loop;
+ end if;
+ end Delete_Non_Minimal;
+
+ begin
+ -- 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
+ -- level production (ie declaration or statement) as quickly as
+ -- possible, because the next real token is known to be the start of
+ -- a high level production, or the end of a containing block-style
+ -- 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
+ -- the minimal complete actions strategy.
+
+ if (for some Item of Working_Set =>
+ Item.Prod.LHS = Descriptor.Accept_ID and
+ (Has_Element (Item.Dot) and then Element (Item.Dot) =
Descriptor.EOI_ID))
+ then
+ -- No actions
+ 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;
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line ("after deletions:");
+ LR1_Items.Put (Grammar, Descriptor, Working_Set, Show_Lookaheads =>
False);
+ end if;
+
+ -- 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 ID in Terminals then
+ State.Minimal_Complete_Action := Find_Action
(State.Action_List, ID);
+
+ 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);
+
+ else
+ State.Minimal_Complete_Action := Find_Action
(State.Action_List, Minimal_Terminal_First (ID));
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
+ end loop;
+ end Set_Minimal_Complete_Actions;
+
+ ----------
+ -- Parse table output
+
+ procedure Put_Text_Rep
+ (Table : in Parse_Table;
+ File_Name : in String;
+ Action_Names : in Names_Array_Array;
+ Check_Names : in Names_Array_Array)
+ is
+ 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.
+
+ Create (File, Out_File, File_Name);
+
+ -- First the discriminants
+ Put (File,
+ Trimmed_Image (Table.State_First) & State_Index'Image
(Table.State_Last) &
+ Token_ID'Image (Table.First_Terminal) & Token_ID'Image
(Table.Last_Terminal) &
+ Token_ID'Image (Table.First_Nonterminal) & Token_ID'Image
(Table.Last_Nonterminal));
+ 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
+ loop
+ exit when Node_I = null;
+ -- Action first, so we know if Symbol is present (not when
Error)
+ declare
+ Node_J : Parse_Action_Node_Ptr := Node_I.Action;
+ Put_Symbol : Boolean := True;
+ begin
+ loop
+ Put (File, Parse_Action_Verbs'Image (Node_J.Item.Verb));
+
+ case Node_J.Item.Verb is
+ when Shift =>
+ Put (File, State_Index'Image (Node_J.Item.State));
+
+ when Reduce | Accept_It =>
+ Put (File, Token_ID'Image (Node_J.Item.Production.LHS)
&
+ Integer'Image (Node_J.Item.Production.RHS));
+
+ if Action_Names (Node_J.Item.Production.LHS) /= null
and then
+ Action_Names
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS) /= null
+ then
+ Put (File, " true");
+ else
+ Put (File, " false");
+ end if;
+ if Check_Names (Node_J.Item.Production.LHS) /= null
and then
+ Check_Names
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS) /= null
+ then
+ Put (File, " true");
+ else
+ Put (File, " false");
+ end if;
+
+ Put (File, Ada.Containers.Count_Type'Image
(Node_J.Item.Token_Count));
+
+ when Parse.LR.Error =>
+ -- Error action terminates the action list
+ Put_Symbol := False;
+ end case;
+
+ Node_J := Node_J.Next;
+ exit when Node_J = null;
+ Put (File, ' ');
+ end loop;
+ Put (File, ';');
+ if Put_Symbol then
+ Put (File, Token_ID'Image (Node_I.Symbol));
+ end if;
+ end;
+ New_Line (File);
+
+ Node_I := Node_I.Next;
+ end loop;
+ end;
+
+ declare
+ Node_I : Goto_Node_Ptr := State.Goto_List;
+ begin
+ loop
+ exit when Node_I = null;
+ Put (File, Token_ID'Image (Symbol (Node_I)) & State_Index'Image
(Parse.LR.State (Node_I)));
+ Node_I := Next (Node_I);
+ end loop;
+ Put (File, ';');
+ 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);
+ end loop;
+ Close (File);
+ end Put_Text_Rep;
+
+ procedure Put (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor)
+ is
+ use Ada.Containers;
+ use Ada.Text_IO;
+ begin
+ case Item.Verb is
+ when Shift =>
+ Put ("shift and goto state" & State_Index'Image (Item.State));
+
+ when Reduce =>
+ Put
+ ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
+ Image (Item.Production.LHS, Descriptor));
+ when Accept_It =>
+ Put ("accept it");
+ when Parse.LR.Error =>
+ Put ("ERROR");
+ end case;
+ end Put;
+
+ procedure Put (Item : in McKenzie_Param_Type; Descriptor : in
WisiToken.Descriptor)
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("(Insert =>");
+ for I in Item.Insert'Range loop
+ Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Insert (I)));
+ if I = Item.Insert'Last then
+ Put_Line (")");
+ else
+ Put_Line (",");
+ end if;
+ end loop;
+ Put_Line ("(Delete =>");
+ for I in Item.Delete'Range loop
+ Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Delete (I)));
+ if I = Item.Delete'Last then
+ Put_Line (")");
+ else
+ Put_Line (",");
+ 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
+ Put_Line (")");
+ else
+ Put_Line (",");
+ end if;
+ end loop;
+ 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));
+ end Put;
+
+ procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Parse_Action_Rec)
+ is
+ use Ada.Containers;
+ use Ada.Text_IO;
+ begin
+ case Item.Verb is
+ when Shift =>
+ Put ("shift and goto state" & State_Index'Image (Item.State));
+ when Reduce =>
+ Put
+ ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
+ Image (Item.Production.LHS, Descriptor));
+ Put (" " & Trimmed_Image (Item.Production));
+ when Accept_It =>
+ Put ("accept it");
+ Put (" " & Trimmed_Image (Item.Production));
+ when Parse.LR.Error =>
+ Put ("ERROR");
+ end case;
+ end Put;
+
+ procedure Put (Descriptor : in WisiToken.Descriptor; Action : in
Parse_Action_Node_Ptr)
+ is
+ use Ada.Text_IO;
+ Ptr : Parse_Action_Node_Ptr := Action;
+ Column : constant Positive_Count := Col;
+ begin
+ loop
+ Put (Descriptor, Ptr.Item);
+ Ptr := Ptr.Next;
+ exit when Ptr = null;
+ Put_Line (",");
+ Set_Col (Column);
+ end loop;
+ end Put;
+
+ procedure Put (Descriptor : in WisiToken.Descriptor; State : in Parse_State)
+ is
+ use Ada.Text_IO;
+ use Ada.Strings.Fixed;
+ Action_Ptr : Action_Node_Ptr := State.Action_List;
+ Goto_Ptr : Goto_Node_Ptr := State.Goto_List;
+ begin
+ while Action_Ptr /= null loop
+ Put (" ");
+ if Action_Ptr.Next = null then
+ Put ("default" & (Descriptor.Image_Width - 7) * ' ' & " => ");
+
+ elsif Action_Ptr.Action.Item.Verb /= Parse.LR.Error then
+ Put (Image (Action_Ptr.Symbol, Descriptor) &
+ (Descriptor.Image_Width - Image (Action_Ptr.Symbol,
Descriptor)'Length) * ' '
+ & " => ");
+ end if;
+ Put (Descriptor, Action_Ptr.Action);
+ New_Line;
+ Action_Ptr := Action_Ptr.Next;
+ end loop;
+
+ if Goto_Ptr /= null then
+ New_Line;
+ end if;
+
+ while Goto_Ptr /= null loop
+ Put_Line
+ (" " & Image (Symbol (Goto_Ptr), Descriptor) &
+ (Descriptor.Image_Width - Image (Symbol (Goto_Ptr),
Descriptor)'Length) * ' ' &
+ " goto state" & State_Index'Image (Parse.LR.State (Goto_Ptr)));
+ Goto_Ptr := Next (Goto_Ptr);
+ end loop;
+
+ New_Line;
+ Put (" Minimal_Complete_Action => (");
+ case State.Minimal_Complete_Action.Verb is
+ when Pause =>
+ null;
+ when Shift =>
+ Put (Image (State.Minimal_Complete_Action.ID, Descriptor));
+ when Reduce =>
+ Put (Image (State.Minimal_Complete_Action.Nonterm, Descriptor));
+ end case;
+ Put_Line (")");
+ 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)
+ is
+ use all type Ada.Containers.Count_Type;
+ use Ada.Text_IO;
+ begin
+ Put_Line ("Tokens:");
+ WisiToken.Put_Tokens (Descriptor);
+
+ New_Line;
+ Put_Line ("Productions:");
+ WisiToken.Productions.Put (Grammar, Descriptor);
+
+ if 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
+ then
+ New_Line;
+ Put_Line ("McKenzie:");
+ Put (Table.McKenzie_Param, Descriptor);
+ end if;
+
+ New_Line;
+ 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);
+ New_Line;
+ Put (Descriptor, Table.States (State_Index));
+
+ if State_Index /= Table.States'Last then
+ New_Line;
+ end if;
+ end loop;
+
+ if Conflicts.Length > 0 then
+ declare
+ use Ada.Strings.Unbounded;
+ Last_State : Unknown_State_Index := Unknown_State;
+ Line : Unbounded_String := +"States with conflicts:";
+ 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;
+ end loop;
+ Indent_Wrap (-Line);
+ end;
+ end if;
+ end Put_Parse_Table;
+
+end WisiToken.Generate.LR;
diff --git a/wisitoken-generate-lr.ads b/wisitoken-generate-lr.ads
index 4a57ff8..9cb22f2 100644
--- a/wisitoken-generate-lr.ads
+++ b/wisitoken-generate-lr.ads
@@ -2,7 +2,7 @@
--
-- Common utilities for LR parser table generators.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -117,33 +117,59 @@ package WisiToken.Generate.LR is
function Match (Known : in Conflict; Item : in
Conflict_Lists.Constant_Reference_Type) return Boolean;
- procedure Compute_Minimal_Terminal_Sequences
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Result : in out Token_Sequence_Arrays.Vector);
+ type RHS_Sequence is
+ record
+ Left_Recursive : Boolean := False;
+ -- Direct or indirect; see comment in
+ -- Set_Minimal_Complete_Actions.Delete_Non_Minimal.
+
+ Sequence : Token_ID_Arrays.Vector;
+ end record;
+
+ package RHS_Sequence_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Natural, RHS_Sequence, Default_Element => (others => <>));
+
+ 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 Min (Item : in RHS_Sequence_Arrays.Vector) return RHS_Sequence;
+ -- Return element of Item with minimum length;
+
+ 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)
+ 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.
+ -- the production may be empty, or Invalid_Token_ID if it is
+ -- recursive.
- function Minimal_Terminal_First
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
+ function Compute_Minimal_Terminal_First
+ (Descriptor : in WisiToken.Descriptor;
+ Minimal_Terminal_Sequences : in Minimal_Sequence_Array)
return Token_Array_Token_ID;
-- For each nonterminal in Grammar, return the first of the minimal
-- sequence of terminals that will complete it; Invalid_Token_ID if
-- the minimal sequence is empty.
procedure Set_Minimal_Complete_Actions
- (State : in out Parse_State;
- Kernel : in LR1_Items.Item_Set;
- Minimal_Terminal_First : in Token_Array_Token_ID;
- Ancestors : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor;
- Grammar : in
WisiToken.Productions.Prod_Arrays.Vector);
- -- Set State.Minimal_Terminal_First to the set of terminals that will
+ (State : in out Parse_State;
+ Kernel : in LR1_Items.Item_Set;
+ Descriptor : in WisiToken.Descriptor;
+ Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
+ Minimal_Terminal_Sequences : in Minimal_Sequence_Array;
+ Minimal_Terminal_First : in Token_Array_Token_ID);
+ -- Set State.Minimal_Complete_Actions to the set of actions that will
-- most quickly complete the productions in Kernel (which must be for
-- State). Useful in error correction when we know the next actual
-- 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.
----------
-- Parse table output
@@ -169,7 +195,6 @@ package WisiToken.Generate.LR is
Title : in String;
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Kernels : in LR1_Items.Item_Set_List;
- Ancestors : in Token_Array_Token_Set;
Conflicts : in Conflict_Lists.List;
Descriptor : in WisiToken.Descriptor);
diff --git a/wisitoken-generate-lr1_items.adb b/wisitoken-generate-lr1_items.adb
index 05ad564..b6d14ca 100644
--- a/wisitoken-generate-lr1_items.adb
+++ b/wisitoken-generate-lr1_items.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2002, 2003, 2008, 2009, 2012 - 2015, 2017, 2018 Free
Software Foundation, Inc.
+-- Copyright (C) 2002, 2003, 2008, 2009, 2012 - 2015, 2017 - 2019 Free
Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -43,7 +43,7 @@ package body WisiToken.Generate.LR1_Items is
begin
for Item of Set loop
if Item.Dot /= Token_ID_Arrays.No_Element then
- if Element (Item.Dot) /= Descriptor.EOF_ID then
+ if Element (Item.Dot) /= Descriptor.EOI_ID then
IDs (Element (Item.Dot)) := True;
end if;
end if;
@@ -536,6 +536,23 @@ package body WisiToken.Generate.LR1_Items is
procedure Put
(Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Descriptor : in WisiToken.Descriptor;
+ Item : in Item_Lists.List;
+ Show_Lookaheads : in Boolean := True;
+ Kernel_Only : in Boolean := False)
+ is begin
+ for It of Item loop
+ if not Kernel_Only or else
+ In_Kernel (Grammar, Descriptor, It)
+ then
+ Ada.Text_IO.Put_Line
+ (" " & Image (Grammar, Descriptor, It, Show_Lookaheads =>
Show_Lookaheads));
+ end if;
+ end loop;
+ end Put;
+
+ procedure Put
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
Item : in Item_Set;
Show_Lookaheads : in Boolean := True;
Kernel_Only : in Boolean := False;
@@ -547,14 +564,7 @@ package body WisiToken.Generate.LR1_Items is
Put_Line ("State" & Unknown_State_Index'Image (Item.State) & ":");
end if;
- for It of Item.Set loop
- if not Kernel_Only or else
- In_Kernel (Grammar, Descriptor, It)
- then
- Put_Line
- (" " & Image (Grammar, Descriptor, It, Show_Lookaheads =>
Show_Lookaheads));
- end if;
- end loop;
+ Put (Grammar, Descriptor, Item.Set, Show_Lookaheads, Kernel_Only);
if Show_Goto_List then
Put (Descriptor, Item.Goto_List);
diff --git a/wisitoken-generate-lr1_items.ads b/wisitoken-generate-lr1_items.ads
index d776e4a..3ee55d8 100644
--- a/wisitoken-generate-lr1_items.ads
+++ b/wisitoken-generate-lr1_items.ads
@@ -2,7 +2,7 @@
--
-- Types and operatorion for LR(1) items.
--
--- Copyright (C) 2003, 2008, 2013-2015, 2017, 2018 Free Software Foundation,
Inc.
+-- Copyright (C) 2003, 2008, 2013 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -216,12 +216,12 @@ package WisiToken.Generate.LR1_Items is
-- Not combined with non-Lookaheads version for speed; this is called
-- a lot.
- package Item_Set_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(State_Index, Item_Set);
+ package Item_Set_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (State_Index, Item_Set, Default_Element => (others => <>));
subtype Item_Set_List is Item_Set_Arrays.Vector;
- package State_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(Positive, State_Index);
-
- package Int_Arrays is new SAL.Gen_Unbounded_Definite_Vectors (Positive,
Interfaces.Integer_16);
+ package Int_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Positive, Interfaces.Integer_16, Default_Element =>
Interfaces.Integer_16'Last);
function Compare_Integer_16 (Left, Right : in Interfaces.Integer_16) return
SAL.Compare_Result is
(if Left > Right then SAL.Greater
elsif Left < Right then SAL.Less
@@ -313,6 +313,13 @@ package WisiToken.Generate.LR1_Items is
procedure Put
(Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Descriptor : in WisiToken.Descriptor;
+ Item : in Item_Lists.List;
+ Show_Lookaheads : in Boolean := True;
+ Kernel_Only : in Boolean := False);
+
+ procedure Put
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
Item : in Item_Set;
Show_Lookaheads : in Boolean := True;
Kernel_Only : in Boolean := False;
diff --git a/wisitoken-generate.adb b/wisitoken-generate.adb
index 81ae9da..9796b87 100644
--- a/wisitoken-generate.adb
+++ b/wisitoken-generate.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
@@ -358,67 +358,6 @@ package body WisiToken.Generate is
return Result;
end Follow;
- function Ancestors
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return Token_Array_Token_Set
- is
- use all type Ada.Containers.Count_Type;
-
- Done : Boolean := False;
- begin
- return All_Ancestors : Token_Array_Token_Set
- (Descriptor.First_Terminal .. Grammar.Last_Index,
- Grammar.First_Index .. Grammar.Last_Index) :=
- (others => (others => False))
- do
- loop
- exit when Done;
- Done := True;
- for Prod of Grammar loop
- for R of Prod.RHSs loop
- if R.Tokens.Length = 1 then
- declare
- ID : constant Token_ID := R.Tokens (1);
- begin
- if not All_Ancestors (ID, Prod.LHS) then
- Done := False;
- end if;
- All_Ancestors (ID, Prod.LHS) := True;
- for J in All_Ancestors'Range (2) loop
- if All_Ancestors (Prod.LHS, J) then
- if not All_Ancestors (ID, J) then
- Done := False;
- All_Ancestors (ID, J) := True;
- end if;
- end if;
- end loop;
- end;
- end if;
- end loop;
- end loop;
- end loop;
- end return;
- end Ancestors;
-
- function Descendants
- (Ancestors : in Token_Array_Token_Set)
- return Token_Sequence_Arrays.Vector
- is
- subtype Nonterminals is Token_ID range Ancestors'First (2) ..
Ancestors'Last (2);
- begin
- return Result : Token_Sequence_Arrays.Vector do
- Result.Set_First_Last (Ancestors'First (2), Ancestors'Last (2));
- for I in Ancestors'Range (1) loop
- for J in Ancestors'Range (2) loop
- if I in Nonterminals and Ancestors (I, J) then
- Result (J).Append (I);
- end if;
- end loop;
- end loop;
- end return;
- end Descendants;
-
----------
-- Indented text output
diff --git a/wisitoken-generate.ads b/wisitoken-generate.ads
index 28636d4..01340eb 100644
--- a/wisitoken-generate.ads
+++ b/wisitoken-generate.ads
@@ -12,7 +12,7 @@
--
-- See wisitoken.ads
--
--- 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
@@ -93,21 +93,6 @@ package WisiToken.Generate is
-- tokens that can follow it. Implements algorithm FOLLOW from
-- [dragon] pg 189.
- function Ancestors
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return Token_Array_Token_Set;
- -- For each terminal and nonterm, record the nonterms it reduces to
- -- via one token reductions, recursively. In other words, if there is
- -- a production J <= I, then Ancestors (I, J) is True.
-
- function Descendants
- (Ancestors : in Token_Array_Token_Set)
- return Token_Sequence_Arrays.Vector;
- -- Inverse of Ancestors, excluding terminals. If there is a
- -- production J <= I and I is a nonterminal, then I is present in
- -- Descendants (J).
-
----------
-- Indented text output. Mostly used for code generation in wisi,
-- also used in outputing the parse_table and other debug stuff.
diff --git a/wisitoken-lexer-re2c.adb b/wisitoken-lexer-re2c.adb
index 5eae70d..10bbd16 100644
--- a/wisitoken-lexer-re2c.adb
+++ b/wisitoken-lexer-re2c.adb
@@ -2,7 +2,7 @@
--
-- see spec.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -47,22 +47,29 @@ package body WisiToken.Lexer.re2c is
type Instance_Access is access Instance; -- silence compiler warning
function New_Lexer
- (Trace : not null access WisiToken.Trace'Class)
+ (Descriptor : not null access constant WisiToken.Descriptor)
return Handle
is begin
- return Handle (Instance_Access'(new Instance (Trace)));
+ return Handle (Instance_Access'(new Instance (Descriptor)));
end New_Lexer;
- overriding procedure Reset_With_String (Lexer : in out Instance; Input : in
String)
+ overriding procedure Reset_With_String
+ (Lexer : in out Instance;
+ Input : in String;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First)
is begin
Finalize (Lexer);
-- We assume Input is in UTF-8 encoding
Lexer.Source :=
- (Label => String_Label,
- File_Name => +"",
- Buffer => new String'(Input),
- User_Buffer => False);
+ (Label => String_Label,
+ File_Name => +"",
+ Buffer_Nominal_First_Byte => Base_Buffer_Pos (Input'First),
+ Buffer_Nominal_First_Char => Begin_Char,
+ Line_Nominal_First => Begin_Line,
+ Buffer => new String'(Input),
+ User_Buffer => False);
Lexer.Lexer := New_Lexer
(Buffer => Lexer.Source.Buffer.all'Address,
@@ -73,9 +80,11 @@ package body WisiToken.Lexer.re2c is
end Reset_With_String;
overriding procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String)
+ (Lexer : in out Instance;
+ Input : access String;
+ 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
Finalize (Lexer);
@@ -85,8 +94,11 @@ package body WisiToken.Lexer.re2c is
File_Name =>
+(if Ada.Strings.Unbounded.Length (File_Name) = 0 then ""
else Ada.Directories.Simple_Name (-File_Name)),
- Buffer => Input,
- User_Buffer => True);
+ Buffer_Nominal_First_Byte => Base_Buffer_Pos (Input'First),
+ Buffer_Nominal_First_Char => Begin_Char,
+ Line_Nominal_First => Begin_Line,
+ Buffer => Input,
+ User_Buffer => True);
Lexer.Lexer := New_Lexer
(Buffer => Lexer.Source.Buffer.all'Address,
@@ -96,27 +108,49 @@ package body WisiToken.Lexer.re2c is
Reset (Lexer);
end Reset_With_String_Access;
- overriding procedure Reset_With_File (Lexer : in out Instance; File_Name :
in String)
+ overriding procedure Reset_With_File
+ (Lexer : in out Instance;
+ File_Name : in String;
+ Begin_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ End_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First)
is
use GNATCOLL.Mmap;
+ Length : Buffer_Pos;
begin
Finalize (Lexer);
-- We assume the file is in UTF-8 encoding
Lexer.Source :=
- (File_Label, +Ada.Directories.Simple_Name (File_Name), Open_Read
(File_Name), Invalid_Mapped_Region, 1);
+ (File_Label, +Ada.Directories.Simple_Name (File_Name),
+ Buffer_Nominal_First_Byte => Buffer_Pos'First, -- overwritten below,
+ Buffer_Nominal_First_Char => Begin_Char,
+ Line_Nominal_First => Line_Number_Type'First, -- overwritten
below
+ File => Open_Read (File_Name),
+ Region => Invalid_Mapped_Region,
+ Buffer_Last => 1);
+
+ if Begin_Byte_Pos = Invalid_Buffer_Pos then
+ Lexer.Source.Region := Read (Lexer.Source.File);
+ Length := Buffer_Pos (Last (Lexer.Source.Region));
+ else
+ Length := End_Byte_Pos - Begin_Byte_Pos + 1;
+
+ Lexer.Source.Buffer_Nominal_First_Byte := Begin_Byte_Pos;
+ Lexer.Source.Line_Nominal_First := Begin_Line;
+
+ Lexer.Source.Region := Read
+ (Lexer.Source.File,
+ Offset => File_Size (Begin_Byte_Pos - 1), -- Offset is 0 indexed,
Begin_Byte_Pos is 1 indexed
+ Length => File_Size (Length));
+ end if;
- Lexer.Source.Region := Read (Lexer.Source.File);
Lexer.Source.Buffer_Last := Last (Lexer.Source.Region);
- if Integer (Length (Lexer.Source.File)) /= Lexer.Source.Buffer_Last then
- raise SAL.Programmer_Error with "not all of file is mapped; file
length" &
- File_Size'Image (Length (Lexer.Source.File)) & " mapped:" &
Integer'Image (Lexer.Source.Buffer_Last);
- end if;
-
Lexer.Lexer := New_Lexer
(Buffer => Data (Lexer.Source.Region).all'Address,
- Length => Interfaces.C.size_t (Last (Lexer.Source.Region)),
+ Length => Interfaces.C.size_t (Length),
Verbosity => Interfaces.C.int (if Trace_Parse > 3 then Trace_Parse -
3 else 0));
Reset (Lexer);
@@ -129,9 +163,10 @@ package body WisiToken.Lexer.re2c is
Lexer.Char_Line_Start := 1;
Lexer.ID :=
-- First token is assumed to be first on a line.
- (if Lexer.Trace.Descriptor.New_Line_ID = Invalid_Token_ID
+ (if Lexer.Descriptor.New_Line_ID = Invalid_Token_ID
then Invalid_Token_ID
- else Lexer.Trace.Descriptor.New_Line_ID);
+ else Lexer.Descriptor.New_Line_ID);
+ Lexer.Prev_ID := Invalid_Token_ID;
end Reset;
overriding function Find_Next
@@ -147,20 +182,33 @@ package body WisiToken.Lexer.re2c is
(ID => Lexer.ID,
Byte_Region =>
- (Buffer_Pos (Lexer.Byte_Position),
- Base_Buffer_Pos (Lexer.Byte_Position + Lexer.Byte_Length - 1)),
-
- Line => Lexer.Line,
+ (if Lexer.ID = Lexer.Descriptor.EOI_ID and then
Lexer.Byte_Position = Integer (Base_Buffer_Pos'First)
+ then
+ -- EOF in empty buffer
+ (Lexer.Source.Buffer_Nominal_First_Byte,
+ Lexer.Source.Buffer_Nominal_First_Byte - 1)
+ else
+ (Base_Buffer_Pos (Lexer.Byte_Position) +
Lexer.Source.Buffer_Nominal_First_Byte - Buffer_Pos'First,
+ Base_Buffer_Pos (Lexer.Byte_Position + Lexer.Byte_Length -
1) +
+ Lexer.Source.Buffer_Nominal_First_Byte -
Buffer_Pos'First)),
+
+ Line => Lexer.Line + Lexer.Source.Line_Nominal_First -
Line_Number_Type'First,
Column =>
- (if Lexer.ID = Lexer.Trace.Descriptor.New_Line_ID or
- Lexer.ID = Lexer.Trace.Descriptor.EOF_ID
+ (if Lexer.ID = Lexer.Descriptor.New_Line_ID or
+ Lexer.ID = Lexer.Descriptor.EOI_ID
then 0
else Ada.Text_IO.Count (Lexer.Char_Position -
Lexer.Char_Line_Start)),
Char_Region =>
- (Buffer_Pos (Lexer.Char_Position),
- Base_Buffer_Pos (Lexer.Char_Position + Lexer.Char_Length - 1)));
+ (if Lexer.ID = Lexer.Descriptor.EOI_ID and then
Lexer.Byte_Position = Integer (Base_Buffer_Pos'First)
+ then
+ -- EOF in empty buffer
+ (Lexer.Source.Buffer_Nominal_First_Byte,
+ Lexer.Source.Buffer_Nominal_First_Byte - 1)
+ else
+ (To_Char_Pos (Lexer.Source, Lexer.Char_Position),
+ To_Char_Pos (Lexer.Source, Lexer.Char_Position +
Lexer.Char_Length - 1))));
end Build_Token;
begin
@@ -177,7 +225,7 @@ package body WisiToken.Lexer.re2c is
begin
case Status is
when 0 =>
- if Lexer.ID = Lexer.Trace.Descriptor.New_Line_ID then
+ if Lexer.ID = Lexer.Descriptor.New_Line_ID then
Lexer.Char_Line_Start := Lexer.Char_Position + 1;
end if;
@@ -191,13 +239,20 @@ package body WisiToken.Lexer.re2c is
declare
Buffer : constant GNATCOLL.Mmap.Str_Access :=
WisiToken.Lexer.Buffer (Lexer.Source);
begin
+ if Trace_Parse > Lexer_Debug then
+ -- We don't have a visible Trace object here.
+ Ada.Text_IO.Put_Line ("lexer error char " & Buffer
(Lexer.Byte_Position));
+ end if;
+
if Buffer (Lexer.Byte_Position) = ''' then
-- Lexer has read to next new-line (or eof), then
backtracked to next
-- char after '.
Lexer.Errors.Append
- ((Buffer_Pos (Lexer.Char_Position),
Invalid_Token_Index, (1 => ''', others => ASCII.NUL)));
+ ((To_Char_Pos (Lexer.Source, Lexer.Char_Position),
+ Invalid_Token_Index,
+ (1 => ''', others => ASCII.NUL)));
- Lexer.ID := Lexer.Trace.Descriptor.String_1_ID;
+ Lexer.ID := Lexer.Descriptor.String_1_ID;
Build_Token;
return True;
@@ -205,16 +260,18 @@ package body WisiToken.Lexer.re2c is
-- Lexer has read to next new-line (or eof), then
backtracked to next
-- char after ".
Lexer.Errors.Append
- ((Buffer_Pos (Lexer.Char_Position),
Invalid_Token_Index, (1 => '"', others => ASCII.NUL)));
+ ((To_Char_Pos (Lexer.Source, Lexer.Char_Position),
+ Invalid_Token_Index,
+ (1 => '"', others => ASCII.NUL)));
- Lexer.ID := Lexer.Trace.Descriptor.String_2_ID;
+ Lexer.ID := Lexer.Descriptor.String_2_ID;
Build_Token;
return True;
else
-- Just skip the character; call Next_Token again.
Lexer.Errors.Append
- ((Buffer_Pos (Lexer.Char_Position),
Invalid_Token_Index, (others => ASCII.NUL)));
+ ((To_Char_Pos (Lexer.Source, Lexer.Char_Position),
Invalid_Token_Index, (others => ASCII.NUL)));
end if;
end;
@@ -227,13 +284,18 @@ package body WisiToken.Lexer.re2c is
overriding function First (Lexer : in Instance) return Boolean
is begin
- return Lexer.Trace.Descriptor.New_Line_ID /= Invalid_Token_ID and then
- Lexer.Prev_ID = Lexer.Trace.Descriptor.New_Line_ID;
+ return Lexer.Descriptor.New_Line_ID /= Invalid_Token_ID and then
+ Lexer.Prev_ID = Lexer.Descriptor.New_Line_ID;
end First;
overriding function Buffer_Text (Lexer : in Instance; Byte_Bounds : in
Buffer_Region) return String
- is begin
- return String (Buffer (Lexer.Source) (Integer (Byte_Bounds.First) ..
Integer (Byte_Bounds.Last)));
+ is
+ First : constant Integer := Integer
+ (Byte_Bounds.First - Lexer.Source.Buffer_Nominal_First_Byte +
Buffer_Pos'First);
+ Last : constant Integer := Integer
+ (Byte_Bounds.Last - Lexer.Source.Buffer_Nominal_First_Byte +
Buffer_Pos'First);
+ begin
+ return String (Buffer (Lexer.Source) (First .. Last));
end Buffer_Text;
overriding function File_Name (Lexer : in Instance) return String
diff --git a/wisitoken-lexer-re2c.ads b/wisitoken-lexer-re2c.ads
index 0472908..b58c4ea 100644
--- a/wisitoken-lexer-re2c.ads
+++ b/wisitoken-lexer-re2c.ads
@@ -6,7 +6,7 @@
--
-- [1] http://re2c.org/
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -39,6 +39,9 @@ generic
return System.Address;
-- Create the re2c lexer object, passing it the full text to process.
-- Length is buffer length in 8 bit bytes.
+ --
+ -- The C lexer does not know about Buffer_Nominal_First,
+ -- Line_Nominal_First; its buffer positions and lines start at 1.
with procedure Free_Lexer (Lexer : in out System.Address);
-- Destruct the re2c lexer object
@@ -75,20 +78,32 @@ package WisiToken.Lexer.re2c is
overriding procedure Finalize (Object : in out Instance);
function New_Lexer
- (Trace : not null access WisiToken.Trace'Class)
+ (Descriptor : not null access constant WisiToken.Descriptor)
return WisiToken.Lexer.Handle;
-- If the tokens do not include a reporting New_Line token, set
-- New_Line_ID to Invalid_Token_ID.
- overriding procedure Reset_With_String (Lexer : in out Instance; Input : in
String);
+ overriding procedure Reset_With_String
+ (Lexer : in out Instance;
+ Input : in String;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First);
-- Copies Input to internal buffer.
overriding procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String);
-
- overriding procedure Reset_With_File (Lexer : in out Instance; File_Name :
in String);
+ (Lexer : in out Instance;
+ Input : access String;
+ 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);
+
+ overriding procedure Reset_With_File
+ (Lexer : in out Instance;
+ File_Name : in String;
+ Begin_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ End_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First);
-- Uses memory mapped file; no copies.
overriding procedure Discard_Rest_Of_Input (Lexer : in out Instance) is
null;
@@ -114,7 +129,7 @@ private
Lexer : System.Address := System.Null_Address;
Source : WisiToken.Lexer.Source;
ID : Token_ID; -- Last token read by find_next
- Byte_Position : Natural; -- We don't use Buffer_Pos here, because
Source.Buffer is indexed by Integer
+ Byte_Position : Natural; -- We don't use Buffer_Pos here, because
Source.Buffer is indexed by Integer
Byte_Length : Natural;
Char_Position : Natural;
Char_Length : Natural;
@@ -122,7 +137,7 @@ private
-- start of Managed.Buffer, 1 indexed.
Line : Line_Number_Type; -- after last (or current) New_Line
token
- Char_Line_Start : Natural; -- Character position after last
New_Line token
+ Char_Line_Start : Natural; -- Character position after last
New_Line token, lexer origin.
Prev_ID : Token_ID; -- previous token_id
end record;
diff --git a/wisitoken-lexer-regexp.adb b/wisitoken-lexer-regexp.adb
index 8eb2242..1790b74 100644
--- a/wisitoken-lexer-regexp.adb
+++ b/wisitoken-lexer-regexp.adb
@@ -2,7 +2,7 @@
--
-- See spec
--
--- Copyright (C) 2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -50,7 +50,7 @@ package body WisiToken.Lexer.Regexp is
-- We only support Reset_With_String.
if Current_Char > Lexer.Source.Buffer'Last then
- Lexer.ID := Lexer.Trace.Descriptor.EOF_ID;
+ Lexer.ID := Lexer.Descriptor.EOI_ID;
Lexer.Lexeme_Head := Lexer.Buffer_Head;
Lexer.Lexeme_Tail := Lexer.Buffer_Head - 1;
return True;
@@ -116,7 +116,7 @@ package body WisiToken.Lexer.Regexp is
return True;
elsif Current_Char = Lexer.Source.Buffer'Last then
- Lexer.ID := Lexer.Trace.Descriptor.EOF_ID;
+ Lexer.ID := Lexer.Descriptor.EOI_ID;
Lexer.Buffer_Head := Lexer.Buffer_Head + 1;
return True;
@@ -141,11 +141,11 @@ package body WisiToken.Lexer.Regexp is
type Instance_Access is access Instance; -- silence compiler warning
function New_Lexer
- (Trace : not null access WisiToken.Trace'Class;
- Syntax : in WisiToken.Lexer.Regexp.Syntax)
+ (Descriptor : not null access constant WisiToken.Descriptor;
+ Syntax : in WisiToken.Lexer.Regexp.Syntax)
return WisiToken.Lexer.Handle
is
- New_Lexer : constant Instance_Access := new Instance (Trace,
Syntax'Last);
+ New_Lexer : constant Instance_Access := new Instance (Descriptor,
Syntax'Last);
begin
New_Lexer.Syntax := Syntax;
@@ -157,38 +157,56 @@ package body WisiToken.Lexer.Regexp is
Finalize (Object.Source);
end Finalize;
- overriding procedure Reset_With_String (Lexer : in out Instance; Input : in
String)
+ overriding procedure Reset_With_String
+ (Lexer : in out Instance;
+ Input : in String;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First)
is begin
Finalize (Lexer);
Lexer.Source :=
- (Label => String_Label,
- File_Name => +"",
- Buffer => new String'(Input),
- User_Buffer => False);
+ (Label => String_Label,
+ File_Name => +"",
+ Buffer_Nominal_First_Byte => Base_Buffer_Pos (Input'First),
+ Buffer_Nominal_First_Char => Begin_Char,
+ Line_Nominal_First => Begin_Line,
+ Buffer => new String'(Input),
+ User_Buffer => False);
Reset (Lexer);
end Reset_With_String;
overriding procedure Reset_With_String_Access
(Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String)
+ Input : access String;
+ 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
Finalize (Lexer);
Lexer.Source :=
(Label => String_Label,
File_Name => File_Name,
+ Buffer_Nominal_First_Byte => Base_Buffer_Pos (Input'First),
+ Buffer_Nominal_First_Char => Begin_Char,
+ Line_Nominal_First => Begin_Line,
Buffer => Input,
User_Buffer => True);
Reset (Lexer);
end Reset_With_String_Access;
- overriding procedure Reset_With_File (Lexer : in out Instance; File_Name :
in String)
+ overriding procedure Reset_With_File
+ (Lexer : in out Instance;
+ File_Name : in String;
+ Begin_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ End_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First)
is
- pragma Unreferenced (File_Name);
+ pragma Unreferenced (File_Name, Begin_Byte_Pos, End_Byte_Pos,
Begin_Char, Begin_Line);
begin
Finalize (Lexer);
diff --git a/wisitoken-lexer-regexp.ads b/wisitoken-lexer-regexp.ads
index 8a94560..3a3d5f4 100644
--- a/wisitoken-lexer-regexp.ads
+++ b/wisitoken-lexer-regexp.ads
@@ -6,7 +6,7 @@
-- used in most of the WisiToken unit tests. Since it uses regexp, it
-- is easy to convert to an Aflex lexer.
--
--- Copyright (C) 2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -50,22 +50,34 @@ package WisiToken.Lexer.Regexp is
type Syntax is array (Token_ID range <>) of Syntax_Item;
type Instance
- (Trace : not null access WisiToken.Trace'Class;
+ (Descriptor : not null access constant WisiToken.Descriptor;
Last_Terminal : Token_ID)
is new WisiToken.Lexer.Instance with private;
function New_Lexer
- (Trace : not null access WisiToken.Trace'Class;
- Syntax : in WisiToken.Lexer.Regexp.Syntax)
+ (Descriptor : not null access constant WisiToken.Descriptor;
+ Syntax : in WisiToken.Lexer.Regexp.Syntax)
return WisiToken.Lexer.Handle;
overriding procedure Finalize (Object : in out Instance);
- overriding procedure Reset_With_String (Lexer : in out Instance; Input : in
String);
+ overriding procedure Reset_With_String
+ (Lexer : in out Instance;
+ Input : in String;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First);
overriding procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String);
- overriding procedure Reset_With_File (Lexer : in out Instance; File_Name :
in String);
+ (Lexer : in out Instance;
+ Input : access String;
+ 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);
+ overriding procedure Reset_With_File
+ (Lexer : in out Instance;
+ File_Name : in String;
+ Begin_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ End_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First);
overriding procedure Reset (Lexer : in out Instance);
overriding procedure Discard_Rest_Of_Input (Lexer : in out Instance) is
null;
@@ -87,9 +99,9 @@ private
procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);
type Instance
- (Trace : not null access WisiToken.Trace'Class;
+ (Descriptor : not null access constant WisiToken.Descriptor;
Last_Terminal : Token_ID)
- is new WisiToken.Lexer.Instance (Trace => Trace) with
+ is new WisiToken.Lexer.Instance (Descriptor => Descriptor) with
record
ID : Token_ID; -- last token read by find_next
Syntax : WisiToken.Lexer.Regexp.Syntax (Token_ID'First ..
Last_Terminal);
diff --git a/wisitoken-lexer.adb b/wisitoken-lexer.adb
index 8ceff80..f73d517 100644
--- a/wisitoken-lexer.adb
+++ b/wisitoken-lexer.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -53,4 +53,9 @@ package body WisiToken.Lexer is
return -Source.File_Name;
end File_Name;
+ function To_Char_Pos (Source : in Lexer.Source; Lexer_Char_Pos : in
Integer) return Base_Buffer_Pos
+ is begin
+ return Base_Buffer_Pos (Lexer_Char_Pos) +
Source.Buffer_Nominal_First_Char - Buffer_Pos'First;
+ end To_Char_Pos;
+
end WisiToken.Lexer;
diff --git a/wisitoken-lexer.ads b/wisitoken-lexer.ads
index 0e9c6a1..7be10ed 100644
--- a/wisitoken-lexer.ads
+++ b/wisitoken-lexer.ads
@@ -2,7 +2,7 @@
--
-- An abstract lexer interface.
--
--- Copyright (C) 2014 - 2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2014 - 2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -51,7 +51,7 @@ package WisiToken.Lexer is
package Error_Lists is new Ada.Containers.Doubly_Linked_Lists (Error);
- type Instance (Trace : not null access WisiToken.Trace'Class)
+ type Instance (Descriptor : not null access constant WisiToken.Descriptor)
is abstract new Ada.Finalization.Limited_Controlled with record
Errors : Error_Lists.List;
end record;
@@ -60,19 +60,35 @@ package WisiToken.Lexer is
type Handle is access all Class;
- procedure Reset_With_String (Lexer : in out Instance; Input : in String) is
abstract;
+ procedure Reset_With_String
+ (Lexer : in out Instance;
+ Input : in String;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First)
+ is abstract;
-- Reset Lexer to start a new parse, reading from Input.
procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String)
+ (Lexer : in out Instance;
+ Input : access String;
+ 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 abstract;
- -- Reset Lexer to start a new parse, reading from Input.
- -- File_Name is used for error messages.
-
- procedure Reset_With_File (Lexer : in out Instance; File_Name : in String)
is abstract;
- -- Reset Lexer to start a new parse, reading from File_Name.
+ -- Reset Lexer to start a new parse, reading from Input. File_Name is
+ -- used for error messages.
+
+ procedure Reset_With_File
+ (Lexer : in out Instance;
+ File_Name : in String;
+ Begin_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ End_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
+ Begin_Char : in Buffer_Pos := Buffer_Pos'First;
+ Begin_Line : in Line_Number_Type := Line_Number_Type'First)
+ is abstract;
+ -- Reset Lexer to start a new parse, reading from File_Name. If
+ -- Begin_Pos, End_Pos /= Invalid_Buffer_Pos, only parse that portion
+ -- of the file.
--
-- Raises Ada.IO_Exceptions.Name_Error if File_Name cannot be opened.
@@ -117,7 +133,7 @@ package WisiToken.Lexer is
-- If the underlying text feeder does not support the notion of
-- 'line', returns Invalid_Line_Number.
--
- -- Token.Col is the column number of the start of the token, 1
+ -- Token.Column is the column number of the start of the token, 1
-- indexed. If the underlying text feeder does not support the notion
-- of 'line', returns byte position in internal buffer.
@@ -132,19 +148,28 @@ private
File_Name : Ada.Strings.Unbounded.Unbounded_String;
-- Not saved in Mapped_File, may be empty for String_Label
+ Buffer_Nominal_First_Byte : Buffer_Pos;
+ Buffer_Nominal_First_Char : Buffer_Pos;
+ Line_Nominal_First : Line_Number_Type;
+
case Label is
when String_Label =>
- Buffer : Ada.Strings.Unbounded.String_Access;
+ Buffer : access String;
User_Buffer : Boolean := False;
-- If User_Buffer is True, user provided buffer and will deallocate
-- it. Otherwise we must deallocate it.
+ -- Buffer_Nominal_First, Line_Nominal_First are 1.
when File_Label =>
-- The input is memory mapped from the following, which must be
closed:
File : GNATCOLL.Mmap.Mapped_File;
Region : GNATCOLL.Mmap.Mapped_Region;
Buffer_Last : Positive;
+ -- Region always has first character at offset 0.
+
+ -- Buffer_Nominal_First is Begin_Pos. Line_Nominal_First is
+ -- Begin_Line.
end case;
end record;
@@ -157,5 +182,6 @@ private
-- Source.Buffer_Last. Indexing is reliable.
function File_Name (Source : in Lexer.Source) return String;
+ function To_Char_Pos (Source : in Lexer.Source; Lexer_Char_Pos : in
Integer) return Base_Buffer_Pos;
end WisiToken.Lexer;
diff --git a/wisitoken-parse-lr-mckenzie_recover-base.ads
b/wisitoken-parse-lr-mckenzie_recover-base.ads
index e7592d4..c5d78ea 100644
--- a/wisitoken-parse-lr-mckenzie_recover-base.ads
+++ b/wisitoken-parse-lr-mckenzie_recover-base.ads
@@ -2,7 +2,7 @@
--
-- Base utilities for McKenzie_Recover
--
--- 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
@@ -18,6 +18,7 @@
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
@@ -165,7 +166,7 @@ private package WisiToken.Parse.LR.McKenzie_Recover.Base is
-- There is only one object of this type, declared in Recover. It
-- provides appropriate access to Shared_Parser components.
--
- -- Since all the accesible objects are read-only (except Trace),
+ -- Since all the accessible objects are read-only (except Trace),
-- there are no protected operations, and this is not a protected
-- type.
diff --git a/wisitoken-parse-lr-mckenzie_recover-explore.adb
b/wisitoken-parse-lr-mckenzie_recover-explore.adb
index f47ed68..56bd3fe 100644
--- a/wisitoken-parse-lr-mckenzie_recover-explore.adb
+++ b/wisitoken-parse-lr-mckenzie_recover-explore.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
@@ -18,6 +18,7 @@
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
@@ -28,13 +29,16 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Config : in out Configuration;
State : in State_Index;
ID : in Token_ID;
- Cost_Delta : in Integer)
+ 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);
@@ -60,6 +64,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
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
@@ -69,25 +74,26 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Local_Config_Heap.Add (Config);
end Do_Shift;
- function Do_Reduce_1
- (Super : not null access Base.Supervisor;
+ 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)
- return Non_Success_Status
+ Action : in Reduce_Action_Rec;
+ Do_Language_Fixes : in Boolean := True)
is
use all type SAL.Base_Peek_Type;
- -- Perform Action on Config, setting Config.Check_Status. If that is
- -- not Ok, call Language_Fixes (which may enqueue configs),
- -- return Abandon. Otherwise return Continue.
use all type Semantic_Checks.Check_Status_Label;
use all type WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Table : Parse_Table renames Shared.Table.all;
- Nonterm : Recover_Token;
- New_State : Unknown_State_Index;
+ 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
@@ -98,11 +104,13 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Config.Error_Token := Nonterm;
Config.Check_Token_Count := Action.Token_Count;
- 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);
+ 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.
@@ -122,29 +130,36 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
end if;
Config.Stack.Push ((New_State, Syntax_Trees.Invalid_Node_Index,
Nonterm));
- return Continue;
+
+ 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
- (Super : not null access Base.Supervisor;
+ (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)
+ Cost_Delta : in Integer;
+ Strategy : in Strategies)
is
- -- Perform reduce actions until shift Inserted_Token; if all succeed,
+ -- 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 : Parse_Action_Node_Ptr;
+ Next_Action : constant Parse_Action_Node_Ptr := Action_For (Table,
Config.Stack (1).State, Inserted_ID);
begin
- Next_Action := Action_For (Table, Config.Stack (1).State, Inserted_ID);
-
if Next_Action.Next /= null then
-- There is a conflict; create a new config to shift or reduce.
declare
@@ -154,15 +169,13 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
case Action.Verb is
when Shift =>
Do_Shift
- (Super, Shared, Parser_Index, Local_Config_Heap, New_Config,
Action.State, Inserted_ID, Cost_Delta);
+ (Super, Shared, Parser_Index, Local_Config_Heap, New_Config,
Action.State, Inserted_ID,
+ Cost_Delta, Strategy);
when Reduce =>
- case Do_Reduce_1 (Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action) is
- when Abandon =>
- null;
- when Continue =>
- Do_Reduce_2 (Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Inserted_ID, Cost_Delta);
- end case;
+ 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";
@@ -178,15 +191,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
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);
+ (Super, Shared, Parser_Index, Local_Config_Heap, Config,
Next_Action.Item.State, Inserted_ID,
+ Cost_Delta, Strategy);
when Reduce =>
- case Do_Reduce_1 (Super, Shared, Parser_Index, Local_Config_Heap,
Config, Next_Action.Item) is
- when Abandon =>
- null;
- when Continue =>
- Do_Reduce_2 (Super, Shared, Parser_Index, Local_Config_Heap,
Config, Inserted_ID, Cost_Delta);
- end case;
+ 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";
@@ -416,6 +426,46 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
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;
@@ -482,7 +532,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
use all type Ada.Containers.Count_Type;
Table : Parse_Table renames Shared.Table.all;
- EOF_ID : Token_ID renames Super.Trace.Descriptor.EOF_ID;
+ EOF_ID : Token_ID renames Super.Trace.Descriptor.EOI_ID;
-- Find terminal insertions from the current state's action_list to try.
--
@@ -495,7 +545,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Cached_Config : Configuration;
Cached_Action : Reduce_Action_Rec;
- Cached_Status : Non_Success_Status;
-- 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.
@@ -509,8 +558,10 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
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; we know that failed.
- Config.Ops (Config.Ops.Last_Index) /= (Push_Back, ID,
Config.Current_Shared_Token))
+ (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 =>
@@ -521,7 +572,9 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
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);
+ (Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Action.State, ID,
+ Cost_Delta => 0,
+ Strategy => Explore_Table);
end;
when Reduce =>
@@ -532,26 +585,25 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
New_Config.Error_Token.ID := Invalid_Token_ID;
New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
- Cached_Status := Do_Reduce_1
- (Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Action);
+ Do_Reduce_1 ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action);
Cached_Config := New_Config;
Cached_Action := Action;
- if Cached_Status = Continue then
- Do_Reduce_2
- (Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, ID, Cost_Delta => 0);
- end if;
+ Do_Reduce_2
+ ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
+ Cost_Delta => 0,
+ Strategy => Explore_Table);
end;
else
- if Cached_Status = Continue then
- declare
- New_Config : Configuration := Cached_Config;
- begin
- Do_Reduce_2
- (Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, ID, Cost_Delta => 0);
- end;
- end if;
+ 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 =>
@@ -566,132 +618,171 @@ package body
WisiToken.Parse.LR.McKenzie_Recover.Explore is
end loop;
end Insert_From_Action_List;
- procedure Insert_Minimal_Complete_Actions
+ 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 SAL.Base_Peek_Type;
+ use all type Ada.Containers.Count_Type;
- Table : Parse_Table renames Shared.Table.all;
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+ Table : Parse_Table renames Shared.Table.all;
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+ Insert_Count : Integer := 0;
Cost_Delta : constant Integer := -1;
- type Work_Type is record
- Config : Configuration;
- Complete_Actions : Minimal_Action_Lists.List;
- end record;
-
- package Work_Queues is new SAL.Gen_Unbounded_Definite_Queues (Work_Type);
-
- Work : Work_Queues.Queue;
-
- function Reduce_Only (Item : in Minimal_Action_Lists.List) return
Minimal_Action_Lists.List
- is begin
- return Result : Minimal_Action_Lists.List do
- for Action of Item loop
- if Action.Verb = Reduce then
- Result.Insert (Action);
- end if;
- end loop;
- end return;
- end Reduce_Only;
+ 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
- Work.Put ((Orig_Config, Table.States
(Orig_Config.Stack.Peek.State).Minimal_Complete_Actions));
- loop
- exit when Work.Length = 0;
+ 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
- Item : constant Work_Type := Work.Get;
+ Reduce_Action : Reduce_Action_Rec := To_Reduce_Action
(Complete_Action);
begin
- for Action of Item.Complete_Actions loop
- case Action.Verb is
- when Reduce =>
- -- Do a reduce, look at resulting state. Keep reducing
until we can't
- -- anymore (ignoring possible shifts along the way; we are
looking
- -- for the _minimal_ terminals to insert).
- declare
- use all type Ada.Containers.Count_Type;
- New_Config : Configuration := Item.Config;
- Reduce_Action : Reduce_Action_Rec := To_Reduce_Action
(Action);
+ loop
+ Do_Reduce_1
+ ("Minimal_Complete_Actions", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Reduce_Action,
+ Do_Language_Fixes => False);
- Temp_Actions : Minimal_Action_Lists.List;
- begin
- loop
- case Do_Reduce_1 (Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Reduce_Action) is
- when Abandon =>
- goto Abandon_Reduce;
+ Complete_Action := Table.States
(New_Config.Stack.Peek.State).Minimal_Complete_Action;
- when Continue =>
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions reduce to" &
- State_Index'Image
(New_Config.Stack.Peek.State) & ", " &
- Image (Reduce_Action.Production.LHS,
Descriptor));
- end if;
+ case Complete_Action.Verb is
+ when Pause =>
+ return 0;
+ when Shift =>
+ Minimal_Do_Shift;
+ return Insert_Count;
+ when Reduce =>
+ null;
+ end case;
- Temp_Actions := Reduce_Only
- (Table.States
(New_Config.Stack.Peek.State).Minimal_Complete_Actions);
+ Reduce_Action := To_Reduce_Action
+ (Table.States
(New_Config.Stack.Peek.State).Minimal_Complete_Action);
+ end loop;
+ end;
- exit when Temp_Actions.Length = 0;
+ when Shift =>
+ Minimal_Do_Shift;
+ end case;
+ return Insert_Count;
+ end Insert_Minimal_Complete_Actions;
- Reduce_Action := To_Reduce_Action
(Temp_Actions.Pop);
+ 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;
- if Temp_Actions.Length > 0 then
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label
(Parser_Index),
- "Minimal_Complete_Actions add work item");
- end if;
- Work.Put ((New_Config, Temp_Actions));
- end if;
- end case;
- end loop;
+ 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;
- Insert_Minimal_Complete_Actions (Super, Shared,
Parser_Index, New_Config, Local_Config_Heap);
+ 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);
- <<Abandon_Reduce>>
- end;
+ when Reduce =>
+ Do_Reduce_1
+ ("Matching_Begin", Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Action.Item,
+ Do_Language_Fixes => False);
- when Shift =>
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions shift " &
- Image (Action.ID, Descriptor));
- end if;
- declare
- New_Config : Configuration := Item.Config;
- begin
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+ Do_Reduce_2
+ ("Matching_Begin", Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Matching_Begin_Token,
+ Cost_Delta => -1,
+ Strategy => Matching_Begin);
- Do_Shift
- (Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Action.State, Action.ID,
- Cost_Delta);
- end;
- end case;
- end loop;
- end;
- end loop;
- end Insert_Minimal_Complete_Actions;
+ 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)
+ (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
- Insert_Minimal_Complete_Actions (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+ 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;
@@ -714,7 +805,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Local_Config_Heap : in out Config_Heaps.Heap_Type)
is
use all type Parser.Language_String_ID_Set_Access;
- use all type Lexer.Error_Lists.Cursor;
Descriptor : WisiToken.Descriptor renames Shared.Trace.Descriptor.all;
Check_Limit : Token_Index renames
Shared.Table.McKenzie_Param.Check_Limit;
@@ -724,10 +814,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Lexer_Error_Token : Base_Token;
function Recovered_Lexer_Error (Line : in Line_Number_Type) return
Base_Token_Index
- is
- use WisiToken.Lexer;
- use WisiToken.Lexer.Error_Lists;
- begin
+ 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
@@ -842,6 +929,8 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
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;
@@ -1034,7 +1123,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
is
-- Try deleting (= skipping) the current shared input token.
Trace : WisiToken.Trace'Class renames Super.Trace.all;
- EOF_ID : Token_ID renames Trace.Descriptor.EOF_ID;
+ 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;
@@ -1060,6 +1149,10 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
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;
@@ -1092,6 +1185,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
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;
@@ -1104,24 +1198,13 @@ package body
WisiToken.Parse.LR.McKenzie_Recover.Explore is
-- 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;
+ Use_Minimal_Complete_Actions : Boolean := False;
+ Matching_Begin_Token : Token_ID := Invalid_Token_ID;
function Allow_Insert_Terminal (Config : in Configuration) return Boolean
- is
- use all type Ada.Containers.Count_Type;
- use all type
WisiToken.Parse.LR.Parser.Language_Use_Minimal_Complete_Actions_Access;
- begin
- if Shared.Language_Use_Minimal_Complete_Actions = null then
- return None_Since_FF (Config.Ops, Delete);
- end if;
-
- Use_Minimal_Complete_Actions :=
Shared.Language_Use_Minimal_Complete_Actions
- (Current_Token_ID_Peek
- (Shared.Terminals.all, Config.Current_Shared_Token,
Config.Insert_Delete, Config.Current_Insert_Delete),
- Config);
-
+ is begin
if Use_Minimal_Complete_Actions then
- if Table.States
(Config.Stack.Peek.State).Minimal_Complete_Actions.Length = 0 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.
@@ -1180,7 +1263,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
if Config.Check_Status.Label = Ok then
-- Parse table Error action.
--
- -- We don't clear Config.Error_Token here, because Try_Insert
calls
+ -- 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.
@@ -1262,15 +1345,37 @@ package body
WisiToken.Parse.LR.McKenzie_Recover.Explore is
--
-- All possible permutations will be explored.
- if None_Since_FF (Config.Ops, Delete) and
- None_Since_FF (Config.Ops, Insert) and
- Config.Stack.Depth > 1 -- can't delete the first state
+ 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);
+ 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
diff --git a/wisitoken-parse-lr-mckenzie_recover-parse.adb
b/wisitoken-parse-lr-mckenzie_recover-parse.adb
index c9a7475..52ee7f1 100644
--- a/wisitoken-parse-lr-mckenzie_recover-parse.adb
+++ b/wisitoken-parse-lr-mckenzie_recover-parse.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
@@ -82,7 +82,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
return (Label => Ok);
else
return Status : constant Semantic_Checks.Check_Status :=
- Action.Check (Shared.Lexer, Nonterm, Tokens)
+ Action.Check (Shared.Lexer, Nonterm, Tokens, Recover_Active => True)
do
if Status.Label = Ok then
Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
@@ -129,7 +129,8 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
Terminals_Current => Config.Current_Shared_Token,
Restore_Terminals_Current => Restore_Terminals_Current,
Insert_Delete => Config.Insert_Delete,
- Current_Insert_Delete => Config.Current_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;
@@ -171,7 +172,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
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 (Current_Token, Descriptor) &
" : " & Image (Action.Item, Descriptor));
end if;
@@ -196,7 +197,8 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
Terminals_Current => Config.Current_Shared_Token,
Restore_Terminals_Current => Restore_Terminals_Current,
Insert_Delete => Config.Insert_Delete,
- Current_Insert_Delete => Config.Current_Insert_Delete);
+ Current_Insert_Delete => Config.Current_Insert_Delete,
+ Prev_Deleted => Super.Parser_State
(Parser_Index).Prev_Deleted);
when Reduce =>
declare
diff --git a/wisitoken-parse-lr-mckenzie_recover.adb
b/wisitoken-parse-lr-mckenzie_recover.adb
index c92e2ed..31c6285 100644
--- a/wisitoken-parse-lr-mckenzie_recover.adb
+++ b/wisitoken-parse-lr-mckenzie_recover.adb
@@ -2,7 +2,7 @@
--
-- See spec
--
--- Copyright (C) 2017 - 2018 Free Software Foundation, Inc.
+-- 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
@@ -20,44 +20,79 @@ 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;
- task type Worker_Task
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared)
- is
- entry Start;
- -- Start getting parser/configs to check from Config_Store.
+ type Supervisor_Access is access all Base.Supervisor;
+ type Shared_Access is access all Base.Shared;
- entry Done;
- -- Available when task is ready to terminate; after this rendezvous,
- -- task discriminants may be freed.
+ 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;
- Status : Base.Config_Status;
- begin
- accept Start;
+ Super : Supervisor_Access;
+ Shared : Shared_Access;
+ Status : Base.Config_Status := Valid;
+ begin
loop
- Explore.Process_One (Super, Shared, Status);
+ 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;
- exit when Status = All_Done;
+ loop
+ Explore.Process_One (Super, Shared, Status);
+ exit when Status = All_Done;
+ end loop;
+
+ accept Done;
+
+ Super := null;
+ Shared := null;
end loop;
- accept Done;
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)
@@ -165,7 +200,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
is
use all type Parser.Post_Recover_Access;
use all type SAL.Base_Peek_Type;
- use all type System.Multiprocessors.CPU_Range;
Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
Parsers : Parser_Lists.List renames Shared_Parser.Parsers;
@@ -191,21 +225,10 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
Task_Count : constant System.Multiprocessors.CPU_Range :=
(if Shared_Parser.Table.McKenzie_Param.Task_Count = 0
- then System.Multiprocessors.CPU_Range'Max (1,
System.Multiprocessors.Number_Of_CPUs - 1)
+ then Worker_Tasks'Last
-- Keep one CPU free for this main task, and the user.
else Shared_Parser.Table.McKenzie_Param.Task_Count);
- Worker_Tasks : array (1 .. Task_Count) of Worker_Task (Super'Access,
Shared'Access);
-
- procedure Cleanup
- is begin
- for I in Worker_Tasks'Range loop
- if Worker_Tasks (I)'Callable then
- abort Worker_Tasks (I);
- end if;
- end loop;
- end Cleanup;
-
begin
if Trace_McKenzie > Outline then
Trace.New_Line;
@@ -223,29 +246,45 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
Trace.Put_Line (System.Multiprocessors.CPU_Range'Image
(Worker_Tasks'Last) & " parallel tasks");
end if;
- for I in Worker_Tasks'Range loop
- Worker_Tasks (I).Start;
+ 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;
+ 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;
- -- Ensure all tasks terminate before proceeding; otherwise local
- -- variables disappear while task is still trying to access them.
- for I in Worker_Tasks'Range loop
- if Worker_Tasks (I)'Callable then
- Worker_Tasks (I).Done;
- end if;
- end loop;
-
-- Adjust parser state for each successful recovery.
--
-- One option here would be to keep only the parser with the least
@@ -354,7 +393,20 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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;
@@ -393,6 +445,10 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- 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
@@ -510,6 +566,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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);
@@ -528,6 +585,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
when Delete =>
Parser_State.Shared_Token := Op.Token_Index + 1;
+ Apply_Prev_Token;
Shared_Token_Changed := True;
end case;
else
@@ -536,46 +594,25 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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.
+ -- 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;
- -- Parser_State.Verb is the action that produced the
current stack
- -- top. Parser_State.Inc_Shared_Token determines how to get
the next
- -- token from Shared_Parser.Terminals.
- --
- -- If the stack top or Current_Token is virtual, then after
all
- -- virtuals are inserted, the main parser would normally
increment
- -- Parser_State.Shared_Token to get the next token.
However, we have
- -- set Shared_Token to the next token, so we don't want it
to
- -- increment. We could set Shared_Token to 1 less, but this
way the
- -- debug messages all show the expected Shared_Terminal.
-
- if Parser_State.Stack (1).Token =
Syntax_Trees.Invalid_Node_Index then
- -- a virtual token from a previous recover
- Parser_State.Set_Verb (Shift_Recover);
- Parser_State.Inc_Shared_Token := False;
- else
- case Tree.Label (Parser_State.Stack (1).Token) is
- when Syntax_Trees.Shared_Terminal =>
- Parser_State.Set_Verb (Shift_Recover);
- Parser_State.Inc_Shared_Token := not
Current_Token_Virtual;
-
- when Syntax_Trees.Virtual_Terminal =>
- Parser_State.Set_Verb (Shift_Recover);
- Parser_State.Inc_Shared_Token := False;
-
- when Syntax_Trees.Nonterm =>
- Parser_State.Set_Verb (Reduce);
- Parser_State.Inc_Shared_Token := not
Current_Token_Virtual;
- end case;
- end if;
-
if Trace_McKenzie > Extra then
Put_Line (Trace, Parser_State.Label, "after Ops
applied:", Task_ID => False);
Put_Line
@@ -595,12 +632,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
(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);
-
- elsif Trace_McKenzie > Outline then
- 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
@@ -609,7 +640,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- Oops. just give up
return Fail_Programmer_Error;
end if;
- Parsers.Terminate_Parser (Current_Parser, "bad config in
recover", Trace);
+ Parsers.Terminate_Parser (Current_Parser, "bad config in
recover", Trace, Shared_Parser.Terminals);
end;
end if;
Current_Parser.Next;
@@ -623,7 +654,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
exception
when others =>
- Cleanup;
return Fail_Programmer_Error;
end Recover;
@@ -641,7 +671,8 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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)
+ 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;
@@ -656,7 +687,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
end Inc_I_D;
begin
- if Terminals_Current = Base_Token_Index'First then
+ if Terminals_Current = Invalid_Token_Index then
-- Happens with really bad syntax; see test_mckenzie_recover.adb
Error_4.
raise Bad_Config;
end if;
@@ -679,7 +710,11 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
return (ID => Op.ID, others => <>);
when Delete =>
- Terminals_Current := Terminals_Current + 1;
+ 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;
@@ -690,22 +725,35 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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
+ 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
- return Terminals (Terminals_Current).ID;
+ Current_Token := Terminals (Terminals_Current).ID;
elsif Insert_Delete (Current_Insert_Delete).Token_Index =
Terminals_Current then
declare
@@ -713,7 +761,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
begin
case Insert_Delete_Op_Label (Op.Op) is
when Insert =>
- return Op.ID;
+ Current_Token := Op.ID;
when Delete =>
-- This should have been handled in Check
@@ -721,9 +769,27 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
end case;
end;
else
- return Terminals (Terminals_Current).ID;
+ 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;
+ end Current_Token_ID_Peek_2;
procedure Delete (Config : in out Configuration; ID : in Token_ID)
is
@@ -785,9 +851,10 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
begin
loop
exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- exit when 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);
+ 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;
@@ -887,23 +954,33 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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)
+ 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;
- Terminals_Current := Terminals_Current + 1;
- Restore_Terminals_Current := Terminals_Current;
- return Terminals (Terminals_Current);
+ return Next_Terminal;
elsif Current_Insert_Delete = No_Insert_Delete then
- Terminals_Current := Terminals_Current + 1;
- Restore_Terminals_Current := Terminals_Current;
- return Terminals (Terminals_Current);
+ return Next_Terminal;
elsif Insert_Delete (Current_Insert_Delete + 1).Token_Index =
Terminals_Current + 1 then
Current_Insert_Delete := Current_Insert_Delete + 1;
@@ -921,9 +998,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
end;
else
- Terminals_Current := Terminals_Current + 1;
- Restore_Terminals_Current := Terminals_Current;
- return Terminals (Terminals_Current);
+ return Next_Terminal;
end if;
end loop;
end Next_Token;
diff --git a/wisitoken-parse-lr-mckenzie_recover.ads
b/wisitoken-parse-lr-mckenzie_recover.ads
index f92897b..eba872a 100644
--- a/wisitoken-parse-lr-mckenzie_recover.ads
+++ b/wisitoken-parse-lr-mckenzie_recover.ads
@@ -11,7 +11,7 @@
-- [Grune 2008] Parsing Techniques, A Practical Guide, Second
-- Edition. Dick Grune, Ceriel J.H. Jacobs.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -66,19 +66,22 @@ private
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)
+ 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;
+ 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.
@@ -149,7 +152,8 @@ private
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)
+ 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.
@@ -164,6 +168,9 @@ private
-- 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
diff --git a/wisitoken-parse-lr-parser.adb b/wisitoken-parse-lr-parser.adb
index 9f8aa66..09df9ed 100644
--- a/wisitoken-parse-lr-parser.adb
+++ b/wisitoken-parse-lr-parser.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2002 - 2005, 2008 - 2015, 2017, 2018 Free Software
Foundation, Inc.
+-- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2019 Free Software
Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -29,6 +29,7 @@ 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
@@ -69,11 +70,12 @@ package body WisiToken.Parse.LR.Parser is
else
declare
- Nonterm_Token : Recover_Token := Parser_State.Tree.Recover_Token
(Nonterm);
+ 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 : constant Semantic_Checks.Check_Status := Action.Check
- (Lexer, Nonterm_Token, Children_Token);
+ 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
@@ -99,6 +101,11 @@ package body WisiToken.Parse.LR.Parser is
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;
@@ -180,7 +187,7 @@ package body WisiToken.Parse.LR.Parser is
declare
Expecting : constant Token_ID_Set := LR.Expecting
- (Shared_Parser.Table.all,
Current_Parser.State_Ref.Stack.Peek.State);
+ (Shared_Parser.Table.all, Parser_State.Stack.Peek.State);
begin
Parser_State.Errors.Append
((Label => LR.Action,
@@ -193,7 +200,8 @@ package body WisiToken.Parse.LR.Parser is
if Trace_Parse > Outline then
Put
(Trace,
- Integer'Image (Current_Parser.Label) & ": expecting: " &
+ 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;
@@ -209,7 +217,9 @@ package body WisiToken.Parse.LR.Parser is
begin
if Trace_Parse > Extra then
Shared_Parser.Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ": recover_insert_delete: " &
+ (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;
@@ -221,8 +231,19 @@ package body WisiToken.Parse.LR.Parser is
then Parser_State.Shared_Token + 1
else Parser_State.Shared_Token)
then
- Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
+ 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;
@@ -236,9 +257,6 @@ package body WisiToken.Parse.LR.Parser is
-- Shift : some Parsers.Verb return Shift, all with the same current
-- token in Shared_Parser.Terminals.
--
- -- Shift_Recover : some Parsers.Verb return Shift, with current
- -- tokens virtual (inserted by error recovery).
- --
-- Pause : Resume is active, and this parser has reached Resume_Goal,
-- so it is waiting for the others to catch up.
--
@@ -254,36 +272,20 @@ package body WisiToken.Parse.LR.Parser is
is
use all type SAL.Base_Peek_Type;
- Shift_Count : SAL.Base_Peek_Type := 0;
- Shift_Recover_Count : SAL.Base_Peek_Type := 0;
- Shift_Virtual_Count : SAL.Base_Peek_Type := 0;
- Accept_Count : SAL.Base_Peek_Type := 0;
- Error_Count : SAL.Base_Peek_Type := 0;
- Resume_Active : Boolean := False;
+ 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_Recover | Shift =>
+ when Pause | Shift =>
Do_Deletes (Shared_Parser, Parser_State);
- 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
- -- Shifting a virtual token.
- Shift_Virtual_Count := Shift_Virtual_Count + 1;
- Shift_Recover_Count := Shift_Recover_Count + 1;
- Parser_State.Set_Verb (Shift_Recover);
-
- else
- Shift_Count := Shift_Count + 1;
- Parser_State.Set_Verb (Shift);
- end if;
+ 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
@@ -320,9 +322,6 @@ package body WisiToken.Parse.LR.Parser is
elsif Shared_Parser.Parsers.Count = Error_Count + Zombie_Count then
Verb := Error;
- elsif Shift_Recover_Count > 0 then
- Verb := Shift_Recover;
-
elsif Shift_Count > 0 then
Verb := Shift;
@@ -332,7 +331,7 @@ package body WisiToken.Parse.LR.Parser is
if Resume_Active then
for Parser_State of Shared_Parser.Parsers loop
- if Parser_State.Verb in Shift | Shift_Recover and not
Parser_State.Resume_Active then
+ if Parser_State.Verb = Shift and not Parser_State.Resume_Active
then
Parser_State.Set_Verb (Pause);
end if;
end loop;
@@ -397,10 +396,11 @@ package body WisiToken.Parse.LR.Parser is
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;
- Zombie_Count : SAL.Base_Peek_Type;
+ 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
@@ -439,7 +439,8 @@ package body WisiToken.Parse.LR.Parser is
-- 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);
+ (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;
@@ -451,6 +452,10 @@ package body WisiToken.Parse.LR.Parser is
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;
@@ -496,34 +501,6 @@ package body WisiToken.Parse.LR.Parser is
end if;
elsif Parser_State.Verb = Shift then
- if Parser_State.Inc_Shared_Token then
- -- Inc_Shared_Token is only set False by
McKenzie_Recover; see there
- -- for when/why.
- 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);
-
- 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 Shift_Recover =>
- -- Same as Shift, except input a token inserted by error
recovery, or
- -- input from Shared_Parser.Terminals during error recovery.
-
- for Parser_State of Shared_Parser.Parsers loop
- -- We don't check for Verb = Error; during recovery, errors
cause
- -- parsers to terminate immediately.
-
- if Parser_State.Verb = Shift_Recover 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 =
@@ -534,19 +511,14 @@ package body WisiToken.Parse.LR.Parser is
Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
(Parser_State.Recover_Insert_Delete.Get.ID);
- 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;
-
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.
+ -- 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;
@@ -555,15 +527,12 @@ package body WisiToken.Parse.LR.Parser is
Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
(Parser_State.Shared_Token, Shared_Parser.Terminals);
- 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;
- else
- -- Set_Verb set the wrong verb.
- raise SAL.Programmer_Error;
+ 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;
@@ -593,7 +562,8 @@ package body WisiToken.Parse.LR.Parser is
else
Temp := Current_Parser;
Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser (Temp,
"zombie", Shared_Parser.Trace.all);
+ Shared_Parser.Parsers.Terminate_Parser
+ (Temp, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
end if;
exit when Current_Parser.Is_Done;
end loop;
@@ -619,7 +589,8 @@ package body WisiToken.Parse.LR.Parser is
else
Temp := Current_Parser;
Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser (Temp,
"zombie", Shared_Parser.Trace.all);
+ Shared_Parser.Parsers.Terminate_Parser
+ (Temp, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
end if;
exit when Current_Parser.Is_Done;
end loop;
@@ -650,15 +621,12 @@ package body WisiToken.Parse.LR.Parser is
else
Temp := Current_Parser;
Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser (Temp,
"errors", Shared_Parser.Trace.all);
+ Shared_Parser.Parsers.Terminate_Parser
+ (Temp, "errors", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
end if;
exit when Current_Parser.Is_Done;
end loop;
- if Trace_Parse > Outline then
- Trace.Put_Line ("ambiguous with error");
- end if;
-
exit Main_Loop;
else
@@ -684,7 +652,10 @@ package body WisiToken.Parse.LR.Parser is
-- 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
@@ -696,7 +667,13 @@ package body WisiToken.Parse.LR.Parser is
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
@@ -712,84 +689,75 @@ package body WisiToken.Parse.LR.Parser is
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
(Shared_Parser.Parsers.Count) & " '" &
+ 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 or not defined");
+ Trace.Put_Line ("recover disabled");
end if;
end if;
if Recover_Result = Success then
- declare
- Shift_Recover_Count : Integer := 0;
- begin
- for Parser_State of Shared_Parser.Parsers loop
- Parser_State.Resume_Active := True;
- Parser_State.Conflict_During_Resume := False;
+ 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;
+ 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;
- case Parser_State.Verb is
- when Shift_Recover =>
- Shift_Recover_Count := Shift_Recover_Count + 1;
-
- Parser_State.Zombie_Token_Count := 0;
-
- when Reduce =>
- Current_Verb := Reduce;
-
- Parser_State.Zombie_Token_Count := 0;
+ Parser_State.Zombie_Token_Count := 0;
- 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;
+ case Parser_State.Verb is
+ when Reduce =>
+ null;
- when Shift =>
- if Current_Verb /= Reduce then
- Current_Verb := Shift;
- end if;
+ 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 Pause | Accept_It =>
- raise SAL.Programmer_Error;
- end case;
- end loop;
+ when Shift =>
+ null;
- if Shift_Recover_Count > 0 then
- Current_Verb := Shift_Recover;
- end if;
- end;
+ when Pause | Accept_It =>
+ raise SAL.Programmer_Error;
+ end case;
+ end loop;
else
-- Terminate with error. Parser_State has all the required
info on
@@ -805,6 +773,12 @@ package body WisiToken.Parse.LR.Parser is
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;
@@ -816,11 +790,16 @@ package body WisiToken.Parse.LR.Parser is
loop
exit Action_Loop when Current_Parser.Is_Done;
- if Shared_Parser.Terminate_Same_State and
- Current_Verb in Shift | Shift_Recover and
+ -- 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.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;
@@ -828,10 +807,14 @@ package body WisiToken.Parse.LR.Parser is
exit Action_Loop 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));
+ 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
@@ -850,10 +833,12 @@ package body WisiToken.Parse.LR.Parser is
Current_Parser.Next;
else
- Shared_Parser.Parsers.Terminate_Parser (Current_Parser,
"zombie", Shared_Parser.Trace.all);
+ Shared_Parser.Parsers.Terminate_Parser
+ (Current_Parser, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
end if;
- elsif Current_Parser.Verb = Current_Verb then
+ 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;
@@ -895,11 +880,13 @@ package body WisiToken.Parse.LR.Parser is
if Max_Parser = Current_Parser then
Current_Parser.Next;
Shared_Parser.Parsers.Terminate_Parser
- (Current_Parser, "too many parsers; max error
repair cost", Trace);
+ (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);
+ (Max_Parser, "too many parsers; max error
repair cost", Trace,
+ Shared_Parser.Terminals);
end if;
end if;
end;
@@ -920,10 +907,16 @@ package body WisiToken.Parse.LR.Parser is
else
if Trace_Parse > Outline then
- Trace.Put_Line
- (Integer'Image (Current_Parser.Label) & ": spawn" &
- Integer'Image (Shared_Parser.Parsers.Last_Label +
1) & ", (" &
- Trimmed_Image (1 + Integer
(Shared_Parser.Parsers.Count)) & " active)");
+ 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);
@@ -947,37 +940,62 @@ package body WisiToken.Parse.LR.Parser is
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 =>
+ 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
- -- 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));
+ 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;
@@ -992,11 +1010,9 @@ package body WisiToken.Parse.LR.Parser is
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;
@@ -1005,33 +1021,34 @@ package body WisiToken.Parse.LR.Parser is
begin
if Parser.User_Data /= null then
- if (for some Par of Parser.Parsers =>
- (for some Err of Par.Errors => Any (Err.Recover.Ops, Delete)))
- then
- if Parser.Parsers.Count > 1 then
- raise Syntax_Error with "ambiguous parse with deleted tokens;
can't execute actions";
- end if;
- for Err of Parser.Parsers.First_State_Ref.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;
+ if Parser.Parsers.Count > 1 then
+ raise Syntax_Error with "ambiguous parse; can't execute actions";
end if;
- for Parser_State of Parser.Parsers loop
+ 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));
+ (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 loop;
+ end;
end if;
end Execute_Actions;
diff --git a/wisitoken-parse-lr-parser.ads b/wisitoken-parse-lr-parser.ads
index f5b7405..3324165 100644
--- a/wisitoken-parse-lr-parser.ads
+++ b/wisitoken-parse-lr-parser.ads
@@ -5,7 +5,7 @@
-- In a child package of Parser.LR partly for historical reasons,
-- partly to allow McKenzie_Recover to be in a sibling package.
--
--- Copyright (C) 2002, 2003, 2009, 2010, 2013-2015, 2017, 2018 Free Software
Foundation, Inc.
+-- Copyright (C) 2002, 2003, 2009, 2010, 2013-2015, 2017 - 2019 Free Software
Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -53,14 +53,19 @@ 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 function
- (Next_Token : in Token_ID;
- Config : in Configuration)
- return Boolean;
- -- Return True if using Minimal_Complete_Actions is appropriate.
+ 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).
--
-- For example, if Next_Token is a block end, return True to complete
- -- the current statement/declaration as quickly as possible..
+ -- the current statement/declaration as quickly as possible, and
+ -- Matching_Begin_Token to the corresponding block begin.
type Language_String_ID_Set_Access is access function
(Descriptor : in WisiToken.Descriptor;
@@ -131,8 +136,14 @@ package WisiToken.Parse.LR.Parser is
-- For errors where no recovery is possible, raises Parse_Error with
-- an appropriate error message.
+ overriding function Tree (Shared_Parser : in Parser) return
Syntax_Trees.Tree;
+ -- If there is one parser in Parsers, return its tree. Otherwise,
+ -- raise Parse_Error for an ambiguous parse.
+
overriding procedure Execute_Actions (Parser : in out LR.Parser.Parser);
- -- Execute the grammar actions in Parser.
+ -- Call User_Data.Reduce on all nonterms in the syntax tree, then
+ -- User_Data.Delete_Token on any tokens deleted by error recovery,
+ -- then the grammar semantic actions.
overriding function Any_Errors (Parser : in LR.Parser.Parser) return
Boolean;
-- Return True if any errors where encountered, recovered or not.
diff --git a/wisitoken-parse-lr-parser_lists.adb
b/wisitoken-parse-lr-parser_lists.adb
index b2ba8be..590af07 100644
--- a/wisitoken-parse-lr-parser_lists.adb
+++ b/wisitoken-parse-lr-parser_lists.adb
@@ -2,7 +2,7 @@
--
-- see spec
--
--- Copyright (C) 2014-2018 All Rights Reserved.
+-- Copyright (C) 2014 - 2019 All Rights Reserved.
--
-- The WisiToken package is free software; you can redistribute it
-- and/or modify it under terms of the GNU General Public License as
@@ -140,19 +140,24 @@ package body WisiToken.Parse.LR.Parser_Lists is
is begin
return Parser_State_Lists.Constant_Reference (Cursor.Ptr).Verb;
end Verb;
+
procedure Terminate_Parser
- (Parsers : in out List;
- Current : in out Cursor'Class;
- Message : in String;
- Trace : in out WisiToken.Trace'Class)
+ (Parsers : in out List;
+ Current : in out Cursor'Class;
+ Message : in String;
+ Trace : in out WisiToken.Trace'Class;
+ Terminals : in Base_Token_Arrays.Vector)
is
use all type SAL.Base_Peek_Type;
+ State : Parser_State renames Parser_State_Lists.Constant_Reference
(Current.Ptr).Element.all;
begin
if Trace_Parse > Outline then
Trace.Put_Line
(Integer'Image (Current.Label) & ": terminate (" &
Trimmed_Image (Integer (Parsers.Count) - 1) & " active)" &
- (if Message'Length > 0 then ": " & Message else ""));
+ ": " & Message & Image
+ (State.Tree.Min_Terminal_Index (State.Current_Token),
+ Terminals, Trace.Descriptor.all));
end if;
Current.Free;
@@ -163,9 +168,10 @@ package body WisiToken.Parse.LR.Parser_Lists is
end Terminate_Parser;
procedure Duplicate_State
- (Parsers : in out List;
- Current : in out Cursor'Class;
- Trace : in out WisiToken.Trace'Class)
+ (Parsers : in out List;
+ Current : in out Cursor'Class;
+ Trace : in out WisiToken.Trace'Class;
+ Terminals : in Base_Token_Arrays.Vector)
is
use all type SAL.Base_Peek_Type;
use all type Ada.Containers.Count_Type;
@@ -225,7 +231,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
-- terminated earlier.
if Other.Total_Recover_Cost = Current.Total_Recover_Cost then
if Other.Max_Recover_Ops_Length = Current.Max_Recover_Ops_Length
then
- Parsers.Terminate_Parser (Other, "duplicate state: random",
Trace);
+ Parsers.Terminate_Parser (Other, "duplicate state: random",
Trace, Terminals);
else
if Other.Max_Recover_Ops_Length >
Current.Max_Recover_Ops_Length then
null;
@@ -233,7 +239,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
Other := Cursor (Current);
Current.Next;
end if;
- Parsers.Terminate_Parser (Other, "duplicate state: ops length",
Trace);
+ Parsers.Terminate_Parser (Other, "duplicate state: ops length",
Trace, Terminals);
end if;
else
if Other.Total_Recover_Cost > Current.Total_Recover_Cost then
@@ -242,7 +248,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
Other := Cursor (Current);
Current.Next;
end if;
- Parsers.Terminate_Parser (Other, "duplicate state: cost", Trace);
+ Parsers.Terminate_Parser (Other, "duplicate state: cost", Trace,
Terminals);
end if;
end if;
end Duplicate_State;
@@ -290,6 +296,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
New_Item :=
(Shared_Token => Item.Shared_Token,
Recover_Insert_Delete => Item.Recover_Insert_Delete,
+ Prev_Deleted => Item.Prev_Deleted,
Current_Token => Item.Current_Token,
Inc_Shared_Token => Item.Inc_Shared_Token,
Stack => Item.Stack,
diff --git a/wisitoken-parse-lr-parser_lists.ads
b/wisitoken-parse-lr-parser_lists.ads
index dcaa268..0dae578 100644
--- a/wisitoken-parse-lr-parser_lists.ads
+++ b/wisitoken-parse-lr-parser_lists.ads
@@ -2,7 +2,7 @@
--
-- Generalized LR parser state.
--
--- Copyright (C) 2014-2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2014-2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -60,6 +60,11 @@ package WisiToken.Parse.LR.Parser_Lists is
Recover_Insert_Delete : Config_Op_Queues.Queue;
-- Tokens in that were inserted during error recovery, or should be
-- deleted/skipped when read. Contains only Insert and Delete ops.
+ -- Used/emptied by main parse.
+
+ Prev_Deleted : Recover_Token_Index_Arrays.Vector;
+ -- Tokens deleted by previous error recovery; don't process in new
+ -- error recovery.
Current_Token : Syntax_Trees.Node_Index :=
Syntax_Trees.Invalid_Node_Index;
-- Current terminal, in Tree
@@ -131,19 +136,25 @@ package WisiToken.Parse.LR.Parser_Lists is
function Verb (Cursor : in Parser_Lists.Cursor) return
All_Parse_Action_Verbs;
procedure Terminate_Parser
- (Parsers : in out List;
- Current : in out Cursor'Class;
- Message : in String;
- Trace : in out WisiToken.Trace'Class);
+ (Parsers : in out List;
+ Current : in out Cursor'Class;
+ Message : in String;
+ Trace : in out WisiToken.Trace'Class;
+ Terminals : in Base_Token_Arrays.Vector);
-- Terminate Current. Current is set to no element.
+ --
+ -- Terminals is used to report the current token in the message.
procedure Duplicate_State
- (Parsers : in out List;
- Current : in out Cursor'Class;
- Trace : in out WisiToken.Trace'Class);
+ (Parsers : in out List;
+ Current : in out Cursor'Class;
+ Trace : in out WisiToken.Trace'Class;
+ Terminals : in Base_Token_Arrays.Vector);
-- If any other parser in Parsers has a stack equivalent to Current,
-- Terminate one of them. Current is either unchanged, or advanced to
-- the next parser.
+ --
+ -- Terminals is used to report the current token in the message.
type State_Reference (Element : not null access Parser_State) is null record
with Implicit_Dereference => Element;
@@ -212,11 +223,13 @@ package WisiToken.Parse.LR.Parser_Lists is
(Container : aliased in List'Class;
Position : in Parser_Node_Access)
return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
function Reference
(Container : aliased in out List'Class;
Position : in Parser_Node_Access)
return State_Reference;
+ pragma Inline (Reference);
function Persistent_State_Ref (Position : in Parser_Node_Access) return
State_Access;
diff --git a/wisitoken-parse-lr-parser_no_recover.adb
b/wisitoken-parse-lr-parser_no_recover.adb
index 48d9e4f..d8ce31e 100644
--- a/wisitoken-parse-lr-parser_no_recover.adb
+++ b/wisitoken-parse-lr-parser_no_recover.adb
@@ -1,491 +1,511 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2002 - 2005, 2008 - 2015, 2017, 2018 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 | Shift_Recover =>
- -- 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);
- end if;
- else
- Check_Parser.Next;
- end if;
- end Check_Error;
-
- begin
- -- The user must call Lexer.Reset_* to set the input text.
- Shared_Parser.Lex_All;
-
- if Shared_Parser.User_Data /= null then
- Shared_Parser.User_Data.Reset;
- end if;
- 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 | Shift_Recover =>
- -- 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);
- -- 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 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
- for Parser_State of Parser.Parsers loop
- Parser_State.Tree.Process_Tree (Process_Node'Access);
- end loop;
- end if;
- end Execute_Actions;
-
- 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);
+
+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;
diff --git a/wisitoken-parse-lr-parser_no_recover.ads
b/wisitoken-parse-lr-parser_no_recover.ads
index 1f91e3d..33665d7 100644
--- a/wisitoken-parse-lr-parser_no_recover.ads
+++ b/wisitoken-parse-lr-parser_no_recover.ads
@@ -6,7 +6,7 @@
-- to not depend on wisitoken-lr-mckenzie_recover, so editing that
-- does not cause everything to be regenerated/compiled.
--
--- Copyright (C) 2002, 2003, 2009, 2010, 2013-2015, 2017, 2018 Free Software
Foundation, Inc.
+-- Copyright (C) 2002, 2003, 2009, 2010, 2013 - 2015, 2017 - 2019 Free
Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -71,6 +71,8 @@ package WisiToken.Parse.LR.Parser_No_Recover is
-- For other errors, raises Parse_Error with an appropriate error
-- message.
+ overriding function Tree (Parser : in LR.Parser_No_Recover.Parser) return
Syntax_Trees.Tree;
+
overriding function Any_Errors (Parser : in LR.Parser_No_Recover.Parser)
return Boolean;
overriding procedure Put_Errors (Parser : in LR.Parser_No_Recover.Parser);
diff --git a/wisitoken-parse-lr.adb b/wisitoken-parse-lr.adb
index 74dcb98..79f4f2e 100644
--- a/wisitoken-parse-lr.adb
+++ b/wisitoken-parse-lr.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2013-2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2013-2015, 2017, 2018, 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -29,7 +29,9 @@ 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
----------
@@ -59,16 +61,17 @@ package body WisiToken.Parse.LR is
begin
case Item.Verb is
when Shift =>
- Trace.Put ("shift and goto state" & State_Index'Image (Item.State));
+ 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));
+ Image (Item.Production.LHS, Trace.Descriptor.all),
+ Prefix => False);
when Accept_It =>
- Trace.Put ("accept it");
+ Trace.Put ("accept it", Prefix => False);
when Error =>
- Trace.Put ("ERROR");
+ Trace.Put ("ERROR", Prefix => False);
end case;
end Put;
@@ -137,37 +140,11 @@ package body WisiToken.Parse.LR is
return List.Next;
end Next;
- function Compare_Minimal_Action (Left, Right : in Minimal_Action) return
SAL.Compare_Result
- is begin
- if Left.Verb > Right.Verb then
- return SAL.Greater;
- elsif Left.Verb < Right.Verb then
- return SAL.Less;
- else
- case Left.Verb is
- when Shift =>
- if Left.ID > Right.ID then
- return SAL.Greater;
- elsif Left.ID < Right.ID then
- return SAL.Less;
- else
- return SAL.Equal;
- end if;
- when Reduce =>
- if Left.Nonterm > Right.Nonterm then
- return SAL.Greater;
- elsif Left.Nonterm < Right.Nonterm then
- return SAL.Less;
- else
- return SAL.Equal;
- end if;
- end case;
- end if;
- end Compare_Minimal_Action;
-
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 =>
@@ -176,13 +153,6 @@ package body WisiToken.Parse.LR is
end case;
end Strict_Image;
- procedure Set_Minimal_Action (List : out Minimal_Action_Lists.List; Actions
: in Minimal_Action_Array)
- is begin
- for Action of Actions loop
- List.Insert (Action);
- end loop;
- end Set_Minimal_Action;
-
function First (State : in Parse_State) return Action_List_Iterator
is begin
return Iter : Action_List_Iterator := (Node => State.Action_List, Item
=> null) do
@@ -552,66 +522,103 @@ package body WisiToken.Parse.LR is
return Parse_Table_Ptr
is
use Ada.Text_IO;
- use Ada.Strings.Unbounded;
- File : File_Type;
- Line : Unbounded_String;
- First : Integer;
- Last : Integer := 0;
+ 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 (" ;");
+ Delimiters : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set (" ;" & ASCII.LF);
- function Last_Char return Character
+ function Check_Semicolon return Boolean
is begin
- if Last = 0 then
- return Element (Line, Last + 1);
+ 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 Element (Line, Last);
+ return False;
end if;
- end Last_Char;
+ end Check_Semicolon;
- procedure Skip_Char
+ procedure Check_Semicolon
is begin
- if Last > 0 then
- Last := Last + 1;
- if Last > Length (Line) then
- Last := 0;
- end if;
- end if;
- if Last = 0 then
- Line := +Get_Line (File);
- Last := -1 + Index_Non_Blank (Line);
+ 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 Skip_Char;
+ end Check_Semicolon;
- function Next_Value return String
+ function Check_EOI return Boolean
is begin
- First := Last + 1;
- Last := Index (Line, Delimiters, First);
- return Result : constant String := Slice (Line, First, (if Last = 0
then Length (Line) else Last - 1))
- do
- if Last = 0 then
- Line := +Get_Line (File);
- Last := -1 + Index_Non_Blank (Line);
+ 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;
- end return;
+ 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
- Val : constant String := Next_Value;
+ Region : constant Buffer_Region := Next_Value;
begin
- return Value_Type'Value (Val);
+ return Value_Type'Value (Buffer (Region.First .. Region.Last));
exception
when Constraint_Error =>
- raise SAL.Programmer_Error with Error_Message
- (File_Name, Line_Number_Type (Ada.Text_IO.Line (File) - 1),
Ada.Text_IO.Count (First),
- "expecting " & Name & ", found '" & Val & "'");
+ 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");
@@ -621,8 +628,10 @@ package body WisiToken.Parse.LR is
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
- Open (File, In_File, File_Name);
- Line := +Get_Line (File);
+ 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
@@ -637,6 +646,8 @@ package body WisiToken.Parse.LR is
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
@@ -646,6 +657,7 @@ package body WisiToken.Parse.LR is
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;
@@ -691,8 +703,7 @@ package body WisiToken.Parse.LR is
Actions_Done := True;
end case;
- if Element (Line, Last) = ';' then
- Skip_Char;
+ if Check_Semicolon then
Action_Done := True;
if not Actions_Done then
@@ -705,6 +716,8 @@ package body WisiToken.Parse.LR is
Node_J.Next := new Parse_Action_Node;
Node_J := Node_J.Next;
end loop;
+
+ Check_New_Line;
end;
exit when Actions_Done;
@@ -713,9 +726,9 @@ package body WisiToken.Parse.LR is
end loop;
end;
- if Element (Line, 1) = ';' then
+ if Check_Semicolon then
-- No Gotos
- Skip_Char;
+ null;
else
declare
Node_I : Goto_Node_Ptr := new Goto_Node;
@@ -724,46 +737,44 @@ package body WisiToken.Parse.LR is
loop
Node_I.Symbol := Next_Token_ID;
Node_I.State := Next_State_Index;
- exit when Element (Line, Last) = ';';
+ exit when Check_Semicolon;
Node_I.Next := new Goto_Node;
Node_I := Node_I.Next;
end loop;
- Skip_Char;
end;
end if;
+ Check_New_Line;
- declare
- Verb : Minimal_Verbs;
- ID : Token_ID;
- Action_State : State_Index;
- Count : Ada.Containers.Count_Type;
- begin
- loop
- if Last_Char = ';' then
- Skip_Char;
- exit;
- end if;
-
- Verb := Next_Parse_Action_Verbs;
+ 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_Actions.Insert ((Shift, ID,
Action_State));
+ State.Minimal_Complete_Action := (Shift, ID,
Action_State);
when Reduce =>
ID := Next_Token_ID;
Count := Next_Count_Type;
- State.Minimal_Complete_Actions.Insert ((Reduce, ID,
Count));
+ State.Minimal_Complete_Action := (Reduce, ID, Count);
end case;
- end loop;
- end;
- -- loop exits on End_Error
+ end;
+ Check_Semicolon;
+ end if;
+ Check_New_Line;
+
+ exit when Check_EOI;
end loop;
- -- real return value in End_Error handler; this satisfies the
compiler
- return null;
- exception
- when End_Error =>
- Close (File);
return Table;
end;
exception
@@ -771,16 +782,11 @@ package body WisiToken.Parse.LR is
raise User_Error with "parser table text file '" & File_Name & "' not
found.";
when SAL.Programmer_Error =>
- if Is_Open (File) then
- Close (File);
- end if;
raise;
+
when E : others =>
- if Is_Open (File) then
- Close (File);
- end if;
raise SAL.Programmer_Error with Error_Message
- (File_Name, Line_Number_Type (Ada.Text_IO.Line (File) - 1),
Ada.Text_IO.Count (First),
+ (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
end Get_Text_Rep;
@@ -834,6 +840,18 @@ package body WisiToken.Parse.LR is
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;
diff --git a/wisitoken-parse-lr.ads b/wisitoken-parse-lr.ads
index 6c9db82..24ca512 100644
--- a/wisitoken-parse-lr.ads
+++ b/wisitoken-parse-lr.ads
@@ -9,7 +9,7 @@
--
-- See wisitoken.ads
--
--- Copyright (C) 2002, 2003, 2009, 2010, 2013-2015, 2017 - 2018 Free Software
Foundation, Inc.
+-- Copyright (C) 2002, 2003, 2009, 2010, 2013 - 2015, 2017 - 2019 Free
Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -36,9 +36,9 @@ pragma License (Modified_GPL);
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Unchecked_Deallocation;
-with SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted;
+with SAL.Gen_Array_Image;
with SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux;
-with SAL.Gen_Definite_Doubly_Linked_Lists_Sorted.Gen_Image;
+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;
@@ -48,10 +48,10 @@ with WisiToken.Semantic_Checks;
with WisiToken.Syntax_Trees;
package WisiToken.Parse.LR is
- type All_Parse_Action_Verbs is (Pause, Shift_Recover, Shift, Reduce,
Accept_It, Error);
+ 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, Shift_Recover are only used for error recovery.
+ 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
@@ -79,7 +79,7 @@ package WisiToken.Parse.LR is
-- 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.
+ -- 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.
@@ -116,8 +116,12 @@ package WisiToken.Parse.LR is
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 := Shift) is record
+ 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;
@@ -128,29 +132,18 @@ package WisiToken.Parse.LR is
end case;
end record;
- function Compare_Minimal_Action (Left, Right : in Minimal_Action) return
SAL.Compare_Result;
-
- type Minimal_Action_Array is array (Positive range <>) of Minimal_Action;
-
- package Minimal_Action_Lists is new
SAL.Gen_Definite_Doubly_Linked_Lists_Sorted
- (Minimal_Action, Compare_Minimal_Action);
-
function Strict_Image (Item : in Minimal_Action) return String;
-- Strict Ada aggregate syntax, for generated code.
- function Image is new Minimal_Action_Lists.Gen_Image (Strict_Image);
-
- procedure Set_Minimal_Action (List : out Minimal_Action_Lists.List; Actions
: in Minimal_Action_Array);
-
type Parse_State is record
Productions : Production_ID_Arrays.Vector;
- -- Used in error recovery.
+ -- Used in some language-specfic error recovery.
Action_List : Action_Node_Ptr;
Goto_List : Goto_Node_Ptr;
- Minimal_Complete_Actions : Minimal_Action_Lists.List;
- -- Set of parse actions that will most quickly complete the
- -- productions in this state; used in error recovery
+ 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;
@@ -331,8 +324,9 @@ package WisiToken.Parse.LR is
McKenzie_Param : in McKenzie_Param_Type;
Productions : in WisiToken.Productions.Prod_Arrays.Vector)
return Parse_Table_Ptr;
- -- Read machine-readable text format of states from a file File_Name.
- -- Result has actions, checks from Productions.
+ -- 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
@@ -496,6 +490,11 @@ package WisiToken.Parse.LR is
-- 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
@@ -548,6 +547,9 @@ package WisiToken.Parse.LR is
-- 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;
@@ -573,9 +575,11 @@ package WisiToken.Parse.LR is
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
diff --git a/wisitoken-parse-packrat-generated.adb
b/wisitoken-parse-packrat-generated.adb
index 0e1adb0..0c909e5 100644
--- a/wisitoken-parse-packrat-generated.adb
+++ b/wisitoken-parse-packrat-generated.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
@@ -21,7 +21,7 @@ package body WisiToken.Parse.Packrat.Generated is
overriding procedure Parse (Parser : aliased in out Generated.Parser)
is
- -- 'aliased required for Base_Tree'Access. WORKAROUND: that was
+ -- 'aliased' required for Base_Tree'Access. WORKAROUND: that was
-- enough when Parser type was declared in generated Main; now that
-- it's a derived type, it doesn't work. So we use Unchecked_Access.
@@ -63,6 +63,11 @@ package body WisiToken.Parse.Packrat.Generated is
end Parse;
+ overriding function Tree (Parser : in Generated.Parser) return
Syntax_Trees.Tree
+ is begin
+ return Parser.Tree;
+ end Tree;
+
overriding function Any_Errors (Parser : in Generated.Parser) return Boolean
is
use all type Ada.Containers.Count_Type;
diff --git a/wisitoken-parse-packrat-generated.ads
b/wisitoken-parse-packrat-generated.ads
index 80d6cee..2eddd56 100644
--- a/wisitoken-parse-packrat-generated.ads
+++ b/wisitoken-parse-packrat-generated.ads
@@ -7,7 +7,7 @@
--
-- see 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
@@ -46,12 +46,14 @@ package WisiToken.Parse.Packrat.Generated is
end case;
end record;
- package Memos is new SAL.Gen_Unbounded_Definite_Vectors (Token_Index,
Memo_Entry);
+ package Memos is new SAL.Gen_Unbounded_Definite_Vectors
+ (Token_Index, Memo_Entry, Default_Element => (others => <>));
subtype Result_Type is Memo_Entry
with Dynamic_Predicate => Result_Type.State in Result_States;
- package Derivs is new SAL.Gen_Unbounded_Definite_Vectors (Token_ID,
Memos.Vector);
+ package Derivs is new SAL.Gen_Unbounded_Definite_Vectors
+ (Token_ID, Memos.Vector, Default_Element => Memos.Empty_Vector);
type Parse_WisiToken_Accept is access
-- WORKAROUND: using Packrat.Parser'Class here hits a GNAT Bug box in
GPL 2018.
@@ -64,6 +66,7 @@ package WisiToken.Parse.Packrat.Generated is
end record;
overriding procedure Parse (Parser : aliased in out Generated.Parser);
+ overriding function Tree (Parser : in Generated.Parser) return
Syntax_Trees.Tree;
overriding function Any_Errors (Parser : in Generated.Parser) return
Boolean;
overriding procedure Put_Errors (Parser : in Generated.Parser);
diff --git a/wisitoken-parse-packrat-procedural.adb
b/wisitoken-parse-packrat-procedural.adb
index 1e5024c..5dc4ef1 100644
--- a/wisitoken-parse-packrat-procedural.adb
+++ b/wisitoken-parse-packrat-procedural.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
@@ -248,4 +248,9 @@ package body WisiToken.Parse.Packrat.Procedural is
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 ecd14de..76c1aee 100644
--- a/wisitoken-parse-packrat-procedural.ads
+++ b/wisitoken-parse-packrat-procedural.ads
@@ -9,7 +9,7 @@
--
-- See 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
@@ -49,7 +49,8 @@ package WisiToken.Parse.Packrat.Procedural is
end case;
end record;
- package Memos is new SAL.Gen_Unbounded_Definite_Vectors (Token_Index,
Memo_Entry);
+ 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
@@ -70,6 +71,8 @@ package WisiToken.Parse.Packrat.Procedural is
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.
diff --git a/wisitoken-parse.adb b/wisitoken-parse.adb
index 52870e0..09280d9 100644
--- a/wisitoken-parse.adb
+++ b/wisitoken-parse.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
@@ -42,7 +42,7 @@ package body WisiToken.Parse is
Parser.Line_Begin_Token (Token.Line) :=
Parser.Terminals.Last_Index +
(if Token.ID >= Parser.Trace.Descriptor.First_Terminal then 1
else 0);
- elsif Token.ID = Parser.Trace.Descriptor.EOF_ID then
+ elsif Token.ID = Parser.Trace.Descriptor.EOI_ID then
Parser.Line_Begin_Token.Set_Length (Ada.Containers.Count_Type
(Token.Line + 1));
Parser.Line_Begin_Token (Token.Line + 1) :=
Parser.Terminals.Last_Index + 1;
end if;
@@ -71,7 +71,7 @@ package body WisiToken.Parse is
procedure Lex_All (Parser : in out Base_Parser)
is
- EOF_ID : constant Token_ID := Parser.Trace.Descriptor.EOF_ID;
+ EOF_ID : constant Token_ID := Parser.Trace.Descriptor.EOI_ID;
begin
Parser.Lexer.Errors.Clear;
Parser.Terminals.Clear;
diff --git a/wisitoken-parse.ads b/wisitoken-parse.ads
index 38574ed..c2fb500 100644
--- a/wisitoken-parse.ads
+++ b/wisitoken-parse.ads
@@ -2,7 +2,7 @@
--
-- Subprograms common to more than one parser, higher-level than in
wisitoken.ads
--
--- 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
@@ -44,7 +44,7 @@ package WisiToken.Parse is
--
-- The user must first call Lexer.Reset_* to set the input text.
- procedure Parse (Shared_Parser : aliased in out Base_Parser) is abstract;
+ procedure Parse (Parser : aliased in out Base_Parser) is abstract;
-- Call Lex_All, then execute parse algorithm to parse the tokens,
-- storing the result in Parser for Execute_Actions.
--
@@ -55,6 +55,9 @@ package WisiToken.Parse is
-- For other errors, raises Parse_Error with an appropriate error
-- message.
+ function Tree (Parser : in Base_Parser) return Syntax_Trees.Tree is
abstract;
+ -- Return the syntax tree resulting from the parse.
+
function Any_Errors (Parser : in Base_Parser) return Boolean is abstract;
procedure Put_Errors (Parser : in Base_Parser) is abstract;
diff --git a/wisitoken-parse_table-mode.el b/wisitoken-parse_table-mode.el
new file mode 100644
index 0000000..5cce27a
--- /dev/null
+++ b/wisitoken-parse_table-mode.el
@@ -0,0 +1,96 @@
+;; wisitoken-parse_table-mode.el --- For navigating in a parse table as output
by wisitoken-bnf-generate. -*- lexical-binding:t -*-
+;;
+;; Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
+;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
+;; Keywords: parser
+;; Version: 1.0
+;; package-requires: ((emacs "25.1"))
+;; URL: http://www.nongnu.org/ada-mode/wisi/wisi.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/>.
+
+(require 'xref)
+
+(defun wisitoken-parse_table--xref-backend () 'wisitoken-parse_table)
+
+(cl-defgeneric xref-backend-identifier-completion-table ((_backend (eql
wisitoken-parse_table)))
+ ;; could complete on nonterms, find productions
+ nil)
+
+(cl-defmethod xref-backend-identifier-at-point ((_backend (eql
wisitoken-parse_table)))
+ ;; if we are on one of:
+ ;; - ’goto state nnn’ in a state action
+ ;; => return nnn state
+ ;;
+ ;; or
+ ;; - foo <= bar baz
+ ;; => return nonterminal name at point
+ ;;
+ ;; - 'reduce n tokens to <nonterminal> <prod_id>'
+ ;; => return 'prod_id: name'
+ (save-excursion
+ (cond
+ ((save-excursion
+ (end-of-line)
+ (or (looking-back "goto state \\([0-9]+\\),?" (line-beginning-position))
+ (looking-back "( \\([0-9]+\\))" (line-beginning-position))))
+ (match-string 1))
+
+ ((save-excursion
+ (back-to-indentation)
+ (looking-at "[a-zA-Z_]+ + => reduce [0-9]+ tokens to \\([a-z0-9_]+\\)
\\([0-9.]+\\)"))
+ (concat (match-string 2) ": " (match-string 1)))
+
+ (t
+ (thing-at-point 'symbol)))))
+
+(cl-defgeneric xref-backend-definitions ((_backend (eql
wisitoken-parse_table)) identifier)
+ ;; IDENTIFIER is from xref-back-identifier-at-point; a state number or a
nonterminal
+ (let ((state-p (string-match "\\`[0-9]+\\'" identifier))
+ (prod_id-p (string-match "\\`[0-9.]+: " identifier)))
+ (save-excursion
+ (goto-char (point-min))
+ (cond
+ (state-p
+ (search-forward-regexp (concat "^State " identifier ":$")))
+
+ (prod_id-p
+ (search-forward-regexp (concat identifier " <=")))
+
+ (t
+ (search-forward-regexp (concat "^[0-9.]+: " identifier " <=")))
+ )
+ (list (xref-make identifier (xref-make-buffer-location (current-buffer)
(match-beginning 0))))
+ )))
+
+;;;###autoload
+(define-minor-mode wisitoken-parse_table-mode
+ "Provides navigation in wisi-generate parse table output."
+ nil ":parse_table" nil
+ (add-hook 'xref-backend-functions #'wisitoken-parse_table--xref-backend nil
t)
+
+ (if wisitoken-parse_table-mode
+ (read-only-mode 0)
+ (read-only-mode 1)
+ ))
+
+;;;###autoload
+(add-to-list 'auto-mode-alist '("\\.parse_table.*\\'" .
wisitoken-parse_table-mode))
+
+(provide 'wisitoken-parse_table-mode)
+;; end of file
diff --git a/wisitoken-productions.ads b/wisitoken-productions.ads
index 0ae651e..854b302 100644
--- a/wisitoken-productions.ads
+++ b/wisitoken-productions.ads
@@ -2,7 +2,7 @@
--
-- Type and operations for building grammar productions.
--
--- Copyright (C) 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -31,14 +31,16 @@ package WisiToken.Productions is
Check : WisiToken.Semantic_Checks.Semantic_Check;
end record;
- package RHS_Arrays is new SAL.Gen_Unbounded_Definite_Vectors (Natural,
Right_Hand_Side);
+ package RHS_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Natural, Right_Hand_Side, Default_Element => (others => <>));
type Instance is record
LHS : Token_ID := Invalid_Token_ID;
RHSs : RHS_Arrays.Vector;
end record;
- package Prod_Arrays is new SAL.Gen_Unbounded_Definite_Vectors (Token_ID,
Instance);
+ package Prod_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Token_ID, Instance, Default_Element => (others => <>));
function Image
(LHS : in Token_ID;
@@ -51,14 +53,16 @@ package WisiToken.Productions is
procedure Put (Grammar : Prod_Arrays.Vector; Descriptor : in
WisiToken.Descriptor);
-- Put Image of each production to Ada.Text_IO.Current_Output.
- package Line_Number_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(Natural, WisiToken.Line_Number_Type);
+ package Line_Number_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (Natural, Line_Number_Type, Default_Element => Invalid_Line_Number);
type Prod_Source_Line_Map is record
- Line : Line_Number_Type;
+ Line : Line_Number_Type := Invalid_Line_Number;
RHS_Map : Line_Number_Arrays.Vector;
end record;
- package Source_Line_Maps is new SAL.Gen_Unbounded_Definite_Vectors
(Token_ID, Prod_Source_Line_Map);
+ package Source_Line_Maps is new SAL.Gen_Unbounded_Definite_Vectors
+ (Token_ID, Prod_Source_Line_Map, Default_Element => (others => <>));
-- For line numbers of productions in source files.
end WisiToken.Productions;
diff --git a/wisitoken-semantic_checks.adb b/wisitoken-semantic_checks.adb
index e90fb59..26dcb49 100644
--- a/wisitoken-semantic_checks.adb
+++ b/wisitoken-semantic_checks.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -132,4 +132,21 @@ package body WisiToken.Semantic_Checks is
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 5fb5807..acb0ce8 100644
--- a/wisitoken-semantic_checks.ads
+++ b/wisitoken-semantic_checks.ads
@@ -2,7 +2,7 @@
--
-- Grammar semantic check routines.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- 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
@@ -45,9 +45,10 @@ package WisiToken.Semantic_Checks is
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)
+ (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.
@@ -86,4 +87,13 @@ package WisiToken.Semantic_Checks is
-- 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 fa6602c..ac780a3 100644
--- a/wisitoken-syntax_trees.adb
+++ b/wisitoken-syntax_trees.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
@@ -33,9 +33,12 @@ package body WisiToken.Syntax_Trees is
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)
@@ -355,12 +358,78 @@ package body WisiToken.Syntax_Trees is
end if;
end Process;
- Junk : constant Boolean := Process_Tree (Tree, Node, Process'Access);
+ 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;
@@ -791,6 +860,7 @@ package body WisiToken.Syntax_Trees is
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)
@@ -799,15 +869,25 @@ package body WisiToken.Syntax_Trees is
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, Process_Node) then
+ if not Process_Tree (Tree, Child, Visit_Parent, Process_Node)
then
return False;
end if;
end loop;
end if;
- return Process_Node (Tree, Node);
+ 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
@@ -915,6 +995,7 @@ package body WisiToken.Syntax_Trees is
else
Tree.Branched_Nodes (Node).Augmented := Value;
end if;
+ Tree.Shared_Tree.Augmented_Present := True;
end Set_Augmented;
procedure Set_Children
diff --git a/wisitoken-syntax_trees.ads b/wisitoken-syntax_trees.ads
index b9cf380..d5cbec1 100644
--- a/wisitoken-syntax_trees.ads
+++ b/wisitoken-syntax_trees.ads
@@ -7,7 +7,7 @@
-- 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 Free Software Foundation, Inc.
+-- 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.
@@ -58,7 +58,8 @@ package WisiToken.Syntax_Trees is
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);
+ 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);
@@ -88,12 +89,12 @@ package WisiToken.Syntax_Trees is
-- input stream.
procedure Delete_Token
- (Data : in out User_Data_Type;
+ (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 as needed. Called from Execute_Actions for each
- -- deleted token, before processing the syntax tree.
+ -- 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;
@@ -264,7 +265,7 @@ package WisiToken.Syntax_Trees is
ID : in Token_ID)
return Node_Index
with Pre => Tree.Is_Nonterm (Node);
- -- Return the child of Node that contains ID, or Invalid_Node_Index if
+ -- Return the child of Node whose ID is ID, or Invalid_Node_Index if
-- none match.
function Find_Descendant
@@ -272,7 +273,25 @@ package WisiToken.Syntax_Trees is
Node : in Valid_Node_Index;
ID : in Token_ID)
return Node_Index;
- -- Return the child of Node that contains ID (may be Node), or
+ -- 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);
@@ -372,7 +391,8 @@ private
subtype Nonterm_Node is Node (Nonterm);
- package Node_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(Valid_Node_Index, Node);
+ 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;
diff --git a/wisitoken-text_io_trace.adb b/wisitoken-text_io_trace.adb
index daa9f4c..77fb331 100644
--- a/wisitoken-text_io_trace.adb
+++ b/wisitoken-text_io_trace.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2017 Free Software Foundation, Inc.
+-- 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
@@ -17,30 +17,65 @@
pragma License (Modified_GPL);
+with Ada.Calendar.Formatting;
+with Ada.Strings.Fixed;
package body WisiToken.Text_IO_Trace is
+ function Insert_Prefix_At_Newlines (Trace : in Text_IO_Trace.Trace; Item :
in String) return String
+ is
+ use Ada.Strings.Fixed;
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String;
+ First : Integer := Item'First;
+ Last : Integer;
+ begin
+ loop
+ Last := Index (Pattern => "" & ASCII.LF, Source => Item (First ..
Item'Last));
+ exit when Last = 0;
+ Result := Result & Item (First .. Last) & Trace.Prefix;
+ First := Last + 1;
+ end loop;
+ Result := Result & Item (First .. Item'Last);
+ return -Result;
+ end Insert_Prefix_At_Newlines;
+
+ ----------
+ -- Public subprograms, declaration order
+
overriding
- procedure Put (Trace : in out Text_IO_Trace.Trace; Item : in String)
+ procedure Set_Prefix (Trace : in out Text_IO_Trace.Trace; Prefix : in
String)
+ is begin
+ Trace.Prefix := +Prefix;
+ end Set_Prefix;
+
+ overriding
+ procedure Put (Trace : in out Text_IO_Trace.Trace; Item : in String; Prefix
: in Boolean := True)
is
use Ada.Text_IO;
begin
if Trace.File /= null and then Is_Open (Trace.File.all) then
- Ada.Text_IO.Put (Trace.File.all, Item);
+ Ada.Text_IO.Put (Trace.File.all, (if Prefix then -Trace.Prefix else
"") & Item);
else
- Ada.Text_IO.Put (Item);
+ Ada.Text_IO.Put ((if Prefix then -Trace.Prefix else "") & Item);
end if;
end Put;
overriding
procedure Put_Line (Trace : in out Text_IO_Trace.Trace; Item : in String)
is
+ use Ada.Strings.Fixed;
use Ada.Text_IO;
+ Temp : constant String :=
+ (if 0 /= Index (Item, "" & ASCII.LF)
+ then Insert_Prefix_At_Newlines (Trace, Item)
+ else Item);
begin
+
if Trace.File /= null and then Is_Open (Trace.File.all) then
- Ada.Text_IO.Put_Line (Trace.File.all, Item);
+ Ada.Text_IO.Put_Line (Trace.File.all, -Trace.Prefix & Temp);
Ada.Text_IO.Flush (Trace.File.all);
else
- Ada.Text_IO.Put_Line (Item);
+ Ada.Text_IO.Put_Line (-Trace.Prefix & Temp);
Ada.Text_IO.Flush;
end if;
end Put_Line;
@@ -57,6 +92,14 @@ package body WisiToken.Text_IO_Trace is
end if;
end New_Line;
+ overriding
+ procedure Put_Clock (Trace : in out Text_IO_Trace.Trace; Label : in String)
+ is begin
+ Trace.Put_Line
+ (Ada.Calendar.Formatting.Image
+ (Ada.Calendar.Clock, Include_Time_Fraction => True) & " " & Label);
+ end Put_Clock;
+
procedure Set_File (Trace : in out Text_IO_Trace.Trace; File : in
Ada.Text_IO.File_Access)
is begin
Trace.File := File;
diff --git a/wisitoken-text_io_trace.ads b/wisitoken-text_io_trace.ads
index ad421dd..c6892c8 100644
--- a/wisitoken-text_io_trace.ads
+++ b/wisitoken-text_io_trace.ads
@@ -2,7 +2,7 @@
--
-- Trace output to Ada.Text_IO
--
--- Copyright (C) 2017 Free Software Foundation, Inc.
+-- 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
@@ -24,7 +24,10 @@ package WisiToken.Text_IO_Trace is
-- Defaults to Ada.Text_IO.Standard_Output
overriding
- procedure Put (Trace : in out Text_IO_Trace.Trace; Item : in String);
+ procedure Set_Prefix (Trace : in out Text_IO_Trace.Trace; Prefix : in
String);
+
+ overriding
+ procedure Put (Trace : in out Text_IO_Trace.Trace; Item : in String; Prefix
: in Boolean := True);
overriding
procedure Put_Line (Trace : in out Text_IO_Trace.Trace; Item : in String);
@@ -32,6 +35,9 @@ package WisiToken.Text_IO_Trace is
overriding
procedure New_Line (Trace : in out Text_IO_Trace.Trace);
+ overriding
+ procedure Put_Clock (Trace : in out Text_IO_Trace.Trace; Label : in String);
+
procedure Set_File (Trace : in out Text_IO_Trace.Trace; File : in
Ada.Text_IO.File_Access);
-- Set file for trace output. Default is Text_IO.Current_Output.
@@ -40,6 +46,7 @@ package WisiToken.Text_IO_Trace is
private
type Trace is limited new WisiToken.Trace with record
- File : Ada.Text_IO.File_Access;
+ File : Ada.Text_IO.File_Access;
+ Prefix : Ada.Strings.Unbounded.Unbounded_String;
end record;
end WisiToken.Text_IO_Trace;
diff --git a/wisitoken-user_guide.info b/wisitoken-user_guide.info
index 4d2bb1d..6d04498 100644
--- a/wisitoken-user_guide.info
+++ b/wisitoken-user_guide.info
@@ -415,8 +415,8 @@ File: wisitoken-user_guide.info, Node: Other declarations,
Prev: Error recover
'wisi-face-apply' actions must be declared, so the elisp and Ada
code aggree on what they mean.
-'%elisp_indent <name>'
- Declare a name for an elisp indent variable.
+'%elisp_indent <elisp name> <Ada name>'
+ Declare elisp and Ada names for an indent variable.
When generating Ada code for Emacs, the elisp indent variables used
in 'wisi-indent' actions must be declared, so the elisp and Ada
@@ -487,11 +487,9 @@ File: wisitoken-user_guide.info, Node: Other
declarations, Prev: Error recover
'%start'
The start token for the grammar.
-'regexp_name <name>'
- Declare a named regular expression. The name may then occur in
- another regular expression.
-
- The re2c lexer supports this usage; other lexers may not.
+'re2c_regexp <name> <value>'
+ Declare a named regular expression with re2c name and syntax. The
+ name may then occur in another re2c regular expression.
File: wisitoken-user_guide.info, Node: Nonterminals, Next: Conditional code,
Prev: Declarations, Up: Grammar File Syntax
@@ -550,7 +548,7 @@ Node: Keywords7260
Node: Tokens7569
Node: Error recovery9217
Node: Other declarations12453
-Node: Nonterminals16476
-Node: Conditional code17193
+Node: Nonterminals16475
+Node: Conditional code17192
End Tag Table
diff --git a/wisitoken.adb b/wisitoken.adb
index ce72d3f..698c18e 100644
--- a/wisitoken.adb
+++ b/wisitoken.adb
@@ -2,7 +2,7 @@
--
-- See spec
--
--- Copyright (C) 2009, 2014-2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2009, 2014-2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -40,7 +40,7 @@ package body WisiToken is
function Image (Item : in Token_ID; Desc : in Descriptor) return String
is begin
- return (if Item = Invalid_Token_ID then "" else Desc.Image (Item).all);
+ return (if Item = Invalid_Token_ID then "-" else Desc.Image (Item).all);
end Image;
procedure Put_Tokens (Descriptor : in WisiToken.Descriptor)
diff --git a/wisitoken.ads b/wisitoken.ads
index 81fc519..4e9d88b 100644
--- a/wisitoken.ads
+++ b/wisitoken.ads
@@ -1,431 +1,450 @@
--- 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, 2018 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
-
- 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);
- 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;
- EOF_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);
-
- function Image is new Token_ID_Arrays.Gen_Image_Aux (WisiToken.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);
-
- ----------
- -- 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);
- 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;
-
- type Token_Index_Array is array (Natural range <>) of 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);
- type Base_Token_Array_Access is access all Base_Token_Arrays.Vector;
-
- Invalid_Token_Index : constant Base_Token_Index :=
Base_Token_Arrays.No_Index;
-
- package Line_Begin_Token_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
(Line_Number_Type, Base_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);
-
- 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 Put (Trace : in out WisiToken.Trace; Item : in String) is
abstract;
- -- Put Item to the Trace display.
-
- 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.
-
- ----------
- -- 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.
+--
+-- 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;
diff --git a/wisitoken_grammar_actions.ads b/wisitoken_grammar_actions.ads
index 25b68e8..359a73d 100644
--- a/wisitoken_grammar_actions.ads
+++ b/wisitoken_grammar_actions.ads
@@ -29,7 +29,7 @@ package Wisitoken_Grammar_Actions is
Last_Terminal => 25,
First_Nonterminal => 26,
Last_Nonterminal => 37,
- EOF_ID => 25,
+ EOI_ID => 25,
Accept_ID => 26,
Case_Insensitive => False,
New_Line_ID => 1,
diff --git a/wisitoken_grammar_main.adb b/wisitoken_grammar_main.adb
index 5470e30..b8cb1c5 100644
--- a/wisitoken_grammar_main.adb
+++ b/wisitoken_grammar_main.adb
@@ -56,7 +56,6 @@ package body Wisitoken_Grammar_Main is
Add_Goto (Table.States (0), 32, 4);
Add_Goto (Table.States (0), 36, 5);
Add_Goto (Table.States (0), 37, 6);
- Set_Minimal_Action (Table.States (0).Minimal_Complete_Actions, (1
=> (Shift, 18, 1)));
Add_Action (Table.States (1), 3, 7);
Add_Action (Table.States (1), 4, 8);
Add_Action (Table.States (1), 5, 9);
@@ -66,17 +65,11 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (1), 22, 13);
Add_Error (Table.States (1));
Add_Goto (Table.States (1), 28, 14);
- Set_Minimal_Action (Table.States (1).Minimal_Complete_Actions,
((Shift, 3, 7), (Shift, 4, 8), (Shift, 5,
- 9), (Shift, 6, 10), (Shift, 22, 13)));
Add_Action (Table.States (2), 13, 15);
Add_Error (Table.States (2));
- Set_Minimal_Action (Table.States (2).Minimal_Complete_Actions, (1
=> (Shift, 13, 15)));
Add_Action (Table.States (3), (18, 22, 25), (36, 0), 1, null,
null);
- Set_Minimal_Action (Table.States (3).Minimal_Complete_Actions, (1
=> (Reduce, 36, 1)));
Add_Action (Table.States (4), (18, 22, 25), (36, 1), 1, null,
null);
- Set_Minimal_Action (Table.States (4).Minimal_Complete_Actions, (1
=> (Reduce, 36, 1)));
Add_Action (Table.States (5), (18, 22, 25), (37, 0), 1, null,
null);
- Set_Minimal_Action (Table.States (5).Minimal_Complete_Actions, (1
=> (Reduce, 37, 1)));
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);
@@ -87,21 +80,15 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (7), 22, 17);
Add_Error (Table.States (7));
Add_Goto (Table.States (7), 29, 18);
- Set_Minimal_Action (Table.States (7).Minimal_Complete_Actions, (1
=> (Shift, 22, 17)));
Add_Action (Table.States (8), 5, 19);
Add_Error (Table.States (8));
- Set_Minimal_Action (Table.States (8).Minimal_Complete_Actions, (1
=> (Shift, 5, 19)));
Add_Action (Table.States (9), 22, 20);
Add_Error (Table.States (9));
- Set_Minimal_Action (Table.States (9).Minimal_Complete_Actions, (1
=> (Shift, 22, 20)));
Add_Action (Table.States (10), (1 => 22), (28, 0), 1, null, null);
- Set_Minimal_Action (Table.States (10).Minimal_Complete_Actions, (1
=> (Reduce, 28, 1)));
Add_Action (Table.States (11), 17, 21);
Add_Error (Table.States (11));
- Set_Minimal_Action (Table.States (11).Minimal_Complete_Actions, (1
=> (Shift, 17, 21)));
Add_Action (Table.States (12), 17, 22);
Add_Error (Table.States (12));
- Set_Minimal_Action (Table.States (12).Minimal_Complete_Actions, (1
=> (Shift, 17, 22)));
Add_Action (Table.States (13), 8, 23);
Add_Action (Table.States (13), 10, 24);
Add_Action (Table.States (13), 14, 25);
@@ -116,10 +103,8 @@ package body Wisitoken_Grammar_Main is
Add_Error (Table.States (13));
Add_Goto (Table.States (13), 30, 32);
Add_Goto (Table.States (13), 31, 33);
- Set_Minimal_Action (Table.States (13).Minimal_Complete_Actions, (1
=> (Reduce, 27, 2)));
Add_Action (Table.States (14), 22, 34);
Add_Error (Table.States (14));
- Set_Minimal_Action (Table.States (14).Minimal_Complete_Actions, (1
=> (Shift, 22, 34)));
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);
@@ -128,44 +113,27 @@ package body Wisitoken_Grammar_Main is
Add_Goto (Table.States (15), 33, 36);
Add_Goto (Table.States (15), 34, 37);
Add_Goto (Table.States (15), 35, 38);
- Set_Minimal_Action (Table.States (15).Minimal_Complete_Actions, (1
=> (Reduce, 33, 0)));
Add_Action (Table.States (16), (18, 22, 25), (37, 1), 2, null,
null);
- Set_Minimal_Action (Table.States (16).Minimal_Complete_Actions, (1
=> (Reduce, 37, 2)));
Add_Action (Table.States (17), (9, 22), (29, 0), 1, null, null);
- Set_Minimal_Action (Table.States (17).Minimal_Complete_Actions, (1
=> (Reduce, 29, 1)));
Add_Action (Table.States (18), 9, 39);
Add_Action (Table.States (18), 22, 40);
Add_Error (Table.States (18));
- Set_Minimal_Action (Table.States (18).Minimal_Complete_Actions, (1
=> (Shift, 9, 39)));
Add_Action (Table.States (19), (18, 22, 25), (27, 5), 3,
declaration_5'Access, null);
- Set_Minimal_Action (Table.States (19).Minimal_Complete_Actions, (1
=> (Reduce, 27, 3)));
Add_Action (Table.States (20), 15, 41);
Add_Error (Table.States (20));
- Set_Minimal_Action (Table.States (20).Minimal_Complete_Actions, (1
=> (Shift, 15, 41)));
Add_Action (Table.States (21), 22, 42);
Add_Error (Table.States (21));
- Set_Minimal_Action (Table.States (21).Minimal_Complete_Actions, (1
=> (Shift, 22, 42)));
Add_Action (Table.States (22), 22, 43);
Add_Error (Table.States (22));
- Set_Minimal_Action (Table.States (22).Minimal_Complete_Actions, (1
=> (Shift, 22, 43)));
Add_Action (Table.States (23), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 8), 1, null, null);
- Set_Minimal_Action (Table.States (23).Minimal_Complete_Actions, (1
=> (Reduce, 31, 1)));
Add_Action (Table.States (24), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 4), 1, null, null);
- Set_Minimal_Action (Table.States (24).Minimal_Complete_Actions, (1
=> (Reduce, 31, 1)));
Add_Action (Table.States (25), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 0), 1, null, null);
- Set_Minimal_Action (Table.States (25).Minimal_Complete_Actions, (1
=> (Reduce, 31, 1)));
Add_Action (Table.States (26), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 2), 1, null, null);
- Set_Minimal_Action (Table.States (26).Minimal_Complete_Actions, (1
=> (Reduce, 31, 1)));
Add_Action (Table.States (27), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 5), 1, null, null);
- Set_Minimal_Action (Table.States (27).Minimal_Complete_Actions, (1
=> (Reduce, 31, 1)));
Add_Action (Table.States (28), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 3), 1, null, null);
- Set_Minimal_Action (Table.States (28).Minimal_Complete_Actions, (1
=> (Reduce, 31, 1)));
Add_Action (Table.States (29), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 1), 1, null, null);
- Set_Minimal_Action (Table.States (29).Minimal_Complete_Actions, (1
=> (Reduce, 31, 1)));
Add_Action (Table.States (30), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 6), 1, null, null);
- Set_Minimal_Action (Table.States (30).Minimal_Complete_Actions, (1
=> (Reduce, 31, 1)));
Add_Action (Table.States (31), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (31, 7), 1, null, null);
- Set_Minimal_Action (Table.States (31).Minimal_Complete_Actions, (1
=> (Reduce, 31, 1)));
Add_Action (Table.States (32), 8, 23);
Add_Action (Table.States (32), 10, 24);
Add_Action (Table.States (32), 14, 25);
@@ -179,9 +147,7 @@ package body Wisitoken_Grammar_Main is
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);
- Set_Minimal_Action (Table.States (32).Minimal_Complete_Actions, (1
=> (Reduce, 27, 3)));
Add_Action (Table.States (33), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (30, 0), 1, null, null);
- Set_Minimal_Action (Table.States (33).Minimal_Complete_Actions, (1
=> (Reduce, 30, 1)));
Add_Action (Table.States (34), 8, 23);
Add_Action (Table.States (34), 10, 24);
Add_Action (Table.States (34), 14, 25);
@@ -194,38 +160,27 @@ package body Wisitoken_Grammar_Main is
Add_Error (Table.States (34));
Add_Goto (Table.States (34), 30, 45);
Add_Goto (Table.States (34), 31, 33);
- Set_Minimal_Action (Table.States (34).Minimal_Complete_Actions, (1
=> (Shift, 8, 23)));
Add_Action (Table.States (35), (11, 12, 18, 19, 22), (35, 0), 1,
null, null);
- Set_Minimal_Action (Table.States (35).Minimal_Complete_Actions, (1
=> (Reduce, 35, 1)));
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));
- Set_Minimal_Action (Table.States (36).Minimal_Complete_Actions, (1
=> (Shift, 19, 48)));
Add_Action (Table.States (37), (12, 18, 19), (33, 0), 1, null,
null);
- Set_Minimal_Action (Table.States (37).Minimal_Complete_Actions, (1
=> (Reduce, 33, 1)));
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_Error (Table.States (38));
- Set_Minimal_Action (Table.States (38).Minimal_Complete_Actions, (1
=> (Reduce, 34, 1)));
Add_Action (Table.States (39), (18, 22, 25), (27, 1), 4,
declaration_1'Access, null);
- Set_Minimal_Action (Table.States (39).Minimal_Complete_Actions, (1
=> (Reduce, 27, 4)));
Add_Action (Table.States (40), (9, 22), (29, 1), 2, null, null);
- Set_Minimal_Action (Table.States (40).Minimal_Complete_Actions, (1
=> (Reduce, 29, 2)));
Add_Action (Table.States (41), 22, 51);
Add_Error (Table.States (41));
- Set_Minimal_Action (Table.States (41).Minimal_Complete_Actions, (1
=> (Shift, 22, 51)));
Add_Action (Table.States (42), 16, 52);
Add_Error (Table.States (42));
- Set_Minimal_Action (Table.States (42).Minimal_Complete_Actions, (1
=> (Shift, 16, 52)));
Add_Action (Table.States (43), 16, 53);
Add_Error (Table.States (43));
- Set_Minimal_Action (Table.States (43).Minimal_Complete_Actions, (1
=> (Shift, 16, 53)));
Add_Action (Table.States (44), (8, 10, 14, 15, 18, 20, 21, 22, 23,
24, 25), (30, 1), 2, null, null);
- Set_Minimal_Action (Table.States (44).Minimal_Complete_Actions, (1
=> (Reduce, 30, 2)));
Add_Action (Table.States (45), 8, 23);
Add_Action (Table.States (45), 10, 24);
Add_Action (Table.States (45), 14, 25);
@@ -239,7 +194,6 @@ package body Wisitoken_Grammar_Main is
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);
- Set_Minimal_Action (Table.States (45).Minimal_Complete_Actions, (1
=> (Reduce, 27, 4)));
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);
@@ -247,47 +201,31 @@ package body Wisitoken_Grammar_Main is
Add_Error (Table.States (46));
Add_Goto (Table.States (46), 34, 54);
Add_Goto (Table.States (46), 35, 38);
- Set_Minimal_Action (Table.States (46).Minimal_Complete_Actions, (1
=> (Reduce, 34, 0)));
Add_Action (Table.States (47), 4, 55);
Add_Action (Table.States (47), 5, 56);
Add_Error (Table.States (47));
- Set_Minimal_Action (Table.States (47).Minimal_Complete_Actions,
((Shift, 4, 55), (Shift, 5, 56)));
Add_Action (Table.States (48), (18, 22, 25), (32, 0), 4,
nonterminal_0'Access, null);
- Set_Minimal_Action (Table.States (48).Minimal_Complete_Actions, (1
=> (Reduce, 32, 4)));
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));
- Set_Minimal_Action (Table.States (49).Minimal_Complete_Actions, (1
=> (Reduce, 34, 2)));
Add_Action (Table.States (50), (11, 12, 18, 19, 22), (35, 1), 2,
null, null);
- Set_Minimal_Action (Table.States (50).Minimal_Complete_Actions, (1
=> (Reduce, 35, 2)));
Add_Action (Table.States (51), (18, 22, 25), (27, 4), 5,
declaration_4'Access, null);
- Set_Minimal_Action (Table.States (51).Minimal_Complete_Actions, (1
=> (Reduce, 27, 5)));
Add_Action (Table.States (52), (1 => 22), (28, 1), 4, null, null);
- Set_Minimal_Action (Table.States (52).Minimal_Complete_Actions, (1
=> (Reduce, 28, 4)));
Add_Action (Table.States (53), (1 => 22), (28, 2), 4, null, null);
- Set_Minimal_Action (Table.States (53).Minimal_Complete_Actions, (1
=> (Reduce, 28, 4)));
Add_Action (Table.States (54), (12, 18, 19), (33, 1), 3, null,
null);
- Set_Minimal_Action (Table.States (54).Minimal_Complete_Actions, (1
=> (Reduce, 33, 3)));
Add_Action (Table.States (55), 5, 58);
Add_Error (Table.States (55));
- Set_Minimal_Action (Table.States (55).Minimal_Complete_Actions, (1
=> (Shift, 5, 58)));
Add_Action (Table.States (56), 22, 59);
Add_Error (Table.States (56));
- Set_Minimal_Action (Table.States (56).Minimal_Complete_Actions, (1
=> (Shift, 22, 59)));
Add_Action (Table.States (57), (12, 18, 19), (34, 3), 3, null,
null);
- Set_Minimal_Action (Table.States (57).Minimal_Complete_Actions, (1
=> (Reduce, 34, 3)));
Add_Action (Table.States (58), (12, 18, 19), (33, 3), 4, null,
null);
- Set_Minimal_Action (Table.States (58).Minimal_Complete_Actions, (1
=> (Reduce, 33, 4)));
Add_Action (Table.States (59), 15, 60);
Add_Error (Table.States (59));
- Set_Minimal_Action (Table.States (59).Minimal_Complete_Actions, (1
=> (Shift, 15, 60)));
Add_Action (Table.States (60), 22, 61);
Add_Error (Table.States (60));
- Set_Minimal_Action (Table.States (60).Minimal_Complete_Actions, (1
=> (Shift, 22, 61)));
Add_Action (Table.States (61), (12, 18, 19), (33, 2), 6, null,
null);
- Set_Minimal_Action (Table.States (61).Minimal_Complete_Actions, (1
=> (Reduce, 33, 6)));
end Subr_1;
begin
Subr_1;
@@ -296,7 +234,7 @@ package body Wisitoken_Grammar_Main is
WisiToken.Parse.LR.Parser_No_Recover.New_Parser
(Parser,
Trace,
- Lexer.New_Lexer (Trace),
+ Lexer.New_Lexer (Trace.Descriptor),
Table,
User_Data,
Max_Parallel => 15,
diff --git a/wisitoken_grammar_re2c.c b/wisitoken_grammar_re2c.c
index b45ab3a..6ad6b86 100644
--- a/wisitoken_grammar_re2c.c
+++ b/wisitoken_grammar_re2c.c
@@ -39,7 +39,7 @@ typedef struct wisi_lexer
int line_token_start; // line at start of current token
unsigned char* marker; // saved cursor
size_t marker_pos; // saved character position
- size_t marker_line; // saved line
+ size_t marker_line; // saved line
unsigned char* context; // saved cursor
size_t context_pos; // saved character position
int context_line; // saved line
@@ -54,13 +54,16 @@ typedef struct wisi_lexer
wisi_lexer* wisitoken_grammar_new_lexer
(unsigned char* input, size_t length, int verbosity)
{
- wisi_lexer* result = malloc (sizeof (wisi_lexer));
- result->buffer = input;
- result->buffer_last = input + length - 1;
- result->cursor = input;
- result->char_pos = 1;
- result->line = (*result->cursor == 0x0A) ? 2 : 1;
- result->verbosity = verbosity;
+ wisi_lexer* result = malloc (sizeof (wisi_lexer));
+ result->buffer = input;
+ result->buffer_last = input + length - 1;
+ result->cursor = input;
+ result->byte_token_start = input;
+ result->char_pos = 1;
+ result->char_token_start = 1;
+ result->line = (*result->cursor == 0x0A) ? 2 : 1;
+ result->line_token_start = result->line;
+ result->verbosity = verbosity;
return result;
}
@@ -98,10 +101,13 @@ static void debug(wisi_lexer* lexer, int state, unsigned
char ch)
static void skip(wisi_lexer* lexer)
{
- if (lexer->cursor <= lexer->buffer_last) ++lexer->cursor;
if (lexer->cursor <= lexer->buffer_last)
+ {
+ ++lexer->cursor;
if (DO_COUNT) ++lexer->char_pos;
- if (*lexer->cursor == 0x0A) ++lexer->line;
+ if (lexer->cursor <= lexer->buffer_last)
+ if (*lexer->cursor == 0x0A) ++lexer->line;
+ }
}
#define YYSKIP() skip(lexer)
#define YYBACKUP() lexer->marker = lexer->cursor; lexer->marker_pos =
lexer->char_pos;lexer->marker_line = lexer->line
@@ -158,10 +164,7 @@ int wisitoken_grammar_next_token
}
lexer->byte_token_start = lexer->cursor;
- if (DO_COUNT)
- lexer->char_token_start = lexer->char_pos;
- else
- lexer->char_token_start = lexer->char_pos + 1;
+ lexer->char_token_start = lexer->char_pos;
if (*lexer->cursor == 0x0A)
lexer->line_token_start = lexer->line-1;
else
@@ -170,7 +173,7 @@ int wisitoken_grammar_next_token
while (*id == -1 && status == 0)
{
-#line 174 "../wisitoken_grammar_re2c.c"
+#line 177 "../wisitoken_grammar_re2c.c"
{
YYCTYPE yych;
unsigned int yyaccept = 0;
@@ -262,21 +265,21 @@ yy2:
YYSKIP ();
yy3:
YYDEBUG(3, YYPEEK ());
-#line 230 "../wisitoken_grammar.re2c"
+#line 233 "../wisitoken_grammar.re2c"
{status = ERROR_unrecognized_character; continue;}
-#line 268 "../wisitoken_grammar_re2c.c"
+#line 271 "../wisitoken_grammar_re2c.c"
yy4:
YYDEBUG(4, YYPEEK ());
YYSKIP ();
YYDEBUG(5, YYPEEK ());
-#line 228 "../wisitoken_grammar.re2c"
+#line 231 "../wisitoken_grammar.re2c"
{*id = 25; continue;}
-#line 275 "../wisitoken_grammar_re2c.c"
+#line 278 "../wisitoken_grammar_re2c.c"
yy6:
YYDEBUG(6, YYPEEK ());
YYSKIP ();
YYDEBUG(7, YYPEEK ());
-#line 197 "../wisitoken_grammar.re2c"
+#line 200 "../wisitoken_grammar.re2c"
{ lexer->byte_token_start = lexer->cursor;
lexer->char_token_start = lexer->char_pos;
if (*lexer->cursor == 0x0A)
@@ -284,14 +287,14 @@ yy6:
else
lexer->line_token_start = lexer->line;
continue; }
-#line 288 "../wisitoken_grammar_re2c.c"
+#line 291 "../wisitoken_grammar_re2c.c"
yy8:
YYDEBUG(8, YYPEEK ());
YYSKIP ();
YYDEBUG(9, YYPEEK ());
-#line 204 "../wisitoken_grammar.re2c"
+#line 207 "../wisitoken_grammar.re2c"
{*id = 1; continue;}
-#line 295 "../wisitoken_grammar_re2c.c"
+#line 298 "../wisitoken_grammar_re2c.c"
yy10:
YYDEBUG(10, YYPEEK ());
YYSKIP ();
@@ -468,9 +471,9 @@ yy12:
}
yy13:
YYDEBUG(13, YYPEEK ());
-#line 221 "../wisitoken_grammar.re2c"
+#line 224 "../wisitoken_grammar.re2c"
{*id = 18; continue;}
-#line 474 "../wisitoken_grammar_re2c.c"
+#line 477 "../wisitoken_grammar_re2c.c"
yy14:
YYDEBUG(14, YYPEEK ());
yyaccept = 0;
@@ -631,16 +634,16 @@ yy15:
YYDEBUG(15, YYPEEK ());
YYSKIP ();
YYDEBUG(16, YYPEEK ());
-#line 217 "../wisitoken_grammar.re2c"
+#line 220 "../wisitoken_grammar.re2c"
{*id = 14; continue;}
-#line 637 "../wisitoken_grammar_re2c.c"
+#line 640 "../wisitoken_grammar_re2c.c"
yy17:
YYDEBUG(17, YYPEEK ());
YYSKIP ();
YYDEBUG(18, YYPEEK ());
-#line 223 "../wisitoken_grammar.re2c"
+#line 226 "../wisitoken_grammar.re2c"
{*id = 20; continue;}
-#line 644 "../wisitoken_grammar_re2c.c"
+#line 647 "../wisitoken_grammar_re2c.c"
yy19:
YYDEBUG(19, YYPEEK ());
YYSKIP ();
@@ -662,16 +665,16 @@ yy19:
}
yy21:
YYDEBUG(21, YYPEEK ());
-#line 224 "../wisitoken_grammar.re2c"
+#line 227 "../wisitoken_grammar.re2c"
{*id = 21; continue;}
-#line 668 "../wisitoken_grammar_re2c.c"
+#line 671 "../wisitoken_grammar_re2c.c"
yy22:
YYDEBUG(22, YYPEEK ());
YYSKIP ();
YYDEBUG(23, YYPEEK ());
-#line 216 "../wisitoken_grammar.re2c"
+#line 219 "../wisitoken_grammar.re2c"
{*id = 13; continue;}
-#line 675 "../wisitoken_grammar_re2c.c"
+#line 678 "../wisitoken_grammar_re2c.c"
yy24:
YYDEBUG(24, YYPEEK ());
YYSKIP ();
@@ -682,30 +685,30 @@ yy24:
}
yy25:
YYDEBUG(25, YYPEEK ());
-#line 222 "../wisitoken_grammar.re2c"
+#line 225 "../wisitoken_grammar.re2c"
{*id = 19; continue;}
-#line 688 "../wisitoken_grammar_re2c.c"
+#line 691 "../wisitoken_grammar_re2c.c"
yy26:
YYDEBUG(26, YYPEEK ());
YYSKIP ();
YYDEBUG(27, YYPEEK ());
-#line 220 "../wisitoken_grammar.re2c"
+#line 223 "../wisitoken_grammar.re2c"
{*id = 17; continue;}
-#line 695 "../wisitoken_grammar_re2c.c"
+#line 698 "../wisitoken_grammar_re2c.c"
yy28:
YYDEBUG(28, YYPEEK ());
YYSKIP ();
YYDEBUG(29, YYPEEK ());
-#line 218 "../wisitoken_grammar.re2c"
+#line 221 "../wisitoken_grammar.re2c"
{*id = 15; continue;}
-#line 702 "../wisitoken_grammar_re2c.c"
+#line 705 "../wisitoken_grammar_re2c.c"
yy30:
YYDEBUG(30, YYPEEK ());
YYSKIP ();
YYDEBUG(31, YYPEEK ());
-#line 219 "../wisitoken_grammar.re2c"
+#line 222 "../wisitoken_grammar.re2c"
{*id = 16; continue;}
-#line 709 "../wisitoken_grammar_re2c.c"
+#line 712 "../wisitoken_grammar_re2c.c"
yy32:
YYDEBUG(32, YYPEEK ());
YYSKIP ();
@@ -781,9 +784,9 @@ yy33:
}
yy34:
YYDEBUG(34, YYPEEK ());
-#line 225 "../wisitoken_grammar.re2c"
+#line 228 "../wisitoken_grammar.re2c"
{*id = 22; continue;}
-#line 787 "../wisitoken_grammar_re2c.c"
+#line 790 "../wisitoken_grammar_re2c.c"
yy35:
YYDEBUG(35, YYPEEK ());
YYSKIP ();
@@ -836,9 +839,9 @@ yy41:
YYDEBUG(41, YYPEEK ());
YYSKIP ();
YYDEBUG(42, YYPEEK ());
-#line 215 "../wisitoken_grammar.re2c"
+#line 218 "../wisitoken_grammar.re2c"
{*id = 12; continue;}
-#line 842 "../wisitoken_grammar_re2c.c"
+#line 845 "../wisitoken_grammar_re2c.c"
yy43:
YYDEBUG(43, YYPEEK ());
YYSKIP ();
@@ -1016,9 +1019,9 @@ yy46:
}
yy47:
YYDEBUG(47, YYPEEK ());
-#line 226 "../wisitoken_grammar.re2c"
+#line 229 "../wisitoken_grammar.re2c"
{*id = 23; continue;}
-#line 1022 "../wisitoken_grammar_re2c.c"
+#line 1025 "../wisitoken_grammar_re2c.c"
yy48:
YYDEBUG(48, YYPEEK ());
YYSKIP ();
@@ -1353,23 +1356,23 @@ yy54:
YYDEBUG(54, YYPEEK ());
YYSKIP ();
YYDEBUG(55, YYPEEK ());
-#line 214 "../wisitoken_grammar.re2c"
+#line 217 "../wisitoken_grammar.re2c"
{*id = 11; skip_to(lexer, ")%"); continue;}
-#line 1359 "../wisitoken_grammar_re2c.c"
+#line 1362 "../wisitoken_grammar_re2c.c"
yy56:
YYDEBUG(56, YYPEEK ());
YYSKIP ();
YYDEBUG(57, YYPEEK ());
-#line 213 "../wisitoken_grammar.re2c"
+#line 216 "../wisitoken_grammar.re2c"
{*id = 10; skip_to(lexer, "]%"); continue;}
-#line 1366 "../wisitoken_grammar_re2c.c"
+#line 1369 "../wisitoken_grammar_re2c.c"
yy58:
YYDEBUG(58, YYPEEK ());
YYSKIP ();
YYDEBUG(59, YYPEEK ());
-#line 212 "../wisitoken_grammar.re2c"
+#line 215 "../wisitoken_grammar.re2c"
{*id = 9; skip_to(lexer, "}%"); continue;}
-#line 1373 "../wisitoken_grammar_re2c.c"
+#line 1376 "../wisitoken_grammar_re2c.c"
yy60:
YYDEBUG(60, YYPEEK ());
YYSKIP ();
@@ -1538,9 +1541,9 @@ yy62:
}
yy63:
YYDEBUG(63, YYPEEK ());
-#line 227 "../wisitoken_grammar.re2c"
+#line 230 "../wisitoken_grammar.re2c"
{*id = 24; continue;}
-#line 1544 "../wisitoken_grammar_re2c.c"
+#line 1547 "../wisitoken_grammar_re2c.c"
yy64:
YYDEBUG(64, YYPEEK ());
YYSKIP ();
@@ -2060,9 +2063,9 @@ yy70:
}
yy72:
YYDEBUG(72, YYPEEK ());
-#line 205 "../wisitoken_grammar.re2c"
+#line 208 "../wisitoken_grammar.re2c"
{*id = 2; continue;}
-#line 2066 "../wisitoken_grammar_re2c.c"
+#line 2069 "../wisitoken_grammar_re2c.c"
yy73:
YYDEBUG(73, YYPEEK ());
YYSKIP ();
@@ -2152,9 +2155,9 @@ yy75:
}
yy76:
YYDEBUG(76, YYPEEK ());
-#line 208 "../wisitoken_grammar.re2c"
+#line 211 "../wisitoken_grammar.re2c"
{*id = 5; continue;}
-#line 2158 "../wisitoken_grammar_re2c.c"
+#line 2161 "../wisitoken_grammar_re2c.c"
yy77:
YYDEBUG(77, YYPEEK ());
YYSKIP ();
@@ -2590,9 +2593,9 @@ yy87:
}
yy88:
YYDEBUG(88, YYPEEK ());
-#line 207 "../wisitoken_grammar.re2c"
+#line 210 "../wisitoken_grammar.re2c"
{*id = 4; continue;}
-#line 2596 "../wisitoken_grammar_re2c.c"
+#line 2599 "../wisitoken_grammar_re2c.c"
yy89:
YYDEBUG(89, YYPEEK ());
YYSKIP ();
@@ -2690,9 +2693,9 @@ yy92:
}
yy93:
YYDEBUG(93, YYPEEK ());
-#line 206 "../wisitoken_grammar.re2c"
+#line 209 "../wisitoken_grammar.re2c"
{*id = 3; continue;}
-#line 2696 "../wisitoken_grammar_re2c.c"
+#line 2699 "../wisitoken_grammar_re2c.c"
yy94:
YYDEBUG(94, YYPEEK ());
YYSKIP ();
@@ -2806,9 +2809,9 @@ yy99:
}
yy100:
YYDEBUG(100, YYPEEK ());
-#line 211 "../wisitoken_grammar.re2c"
+#line 214 "../wisitoken_grammar.re2c"
{*id = 8; continue;}
-#line 2812 "../wisitoken_grammar_re2c.c"
+#line 2815 "../wisitoken_grammar_re2c.c"
yy101:
YYDEBUG(101, YYPEEK ());
YYSKIP ();
@@ -2898,9 +2901,9 @@ yy103:
}
yy104:
YYDEBUG(104, YYPEEK ());
-#line 209 "../wisitoken_grammar.re2c"
+#line 212 "../wisitoken_grammar.re2c"
{*id = 6; continue;}
-#line 2904 "../wisitoken_grammar_re2c.c"
+#line 2907 "../wisitoken_grammar_re2c.c"
yy105:
YYDEBUG(105, YYPEEK ());
YYSKIP ();
@@ -3006,11 +3009,11 @@ yy109:
}
yy110:
YYDEBUG(110, YYPEEK ());
-#line 210 "../wisitoken_grammar.re2c"
+#line 213 "../wisitoken_grammar.re2c"
{*id = 7; continue;}
-#line 3012 "../wisitoken_grammar_re2c.c"
+#line 3015 "../wisitoken_grammar_re2c.c"
}
-#line 231 "../wisitoken_grammar.re2c"
+#line 234 "../wisitoken_grammar.re2c"
}
*byte_position = lexer->byte_token_start - lexer->buffer + 1;
diff --git a/wisitoken_grammar_runtime.adb b/wisitoken_grammar_runtime.adb
index 412ffef..3795b1a 100644
--- a/wisitoken_grammar_runtime.adb
+++ b/wisitoken_grammar_runtime.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,7 +39,7 @@ package body WisiToken_Grammar_Runtime is
Region : Buffer_Region renames Data.Terminals.all (Tree.Terminal
(Tree_Index)).Byte_Region;
begin
if -Tree.ID (Tree_Index) in RAW_CODE_ID | REGEXP_ID | ACTION_ID then
- -- strip delimiters.
+ -- 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
@@ -140,7 +140,7 @@ package body WisiToken_Grammar_Runtime is
declare
Text : constant String := Get_Text (Data, Tree, Tokens (2));
begin
- if Text'Length > 0 then
+ if Text'Length > 0 and (for some C of Text => C /= ' ') then
RHS.Action := +Text;
Data.Action_Count := Data.Action_Count + 1;
end if;
@@ -220,7 +220,6 @@ package body WisiToken_Grammar_Runtime is
Data.Language_Params := (others => <>);
WisiToken.BNF.Free (Data.Generate_Set);
Data.Tokens := (others => <>);
- Data.User_Names := (others => <>);
Data.Conflicts.Clear;
Data.McKenzie_Recover := (others => <>);
Data.Rule_Count := 0;
@@ -437,10 +436,10 @@ package body WisiToken_Grammar_Runtime is
null;
elsif Kind = "elisp_face" then
- Data.User_Names.Faces.Append (Get_Text (Data, Tree, Tokens
(3), Strip_Quotes => True));
+ Data.Tokens.Faces.Append (Get_Text (Data, Tree, Tokens (3),
Strip_Quotes => True));
elsif Kind = "elisp_indent" then
- Data.User_Names.Indents.Append
+ Data.Tokens.Indents.Append
((Name => +Get_Child_Text (Data, Tree, Tokens (3), 1,
Strip_Quotes => True),
Value => +Get_Child_Text (Data, Tree, Tokens (3), 2)));
diff --git a/wisitoken_grammar_runtime.ads b/wisitoken_grammar_runtime.ads
index 62aaf9a..9c9d0ac 100644
--- a/wisitoken_grammar_runtime.ads
+++ b/wisitoken_grammar_runtime.ads
@@ -41,7 +41,6 @@ package WisiToken_Grammar_Runtime is
Raw_Code : WisiToken.BNF.Raw_Code;
Language_Params : WisiToken.BNF.Language_Param_Type;
Tokens : aliased WisiToken.BNF.Tokens;
- User_Names : WisiToken.BNF.User_Names;
Conflicts : WisiToken.BNF.Conflict_Lists.List;
McKenzie_Recover : WisiToken.BNF.McKenzie_Recover_Param_Type;
- [elpa] externals/wisi 89eee25 23/35: Release ada-mode 6.0.1, wisi 2.0.1; fix copyright, packaging bugs, (continued)
- [elpa] externals/wisi 89eee25 23/35: Release ada-mode 6.0.1, wisi 2.0.1; fix copyright, packaging bugs, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi d0eac6a 34/35: Forgot some new files in wisi, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi a6b3115 24/35: * ada-mode, wisi: Fix file access rights, Stefan Monnier, 2020/11/28
- [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 <=
- [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, 2020/11/28
- [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