[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/wisi d10db37 22/35: Release ada-mode version 6.0. Relea
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] externals/wisi d10db37 22/35: Release ada-mode version 6.0. Release wisi version 2.0 |
|
Date: |
Sat, 28 Nov 2020 14:47:54 -0500 (EST) |
branch: externals/wisi
commit d10db37c397cfdcb56cf10a9a71fd4b8e5aca51c
Author: Stephen Leake <stephen_leake@stephe-leake.org>
Commit: Stephen Leake <stephen_leake@stephe-leake.org>
Release ada-mode version 6.0. Release wisi version 2.0
---
NEWS | 22 +-
README | 6 +-
build-wisitoken-bnf-generate.sh | 9 +
long_float_elementary_functions.ads | 21 +
parse_table-mode.el | 64 -
sal-gen_bounded_definite_vectors-gen_image.adb | 39 +
sal-gen_bounded_definite_vectors-gen_image.ads | 23 +
sal-gen_bounded_definite_vectors-gen_image_aux.adb | 35 +
sal-gen_bounded_definite_vectors-gen_image_aux.ads | 23 +
sal-gen_bounded_definite_vectors-gen_sorted.adb | 85 +
sal-gen_bounded_definite_vectors-gen_sorted.ads | 50 +
sal-gen_bounded_definite_vectors.adb | 224 ++
sal-gen_bounded_definite_vectors.ads | 150 +
sal-gen_definite_doubly_linked_lists.adb | 304 ++
sal-gen_definite_doubly_linked_lists.ads | 159 +
...finite_doubly_linked_lists_sorted-gen_image.adb | 47 +
...finite_doubly_linked_lists_sorted-gen_image.ads | 25 +
sal-gen_definite_doubly_linked_lists_sorted.adb | 542 ++++
sal-gen_definite_doubly_linked_lists_sorted.ads | 175 ++
sal-gen_indefinite_doubly_linked_lists.adb | 201 ++
sal-gen_indefinite_doubly_linked_lists.ads | 114 +
sal-gen_trimmed_image.adb | 28 +
sal-gen_trimmed_image.ads | 23 +
sal-gen_unbounded_definite_min_heaps_fibonacci.adb | 340 +++
sal-gen_unbounded_definite_min_heaps_fibonacci.ads | 114 +
...gen_unbounded_definite_queues-gen_image_aux.adb | 35 +
...gen_unbounded_definite_queues-gen_image_aux.ads | 23 +
sal-gen_unbounded_definite_queues.adb | 97 +
sal-gen_unbounded_definite_queues.ads | 108 +
sal-gen_unbounded_definite_red_black_trees.adb | 863 ++++++
sal-gen_unbounded_definite_red_black_trees.ads | 181 ++
...gen_unbounded_definite_stacks-gen_image_aux.adb | 42 +
...gen_unbounded_definite_stacks-gen_image_aux.ads | 27 +
sal-gen_unbounded_definite_stacks.adb | 178 ++
sal-gen_unbounded_definite_stacks.ads | 133 +
...n_unbounded_definite_vectors-gen_comparable.adb | 73 +
...n_unbounded_definite_vectors-gen_comparable.ads | 30 +
sal-gen_unbounded_definite_vectors-gen_image.adb | 50 +
sal-gen_unbounded_definite_vectors-gen_image.ads | 24 +
...en_unbounded_definite_vectors-gen_image_aux.adb | 36 +
...en_unbounded_definite_vectors-gen_image_aux.ads | 23 +
sal-gen_unbounded_definite_vectors.adb | 578 ++++
sal-gen_unbounded_definite_vectors.ads | 226 ++
sal.adb | 32 +
sal.ads | 75 +
standard_common.gpr | 118 +
wisi-compat-24.2.el | 34 -
wisi-compile.el | 34 +-
wisi-elisp-lexer.el | 393 +++
wisi-elisp-parse.el | 1682 +++++++++++
wisi-fringe.el | 146 +
wisi-parse-common.el | 341 +++
wisi-parse.el | 549 ----
wisi-process-parse.el | 691 +++++
wisi.adb | 1891 ++++++++++++
wisi.ads | 666 +++++
wisi.el | 2940 +++++++++----------
wisitoken-bnf-generate.adb | 522 ++++
wisitoken-bnf-generate_grammar.adb | 86 +
wisitoken-bnf-generate_packrat.adb | 331 +++
wisitoken-bnf-generate_utils.adb | 818 ++++++
wisitoken-bnf-generate_utils.ads | 176 ++
wisitoken-bnf-output_ada.adb | 436 +++
wisitoken-bnf-output_ada_common.adb | 1407 +++++++++
wisitoken-bnf-output_ada_common.ads | 91 +
wisitoken-bnf-output_ada_emacs.adb | 1519 ++++++++++
wisitoken-bnf-output_elisp.adb | 293 ++
wisitoken-bnf-output_elisp_common.adb | 145 +
wisitoken-bnf-output_elisp_common.ads | 49 +
wisitoken-bnf-utils.adb | 45 +
wisitoken-bnf-utils.ads | 29 +
wisitoken-bnf.adb | 337 +++
wisitoken-bnf.ads | 310 ++
wisitoken-gen_token_enum.adb | 133 +
wisitoken-gen_token_enum.ads | 130 +
wisitoken-generate-lr-lalr_generate.adb | 593 ++++
wisitoken-generate-lr-lalr_generate.ads | 67 +
wisitoken-generate-lr-lr1_generate.adb | 315 ++
wisitoken-generate-lr-lr1_generate.ads | 76 +
wisitoken-generate-lr.adb | 1141 ++++++++
wisitoken-generate-lr.ads | 176 ++
wisitoken-generate-lr1_items.adb | 580 ++++
wisitoken-generate-lr1_items.ads | 332 +++
wisitoken-generate-packrat.adb | 247 ++
wisitoken-generate-packrat.ads | 75 +
wisitoken-generate.adb | 495 ++++
wisitoken-generate.ads | 136 +
wisitoken-lexer-re2c.adb | 244 ++
wisitoken-lexer-re2c.ads | 129 +
wisitoken-lexer-regexp.adb | 240 ++
wisitoken-lexer-regexp.ads | 102 +
wisitoken-lexer.adb | 56 +
wisitoken-lexer.ads | 161 ++
wisitoken-parse-lr-mckenzie_recover-base.adb | 433 +++
wisitoken-parse-lr-mckenzie_recover-base.ads | 180 ++
wisitoken-parse-lr-mckenzie_recover-explore.adb | 1301 +++++++++
wisitoken-parse-lr-mckenzie_recover-explore.ads | 28 +
wisitoken-parse-lr-mckenzie_recover-parse.adb | 302 ++
wisitoken-parse-lr-mckenzie_recover-parse.ads | 77 +
wisitoken-parse-lr-mckenzie_recover.adb | 1062 +++++++
wisitoken-parse-lr-mckenzie_recover.ads | 220 ++
wisitoken-parse-lr-parser.adb | 1105 +++++++
wisitoken-parse-lr-parser.ads | 145 +
wisitoken-parse-lr-parser_lists.adb | 405 +++
wisitoken-parse-lr-parser_lists.ads | 260 ++
wisitoken-parse-lr-parser_no_recover.adb | 492 ++++
wisitoken-parse-lr-parser_no_recover.ads | 84 +
wisitoken-parse-lr.adb | 856 ++++++
wisitoken-parse-lr.ads | 624 ++++
wisitoken-parse-packrat-generated.adb | 86 +
wisitoken-parse-packrat-generated.ads | 70 +
wisitoken-parse-packrat-procedural.adb | 251 ++
wisitoken-parse-packrat-procedural.ads | 80 +
wisitoken-parse-packrat.adb | 56 +
wisitoken-parse-packrat.ads | 71 +
wisitoken-parse.adb | 88 +
wisitoken-parse.ads | 66 +
wisitoken-productions.adb | 51 +
wisitoken-productions.ads | 64 +
wisitoken-regexp.adb | 1347 +++++++++
wisitoken-regexp.ads | 139 +
wisitoken-semantic_checks.adb | 135 +
wisitoken-semantic_checks.ads | 89 +
wisitoken-syntax_trees.adb | 1114 +++++++
wisitoken-syntax_trees.ads | 411 +++
wisitoken-text_io_trace.adb | 70 +
wisitoken-text_io_trace.ads | 45 +
wisitoken-wisi_ada.adb | 163 ++
wisitoken-wisi_ada.ads | 82 +
wisitoken.adb | 351 +++
wisitoken.ads | 432 +++
wisitoken.gpr | 56 +
wisitoken_grammar_actions.adb | 105 +
wisitoken_grammar_actions.ads | 168 ++
wisitoken_grammar_main.adb | 305 ++
wisitoken_grammar_main.ads | 33 +
wisitoken_grammar_re2c.c | 3025 ++++++++++++++++++++
wisitoken_grammar_re2c_c.ads | 63 +
wisitoken_grammar_runtime.adb | 610 ++++
wisitoken_grammar_runtime.ads | 85 +
140 files changed, 42135 insertions(+), 2314 deletions(-)
diff --git a/NEWS b/NEWS
index 5e837c7..f86dbe5 100644
--- a/NEWS
+++ b/NEWS
@@ -1,12 +1,32 @@
GNU Emacs wisi NEWS -- history of user-visible changes.
-Copyright (C) 2014 Free Software Foundation, Inc.
+Copyright (C) 2018 Free Software Foundation, Inc.
See the end of the file for license conditions.
Please send wisi bug reports to bug-gnu-emacs@gnu.org, with
'wisi' in the subject. If possible, use M-x report-emacs-bug.
+* wisi 2.0.0
+17 Nov 2018
+
+** Change indentation engine to compute indent directly in parser actions.
+
+** Add error correcting external process parser.
+
+** Factor out wisi-elisp-lexer.el from wisi.el, and
+ ada-wisi-elisp-parse.el from ada-wisi.el. Move elisp grammar
+ actions from wisi.el to wisi-elisp-parse.el; they are not used with
+ the process parser.
+
+** Add support for error corrections in parser; 'wisi-repair-error'
+ can apply the corrections to the buffer text.
+
+** Display marks in fringe at location of errors detected by
+ background parser.
+
+** include sources for wisitoken parser runtime, parser generator.
+
* wisi 1.1.6
3 Oct 2017
diff --git a/README b/README
index 648f35c..0435747 100644
--- a/README
+++ b/README
@@ -1,7 +1,7 @@
-Emacs wisi package 1.1.6
+Emacs wisi package 2.0.0
The wisi package provides utilities for using generalized LALR parsers
-to do indentation, fontification, and navigation. See ada-mode for an
-example of its use.
+(in elisp or external processes) to do indentation, fontification, and
+navigation. See ada-mode for an example of its use.
diff --git a/build-wisitoken-bnf-generate.sh b/build-wisitoken-bnf-generate.sh
new file mode 100644
index 0000000..c087be6
--- /dev/null
+++ b/build-wisitoken-bnf-generate.sh
@@ -0,0 +1,9 @@
+# Build wisitoken-bnf-generate.exe, for generating code from grammar files.
+#
+# Assumes build.sh has run.
+#
+# Instead of using this, you should consider using the complete
+# wisitoken development tree; see
+# http://stephe-leake.org/ada/wisitoken.html
+
+gprbuild -p -P wisitoken.gpr wisitoken-bnf-generate
diff --git a/long_float_elementary_functions.ads
b/long_float_elementary_functions.ads
new file mode 100644
index 0000000..3f543b9
--- /dev/null
+++ b/long_float_elementary_functions.ads
@@ -0,0 +1,21 @@
+-- Abstract :
+--
+-- instantiation
+--
+-- Copyright (C) 2017 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Numerics.Generic_Elementary_Functions;
+package Long_Float_Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Long_Float);
diff --git a/parse_table-mode.el b/parse_table-mode.el
deleted file mode 100755
index d8d2651..0000000
--- a/parse_table-mode.el
+++ /dev/null
@@ -1,64 +0,0 @@
-;; parse_table-mode.el --- For navigating in a parse_table as output by
wisi-generate. -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2017 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 parse_table--xref-backend () 'parse_table)
-
-(cl-defgeneric xref-backend-identifier-completion-table ((_backend (eql
parse_table)))
- ;; could complete on nonterms, find productions
- nil)
-
-(cl-defmethod xref-backend-identifier-at-point ((_backend (eql parse_table)))
- ;; assume we are on one of:
- ;; - ’goto state nnn’ in a state action
- ;; - ’=> State nnn’ in the debug kernels list
- ;; - ’( nnn)’ in the unknown conflicts list
- (save-excursion
- (end-of-line)
- (when (or (looking-back "[Ss]tate \\([0-9]+\\),?"
(line-beginning-position))
- (looking-back "( \\([0-9]+\\))" (line-beginning-position)))
- (match-string 1))))
-
-(cl-defgeneric xref-backend-definitions ((_backend (eql parse_table))
identifier)
- ;; state tables are self-contained; IDENTIFIER must be a state number
- (save-excursion
- (goto-char (point-min))
- (search-forward-regexp (concat "^State " identifier ":$"))
- (list (xref-make identifier (xref-make-buffer-location (current-buffer)
(match-beginning 0))))))
-
-(define-minor-mode parse_table-mode
- "Provides navigation in wisi-generate parse table output."
- nil ":parse_table" nil
- (add-hook 'xref-backend-functions #'parse_table--xref-backend nil t)
-
- (if parse_table-mode
- (read-only-mode 0)
- (read-only-mode 1)
- ))
-
-(provide 'parse_table-mode)
-;; end of file
diff --git a/sal-gen_bounded_definite_vectors-gen_image.adb
b/sal-gen_bounded_definite_vectors-gen_image.adb
new file mode 100644
index 0000000..893b178
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors-gen_image.adb
@@ -0,0 +1,39 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+function SAL.Gen_Bounded_Definite_Vectors.Gen_Image (Item : in Vector) return
String
+is
+ use all type SAL.Base_Peek_Type;
+ use Ada.Strings;
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ Last : Base_Peek_Type := To_Peek_Index (Item.Last);
+begin
+ for I in Item.Elements (1 .. Last) loop
+ Result := Result &
+ ((if Trim
+ then Fixed.Trim (Element_Image (Item.Elements (I)), Left)
+ else Element_Image (Item.Elements (I)));
+ if I /= Last then
+ Result := Result & ", ";
+ end if;
+ end loop;
+ Result := Result & ")";
+ return To_String (Result);
+end SAL.Gen_Bounded_Definite_Vectors.Gen_Image;
diff --git a/sal-gen_bounded_definite_vectors-gen_image.ads
b/sal-gen_bounded_definite_vectors-gen_image.ads
new file mode 100644
index 0000000..6202be0
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors-gen_image.ads
@@ -0,0 +1,23 @@
+-- Abstract :
+--
+-- Image for instantiations of parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ with function Element_Image (Item : in Element_Type) return String;
+ Trim : in Boolean;
+function SAL.Gen_Bounded_Definite_Vectors.Gen_Image (Item : in Vector) return
String;
diff --git a/sal-gen_bounded_definite_vectors-gen_image_aux.adb
b/sal-gen_bounded_definite_vectors-gen_image_aux.adb
new file mode 100644
index 0000000..39ecd46
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors-gen_image_aux.adb
@@ -0,0 +1,35 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Unbounded;
+function SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector; Aux
: in Aux_Data) return String
+is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ Last : constant Base_Peek_Type := To_Peek_Index (Item.Last);
+begin
+ for I in 1 .. Last loop
+ Result := Result & Element_Image (Item.Elements (I), Aux);
+ if I /= Last then
+ Result := Result & ", ";
+ end if;
+ end loop;
+ Result := Result & ")";
+ return To_String (Result);
+end SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux;
diff --git a/sal-gen_bounded_definite_vectors-gen_image_aux.ads
b/sal-gen_bounded_definite_vectors-gen_image_aux.ads
new file mode 100644
index 0000000..c72f8ee
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors-gen_image_aux.ads
@@ -0,0 +1,23 @@
+-- Abstract :
+--
+-- Image with auxiliary data for instantiations of parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Aux_Data (<>) is private;
+ with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
+function SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector; Aux
: in Aux_Data) return String;
diff --git a/sal-gen_bounded_definite_vectors-gen_sorted.adb
b/sal-gen_bounded_definite_vectors-gen_sorted.adb
new file mode 100644
index 0000000..088b807
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors-gen_sorted.adb
@@ -0,0 +1,85 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted is
+
+ overriding procedure Append (Container : in out Vector; New_Item : in
Element_Type)
+ is begin
+ raise Programmer_Error;
+ end Append;
+
+ overriding procedure Prepend (Container : in out Vector; New_Item : in
Element_Type)
+ is begin
+ raise Programmer_Error;
+ end Prepend;
+
+ overriding
+ procedure Insert
+ (Container : in out Vector;
+ New_Item : in Element_Type;
+ Before : in Extended_Index)
+ is begin
+ raise Programmer_Error;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ New_Item : in Element_Type)
+ is
+ K : constant Base_Peek_Type := To_Peek_Index (Container.Last);
+ J : Base_Peek_Type := K;
+ begin
+ if K + 1 > Container.Elements'Last then
+ raise Container_Full;
+
+ elsif K = 0 then
+ -- Container empty
+ Container.Last := Container.Last + 1;
+ Container.Elements (1) := New_Item;
+ return;
+ end if;
+
+ loop
+ exit when J < 1;
+
+ case Element_Compare (New_Item, Container.Elements (J)) is
+ when Less =>
+ J := J - 1;
+ when Equal =>
+ -- Insert after J
+ exit;
+ when Greater =>
+ -- Insert after J
+ exit;
+ end case;
+ end loop;
+
+ if J = 0 then
+ -- Insert before all
+ Container.Elements (2 .. K + 1) := Container.Elements (1 .. K);
+ Container.Elements (1) := New_Item;
+ else
+ -- Insert after J
+ Container.Elements (J + 2 .. K + 1) := Container.Elements (J + 1 ..
K);
+ Container.Elements (J + 1) := New_Item;
+ end if;
+ Container.Last := Container.Last + 1;
+ end Insert;
+
+end SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted;
diff --git a/sal-gen_bounded_definite_vectors-gen_sorted.ads
b/sal-gen_bounded_definite_vectors-gen_sorted.ads
new file mode 100644
index 0000000..d210c0b
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors-gen_sorted.ads
@@ -0,0 +1,50 @@
+-- Abstract :
+--
+-- Add sorted behavior to parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ with function Element_Compare (Left, Right : in Element_Type) return
Compare_Result;
+package SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted is
+
+ type Vector is new SAL.Gen_Bounded_Definite_Vectors.Vector with null record;
+
+ overriding procedure Append (Container : in out Vector; New_Item : in
Element_Type)
+ with Inline => True;
+ -- Raises Programmer_Error
+
+ overriding procedure Prepend (Container : in out Vector; New_Item : in
Element_Type)
+ with Inline => True;
+ -- Raises Programmer_Error
+
+ overriding
+ procedure Insert
+ (Container : in out Vector;
+ New_Item : in Element_Type;
+ Before : in Extended_Index)
+ with Inline => True;
+ -- Raises Programmer_Error
+
+ not overriding
+ procedure Insert
+ (Container : in out Vector;
+ New_Item : in Element_Type);
+ -- Insert New_Item in sorted position. Items are sorted in increasing
+ -- order according to Element_Compare. New_Item is inserted after
+ -- Equal items.
+
+end SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted;
diff --git a/sal-gen_bounded_definite_vectors.adb
b/sal-gen_bounded_definite_vectors.adb
new file mode 100644
index 0000000..75b4016
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors.adb
@@ -0,0 +1,224 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Bounded_Definite_Vectors is
+
+ function Length (Container : in Vector) return Ada.Containers.Count_Type
+ is begin
+ -- We assume the type ranges are sensible, so no exceptions occur
+ -- here.
+ return Ada.Containers.Count_Type (Container.Last - Index_Type'First + 1);
+ end Length;
+
+ function Is_Full (Container : in Vector) return Boolean
+ is begin
+ return To_Peek_Index (Container.Last) = Peek_Type (Capacity);
+ end Is_Full;
+
+ procedure Clear (Container : in out Vector)
+ is begin
+ Container.Last := No_Index;
+ end Clear;
+
+ function Element (Container : Vector; Index : Index_Type) return
Element_Type
+ is begin
+ return Container.Elements (Peek_Type (Index - Index_Type'First + 1));
+ end Element;
+
+ function Last_Index (Container : Vector) return Extended_Index
+ is begin
+ return Container.Last;
+ end Last_Index;
+
+ procedure Set_Last (Container : in out Vector; Last : in Index_Type)
+ is begin
+ Container.Last := Last;
+ end Set_Last;
+
+ procedure Append (Container : in out Vector; New_Item : in Element_Type)
+ is
+ J : constant Peek_Type := To_Peek_Index (Container.Last + 1);
+ begin
+ if J > Container.Elements'Last then
+ raise Container_Full;
+ end if;
+ Container.Elements (J) := New_Item;
+ Container.Last := Container.Last + 1;
+ end Append;
+
+ procedure Prepend (Container : in out Vector; New_Item : in Element_Type)
+ is
+ J : constant Peek_Type := Peek_Type (Container.Last + 1 -
Index_Type'First + 1);
+ begin
+ if J > Container.Elements'Last then
+ raise Container_Full;
+ end if;
+
+ Container.Elements (2 .. J) := Container.Elements (1 .. J - 1);
+ Container.Elements (1) := New_Item;
+ Container.Last := Container.Last + 1;
+ end Prepend;
+
+ procedure Insert
+ (Container : in out Vector;
+ New_Item : in Element_Type;
+ Before : in Extended_Index)
+ is
+ J : constant Peek_Type := To_Peek_Index ((if Before = No_Index then
Container.Last + 1 else Before));
+ K : constant Base_Peek_Type := To_Peek_Index (Container.Last);
+ begin
+ if K + 1 > Container.Elements'Last then
+ raise Container_Full;
+ end if;
+
+ Container.Elements (J + 1 .. K + 1) := Container.Elements (J .. K);
+ Container.Elements (J) := New_Item;
+ Container.Last := Container.Last + 1;
+ end Insert;
+
+ function "+" (Item : in Element_Type) return Vector
+ is begin
+ return Result : Vector do
+ Result.Append (Item);
+ end return;
+ end "+";
+
+ function "&" (Left : in Vector; Right : in Element_Type) return Vector
+ is begin
+ return Result : Vector := Left do
+ Result.Append (Right);
+ end return;
+ end "&";
+
+ procedure Delete_First (Container : in out Vector; Count : in Index_Type :=
1)
+ is
+ J : constant Peek_Type := Peek_Type (Container.Last - Index_Type'First +
Count);
+ begin
+ if Count > Container.Last then
+ raise Container_Empty;
+ end if;
+ Container.Elements (1 .. J - 1) := Container.Elements (2 .. J);
+ Container.Last := Container.Last - Count;
+ end Delete_First;
+
+ function Constant_Reference (Container : aliased Vector; Index : in
Index_Type) return Constant_Reference_Type
+ is
+ J : constant Peek_Type := Peek_Type (Index - Index_Type'First + 1);
+ begin
+ if Index > Container.Last then
+ raise Constraint_Error;
+ end if;
+ return (Element => Container.Elements (J)'Access);
+ end Constant_Reference;
+
+ function Variable_Reference
+ (Container : aliased in out Vector;
+ Index : in Index_Type)
+ return Variable_Reference_Type
+ is
+ J : constant Peek_Type := Peek_Type (Index - Index_Type'First + 1);
+ begin
+ if Index > Container.Last then
+ raise Constraint_Error;
+ end if;
+ return (Element => Container.Elements (J)'Access);
+ end Variable_Reference;
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ if Position.Container = null then
+ return False;
+ end if;
+
+ return Position.Index <= Position.Container.Last;
+ end Has_Element;
+
+ overriding function First (Object : Iterator) return Cursor
+ is begin
+ if Object.Container.Last = No_Index then
+ return (null, Index_Type'First);
+ else
+ return (Object.Container, Object.Container.First_Index);
+ end if;
+ end First;
+
+ overriding function Last (Object : Iterator) return Cursor
+ is begin
+ if Object.Container.Last = No_Index then
+ return (null, Index_Type'First);
+ else
+ return (Object.Container, Object.Container.Last_Index);
+ end if;
+ end Last;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor
+ is begin
+ if Position.Index = Object.Container.Last then
+ return (null, Index_Type'First);
+ else
+ return (Object.Container, Position.Index + 1);
+ end if;
+ end Next;
+
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor
+ is begin
+ if Position.Index = Index_Type'First then
+ return (null, Index_Type'First);
+ else
+ return (Object.Container, Position.Index - 1);
+ end if;
+ end Previous;
+
+ function Iterate (Container : Vector) return
Vector_Iterator_Interfaces.Reversible_Iterator'Class
+ is begin
+ return Iterator'
+ (Container => Container'Unrestricted_Access,
+ Index => No_Index);
+ end Iterate;
+
+ function Constant_Reference (Container : aliased Vector; Position : in
Cursor) return Constant_Reference_Type
+ is
+ J : constant Peek_Type := Peek_Type (Position.Index - Index_Type'First +
1);
+ begin
+ return (Element => Container.Elements (J)'Access);
+ end Constant_Reference;
+
+ function Variable_Reference
+ (Container : aliased in out Vector;
+ Position : in Cursor)
+ return Variable_Reference_Type
+ is
+ J : constant Peek_Type := Peek_Type (Position.Index - Index_Type'First +
1);
+ begin
+ return (Element => Container.Elements (J)'Access);
+ end Variable_Reference;
+
+ ----------
+ -- Spec private functions
+
+ function To_Peek_Index (Index : in Extended_Index) return Base_Peek_Type
+ is begin
+ return Base_Peek_Type (Index - Index_Type'First + 1);
+ end To_Peek_Index;
+
+end SAL.Gen_Bounded_Definite_Vectors;
diff --git a/sal-gen_bounded_definite_vectors.ads
b/sal-gen_bounded_definite_vectors.ads
new file mode 100644
index 0000000..d4c808d
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors.ads
@@ -0,0 +1,150 @@
+-- Abstract :
+--
+-- A simple bounded vector of definite items, intended to be faster
+-- than Ada.Containers.Bounded_Definite_Vectors.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Iterator_Interfaces;
+generic
+ type Index_Type is range <>;
+ type Element_Type is private;
+ Capacity : in Ada.Containers.Count_Type;
+package SAL.Gen_Bounded_Definite_Vectors is
+
+ subtype Extended_Index is Index_Type'Base
+ range Index_Type'First - 1 ..
+ Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
+
+ No_Index : constant Extended_Index := Extended_Index'First;
+
+ type Vector is tagged private with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Variable_Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
+ Empty_Vector : constant Vector;
+
+ function Length (Container : in Vector) return Ada.Containers.Count_Type;
+
+ function Is_Full (Container : in Vector) return Boolean;
+
+ procedure Clear (Container : in out Vector);
+
+ function First_Index (Container : in Vector) return Index_Type is
(Index_Type'First);
+
+ function Last_Index (Container : in Vector) return Extended_Index;
+ -- No_Index when Container is empty.
+
+ procedure Set_Last (Container : in out Vector; Last : in Index_Type);
+ -- Elements with indices < Last that have not been set are undefined.
+
+ function Element (Container : Vector; Index : Index_Type) return
Element_Type;
+ -- Index of first element in vector is Index_Type'First.
+
+ procedure Append (Container : in out Vector; New_Item : in Element_Type);
+ -- Raises Container_Full if full (more useful than a precondition failure).
+
+ procedure Prepend (Container : in out Vector; New_Item : in Element_Type);
+ -- Insert New_Item at beginning of Container; current elements slide right.
+
+ procedure Insert
+ (Container : in out Vector;
+ New_Item : in Element_Type;
+ Before : in Extended_Index);
+ -- Insert New_Item before Before, or after Last_Index if Before is
+ -- No_Index. Current elements at Before and after slide right.
+ -- New_Item then has index Before.
+
+ function "+" (Item : in Element_Type) return Vector;
+ function "&" (Left : in Vector; Right : in Element_Type) return Vector;
+
+ procedure Delete_First (Container : in out Vector; Count : in Index_Type :=
1);
+ -- Remaining elements slide down.
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is null record
+ with Implicit_Dereference => Element;
+
+ function Constant_Reference (Container : aliased Vector; Index : in
Index_Type) return Constant_Reference_Type;
+
+ type Variable_Reference_Type (Element : not null access Element_Type) is
null record
+ with Implicit_Dereference => Element;
+
+ function Variable_Reference
+ (Container : aliased in out Vector;
+ Index : in Index_Type)
+ return Variable_Reference_Type;
+
+ type Cursor is private;
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ package Vector_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
+
+ function Iterate (Container : Vector) return
Vector_Iterator_Interfaces.Reversible_Iterator'Class;
+
+ function Constant_Reference (Container : aliased Vector; Position : in
Cursor) return Constant_Reference_Type;
+
+ function Variable_Reference
+ (Container : aliased in out Vector;
+ Position : in Cursor)
+ return Variable_Reference_Type;
+
+private
+
+ type Array_Type is array (Peek_Type range 1 .. Peek_Type (Capacity)) of
aliased Element_Type;
+
+ type Vector is tagged
+ record
+ Elements : Array_Type := (others => <>);
+ Last : Extended_Index := No_Index;
+ end record;
+
+ type Vector_Access is access all Vector;
+ for Vector_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Vector_Access;
+ Index : Index_Type := Index_Type'First;
+ end record;
+
+ type Iterator is new Vector_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Vector_Access;
+ Index : Index_Type'Base;
+ end record;
+
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ Empty_Vector : constant Vector := (others => <>);
+
+ ----------
+ -- For child units
+
+ function To_Peek_Index (Index : in Extended_Index) return Base_Peek_Type
+ with Inline;
+
+end SAL.Gen_Bounded_Definite_Vectors;
diff --git a/sal-gen_definite_doubly_linked_lists.adb
b/sal-gen_definite_doubly_linked_lists.adb
new file mode 100644
index 0000000..3855ae6
--- /dev/null
+++ b/sal-gen_definite_doubly_linked_lists.adb
@@ -0,0 +1,304 @@
+-- Abstract :
+--
+-- see spec
+--
+-- Copyright (C) 2017, 2018 Stephen Leake. All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This library is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
+-- MA 02111-1307, USA.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Definite_Doubly_Linked_Lists is
+
+ ---------
+ -- Public operations, declaration order.
+
+ overriding
+ procedure Adjust (Container : in out List)
+ is
+ Next_Source : Node_Access := Container.Head;
+ New_Node : Node_Access;
+ begin
+ if Next_Source = null then
+ return;
+ end if;
+
+ Container.Tail := null;
+
+ loop
+ New_Node := new Node_Type'
+ (Element => Next_Source.Element,
+ Next => null,
+ Prev => Container.Tail);
+ if Container.Tail = null then
+ Container.Head := New_Node;
+ Container.Tail := New_Node;
+ else
+ Container.Tail.Next := New_Node;
+ Container.Tail := New_Node;
+ end if;
+ Next_Source := Next_Source.Next;
+ exit when Next_Source = null;
+ end loop;
+ end Adjust;
+
+ overriding
+ procedure Finalize (Container : in out List)
+ is
+ Next : Node_Access := Container.Head;
+ begin
+ loop
+ exit when Next = null;
+ Next := Container.Head.Next;
+ Free (Container.Head);
+ Container.Head := Next;
+ end loop;
+ Container.Tail := null;
+ end Finalize;
+
+ function Length (Container : in List) return Ada.Containers.Count_Type
+ is begin
+ return Container.Count;
+ end Length;
+
+ procedure Append (Container : in out List; Element : in Element_Type)
+ is
+ use all type Ada.Containers.Count_Type;
+ New_Node : constant Node_Access := new Node_Type'
+ (Element => Element,
+ Prev => Container.Tail,
+ Next => null);
+ begin
+ if Container.Tail = null then
+ Container.Head := New_Node;
+ Container.Tail := New_Node;
+ else
+ Container.Tail.Next := New_Node;
+ Container.Tail := New_Node;
+ end if;
+ Container.Count := Container.Count + 1;
+ end Append;
+
+ procedure Prepend (Container : in out List; Element : in Element_Type)
+ is
+ use all type Ada.Containers.Count_Type;
+ New_Node : constant Node_Access := new Node_Type'
+ (Element => Element,
+ Prev => null,
+ Next => Container.Head);
+ begin
+ if Container.Tail = null then
+ Container.Head := New_Node;
+ Container.Tail := New_Node;
+ else
+ Container.Head.Prev := New_Node;
+ Container.Head := New_Node;
+ end if;
+ Container.Count := Container.Count + 1;
+ end Prepend;
+
+ function To_List (Element : in Element_Type) return List
+ is begin
+ return Result : List do
+ Result.Append (Element);
+ end return;
+ end To_List;
+
+ function Has_Element (Position : in Cursor) return Boolean
+ is begin
+ return Position.Ptr /= null;
+ end Has_Element;
+
+ function First (Container : in List) return Cursor
+ is begin
+ if Container.Head = null then
+ return No_Element;
+ else
+ return (Container'Unrestricted_Access, Container.Head);
+ end if;
+ end First;
+
+ function Last (Container : in List) return Cursor
+ is begin
+ if Container.Tail = null then
+ return No_Element;
+ else
+ return (Container'Unrestricted_Access, Container.Tail);
+ end if;
+ end Last;
+
+ procedure Next (Position : in out Cursor)
+ is begin
+ if Position.Ptr /= null then
+ if Position.Ptr.Next = null then
+ Position := No_Element;
+ else
+ Position.Ptr := Position.Ptr.Next;
+ end if;
+ end if;
+ end Next;
+
+ function Next (Position : in Cursor) return Cursor
+ is begin
+ if Position.Ptr = null then
+ return Position;
+ else
+ if Position.Ptr.Next = null then
+ return No_Element;
+ else
+ return (Position.Container, Position.Ptr.Next);
+ end if;
+ end if;
+ end Next;
+
+ function Previous (Position : in Cursor) return Cursor
+ is begin
+ if Position.Ptr = null then
+ return Position;
+ else
+ if Position.Ptr.Prev = null then
+ return No_Element;
+ else
+ return (Position.Container, Position.Ptr.Prev);
+ end if;
+ end if;
+ end Previous;
+
+ function Element (Position : in Cursor) return Element_Type
+ is begin
+ return Position.Ptr.Element;
+ end Element;
+
+ procedure Delete (Container : in out List; Position : in out Cursor)
+ is
+ use all type Ada.Containers.Count_Type;
+ Node : Node_Access renames Position.Ptr;
+ begin
+ if Node.Next = null then
+ Container.Tail := Node.Prev;
+ else
+ Node.Next.Prev := Node.Prev;
+ end if;
+ if Node.Prev = null then
+ Container.Head := Node.Next;
+ else
+ Node.Prev.Next := Node.Next;
+ end if;
+ Free (Node);
+ Position := No_Element;
+ Container.Count := Container.Count - 1;
+ end Delete;
+
+ procedure Insert
+ (Container : in out List;
+ Before : in Cursor;
+ Element : in Element_Type)
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Before = No_Element then
+ Container.Append (Element);
+ else
+ if Before.Ptr = Container.Head then
+ declare
+ -- old list: before ...
+ -- newlist: new before ...
+ New_Node : constant Node_Access := new Node_Type'
+ (Element => Element,
+ Prev => null,
+ Next => Before.Ptr);
+ begin
+ Before.Ptr.Prev := New_Node;
+ Container.Head := New_Node;
+ end;
+ else
+ declare
+ -- old list: ... prev before ...
+ -- newlist: ... prev new before ...
+ New_Node : constant Node_Access := new Node_Type'
+ (Element => Element,
+ Prev => Before.Ptr.Prev,
+ Next => Before.Ptr);
+ begin
+ Before.Ptr.Prev.Next := New_Node;
+ Before.Ptr.Prev := New_Node;
+
+ end;
+ end if;
+ Container.Count := Container.Count + 1;
+ end if;
+ end Insert;
+
+ function Persistent_Ref (Position : in Cursor) return access Element_Type
+ is begin
+ return Position.Ptr.Element'Access;
+ end Persistent_Ref;
+
+ function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ return (Element => Position.Ptr.all.Element'Access);
+ end Constant_Reference;
+
+ function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element'Access);
+ end Constant_Ref;
+
+ function Reference (Container : in List; Position : in Cursor) return
Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ return (Element => Position.Ptr.all.Element'Access);
+ end Reference;
+
+ function Ref (Position : in Cursor) return Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element'Access);
+ end Ref;
+
+ function Iterate (Container : aliased in List) return
Iterator_Interfaces.Reversible_Iterator'Class
+ is begin
+ return Iterator'(Container => Container'Unrestricted_Access);
+ end Iterate;
+
+ overriding function First (Object : Iterator) return Cursor
+ is begin
+ return First (Object.Container.all);
+ end First;
+
+ overriding function Last (Object : Iterator) return Cursor
+ is begin
+ return Last (Object.Container.all);
+ end Last;
+
+ overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
+ is
+ pragma Unreferenced (Object);
+ begin
+ return Next (Position);
+ end Next;
+
+ overriding function Previous (Object : in Iterator; Position : in Cursor)
return Cursor
+ is
+ pragma Unreferenced (Object);
+ begin
+ return Previous (Position);
+ end Previous;
+
+end SAL.Gen_Definite_Doubly_Linked_Lists;
diff --git a/sal-gen_definite_doubly_linked_lists.ads
b/sal-gen_definite_doubly_linked_lists.ads
new file mode 100644
index 0000000..203f9ad
--- /dev/null
+++ b/sal-gen_definite_doubly_linked_lists.ads
@@ -0,0 +1,159 @@
+-- Abstract :
+--
+-- A generic doubly linked list with definite elements, allowing
+-- permanent references to elements.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake. All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This library is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
+-- MA 02111-1307, USA.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers;
+with Ada.Finalization;
+with Ada.Iterator_Interfaces;
+with Ada.Unchecked_Deallocation;
+generic
+ type Element_Type is private;
+package SAL.Gen_Definite_Doubly_Linked_Lists is
+
+ type List is new Ada.Finalization.Controlled with private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
+ type List_Access_Constant is access constant List;
+ for List_Access_Constant'Storage_Size use 0;
+
+ type List_Access is access all List;
+ for List_Access'Storage_Size use 0;
+
+ Empty_List : constant List;
+
+ overriding procedure Adjust (Container : in out List);
+ -- Deep copy.
+
+ overriding procedure Finalize (Container : in out List);
+ -- Free all items in List.
+
+ function Length (Container : in List) return Ada.Containers.Count_Type;
+
+ procedure Append (Container : in out List; Element : in Element_Type);
+
+ procedure Prepend (Container : in out List; Element : in Element_Type);
+
+ function To_List (Element : in Element_Type) return List;
+
+ type Cursor is private;
+
+ No_Element : constant Cursor;
+
+ function Has_Element (Position : in Cursor) return Boolean;
+
+ function First (Container : in List) return Cursor;
+ function Last (Container : in List) return Cursor;
+
+ procedure Next (Position : in out Cursor)
+ with Pre => Position /= No_Element;
+
+ function Next (Position : in Cursor) return Cursor
+ with Pre => Position /= No_Element;
+ function Previous (Position : in Cursor) return Cursor
+ with Pre => Position /= No_Element;
+
+ function Element (Position : in Cursor) return Element_Type
+ with Pre => Position /= No_Element;
+
+ procedure Delete (Container : in out List; Position : in out Cursor)
+ with Pre => Position /= No_Element;
+
+ procedure Insert
+ (Container : in out List;
+ Before : in Cursor;
+ Element : in Element_Type);
+ -- If Before is No_Element, insert after Last.
+
+ function Persistent_Ref (Position : in Cursor) return access Element_Type
+ with Pre => Position /= No_Element;
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is null record
+ with Implicit_Dereference => Element;
+
+ function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type
+ with Pre => Position /= No_Element;
+ function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
+ with Pre => Position /= No_Element;
+
+ 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;
+ function Ref (Position : in Cursor) return Reference_Type
+ with Pre => Position /= No_Element;
+
+ package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
+
+ function Iterate (Container : aliased in List) return
Iterator_Interfaces.Reversible_Iterator'Class;
+
+private
+ type Node_Type;
+
+ type Node_Access is access Node_Type;
+
+ type Node_Type is record
+ Element : aliased Element_Type;
+ Prev : Node_Access;
+ Next : Node_Access;
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ type List is new Ada.Finalization.Controlled with record
+ Head : Node_Access := null;
+ Tail : Node_Access := null;
+ Count : Ada.Containers.Count_Type := 0;
+ end record;
+
+ type Cursor is record
+ Container : List_Access;
+ Ptr : Node_Access;
+ end record;
+
+ Empty_List : constant List := (Ada.Finalization.Controlled with null, null,
0);
+
+ No_Element : constant Cursor := (null, null);
+
+ type Iterator is new Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : List_Access;
+ end record;
+
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+end SAL.Gen_Definite_Doubly_Linked_Lists;
diff --git a/sal-gen_definite_doubly_linked_lists_sorted-gen_image.adb
b/sal-gen_definite_doubly_linked_lists_sorted-gen_image.adb
new file mode 100644
index 0000000..898a588
--- /dev/null
+++ b/sal-gen_definite_doubly_linked_lists_sorted-gen_image.adb
@@ -0,0 +1,47 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Unbounded;
+function SAL.Gen_Definite_Doubly_Linked_Lists_Sorted.Gen_Image
+ (Item : in List; Strict : in Boolean := False) return String
+is
+ use Ada.Strings;
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ Need_Comma : Boolean := False;
+begin
+ if Strict and Item.Length = 0 then
+ return "(1 .. 0 => <>)";
+
+ elsif Strict and Item.Length = 1 then
+ return "(1 => " & Element_Image (Element (Item.First)) & ")";
+
+ else
+ for El of Item loop
+ if Need_Comma then
+ Result := Result & ", ";
+ else
+ Need_Comma := True;
+ end if;
+ Result := Result & Element_Image (El);
+ end loop;
+ Result := Result & ")";
+ return To_String (Result);
+ end if;
+end SAL.Gen_Definite_Doubly_Linked_Lists_Sorted.Gen_Image;
diff --git a/sal-gen_definite_doubly_linked_lists_sorted-gen_image.ads
b/sal-gen_definite_doubly_linked_lists_sorted-gen_image.ads
new file mode 100644
index 0000000..2743f4e
--- /dev/null
+++ b/sal-gen_definite_doubly_linked_lists_sorted-gen_image.ads
@@ -0,0 +1,25 @@
+-- Abstract :
+--
+-- Image of parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ with function Element_Image (Item : in Element_Type) return String;
+function SAL.Gen_Definite_Doubly_Linked_Lists_Sorted.Gen_Image
+ (Item : in List; Strict : in Boolean := False) return String;
+-- Image of Item, in Ada aggregate syntax. If Strict, use correct
+-- syntax for 0 and 1 item; otherwise, use () and (item).
diff --git a/sal-gen_definite_doubly_linked_lists_sorted.adb
b/sal-gen_definite_doubly_linked_lists_sorted.adb
new file mode 100644
index 0000000..da99b3e
--- /dev/null
+++ b/sal-gen_definite_doubly_linked_lists_sorted.adb
@@ -0,0 +1,542 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Definite_Doubly_Linked_Lists_Sorted is
+
+ ----------
+ -- Body subprograms, alphabetical
+
+ procedure Find
+ (Container : in List;
+ Element : in Element_Type;
+ Found : out Node_Access;
+ Found_Compare : out Compare_Result)
+ is
+ -- Return pointer to first item in Container for which Compare (item,
+ -- element) returns True or Greater. If no such element exists, Found
+ -- is null, Found_Compare is Less.
+ use Ada.Containers;
+ begin
+ if Container.Head = null then
+ Found := null;
+ Found_Compare := Less;
+ return;
+ end if;
+
+ declare
+ Low_Index : Count_Type := 1;
+ High_Index : Count_Type := Container.Count;
+ Next_Node : Node_Access := Container.Head;
+ Next_Index : Count_Type := Low_Index;
+ Old_Index : Count_Type;
+ begin
+ loop
+ Old_Index := Next_Index;
+ Next_Index := (Low_Index + High_Index) / 2;
+
+ if Next_Index > Old_Index then
+ for I in Old_Index + 1 .. Next_Index loop
+ Next_Node := Next_Node.Next;
+ end loop;
+ elsif Next_Index < Old_Index then
+ for I in Next_Index .. Old_Index - 1 loop
+ Next_Node := Next_Node.Prev;
+ end loop;
+ end if;
+
+ case Element_Compare (Next_Node.Element, Element) is
+ when Less =>
+ if Next_Index = High_Index then
+ -- no more nodes to check
+ Found := null;
+ Found_Compare := Less;
+ return;
+ elsif Next_Index = Low_Index then
+ -- force check of high_index
+ Low_Index := High_Index;
+ else
+ Low_Index := Next_Index;
+ end if;
+
+ when Equal =>
+ Found := Next_Node;
+ Found_Compare := Equal;
+ return;
+
+ when Greater =>
+ if Low_Index = Next_Index then
+ -- no more nodes to check
+ Found := Next_Node;
+ Found_Compare := Greater;
+ return;
+ elsif High_Index = Next_Index then
+ -- Desired result is either high_index or low_index
+ pragma Assert (Low_Index + 1 = High_Index);
+ case Element_Compare (Next_Node.Prev.Element, Element) is
+ when Less =>
+ Found := Next_Node;
+ Found_Compare := Greater;
+ return;
+ when Equal =>
+ Found := Next_Node.Prev;
+ Found_Compare := Equal;
+ return;
+ when Greater =>
+ Found := Next_Node.Prev;
+ Found_Compare := Greater;
+ return;
+ end case;
+ else
+ High_Index := Next_Index;
+ end if;
+ end case;
+ end loop;
+ end;
+ end Find;
+
+ procedure Insert_Before
+ (Container : in out List;
+ Before : in Node_Access;
+ Element : in Element_Type)
+ is
+ New_Node : constant Node_Access := new Node_Type'
+ (Element => Element,
+ Prev => Before.Prev,
+ Next => Before);
+ begin
+ if Before = Container.Head then
+ Before.Prev := New_Node;
+ Container.Head := New_Node;
+ else
+ Before.Prev.Next := New_Node;
+ Before.Prev := New_Node;
+ end if;
+ end Insert_Before;
+
+ procedure Insert_After_Tail
+ (Container : in out List;
+ Element : in Element_Type)
+ is
+ New_Node : constant Node_Access := new Node_Type'
+ (Element => Element,
+ Prev => Container.Tail,
+ Next => null);
+ begin
+ Container.Tail.Next := New_Node;
+ Container.Tail := New_Node;
+ end Insert_After_Tail;
+
+ ---------
+ -- Public operations, declaration order.
+
+ overriding
+ procedure Adjust (Container : in out List)
+ is
+ Next_Source : Node_Access := Container.Head;
+ New_Node : Node_Access;
+ begin
+ if Next_Source = null then
+ return;
+ end if;
+
+ Container.Tail := null;
+
+ loop
+ New_Node := new Node_Type'
+ (Element => Next_Source.Element,
+ Next => null,
+ Prev => Container.Tail);
+ if Container.Tail = null then
+ Container.Head := New_Node;
+ Container.Tail := New_Node;
+ else
+ Container.Tail.Next := New_Node;
+ Container.Tail := New_Node;
+ end if;
+ Next_Source := Next_Source.Next;
+ exit when Next_Source = null;
+ end loop;
+ end Adjust;
+
+ overriding
+ procedure Finalize (Container : in out List)
+ is
+ Next : Node_Access := Container.Head;
+ begin
+ loop
+ exit when Next = null;
+ Next := Container.Head.Next;
+ Free (Container.Head);
+ Container.Head := Next;
+ end loop;
+ Container.Tail := null;
+ end Finalize;
+
+ overriding function "=" (Left, Right : in List) return Boolean
+ is
+ Left_I : Node_Access := Left.Head;
+ Right_I : Node_Access := Right.Head;
+ begin
+ loop
+ exit when Left_I = null;
+
+ if Right_I = null then
+ return False;
+ elsif Left_I.Element /= Right_I.Element then
+ return False;
+ end if;
+
+ Left_I := Left_I.Next;
+ Right_I := Right_I.Next;
+ end loop;
+ return Right_I = null;
+ end "=";
+
+ function Length (Container : in List) return Ada.Containers.Count_Type
+ is begin
+ return Container.Count;
+ end Length;
+
+ function To_List (Element : in Element_Type) return List
+ is
+ New_Node : constant Node_Access := new Node_Type'
+ (Element => Element,
+ Prev => null,
+ Next => null);
+ begin
+ return Result : constant List :=
+ (Ada.Finalization.Controlled with
+ Head => New_Node,
+ Tail => New_Node,
+ Count => 1);
+ end To_List;
+
+ procedure Insert (Container : in out List; Element : in Element_Type)
+ is
+ Node : Node_Access := Container.Head;
+ Compare : Compare_Result;
+ begin
+ if Node = null then
+ Container := To_List (Element);
+ else
+ Find (Container, Element, Node, Compare);
+
+ Container.Count := Container.Count + 1;
+
+ if Node = null then
+ Insert_After_Tail (Container, Element);
+ else
+ Insert_Before (Container, Node, Element);
+ end if;
+ end if;
+ end Insert;
+
+ function Contains (Container : in List; Element : in Element_Type) return
Boolean
+ is
+ Node : Node_Access := Container.Head;
+ Compare : Compare_Result;
+ begin
+ Find (Container, Element, Node, Compare);
+ return Compare = Equal;
+ end Contains;
+
+ procedure Merge
+ (Target : in out List;
+ Source : in List;
+ Added : out Boolean)
+ is
+ Target_I : Node_Access := Target.Head;
+ Source_I : Node_Access := Source.Head;
+ begin
+ if Target_I = null then
+ if Source_I = null then
+ Added := False;
+ else
+ Target.Head := Source.Head;
+ Target.Tail := Source.Tail;
+ Target.Count := Source.Count;
+ Adjust (Target);
+
+ Added := True;
+ end if;
+
+ elsif Source_I = null then
+ Added := False;
+
+ else
+ Added := False;
+ loop
+ exit when Source_I = null;
+
+ if Target_I = null then
+ Added := True;
+ Target.Count := Target.Count + 1;
+ Insert_After_Tail (Target, Source_I.Element);
+ Source_I := Source_I.Next;
+
+ else
+ case Element_Compare (Target_I.Element, Source_I.Element) is
+ when Greater =>
+ Added := True;
+ Target.Count := Target.Count + 1;
+ Insert_Before (Target, Target_I, Source_I.Element);
+ Source_I := Source_I.Next;
+
+ when Equal =>
+ Target_I := Target_I.Next;
+ Source_I := Source_I.Next;
+
+ when Less =>
+ Target_I := Target_I.Next;
+ end case;
+ end if;
+ end loop;
+ end if;
+ end Merge;
+
+ procedure Merge
+ (Target : in out List;
+ Source : in List;
+ Added : out Boolean;
+ Exclude : in Element_Type)
+ is
+ Target_I : Node_Access := Target.Head;
+ Source_I : Node_Access := Source.Head;
+ begin
+ Added := False;
+
+ if Target_I = null then
+ if Source_I = null then
+ return;
+ else
+ loop
+ if Source_I = null then
+ return;
+ end if;
+ exit when Source_I.Element /= Exclude;
+ Source_I := Source_I.Next;
+ end loop;
+
+ Added := True;
+ Target := To_List (Source_I.Element);
+ Source_I := Source_I.Next;
+ end if;
+ end if;
+
+ loop
+ exit when Source_I = null;
+
+ if Source_I.Element = Exclude then
+ Source_I := Source_I.Next;
+
+ elsif Target_I = null then
+ Added := True;
+ Target.Count := Target.Count + 1;
+ Insert_After_Tail (Target, Source_I.Element);
+ Source_I := Source_I.Next;
+
+ else
+ case Element_Compare (Target_I.Element, Source_I.Element) is
+ when Greater =>
+ Added := True;
+ Target.Count := Target.Count + 1;
+ Insert_Before (Target, Target_I, Source_I.Element);
+ Source_I := Source_I.Next;
+
+ when Equal =>
+ Target_I := Target_I.Next;
+ Source_I := Source_I.Next;
+
+ when Less =>
+ Target_I := Target_I.Next;
+ end case;
+ end if;
+ end loop;
+ end Merge;
+
+ function Has_Element (Position : in Cursor) return Boolean
+ is begin
+ return Position.Ptr /= null;
+ end Has_Element;
+
+ function First (Container : in List) return Cursor
+ is begin
+ if Container.Head = null then
+ return No_Element;
+ else
+ return (Container'Unrestricted_Access, Container.Head);
+ end if;
+ end First;
+
+ function Last (Container : in List) return Cursor
+ is begin
+ if Container.Tail = null then
+ return No_Element;
+ else
+ return (Container'Unrestricted_Access, Container.Tail);
+ end if;
+ end Last;
+
+ function Find (Container : in List; Element : in Element_Type) return Cursor
+ is
+ Node : Node_Access;
+ Compare : Compare_Result;
+ begin
+ Find (Container, Element, Node, Compare);
+
+ if Node = null then
+ return No_Element;
+ elsif Compare = Equal then
+ return (Container'Unrestricted_Access, Node);
+ else
+ return No_Element;
+ end if;
+ end Find;
+
+ procedure Next (Position : in out Cursor)
+ is begin
+ if Position.Ptr /= null then
+ if Position.Ptr.Next = null then
+ Position := No_Element;
+ else
+ Position.Ptr := Position.Ptr.Next;
+ end if;
+ end if;
+ end Next;
+
+ function Next (Position : in Cursor) return Cursor
+ is begin
+ if Position.Ptr = null then
+ return Position;
+ else
+ if Position.Ptr.Next = null then
+ return No_Element;
+ else
+ return (Position.Container, Position.Ptr.Next);
+ end if;
+ end if;
+ end Next;
+
+ function Previous (Position : in Cursor) return Cursor
+ is begin
+ if Position.Ptr = null then
+ return Position;
+ else
+ if Position.Ptr.Prev = null then
+ return No_Element;
+ else
+ return (Position.Container, Position.Ptr.Prev);
+ end if;
+ end if;
+ end Previous;
+
+ function Element (Position : in Cursor) return Element_Type
+ is begin
+ return Position.Ptr.Element;
+ end Element;
+
+ procedure Delete (Container : in out List; Position : in out Cursor)
+ is
+ Node : Node_Access renames Position.Ptr;
+ begin
+ if Node.Next = null then
+ Container.Tail := Node.Prev;
+ else
+ Node.Next.Prev := Node.Prev;
+ end if;
+ if Node.Prev = null then
+ Container.Head := Node.Next;
+ else
+ Node.Prev.Next := Node.Next;
+ end if;
+ Free (Node);
+ Position := No_Element;
+ Container.Count := Container.Count - 1;
+ end Delete;
+
+ function Pop (Container : in out List) return Element_Type
+ is
+ Node : Node_Access := Container.Head;
+ begin
+ return Result : constant Element_Type := Container.Head.Element do
+ Container.Head := Node.Next;
+ if Node.Next = null then
+ Container.Tail := null;
+ else
+ Node.Next.Prev := null;
+ end if;
+ Free (Node);
+ Container.Count := Container.Count - 1;
+ end return;
+ end Pop;
+
+ function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ return (Element => Position.Ptr.all.Element'Access);
+ end Constant_Reference;
+
+ function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element'Access);
+ end Constant_Ref;
+
+ function Reference (Container : in List; Position : in Cursor) return
Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ return (Element => Position.Ptr.all.Element'Access);
+ end Reference;
+
+ function Ref (Position : in Cursor) return Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element'Access);
+ end Ref;
+
+ function Iterate (Container : aliased in List) return
Iterator_Interfaces.Reversible_Iterator'Class
+ is begin
+ return Iterator'(Container => Container'Unrestricted_Access);
+ end Iterate;
+
+ overriding function First (Object : Iterator) return Cursor
+ is begin
+ return First (Object.Container.all);
+ end First;
+
+ overriding function Last (Object : Iterator) return Cursor
+ is begin
+ return Last (Object.Container.all);
+ end Last;
+
+ overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
+ is
+ pragma Unreferenced (Object);
+ begin
+ return Next (Position);
+ end Next;
+
+ overriding function Previous (Object : in Iterator; Position : in Cursor)
return Cursor
+ is
+ pragma Unreferenced (Object);
+ begin
+ return Previous (Position);
+ end Previous;
+
+end SAL.Gen_Definite_Doubly_Linked_Lists_Sorted;
diff --git a/sal-gen_definite_doubly_linked_lists_sorted.ads
b/sal-gen_definite_doubly_linked_lists_sorted.ads
new file mode 100644
index 0000000..464ff86
--- /dev/null
+++ b/sal-gen_definite_doubly_linked_lists_sorted.ads
@@ -0,0 +1,175 @@
+-- Abstract :
+--
+-- A generic sorted doubly linked list with definite elements.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with Ada.Iterator_Interfaces;
+with Ada.Unchecked_Deallocation;
+generic
+ type Element_Type is private;
+ with function Element_Compare (Left, Right : in Element_Type) return
Compare_Result;
+package SAL.Gen_Definite_Doubly_Linked_Lists_Sorted is
+ use all type Ada.Containers.Count_Type;
+
+ type List is new Ada.Finalization.Controlled with private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
+ -- If user uses Variable_Indexing, they must not change the sort
+ -- order of the elements.
+
+ type List_Access is access all List;
+ for List_Access'Storage_Size use 0;
+
+ Empty_List : constant List;
+
+ overriding procedure Adjust (Container : in out List);
+ -- Deep copy.
+
+ overriding procedure Finalize (Container : in out List);
+ -- Free all items in List.
+
+ overriding function "=" (Left, Right : in List) return Boolean;
+ -- True if contents are the same.
+
+ function Length (Container : in List) return Ada.Containers.Count_Type;
+
+ function To_List (Element : in Element_Type) return List;
+
+ procedure Insert (Container : in out List; Element : in Element_Type);
+ -- Insert Element before first item for which Element_Order (item,
+ -- element) returns True.
+
+ function Contains (Container : in List; Element : in Element_Type) return
Boolean;
+
+ procedure Merge
+ (Target : in out List;
+ Source : in List;
+ Added : out Boolean);
+ -- Add all elements of Source to Target, if they are not already
+ -- present.
+ --
+ -- Added is True if any element was not already present.
+
+ procedure Merge
+ (Target : in out List;
+ Source : in List;
+ Added : out Boolean;
+ Exclude : in Element_Type);
+ -- Add all elements of Source to Target, if they are not already
+ -- present, and are not equal to Exclude.
+ --
+ -- Added is True if any element was not already present.
+
+ type Cursor is private;
+
+ No_Element : constant Cursor;
+
+ function Has_Element (Position : in Cursor) return Boolean;
+
+ function First (Container : in List) return Cursor;
+ function Last (Container : in List) return Cursor;
+
+ function Find (Container : in List; Element : in Element_Type) return
Cursor;
+ -- No_Element if Element not found.
+
+ procedure Next (Position : in out Cursor)
+ with Pre => Position /= No_Element;
+
+ function Next (Position : in Cursor) return Cursor
+ with Pre => Position /= No_Element;
+ function Previous (Position : in Cursor) return Cursor
+ with Pre => Position /= No_Element;
+
+ function Element (Position : in Cursor) return Element_Type
+ with Pre => Position /= No_Element;
+
+ procedure Delete (Container : in out List; Position : in out Cursor)
+ with Pre => Position /= No_Element;
+
+ function Pop (Container : in out List) return Element_Type
+ with Pre => Container.Length > 0;
+ -- Return Container.First, delete it from Container.
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is null record
+ with Implicit_Dereference => Element;
+
+ function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type;
+ function Constant_Ref (Position : in Cursor) return Constant_Reference_Type;
+
+ 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;
+ function Ref (Position : in Cursor) return Reference_Type
+ with Pre => Position /= No_Element;
+ -- 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);
+
+ function Iterate (Container : aliased in List) return
Iterator_Interfaces.Reversible_Iterator'Class;
+
+private
+ type Node_Type;
+
+ type Node_Access is access Node_Type;
+
+ type Node_Type is record
+ Element : aliased Element_Type;
+ Prev : Node_Access;
+ Next : Node_Access;
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ type List is new Ada.Finalization.Controlled with record
+ Head : Node_Access := null;
+ Tail : Node_Access := null;
+ Count : Ada.Containers.Count_Type := 0;
+ end record;
+
+ type Cursor is record
+ Container : List_Access;
+ Ptr : Node_Access;
+ end record;
+
+ Empty_List : constant List := (Ada.Finalization.Controlled with null, null,
0);
+
+ No_Element : constant Cursor := (null, null);
+
+ type Iterator is new Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : List_Access;
+ end record;
+
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+end SAL.Gen_Definite_Doubly_Linked_Lists_Sorted;
diff --git a/sal-gen_indefinite_doubly_linked_lists.adb
b/sal-gen_indefinite_doubly_linked_lists.adb
new file mode 100644
index 0000000..079e736
--- /dev/null
+++ b/sal-gen_indefinite_doubly_linked_lists.adb
@@ -0,0 +1,201 @@
+-- Abstract :
+--
+-- see spec
+--
+-- Copyright (C) 2018 Stephen Leake. All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This library is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
+-- MA 02111-1307, USA.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Indefinite_Doubly_Linked_Lists is
+
+ ---------
+ -- Public operations, declaration order.
+
+ overriding
+ procedure Adjust (Container : in out List)
+ is
+ Source : Node_Access := Container.Head;
+ New_Node : Node_Access;
+ begin
+ if Source = null then
+ return;
+ end if;
+
+ Container.Tail := null;
+
+ loop
+ New_Node := new Node_Type'
+ (Element => new Element_Type'(Source.Element.all),
+ Next => null,
+ Prev => Container.Tail);
+ if Container.Tail = null then
+ Container.Head := New_Node;
+ Container.Tail := New_Node;
+ else
+ Container.Tail.Next := New_Node;
+ Container.Tail := New_Node;
+ end if;
+ Source := Source.Next;
+ exit when Source = null;
+ end loop;
+ end Adjust;
+
+ overriding
+ procedure Finalize (Container : in out List)
+ is
+ Next : Node_Access := Container.Head;
+ begin
+ loop
+ exit when Next = null;
+ Next := Container.Head.Next;
+ Free (Container.Head.Element);
+ Free (Container.Head);
+ Container.Head := Next;
+ end loop;
+ Container.Tail := null;
+ end Finalize;
+
+ function Length (Container : in List) return SAL.Base_Peek_Type
+ is begin
+ return Container.Count;
+ end Length;
+
+ procedure Append (Container : in out List; Element : in Element_Type)
+ is
+ New_Node : constant Node_Access := new Node_Type'
+ (Element => new Element_Type'(Element),
+ Prev => Container.Tail,
+ Next => null);
+ begin
+ if Container.Tail = null then
+ Container.Head := New_Node;
+ Container.Tail := New_Node;
+ else
+ Container.Tail.Next := New_Node;
+ Container.Tail := New_Node;
+ end if;
+ Container.Count := Container.Count + 1;
+ end Append;
+
+ procedure Prepend (Container : in out List; Element : in Element_Type)
+ is
+ New_Node : constant Node_Access := new Node_Type'
+ (Element => new Element_Type'(Element),
+ Prev => null,
+ Next => Container.Head);
+ begin
+ if Container.Tail = null then
+ Container.Head := New_Node;
+ Container.Tail := New_Node;
+ else
+ Container.Head.Prev := New_Node;
+ Container.Head := New_Node;
+ end if;
+ Container.Count := Container.Count + 1;
+ end Prepend;
+
+ function Has_Element (Position : in Cursor) return Boolean
+ is begin
+ return Position.Ptr /= null;
+ end Has_Element;
+
+ function First (Container : in List) return Cursor
+ is begin
+ if Container.Head = null then
+ return No_Element;
+ else
+ return (Container'Unrestricted_Access, Container.Head);
+ end if;
+ end First;
+
+ procedure Next (Position : in out Cursor)
+ is begin
+ if Position.Ptr /= null then
+ if Position.Ptr.Next = null then
+ Position := No_Element;
+ else
+ Position.Ptr := Position.Ptr.Next;
+ end if;
+ end if;
+ end Next;
+
+ function Next (Position : in Cursor) return Cursor
+ is begin
+ if Position.Ptr = null then
+ return Position;
+ else
+ if Position.Ptr.Next = null then
+ return No_Element;
+ else
+ return (Position.Container, Position.Ptr.Next);
+ end if;
+ end if;
+ end Next;
+
+ function Element (Position : in Cursor) return Element_Type
+ is begin
+ return Position.Ptr.Element.all;
+ end Element;
+
+ procedure Delete (Container : in out List; Position : in out Cursor)
+ is
+ Node : Node_Access renames Position.Ptr;
+ begin
+ if Node.Next = null then
+ Container.Tail := Node.Prev;
+ else
+ Node.Next.Prev := Node.Prev;
+ end if;
+ if Node.Prev = null then
+ Container.Head := Node.Next;
+ else
+ Node.Prev.Next := Node.Next;
+ end if;
+ Free (Node.Element);
+ Free (Node);
+ Position := No_Element;
+ Container.Count := Container.Count - 1;
+ end Delete;
+
+ function Persistent_Ref (Position : in Cursor) return access Element_Type
+ is begin
+ return Position.Ptr.Element;
+ end Persistent_Ref;
+
+ function Constant_Reference (Position : in Cursor) return
Constant_Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element);
+ end Constant_Reference;
+
+ function Constant_Ref (Container : in List'Class; Position : in Peek_Type)
return Constant_Reference_Type
+ is
+ Ptr : Node_Access := Container.Head;
+ begin
+ for I in 2 .. Position loop
+ Ptr := Ptr.Next;
+ end loop;
+ return (Element => Ptr.all.Element);
+ end Constant_Ref;
+
+ function Reference (Position : in Cursor) return Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element);
+ end Reference;
+
+end SAL.Gen_Indefinite_Doubly_Linked_Lists;
diff --git a/sal-gen_indefinite_doubly_linked_lists.ads
b/sal-gen_indefinite_doubly_linked_lists.ads
new file mode 100644
index 0000000..f477f2d
--- /dev/null
+++ b/sal-gen_indefinite_doubly_linked_lists.ads
@@ -0,0 +1,114 @@
+-- Abstract :
+--
+-- A generic doubly linked list with indefinite elements, allowing
+-- permanent references to elements.
+--
+-- Copyright (C) 2018 Stephen Leake. All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This library is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
+-- MA 02111-1307, USA.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with Ada.Unchecked_Deallocation;
+generic
+ type Element_Type (<>) is private;
+package SAL.Gen_Indefinite_Doubly_Linked_Lists is
+
+ type List is new Ada.Finalization.Controlled with private;
+
+ Empty_List : constant List;
+
+ overriding procedure Adjust (Container : in out List);
+ -- Deep copy.
+
+ overriding procedure Finalize (Container : in out List);
+ -- Free all items in List.
+
+ function Length (Container : in List) return Base_Peek_Type;
+
+ procedure Append (Container : in out List; Element : in Element_Type);
+
+ procedure Prepend (Container : in out List; Element : in Element_Type);
+
+ type Cursor is private;
+
+ No_Element : constant Cursor;
+
+ function Has_Element (Position : in Cursor) return Boolean;
+
+ function First (Container : in List) return Cursor;
+
+ procedure Next (Position : in out Cursor);
+
+ function Next (Position : in Cursor) return Cursor;
+
+ function Element (Position : in Cursor) return Element_Type
+ with Pre => Has_Element (Position);
+
+ procedure Delete (Container : in out List; Position : in out Cursor)
+ with Pre => Has_Element (Position);
+
+ function Persistent_Ref (Position : in Cursor) return access Element_Type
+ with Pre => Has_Element (Position);
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is null record
+ with Implicit_Dereference => Element;
+
+ function Constant_Reference (Position : in Cursor) return
Constant_Reference_Type
+ with Pre => Has_Element (Position);
+
+ function Constant_Ref (Container : in List'Class; Position : in Peek_Type)
return Constant_Reference_Type
+ with Pre => Position <= Container.Length;
+
+ 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);
+
+private
+ type Node_Type;
+ type Node_Access is access Node_Type;
+ type Element_Access is access Element_Type;
+
+
+ type Node_Type is record
+ Element : Element_Access;
+ Prev : Node_Access;
+ Next : Node_Access;
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+ procedure Free is new Ada.Unchecked_Deallocation (Element_Type,
Element_Access);
+
+ type List is new Ada.Finalization.Controlled with record
+ Head : Node_Access := null;
+ Tail : Node_Access := null;
+ Count : SAL.Base_Peek_Type := 0;
+ end record;
+
+ type Cursor is record
+ Container : access List;
+ Ptr : Node_Access;
+ end record;
+
+ Empty_List : constant List := (Ada.Finalization.Controlled with null, null,
0);
+
+ No_Element : constant Cursor := (null, null);
+
+end SAL.Gen_Indefinite_Doubly_Linked_Lists;
diff --git a/sal-gen_trimmed_image.adb b/sal-gen_trimmed_image.adb
new file mode 100644
index 0000000..41fb042
--- /dev/null
+++ b/sal-gen_trimmed_image.adb
@@ -0,0 +1,28 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings;
+with Ada.Strings.Fixed;
+function SAL.Gen_Trimmed_Image (Item : in Element_Type) return String
+is
+ use Ada.Strings;
+ use Ada.Strings.Fixed;
+begin
+ return Trim (Element_Type'Image (Item), Both);
+end SAL.Gen_Trimmed_Image;
diff --git a/sal-gen_trimmed_image.ads b/sal-gen_trimmed_image.ads
new file mode 100644
index 0000000..faf782f
--- /dev/null
+++ b/sal-gen_trimmed_image.ads
@@ -0,0 +1,23 @@
+-- Abstract :
+--
+-- Generic trimmed image.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Element_Type is range <>;
+function SAL.Gen_Trimmed_Image (Item : in Element_Type) return String;
+-- Return image of Item with no leading space.
diff --git a/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
b/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
new file mode 100644
index 0000000..75b9478
--- /dev/null
+++ b/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
@@ -0,0 +1,340 @@
+-- Abstract:
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Unchecked_Deallocation;
+with Long_Float_Elementary_Functions;
+package body SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci is
+
+ ----------
+ -- local subprogram specs (as needed), alphabetical order
+
+ procedure Insert_Into_Root_List (Heap : in out Heap_Type; X : in
Node_Access);
+
+ procedure Link (Y, X : in Node_Access);
+
+ procedure Remove_From_List (X : in Node_Access);
+
+ procedure Swap (A, B : in out Node_Access);
+
+ ----------
+ -- local subprogram bodies, alphabetical order
+
+ function Add (Heap : in out Heap_Type; Item : in Element_Type) return
Node_Access
+ is
+ X : constant Node_Access := new Node'(Item, null, null, null, null, 0,
False);
+ begin
+ -- [1] 19.2 FIB-HEAP-INSERT
+ if Heap.Min = null then
+ Heap.Min := X;
+ Heap.Min.Left := Heap.Min;
+ Heap.Min.Right := Heap.Min;
+ else
+ Insert_Into_Root_List (Heap, X);
+
+ if Key (Item) < Key (Heap.Min.Element) then
+ Heap.Min := X;
+ end if;
+ end if;
+ Heap.Count := Heap.Count + 1;
+
+ return X;
+ end Add;
+
+ procedure Consolidate (Heap : in out Heap_Type)
+ is
+ -- [1] 19.4 max degree of Fibonacci heap
+ Phi : constant := 1.61803398874989484820458683436563811772; --
https://oeis.org/A001622/constant
+ Max_Degree : constant Integer := Integer
+ (Long_Float_Elementary_Functions.Log (Long_Float (Heap.Count), Base =>
Phi));
+
+ -- [1] 19.2 CONSOLIDATE
+ A : array (0 .. Max_Degree) of Node_Access := (others => null);
+
+ W : Node_Access := Heap.Min;
+ Last : Node_Access := Heap.Min;
+ X, Y : Node_Access;
+ D : Integer;
+
+ Min_Key : Key_Type;
+ begin
+ loop
+ X := W;
+ W := W.Right;
+
+ D := X.Degree;
+
+ loop
+ exit when A (D) = null;
+
+ Y := A (D);
+ if Key (Y.Element) < Key (X.Element) then
+ Swap (X, Y);
+ end if;
+ if Y = Last and W /= Last then
+ Last := Y.Right;
+ end if;
+ Link (Y, X);
+ A (D) := null;
+ D := D + 1;
+ exit when D = A'Last;
+ end loop;
+
+ A (D) := X;
+
+ exit when W = Last;
+ end loop;
+
+ Heap.Min := null;
+ for I in A'Range loop
+ if A (I) /= null then
+ if Heap.Min = null then
+ Heap.Min := A (I);
+ Heap.Min.Left := Heap.Min;
+ Heap.Min.Right := Heap.Min;
+ Min_Key := Key (Heap.Min.Element);
+ else
+ Insert_Into_Root_List (Heap, A (I));
+ if Key (A (I).Element) < Min_Key then
+ Heap.Min := A (I);
+ Min_Key := Key (A (I).Element);
+ end if;
+ end if;
+ end if;
+ end loop;
+ end Consolidate;
+
+ procedure Copy_Node (Old_Obj : in Node_Access; New_Obj : in out Heap_Type)
+ is
+ Child : Node_Access;
+ begin
+ if Old_Obj = null then
+ return;
+ end if;
+
+ if Old_Obj.Child /= null then
+ Child := Old_Obj.Child;
+
+ loop
+ Add (New_Obj, Child.Element);
+ Child := Child.Right;
+ exit when Child = Old_Obj.Child;
+ end loop;
+ end if;
+
+ Add (New_Obj, Old_Obj.Element);
+ end Copy_Node;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Access);
+
+ procedure Free_Node (Item : in out Node_Access)
+ is
+ Child : Node_Access;
+ Temp : Node_Access;
+ begin
+ if Item = null then
+ return;
+ end if;
+
+ -- Parent has already been free'd
+ -- Siblings are freed by caller
+
+ -- Free children
+ if Item.Child /= null then
+ Child := Item.Child;
+
+ loop
+ Temp := Child;
+ Child := Child.Right;
+ Free_Node (Temp);
+ exit when Child = Item.Child;
+ end loop;
+ end if;
+ Free (Item);
+ end Free_Node;
+
+ procedure Insert_Into_Root_List (Heap : in out Heap_Type; X : in
Node_Access)
+ is begin
+ -- match [1] fig 19.3
+ X.Right := Heap.Min;
+ X.Left := Heap.Min.Left;
+ Heap.Min.Left.Right := X;
+ Heap.Min.Left := X;
+ end Insert_Into_Root_List;
+
+ procedure Link (Y, X : in Node_Access)
+ is begin
+ -- [1] 19.2 FIB-HEAP-LINK
+ Remove_From_List (Y);
+ Y.Parent := X;
+ X.Degree := X.Degree + 1;
+ if X.Child = null then
+ X.Child := Y;
+ Y.Right := Y;
+ Y.Left := Y;
+ else
+ -- Insert Y into X child list
+ Y.Right := X.Child;
+ Y.Left := X.Child.Left;
+ X.Child.Left.Right := Y;
+ X.Child.Left := Y;
+ end if;
+ Y.Mark := False;
+ end Link;
+
+ procedure Remove_From_List (X : in Node_Access)
+ is begin
+ X.Left.Right := X.Right;
+ X.Right.Left := X.Left;
+ end Remove_From_List;
+
+ procedure Swap (A, B : in out Node_Access)
+ is
+ C : constant Node_Access := A;
+ begin
+ A := B;
+ B := C;
+ end Swap;
+
+ ----------
+ -- Visible operations
+
+ overriding
+ procedure Initialize (Object : in out Heap_Type)
+ is begin
+ -- Min is null by default.
+ Object.Count := 0;
+ end Initialize;
+
+ overriding
+ procedure Finalize (Object : in out Heap_Type)
+ is
+ Next : Node_Access := Object.Min;
+ Temp : Node_Access;
+ begin
+ if Next = null then
+ return;
+ end if;
+
+ loop
+ Temp := Next;
+ Next := Next.Right;
+ Free_Node (Temp);
+ exit when Next = Object.Min;
+ end loop;
+ Object.Min := null;
+ Object.Count := 0;
+ end Finalize;
+
+ overriding
+ procedure Adjust (Object : in out Heap_Type)
+ is
+ Old_Obj : Node_Access := Object.Min;
+ Last : constant Node_Access := Old_Obj;
+ begin
+ if Old_Obj = null then
+ return;
+ end if;
+
+ Object.Min := null;
+ Object.Count := 0;
+
+ loop
+ Copy_Node (Old_Obj, Object);
+ Old_Obj := Old_Obj.Right;
+ exit when Old_Obj = Last;
+ end loop;
+ end Adjust;
+
+ procedure Clear (Heap : in out Heap_Type)
+ is begin
+ Finalize (Heap);
+ end Clear;
+
+ function Count (Heap : in Heap_Type) return Base_Peek_Type
+ is begin
+ return Heap.Count;
+ end Count;
+
+ function Remove (Heap : in out Heap_Type) return Element_Type
+ is
+ Z : Node_Access := Heap.Min;
+ Child, Temp : Node_Access;
+ begin
+ if Heap.Count = 0 then
+ raise Container_Empty;
+ end if;
+
+ -- [1] 19.2 FIB-HEAP-EXTRACT-MIN
+ Child := Z.Child;
+ for I in 1 .. Z.Degree loop
+ Temp := Child;
+ Child := Child.Right;
+ Temp.Parent := null;
+ Insert_Into_Root_List (Heap, Temp);
+ end loop;
+
+ Remove_From_List (Z);
+
+ if Z.Right = Z then
+ Heap.Min := null;
+ else
+ Heap.Min := Z.Right;
+ Consolidate (Heap);
+ end if;
+ Heap.Count := Heap.Count - 1;
+
+ return Result : constant Element_Type := Z.Element do
+ Free (Z);
+ end return;
+ end Remove;
+
+ function Min_Key (Heap : in out Heap_Type) return Key_Type
+ is begin
+ return Key (Heap.Min.Element);
+ end Min_Key;
+
+ procedure Drop (Heap : in out Heap_Type)
+ is
+ Junk : Element_Type := Remove (Heap);
+ pragma Unreferenced (Junk);
+ begin
+ null;
+ end Drop;
+
+ procedure Add (Heap : in out Heap_Type; Item : in Element_Type)
+ is
+ X : constant Node_Access := Add (Heap, Item);
+ pragma Unreferenced (X);
+ begin
+ null;
+ end Add;
+
+ function Add (Heap : in out Heap_Type; Item : in Element_Type) return
Element_Access
+ is
+ X : constant Node_Access := Add (Heap, Item);
+ begin
+ return X.all.Element'Access;
+ end Add;
+
+ function Peek (Heap : in Heap_Type) return Constant_Reference_Type
+ is begin
+ return (Element => Heap.Min.all.Element'Access);
+ end Peek;
+
+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
new file mode 100644
index 0000000..381bd35
--- /dev/null
+++ b/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
@@ -0,0 +1,114 @@
+-- Abstract:
+--
+-- An unbounded minimum Fibonacci heap of definite non-limited elements.
+--
+-- References:
+--
+-- [1] Introduction to Algorithms, Third Edition. Thomas H. Cormen,
+-- Charles E. Leiserson, Ronald L. Rivest, Clifford Stein. Chapter 19.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake. All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+generic
+ type Element_Type is private;
+ type Element_Access is access all Element_Type;
+ type Key_Type is private;
+ with function Key (Item : in Element_Type) return Key_Type;
+ with procedure Set_Key (Item : in out Element_Type; Key : in Key_Type);
+ pragma Unreferenced (Set_Key); -- needed for Decrease_Key
+ with function "<" (Left, Right : in Key_Type) return Boolean is <>;
+package SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci is
+
+ type Heap_Type is new Ada.Finalization.Controlled with private;
+
+ Empty_Heap : constant Heap_Type;
+
+ overriding
+ procedure Initialize (Object : in out Heap_Type);
+
+ overriding
+ procedure Finalize (Object : in out Heap_Type);
+
+ overriding
+ procedure Adjust (Object : in out Heap_Type);
+
+ procedure Clear (Heap : in out Heap_Type);
+ -- Empty Heap.
+
+ function Count (Heap : in Heap_Type) return Base_Peek_Type;
+ -- Return count of elements in Heap.
+
+ function Remove (Heap : in out Heap_Type) return Element_Type;
+ -- Remove minimum element in Heap, return it.
+
+ function Min_Key (Heap : in out Heap_Type) return Key_Type;
+ -- Return a copy of the minimum key value.
+
+ function Get (Heap : in out Heap_Type) return Element_Type renames Remove;
+
+ procedure Drop (Heap : in out Heap_Type);
+ -- Remove minimum element in Heap, discard it.
+
+ procedure Add (Heap : in out Heap_Type; Item : in Element_Type);
+ -- Add Item to Heap.
+
+ procedure Insert (Heap : in out Heap_Type; Item : in Element_Type) renames
Add;
+
+ function Add (Heap : in out Heap_Type; Item : in Element_Type) return
Element_Access;
+ -- Add Item to Heap, return a pointer to it. This avoids extra
+ -- copying of Item.
+ --
+ -- Result is valid at least until next Get.
+
+ -- Despite being called a "mergeable heap" in [1], there is no
+ -- algorithm for merging two Fibonacci heaps. And the naive method of
+ -- simply splicing the root lists apparently breaks the consolidate
+ -- algorithm; it assumes there can only be one tree of each degree >
+ -- 0.
+
+ -- procedure Increase_Key (Heap : in out Heap_Type; index : in index_type;
Item : in Element_Type);
+ -- IMPROVEME: implement. need Index (heap, Key), or Add return index.
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is null record
+ with Implicit_Dereference => Element;
+
+ function Peek (Heap : in Heap_Type) return Constant_Reference_Type;
+ -- Return a constant reference to the min element.
+
+private
+
+ type Node;
+ type Node_Access is access Node;
+
+ type Node is record
+ Element : aliased Element_Type;
+ Parent : Node_Access;
+ Child : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Degree : Natural;
+ Mark : Boolean;
+ end record;
+
+ type Heap_Type is new Ada.Finalization.Controlled with record
+ Min : Node_Access;
+ Count : Base_Peek_Type;
+ end record;
+
+ Empty_Heap : constant Heap_Type := (Ada.Finalization.Controlled with Min =>
null, Count => 0);
+
+end SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci;
diff --git a/sal-gen_unbounded_definite_queues-gen_image_aux.adb
b/sal-gen_unbounded_definite_queues-gen_image_aux.adb
new file mode 100644
index 0000000..233aa1b
--- /dev/null
+++ b/sal-gen_unbounded_definite_queues-gen_image_aux.adb
@@ -0,0 +1,35 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Unbounded;
+function SAL.Gen_Unbounded_Definite_Queues.Gen_Image_Aux (Item : in Queue; Aux
: in Aux_Data) return String
+is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ Last : constant Base_Peek_Type := Item.Count;
+begin
+ for I in 1 .. Last loop
+ Result := Result & Element_Image (Item.Peek (I), Aux);
+ if I /= Last then
+ Result := Result & ", ";
+ end if;
+ end loop;
+ Result := Result & ")";
+ return To_String (Result);
+end SAL.Gen_Unbounded_Definite_Queues.Gen_Image_Aux;
diff --git a/sal-gen_unbounded_definite_queues-gen_image_aux.ads
b/sal-gen_unbounded_definite_queues-gen_image_aux.ads
new file mode 100644
index 0000000..6ea7c8f
--- /dev/null
+++ b/sal-gen_unbounded_definite_queues-gen_image_aux.ads
@@ -0,0 +1,23 @@
+-- Abstract :
+--
+-- Image with auxiliary data for instantiations of parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Aux_Data (<>) is private;
+ with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
+function SAL.Gen_Unbounded_Definite_Queues.Gen_Image_Aux (Item : in Queue; Aux
: in Aux_Data) return String;
diff --git a/sal-gen_unbounded_definite_queues.adb
b/sal-gen_unbounded_definite_queues.adb
new file mode 100644
index 0000000..f71fbe5
--- /dev/null
+++ b/sal-gen_unbounded_definite_queues.adb
@@ -0,0 +1,97 @@
+-- Abstract:
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Unbounded_Definite_Queues is
+
+ procedure Clear (Queue : in out Pkg.Queue)
+ is begin
+ Queue.Data.Clear;
+ end Clear;
+
+ function Count (Queue : in Pkg.Queue) return Base_Peek_Type
+ is begin
+ return Base_Peek_Type (Queue.Data.Length);
+ end Count;
+
+ function Is_Empty (Queue : in Pkg.Queue) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ return Queue.Data.Length = 0;
+ end Is_Empty;
+
+ function Remove (Queue : in out Pkg.Queue) return Element_Type
+ is
+ use Element_Lists;
+ begin
+ return A : constant Element_Type := Element (Queue.Data.First) do
+ Queue.Data.Delete_First;
+ end return;
+ end Remove;
+
+ procedure Drop (Queue : in out Pkg.Queue)
+ is begin
+ Queue.Data.Delete_First;
+ end Drop;
+
+ function Peek (Queue : in Pkg.Queue; N : Peek_Type := 1) return
Constant_Reference_Type
+ is
+ use Ada.Containers;
+ use Element_Lists;
+ I : Cursor := Queue.Data.First;
+ begin
+ if Count_Type (N) > Queue.Data.Length then
+ raise Parameter_Error;
+ end if;
+
+ for K in 2 .. N loop
+ Next (I);
+ end loop;
+
+ return (Element => Element_Lists.Constant_Reference (Queue.Data,
I).Element, Dummy => 1);
+ end Peek;
+
+ function Variable_Peek (Queue : in out Pkg.Queue; N : Peek_Type := 1)
return Variable_Reference_Type
+ is
+ use Ada.Containers;
+ use Element_Lists;
+ I : Cursor := Queue.Data.First;
+ begin
+ if Count_Type (N) > Queue.Data.Length then
+ raise Parameter_Error;
+ end if;
+
+ for K in 2 .. N loop
+ Next (I);
+ end loop;
+
+ return (Element => Element_Lists.Reference (Queue.Data, I).Element,
Dummy => 1);
+ end Variable_Peek;
+
+ procedure Add (Queue : in out Pkg.Queue; Item : in Element_Type)
+ is begin
+ Queue.Data.Append (Item);
+ end Add;
+
+ procedure Add_To_Head (Queue : in out Pkg.Queue; Item : in Element_Type)
+ is begin
+ Queue.Data.Prepend (Item);
+ end Add_To_Head;
+
+end SAL.Gen_Unbounded_Definite_Queues;
diff --git a/sal-gen_unbounded_definite_queues.ads
b/sal-gen_unbounded_definite_queues.ads
new file mode 100644
index 0000000..d891f9d
--- /dev/null
+++ b/sal-gen_unbounded_definite_queues.ads
@@ -0,0 +1,108 @@
+-- Abstract:
+--
+-- An unbounded queue of definite non-limited elements.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake. All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers.Doubly_Linked_Lists;
+generic
+ type Element_Type is private;
+package SAL.Gen_Unbounded_Definite_Queues is
+
+ package Pkg renames SAL.Gen_Unbounded_Definite_Queues;
+
+ type Queue is tagged private;
+
+ Empty_Queue : constant Queue;
+
+ procedure Clear (Queue : in out Pkg.Queue);
+ -- Empty Queue.
+
+ function Count (Queue : in Pkg.Queue) return Base_Peek_Type;
+ -- Return count of items in the Queue
+
+ function Length (Queue : in Pkg.Queue) return Base_Peek_Type renames Count;
+
+ function Is_Empty (Queue : in Pkg.Queue) return Boolean;
+ -- Return true if no items are in Pkg.Queue.
+
+ function Is_Full (Queue : in Pkg.Queue) return Boolean is (False);
+ -- Return true if Queue is full.
+
+ function Remove (Queue : in out Pkg.Queue) return Element_Type;
+ -- Remove head/front item from Queue, return it.
+ --
+ -- Raise Container_Empty if Is_Empty.
+
+ function Get (Queue : in out Pkg.Queue) return Element_Type renames Remove;
+
+ procedure Drop (Queue : in out Pkg.Queue);
+ -- Remove head/front item from Queue, discard it.
+ --
+ -- Raise Container_Empty if Is_Empty.
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ function Peek (Queue : in Pkg.Queue; N : Peek_Type := 1) return
Constant_Reference_Type;
+ -- Return a constant reference to a queue item. N = 1 is the queue
+ -- head.
+ --
+ -- Raise Parameter_Error if N > Count
+
+ type Variable_Reference_Type (Element : not null access Element_Type) is
private
+ with Implicit_Dereference => Element;
+
+ function Variable_Peek (Queue : in out Pkg.Queue; N : Peek_Type := 1)
return Variable_Reference_Type;
+ -- Return a variable reference to a queue item. N = 1 is the queue
+ -- head.
+ --
+ -- Raises Parameter_Error if N > Count
+
+ procedure Add (Queue : in out Pkg.Queue; Item : in Element_Type);
+ -- Add Element to the tail/back of Queue.
+
+ procedure Put (Queue : in out Pkg.Queue; Item : in Element_Type) renames
Add;
+
+ procedure Add_To_Head (Queue : in out Pkg.Queue; Item : in Element_Type);
+ -- Add Element to the head/front of Queue.
+
+private
+
+ package Element_Lists is new Ada.Containers.Doubly_Linked_Lists
(Element_Type);
+
+ -- We don't provide cursors or write access to queue elements, so we
+ -- don't need any tampering checks.
+
+ type Queue is tagged record
+ Data : Element_Lists.List;
+ -- Add at Tail/Back = Last, remove at Head/Front = First.
+ end record;
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is
+ record
+ Dummy : Integer := raise Program_Error with "uninitialized reference";
+ end record;
+
+ type Variable_Reference_Type (Element : not null access Element_Type) is
+ record
+ Dummy : Integer := raise Program_Error with "uninitialized reference";
+ end record;
+
+ Empty_Queue : constant Queue := (Data => Element_Lists.Empty_List);
+
+end SAL.Gen_Unbounded_Definite_Queues;
diff --git a/sal-gen_unbounded_definite_red_black_trees.adb
b/sal-gen_unbounded_definite_red_black_trees.adb
new file mode 100644
index 0000000..2d84c57
--- /dev/null
+++ b/sal-gen_unbounded_definite_red_black_trees.adb
@@ -0,0 +1,863 @@
+-- Abstract :
+--
+-- Generic unbounded red-black tree with definite elements.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Unbounded_Definite_Red_Black_Trees is
+
+ -- Local declarations (alphabetical order)
+
+ function Count_Tree (Item : in Node_Access; Nil : in Node_Access) return
Ada.Containers.Count_Type
+ with Pre => Nil /= null;
+
+ procedure Delete_Fixup (T : in out Tree; X : in out Node_Access);
+
+ function Find (Root : in Node_Access; Key : in Key_Type; Nil : in
Node_Access) return Node_Access
+ with Pre => Nil /= null;
+
+ procedure Left_Rotate (Tree : in out Pkg.Tree; X : in Node_Access)
+ with Pre => X /= null;
+
+ procedure Right_Rotate (Tree : in out Pkg.Tree; X : in Node_Access)
+ with Pre => X /= null;
+
+ procedure Transplant (T : in out Pkg.Tree; U, V : in Node_Access)
+ with Pre => U /= null and T.Root /= null;
+
+ ----------
+ -- local bodies (alphabetical order)
+
+ function Count_Tree (Item : in Node_Access; Nil : in Node_Access) return
Ada.Containers.Count_Type
+ is
+ use all type Ada.Containers.Count_Type;
+ Result : Ada.Containers.Count_Type := 0;
+ begin
+ if Item.Left /= Nil then
+ Result := Result + Count_Tree (Item.Left, Nil);
+ end if;
+
+ if Item.Right /= Nil then
+ Result := Result + Count_Tree (Item.Right, Nil);
+ end if;
+
+ return Result + 1;
+ end Count_Tree;
+
+ procedure Delete_Fixup (T : in out Tree; X : in out Node_Access)
+ is
+ W : Node_Access;
+ begin
+ -- [1] 13.3 RB-Delete-Fixup
+ -- X is either "doubly black" or "red and black"
+ -- X.Parent is set, even if X = Nil.
+ -- In all cases, Nil.Left = null.Right = null.
+
+ while X /= T.Root and X.Color = Black loop
+ if X = X.Parent.Left then
+ W := X.Parent.Right;
+ if W.Color = Red then
+ W.Color := Black;
+ X.Parent.Color := Red;
+ Left_Rotate (T, X.Parent);
+ W := X.Parent.Right;
+ end if;
+
+ if W.Left.Color = Black and W.Right.Color = Black then
+ W.Color := Red;
+ X := X.Parent;
+ else
+ if W.Right.Color = Black then
+ W.Left.Color := Black;
+ W.Color := Red;
+ Right_Rotate (T, W);
+ W := X.Parent.Right;
+ end if;
+ W.Color := X.Parent.Color;
+ X.Parent.Color := Black;
+ W.Right.Color := Black;
+ Left_Rotate (T, X.Parent);
+ X := T.Root;
+ end if;
+ else
+ W := X.Parent.Left;
+ if W.Color = Red then
+ W.Color := Black;
+ X.Parent.Color := Red;
+ Right_Rotate (T, X.Parent);
+ W := X.Parent.Left;
+ end if;
+
+ if W.Right.Color = Black and W.Left.Color = Black then
+ W.Color := Red;
+ X := X.Parent;
+ else
+ if W.Left.Color = Black then
+ W.Right.Color := Black;
+ W.Color := Red;
+ Left_Rotate (T, W);
+ W := X.Parent.Left;
+ end if;
+ W.Color := X.Parent.Color;
+ X.Parent.Color := Black;
+ W.Left.Color := Black;
+ Right_Rotate (T, X.Parent);
+ X := T.Root;
+ end if;
+ end if;
+ end loop;
+ X.Color := Black;
+ end Delete_Fixup;
+
+ function Find (Root : in Node_Access; Key : in Key_Type; Nil : in
Node_Access) return Node_Access
+ is
+ Node : Node_Access := Root;
+ begin
+ while Node /= Nil loop
+ case Key_Compare (Key, Pkg.Key (Node.Element)) is
+ when Equal =>
+ return Node;
+ when Less =>
+ Node := Node.Left;
+ when Greater =>
+ Node := Node.Right;
+ end case;
+ end loop;
+ return null;
+ end Find;
+
+ procedure Free_Tree (Item : in out Node_Access; Nil : in Node_Access)
+ is begin
+ if Item = Nil or Item = null then
+ raise Programmer_Error;
+ end if;
+
+ if Item.Left /= Nil then
+ Free_Tree (Item.Left, Nil);
+ end if;
+
+ if Item.Right /= Nil then
+ Free_Tree (Item.Right, Nil);
+ end if;
+
+ Free (Item);
+ end Free_Tree;
+
+ procedure Insert_Fixup (Tree : in out Pkg.Tree; Z : in out Node_Access)
+ is
+ -- [1] 13.3 RB-Insert-Fixup (T, z)
+ Nil : Node_Access renames Tree.Nil;
+ Y : Node_Access;
+ begin
+ while Z.Parent /= Nil and then Z.Parent.Color = Red loop
+ if Z.Parent = Z.Parent.Parent.Left then
+ Y := Z.Parent.Parent.Right;
+ if Y /= Nil and then Y.Color = Red then
+ Z.Parent.Color := Black;
+ Y.Color := Black;
+ Z.Parent.Parent.Color := Red;
+ Z := Z.Parent.Parent;
+ else
+ if Z = Z.Parent.Right then
+ Z := Z.Parent;
+ Left_Rotate (Tree, Z);
+ end if;
+ Z.Parent.Color := Black;
+ Z.Parent.Parent.Color := Red;
+ Right_Rotate (Tree, Z.Parent.Parent);
+ end if;
+ else
+ Y := Z.Parent.Parent.Left;
+ if Y /= Nil and then Y.Color = Red then
+ Z.Parent.Color := Black;
+ Y.Color := Black;
+ Z.Parent.Parent.Color := Red;
+ Z := Z.Parent.Parent;
+ else
+ if Z = Z.Parent.Left then
+ Z := Z.Parent;
+ Right_Rotate (Tree, Z);
+ end if;
+ Z.Parent.Color := Black;
+ Z.Parent.Parent.Color := Red;
+ Left_Rotate (Tree, Z.Parent.Parent);
+ end if;
+ end if;
+ end loop;
+ Tree.Root.Color := Black;
+ end Insert_Fixup;
+
+ procedure Left_Rotate (Tree : in out Pkg.Tree; X : in Node_Access)
+ is
+ -- [1] 13.2 Left-Rotate (T, x)
+ Nil : Node_Access renames Tree.Nil;
+ Y : constant Node_Access := X.Right;
+ begin
+ X.Right := Y.Left;
+ if Y.Left /= Nil then
+ Y.Left.Parent := X;
+ end if;
+ Y.Parent := X.Parent;
+ if X.Parent = Nil then
+ Tree.Root := Y;
+ elsif X = X.Parent.Left then
+ X.Parent.Left := Y;
+ else
+ X.Parent.Right := Y;
+ end if;
+ Y.Left := X;
+ X.Parent := Y;
+ end Left_Rotate;
+
+ function Minimum (Node : in Node_Access; Nil : in Node_Access) return
Node_Access
+ is begin
+ return Result : Node_Access := Node
+ do
+ while Result.Left /= Nil loop
+ Result := Result.Left;
+ end loop;
+ end return;
+ end Minimum;
+
+ procedure Right_Rotate (Tree : in out Pkg.Tree; X : in Node_Access)
+ is
+ -- [1] 13.2 Right-Rotate (T, x)
+ Nil : Node_Access renames Tree.Nil;
+ Y : constant Node_Access := X.Left;
+ begin
+ X.Left := Y.Right;
+ if Y.Right /= Nil then
+ Y.Right.Parent := X;
+ end if;
+ Y.Parent := X.Parent;
+ if X.Parent = Nil then
+ Tree.Root := Y;
+ elsif X = X.Parent.Right then
+ X.Parent.Right := Y;
+ else
+ X.Parent.Left := Y;
+ end if;
+ Y.Right := X;
+ X.Parent := Y;
+ end Right_Rotate;
+
+ procedure Transplant (T : in out Pkg.Tree; U, V : in Node_Access)
+ is
+ Nil : Node_Access renames T.Nil;
+ begin
+ -- [1] 13.4 RB-Transplant, 12.3 Transplant
+
+ if U.Parent = Nil then
+ T.Root := V;
+ elsif U = U.Parent.Left then
+ U.Parent.Left := V;
+ else
+ U.Parent.Right := V;
+ end if;
+ V.Parent := U.Parent;
+ end Transplant;
+
+ ----------
+ -- Public subprograms, spec order
+
+ overriding procedure Finalize (Object : in out Tree)
+ is begin
+ if Object.Root /= null then
+ if Object.Root = Object.Nil then
+ Free (Object.Nil);
+ Object.Root := null;
+ else
+ Free_Tree (Object.Root, Object.Nil);
+ Free (Object.Nil);
+ end if;
+ end if;
+ end Finalize;
+
+ overriding procedure Initialize (Object : in out Tree)
+ is begin
+ Object.Nil := new Node;
+ Object.Nil.Color := Black;
+ Object.Root := Object.Nil;
+ end Initialize;
+
+ function Has_Element (Cursor : in Pkg.Cursor) return Boolean
+ is begin
+ return Cursor.Node /= null;
+ end Has_Element;
+
+ function Constant_Ref
+ (Container : aliased in Tree;
+ Position : in Cursor)
+ return Constant_Ref_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ return (Element => Position.Node.all.Element'Access);
+ end Constant_Ref;
+
+ function Constant_Ref
+ (Container : aliased in Tree;
+ Key : in Key_Type)
+ return Constant_Ref_Type
+ is
+ Node : constant Node_Access := Find (Container.Root, Key, Container.Nil);
+ begin
+ if Node = null then
+ raise Not_Found;
+ else
+ return (Element => Node.all.Element'Access);
+ end if;
+ end Constant_Ref;
+
+ function Variable_Ref
+ (Container : aliased in Tree;
+ Position : in Cursor)
+ return Variable_Ref_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ return (Element => Position.Node.all.Element'Access);
+ end Variable_Ref;
+
+ function Variable_Ref
+ (Container : aliased in Tree;
+ Key : in Key_Type)
+ return Variable_Ref_Type
+ is
+ Node : constant Node_Access := Find (Container.Root, Key, Container.Nil);
+ begin
+ if Node = null then
+ raise Not_Found;
+ else
+ return (Element => Node.all.Element'Access);
+ end if;
+ end Variable_Ref;
+
+ function Iterate (Tree : in Pkg.Tree'Class) return Iterator
+ is begin
+ return (Tree.Root, Tree.Nil);
+ end Iterate;
+
+ overriding function First (Iterator : in Pkg.Iterator) return Cursor
+ is
+ Nil : Node_Access renames Iterator.Nil;
+ Node : Node_Access := Iterator.Root;
+ begin
+ if Node = Nil then
+ return
+ (Node => null,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+ else
+ loop
+ exit when Node.Left = Nil;
+ Node := Node.Left;
+ end loop;
+
+ return
+ (Node => Node,
+ Direction => Ascending,
+ Left_Done => True,
+ Right_Done => False);
+ end if;
+
+ end First;
+
+ overriding function Next (Iterator : in Pkg.Iterator; Position : in Cursor)
return Cursor
+ is
+ Nil : Node_Access renames Iterator.Nil;
+ begin
+ if Position.Direction /= Ascending then
+ raise Programmer_Error;
+ end if;
+
+ if Position.Node = null then
+ return
+ (Node => null,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+
+ elsif Position.Left_Done or Position.Node.Left = Nil then
+ if Position.Right_Done or Position.Node.Right = Nil then
+ if Position.Node.Parent = Nil then
+ return
+ (Node => null,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+ else
+ declare
+ Node : constant Node_Access := Position.Node.Parent;
+ Temp : constant Cursor :=
+ (Node => Node,
+ Direction => Ascending,
+ Left_Done => Node.Right = Position.Node or Node.Left =
Position.Node,
+ Right_Done => Node.Right = Position.Node);
+ begin
+ if Temp.Right_Done then
+ return Next (Iterator, Temp);
+ else
+ return Temp;
+ end if;
+ end;
+ end if;
+ else
+ declare
+ Node : constant Node_Access := Position.Node.Right;
+ Temp : constant Cursor :=
+ (Node => Node,
+ Direction => Ascending,
+ Left_Done => Node.Left = Nil,
+ Right_Done => False);
+ begin
+ if Temp.Left_Done then
+ return Temp;
+ else
+ return Next (Iterator, Temp);
+ end if;
+ end;
+ end if;
+ else
+ declare
+ Node : constant Node_Access := Position.Node.Left;
+ Temp : constant Cursor :=
+ (Node => Node,
+ Direction => Ascending,
+ Left_Done => Node.Left = Nil,
+ Right_Done => False);
+ begin
+ if Temp.Left_Done then
+ return Temp;
+ else
+ return Next (Iterator, Temp);
+ end if;
+ end;
+ end if;
+ end Next;
+
+ overriding function Last (Iterator : in Pkg.Iterator) return Cursor
+ is
+ Nil : Node_Access renames Iterator.Nil;
+ Node : Node_Access := Iterator.Root;
+ begin
+ if Node = Nil then
+ return
+ (Node => null,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+ else
+ loop
+ exit when Node.Right = Nil;
+ Node := Node.Right;
+ end loop;
+ return
+ (Node => Node,
+ Direction => Descending,
+ Right_Done => True,
+ Left_Done => False);
+ end if;
+ end Last;
+
+ overriding function Previous (Iterator : in Pkg.Iterator; Position : in
Cursor) return Cursor
+ is
+ Nil : Node_Access renames Iterator.Nil;
+ begin
+ if Position.Direction /= Descending then
+ raise Programmer_Error;
+ end if;
+
+ if Position.Node = null then
+ return
+ (Node => null,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+
+ elsif Position.Right_Done or Position.Node.Right = Nil then
+ if Position.Left_Done or Position.Node.Left = Nil then
+ if Position.Node.Parent = Nil then
+ return
+ (Node => null,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+ else
+ declare
+ Node : constant Node_Access := Position.Node.Parent;
+ Temp : constant Cursor :=
+ (Node => Node,
+ Direction => Descending,
+ Right_Done => Node.Left = Position.Node or Node.Right =
Position.Node,
+ Left_Done => Node.Left = Position.Node);
+ begin
+ if Temp.Left_Done then
+ return Previous (Iterator, Temp);
+ else
+ return Temp;
+ end if;
+ end;
+ end if;
+ else
+ declare
+ Node : constant Node_Access := Position.Node.Left;
+ Temp : constant Cursor :=
+ (Node => Node,
+ Direction => Descending,
+ Right_Done => Node.Right = Nil,
+ Left_Done => False);
+ begin
+ if Temp.Right_Done then
+ return Temp;
+ else
+ return Previous (Iterator, Temp);
+ end if;
+ end;
+ end if;
+ else
+ declare
+ Node : constant Node_Access := Position.Node.Right;
+ Temp : constant Cursor :=
+ (Node => Node,
+ Direction => Descending,
+ Right_Done => Node.Right = Nil,
+ Left_Done => False);
+ begin
+ if Temp.Right_Done then
+ return Temp;
+ else
+ return Previous (Iterator, Temp);
+ end if;
+ end;
+ end if;
+ end Previous;
+
+ function Previous (Iterator : in Pkg.Iterator; Key : in Key_Type) return
Cursor
+ is
+ Nil : Node_Access renames Iterator.Nil;
+ Node : Node_Access := Iterator.Root;
+ begin
+ while Node /= Nil loop
+ declare
+ Current_Key : Key_Type renames Pkg.Key (Node.Element);
+ begin
+ case Key_Compare (Key, Current_Key) is
+ when Equal =>
+ return Previous (Iterator, (Node, Descending, Right_Done =>
True, Left_Done => False));
+
+ when Less =>
+ if Node.Left = Nil then
+ return Previous (Iterator, (Node, Descending, Right_Done =>
True, Left_Done => True));
+ else
+ Node := Node.Left;
+ end if;
+
+ when Greater =>
+ if Node.Right = Nil then
+ return (Node, Descending, Right_Done => True, Left_Done =>
False);
+ else
+ Node := Node.Right;
+ end if;
+ end case;
+ end;
+ end loop;
+
+ return
+ (Node => null,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+ end Previous;
+
+ function Find
+ (Iterator : in Pkg.Iterator;
+ Key : in Key_Type;
+ Direction : in Direction_Type := Ascending)
+ return Cursor
+ is
+ Nil : Node_Access renames Iterator.Nil;
+ Node : constant Node_Access := Find (Iterator.Root, Key, Nil);
+ begin
+ if Node = null then
+ return
+ (Node => null,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+ else
+ return
+ (Node => Node,
+ Direction => Direction,
+ Left_Done =>
+ (case Direction is
+ when Ascending | Unknown => True,
+ when Descending => Node.Left = Nil),
+ Right_Done =>
+ (case Direction is
+ when Ascending => Node.Right = Nil,
+ when Descending | Unknown => True));
+ end if;
+ end Find;
+
+ function Find_In_Range
+ (Iterator : in Pkg.Iterator;
+ Direction : in Known_Direction_Type;
+ First, Last : in Key_Type)
+ return Cursor
+ is
+ Nil : Node_Access renames Iterator.Nil;
+ Node : Node_Access := Iterator.Root;
+ Candidate : Node_Access := null; -- best result found so far
+ begin
+ while Node /= Nil loop
+ declare
+ Current_Key : Key_Type renames Key (Node.Element);
+ begin
+ case Direction is
+ when Ascending =>
+ case Key_Compare (First, Current_Key) is
+ when Equal =>
+ return (Node, Ascending, Right_Done => False, Left_Done
=> True);
+
+ when Less =>
+ if Node.Left = Nil then
+ case Key_Compare (Current_Key, Last) is
+ when Less | Equal =>
+ return (Node, Ascending, Right_Done => False,
Left_Done => True);
+ when Greater =>
+ if Candidate = null then
+ return No_Element;
+ else
+ return (Candidate, Ascending, Right_Done => False,
Left_Done => True);
+ end if;
+ end case;
+ else
+ case Key_Compare (Last, Current_Key) is
+ when Greater | Equal =>
+ Candidate := Node;
+ when Less =>
+ null;
+ end case;
+ Node := Node.Left;
+ end if;
+
+ when Greater =>
+ if Node.Right = Nil then
+ if Candidate = null then
+ return No_Element;
+ else
+ return (Candidate, Ascending, Right_Done => False,
Left_Done => True);
+ end if;
+ else
+ Node := Node.Right;
+ end if;
+ end case;
+
+ when Descending =>
+ if Last = Current_Key then
+ return (Node, Descending, Right_Done => True, Left_Done =>
False);
+
+ else
+ case Key_Compare (Last, Current_Key) is
+ when Greater =>
+ if Node.Right = Nil then
+ case Key_Compare (Current_Key, First) is
+ when Greater | Equal =>
+ return (Node, Descending, Right_Done => True,
Left_Done => False);
+ when Less =>
+ if Candidate = null then
+ return No_Element;
+ else
+ return (Candidate, Ascending, Right_Done =>
False, Left_Done => True);
+ end if;
+ end case;
+ else
+ case Key_Compare (First, Current_Key) is
+ when Less | Equal =>
+ Candidate := Node;
+ when Greater =>
+ null;
+ end case;
+ Node := Node.Right;
+ end if;
+ when Equal | Less =>
+ if Node.Left = Nil then
+ if Candidate = null then
+ return No_Element;
+ else
+ return (Candidate, Ascending, Right_Done => False,
Left_Done => True);
+ end if;
+ else
+ Node := Node.Left;
+ end if;
+ end case;
+ end if;
+ end case;
+ end;
+ end loop;
+
+ return No_Element;
+ end Find_In_Range;
+
+ function Count (Tree : in Pkg.Tree) return Ada.Containers.Count_Type
+ is begin
+ if Tree.Root = Tree.Nil then
+ return 0;
+ else
+ return Count_Tree (Tree.Root, Tree.Nil);
+ end if;
+ end Count;
+
+ function Present (Container : in Tree; Key : in Key_Type) return Boolean
+ is
+ Nil : Node_Access renames Container.Nil;
+ Node : Node_Access := Container.Root;
+ begin
+ while Node /= Nil loop
+ case Key_Compare (Key, Pkg.Key (Node.Element)) is
+ when Equal =>
+ return True;
+ when Less =>
+ Node := Node.Left;
+ when Greater =>
+ Node := Node.Right;
+ end case;
+ end loop;
+ return False;
+ end Present;
+
+ function Insert (Tree : in out Pkg.Tree; Element : in Element_Type) return
Cursor
+ is
+ -- [1] 13.3 RB-Insert (T, z)
+ Nil : Node_Access renames Tree.Nil;
+ Z : Node_Access := new Node'(Element, Nil, Nil, Nil, Red);
+ Key_Z : constant Key_Type := Key (Z.Element);
+ Y : Node_Access := Nil;
+ X : Node_Access := Tree.Root;
+
+ Result : Node_Access;
+ Compare_Z_Y : Compare_Result;
+ begin
+ Nil.Parent := null;
+ Nil.Left := null;
+ Nil.Right := null;
+
+ while X /= Nil loop
+ Y := X;
+ Compare_Z_Y := Key_Compare (Key_Z, Key (X.Element));
+ case Compare_Z_Y is
+ when Less =>
+ X := X.Left;
+ when Equal | Greater =>
+ X := X.Right;
+ end case;
+ end loop;
+
+ Z.Parent := Y;
+ if Y = Nil then
+ Tree.Root := Z;
+ else
+ case Compare_Z_Y is
+ when Less =>
+ Y.Left := Z;
+ when Equal | Greater =>
+ Y.Right := Z;
+ end case;
+ end if;
+
+ Result := Z;
+ if Z = Tree.Root then
+ Z.Color := Black;
+ else
+ Insert_Fixup (Tree, Z);
+ end if;
+
+ return
+ (Node => Result,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+ end Insert;
+
+ procedure Insert (Tree : in out Pkg.Tree; Element : in Element_Type)
+ is
+ Temp : Cursor := Insert (Tree, Element);
+ pragma Unreferenced (Temp);
+ begin
+ null;
+ end Insert;
+
+ procedure Delete (Tree : in out Pkg.Tree; Position : in out Cursor)
+ is
+ Nil : Node_Access renames Tree.Nil;
+ T : Pkg.Tree renames Tree;
+ Z : constant Node_Access :=
+ (if Position.Node = null then raise Parameter_Error else
Position.Node);
+ Y : Node_Access := Z;
+ Y_Orig_Color : Color := Y.Color;
+ X : Node_Access;
+ begin
+ -- Catch logic errors in use of Nil
+ Nil.Parent := null;
+ Nil.Left := null;
+ Nil.Right := null;
+
+ -- [1] 13.4 RB-Delete.
+ if Z.Left = Nil then
+ X := Z.Right;
+ Transplant (T, Z, Z.Right);
+
+ elsif Z.Right = Nil then
+ X := Z.Left;
+ Transplant (T, Z, Z.Left);
+
+ else
+ Y := Minimum (Z.Right, Nil);
+ Y_Orig_Color := Y.Color;
+ X := Y.Right;
+ if Y.Parent = Z then
+ X.Parent := Y;
+ -- This is already true unless X = Nil, in which case delete_fixup
+ -- needs the info.
+ else
+ Transplant (T, Y, Y.Right);
+ Y.Right := Z.Right;
+
+ Y.Right.Parent := Y;
+ -- This is already true unless Y.Right = Nil, in which case
+ -- delete_fixup needs the info.
+ end if;
+
+ Transplant (T, Z, Y);
+ Y.Left := Z.Left;
+
+ Y.Left.Parent := Y;
+ -- This is already true unless Y.Left = Nil, in which case
+ -- delete_fixup needs the info.
+
+ Y.Color := Z.Color;
+ end if;
+
+ if Y_Orig_Color = Black then
+ Delete_Fixup (T, X);
+ end if;
+
+ Free (Position.Node);
+ end Delete;
+
+end SAL.Gen_Unbounded_Definite_Red_Black_Trees;
diff --git a/sal-gen_unbounded_definite_red_black_trees.ads
b/sal-gen_unbounded_definite_red_black_trees.ads
new file mode 100644
index 0000000..7096970
--- /dev/null
+++ b/sal-gen_unbounded_definite_red_black_trees.ads
@@ -0,0 +1,181 @@
+-- Abstract :
+--
+-- Generic unbounded red-black tree with definite elements, definite
+-- or indefinite key.
+--
+-- References :
+--
+-- [1] Introduction to Algorithms, Thomas H. Cormen, Charles E.
+-- Leiserson, Ronald L. Rivest, Clifford Stein.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with Ada.Iterator_Interfaces;
+with Ada.Unchecked_Deallocation;
+generic
+ type Element_Type is private;
+ type Key_Type (<>) is private;
+ with function Key (Element : in Element_Type) return Key_Type is <>;
+ with function Key_Compare (Left, Right : in Key_Type) return Compare_Result
is <>;
+package SAL.Gen_Unbounded_Definite_Red_Black_Trees is
+
+ package Pkg renames Gen_Unbounded_Definite_Red_Black_Trees;
+
+ type Tree is new Ada.Finalization.Limited_Controlled with private
+ with
+ Constant_Indexing => Constant_Ref,
+ Variable_Indexing => Variable_Ref,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
+ overriding procedure Finalize (Object : in out Tree);
+ overriding procedure Initialize (Object : in out Tree);
+
+ type Direction_Type is (Ascending, Descending, Unknown);
+ subtype Known_Direction_Type is Direction_Type range Ascending ..
Descending;
+ -- Direction of Iterators.
+ -- If Ascending, Next may be called.
+ -- If Descending, Previous may be called.
+ -- If Unknown, neither.
+
+ type Cursor is private;
+
+ No_Element : constant Cursor;
+
+ function Has_Element (Cursor : in Pkg.Cursor) return Boolean;
+
+ type Constant_Ref_Type (Element : not null access constant Element_Type) is
null record
+ with Implicit_Dereference => Element;
+
+ function Constant_Ref
+ (Container : aliased in Tree;
+ Position : in Cursor)
+ return Constant_Ref_Type;
+
+ function Constant_Ref
+ (Container : aliased in Tree;
+ Key : in Key_Type)
+ return Constant_Ref_Type;
+
+ type Variable_Ref_Type (Element : not null access Element_Type) is null
record
+ with Implicit_Dereference => Element;
+
+ function Variable_Ref
+ (Container : aliased in Tree;
+ Position : in Cursor)
+ return Variable_Ref_Type;
+
+ function Variable_Ref
+ (Container : aliased in Tree;
+ Key : in Key_Type)
+ return Variable_Ref_Type;
+ -- Raises Not_Found if Key not found in Container.
+
+ package Iterators is new Ada.Iterator_Interfaces (Cursor, Has_Element);
+
+ type Iterator is new Iterators.Reversible_Iterator with private;
+
+ function Iterate (Tree : in Pkg.Tree'Class) return Iterator;
+
+ overriding function First (Iterator : in Pkg.Iterator) return Cursor;
+ overriding function Next (Iterator : in Pkg.Iterator; Position : in Cursor)
return Cursor;
+ overriding function Last (Iterator : in Pkg.Iterator) return Cursor;
+ overriding function Previous (Iterator : in Pkg.Iterator; Position : in
Cursor) return Cursor;
+
+ function Previous (Iterator : in Pkg.Iterator; Key : in Key_Type) return
Cursor;
+ -- Initialise Iterator to descending, starting at element with
+ -- largest key < Key. Has_Element (result) is False if there is no
+ -- such element.
+
+ function Find
+ (Iterator : in Pkg.Iterator;
+ Key : in Key_Type;
+ Direction : in Direction_Type := Ascending)
+ return Cursor;
+ -- Has_Element is False if Key is not in Container.
+
+ function Find_In_Range
+ (Iterator : in Pkg.Iterator;
+ Direction : in Known_Direction_Type;
+ First, Last : in Key_Type)
+ return Cursor;
+ -- Find first element with Key greater than or equal to First, and
+ -- less than or equal to Last. If Direction is Ascending, start
+ -- search at First; if Descending, at Last.
+ --
+ -- Has_Element is False if there is no such Key.
+
+ function Count (Tree : in Pkg.Tree) return Ada.Containers.Count_Type;
+
+ function Present (Container : in Tree; Key : in Key_Type) return Boolean;
+
+ procedure Insert (Tree : in out Pkg.Tree; Element : in Element_Type);
+ function Insert (Tree : in out Pkg.Tree; Element : in Element_Type) return
Cursor;
+ -- Result points to newly inserted element.
+
+ procedure Delete (Tree : in out Pkg.Tree; Position : in out Cursor);
+ -- Delete element at Position; set Position to point to no element.
+private
+
+ type Node;
+ type Node_Access is access Node;
+
+ type Color is (Red, Black);
+
+ type Node is record
+ Element : aliased Element_Type;
+ Parent : Node_Access;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Pkg.Color;
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Access);
+
+ type Tree is new Ada.Finalization.Limited_Controlled with record
+ Root : Node_Access;
+ Nil : Node_Access;
+ -- Nil is the node pointed to by all links that would otherwise be
+ -- 'null'. This simplifies several algorithm (for example,
+ -- Node.Left.Color is always valid). Its parent, left, right links
+ -- are used as temp storage for some algorithms (especially Delete).
+ -- Nil.Color is Black.
+ end record;
+
+ type Cursor is record
+ Node : Node_Access := null;
+
+ Direction : Direction_Type := Unknown;
+ -- Set in First or Last, enforced in next/prev (cannot change
direction).
+
+ Left_Done : Boolean := True;
+ Right_Done : Boolean := True;
+ end record;
+
+ No_Element : constant Cursor :=
+ (Node => null,
+ Direction => Unknown,
+ Left_Done => True,
+ Right_Done => True);
+
+ type Iterator is new Iterators.Reversible_Iterator with
+ record
+ Root : Node_Access;
+ Nil : Node_Access;
+ end record;
+
+end SAL.Gen_Unbounded_Definite_Red_Black_Trees;
diff --git a/sal-gen_unbounded_definite_stacks-gen_image_aux.adb
b/sal-gen_unbounded_definite_stacks-gen_image_aux.adb
new file mode 100644
index 0000000..e900846
--- /dev/null
+++ b/sal-gen_unbounded_definite_stacks-gen_image_aux.adb
@@ -0,0 +1,42 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Unbounded;
+function SAL.Gen_Unbounded_Definite_Stacks.Gen_Image_Aux
+ (Item : in Stack;
+ Aux : in Aux_Data;
+ Depth : in SAL.Base_Peek_Type := 0)
+ return String
+is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ Last : constant Base_Peek_Type :=
+ (if Depth = 0
+ then Item.Top
+ else Base_Peek_Type'Min (Depth, Item.Top));
+begin
+ for I in 1 .. Last loop
+ Result := Result & Element_Image (Item.Peek (I), Aux);
+ if I /= Last then
+ Result := Result & ", ";
+ end if;
+ end loop;
+ Result := Result & ")";
+ return To_String (Result);
+end SAL.Gen_Unbounded_Definite_Stacks.Gen_Image_Aux;
diff --git a/sal-gen_unbounded_definite_stacks-gen_image_aux.ads
b/sal-gen_unbounded_definite_stacks-gen_image_aux.ads
new file mode 100644
index 0000000..ff732a8
--- /dev/null
+++ b/sal-gen_unbounded_definite_stacks-gen_image_aux.ads
@@ -0,0 +1,27 @@
+-- Abstract :
+--
+-- Image with auxiliary data for instantiations of parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Aux_Data (<>) is private;
+ with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
+function SAL.Gen_Unbounded_Definite_Stacks.Gen_Image_Aux
+ (Item : in Stack;
+ Aux : in Aux_Data;
+ Depth : in SAL.Base_Peek_Type := 0)
+ return String;
diff --git a/sal-gen_unbounded_definite_stacks.adb
b/sal-gen_unbounded_definite_stacks.adb
new file mode 100644
index 0000000..d916b6e
--- /dev/null
+++ b/sal-gen_unbounded_definite_stacks.adb
@@ -0,0 +1,178 @@
+-- Abstract:
+--
+-- see spec
+--
+-- Copyright (C) 1998, 2003, 2009, 2015, 2017, 2018 Stephen Leake. All
Rights Reserved.
+--
+-- SAL 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. SAL 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 SAL; see file COPYING. If not, write to the Free Software
+-- Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+-- USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- SAL, or you link SAL object files with other files to produce an
+-- executable, that 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 SAL.Gen_Unbounded_Definite_Stacks is
+
+ ----------
+ -- local subprogram bodies
+
+ procedure Grow (Stack : in out Sguds.Stack; Desired_Size : in
Base_Peek_Type)
+ is
+ New_Data : constant Element_Array_Access := new Element_Array (1 ..
Desired_Size);
+ begin
+ New_Data (1 .. Stack.Top) := Stack.Data (1 .. Stack.Top);
+ Free (Stack.Data);
+ Stack.Data := New_Data;
+ end Grow;
+
+ ----------
+ -- Spec visible subprograms
+ overriding procedure Finalize (Stack : in out Sguds.Stack)
+ is begin
+ if Stack.Data /= null then
+ Free (Stack.Data);
+ Stack.Top := Invalid_Peek_Index;
+ end if;
+ end Finalize;
+
+ overriding procedure Adjust (Stack : in out Sguds.Stack)
+ is begin
+ if Stack.Data /= null then
+ Stack.Data := new Element_Array'(Stack.Data.all);
+ end if;
+ end Adjust;
+
+ overriding
+ function "=" (Left, Right : in Sguds.Stack) return Boolean
+ is begin
+ if Left.Data = null then
+ return Right.Data = null;
+ elsif Left.Top /= Right.Top then
+ return False;
+ else
+ -- Assume stacks differ near top.
+ for I in reverse 1 .. Left.Top loop
+ if Left.Data (I) /= Right.Data (I) then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end if;
+ end "=";
+
+ procedure Clear (Stack : in out Sguds.Stack)
+ is begin
+ -- We don't change the reserved capacity, on the assumption the
+ -- stack will be used again.
+ Stack.Top := 0;
+ end Clear;
+
+ function Depth (Stack : in Sguds.Stack) return Base_Peek_Type
+ is begin
+ return Stack.Top;
+ end Depth;
+
+ function Is_Empty (Stack : in Sguds.Stack) return Boolean
+ is begin
+ return Stack.Top = 0;
+ end Is_Empty;
+
+ function Peek
+ (Stack : in Sguds.Stack;
+ Index : in Peek_Type := 1)
+ return Element_Type
+ is begin
+ return Stack.Data (Stack.Top - Index + 1);
+ end Peek;
+
+ procedure Pop (Stack : in out Sguds.Stack; Count : in Base_Peek_Type := 1)
+ is begin
+ if Stack.Top < Count then
+ raise Container_Empty;
+ else
+ Stack.Top := Stack.Top - Count;
+ end if;
+ end Pop;
+
+ function Pop (Stack : in out Sguds.Stack) return Element_Type
+ is begin
+ if Stack.Top = 0 then
+ raise Container_Empty;
+ else
+ return Result : constant Element_Type := Stack.Peek (1)
+ do
+ Stack.Top := Stack.Top - 1;
+ end return;
+ end if;
+ end Pop;
+
+ procedure Push (Stack : in out Sguds.Stack; Item : in Element_Type)
+ is begin
+ if Stack.Data = null then
+ -- Adding a generic parameter for a reasonably large default initial
+ -- size here makes Wisitoken McKenzie recover slightly slower,
+ -- presumably due to increased cache thrashing.
+ Stack.Data := new Element_Array (1 .. 2);
+ elsif Stack.Top = Stack.Data'Last then
+ Grow (Stack, Desired_Size => 2 * Stack.Data'Last);
+ end if;
+ Stack.Top := Stack.Top + 1;
+ Stack.Data (Stack.Top) := Item;
+ end Push;
+
+ function Top (Stack : in Sguds.Stack) return Element_Type
+ is begin
+ if Stack.Top < 1 then
+ raise SAL.Container_Empty;
+ else
+ return Peek (Stack, 1);
+ end if;
+ end Top;
+
+ procedure Set_Depth
+ (Stack : in out Sguds.Stack;
+ Depth : in Peek_Type)
+ is begin
+ if Stack.Data = null then
+ Stack.Data := new Element_Array (1 .. 2 * Depth);
+ elsif Depth > Stack.Data'Last then
+ Grow (Stack, Desired_Size => 2 * Depth);
+ end if;
+ end Set_Depth;
+
+ procedure Set
+ (Stack : in out Sguds.Stack;
+ Index : in Peek_Type;
+ Depth : in Peek_Type;
+ Element : in Element_Type)
+ is begin
+ -- Same Position algorithm as in Peek
+ Stack.Top := Depth;
+ Stack.Data (Depth - Index + 1) := Element;
+ end Set;
+
+ function Constant_Ref
+ (Container : aliased in Stack'Class;
+ Position : in Peek_Type)
+ return Constant_Ref_Type
+ is begin
+ return
+ (Element => Container.Data (Container.Top - Position + 1)'Access,
+ Dummy => 1);
+ end Constant_Ref;
+
+end SAL.Gen_Unbounded_Definite_Stacks;
diff --git a/sal-gen_unbounded_definite_stacks.ads
b/sal-gen_unbounded_definite_stacks.ads
new file mode 100644
index 0000000..413071f
--- /dev/null
+++ b/sal-gen_unbounded_definite_stacks.ads
@@ -0,0 +1,133 @@
+-- Abstract:
+--
+-- Stack implementation.
+--
+-- Copyright (C) 1998-2000, 2002-2003, 2009, 2015, 2017, 2018 Stephen Leake.
All Rights Reserved.
+--
+-- SAL 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. SAL 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 SAL; see file COPYING. If not, write to the Free Software
+-- Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+-- USA.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with Ada.Unchecked_Deallocation;
+generic
+ type Element_Type is private;
+package SAL.Gen_Unbounded_Definite_Stacks is
+
+ package Sguds renames SAL.Gen_Unbounded_Definite_Stacks;
+
+ type Stack is new Ada.Finalization.Controlled with private
+ with
+ Constant_Indexing => Constant_Ref;
+
+ Empty_Stack : constant Stack;
+
+ overriding procedure Finalize (Stack : in out Sguds.Stack);
+ overriding procedure Adjust (Stack : in out Sguds.Stack);
+
+ overriding function "=" (Left, Right : in Sguds.Stack) return Boolean;
+
+ procedure Clear (Stack : in out Sguds.Stack);
+ -- Empty Stack of all items.
+
+ function Depth (Stack : in Sguds.Stack) return Base_Peek_Type;
+ -- Returns current count of items in the Stack
+
+ function Is_Empty (Stack : in Sguds.Stack) return Boolean;
+ -- Returns true iff no items are in Stack.
+
+ function Peek
+ (Stack : in Sguds.Stack;
+ Index : in Peek_Type := 1)
+ return Element_Type;
+ -- Return the Index'th item from the top of Stack; the Item is _not_
removed.
+ -- Top item has index 1.
+ --
+ -- Raises Constraint_Error if Index > Depth.
+ --
+ -- See also Constant_Ref, implicit indexing
+
+ procedure Pop (Stack : in out Sguds.Stack; Count : in Base_Peek_Type := 1);
+ -- Remove Count Items from the top of Stack, discard them.
+ --
+ -- Raises Container_Empty if there are fewer than Count items on
+ -- Stack.
+
+ function Pop (Stack : in out Sguds.Stack) return Element_Type;
+ -- Remove Item from the top of Stack, and return it.
+ --
+ -- Raises Container_Empty if Is_Empty.
+
+ procedure Push (Stack : in out Sguds.Stack; Item : in Element_Type);
+ -- Add Item to the top of Stack.
+ --
+ -- May raise Container_Full.
+
+ function Top (Stack : in Sguds.Stack) return Element_Type;
+ -- Return the item at the top of Stack; the Item is _not_ removed.
+ -- Same as Peek (Stack, 1).
+ --
+ -- Raises Container_Empty if Is_Empty.
+
+ procedure Set_Depth
+ (Stack : in out Sguds.Stack;
+ Depth : in Peek_Type);
+ -- Empty Stack, set its Depth to Depth. Must be followed by Set
+ -- for each element.
+ --
+ -- Useful when creating a stack from pre-existing data.
+
+ procedure Set
+ (Stack : in out Sguds.Stack;
+ Index : in Peek_Type;
+ Depth : in Peek_Type;
+ Element : in Element_Type);
+ -- Set a Stack element. Index is the same as Peek Index; Depth is
+ -- used to compute the index in the underlying array.
+ --
+ -- Stack must have been initialized by Set_Depth.
+ --
+ -- Useful when creating a stack from pre-existing data.
+
+ type Constant_Ref_Type (Element : not null access constant Element_Type) is
+ record
+ Dummy : Integer := raise Program_Error with "uninitialized reference";
+ end record
+ with Implicit_Dereference => Element;
+
+ function Constant_Ref
+ (Container : aliased in Stack'Class;
+ Position : in Peek_Type)
+ return Constant_Ref_Type;
+
+private
+
+ type Element_Array is array (Peek_Type range <>) of aliased Element_Type;
+ type Element_Array_Access is access Element_Array;
+ procedure Free is new Ada.Unchecked_Deallocation (Element_Array,
Element_Array_Access);
+
+ type Stack is new Ada.Finalization.Controlled with record
+ Top : Base_Peek_Type := Invalid_Peek_Index; -- empty
+ Data : Element_Array_Access;
+
+ -- Top of stack is at Data (Top).
+ -- Data (1 .. Last_Index) has been set at some point.
+ end record;
+
+ Empty_Stack : constant Stack := (Ada.Finalization.Controlled with
Invalid_Peek_Index, null);
+
+end SAL.Gen_Unbounded_Definite_Stacks;
diff --git a/sal-gen_unbounded_definite_vectors-gen_comparable.adb
b/sal-gen_unbounded_definite_vectors-gen_comparable.adb
new file mode 100644
index 0000000..1bd9251
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors-gen_comparable.adb
@@ -0,0 +1,73 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable is
+
+ function Compare (Left, Right : in Vector) return Compare_Result
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Left.Length = 0 then
+ if Right.Length = 0 then
+ return Equal;
+ else
+ -- null is less than non-null
+ return Less;
+ end if;
+
+ elsif Right.Length = 0 then
+ return Greater;
+
+ else
+ declare
+ I : Base_Peek_Type := To_Peek_Type (Left.First);
+ J : Base_Peek_Type := To_Peek_Type (Right.First);
+
+ Left_Last : constant Base_Peek_Type := To_Peek_Type (Left.Last);
+ Right_Last : constant Base_Peek_Type := To_Peek_Type (Right.Last);
+ begin
+ loop
+ exit when I > Left_Last or J > Right_Last;
+
+ case Element_Compare (Left.Elements (I), Right.Elements (J)) is
+ when Less =>
+ return Less;
+ when Equal =>
+ I := I + 1;
+ J := J + 1;
+ when Greater =>
+ return Greater;
+ end case;
+ end loop;
+ if I > Left_Last then
+ if J > Right_Last then
+ return Equal;
+ else
+ -- right is longer
+ return Less;
+ end if;
+ else
+ -- left is longer
+ return Greater;
+ end if;
+ end;
+ end if;
+ end Compare;
+
+end SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable;
diff --git a/sal-gen_unbounded_definite_vectors-gen_comparable.ads
b/sal-gen_unbounded_definite_vectors-gen_comparable.ads
new file mode 100644
index 0000000..a12f81a
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors-gen_comparable.ads
@@ -0,0 +1,30 @@
+-- Abstract :
+--
+-- Add "<" to parent
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ with function Element_Compare (Left, Right : in Element_Type) return
Compare_Result;
+package SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable is
+
+ type Vector is new SAL.Gen_Unbounded_Definite_Vectors.Vector with null
record;
+
+ function Compare (Left, Right : in Vector) return Compare_Result;
+ -- Similar to Ada "<" for arrays; Ada Reference Manual
+ -- section 4.5.2 para 26/3.
+
+end SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable;
diff --git a/sal-gen_unbounded_definite_vectors-gen_image.adb
b/sal-gen_unbounded_definite_vectors-gen_image.adb
new file mode 100644
index 0000000..03a1c5f
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors-gen_image.adb
@@ -0,0 +1,50 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Fixed;
+with Ada.Strings.Unbounded;
+function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image (Item : in Vector;
Strict : in Boolean := False) return String
+is
+ use all type Ada.Containers.Count_Type;
+ use Ada.Strings;
+ use Ada.Strings.Fixed;
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ First : constant Base_Peek_Type := To_Peek_Type (Item.First_Index);
+ Last : constant Base_Peek_Type := To_Peek_Type (Item.Last_Index);
+begin
+ if Strict and Item.Length = 0 then
+ return "(" & Trim (Index_Type'Image (Index_Type'First), Left) & " .. " &
+ Trim (Index_Type'Image (Extended_Index'First), Left) & " => <>)";
+
+ elsif Strict and Item.Length = 1 then
+ return "(" & Trim (Index_Type'Image (Index_Type'First), Left) & " => " &
+ Element_Image (Item.Elements (First)) & ")";
+
+ else
+ for I in First .. Last loop
+ Result := Result & Element_Image (Item.Elements (I));
+ if I /= Last then
+ Result := Result & ", ";
+ end if;
+ end loop;
+ Result := Result & ")";
+ return To_String (Result);
+ end if;
+end SAL.Gen_Unbounded_Definite_Vectors.Gen_Image;
diff --git a/sal-gen_unbounded_definite_vectors-gen_image.ads
b/sal-gen_unbounded_definite_vectors-gen_image.ads
new file mode 100644
index 0000000..1ace2fe
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors-gen_image.ads
@@ -0,0 +1,24 @@
+-- Abstract :
+--
+-- Image of parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ with function Element_Image (Item : in Element_Type) return String;
+function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image (Item : in Vector;
Strict : in Boolean := False) return String;
+-- Image of Item, in Ada aggregate syntax. If Strict, use correct
+-- syntax for 0 and 1 item; otherwise, use () and (item).
diff --git a/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
b/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
new file mode 100644
index 0000000..c498e0e
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
@@ -0,0 +1,36 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Unbounded;
+function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector;
Aux : in Aux_Data) return String
+is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ First : constant Base_Peek_Type := To_Peek_Type (Item.First_Index);
+ Last : constant Base_Peek_Type := To_Peek_Type (Item.Last_Index);
+begin
+ for I in First .. Last loop
+ Result := Result & Element_Image (Item.Elements (I), Aux);
+ if I /= Last then
+ Result := Result & ", ";
+ end if;
+ end loop;
+ Result := Result & ")";
+ return To_String (Result);
+end SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux;
diff --git a/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
b/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
new file mode 100644
index 0000000..0be7c41
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
@@ -0,0 +1,23 @@
+-- Abstract :
+--
+-- Image with auxiliary data for instantiations of parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Aux_Data (<>) is private;
+ with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
+function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector;
Aux : in Aux_Data) return String;
diff --git a/sal-gen_unbounded_definite_vectors.adb
b/sal-gen_unbounded_definite_vectors.adb
new file mode 100644
index 0000000..8faaf88
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors.adb
@@ -0,0 +1,578 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Unbounded_Definite_Vectors is
+
+ function To_Peek_Type (Item : in Extended_Index) return Base_Peek_Type
+ is begin
+ return Base_Peek_Type'Base (Item - Index_Type'First) + Peek_Type'First;
+ end To_Peek_Type;
+
+ function To_Index_Type (Item : in Base_Peek_Type) return Extended_Index
+ is begin
+ return Extended_Index (Item - Peek_Type'First) + Index_Type'First;
+ end To_Index_Type;
+
+ procedure Grow (Elements : in out Array_Access; Index : in Base_Peek_Type)
+ is
+ -- Reallocate Elements so Elements (Index) is a valid element.
+
+ Old_First : constant Peek_Type := Elements'First;
+ Old_Last : constant Peek_Type := Elements'Last;
+ New_First : Peek_Type := Old_First;
+ New_Last : Peek_Type := Old_Last;
+ New_Length : Peek_Type := Elements'Length;
+
+ New_Array : Array_Access;
+ begin
+ loop
+ exit when New_First <= Index;
+ New_Length := New_Length * 2;
+ New_First := Peek_Type'Max (Peek_Type'First, Old_Last - New_Length +
1);
+ end loop;
+ loop
+ exit when New_Last >= Index;
+ New_Length := New_Length * 2;
+ New_Last := Peek_Type'Min (Peek_Type'Last, New_First + New_Length -
1);
+ end loop;
+
+ New_Array := new Array_Type (New_First .. New_Last);
+
+ -- We'd like to use this:
+ --
+ -- New_Array (New_First .. Old_First - 1) := (others => <>);
+ --
+ -- but that can overflow the stack, since the aggregate is allocated
+ -- on the stack.
+
+ for I in New_First .. Old_First - 1 loop
+ New_Array (I .. I) := (others => <>);
+ end loop;
+
+ New_Array (Old_First .. Old_Last) := Elements.all;
+
+ for I in Old_Last + 1 .. New_Last loop
+ New_Array (I .. I) := (others => <>);
+ end loop;
+
+ Free (Elements);
+ Elements := New_Array;
+ end Grow;
+
+ ----------
+ -- public subprograms
+
+ overriding procedure Finalize (Container : in out Vector)
+ is begin
+ Free (Container.Elements);
+ Container.First := No_Index;
+ Container.Last := No_Index;
+ end Finalize;
+
+ overriding procedure Adjust (Container : in out Vector)
+ is begin
+ if Container.Elements /= null then
+ Container.Elements := new Array_Type'(Container.Elements.all);
+ end if;
+ end Adjust;
+
+ function Length (Container : in Vector) return Ada.Containers.Count_Type
+ is begin
+ -- We assume the type ranges are sensible, so no exceptions occur
+ -- here.
+ if Container.Elements = null then
+ return 0;
+ else
+ return Ada.Containers.Count_Type (To_Peek_Type (Container.Last) -
Container.Elements'First + 1);
+ end if;
+ end Length;
+
+ function Capacity (Container : in Vector) return Ada.Containers.Count_Type
+ is begin
+ if Container.Elements = null then
+ return 0;
+ else
+ return Ada.Containers.Count_Type (Container.Elements'Length);
+ end if;
+ end Capacity;
+
+ function Element (Container : Vector; Index : Index_Type) return
Element_Type
+ is begin
+ return Container.Elements (To_Peek_Type (Index));
+ end Element;
+
+ procedure Replace_Element (Container : Vector; Index : Index_Type; New_Item
: in Element_Type)
+ is begin
+ Container.Elements (To_Peek_Type (Index)) := New_Item;
+ end Replace_Element;
+
+ function First_Index (Container : Vector) return Extended_Index
+ is begin
+ if Container.Elements = null then
+ return No_Index + 1;
+ else
+ return Container.First;
+ end if;
+ end First_Index;
+
+ function Last_Index (Container : Vector) return Extended_Index
+ is begin
+ if Container.Elements = null then
+ return No_Index;
+ else
+ return Container.Last;
+ end if;
+ end Last_Index;
+
+ procedure Append (Container : in out Vector; New_Item : in Element_Type)
+ is begin
+ if Container.First = No_Index then
+ Container.First := Index_Type'First;
+ Container.Last := Index_Type'First;
+ else
+ Container.Last := Container.Last + 1;
+ end if;
+
+ declare
+ J : constant Base_Peek_Type := To_Peek_Type (Container.Last);
+ begin
+ if Container.Elements = null then
+ Container.Elements := new Array_Type (J .. J);
+
+ elsif J > Container.Elements'Last then
+ Grow (Container.Elements, J);
+ end if;
+
+ Container.Elements (J) := New_Item;
+ end;
+ end Append;
+
+ procedure Append (Container : in out Vector; New_Items : in Vector)
+ is
+ use all type Ada.Containers.Count_Type;
+ Old_Last : Extended_Index := Container.Last;
+ begin
+ if New_Items.Length = 0 then
+ return;
+ end if;
+
+ if Container.First = No_Index then
+ Container.First := Index_Type'First;
+ Old_Last := Container.First - 1;
+ Container.Last := Container.First + Extended_Index
(New_Items.Length) - 1;
+ else
+ Container.Last := Container.Last + Extended_Index (New_Items.Length);
+ end if;
+
+ declare
+ I : constant Peek_Type := To_Peek_Type (Old_Last + 1);
+ J : constant Peek_Type := To_Peek_Type (Container.Last);
+ begin
+ if Container.Elements = null then
+ Container.Elements := new Array_Type (I .. J);
+ elsif J > Container.Elements'Last then
+ Grow (Container.Elements, J);
+ end if;
+
+ Container.Elements (I .. J) := New_Items.Elements
+ (To_Peek_Type (New_Items.First) .. To_Peek_Type (New_Items.Last));
+ end;
+ end Append;
+
+ procedure Prepend (Container : in out Vector; New_Item : in Element_Type)
+ is begin
+ if Container.First = No_Index then
+ Container.First := Index_Type'First;
+ Container.Last := Index_Type'First;
+ else
+ Container.First := Container.First - 1;
+ end if;
+
+ declare
+ J : constant Peek_Type := To_Peek_Type (Container.First);
+ begin
+ if Container.Elements = null then
+ Container.Elements := new Array_Type (J .. J);
+
+ elsif J < Container.Elements'First then
+ Grow (Container.Elements, J);
+ end if;
+
+ Container.Elements (J) := New_Item;
+ end;
+ end Prepend;
+
+ procedure Prepend
+ (Target : in out Vector;
+ Source : in Vector;
+ Source_First : in Index_Type;
+ Source_Last : in Index_Type)
+ is
+ Source_I : constant Peek_Type := To_Peek_Type (Source_First);
+ Source_J : constant Peek_Type := To_Peek_Type (Source_Last);
+ begin
+ if Target.Elements = null then
+ Target.Elements := new Array_Type'(Source.Elements (Source_I ..
Source_J));
+ Target.First := Source_First;
+ Target.Last := Source_Last;
+ else
+ declare
+ New_First : constant Index_Type := Target.First - (Source_Last -
Source_First + 1);
+ I : constant Peek_Type := To_Peek_Type (New_First);
+ J : constant Peek_Type := To_Peek_Type (Target.First - 1);
+ begin
+ if Target.Elements'First > I then
+ Grow (Target.Elements, I);
+ end if;
+ Target.Elements (I .. J) := Source.Elements (Source_I .. Source_J);
+ Target.First := New_First;
+ end;
+ end if;
+ end Prepend;
+
+ procedure Insert
+ (Container : in out Vector;
+ Element : in Element_Type;
+ Before : in Index_Type)
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Container.Length = 0 then
+ Container.Append (Element);
+ else
+ Container.Last := Container.Last + 1;
+
+ declare
+ J : constant Peek_Type := To_Peek_Type (Before);
+ K : constant Base_Peek_Type := To_Peek_Type (Container.Last);
+ begin
+ if K > Container.Elements'Last then
+ Grow (Container.Elements, K);
+ end if;
+
+ Container.Elements (J + 1 .. K) := Container.Elements (J .. K - 1);
+ Container.Elements (J) := Element;
+ end;
+ end if;
+ end Insert;
+
+ procedure Merge
+ (Target : in out Vector;
+ Source : in out Vector)
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Source.Length = 0 then
+ Source.Clear;
+
+ elsif Target.Length = 0 then
+ Target := Source;
+ Source.Clear;
+
+ else
+ declare
+ New_First : constant Index_Type := Extended_Index'Min
(Target.First, Source.First);
+ New_Last : constant Index_Type := Extended_Index'Max
(Target.Last, Source.Last);
+ New_I : constant Peek_Type := To_Peek_Type (New_First);
+ New_J : constant Base_Peek_Type := To_Peek_Type (New_Last);
+ begin
+ if New_I < Target.Elements'First then
+ Grow (Target.Elements, New_I);
+ end if;
+ if New_J > Target.Elements'Last then
+ Grow (Target.Elements, New_J);
+ end if;
+
+ Target.Elements (To_Peek_Type (Source.First) .. To_Peek_Type
(Source.Last)) := Source.Elements
+ (To_Peek_Type (Source.First) .. To_Peek_Type (Source.Last));
+
+ Target.First := New_First;
+ Target.Last := New_Last;
+
+ Source.Clear;
+ end;
+ end if;
+ end Merge;
+
+ function To_Vector (Item : in Element_Type; Count : in
Ada.Containers.Count_Type := 1) return Vector
+ is begin
+ return Result : Vector do
+ for I in 1 .. Count loop
+ Result.Append (Item);
+ end loop;
+ end return;
+ end To_Vector;
+
+ function "+" (Element : in Element_Type) return Vector
+ is begin
+ return Result : Vector do
+ Result.Append (Element);
+ end return;
+ end "+";
+
+ function "&" (Left, Right : in Element_Type) return Vector
+ is begin
+ return Result : Vector do
+ Result.Append (Left);
+ Result.Append (Right);
+ end return;
+ end "&";
+
+ function "&" (Left : in Vector; Right : in Element_Type) return Vector
+ is begin
+ return Result : Vector := Left do
+ Result.Append (Right);
+ end return;
+ end "&";
+
+ procedure Set_First (Container : in out Vector; First : in Index_Type)
+ is
+ J : constant Peek_Type := To_Peek_Type (First);
+ begin
+ Container.First := First;
+ if Container.Last = No_Index then
+ Container.Last := First - 1;
+ end if;
+
+ if Container.Last >= First then
+ if Container.Elements = null then
+ Container.Elements := new Array_Type'(J .. To_Peek_Type
(Container.Last) => <>);
+
+ elsif Container.Elements'First > J then
+ Grow (Container.Elements, J);
+ end if;
+ end if;
+ end Set_First;
+
+ procedure Set_Last (Container : in out Vector; Last : in Extended_Index)
+ is
+ J : constant Base_Peek_Type := To_Peek_Type (Last);
+ begin
+ Container.Last := Last;
+ if Container.First = No_Index then
+ Container.First := Last + 1;
+ end if;
+
+ if Last >= Container.First then
+ if Container.Elements = null then
+ Container.Elements := new Array_Type'(To_Peek_Type
(Container.First) .. J => <>);
+
+ elsif Container.Elements'Last < J then
+ Grow (Container.Elements, J);
+ end if;
+ end if;
+ end Set_Last;
+
+ 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);
+ end Set_First_Last;
+
+ procedure Set_Length (Container : in out Vector; Length : in
Ada.Containers.Count_Type)
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Container.First = No_Index then
+ Container.First := Index_Type'First;
+ Container.Last := Container.First - 1;
+ end if;
+ if Length > 0 then
+ Container.Set_Last (Index_Type (Length) + Container.First - 1);
+ 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);
+ begin
+ Container.Elements (J .. J) := (J => <>);
+ if Index = Container.Last then
+ Container.Last := Container.Last - 1;
+ end if;
+ end Delete;
+
+ function Contains (Container : in Vector; Element : in Element_Type) return
Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Container.Length = 0 then
+ return False;
+ else
+ for It of Container.Elements.all loop
+ if It = Element then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end if;
+ end Contains;
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position.Index /= Invalid_Peek_Index;
+ end Has_Element;
+
+ function Element (Position : Cursor) return Element_Type
+ is begin
+ return Position.Container.Elements (Position.Index);
+ end Element;
+
+ function First (Container : aliased in Vector) return Cursor
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Container.Length = 0 then
+ return No_Element;
+ else
+ return (Container'Access, To_Peek_Type (Container.First));
+ end if;
+ end First;
+
+ function Next (Position : in Cursor) return Cursor
+ is begin
+ if Position = No_Element then
+ return No_Element;
+ elsif Position.Index < To_Peek_Type (Position.Container.Last) then
+ return (Position.Container, Position.Index + 1);
+ else
+ return No_Element;
+ end if;
+ end Next;
+
+ procedure Next (Position : in out Cursor)
+ is begin
+ if Position = No_Element then
+ null;
+ elsif Position.Index < To_Peek_Type (Position.Container.Last) then
+ Position.Index := Position.Index + 1;
+ else
+ Position := No_Element;
+ end if;
+ end Next;
+
+ function To_Cursor
+ (Container : aliased in Vector;
+ Index : in Extended_Index)
+ return Cursor
+ is begin
+ if Index not in Container.First .. Container.Last then
+ return No_Element;
+ else
+ return (Container'Access, To_Peek_Type (Index));
+ end if;
+ end To_Cursor;
+
+ function To_Index (Position : in Cursor) return Extended_Index
+ is begin
+ if Position = No_Element then
+ return No_Index;
+ else
+ return To_Index_Type (Position.Index);
+ end if;
+ end To_Index;
+
+ function Constant_Ref (Container : aliased Vector; Index : in Index_Type)
return Constant_Reference_Type
+ is
+ J : constant Peek_Type := To_Peek_Type (Index);
+ begin
+ return (Element => Container.Elements (J)'Access);
+ end Constant_Ref;
+
+ function Variable_Ref
+ (Container : aliased in Vector;
+ Index : in Index_Type)
+ return Variable_Reference_Type
+ is
+ J : constant Peek_Type := To_Peek_Type (Index);
+ begin
+ return (Element => Container.Elements (J)'Access);
+ end Variable_Ref;
+
+ overriding function First (Object : Iterator) return Cursor
+ is begin
+ if Object.Container.Elements = null then
+ return (null, Invalid_Peek_Index);
+ else
+ return (Object.Container, To_Peek_Type
(Object.Container.First_Index));
+ end if;
+ end First;
+
+ overriding function Last (Object : Iterator) return Cursor
+ is begin
+ if Object.Container.Elements = null then
+ return (null, Invalid_Peek_Index);
+ else
+ return (Object.Container, To_Peek_Type (Object.Container.Last_Index));
+ end if;
+ end Last;
+
+ overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
+ is begin
+ if Position.Index = To_Peek_Type (Object.Container.Last) then
+ return (null, Invalid_Peek_Index);
+ else
+ return (Object.Container, Position.Index + 1);
+ end if;
+ end Next;
+
+ overriding function Previous (Object : in Iterator; Position : in Cursor)
return Cursor
+ is begin
+ if Position.Index = To_Peek_Type (Index_Type'First) then
+ return (null, Invalid_Peek_Index);
+ else
+ return (Object.Container, Position.Index - 1);
+ end if;
+ end Previous;
+
+ function Iterate (Container : aliased in Vector) return
Iterator_Interfaces.Reversible_Iterator'Class
+ is begin
+ return Iterator'(Container => Container'Unrestricted_Access);
+ end Iterate;
+
+ function Constant_Ref (Container : aliased Vector; Position : in Cursor)
return Constant_Reference_Type
+ is begin
+ return (Element => Container.Elements (Position.Index)'Access);
+ end Constant_Ref;
+
+ function Variable_Ref
+ (Container : aliased in Vector;
+ Position : in Cursor)
+ return Variable_Reference_Type
+ is begin
+ return (Element => Container.Elements (Position.Index)'Access);
+ end Variable_Ref;
+
+end SAL.Gen_Unbounded_Definite_Vectors;
diff --git a/sal-gen_unbounded_definite_vectors.ads
b/sal-gen_unbounded_definite_vectors.ads
new file mode 100644
index 0000000..799e73c
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors.ads
@@ -0,0 +1,226 @@
+-- Abstract :
+--
+-- A simple unbounded vector of definite items, intended to be faster
+-- than Ada.Containers.Vectors.
+--
+-- Prepend is as fast (in amortized time) as Append.
+--
+-- It provides no checking of cursor tampering; higher level code
+-- must ensure that.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with Ada.Iterator_Interfaces;
+with Ada.Unchecked_Deallocation;
+generic
+ type Index_Type is range <>;
+ type Element_Type is private;
+package SAL.Gen_Unbounded_Definite_Vectors is
+
+ subtype Extended_Index is Index_Type'Base
+ range Index_Type'First - 1 ..
+ Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
+
+ No_Index : constant Extended_Index := Extended_Index'First;
+
+ type Vector is new Ada.Finalization.Controlled with private with
+ Constant_Indexing => Constant_Ref,
+ Variable_Indexing => Variable_Ref,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
+ Empty_Vector : constant Vector;
+
+ overriding procedure Finalize (Container : in out Vector);
+ overriding procedure Adjust (Container : in out Vector);
+
+ overriding function "=" (Left, Right : in Vector) return Boolean is
+ (raise Programmer_Error);
+ -- Use Gen_Comparable child.
+
+ function Length (Container : in Vector) return Ada.Containers.Count_Type;
+ function Capacity (Container : in Vector) return Ada.Containers.Count_Type;
+
+ procedure Clear (Container : in out Vector)
+ renames Finalize;
+
+ function First_Index (Container : Vector) return Extended_Index;
+ -- No_Index + 1 when Container is empty, so "for I in C.First_Index
+ -- .. C.Last_Index loop" works.
+
+ function Last_Index (Container : Vector) return Extended_Index;
+ -- No_Index when Container is empty.
+
+ function Element (Container : Vector; Index : Index_Type) return
Element_Type
+ with Pre => Index >= Container.First_Index and Index <=
Container.Last_Index;
+
+ procedure Replace_Element (Container : Vector; Index : Index_Type; New_Item
: in Element_Type);
+
+ procedure Append (Container : in out Vector; New_Item : in Element_Type);
+ -- Insert New_Item at end of Container.
+ --
+ -- Raises Constraint_Error if index of new item would be greater than
+ -- Index_Type'Last.
+
+ procedure Append (Container : in out Vector; New_Items : in Vector);
+ -- Insert all elements of New_Items at end of Container.
+
+ procedure Prepend (Container : in out Vector; New_Item : in Element_Type);
+ -- Insert New_Item at beginning of Container.
+ --
+ -- Raises Constraint_Error if index of new item would be less than
+ -- Index_Type'First.
+
+ procedure Prepend
+ (Target : in out Vector;
+ Source : in Vector;
+ Source_First : in Index_Type;
+ Source_Last : in Index_Type);
+ -- Copy Source (Source_First .. Source_Last) to Target, before
+ -- Target.First_Index.
+
+ procedure Insert
+ (Container : in out Vector;
+ Element : in Element_Type;
+ Before : in Index_Type);
+ -- Existing elements at Before and after are slid to higher indices.
+
+ procedure Merge
+ (Target : in out Vector;
+ Source : in out Vector);
+ -- Copy all elements from Source to Target, to the same index range,
+ -- deleting them from Source, and overwriting overlapping ranges.
+
+ function To_Vector (Item : in Element_Type; Count : in
Ada.Containers.Count_Type := 1) return Vector;
+
+ function "+" (Element : in Element_Type) return Vector;
+
+ function "&" (Left, Right : in Element_Type) return Vector;
+ function "&" (Left : in Vector; Right : in Element_Type) return Vector;
+
+ 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);
+ -- Default First is Index_Type'First.
+ -- Elements with First <= index <= Last that have not been set have
+ -- Element_Type default 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.
+
+ procedure Delete (Container : in out Vector; Index : in Index_Type);
+ -- Replace Index element contents with default. If Index =
+ -- Container.Last_Index, Container.Last_Index is decremented.
+
+ function Contains (Container : in Vector; Element : in Element_Type) return
Boolean;
+ -- Return True if Element is in Container, False if not.
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is null record
+ with Implicit_Dereference => Element;
+
+ 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;
+
+ 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;
+
+ type Cursor is private;
+
+ No_Element : constant Cursor;
+
+ function Has_Element (Position : Cursor) return Boolean;
+ function Element (Position : Cursor) return Element_Type
+ with Pre => Position /= No_Element;
+ function First (Container : aliased in Vector) return Cursor;
+ function Next (Position : in Cursor) return Cursor;
+ procedure Next (Position : in out Cursor);
+
+ function To_Cursor
+ (Container : aliased in Vector;
+ Index : in Extended_Index)
+ return Cursor;
+
+ function To_Index (Position : in Cursor) return Extended_Index;
+
+ package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
+
+ function Iterate (Container : aliased in Vector) return
Iterator_Interfaces.Reversible_Iterator'Class;
+
+ function Constant_Ref (Container : aliased in Vector; Position : in Cursor)
return Constant_Reference_Type
+ with Pre => Has_Element (Position);
+
+ function Variable_Ref (Container : aliased in Vector; Position : in
Cursor) return Variable_Reference_Type
+ with Pre => Has_Element (Position);
+
+private
+
+ type Array_Type is array (SAL.Peek_Type range <>) of aliased Element_Type;
+ type Array_Access is access Array_Type;
+ procedure Free is new Ada.Unchecked_Deallocation (Array_Type, Array_Access);
+
+ type Vector is new Ada.Finalization.Controlled with
+ record
+ Elements : Array_Access;
+ First : Extended_Index := No_Index;
+ Last : Extended_Index := No_Index;
+ end record;
+
+ type Vector_Access is access constant Vector;
+ for Vector_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Container : Vector_Access := null;
+ Index : Base_Peek_Type := Invalid_Peek_Index;
+ end record;
+
+ type Iterator is new Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Vector_Access;
+ end record;
+
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ Empty_Vector : constant Vector := (Ada.Finalization.Controlled with others
=> <>);
+
+ No_Element : constant Cursor := (others => <>);
+
+ ----------
+ -- Visible for child package
+
+ function To_Peek_Type (Item : in Extended_Index) return Base_Peek_Type with
Inline;
+
+end SAL.Gen_Unbounded_Definite_Vectors;
diff --git a/sal.adb b/sal.adb
new file mode 100644
index 0000000..6c5013e
--- /dev/null
+++ b/sal.adb
@@ -0,0 +1,32 @@
+-- Abstract:
+--
+-- See spec.
+--
+-- Copyright (C) 1997 - 2004, 2006, 2009 Stephen Leake. All Rights Reserved.
+--
+-- SAL 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. SAL 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 SAL; see
+-- file COPYING. If not, write to the Free Software Foundation, 59
+-- Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- SAL, or you link SAL object files with other files to produce
+-- an executable, that 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.
+--
+package body SAL is
+
+ function Version return String is
+ begin
+ return "SAL 2.01";
+ end Version;
+
+end SAL;
diff --git a/sal.ads b/sal.ads
new file mode 100644
index 0000000..0d5a4e6
--- /dev/null
+++ b/sal.ads
@@ -0,0 +1,75 @@
+-- Abstract:
+--
+-- Root package for Stephe's Ada Library packages.
+--
+-- See sal.html for more information.
+--
+-- See http://stephe-leake.org/ada/sal.html for the
+-- latest version.
+--
+-- Contact Stephe at stephen_leake@stephe-leake.org.
+--
+-- Copyright (C) 1997 - 2004, 2008, 2009, 2015, 2017, 2018 Stephen Leake.
All Rights Reserved.
+--
+-- SAL 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. SAL 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 SAL; see
+-- file COPYING. If not, write to the Free Software Foundation, 59
+-- Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- SAL, or you link SAL object files with other files to produce
+-- an executable, that does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers;
+
+package SAL is
+ pragma Pure;
+
+ function Version return String;
+ -- Returns string with format "SAL x.xx".
+
+ Container_Empty : exception;
+ Container_Full : exception;
+ Config_File_Error : exception;
+ Domain_Error : exception;
+ Duplicate_Key : exception;
+ Initialization_Error : exception;
+ Invalid_Format : exception;
+ Invalid_Limit : exception;
+ Invalid_Operation : exception;
+ Invalid_Range : exception;
+ Iterator_Error : exception;
+ Not_Found : exception;
+ Not_Implemented : exception;
+ Parameter_Error : exception;
+ Programmer_Error : exception;
+ Range_Error : exception;
+
+ --------------
+ -- General options
+
+ type Direction_Type is (Forward, Backward);
+
+ type Duplicate_Action_Type is (Allow, Ignore, Error);
+
+ type Overflow_Action_Type is (Overwrite, Error);
+
+ -- We use a new type for Peek_Type, not just
+ -- Ada.Containers.Count_Type, to enforce Peek_Type'First = top/first.
+ type Base_Peek_Type is new Ada.Containers.Count_Type range 0 ..
Ada.Containers.Count_Type'Last;
+ subtype Peek_Type is Base_Peek_Type range 1 .. Base_Peek_Type'Last;
+ Invalid_Peek_Index : constant Base_Peek_Type := 0;
+
+ type Compare_Result is (Less, Equal, Greater);
+end SAL;
diff --git a/standard_common.gpr b/standard_common.gpr
new file mode 100644
index 0000000..82e2fc9
--- /dev/null
+++ b/standard_common.gpr
@@ -0,0 +1,118 @@
+-- Standard settings for all of Stephe's Ada projects.
+project Standard_Common is
+ for Source_Dirs use ();
+
+ type Build_Type is ("Debug", "Normal");
+ Build : Build_Type := External ("Standard_Common_Build", "Normal");
+
+ type Profile_Type is ("On", "Off");
+ Profile : Profile_Type := External ("Standard_Common_Profile", "Off");
+
+ type Mem_Check_Type is ("On", "Off");
+ Mem_Check : Profile_Type := External ("Standard_Common_Mem_Check", "Off");
+
+ package Compiler is
+ -- Switches for gcc
+
+ Base_Style_Checks := "-gnaty3abcefhiklnOprtx";
+ Line_Length := "-gnatyM120";
+
+ Style_Checks := (Base_Style_Checks, Line_Length);
+
+ Common_Switches :=
+ (
+ "-fstack-check",
+ "-g",
+ "-gnat2012",
+ "-gnatfoqQ",
+ "-gnatw.d",
+ "-gnatwaBCeJL",
+ "-gnatyO"
+ );
+
+ -- -gnatVa causes some inline procedures to be non-inlineable;
+ -- suppress that warning with -gnatwP.
+ Debug_Switches := Common_Switches &
+ (
+ "-O0",
+ "-gnata", -- assertions, pre/post-conditions
+ "-gnatVa", -- validity checks
+ "-gnateE", -- extra info in exceptions
+ "-gnatwaP"
+ );
+
+ -- -O3 is measurably faster than -O2 for wisitoken generate
+ -- LR1. We include -fstack-check because it catches
+ -- hard-to-find bugs, and the processors are so fast.
+ -- -fno-var-tracking-assignments speeds compiling of large
+ -- files; var tracking is only useful for debugging.
+ Base_Release_Switches := Common_Switches &
+ (
+ "-O3",
+ "-fno-var-tracking-assignments",
+ "-gnatyO"
+ );
+
+ Inlining := ("-gnatn");
+
+ Release_Switches := Base_Release_Switches & Inlining;
+
+ -- No -ansi; GNAT 7.1 compiler C header files are mingw 64, which don't
support -ansi
+ Debug_Switches_C := ("-Wall", "-Wstrict-prototypes", "-pedantic",
"-Werror", "-g", "-O0", "-funwind-tables");
+ Debug_Switches_C_Non_Pedantic := ("-Wall", "-Wstrict-prototypes",
"-Werror", "-g", "-O0", "-funwind-tables");
+ Release_Switches_C := ("-Wall", "-Wstrict-prototypes", "-pedantic",
"-Werror", "-g", "-O2", "-funwind-tables");
+ Release_Switches_C_Non_Pedantic := ("-Wall", "-Wstrict-prototypes",
"-Werror", "-g", "-O2", "-funwind-tables");
+
+ end Compiler;
+
+ -- In project files, normally use this:
+ -- package Compiler is
+ -- for Default_Switches ("Ada") use
+ -- Standard_Common.Compiler.Release_Switches &
+ -- Standard_Common.Compiler.Style_Checks;
+ -- end Compiler;
+
+ package Builder is
+ -- Switches for gnatmake
+ for Default_Switches ("Ada") use ("-C");
+ end Builder;
+
+ -- In project files, normally use this:
+ -- package Builder is
+ -- for Default_Switches ("Ada") use
Standard_Common.Builder'Default_Switches ("Ada");
+ -- end Builder;
+
+ package Binder is
+ -- Switches for gnatbind
+ for Default_Switches ("Ada") use ("-E");
+
+ Debug_Configuration_Pragmas := "Normalize_Scalars";
+ end Binder;
+
+ -- In project files, normally use this:
+ -- package Binder is
+ -- for Default_Switches ("Ada") use
Standard_Common.Binder'Default_Switches ("Ada");
+ -- end Binder;
+
+ package Linker is
+ case Profile is
+ when "On" =>
+ case Mem_Check is
+ when "On" =>
+ for Linker_Options use ("-pg", "-lgmem");
+ when "Off" =>
+ for Linker_Options use ("-pg");
+ end case;
+
+ when "Off" =>
+ case Mem_Check is
+ when "On" =>
+ for Linker_Options use ("-lgmem");
+ when "Off" =>
+ null;
+ end case;
+ end case;
+ end Linker;
+
+ -- In project files, no linker package is needed.
+end Standard_Common;
diff --git a/wisi-compat-24.2.el b/wisi-compat-24.2.el
deleted file mode 100644
index 03bae80..0000000
--- a/wisi-compat-24.2.el
+++ /dev/null
@@ -1,34 +0,0 @@
-;;; wisi-compat-24.2.el --- Implement current Emacs features not present in
Emacs 24.2 -*- lexical-binding:t -*-
-
-;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;; using cl-lib 0.4 from Gnu ELPA
-
-(when (not (boundp 'defvar-local))
- (defmacro defvar-local (var val &optional docstring)
- "Define VAR as a buffer-local variable with default value VAL.
-Like `defvar' but additionally marks the variable as being automatically
-buffer-local wherever it is set."
- (declare (debug defvar) (doc-string 3))
- ;; Can't use backquote here, it's too early in the bootstrap.
- (list 'progn (list 'defvar var val docstring)
- (list 'make-variable-buffer-local (list 'quote var))))
- )
-
-(provide 'wisi-compat-24.2)
-;;; wisi-compat-24.2.el ends here
diff --git a/wisi-compile.el b/wisi-compile.el
index 420621a..9788938 100644
--- a/wisi-compile.el
+++ b/wisi-compile.el
@@ -1,6 +1,6 @@
;; wisi-compile.el --- Grammar compiler for the wisi parser, integrating Wisi
OpenToken output. -*- lexical-binding:t -*-
;;
-;; Copyright (C) 2012-2013, 2015-2017 Free Software Foundation, Inc.
+;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
;;
;; Author: Stephen Leake <stephen_leake@member.fsf.org>
;;
@@ -117,7 +117,7 @@ NONTERM is the nonterminal left hand side.
IACTN is the index of the production in the NTERM rule.
The semantic action function accepts two arguments;
-- $nterm : the nonterminal
+- wisi-nterm : the nonterminal
- wisi-tokens : the list of tokens to be reduced.
It returns nil; it is called for the semantic side-effects only."
@@ -126,16 +126,14 @@ It returns nil; it is called for the semantic
side-effects only."
(action-symbol (intern name symbol-obarray)))
(fset action-symbol
- `(lambda ($nterm wisi-tokens)
+ `(lambda (wisi-nterm wisi-tokens)
,form
nil))
(byte-compile action-symbol)))
(defun wisi-compile-grammar (grammar)
"Compile the LALR(1) GRAMMAR; return the automaton for wisi-parse.
-GRAMMAR is a list TERMINALS NONTERMS ACTIONS GOTOS, where:
-
-TERMINALS is a list of terminal token symbols.
+GRAMMAR is a list NONTERMS ACTIONS GOTOS, where:
NONTERMS is a list of productions; each production is a
list (nonterm (tokens semantic-action) ...) where `semantic-action' is
@@ -151,10 +149,10 @@ terminal tokens. The value of each item in the alists is
one of:
integer - shift; gives new state
-(nonterm . index) - reduce by nonterm production index.
+ (nonterm . index) - reduce by nonterm production index.
-(integer (nonterm . index)) - a shift/reduce conflict
-((nonterm . index) (nonterm . index)) - a reduce/reduce conflict
+ (integer (nonterm . index)) - a shift/reduce conflict
+ ((nonterm . index) (nonterm . index)) - a reduce/reduce conflict
The first item in the alist must have the key `default' (not a
terminal token); it is used when no other item matches the
@@ -185,14 +183,8 @@ implement the semantic action for each nonterminal; the
function
names have the format nonterm:index."
;; We store named symbols for semantic actions, not just lambda
;; functions, so we have a name for debug trace.
- ;;
- ;; FIXME: TERMINALS is not used. Eliminating it requires decoupling
- ;; from OpenToken; we'll do that in the move to FastToken.
- ;;
- ;; FIXME: eliminate use of semantic-lex-* in *-wy.el. Similarly
- ;; requires decoupling from OpenToken
-
- (let ((defs (nth 1 grammar))
+
+ (let ((defs (nth 0 grammar))
(symbol-obarray (make-vector 13 0));; for parse actions
(byte-compile-warnings '(not free-vars)) ;; for "wisi-test-success" in
test/wisi/*
def nonterm rhs-list rule
@@ -216,16 +208,16 @@ names have the format nonterm:index."
))
;; replace semantic actions in ACTIONS with symbols from symbol-obarray
- (let ((nactions (length (nth 2 grammar)))
- (actions (nth 2 grammar))
+ (let ((nactions (length (nth 1 grammar)))
+ (actions (nth 1 grammar))
(i 0))
(while (< i nactions)
(aset actions i
- (wisi-replace-actions (aref actions i) symbol-obarray (nth 1
grammar)))
+ (wisi-replace-actions (aref actions i) symbol-obarray (nth 0
grammar)))
(setq i (1+ i)))
(vector
actions
- (nth 3 grammar)
+ (nth 2 grammar)
symbol-obarray)
)))
diff --git a/wisi-elisp-lexer.el b/wisi-elisp-lexer.el
new file mode 100644
index 0000000..b0d1e3c
--- /dev/null
+++ b/wisi-elisp-lexer.el
@@ -0,0 +1,393 @@
+;;; wisi-elisp-lexer.el --- A lexer for wisi, implemented in elisp -*-
lexical-binding:t -*-
+;;
+;; Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;
+
+;;; Commentary:
+
+;;;; History: see NEWS-wisi.text
+
+(require 'cl-lib)
+(require 'semantic/lex)
+(require 'wisi-parse-common)
+
+(cl-defstruct wisi-elisp-lexer
+ id-alist ;; alist mapping strings to token ids; used by repair error
+ keyword-table ;; obarray holding keyword tokens
+ punctuation-table ;; obarray holding punctuation tokens
+ punctuation-table-max-length ;; max string length in punctuation-table
+ string-double-term ;; non-nil if strings delimited by double quotes
+ string-quote-escape-doubled ;; Non-nil if a string delimiter is escaped by
doubling it
+ string-quote-escape
+ ;; Cons (delim . character) where `character' escapes quotes in strings
delimited by `delim'.
+ string-single-term ;; non-nil if strings delimited by single quotes
+ symbol-term ;; symbol for a terminal symbol token
+ number-term ;; symbol for a terminal number literal token
+ number-p ;; function that determines if argument is a number literal
+ line-begin ;; vector of beginning-of-line positions in buffer
+ last-line ;; index into line-begin of line containing last lexed token
+ )
+
+(defun wisi-elisp-lexer-reset (line-count lexer)
+ "Reset lexer to start a new parse. LINE-COUNT is the count of lines in the
current buffer."
+ (setf (wisi-elisp-lexer-line-begin lexer) (wisi--set-line-begin line-count))
+ (setf (wisi-elisp-lexer-last-line lexer) nil))
+
+(defvar-local wisi--lexer nil
+ "A `wisi-elisp-lexer' struct defining the lexer for the current buffer.")
+
+(defun wisi-elisp-lexer--safe-intern (name obtable)
+ (let ((var (intern-soft name obtable)))
+ (and (boundp var) (symbol-value var))))
+
+(cl-defun wisi-make-elisp-lexer (&key token-table-raw keyword-table-raw
string-quote-escape-doubled string-quote-escape)
+ "Return a ‘wisi-elisp-lexer’ object."
+ (let* ((token-table (semantic-lex-make-type-table token-table-raw))
+ (keyword-table (semantic-lex-make-keyword-table keyword-table-raw))
+ (left-paren (cadr (wisi-elisp-lexer--safe-intern "left-paren"
token-table)))
+ (right-paren (cadr (wisi-elisp-lexer--safe-intern "right-paren"
token-table)))
+ (punctuation-table (wisi-elisp-lexer--safe-intern "punctuation"
token-table))
+ (punct-max-length 0)
+ (number (cadr (wisi-elisp-lexer--safe-intern "number" token-table)))
+ (symbol (cadr (wisi-elisp-lexer--safe-intern "symbol" token-table)))
+ (string-double (cadr (wisi-elisp-lexer--safe-intern "string-double"
token-table)))
+ (string-single (cadr (wisi-elisp-lexer--safe-intern "string-single"
token-table)))
+ id-alist
+ fail)
+ (dolist (item punctuation-table)
+ ;; check that all chars used in punctuation tokens have punctuation
syntax
+ (mapc (lambda (char)
+ (when (not (= ?. (char-syntax char)))
+ (setq fail t)
+ (message "in %s, %c does not have punctuation syntax"
+ (car item) char)))
+ (cdr item))
+
+ ;; accumulate max length
+ (when (< punct-max-length (length (cdr item)))
+ (setq punct-max-length (length (cdr item))))
+
+ ;; build id-alist
+ (push item id-alist)
+ )
+
+ (when fail
+ (error "aborting due to punctuation errors"))
+
+ (when number
+ (push (cons (nth 0 number) "1234") id-alist)
+ (when (nth 2 number)
+ (require (nth 2 number)))) ;; for number-p
+
+ (when left-paren
+ (push left-paren id-alist)
+ (set (intern (cdr left-paren) keyword-table) (car left-paren)))
+ (when right-paren
+ (push right-paren id-alist)
+ (set (intern (cdr right-paren) keyword-table) (car right-paren)))
+
+ (when symbol
+ (push (cons (car symbol) "a_bogus_identifier") id-alist))
+
+ (when string-double
+ (push (cons (car string-double) "\"\"") id-alist))
+
+ (when string-single
+ (push (cons (car string-single) "''") id-alist))
+
+ (dolist (item keyword-table-raw)
+ (push (cons (cdr item) (car item)) id-alist))
+
+ (make-wisi-elisp-lexer
+ :id-alist id-alist
+ :keyword-table keyword-table
+ :punctuation-table punctuation-table
+ :punctuation-table-max-length punct-max-length
+ :string-double-term (car string-double)
+ :string-quote-escape-doubled string-quote-escape-doubled
+ :string-quote-escape string-quote-escape
+ :string-single-term (car string-single)
+ :symbol-term (car symbol)
+ :number-term (nth 0 number)
+ :number-p (nth 1 number)
+ )
+ ))
+
+(defun wisi-number-p (token-text)
+ ;; Not ’wisi-elisp-lexer-number-p’, because this can appear in grammar files.
+ "Return t if TOKEN-TEXT plus text after point matches the
+syntax for a real literal; otherwise nil. Point is after
+TOKEN-TEXT; move point to just past token."
+ ;; Typical literals:
+ ;; 1234
+ ;; 1234.5678
+ ;; _not_ including non-decimal base, or underscores (see ada-wisi-number-p)
+ ;;
+ ;; Starts with a simple integer
+ (when (string-match "^[0-9]+$" token-text)
+ (when (looking-at "\\.[0-9]+")
+ ;; real number
+ (goto-char (match-end 0))
+ (when (looking-at "[Ee][+-][0-9]+")
+ ;; exponent
+ (goto-char (match-end 0))))
+
+ t
+ ))
+
+(defun wisi-forward-token ()
+ ;; Not ’wisi-elisp-lexer-forward-token’, for backward compatibility
+ "Move point forward across one token, then skip whitespace and comments.
+Return the corresponding token as a `wisi-tok'.
+If at whitespace or comment, throw an error.
+If at end of buffer, return `wisi-eoi-term'."
+ (let ((start (point))
+ ;; (info "(elisp)Syntax Table Internals" "*info elisp syntax*")
+ end
+ (syntax (syntax-class (syntax-after (point))))
+ (first nil)
+ (comment-line nil)
+ (comment-end nil)
+ token-id token-text line)
+ (cond
+ ((eobp)
+ (setq token-id wisi-eoi-term))
+
+ ((eq syntax 1)
+ ;; punctuation. Find the longest matching string in
wisi-punctuation-table
+ (forward-char 1)
+ (let ((next-point (point))
+ temp-text temp-id done)
+ (while (not done)
+ (setq temp-text (buffer-substring-no-properties start (point)))
+ (setq temp-id (car (rassoc temp-text
(wisi-elisp-lexer-punctuation-table wisi--lexer))))
+ (when temp-id
+ (setq token-id temp-id
+ next-point (point)))
+ (if (or
+ (eobp)
+ (= (- (point) start)
(wisi-elisp-lexer-punctuation-table-max-length wisi--lexer)))
+ (setq done t)
+ (forward-char 1))
+ )
+ (goto-char next-point)))
+
+ ((memq syntax '(4 5)) ;; open, close parenthesis
+ (forward-char 1)
+ (setq token-text (buffer-substring-no-properties start (point)))
+ (setq token-id (symbol-value (intern-soft token-text
(wisi-elisp-lexer-keyword-table wisi--lexer)))))
+
+ ((eq syntax 7)
+ ;; string quote, either single or double. we assume point is
+ ;; before the start quote, not the end quote
+ (let ((delim (char-after (point)))
+ (forward-sexp-function nil))
+ (condition-case err
+ (progn
+ (forward-sexp)
+
+ ;; point is now after the end quote; check for an escaped quote
+ (while (or
+ (and (wisi-elisp-lexer-string-quote-escape-doubled
wisi--lexer)
+ (eq (char-after (point)) delim))
+ (and (eq delim (car (wisi-elisp-lexer-string-quote-escape
wisi--lexer)))
+ (eq (char-before (1- (point))) (cdr
(wisi-elisp-lexer-string-quote-escape wisi--lexer)))))
+ (forward-sexp))
+ (setq token-id (if (= delim ?\")
+ (wisi-elisp-lexer-string-double-term
wisi--lexer)
+ (wisi-elisp-lexer-string-single-term
wisi--lexer))))
+ (scan-error
+ ;; Something screwed up; we should not get here if
+ ;; syntax-propertize works properly.
+ (signal 'wisi-parse-error (format "wisi-forward-token: forward-sexp
failed %s" err))
+ ))))
+
+ ((memq syntax '(2 3 6)) ;; word, symbol, expression prefix (includes
numbers)
+ (skip-syntax-forward "w_'")
+ (setq token-text (buffer-substring-no-properties start (point)))
+ (setq token-id
+ (or (symbol-value (intern-soft (downcase token-text)
(wisi-elisp-lexer-keyword-table wisi--lexer)))
+ (and (functionp (wisi-elisp-lexer-number-p wisi--lexer))
+ (funcall (wisi-elisp-lexer-number-p wisi--lexer)
token-text)
+ (setq token-text (buffer-substring-no-properties start
(point)))
+ (wisi-elisp-lexer-number-term wisi--lexer))
+ (wisi-elisp-lexer-symbol-term wisi--lexer)))
+ )
+
+ (t
+ (signal 'wisi-parse-error (format "wisi-forward-token: unsupported
syntax %s" syntax)))
+
+ );; cond
+
+ (unless token-id
+ (signal 'wisi-parse-error
+ (wisi-error-msg "unrecognized token '%s'"
(buffer-substring-no-properties start (point)))))
+
+ (setq end (point))
+
+ (forward-comment (point-max))
+
+ (when (and (not (eq token-id wisi-eoi-term))
+ (eq wisi--parse-action 'indent))
+ ;; parsing for indent; track line numbers
+
+ (if (wisi-elisp-lexer-last-line wisi--lexer)
+ (progn
+ (setq line (wisi-elisp-lexer-last-line wisi--lexer))
+ (when (>= start (aref (wisi-elisp-lexer-line-begin wisi--lexer)
line))
+ ;; first token on next non-blank line
+ (setq line (1+ line))
+ (setq first t))
+ ;; else other token on line
+ )
+
+ ;; First token on first non-comment line
+ (setq line (line-number-at-pos start))
+ (setq first t)
+ )
+ (setf (wisi-elisp-lexer-last-line wisi--lexer) line)
+
+ ;; set comment-line, comment-end
+ (when (and (< (1+ (wisi-elisp-lexer-last-line wisi--lexer)) (length
(wisi-elisp-lexer-line-begin wisi--lexer)))
+ (>= (point) (aref (wisi-elisp-lexer-line-begin wisi--lexer)
+ (1+ (wisi-elisp-lexer-last-line
wisi--lexer)))))
+ (setq comment-line (1+ (wisi-elisp-lexer-last-line wisi--lexer)))
+ (setf (wisi-elisp-lexer-last-line wisi--lexer) comment-line)
+ (setq comment-end (line-end-position 0)))
+
+ ;; count blank or comment lines following token
+ (when comment-end
+ (while (and (< (1+ (wisi-elisp-lexer-last-line wisi--lexer)) (length
(wisi-elisp-lexer-line-begin wisi--lexer)))
+ (>= comment-end (aref (wisi-elisp-lexer-line-begin
wisi--lexer) (wisi-elisp-lexer-last-line wisi--lexer))))
+ (setf (wisi-elisp-lexer-last-line wisi--lexer) (1+
(wisi-elisp-lexer-last-line wisi--lexer))))
+
+ ))
+
+ (make-wisi-tok
+ :token token-id
+ :region (cons start end)
+ :line line
+ :first first
+ :comment-end comment-end
+ :comment-line comment-line)
+ ))
+
+(defun wisi-backward-token ()
+ ;; Not ’wisi-elisp-lexer-backward-token’, for backward compatibility
+ "Move point backward across one token, skipping whitespace and comments.
+Does _not_ handle numbers with wisi-number-p; just sees
+lower-level syntax. Return a `wisi-tok' - same structure as
+wisi-forward-token, but only sets token-id and region."
+ (forward-comment (- (point)))
+ ;; skips leading whitespace, comment, trailing whitespace.
+
+ ;; (info "(elisp)Syntax Table Internals" "*info elisp syntax*")
+ (let ((end (point))
+ (syntax (syntax-class (syntax-after (1- (point)))))
+ token-id token-text)
+ (cond
+ ((bobp) nil)
+
+ ((eq syntax 1)
+ ;; punctuation. Find the longest matching string in
wisi-lex-punctuation-table
+ (backward-char 1)
+ (let ((next-point (point))
+ temp-text temp-id done)
+ (while (not done)
+ (setq temp-text (buffer-substring-no-properties (point) end))
+ (when (setq temp-id (car (rassoc temp-text
(wisi-elisp-lexer-punctuation-table wisi--lexer))))
+ (setq token-id temp-id)
+ (setq next-point (point)))
+ (if (or
+ (bobp)
+ (= (- end (point))
(wisi-elisp-lexer-punctuation-table-max-length wisi--lexer)))
+ (setq done t)
+ (backward-char 1))
+ )
+ (goto-char next-point))
+ )
+
+ ((memq syntax '(4 5)) ;; open, close parenthesis
+ (backward-char 1)
+ (setq token-id
+ (symbol-value
+ (intern-soft (buffer-substring-no-properties (point) end)
+ (wisi-elisp-lexer-keyword-table wisi--lexer)))))
+
+ ((eq syntax 7)
+ ;; a string quote. we assume we are after the end quote, not the start
quote
+ (let ((delim (char-after (1- (point))))
+ (forward-sexp-function nil))
+ (forward-sexp -1)
+ (setq token-id (if (= delim ?\")
+ (wisi-elisp-lexer-string-double-term wisi--lexer)
+ (wisi-elisp-lexer-string-single-term wisi--lexer)))
+ ))
+
+ (t ;; assuming word or symbol syntax
+ (if (zerop (skip-syntax-backward "."))
+ (skip-syntax-backward "w_'"))
+ (setq token-text (buffer-substring-no-properties (point) end))
+ (setq token-id
+ (or (symbol-value (intern-soft (downcase token-text)
(wisi-elisp-lexer-keyword-table wisi--lexer)))
+ (and (functionp (wisi-elisp-lexer-number-p wisi--lexer))
+ (funcall (wisi-elisp-lexer-number-p wisi--lexer)
token-text)
+ (setq token-text (buffer-substring-no-properties (point)
end))
+ (wisi-elisp-lexer-number-term wisi--lexer))
+ (wisi-elisp-lexer-symbol-term wisi--lexer))))
+ )
+
+ (make-wisi-tok
+ :token token-id
+ :region (cons (point) end))
+ ))
+
+;;;; Debugging
+
+(defun wisi-lex-buffer (&optional parse-action)
+ ;; for timing the lexer
+ (interactive)
+ (when (< emacs-major-version 25) (syntax-propertize (point-max)))
+
+ (let* ((wisi--parse-action (or parse-action 'indent))
+ (line-count (1+ (count-lines (point-min) (point-max))))
+ )
+
+ (cl-case wisi--parse-action
+ (indent
+ (setf (wisi-elisp-lexer-last-line wisi--lexer) nil)
+ (setf (wisi-elisp-lexer-line-begin wisi--lexer) (wisi--set-line-begin
line-count)))
+ (t nil))
+
+ (goto-char (point-min))
+ (while (forward-comment 1))
+ (while (not (eq wisi-eoi-term (wisi-tok-token (wisi-forward-token)))))
+ ))
+
+(defun wisi-show-token ()
+ "Move forward across one keyword, show token."
+ (interactive)
+ (let* ((wisi--parse-action nil)
+ (token (wisi-forward-token)))
+ (message "%s" token)))
+
+
+(provide 'wisi-elisp-lexer)
+;;; end of file
diff --git a/wisi-elisp-parse.el b/wisi-elisp-parse.el
new file mode 100644
index 0000000..83ddba2
--- /dev/null
+++ b/wisi-elisp-parse.el
@@ -0,0 +1,1682 @@
+;; wisi-elisp-parse.el --- Wisi parser -*- lexical-binding:t -*-
+
+;; Copyright (C) 2013-2015, 2017 - 2018 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+
+;; An extended LALR parser, that handles shift/reduce and
+;; reduce/reduce conflicts by spawning parallel parsers to follow each
+;; path.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'wisi-elisp-lexer)
+(require 'wisi-parse-common)
+
+(defvar wisi-elisp-parse-max-parallel-current (cons 0 0)
+ "Cons (count . point); Maximum number of parallel parsers used in most
recent parse,
+point at which that max was spawned.")
+
+(defvar wisi-debug-identical 0
+ "Debug terminating identical parsers.
+0 - keep lower-numbered parser.
+1 - keep higher-numbered parser.
+2 - error.")
+
+(cl-defstruct (wisi-elisp-parser-state
+ (:copier nil))
+ label ;; integer identifying parser for debug
+
+ active
+ ;; 'shift - need new token
+ ;; 'reduce - need reduce
+ ;; 'accept - parsing completed
+ ;; 'error - failed, error not reported yet
+ ;; nil - terminated
+ ;;
+ ;; 'pending-shift, 'pending-reduce - newly created parser
+
+ stack
+ ;; Each stack item takes two slots: wisi-tok, state
+
+ sp ;; stack pointer
+
+ pending
+ ;; list of (action-symbol stack-fragment)
+ )
+
+(cl-defstruct (wisi-elisp-parser (:include wisi-parser))
+ actions
+ gotos
+ next-token
+ )
+
+;;;###autoload
+(defun wisi-make-elisp-parser (automaton next-token)
+ "Return ‘wisi-parser’ object.
+
+- AUTOMATON is the parse table generated by `wisi-compile-grammar'.
+
+- NEXT-TOKEN is a function with no argument called by the parser to
+ obtain the next token from the current buffer after point, as a
+ ’wisi-tok’ object (normally ‘wisi-forward-token’)."
+ (make-wisi-elisp-parser
+ :actions (aref automaton 0)
+ :gotos (aref automaton 1)
+ :next-token next-token))
+
+(cl-defmethod wisi-parse-kill ((_parser wisi-elisp-parser))
+ nil)
+
+(defvar wisi-elisp-parse--indent
+ ;; not buffer-local; only let-bound in wisi-parse-current (elisp)
+ "A vector of indentation for all lines in buffer.
+Each element can be one of:
+- integer : indent
+
+- list ('anchor (start-id ...) indent) :
+ indent for current line, base indent for following 'anchored
+ lines. Start-id is list of ids anchored at this line. For parens
+ and other uses.
+
+- list ('anchored id delta) :
+ indent = delta + 'anchor id line indent; for lines indented
+ relative to anchor.
+
+- list ('anchor (start-id ...) ('anchored id delta))
+ for nested anchors.")
+
+(cl-defmethod wisi-parse-current ((parser wisi-elisp-parser))
+ "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-case wisi--parse-action
+ (indent
+ (let ((line-count (1+ (count-lines (point-min) (point-max)))))
+ (setq wisi-elisp-parse--indent (make-vector line-count 0))
+ (wisi-elisp-lexer-reset line-count wisi--lexer)))
+
+ (navigate
+ (setq wisi-end-caches nil))
+
+ (t nil))
+
+ (setf (wisi-parser-lexer-errors parser) nil)
+ (setf (wisi-parser-parse-errors parser) nil)
+
+ ;; We assume the lexer relies on syntax properties
+ (when (< emacs-major-version 25) (syntax-propertize (point-max)))
+
+ (goto-char (point-min))
+ (forward-comment (point-max))
+ (aset (wisi-elisp-parser-state-stack (aref parser-states 0)) 0 0)
+
+ (setq token (funcall (wisi-elisp-parser-next-token parser)))
+ (setq wisi-elisp-parse-max-parallel-current (cons 0 0))
+
+ (while (not (eq active 'accept))
+ (setq active-parser-count-prev active-parser-count)
+ (setq some-pending nil)
+ (dotimes (parser-index (length parser-states))
+ (when (eq active (wisi-elisp-parser-state-active (aref parser-states
parser-index)))
+ (let* ((parser-state (aref parser-states parser-index))
+ (result (wisi-elisp-parse-1 token parser-state (>
active-parser-count 1) actions gotos)))
+ (when result
+ ;; spawn a new parser
+ (when (= active-parser-count wisi-parse-max-parallel)
+ (let* ((state (aref (wisi-elisp-parser-state-stack parser-state)
+ (wisi-elisp-parser-state-sp parser-state)))
+ (msg (wisi-error-msg (concat "too many parallel parsers
required in grammar state %d;"
+ " simplify grammar, or
increase `wisi-elisp-parse-max-parallel'")
+ state)))
+ (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error msg)))
+
+ (let ((j (wisi-elisp-parse-free-parser parser-states)))
+ (cond
+ ((= j -1)
+ ;; Add to parser-states; the new parser won't be executed
+ ;; again in this parser-index loop.
+ (setq parser-states (vconcat parser-states (vector nil)))
+ (setq j (1- (length parser-states))))
+ ((< j parser-index)
+ ;; The new parser won't be executed again in this
+ ;; parser-index loop; nothing to do.
+ )
+ (t
+ ;; Don't let the new parser execute again in this
+ ;; parser-index loop.
+ (setq some-pending t)
+ (setf (wisi-elisp-parser-state-active result)
+ (cl-case (wisi-elisp-parser-state-active result)
+ (shift 'pending-shift)
+ (reduce 'pending-reduce)
+ )))
+ )
+ (setq active-parser-count (1+ active-parser-count))
+ (when (> active-parser-count (car
wisi-elisp-parse-max-parallel-current))
+ (setq wisi-elisp-parse-max-parallel-current (cons
active-parser-count (point))))
+ (setf (wisi-elisp-parser-state-label result) j)
+ (aset parser-states j result))
+ (when (> wisi-debug 1)
+ (message "spawn parser (%d active)" active-parser-count)))
+
+ (when (eq 'error (wisi-elisp-parser-state-active parser-state))
+ (setq active-parser-count (1- active-parser-count))
+ (when (> wisi-debug 1)
+ (message "terminate parser (%d active)" active-parser-count))
+ (cl-case active-parser-count
+ (0
+ (cond
+ ((= active-parser-count-prev 1)
+ ;; We were not in a parallel parse; abandon parsing, report
the error.
+ (let* ((state (aref (wisi-elisp-parser-state-stack
parser-state)
+ (wisi-elisp-parser-state-sp
parser-state)))
+ (msg (wisi-error-msg "syntax error in grammar state
%d; unexpected %s, expecting one of %s"
+ state
+ (wisi-token-text token)
+ (mapcar 'car (aref actions
state)))))
+ (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error msg)))
+ (t
+ ;; Report errors from all parsers that failed on this token.
+ (let ((msg))
+ (dotimes (_ (length parser-states))
+ (let* ((parser-state (aref parser-states parser-index))
+ (state (aref (wisi-elisp-parser-state-stack
parser-state)
+ (wisi-elisp-parser-state-sp
parser-state))))
+ (when (eq 'error (wisi-elisp-parser-state-active
parser-state))
+ (setq msg
+ (concat msg
+ (when msg "\n")
+ (wisi-error-msg
+ "syntax error in grammar state %d;
unexpected %s, expecting one of %s"
+ state
+ (wisi-token-text token)
+ (mapcar 'car (aref actions state)))))
+ )))
+ (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error msg)))
+ ))
+
+ (1
+ (setf (wisi-elisp-parser-state-active parser-state) nil);
Don't save error for later.
+ (wisi-elisp-parse-execute-pending (aref parser-states
(wisi-elisp-parse-active-parser parser-states))))
+
+ (t
+ ;; We were in a parallel parse, and this parser
+ ;; failed; mark it inactive, don't save error for
+ ;; later.
+ (setf (wisi-elisp-parser-state-active parser-state) nil)
+ )))
+ )));; end dotimes
+
+ (when some-pending
+ ;; Change pending-* parsers to *.
+ (dotimes (parser-index (length parser-states))
+ (cond
+ ((eq (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'pending-shift)
+ (setf (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'shift))
+ ((eq (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'pending-reduce)
+ (setf (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'reduce))
+ )))
+
+ (setq active (wisi-elisp-parsers-active parser-states
active-parser-count))
+ (when (eq active 'shift)
+ (when (> active-parser-count 1)
+ (setq active-parser-count (wisi-elisp-parse-elim-identical parser
parser-states active-parser-count)))
+
+ (setq token (funcall (wisi-elisp-parser-next-token parser))))
+ )
+ (when (> active-parser-count 1)
+ (error "ambiguous parse result"))
+
+ (cl-case wisi--parse-action
+ (indent
+ (wisi-elisp-parse--indent-leading-comments)
+ (wisi-elisp-parse--resolve-anchors))
+
+ (t nil))
+ ))
+
+(defun wisi-elisp-parsers-active-index (parser-states)
+ ;; only called when active-parser-count = 1
+ (let ((result nil)
+ (i 0))
+ (while (and (not result)
+ (< i (length parser-states)))
+ (when (wisi-elisp-parser-state-active (aref parser-states i))
+ (setq result i))
+ (setq i (1+ i)))
+ result))
+
+(defun wisi-elisp-parsers-active (parser-states active-count)
+ "Return the type of parser cycle to execute.
+PARSER-STATES[*].active is the last action a parser took. If it
+was `shift', that parser used the input token, and should not be
+executed again until another input token is available, after all
+parsers have shifted the current token or terminated.
+
+Returns one of:
+
+`accept' : all PARSER-STATES have active set to nil or `accept' -
+done parsing
+
+`shift' : all PARSER-STATES have active set to nil, `accept', or
+`shift' - get a new token, execute `shift' parsers.
+
+`reduce' : some PARSER-STATES have active set to `reduce' - no new
+token, execute `reduce' parsers."
+ (let ((result nil)
+ (i 0)
+ (shift-count 0)
+ (accept-count 0)
+ active)
+ (while (and (not result)
+ (< i (length parser-states)))
+ (setq active (wisi-elisp-parser-state-active (aref parser-states i)))
+ (cond
+ ((eq active 'shift) (setq shift-count (1+ shift-count)))
+ ((eq active 'reduce) (setq result 'reduce))
+ ((eq active 'accept) (setq accept-count (1+ accept-count)))
+ )
+ (setq i (1+ i)))
+
+ (cond
+ (result )
+ ((= accept-count active-count)
+ 'accept)
+ ((= (+ shift-count accept-count) active-count)
+ 'shift)
+ (t
+ ;; all parsers in error state; should not get here
+ (error "all parsers in error state; programmer error"))
+ )))
+
+(defun wisi-elisp-parse-free-parser (parser-states)
+ "Return index to a non-active parser in PARSER-STATES, -1 if there is none."
+ (let ((result nil)
+ (i 0))
+ (while (and (not result)
+ (< i (length parser-states)))
+ (when (not (wisi-elisp-parser-state-active (aref parser-states i)))
+ (setq result i))
+ (setq i (1+ i)))
+ (if result result -1)))
+
+(defun wisi-elisp-parse-active-parser (parser-states)
+ "Return index to the first active parser in PARSER-STATES."
+ (let ((result nil)
+ (i 0))
+ (while (and (not result)
+ (< i (length parser-states)))
+ (when (wisi-elisp-parser-state-active (aref parser-states i))
+ (setq result i))
+ (setq i (1+ i)))
+ (unless result
+ (error "no active parsers"))
+ result))
+
+(defun wisi-elisp-parse-elim-identical (parser parser-states
active-parser-count)
+ "Check for parsers in PARSER-STATES that have reached identical states
eliminate one.
+Return new ACTIVE-PARSER-COUNT. Assumes all parsers have active
+nil, `shift', or `accept'."
+ ;; parser-states passed by reference; active-parser-count by copy
+ ;; see test/ada_mode-slices.adb for example
+ (dotimes (parser-i (1- (length parser-states)))
+ (when (wisi-elisp-parser-state-active (aref parser-states parser-i))
+ (dotimes (parser-j (- (length parser-states) parser-i 1))
+ (when (wisi-elisp-parser-state-active (aref parser-states (+ parser-i
parser-j 1)))
+ (when (eq (wisi-elisp-parser-state-sp (aref parser-states parser-i))
+ (wisi-elisp-parser-state-sp (aref parser-states (+
parser-i parser-j 1))))
+ (let ((compare t)
+ exec)
+ (dotimes (stack-i (wisi-elisp-parser-state-sp (aref parser-states
parser-i)))
+ (setq
+ compare
+ (and compare ;; bypass expensive 'arefs' after first stack
item compare fail
+ (equal (aref (wisi-elisp-parser-state-stack (aref
parser-states parser-i)) stack-i)
+ (aref (wisi-elisp-parser-state-stack (aref
parser-states (+ parser-i parser-j 1)))
+ stack-i)))))
+ (when compare
+ ;; parser stacks are identical
+ (setq active-parser-count (1- active-parser-count))
+ (when (> wisi-debug 1)
+ (message "terminate identical parser %d (%d active)"
+ (+ parser-i parser-j 1) active-parser-count)
+ (let ((state-i (aref parser-states parser-i))
+ (state-j (aref parser-states (+ parser-i parser-j 1))))
+ (message "%d actions:" (wisi-elisp-parser-state-label
state-i))
+ (mapc #'wisi-elisp-parse-debug-put-action
(wisi-elisp-parser-state-pending state-i))
+
+ (message "%d actions:" (wisi-elisp-parser-state-label
state-j))
+ (mapc #'wisi-elisp-parse-debug-put-action
(wisi-elisp-parser-state-pending state-j))
+ ))
+ (cl-ecase wisi-debug-identical
+ (0
+ (setq exec parser-i)
+ (setf (wisi-elisp-parser-state-active (aref parser-states (+
parser-i parser-j 1))) nil))
+
+ (1
+ (setq exec (+ parser-i parser-j 1))
+ (setf (wisi-elisp-parser-state-active (aref parser-states
parser-i)) nil))
+
+ (2
+ (let ((msg "identical parser stacks"))
+ (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error msg)))
+ )
+ (when (= active-parser-count 1)
+ ;; The actions for the two parsers are not
+ ;; identical, but most of the time either is good
+ ;; enough for indentation and navigation, so we just
+ ;; do the actions for the one that is not
+ ;; terminating. Some times, a significant action is
+ ;; lost. In that case, turn on
+ ;; ‘wisi-debug-identical’ to investigate fixing it.
+ (wisi-elisp-parse-execute-pending (aref parser-states exec)))
+ ))))
+ )))
+ active-parser-count)
+
+(defun wisi-elisp-parse-exec-action (func nonterm tokens)
+ "Execute action if TOKENS not null."
+ ;; `tokens' is null when all tokens in a grammar statement are
+ ;; optional and not present.
+ (unless wisi-action-disable
+ (if (< 0 (length tokens))
+ (when wisi--parse-action
+ (funcall func nonterm tokens))
+
+ (when (> wisi-debug 1)
+ (message "... action skipped; no tokens"))
+ )))
+
+(defvar wisi-elisp-parser-state nil
+ "Let-bound in `wisi-elisp-parse-reduce', used in `wisi-parse-find-token'.")
+
+(defun wisi-elisp-parse-debug-put-action (action)
+ ;; Action is (semantic-function nonterm [tokens])
+ (message "%s [%s]"
+ (nth 0 action)
+ (mapcar #'wisi-tok-debug-image (nth 2 action))))
+
+(defun wisi-elisp-parse-execute-pending (parser-state)
+ (let ((wisi-elisp-parser-state parser-state);; reference, for
wisi-parse-find-token
+ (pending (wisi-elisp-parser-state-pending parser-state)))
+
+ (when (> wisi-debug 1)
+ (message "%d: pending actions:" (wisi-elisp-parser-state-label
parser-state)))
+
+ (while pending
+ (when (> wisi-debug 1) (wisi-elisp-parse-debug-put-action (car pending)))
+
+ (let ((func-args (pop pending)))
+ (wisi-elisp-parse-exec-action (nth 0 func-args) (nth 1 func-args)
(cl-caddr func-args)))
+ )
+ (setf (wisi-elisp-parser-state-pending parser-state) nil)
+ ))
+
+(defmacro wisi-elisp-parse-action (i al)
+ "Return the parser action.
+I is a token item number and AL is the list of (item . action)
+available at current state. The first element of AL contains the
+default action for this state."
+ `(cdr (or (assq ,i ,al) (car ,al))))
+
+(defun wisi-elisp-parse-1 (token parser-state pendingp actions gotos)
+ "Perform one shift or reduce on PARSER-STATE.
+If PENDINGP, push actions onto PARSER-STATE.pending; otherwise execute them.
+See `wisi-elisp-parse' for full details.
+Return nil or new parser (a wisi-elisp-parser-state struct)."
+ (let* ((state (aref (wisi-elisp-parser-state-stack parser-state)
+ (wisi-elisp-parser-state-sp parser-state)))
+ (parse-action (wisi-elisp-parse-action (wisi-tok-token token) (aref
actions state)))
+ new-parser-state)
+
+ (when (> wisi-debug 1)
+ ;; output trace info
+ (if (> wisi-debug 2)
+ (progn
+ ;; put top 10 stack items
+ (let* ((count (min 20 (wisi-elisp-parser-state-sp parser-state)))
+ (msg (make-vector (+ 1 count) nil)))
+ (dotimes (i count)
+ (aset msg (- count i)
+ (aref (wisi-elisp-parser-state-stack parser-state)
+ (- (wisi-elisp-parser-state-sp parser-state) i)))
+ )
+ (message "%d: %s: %d: %s"
+ (wisi-elisp-parser-state-label parser-state)
+ (wisi-elisp-parser-state-active parser-state)
+ (wisi-elisp-parser-state-sp parser-state)
+ msg))
+ (message " %d: %s: %s" state (wisi-tok-debug-image token)
parse-action))
+ (message "%d: %d: %s: %s" (wisi-elisp-parser-state-label parser-state)
state token parse-action)))
+
+ (when (and (listp parse-action)
+ (not (symbolp (car parse-action))))
+ ;; Conflict; spawn a new parser.
+ (setq new-parser-state
+ (make-wisi-elisp-parser-state
+ :active nil
+ :stack (vconcat (wisi-elisp-parser-state-stack parser-state))
+ :sp (wisi-elisp-parser-state-sp parser-state)
+ :pending (wisi-elisp-parser-state-pending parser-state)))
+
+ (wisi-elisp-parse-2 (cadr parse-action) token new-parser-state t gotos)
+ (setq pendingp t)
+ (setq parse-action (car parse-action))
+ );; when
+
+ ;; current parser
+ (wisi-elisp-parse-2 parse-action token parser-state pendingp gotos)
+
+ new-parser-state))
+
+(defun wisi-elisp-parse-2 (action token parser-state pendingp gotos)
+ "Execute parser ACTION (must not be a conflict).
+Return nil."
+ (cond
+ ((eq action 'accept)
+ (setf (wisi-elisp-parser-state-active parser-state) 'accept))
+
+ ((eq action 'error)
+ (setf (wisi-elisp-parser-state-active parser-state) 'error))
+
+ ((natnump action)
+ ;; Shift token and new state (= action) onto stack
+ (let ((stack (wisi-elisp-parser-state-stack parser-state)); reference
+ (sp (wisi-elisp-parser-state-sp parser-state))); copy
+ (setq sp (+ sp 2))
+ (aset stack (1- sp) token)
+ (aset stack sp action)
+ (setf (wisi-elisp-parser-state-sp parser-state) sp))
+ (setf (wisi-elisp-parser-state-active parser-state) 'shift))
+
+ (t
+ (wisi-elisp-parse-reduce action parser-state pendingp gotos)
+ (setf (wisi-elisp-parser-state-active parser-state) 'reduce))
+ ))
+
+(defun wisi-elisp-parse-first-last (stack i j)
+ "Return a pair (FIRST . LAST), indices for the first and last
+non-empty tokens for a nonterminal; or nil if all tokens are
+empty. STACK is the parser stack. I and J are the indices in
+STACK of the first and last tokens of the nonterminal."
+ (let ((start (car (wisi-tok-region (aref stack i))))
+ (end (cdr (wisi-tok-region (aref stack j)))))
+ (while (and (or (not start) (not end))
+ (/= i j))
+ (cond
+ ((not start)
+ ;; item i is an empty production
+ (setq start (car (wisi-tok-region (aref stack (setq i (+ i 2)))))))
+
+ ((not end)
+ ;; item j is an empty production
+ (setq end (cdr (wisi-tok-region (aref stack (setq j (- j 2)))))))
+
+ (t (setq i j))))
+
+ (when (and start end)
+ (cons i j))
+ ))
+
+(cl-defmethod wisi-parse-find-token ((_parser wisi-elisp-parser) token-symbol)
+ "Find token with TOKEN-SYMBOL on current parser stack, return token struct.
+For use in grammar actions."
+ ;; Called from wisi-parse-exec-action in wisi-parse-reduce
+ (let* ((stack (wisi-elisp-parser-state-stack wisi-elisp-parser-state))
+ (sp (1- (wisi-elisp-parser-state-sp wisi-elisp-parser-state)))
+ (tok (aref stack sp)))
+ (while (and (> sp 0)
+ (not (eq token-symbol (wisi-tok-token tok))))
+ (setq sp (- sp 2))
+ (setq tok (aref stack sp)))
+ (if (= sp 0)
+ (error "token %s not found on parse stack" token-symbol)
+ tok)
+ ))
+
+(cl-defmethod wisi-parse-stack-peek ((_parser wisi-elisp-parser) n)
+ ;; IMPROVEME: store stack in parser
+ (let* ((stack (wisi-elisp-parser-state-stack wisi-elisp-parser-state))
+ (sp (1- (wisi-elisp-parser-state-sp wisi-elisp-parser-state)))
+ (i (- sp (* 2 n))))
+ (when (> i 0)
+ (aref stack i))))
+
+(defun wisi-elisp-parse-reduce (action parser-state pendingp gotos)
+ "Reduce PARSER-STATE.stack, and execute or pend ACTION."
+ (let* ((wisi-elisp-parser-state parser-state);; reference, for
wisi-parse-find-token
+ (stack (wisi-elisp-parser-state-stack parser-state)); reference
+ (sp (wisi-elisp-parser-state-sp parser-state)); copy
+ (token-count (nth 2 action))
+ (nonterm (nth 0 action))
+ (first-last (when (> token-count 0)
+ (wisi-elisp-parse-first-last stack (- sp (* 2 (1-
token-count)) 1) (1- sp))))
+ (nonterm-region (when first-last
+ (cons
+ (car (wisi-tok-region (aref stack (car
first-last))))
+ (cdr (wisi-tok-region (aref stack (cdr
first-last)))))))
+ (post-reduce-state (aref stack (- sp (* 2 token-count))))
+ (new-state (cdr (assoc nonterm (aref gotos post-reduce-state))))
+ (tokens (make-vector token-count nil))
+ line first comment-line comment-end)
+
+ (when (not new-state)
+ (error "no goto for %s %d" nonterm post-reduce-state))
+
+ (dotimes (i token-count) ;; i = 0 .. (1- token-count); last token = 0,
first token = (1- token-count)
+ (let ((tok (aref stack (- sp (* 2 i) 1))))
+ (when (nth 1 action)
+ ;; don't need wisi-tokens for a null user action
+ (aset tokens (- token-count i 1) tok))
+
+ (when (eq wisi--parse-action 'indent)
+ (setq line (or (wisi-tok-line tok) line))
+ (cond
+ ((numberp (wisi-tok-first tok))
+ (setq first (wisi-tok-first tok)))
+
+ ((wisi-tok-first tok)
+ (setq first (wisi-tok-line tok)))
+
+ ((and (not (= i 0))
+ (wisi-tok-comment-line tok))
+ ;; comment lines following last token are not included in nonterm
+ ;; test/ada_mode-nominal.ads Object_Access_Type_5a
+ ;; test/ada_mode-parens.adb
+ (setq first (wisi-tok-comment-line tok)))
+ )
+ (when (and (= i 0)
+ (wisi-tok-comment-line tok))
+ (setq comment-line (wisi-tok-comment-line tok))
+ (setq comment-end (wisi-tok-comment-end tok)))
+ )))
+
+ (setq sp (+ 2 (- sp (* 2 token-count))))
+ (aset stack (1- sp)
+ (make-wisi-tok
+ :token nonterm
+ :region nonterm-region
+ :nonterminal t
+ :line line
+ :first first
+ :comment-line comment-line
+ :comment-end comment-end))
+ (aset stack sp new-state)
+ (setf (wisi-elisp-parser-state-sp parser-state) sp)
+
+ (when (nth 1 action)
+ ;; nothing to do for a null user action
+ (if pendingp
+ (if (wisi-elisp-parser-state-pending parser-state)
+ (setf (wisi-elisp-parser-state-pending parser-state)
+ (append (wisi-elisp-parser-state-pending parser-state)
+ (list (list (nth 1 action) nonterm tokens))))
+ (setf (wisi-elisp-parser-state-pending parser-state)
+ (list (list (nth 1 action) nonterm tokens))))
+
+ ;; Not pending.
+ (wisi-elisp-parse-exec-action (nth 1 action) nonterm tokens)
+ ))
+ ))
+
+;;;; navigate grammar actions
+
+(defun wisi-elisp-parse--set-end (start-mark end-mark)
+ "Set END-MARK on all caches in `wisi-end-caches' in range START-MARK
END-MARK,
+delete from `wisi-end-caches'."
+ (let ((i 0)
+ pos cache)
+ (while (< i (length wisi-end-caches))
+ (setq pos (nth i wisi-end-caches))
+ (setq cache (wisi-get-cache pos))
+
+ (if (and (>= pos start-mark)
+ (< pos end-mark))
+ (progn
+ (setf (wisi-cache-end cache) end-mark)
+ (setq wisi-end-caches (delq pos wisi-end-caches)))
+
+ ;; else not in range
+ (setq i (1+ i)))
+ )))
+
+(defvar wisi-tokens nil
+ ;; Not wisi-elisp-parse--tokens for ease in debugging actions, and
+ ;; to match lots of doc strings.
+ "Array of ‘wisi-tok’ structures for the right hand side of the current
production.
+Let-bound in parser semantic actions.")
+
+(defvar wisi-nterm nil
+ ;; Not wisi-elisp-parse--nterm for ease in debugging actions
+ "The token id for the left hand side of the current production.
+Let-bound in parser semantic actions.")
+
+(defun wisi-statement-action (pairs)
+ ;; Not wisi-elisp-parse--statement-action to match existing grammar files
+ "Cache navigation information in text properties of tokens.
+Intended as a grammar non-terminal action.
+
+PAIRS is a vector of the form [TOKEN-NUMBER CLASS TOKEN-NUMBER
+CLASS ...] where TOKEN-NUMBER is the (1 indexed) token number in
+the production, CLASS is the wisi class of that token. Use in a
+grammar action as:
+ (wisi-statement-action [1 statement-start 7 statement-end])"
+ (when (eq wisi--parse-action 'navigate)
+ (save-excursion
+ (let ((first-item t)
+ first-keyword-mark
+ (override-start nil)
+ (i 0))
+ (while (< i (length pairs))
+ (let* ((number (1- (aref pairs i)))
+ (region (wisi-tok-region (aref wisi-tokens number)))
+ (token (wisi-tok-token (aref wisi-tokens number)))
+ (class (aref pairs (setq i (1+ i))))
+ (mark (when region (copy-marker (car region) t)))
+ cache)
+
+ (setq i (1+ i))
+
+ (unless (seq-contains wisi-class-list class)
+ (error "%s not in wisi-class-list" class))
+
+ (if region
+ (progn
+ (if (setq cache (wisi-get-cache (car region)))
+ ;; We are processing a previously set non-terminal; ie
simple_statement in
+ ;;
+ ;; statement : label_opt simple_statement
+ ;;
+ ;; override nonterm, class, containing
+ (progn
+ (setf (wisi-cache-class cache) (or override-start
class))
+ (setf (wisi-cache-nonterm cache) wisi-nterm)
+ (setf (wisi-cache-containing cache) first-keyword-mark)
+ (if wisi-end-caches
+ (push (car region) wisi-end-caches)
+ (setq wisi-end-caches (list (car region)))
+ ))
+
+ ;; else create new cache
+ (with-silent-modifications
+ (put-text-property
+ (car region)
+ (1+ (car region))
+ 'wisi-cache
+ (wisi-cache-create
+ :nonterm wisi-nterm
+ :token token
+ :last (- (cdr region) (car region))
+ :class (or override-start class)
+ :containing first-keyword-mark)
+ ))
+ (if wisi-end-caches
+ (push (car region) wisi-end-caches)
+ (setq wisi-end-caches (list (car region)))
+ ))
+
+ (when first-item
+ (setq first-item nil)
+ (when (or override-start
+ (eq class 'statement-start))
+ (setq override-start nil)
+ (setq first-keyword-mark mark)))
+
+ (when (eq class 'statement-end)
+ (wisi-elisp-parse--set-end first-keyword-mark (copy-marker
(car region) t)))
+ )
+
+ ;; region is nil when a production is empty; if the first
+ ;; token is a start, override the class on the next token.
+ (when (and first-item
+ (eq class 'statement-start))
+ (setq override-start class)))
+ ))
+ ))))
+
+(defun wisi-containing-action (containing-token contained-token)
+ ;; Not wisi-elisp-parse--containing-action to match existing grammar files
+ "Set containing marks in all tokens in CONTAINED-TOKEN
+with null containing mark to marker pointing to CONTAINING-TOKEN.
+If CONTAINING-TOKEN is empty, the next token number is used."
+ (when (eq wisi--parse-action 'navigate)
+ (let* ((containing-tok (aref wisi-tokens (1- containing-token)))
+ (containing-region (wisi-tok-region containing-tok))
+ (contained-tok (aref wisi-tokens (1- contained-token)))
+ (contained-region (wisi-tok-region contained-tok)))
+
+ (unless containing-region
+ (signal 'wisi-parse-error
+ (wisi-error-msg
+ "wisi-containing-action: containing-region '%s' is empty.
grammar error; bad action"
+ (wisi-tok-token containing-tok))))
+
+ (unless (or (not contained-region) ;; contained-token is empty
+ (wisi-get-cache (car containing-region)))
+ (signal 'wisi-parse-error
+ (wisi-error-msg
+ "wisi-containing-action: containing-token '%s' has no cache.
grammar error; missing action"
+ (wisi-token-text (aref wisi-tokens (1- containing-token))))))
+
+ (when contained-region
+ ;; nil when empty production, may not contain any caches
+ (save-excursion
+ (goto-char (cdr contained-region))
+ (let ((cache (wisi-backward-cache))
+ (mark (copy-marker (car containing-region) t)))
+ (while cache
+
+ ;; skip blocks that are already marked
+ (while (and (>= (point) (car contained-region))
+ (markerp (wisi-cache-containing cache)))
+ (goto-char (wisi-cache-containing cache))
+ (setq cache (wisi-get-cache (point))))
+
+ (if (or (and (= (car containing-region) (car contained-region))
+ (<= (point) (car contained-region)))
+ (< (point) (car contained-region)))
+ ;; done
+ (setq cache nil)
+
+ ;; else set mark, loop
+ (setf (wisi-cache-containing cache) mark)
+ (setq cache (wisi-backward-cache)))
+ ))))
+ )))
+
+(defun wisi-elisp-parse--match-token (cache tokens start)
+ "Return t if CACHE has id from TOKENS and is at START or has containing
equal to START.
+point must be at cache token start.
+TOKENS is a vector [number token_id token_id ...].
+number is ignored."
+ (let ((i 1)
+ (done nil)
+ (result nil)
+ token)
+ (when (or (= start (point))
+ (and (wisi-cache-containing cache)
+ (= start (wisi-cache-containing cache))))
+ (while (and (not done)
+ (< i (length tokens)))
+ (setq token (aref tokens i))
+ (if (eq token (wisi-cache-token cache))
+ (setq result t
+ done t)
+ (setq i (1+ i)))
+ ))
+ result))
+
+(defun wisi-motion-action (token-numbers)
+ ;; Not wisi-elisp-parse--motion-action to match existing grammar files
+ "Set prev/next marks in all tokens given by TOKEN-NUMBERS.
+TOKEN-NUMBERS is a vector with each element one of:
+
+number: the token number; mark that token
+
+vector [number token_id]:
+vector [number token_id token_id ...]:
+ mark all tokens in number nonterminal matching token_id with nil prev/next."
+ (when (eq wisi--parse-action 'navigate)
+ (save-excursion
+ (let (prev-keyword-mark
+ prev-cache
+ token
+ start
+ cache
+ mark
+ (i 0))
+ (while (< i (length token-numbers))
+ (let ((token-number (aref token-numbers i))
+ region)
+ (setq i (1+ i))
+ (cond
+ ((numberp token-number)
+ (setq token (aref wisi-tokens (1- token-number)))
+ (setq region (wisi-tok-region token))
+ (when region
+ (unless start (setq start (car region)))
+ (setq cache (wisi-get-cache (car region)))
+ (unless cache (error "no cache on token %d; add to
statement-action" token-number))
+ (setq mark (copy-marker (car region) t))
+
+ (if prev-keyword-mark
+ (progn
+ (setf (wisi-cache-prev cache) prev-keyword-mark)
+ (setf (wisi-cache-next prev-cache) mark)
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache))
+
+ ;; else first token; save as prev
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache))
+ ))
+
+ ((vectorp token-number)
+ ;; token-number may contain 1 or more token_ids
+ ;; the corresponding region may be empty
+ ;; there may not have been a prev keyword
+ (setq region (wisi-tok-region (aref wisi-tokens (1- (aref
token-number 0)))))
+ (when region ;; not an empty token
+ ;; We must search for all targets at the same time, to
+ ;; get the motion order right.
+ (unless start (setq start (car region)))
+ (goto-char (car region))
+ (setq cache (wisi-get-cache (point)))
+ (unless cache (error "no cache at %d; add to statement-action"
(car region)))
+ (while (< (point) (cdr region))
+ (when (wisi-elisp-parse--match-token cache token-number start)
+ (setq mark (copy-marker (point) t))
+
+ (if prev-keyword-mark
+ ;; Don't include this token if prev/next
+ ;; already set by a lower level statement,
+ ;; such as a nested if/then/elsif/end if.
+ (when (and (null (wisi-cache-prev cache))
+ (null (wisi-cache-next prev-cache)))
+ (setf (wisi-cache-prev cache) prev-keyword-mark)
+ (setf (wisi-cache-next prev-cache) mark)
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache))
+
+ ;; else first token; save as prev
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache)))
+
+ (setq cache (wisi-forward-cache))
+ )))
+
+ (t
+ (error "unexpected token-number %s" token-number))
+ )
+
+ ))
+ ))))
+
+;;;; Face grammar actions
+
+(defun wisi-elisp-parse--face-put-cache (region class)
+ "Put a ’wisi-face’ cache with class CLASS on REGION."
+ (when (> wisi-debug 1)
+ (message "face: put cache %s:%s" region class))
+ (with-silent-modifications
+ (put-text-property
+ (car region)
+ (1+ (car region))
+ 'wisi-face
+ (wisi-cache-create
+ :last (- (cdr region) (car region))
+ :class class)
+ )))
+
+(defun wisi-face-mark-action (pairs)
+ ;; Not wisi-elisp-parse--face-mark-action to match existing grammar files
+ "PAIRS is a vector of TOKEN CLASS pairs; mark TOKEN (token number)
+as having face CLASS (prefix or suffix).
+Intended as a grammar action."
+ (when (eq wisi--parse-action 'face)
+ (let ((i 0))
+ (while (< i (length pairs))
+ (let ((region (wisi-tok-region (aref wisi-tokens (1- (aref pairs i)))))
+ (class (aref pairs (setq i (1+ i)))))
+ (setq i (1+ i))
+ (when region
+ ;; region can be null on an optional or virtual token
+ (let ((cache (get-text-property (car region) 'wisi-face)))
+ (if cache
+ ;; previously marked; extend this cache, delete any others
+ (progn
+ (with-silent-modifications
+ (remove-text-properties (+ (car region) (wisi-cache-last
cache)) (cdr region) '(wisi-face nil)))
+ (setf (wisi-cache-class cache) class)
+ (setf (wisi-cache-last cache) (- (cdr region) (car
region))))
+
+ ;; else not previously marked
+ (wisi-elisp-parse--face-put-cache region class)))
+ ))
+ ))))
+
+(defun wisi-face-remove-action (tokens)
+ ;; Not wisi-elisp-parse--face-remove-action to match existing grammar files
+ "Remove face caches and faces in TOKENS.
+Intended as a grammar action.
+
+TOKENS is a vector of token numbers."
+ (when (eq wisi--parse-action 'face)
+ (let ((i 0))
+ (while (< i (length tokens))
+ (let* ((number (1- (aref tokens i)))
+ (region (wisi-tok-region (aref wisi-tokens number)))
+ face-cache)
+
+ (setq i (1+ i))
+
+ (when region
+ (let ((pos (car region)))
+ (while (< pos (cdr region))
+ (when (setq face-cache (get-text-property pos 'wisi-face))
+ (when (> wisi-debug 1)
+ (message "face: remove face %s" (cons pos (+ pos
(wisi-cache-last face-cache)))))
+ (with-silent-modifications
+ (remove-text-properties
+ pos (+ pos (wisi-cache-last face-cache))
+ (list
+ 'wisi-face nil
+ 'font-lock-face nil
+ 'fontified t))))
+ (setq pos (next-single-property-change
+ (+ pos (or (and face-cache
+ (wisi-cache-last face-cache))
+ 0))
+ 'wisi-face nil (cdr region)))
+ )))
+ )))))
+
+(defun wisi-elisp-parse--face-action-1 (face region)
+ "Apply FACE to REGION."
+ (when region
+ (when (> wisi-debug 1)
+ (message "face: add face %s:%s" region face))
+ (with-silent-modifications
+ (add-text-properties
+ (car region) (cdr region)
+ (list
+ 'font-lock-face face
+ 'fontified t)))
+ ))
+
+(defun wisi-face-apply-action (triples)
+ ;; Not wisi-elisp-parse--face-apply-action to match existing grammar files
+ "Set face information in `wisi-face' text properties of tokens.
+Intended as a grammar non-terminal action.
+
+TRIPLES is a vector of the form [TOKEN-NUMBER PREFIX-FACE SUFFIX-FACE ...]
+
+In the first ’wisi-face’ cache in each token region, apply
+PREFIX-FACE to class PREFIX, SUFFIX-FACE to class SUFFIX, or
+SUFFIX-FACE to all of the token region if there is no ’wisi-face’
+cache."
+ (when (eq wisi--parse-action 'face)
+ (let (number prefix-face suffix-face (i 0))
+ (while (< i (length triples))
+ (setq number (aref triples i))
+ (setq prefix-face (aref triples (setq i (1+ i))))
+ (setq suffix-face (aref triples (setq i (1+ i))))
+ (cond
+ ((integerp number)
+ (let* ((token-region (wisi-tok-region (aref wisi-tokens (1- number))))
+ (pos (car token-region))
+ (j 0)
+ (some-cache nil)
+ cache)
+ (when token-region
+ ;; region can be null for an optional or virtual token
+ (while (< j 2)
+ (setq cache (get-text-property pos 'wisi-face))
+ (cond
+ ((and (not some-cache)
+ (null cache))
+ ;; cache is null when applying a face to a token
+ ;; directly, without first calling
+ ;; wisi-face-mark-action. Or when there is a
+ ;; previously applied face in a lower level token,
+ ;; such as a numeric literal.
+ (wisi-elisp-parse--face-action-1 suffix-face token-region))
+
+ ((and cache
+ (eq 'prefix (wisi-cache-class cache)))
+ (setq some-cache t)
+ (wisi-elisp-parse--face-action-1 prefix-face
(wisi-cache-region cache pos)))
+
+ ((and cache
+ (eq 'suffix (wisi-cache-class cache)))
+ (setq some-cache t)
+ (wisi-elisp-parse--face-action-1 suffix-face
(wisi-cache-region cache pos)))
+
+ (t
+ ;; don’t apply a face
+ nil)
+ )
+
+ (setq j (1+ j))
+ (if suffix-face
+ (setq pos (next-single-property-change (+ 2 pos) 'wisi-face
nil (cdr token-region)))
+ (setq j 2))
+ ))))
+
+ (t
+ ;; catch conversion errors from previous grammar syntax
+ (error "wisi-face-apply-action with non-integer token number"))
+ )
+ (setq i (1+ i))
+ ))))
+
+(defun wisi-face-apply-list-action (triples)
+ ;; Not wisi-elisp-parse--face-apply-list-action to match existing grammar
files
+ "Similar to ’wisi-face-apply-action’, but applies faces to all
+tokens with a `wisi-face' cache in the wisi-tokens[token-number]
+region, and does not apply a face if there are no such caches."
+ (when (eq wisi--parse-action 'face)
+ (let (number token-region face-region prefix-face suffix-face cache (i 0)
pos)
+ (while (< i (length triples))
+ (setq number (aref triples i))
+ (setq prefix-face (aref triples (setq i (1+ i))))
+ (setq suffix-face (aref triples (setq i (1+ i))))
+ (cond
+ ((integerp number)
+ (setq token-region (wisi-tok-region (aref wisi-tokens (1- number))))
+ (when token-region
+ ;; region can be null for an optional token
+ (setq pos (car token-region))
+ (while (and pos
+ (< pos (cdr token-region)))
+ (setq cache (get-text-property pos 'wisi-face))
+ (setq face-region (wisi-cache-region cache pos))
+ (cond
+ ((or (null (wisi-cache-class cache))
+ (eq 'prefix (wisi-cache-class cache)))
+ (wisi-elisp-parse--face-action-1 prefix-face face-region))
+ ((eq 'suffix (wisi-cache-class cache))
+ (wisi-elisp-parse--face-action-1 suffix-face face-region))
+
+ (t
+ (error "wisi-face-apply-list-action: face cache class is not
prefix or suffix")))
+
+ (setq pos (next-single-property-change (1+ pos) 'wisi-face nil
(cdr token-region)))
+ )))
+ (t
+ ;; catch conversion errors from previous grammar syntax
+ (error "wisi-face-apply-list-action with non-integer token number"))
+ )
+ (setq i (1+ i))
+ ))))
+
+;;;; indent grammar actions
+
+(defvar wisi-elisp-parse-indent-hanging-function nil
+ "Language-specific implementation of `wisi-hanging', `wisi-hanging%'.
+A function taking args TOK DELTA1 DELTA2 OPTION NO-ACCUMULATE,
+and returning an indent.
+TOK is a `wisi-tok' struct for the token being indented.
+DELTA1, DELTA2 are the indents of the first and following lines
+within the nonterminal. OPTION is non-nil if action is `wisi-hanging%'.
+point is at start of TOK, and may be moved.")
+(make-variable-buffer-local 'wisi-elisp-parse-indent-hanging-function)
+
+(defvar wisi-token-index nil
+ ;; Not wisi-elisp-parse--token-index for backward compatibility
+ "Index of current token in `wisi-tokens'.
+Let-bound in `wisi-indent-action', for grammar actions.")
+
+(defvar wisi-indent-comment nil
+ ;; Not wisi-elisp-parse--indent-comment for backward compatibility
+ "Non-nil if computing indent for comment.
+Let-bound in `wisi-indent-action', for grammar actions.")
+
+(defun wisi-elisp-parse--indent-zero-p (indent)
+ (cond
+ ((integerp indent)
+ (= indent 0))
+
+ (t ;; 'anchor
+ (integerp (nth 2 indent)))
+ ))
+
+(defun wisi-elisp-parse--apply-int (i delta)
+ "Add DELTA (an integer) to the indent at index I."
+ (let ((indent (aref wisi-elisp-parse--indent i))) ;; reference if list
+
+ (cond
+ ((integerp indent)
+ (aset wisi-elisp-parse--indent i (+ delta indent)))
+
+ ((listp indent)
+ (cond
+ ((eq 'anchor (car indent))
+ (when (integerp (nth 2 indent))
+ (setf (nth 2 indent) (+ delta (nth 2 indent)))
+ ;; else anchored; not affected by this delta
+ ))
+
+ ((eq 'anchored (car indent))
+ ;; not affected by this delta
+ )))
+
+ (t
+ (error "wisi-elisp-parse--apply-int: invalid form : %s" indent))
+ )))
+
+(defun wisi-elisp-parse--apply-anchored (delta i)
+ "Apply DELTA (an anchored indent) to indent I."
+ ;; delta is from wisi-anchored; ('anchored 1 delta no-accumulate)
+ (let ((indent (aref wisi-elisp-parse--indent i))
+ (accumulate (not (nth 3 delta))))
+
+ (cond
+ ((integerp indent)
+ (when (or accumulate
+ (= indent 0))
+ (let ((temp (seq-take delta 3)))
+ (setf (nth 2 temp) (+ indent (nth 2 temp)))
+ (aset wisi-elisp-parse--indent i temp))))
+
+ ((and (listp indent)
+ (eq 'anchor (car indent))
+ (integerp (nth 2 indent)))
+ (when (or accumulate
+ (= (nth 2 indent) 0))
+ (let ((temp (seq-take delta 3)))
+ (setf (nth 2 temp) (+ (nth 2 indent) (nth 2 temp)))
+ (setf (nth 2 indent) temp))))
+ )))
+
+(defun wisi-elisp-parse--indent-token-1 (line end delta)
+ "Apply indent DELTA to all lines from LINE (a line number) thru END (a
buffer position)."
+ (let ((i (1- line));; index to wisi-elisp-lexer-line-begin,
wisi-elisp-parse--indent
+ (paren-first (when (and (listp delta)
+ (eq 'hanging (car delta)))
+ (nth 2 delta))))
+
+ (while (<= (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end)
+ (unless
+ (and ;; no check for called from wisi--indent-comment;
+ ;; comments within tokens are indented by
+ ;; wisi--indent-token
+ wisi-indent-comment-col-0
+ (= 11 (syntax-class (syntax-after (aref
(wisi-elisp-lexer-line-begin wisi--lexer) i)))))
+ (cond
+ ((integerp delta)
+ (wisi-elisp-parse--apply-int i delta))
+
+ ((listp delta)
+ (cond
+ ((eq 'anchored (car delta))
+ (wisi-elisp-parse--apply-anchored delta i))
+
+ ((eq 'hanging (car delta))
+ ;; from wisi-hanging; delta is ('hanging first-line nest delta1
delta2 no-accumulate)
+ ;; delta1, delta2 may be anchored
+ (when (or (not (nth 5 delta))
+ (wisi-elisp-parse--indent-zero-p (aref
wisi-elisp-parse--indent i)))
+ (if (= i (1- (nth 1 delta)))
+ ;; apply delta1
+ (let ((delta1 (nth 3 delta)))
+ (cond
+ ((integerp delta1)
+ (wisi-elisp-parse--apply-int i delta1))
+
+ (t ;; anchored
+ (wisi-elisp-parse--apply-anchored delta1 i))
+ ))
+
+ ;; don't apply hanging indent in nested parens.
+ ;; test/ada_mode-parens.adb
+ ;; No_Conditional_Set : constant Ada.Strings.Maps.Character_Set
:=
+ ;; Ada.Strings.Maps."or"
+ ;; (Ada.Strings.Maps.To_Set (' '),
+ (when (= paren-first
+ (nth 0 (save-excursion (syntax-ppss (aref
(wisi-elisp-lexer-line-begin wisi--lexer) i)))))
+ (let ((delta2 (nth 4 delta)))
+ (cond
+ ((integerp delta2)
+ (wisi-elisp-parse--apply-int i delta2))
+
+ (t ;; anchored
+ (wisi-elisp-parse--apply-anchored delta2 i))
+ )))
+ )))
+
+ (t
+ (error "wisi-elisp-parse--indent-token-1: invalid delta: %s" delta))
+ )) ;; listp delta
+
+ (t
+ (error "wisi-elisp-parse--indent-token-1: invalid delta: %s" delta))
+ ))
+ (setq i (1+ i))
+ )))
+
+(defun wisi-elisp-parse--indent-token (tok token-delta)
+ "Add TOKEN-DELTA to all indents in TOK region,"
+ (let ((line (if (wisi-tok-nonterminal tok)
+ (wisi-tok-first tok)
+ (when (wisi-tok-first tok) (wisi-tok-line tok))))
+ (end (cdr (wisi-tok-region tok))))
+ (when (and line end token-delta)
+ (wisi-elisp-parse--indent-token-1 line end token-delta))))
+
+(defun wisi-elisp-parse--indent-comment (tok comment-delta)
+ "Add COMMENT-DELTA to all indents in comment region following TOK."
+ (let ((line (wisi-tok-comment-line tok))
+ (end (wisi-tok-comment-end tok)))
+ (when (and line end comment-delta)
+ (wisi-elisp-parse--indent-token-1 line end comment-delta))))
+
+(defun wisi-elisp-parse--anchored-1 (tok offset &optional no-accumulate)
+ "Return offset of TOK relative to current indentation + OFFSET.
+For use in grammar indent actions."
+ (when (wisi-tok-region tok)
+ ;; region can be nil when token is inserted by error recovery
+ (let ((pos (car (wisi-tok-region tok)))
+ delta)
+
+ (goto-char pos)
+ (setq delta (+ offset (- (current-column) (current-indentation))))
+ (wisi-elisp-parse--anchored-2
+ (wisi-tok-line tok) ;; anchor-line
+ (if wisi-indent-comment
+ (wisi-tok-comment-end (aref wisi-tokens wisi-token-index))
+ (cdr (wisi-tok-region (aref wisi-tokens wisi-token-index))));; end
+ delta
+ no-accumulate)
+ )))
+
+(defun wisi-elisp-parse--max-anchor (begin-line end)
+ (let ((i (1- begin-line))
+ (max-i (length (wisi-elisp-lexer-line-begin wisi--lexer)))
+ (result 0))
+ (while (and (< i max-i)
+ (<= (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end))
+ (let ((indent (aref wisi-elisp-parse--indent i)))
+ (when (listp indent)
+ (cond
+ ((eq 'anchor (car indent))
+ (setq result (max result (car (nth 1 indent))))
+ (when (listp (nth 2 indent))
+ (setq result (max result (nth 1 (nth 2 indent))))
+ ))
+ (t ;; anchored
+ (setq result (max result (nth 1 indent))))
+ )))
+ (setq i (1+ i)))
+ result
+ ))
+
+(defun wisi-elisp-parse--anchored-2 (anchor-line end delta no-accumulate)
+ "Set ANCHOR-LINE as anchor, increment anchors thru END, return anchored
delta."
+ ;; Typically, we use anchored to indent relative to a token buried in a line:
+ ;;
+ ;; test/ada_mode-parens.adb
+ ;; Local_2 : Integer := (1 + 2 +
+ ;; 3);
+ ;; line starting with '3' is anchored to '('
+ ;;
+ ;; If the anchor is a nonterminal, and the first token in the anchor
+ ;; is also first on a line, we don't need anchored to compute the
+ ;; delta:
+ ;;
+ ;; test/ada_mode-parens.adb
+ ;; Local_5 : Integer :=
+ ;; (1 + 2 +
+ ;; 3);
+ ;; delta for line starting with '3' can just be '3'.
+ ;;
+ ;; However, in some places we need anchored to prevent later
+ ;; deltas from accumulating:
+ ;;
+ ;; test/ada_mode-parens.adb
+ ;; No_Conditional_Set : constant Ada.Strings.Maps.Character_Set :=
+ ;; Ada.Strings.Maps."or"
+ ;; (Ada.Strings.Maps.To_Set (' '),
+ ;;
+ ;; here the function call actual parameter part is indented first
+ ;; by 'name' and later by 'expression'; we use anchored to keep the
+ ;; 'name' delta and ignore the later delta.
+ ;;
+ ;; So we apply anchored whether the anchor token is first or not.
+
+ (let* ((i (1- anchor-line))
+ (indent (aref wisi-elisp-parse--indent i)) ;; reference if list
+ (anchor-id (1+ (wisi-elisp-parse--max-anchor anchor-line end))))
+
+ ;; Set anchor
+ (cond
+ ((integerp indent)
+ (aset wisi-elisp-parse--indent i (list 'anchor (list anchor-id) indent)))
+
+ ((and (listp indent)
+ (eq 'anchor (car indent)))
+ (push anchor-id (nth 1 indent)))
+
+ ((and (listp indent)
+ (eq 'anchored (car indent)))
+ (aset wisi-elisp-parse--indent i (list 'anchor (list anchor-id)
(copy-sequence indent))))
+
+ (t
+ (error "wisi-anchored-delta: invalid form in indent: %s" indent)))
+
+ (list 'anchored anchor-id delta no-accumulate)
+ ))
+
+(defun wisi-anchored (token-number offset &optional no-accumulate)
+ ;; Not wisi-elisp-parse--anchored to match existing grammar files
+ "Return offset of token TOKEN-NUMBER in `wisi-tokens'.relative to current
indentation + OFFSET.
+For use in grammar indent actions."
+ (wisi-elisp-parse--anchored-1 (aref wisi-tokens (1- token-number)) offset
no-accumulate))
+
+(defun wisi-anchored* (token-number offset)
+ ;; Not wisi-elisp-parse--anchored* to match existing grammar files
+ "If TOKEN-NUMBER token in `wisi-tokens' is first on a line,
+call ’wisi-anchored OFFSET’. Otherwise return 0.
+For use in grammar indent actions."
+ (if (wisi-tok-first (aref wisi-tokens (1- token-number)))
+ (wisi-anchored token-number offset)
+ 0))
+
+(defun wisi-anchored*- (token-number offset)
+ ;; Not wisi-elisp-parse--anchored*- to match existing grammar files
+ "If existing indent is zero, and TOKEN-NUMBER token in `wisi-tokens' is
first on a line,
+call ’wisi-anchored OFFSET’. Otherwise return 0.
+For use in grammar indent actions."
+ (if (wisi-tok-first (aref wisi-tokens (1- token-number)))
+ (wisi-anchored token-number offset t)
+ 0))
+
+(defun wisi-elisp-parse--paren-in-anchor-line (anchor-tok offset)
+ "If there is an opening paren containing ANCHOR-TOK in the same line as
ANCHOR-TOK,
+return OFFSET plus the delta from the line indent to the paren
+position. Otherwise return OFFSET."
+ (let* ((tok-syntax (syntax-ppss (car (wisi-tok-region anchor-tok))))
+ (paren-pos (nth 1 tok-syntax))
+ (anchor-line (wisi-tok-line anchor-tok)))
+
+ (when (and paren-pos ;; in paren
+ (< paren-pos (aref (wisi-elisp-lexer-line-begin wisi--lexer) (1-
anchor-line))))
+ ;; paren not in anchor line
+ (setq paren-pos nil))
+
+ (if paren-pos
+ (progn
+ (goto-char paren-pos)
+ (+ 1 (- (current-column) (current-indentation)) offset))
+ offset)
+ ))
+
+(defun wisi-anchored% (token-number offset &optional no-accumulate)
+ ;; Not wisi-elisp-parse--anchored% to match existing grammar files
+ "Return either an anchor for the current token at OFFSET from an enclosing
paren on
+the line containing TOKEN-NUMBER, or OFFSET.
+For use in grammar indent actions."
+ (let* ((indent-tok (aref wisi-tokens wisi-token-index))
+ ;; indent-tok is a nonterminal; this function makes no sense for
terminals
+ (anchor-tok (aref wisi-tokens (1- token-number))))
+
+ (wisi-elisp-parse--anchored-2
+ (wisi-tok-line anchor-tok)
+
+ (if wisi-indent-comment
+ (wisi-tok-comment-end indent-tok)
+ (cdr (wisi-tok-region indent-tok))) ;; end
+
+ (wisi-elisp-parse--paren-in-anchor-line anchor-tok offset)
+ no-accumulate)
+ ))
+
+(defun wisi-anchored%- (token-number offset)
+ ;; Not wisi-elisp-parse--anchored%- to match existing grammar files
+ "If existing indent is zero, anchor the current token at OFFSET
+from the first token on the line containing TOKEN-NUMBER in `wisi-tokens'.
+Return the delta.
+For use in grammar indent actions."
+ (wisi-anchored% token-number offset t))
+
+(defun wisi-elisp-parse--hanging-1 (delta1 delta2 option no-accumulate)
+ "If OPTION is nil, implement `wisi-hanging'; otherwise `wisi-hanging%'."
+ (let ((tok (aref wisi-tokens wisi-token-index)))
+ ;; tok is a nonterminal; this function makes no sense for terminals
+ ;; syntax-ppss moves point to start of tok
+
+ (cond
+ ((functionp wisi-elisp-parse-indent-hanging-function)
+ (funcall wisi-elisp-parse-indent-hanging-function tok delta1 delta2
option no-accumulate))
+
+ (t
+ (let ((tok-syntax (syntax-ppss (car (wisi-tok-region tok))))
+ (first-tok-first-on-line
+ ;; first token in tok is first on line
+ (and (numberp (wisi-tok-first tok))
+ (= (wisi-tok-line tok) (wisi-tok-first tok)))))
+ (list 'hanging
+ (wisi-tok-line tok) ;; first line of token
+ (nth 0 tok-syntax) ;; paren nest level at tok
+ delta1
+ (if (or (not option) first-tok-first-on-line)
+ delta2
+ delta1)
+ no-accumulate))
+ ))
+ ))
+
+(defun wisi-hanging (delta1 delta2)
+ ;; Not wisi-elisp-parse--hanging to match existing grammar files
+ "Use DETLA1 for first line, DELTA2 for following lines.
+For use in grammar indent actions."
+ (wisi-elisp-parse--hanging-1 delta1 delta2 nil nil))
+
+(defun wisi-hanging% (delta1 delta2)
+ ;; Not wisi-elisp-parse--hanging% to match existing grammar files
+ "If first token is first in line, use DETLA1 for first line, DELTA2 for
following lines.
+Otherwise use DELTA1 for all lines.
+For use in grammar indent actions."
+ (wisi-elisp-parse--hanging-1 delta1 delta2 t nil))
+
+(defun wisi-hanging%- (delta1 delta2)
+ ;; Not wisi-elisp-parse--hanging%- to match existing grammar files
+ "If existing indent is non-zero, do nothing.
+Else if first token is first in line, use DETLA1 for first line,
+DELTA2 for following lines. Otherwise use DELTA1 for all lines.
+For use in grammar indent actions."
+ (wisi-elisp-parse--hanging-1 delta1 delta2 t t))
+
+(defun wisi-elisp-parse--indent-offset (token offset)
+ "Return offset from beginning of first token on line containing TOKEN,
+ to beginning of TOKEN, plus OFFSET."
+ (save-excursion
+ (goto-char (aref (wisi-elisp-lexer-line-begin wisi--lexer) (1-
(wisi-tok-line token))))
+ (back-to-indentation)
+ (+ offset (- (car (wisi-tok-region token)) (point)))
+ ))
+
+(defun wisi-elisp-parse--indent-compute-delta (delta tok)
+ "Return evaluation of DELTA."
+ (cond
+ ((integerp delta)
+ delta)
+
+ ((symbolp delta)
+ (symbol-value delta))
+
+ ((vectorp delta)
+ ;; [token comment]
+ ;; if wisi-indent-comment, we are indenting the comments of the
+ ;; previous token; they should align with the 'token' delta.
+ (wisi-elisp-parse--indent-compute-delta (aref delta 0) tok))
+
+ (t ;; form
+ (cond
+ ((eq 'anchored (car delta))
+ delta)
+
+ (t
+ (save-excursion
+ (goto-char (car (wisi-tok-region tok)))
+ (eval delta)))))
+ ))
+
+(defun wisi-indent-action (deltas)
+ ;; Not wisi-elisp-parse--indent-action to match existing grammar files
+ "Accumulate `wisi--indents' from DELTAS.
+DELTAS is a vector; each element can be:
+- an integer
+- a symbol
+- a lisp form
+- a vector.
+
+The first three are evaluated to give an integer delta. A vector must
+have two elements, giving the code and following comment
+deltas. Otherwise the comment delta is the following delta in
+DELTAS."
+ (when (eq wisi--parse-action 'indent)
+ (dotimes (wisi-token-index (length wisi-tokens))
+ (let* ((tok (aref wisi-tokens wisi-token-index))
+ (token-delta (aref deltas wisi-token-index))
+ (comment-delta
+ (cond
+ ((vectorp token-delta)
+ (aref token-delta 1))
+
+ ((< wisi-token-index (1- (length wisi-tokens)))
+ (aref deltas (1+ wisi-token-index)))
+ )))
+ (when (wisi-tok-region tok)
+ ;; region is null when optional nonterminal is empty
+ (let ((wisi-indent-comment nil))
+ (setq token-delta
+ (when (and token-delta
+ (wisi-tok-first tok))
+ (wisi-elisp-parse--indent-compute-delta token-delta tok)))
+
+ (when (and token-delta
+ (or (consp token-delta)
+ (not (= 0 token-delta))))
+ (wisi-elisp-parse--indent-token tok token-delta))
+
+ (setq wisi-indent-comment t)
+ (setq comment-delta
+ (when (and comment-delta
+ (wisi-tok-comment-line tok))
+ (wisi-elisp-parse--indent-compute-delta comment-delta tok)))
+
+ (when (and comment-delta
+ (or (consp comment-delta)
+ (not (= 0 comment-delta))))
+ (wisi-elisp-parse--indent-comment tok comment-delta))
+ )
+ )))))
+
+(defun wisi-indent-action* (n deltas)
+ ;; Not wisi-elisp-parse--indent-action* to match existing grammar files
+ "If any of the first N tokens in `wisi-tokens' is first on a line,
+call `wisi-indent-action' with DELTAS. Otherwise do nothing."
+ (when (eq wisi--parse-action 'indent)
+ (let ((done nil)
+ (i 0)
+ tok)
+ (while (and (not done)
+ (< i n))
+ (setq tok (aref wisi-tokens i))
+ (setq i (1+ i))
+ (when (and (wisi-tok-region tok)
+ (wisi-tok-first tok))
+ (setq done t)
+ (wisi-indent-action deltas))
+ ))))
+
+;;;; non-grammar indent functions
+
+(defconst wisi-elisp-parse--max-anchor-depth 20) ;; IMRPOVEME: can compute in
actions
+
+(defun wisi-elisp-parse--indent-leading-comments ()
+ "Set `wisi-elisp-parse--indent to 0 for comment lines before first token in
buffer.
+Leave point at first token (or eob)."
+ (save-excursion
+ (goto-char (point-min))
+ (forward-comment (point-max))
+ (let ((end (point))
+ (i 0)
+ (max-i (length wisi-elisp-parse--indent)))
+ (while (and (< i max-i)
+ (< (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end))
+ (aset wisi-elisp-parse--indent i 0)
+ (setq i (1+ i)))
+ )))
+
+(defun wisi-elisp-parse--resolve-anchors ()
+ (let ((anchor-indent (make-vector wisi-elisp-parse--max-anchor-depth 0))
+ pos)
+
+ (dotimes (i (length wisi-elisp-parse--indent))
+ (let ((indent (aref wisi-elisp-parse--indent i)))
+
+ (cond
+ ((integerp indent))
+
+ ((listp indent)
+ (let ((anchor-ids (nth 1 indent))
+ (indent2 (nth 2 indent)))
+ (cond
+ ((eq 'anchor (car indent))
+ (cond
+ ((integerp indent2)
+ (dotimes (i (length anchor-ids))
+ (aset anchor-indent (nth i anchor-ids) indent2))
+ (setq indent indent2))
+
+ ((listp indent2) ;; 'anchored
+ (setq indent (+ (aref anchor-indent (nth 1 indent2)) (nth 2
indent2)))
+
+ (dotimes (i (length anchor-ids))
+ (aset anchor-indent (nth i anchor-ids) indent)))
+
+ (t
+ (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
+ ));; 'anchor
+
+ ((eq 'anchored (car indent))
+ (setq indent (+ (aref anchor-indent (nth 1 indent)) indent2)))
+
+ (t
+ (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
+ )));; listp indent
+
+ (t
+ (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
+ );; cond indent
+
+ (when (> i 0)
+ (setq pos (aref (wisi-elisp-lexer-line-begin wisi--lexer) i))
+ (with-silent-modifications
+ (put-text-property (1- pos) pos 'wisi-indent indent)))
+ )) ;; dotimes lines
+
+ ))
+
+(provide 'wisi-elisp-parse)
+;;; wisi-elisp-parse.el ends here
diff --git a/wisi-fringe.el b/wisi-fringe.el
new file mode 100644
index 0000000..7f1c10b
--- /dev/null
+++ b/wisi-fringe.el
@@ -0,0 +1,146 @@
+;;; wisi-fringe.el --- show approximate error locations in the fringe
+;;
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; Design:
+;;
+;; Bitmaps are displayed in the fringe by putting a 'display property
+;; on buffer text. However, just doing that also hides the buffer
+;; text. To avoid that, we put the ’display property on a string, and
+;; then an overlay containing that string as ’before-string or
+;; ’after-string on the newline of a buffer line.
+;;
+;; We show approximate error positions in the entire buffer with
+;; single-pixel lines in the right fringe, and mark error lines with
+;; ’!!’ in the left fringe.
+
+(defun wisi-fringe-create-bitmaps ()
+ "Return an array of bitmap symbols containing the fringe bitmaps."
+ ;; First create the ’!!’ bitmap.
+ (define-fringe-bitmap 'wisi-fringe--double-exclaim-bmp
+ (vector
+ #b00000000
+ #b01100110
+ #b01100110
+ #b01100110
+ #b01100110
+ #b01100110
+ #b00000000
+ #b01100110
+ #b01010110
+ #b00000000))
+
+ ;; In condensing the entire buffer to the current window height, we
+ ;; assume a 10 point font, which allows 6 distinct line positions
+ ;; each one pixel high, with one blank pixel between.
+
+ (let ((result (make-vector 64 nil))
+ (i 1))
+ (while (<= i (length result))
+ (aset result (1- i)
+ (define-fringe-bitmap (intern (format "wisi-fringe--line-%d-bmp" i))
+ (vector
+ (if (>= i 32) #b11111111 #b00000000)
+ #b00000000
+ (if (>= (% i 32) 16) #b11111111 #b00000000)
+ #b00000000
+ (if (>= (% i 16) 8) #b11111111 #b00000000)
+ #b00000000
+ (if (>= (% i 8) 4) #b11111111 #b00000000)
+ #b00000000
+ (if (>= (% i 4) 2) #b11111111 #b00000000)
+ #b00000000
+ (if (>= (% i 2) 1) #b11111111 #b00000000)
+ )))
+ (setq i (1+ i)))
+ result))
+
+(defconst wisi-fringe-bitmaps (wisi-fringe-create-bitmaps)
+ "Array of 64 bitmap symbols.")
+
+(defun wisi-fringe--put-right (line bitmap-index)
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (let* ((endpos (line-end-position))
+ (ov (make-overlay endpos (1+ endpos)))
+ (bmp (aref wisi-fringe-bitmaps bitmap-index)))
+ (overlay-put ov 'after-string (propertize "-" 'display (list
'right-fringe bmp 'compilation-error)))
+ (overlay-put ov 'wisi-fringe t)
+ )))
+
+(defun wisi-fringe--put-left (line)
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (let* ((endpos (line-end-position))
+ (ov (make-overlay endpos (1+ endpos)))
+ (bmp 'wisi-fringe--double-exclaim-bmp))
+ (overlay-put ov 'before-string (propertize "-" 'display (list
'left-fringe bmp 'compilation-error)))
+ (overlay-put ov 'wisi-fringe t)
+ )))
+
+(defun wisi-fringe--scale (error-line buffer-lines window-line-first
window-lines)
+ "Return a cons (LINE . BIN) for ERROR-LINE,
+where LINE is the line to display the error bar on, and BIN is a
+6-bit bit vector giving the relative position in that line.
+BUFFER-LINES is the count of lines in the buffer.
+WINDOW-LINE-FIRST is the first and last lines of the buffer
+visible in the window. WINDOW-LINES is the count of lines visible
+in the window."
+ ;; If the end of buffer is inside the window, and this calculation
+ ;; puts a mark after that, it will actually be put on the last real
+ ;; line. That’s good enough for our purposes.
+
+ ;; partial-lines / window-line = 6
+ ;; buffer-lines / window-line = 1/scale
+ ;; buffer-lines / partial-line = (window-line / partial-lines) *
(buffer-lines / window-line) = 1/6 * 1/scale
+ (let* ((scale (/ window-lines (float buffer-lines)))
+ (line (floor (* scale error-line)))
+ (rem (- error-line (floor (/ line scale)))))
+ (cons (+ window-line-first line) (lsh 1 (min 5 (floor (* rem (* 6
scale))))))))
+
+(defun wisi-fringe-display-errors (positions)
+ "Display a bar in the 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)
+ (let (scaled-posns
+ (buffer-lines (line-number-at-pos (point-max)))
+ (window-lines (window-height))
+ (window-pos-first (window-start))
+ (window-pos-last (window-end))
+ (window-line-first (line-number-at-pos (window-start))))
+ (dolist (pos positions)
+ (let* ((line (line-number-at-pos pos))
+ (scaled-pos (wisi-fringe--scale line buffer-lines
window-line-first window-lines)))
+ (when (and (>= pos window-pos-first)
+ (<= pos window-pos-last))
+ (wisi-fringe--put-left line))
+ (if (and scaled-posns
+ (= (caar scaled-posns) (car scaled-pos)))
+ (setcdr (car scaled-posns) (logior (cdar scaled-posns) (cdr
scaled-pos)))
+ (push scaled-pos scaled-posns))
+ ))
+
+ (dolist (pos scaled-posns)
+ (wisi-fringe--put-right (car pos) (1- (cdr pos))))
+ ))
+
+(provide 'wisi-fringe)
diff --git a/wisi-parse-common.el b/wisi-parse-common.el
new file mode 100644
index 0000000..3aa2c92
--- /dev/null
+++ b/wisi-parse-common.el
@@ -0,0 +1,341 @@
+;;; 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)
diff --git a/wisi-parse.el b/wisi-parse.el
deleted file mode 100755
index 0076fe5..0000000
--- a/wisi-parse.el
+++ /dev/null
@@ -1,549 +0,0 @@
-;;; wisi-parse.el --- Wisi parser -*- lexical-binding:t -*-
-
-;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-
-;; An extended LALR parser, that handles shift/reduce and
-;; reduce/reduce conflicts by spawning parallel parsers to follow each
-;; path.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'semantic/wisent)
-
-;; WORKAROUND: for some reason, this condition doesn't work in batch mode!
-;; (when (and (= emacs-major-version 24)
-;; (= emacs-minor-version 2))
- (require 'wisi-compat-24.2)
-;;)
-
-(defvar wisi-parse-max-parallel 15
- "Maximum number of parallel parsers for acceptable performance.
-If a file needs more than this, it's probably an indication that
-the grammar is excessively redundant.")
-
-(defvar wisi-parse-max-parallel-current (cons 0 0)
- "Cons (count . point); Maximum number of parallel parsers used in most
recent parse,
-point at which that max was spawned.")
-
-(defvar wisi-debug 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, debug-on-error works in
parser
-3 : also show top 10 items of parser stack.")
-
-(cl-defstruct (wisi-parser-state
- (:copier nil))
- label ;; integer identifying parser for debug
-
- active
- ;; 'shift - need new token
- ;; 'reduce - need reduce
- ;; 'accept - parsing completed
- ;; 'error - failed, error not reported yet
- ;; nil - terminated
- ;;
- ;; 'pending-shift, 'pending-reduce - newly created parser; see wisi-parse
-
- stack
- ;; Each stack item takes two slots: (token-symbol token-text (token-start .
token-end)), state
- ;; token-text is nil for nonterminals.
- ;; this is _not_ the same as the wisent-parse stack; that leaves out
token-symbol.
-
- sp ;; stack pointer
-
- pending
- ;; list of (action-symbol stack-fragment)
- )
-
-(defun wisi-error-msg (message &rest args)
- (let ((line (line-number-at-pos))
- (col (- (point) (line-beginning-position))))
- (format
- "%s:%d:%d: %s"
- (file-name-nondirectory (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")
-
-(defvar-local wisi-cache-max 0
- "Maximimum position in buffer where wisi-cache text properties are valid.")
-
-(defun wisi-token-text (token)
- "Return buffer text from token range."
- (let ((region (cdr token)))
- (and region
- (buffer-substring-no-properties (car region) (cdr region)))))
-
-(defun wisi-parse (automaton lexer)
- "Parse current buffer from bob using the automaton specified in AUTOMATON.
-
-- AUTOMATON is the parse table generated by `wisi-compile-grammar'.
-
-- LEXER is a function with no argument called by the parser to
- obtain the next token from the current buffer after point, as a
- list (symbol text start . end), where `symbol' is the terminal
- symbol, `text' is the token string, `start . end' is the range
- in the buffer."
-
- (let* ((actions (aref automaton 0))
- (gotos (aref automaton 1))
- (parser-states ;; vector of parallel parser states
- (vector
- (make-wisi-parser-state
- :label 0
- :active 'shift
- :stack (make-vector wisent-parse-max-stack-size nil)
- :sp 0
- :pending nil)))
- (active-parser-count 1)
- active-parser-count-prev
- (active 'shift)
- (token nil)
- some-pending
- )
-
- (goto-char (point-min))
- (aset (wisi-parser-state-stack (aref parser-states 0)) 0 0)
-
- (setq token (funcall lexer))
- (setq wisi-parse-max-parallel-current (cons 0 0))
-
- (while (not (eq active 'accept))
- (setq active-parser-count-prev active-parser-count)
- (setq some-pending nil)
- (dotimes (parser-index (length parser-states))
- (when (eq active (wisi-parser-state-active (aref parser-states
parser-index)))
- (let* ((parser-state (aref parser-states parser-index))
- (result (wisi-parse-1 token parser-state (>
active-parser-count 1) actions gotos)))
- (when result
- ;; spawn a new parser
- (when (= active-parser-count wisi-parse-max-parallel)
- (signal 'wisi-parse-error
- (let ((state (aref (wisi-parser-state-stack
parser-state)
- (wisi-parser-state-sp
parser-state))))
- (wisi-error-msg (concat "too many parallel parsers
required in grammar state %d;"
- " simplify grammar, or
increase `wisi-parse-max-parallel'")
- state))))
-
- (let ((j (wisi-free-parser parser-states)))
- (cond
- ((= j -1)
- ;; Add to parser-states; the new parser won't be executed
- ;; again in this parser-index loop.
- (setq parser-states (vconcat parser-states (vector nil)))
- (setq j (1- (length parser-states))))
- ((< j parser-index)
- ;; The new parser won't be executed again in this
- ;; parser-index loop; nothing to do.
- )
- (t
- ;; Don't let the new parser execute again in this
- ;; parser-index loop.
- (setq some-pending t)
- (setf (wisi-parser-state-active result)
- (cl-case (wisi-parser-state-active result)
- (shift 'pending-shift)
- (reduce 'pending-reduce)
- )))
- )
- (setq active-parser-count (1+ active-parser-count))
- (when (> active-parser-count (car
wisi-parse-max-parallel-current))
- (setq wisi-parse-max-parallel-current (cons
active-parser-count (point))))
- (setf (wisi-parser-state-label result) j)
- (aset parser-states j result))
- (when (> wisi-debug 1)
- (message "spawn parser (%d active)" active-parser-count)))
-
- (when (eq 'error (wisi-parser-state-active parser-state))
- (setq active-parser-count (1- active-parser-count))
- (when (> wisi-debug 1)
- (message "terminate parser (%d active)" active-parser-count))
- (cl-case active-parser-count
- (0
- (cond
- ((= active-parser-count-prev 1)
- ;; We were not in a parallel parse; report the error.
- (let ((state (aref (wisi-parser-state-stack parser-state)
- (wisi-parser-state-sp parser-state))))
- (signal 'wisi-parse-error
- (wisi-error-msg "syntax error in grammar state %d;
unexpected %s, expecting one of %s"
- state
- (wisi-token-text token)
- (mapcar 'car (aref actions
state))))
- ))
- (t
- ;; Report errors from all parsers that failed on this token.
- (let ((msg))
- (dotimes (_ (length parser-states))
- (let* ((parser-state (aref parser-states parser-index))
- (state (aref (wisi-parser-state-stack
parser-state)
- (wisi-parser-state-sp
parser-state))))
- (when (eq 'error (wisi-parser-state-active
parser-state))
- (setq msg
- (concat msg
- (when msg "\n")
- (wisi-error-msg
- "syntax error in grammar state %d;
unexpected %s, expecting one of %s"
- state
- (wisi-token-text token)
- (mapcar 'car (aref actions state)))))
- )))
- (signal 'wisi-parse-error msg)))
- ))
-
- (1
- (setf (wisi-parser-state-active parser-state) nil); Don't save
error for later.
- (let ((parser-state (aref parser-states (wisi-active-parser
parser-states))))
- (wisi-execute-pending (wisi-parser-state-label parser-state)
- (wisi-parser-state-pending
parser-state))
- (setf (wisi-parser-state-pending parser-state) nil)
- ))
- (t
- ;; We were in a parallel parse, and this parser
- ;; failed; mark it inactive, don't save error for
- ;; later.
- (setf (wisi-parser-state-active parser-state) nil)
- )))
- )));; end dotimes
-
- (when some-pending
- ;; Change pending-* parsers to *.
- (dotimes (parser-index (length parser-states))
- (cond
- ((eq (wisi-parser-state-active (aref parser-states parser-index))
'pending-shift)
- (setf (wisi-parser-state-active (aref parser-states parser-index))
'shift))
- ((eq (wisi-parser-state-active (aref parser-states parser-index))
'pending-reduce)
- (setf (wisi-parser-state-active (aref parser-states parser-index))
'reduce))
- )))
-
- (setq active (wisi-parsers-active parser-states active-parser-count))
- (when (eq active 'shift)
- (when (> active-parser-count 1)
- (setq active-parser-count (wisi-parse-elim-identical parser-states
active-parser-count)))
-
- (setq token (funcall lexer)))
- )
- (when (> active-parser-count 1)
- (error "ambiguous parse result"))))
-
-(defun wisi-parsers-active-index (parser-states)
- ;; only called when active-parser-count = 1
- (let ((result nil)
- (i 0))
- (while (and (not result)
- (< i (length parser-states)))
- (when (wisi-parser-state-active (aref parser-states i))
- (setq result i))
- (setq i (1+ i)))
- result))
-
-(defun wisi-parsers-active (parser-states active-count)
- "Return the type of parser cycle to execute.
-PARSER-STATES[*].active is the last action a parser took. If it
-was `shift', that parser used the input token, and should not be
-executed again until another input token is available, after all
-parsers have shifted the current token or terminated.
-
-Returns one of:
-
-`accept' : all PARSER-STATES have active set to nil or `accept' -
-done parsing
-
-`shift' : all PARSER-STATES have active set to nil, `accept', or
-`shift' - get a new token, execute `shift' parsers.
-
-`reduce' : some PARSER-STATES have active set to `reduce' - no new
-token, execute `reduce' parsers."
- (let ((result nil)
- (i 0)
- (shift-count 0)
- (accept-count 0)
- active)
- (while (and (not result)
- (< i (length parser-states)))
- (setq active (wisi-parser-state-active (aref parser-states i)))
- (cond
- ((eq active 'shift) (setq shift-count (1+ shift-count)))
- ((eq active 'reduce) (setq result 'reduce))
- ((eq active 'accept) (setq accept-count (1+ accept-count)))
- )
- (setq i (1+ i)))
-
- (cond
- (result )
- ((= accept-count active-count)
- 'accept)
- ((= (+ shift-count accept-count) active-count)
- 'shift)
- (t
- ;; all parsers in error state; should not get here
- (error "all parsers in error state; programmer error"))
- )))
-
-(defun wisi-free-parser (parser-states)
- "Return index to a non-active parser in PARSER-STATES, -1 if there is none."
- (let ((result nil)
- (i 0))
- (while (and (not result)
- (< i (length parser-states)))
- (when (not (wisi-parser-state-active (aref parser-states i)))
- (setq result i))
- (setq i (1+ i)))
- (if result result -1)))
-
-(defun wisi-active-parser (parser-states)
- "Return index to the first active parser in PARSER-STATES."
- (let ((result nil)
- (i 0))
- (while (and (not result)
- (< i (length parser-states)))
- (when (wisi-parser-state-active (aref parser-states i))
- (setq result i))
- (setq i (1+ i)))
- (unless result
- (error "no active parsers"))
- result))
-
-(defun wisi-parse-elim-identical (parser-states active-parser-count)
- "Check for parsers in PARSER-STATES that have reached identical states
eliminate one.
-Return new ACTIVE-PARSER-COUNT. Assumes all parsers have active
-nil, `shift', or `accept'."
- ;; parser-states passed by reference; active-parser-count by copy
- ;; see test/ada_mode-slices.adb for example
- (dotimes (parser-i (1- (length parser-states)))
- (when (wisi-parser-state-active (aref parser-states parser-i))
- (dotimes (parser-j (- (length parser-states) parser-i 1))
- (when (wisi-parser-state-active (aref parser-states (+ parser-i
parser-j 1)))
- (when (eq (wisi-parser-state-sp (aref parser-states parser-i))
- (wisi-parser-state-sp (aref parser-states (+ parser-i
parser-j 1))))
- (let ((compare t))
- (dotimes (stack-i (wisi-parser-state-sp (aref parser-states
parser-i)))
- (setq
- compare
- (and compare ;; bypass expensive 'arefs' after first stack
item compare fail
- (equal (aref (wisi-parser-state-stack (aref parser-states
parser-i)) stack-i)
- (aref (wisi-parser-state-stack (aref parser-states
(+ parser-i parser-j 1))) stack-i)))))
- (when compare
- ;; parser stacks are identical
- (setq active-parser-count (1- active-parser-count))
- (when (> wisi-debug 1)
- (message "terminate identical parser %d (%d active)"
- (+ parser-i parser-j 1) active-parser-count))
- (setf (wisi-parser-state-active (aref parser-states (+ parser-i
parser-j 1))) nil)
- (when (= active-parser-count 1)
- ;; the actions for the two parsers are not
- ;; identical, but either is good enough for
- ;; indentation and navigation, so we just do the
- ;; actions for the one that is not terminating.
- (let ((parser-state (aref parser-states parser-i)))
- (wisi-execute-pending (wisi-parser-state-label parser-state)
- (wisi-parser-state-pending
parser-state))
- (setf (wisi-parser-state-pending parser-state) nil)
- ))
- ))))
- )))
- active-parser-count)
-
-(defun wisi-parse-max-pos (tokens)
- "Return max position in tokens, or point if tokens nil."
- (let ((result (if tokens 0 (point))))
- (mapc
- (lambda (token)
- (when (cddr token)
- (setq result (max (cddr token) result))))
- tokens)
- result)
- )
-
-(defun wisi-parse-exec-action (func nonterm tokens)
- "Execute action if all tokens past wisi-cache-max."
- ;; We don't execute actions if all tokens are before wisi-cache-max,
- ;; because later actions can update existing caches, and if the
- ;; parse fails that won't happen. It also saves time.
- ;;
- ;; Also skip if no tokens; nothing to do. This can happen when all
- ;; tokens in a grammar statement are optional.
- (if (< 0 (length tokens))
- (if (>= (wisi-parse-max-pos tokens) wisi-cache-max)
-
- (funcall func nonterm tokens)
-
- (when (> wisi-debug 1)
- (message "... action skipped; before wisi-cache-max %d"
wisi-cache-max)))
-
- (when (> wisi-debug 1)
- (message "... action skipped; no tokens"))
- ))
-
-(defun wisi-execute-pending (parser-label pending)
- (when (> wisi-debug 1) (message "%d: pending actions:" parser-label))
- (while pending
- (when (> wisi-debug 1) (message "%s" (car pending)))
-
- (let ((func-args (pop pending)))
- (wisi-parse-exec-action (nth 0 func-args) (nth 1 func-args) (cl-caddr
func-args)))
- ))
-
-(defun wisi-parse-1 (token parser-state pendingp actions gotos)
- "Perform one shift or reduce on PARSER-STATE.
-If PENDINGP, push actions onto PARSER-STATE.pending; otherwise execute them.
-See `wisi-parse' for full details.
-Return nil or new parser (a wisi-parse-state struct)."
- (let* ((state (aref (wisi-parser-state-stack parser-state)
- (wisi-parser-state-sp parser-state)))
- (parse-action (wisent-parse-action (car token) (aref actions state)))
- new-parser-state)
-
- (when (> wisi-debug 1)
- ;; output trace info
- (if (> wisi-debug 2)
- (progn
- ;; put top 10 stack items
- (let* ((count (min 20 (wisi-parser-state-sp parser-state)))
- (msg (make-vector (+ 1 count) nil)))
- (dotimes (i count)
- (aset msg (- count i)
- (aref (wisi-parser-state-stack parser-state) (-
(wisi-parser-state-sp parser-state) i)))
- )
- (message "%d: %s: %d: %s"
- (wisi-parser-state-label parser-state)
- (wisi-parser-state-active parser-state)
- (wisi-parser-state-sp parser-state)
- msg))
- (message " %d: %s: %s" state token parse-action))
- (message "%d: %d: %s: %s" (wisi-parser-state-label parser-state) state
token parse-action)))
-
- (when (and (listp parse-action)
- (not (symbolp (car parse-action))))
- ;; Conflict; spawn a new parser.
- (setq new-parser-state
- (make-wisi-parser-state
- :active nil
- :stack (vconcat (wisi-parser-state-stack parser-state))
- :sp (wisi-parser-state-sp parser-state)
- :pending (wisi-parser-state-pending parser-state)))
-
- (wisi-parse-2 (cadr parse-action) token new-parser-state t gotos)
- (setq pendingp t)
- (setq parse-action (car parse-action))
- );; when
-
- ;; current parser
- (wisi-parse-2 parse-action token parser-state pendingp gotos)
-
- new-parser-state))
-
-(defun wisi-parse-2 (action token parser-state pendingp gotos)
- "Execute parser ACTION (must not be a conflict).
-Return nil."
- (cond
- ((eq action 'accept)
- (setf (wisi-parser-state-active parser-state) 'accept))
-
- ((eq action 'error)
- (setf (wisi-parser-state-active parser-state) 'error))
-
- ((natnump action)
- ;; Shift token and new state (= action) onto stack
- (let ((stack (wisi-parser-state-stack parser-state)); reference
- (sp (wisi-parser-state-sp parser-state))); copy
- (setq sp (+ sp 2))
- (aset stack (1- sp) token)
- (aset stack sp action)
- (setf (wisi-parser-state-sp parser-state) sp))
- (setf (wisi-parser-state-active parser-state) 'shift))
-
- (t
- (wisi-parse-reduce action parser-state pendingp gotos)
- (setf (wisi-parser-state-active parser-state) 'reduce))
- ))
-
-(defun wisi-nonterm-bounds (stack i j)
- "Return a pair (START . END), the buffer region for a nonterminal.
-STACK is the parser stack. I and J are the indices in STACK of
-the first and last tokens of the nonterminal."
- (let ((start (cadr (aref stack i)))
- (end (cddr (aref stack j))))
- (while (and (or (not start) (not end))
- (/= i j))
- (cond
- ((not start)
- ;; item i is an empty production
- (setq start (cadr (aref stack (setq i (+ i 2))))))
-
- ((not end)
- ;; item j is an empty production
- (setq end (cddr (aref stack (setq j (- j 2))))))
-
- (t (setq i j))))
- (and start end (cons start end))))
-
-(defun wisi-parse-reduce (action parser-state pendingp gotos)
- "Reduce PARSER-STATE.stack, and execute or pend ACTION."
- (let* ((stack (wisi-parser-state-stack parser-state)); reference
- (sp (wisi-parser-state-sp parser-state)); copy
- (token-count (nth 2 action))
- (nonterm (nth 0 action))
- (nonterm-region (when (> token-count 0)
- (wisi-nonterm-bounds stack (- sp (* 2 (1-
token-count)) 1) (1- sp))))
- (post-reduce-state (aref stack (- sp (* 2 token-count))))
- (new-state (cdr (assoc nonterm (aref gotos post-reduce-state))))
- (tokens (make-vector token-count nil)))
-
- (when (not new-state)
- (error "no goto for %s %d" nonterm post-reduce-state))
-
- (when (nth 1 action)
- ;; don't need wisi-tokens for a null user action
- (dotimes (i token-count)
- (aset tokens (- token-count i 1) (aref stack (- sp (* 2 i) 1)))))
-
- (setq sp (+ 2 (- sp (* 2 token-count))))
- (aset stack (1- sp) (cons nonterm nonterm-region))
- (aset stack sp new-state)
- (setf (wisi-parser-state-sp parser-state) sp)
-
- (when (nth 1 action)
- ;; nothing to do for a null user action
- (if pendingp
- (if (wisi-parser-state-pending parser-state)
- (setf (wisi-parser-state-pending parser-state)
- (append (wisi-parser-state-pending parser-state)
- (list (list (nth 1 action) nonterm tokens))))
- (setf (wisi-parser-state-pending parser-state)
- (list (list (nth 1 action) nonterm tokens))))
-
- ;; Not pending.
- (wisi-parse-exec-action (nth 1 action) nonterm tokens)
- ))
- ))
-
-(provide 'wisi-parse)
-;;; wisi-parse.el ends here
diff --git a/wisi-process-parse.el b/wisi-process-parse.el
new file mode 100644
index 0000000..cfc98eb
--- /dev/null
+++ b/wisi-process-parse.el
@@ -0,0 +1,691 @@
+;;; wisi-process-parse.el --- interface to external parse program
+;;
+;; Copyright (C) 2014, 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/>.
+
+(require 'cl-lib)
+(require 'wisi-parse-common)
+
+(defconst wisi-process-parse-prompt "^;;> "
+ "Regexp matching executable prompt; indicates previous command is complete.")
+
+(defconst wisi-process-parse-quit-cmd "004quit\n"
+ "Command to external process telling it to quit.")
+
+(defvar wisi-process-parse-debug 0)
+
+;;;;; sessions
+
+;; The executable builds internal parser structures on startup,
+;; then runs a loop, waiting for parse requests.
+;;
+;; We only need one process per language; there is no persistent state
+;; in the process between parses, and processes are too heavy-weight
+;; to have one per buffer. We use a global alist of parser objects to
+;; find the right one for the current buffer.
+
+(cl-defstruct (wisi-process--parser (:include wisi-parser))
+ (label nil) ;; string uniquely identifying parser
+ (exec-file nil) ;; absolute file name of executable
+ (exec-opts nil) ;; list of process start options for executable
+ (token-table nil) ;; vector of token symbols, indexed by integer
+ (face-table nil) ;; vector of face symbols, indexed by integer
+ (busy nil) ;; t while parser is active
+ (process nil) ;; running *_wisi_parse executable
+ (buffer nil) ;; receives output of executable
+ 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.
+ )
+
+(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.
+If label found in ‘wisi-process--alist’, return that.
+Otherwise add PARSER to ‘wisi-process--alist’, return it."
+ (or (cdr (assoc (wisi-process--parser-label parser) wisi-process--alist))
+ (let ((exec-file (locate-file (wisi-process--parser-exec-file parser)
exec-path '("" ".exe"))))
+
+ (unless exec-file
+ (error "%s not found on `exec-path'" (wisi-process--parser-exec-file
parser)))
+
+ (push (cons (wisi-process--parser-label parser) parser)
wisi-process--alist)
+
+ parser
+ )))
+
+(defun wisi-process-parse-set-exec (label exec-file)
+ "Change the EXEC-FILE for parsers with LABEL."
+ (let ((parser (cdr (assoc label wisi-process--alist))))
+ (when parser
+ (wisi-parse-kill parser)
+ (setf (wisi-process--parser-exec-file parser) exec-file))))
+
+(defun wisi-process-parse--require-process (parser)
+ "Start the process for PARSER if not already started."
+ (unless (process-live-p (wisi-process--parser-process parser))
+ (let ((process-connection-type nil) ;; use a pipe, not a pty; avoid
line-by-line reads
+ (process-name (format " *%s_wisi_parse*" (wisi-process--parser-label
parser))))
+
+ (unless (buffer-live-p (wisi-process--parser-buffer parser))
+ ;; User may have killed buffer to kill parser.
+ (setf (wisi-process--parser-buffer parser)
+ (get-buffer-create process-name)))
+
+ (with-current-buffer (wisi-process--parser-buffer parser)
+ (erase-buffer)); delete any previous messages, prompt
+
+ (setf (wisi-process--parser-process parser)
+ (if (fboundp 'make-process)
+ ;; emacs >= 25
+ (make-process
+ :name process-name
+ :buffer (wisi-process--parser-buffer parser)
+ :command (append (list (wisi-process--parser-exec-file parser))
+ (wisi-process--parser-exec-opts parser)))
+ ;; emacs < 25
+ (start-process
+ process-name
+ (wisi-process--parser-buffer parser)
+ (wisi-process--parser-exec-file parser)
+ (wisi-process--parser-exec-opts parser)
+ )))
+
+ (set-process-query-on-exit-flag (wisi-process--parser-process parser)
nil)
+ (setf (wisi-process--parser-busy parser) nil)
+
+ ;; IMPROVEME: check protocol and version numbers
+ (wisi-process-parse--wait parser)
+ )))
+
+(defun wisi-process-parse--wait (parser)
+ "Wait for the current command to complete."
+ (let ((process (wisi-process--parser-process parser))
+ (search-start (point-min))
+ (wait-count 0)
+ (found nil))
+
+ (with-current-buffer (wisi-process--parser-buffer parser)
+ (while (and (process-live-p process)
+ (progn
+ ;; process output is inserted before point, so move back
over it to search it
+ (goto-char search-start)
+ (not (setq found (re-search-forward
wisi-process-parse-prompt (point-max) t)))))
+ (setq search-start (point));; don't search same text again
+ (setq wait-count (1+ wait-count))
+ (when (> wisi-process-parse-debug 0)
+ (message "wisi-process-parse--wait: %d" wait-count))
+ (accept-process-output process 0.1))
+
+ (if found
+ (when (> wisi-process-parse-debug 0)
+ (message "wisi-process-parse--wait: %d" wait-count)
+ (when (> wisi-process-parse-debug 2)
+ (message "'%s'" (buffer-substring-no-properties (point-min)
(point-max)))))
+
+ (wisi-process-parse-show-buffer parser)
+ (error "%s process died" (wisi-process--parser-exec-file parser)))
+ )))
+
+(defun wisi-process-parse-show-buffer (parser)
+ "Show PARSER buffer."
+ (if (buffer-live-p (wisi-process--parser-buffer parser))
+ (pop-to-buffer (wisi-process--parser-buffer parser))
+ (error "wisi-process-parse process not active")))
+
+(defun wisi-process-parse--send-parse (parser line-count)
+ "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"
+ (cl-ecase wisi--parse-action
+ (navigate 0)
+ (face 1)
+ (indent 2))
+ (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
+ line-count
+ (if (> wisi-debug 0) 1 0) ;; debug-mode
+ (1- wisi-debug) ;; trace_parse
+ wisi-trace-mckenzie
+ wisi-trace-action
+ (if wisi-mckenzie-disable 1 0)
+ (if wisi-mckenzie-task-count wisi-mckenzie-task-count -1)
+ (if wisi-mckenzie-cost-limit wisi-mckenzie-cost-limit -1)
+ (if wisi-mckenzie-check-limit wisi-mckenzie-check-limit
-1)
+ (if wisi-mckenzie-enqueue-limit
wisi-mckenzie-enqueue-limit -1)
+ (1- (position-bytes (point-max)))
+ (wisi-parse-format-language-options parser)
+ ))
+ (msg (format "%03d%s" (length cmd) cmd))
+ (process (wisi-process--parser-process parser)))
+ (when (> wisi-process-parse-debug 0)
+ (message msg))
+ (with-current-buffer (wisi-process--parser-buffer parser)
+ (erase-buffer))
+
+ (process-send-string process msg)
+ (process-send-string process (buffer-substring-no-properties (point-min)
(point-max)))
+
+ ;; We don’t wait for the send to complete; the external process
+ ;; may start parsing and send an error message.
+ ))
+
+(defun wisi-process-parse--send-noop (parser)
+ "Send a noop command to PARSER external process, followed by
+the content of the current buffer. Does not wait for command to
+complete."
+ (let* ((cmd (format "noop %d" (1- (position-bytes (point-max)))))
+ (msg (format "%03d%s" (length cmd) cmd))
+ (process (wisi-process--parser-process parser)))
+ (when (> wisi-process-parse-debug 0)
+ (message msg))
+ (with-current-buffer (wisi-process--parser-buffer parser)
+ (erase-buffer))
+
+ (process-send-string process msg)
+ (process-send-string process (buffer-substring-no-properties (point-min)
(point-max)))
+ ))
+
+(defun wisi-process-parse--marker-or-nil (item)
+ (if (= -1 item) nil (copy-marker item t)))
+
+(defun wisi-process-parse--Navigate_Cache (parser sexp)
+ ;; sexp is [Navigate_Cache pos statement_id id length class containing_pos
prev_pos next_pos end_pos]
+ ;; see ‘wisi-process-parse--execute’
+ (let ((pos (aref sexp 1)))
+ (with-silent-modifications
+ (put-text-property
+ pos
+ (1+ pos)
+ 'wisi-cache
+ (wisi-cache-create
+ :nonterm (aref (wisi-process--parser-token-table parser) (aref sexp
2))
+ :token (aref (wisi-process--parser-token-table parser) (aref sexp
3))
+ :last (aref sexp 4)
+ :class (aref wisi-class-list (aref sexp 5))
+ :containing (wisi-process-parse--marker-or-nil (aref sexp 6))
+ :prev (wisi-process-parse--marker-or-nil (aref sexp 7))
+ :next (wisi-process-parse--marker-or-nil (aref sexp 8))
+ :end (wisi-process-parse--marker-or-nil (aref sexp 9))
+ )))
+ ))
+
+(defun wisi-process-parse--Face_Property (parser sexp)
+ ;; sexp is [Face_Property first-pos last-pos face-index]
+ ;; see ‘wisi-process-parse--execute’
+ ;; implements wisi--face-action-1
+ (with-silent-modifications
+ (add-text-properties
+ (aref sexp 1)
+ (1+ (aref sexp 2))
+ (list 'font-lock-face (aref (wisi-process--parser-face-table parser)
(aref sexp 3))
+ 'fontified t)
+ )))
+
+(defun wisi-process-parse--Indent (parser sexp)
+ ;; sexp is [Indent line-number indent]
+ ;; 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)))
+ ))
+
+(defun wisi-process-parse--Lexer_Error (parser sexp)
+ ;; sexp is [Lexer_Error char-position <message> <repair-char>]
+ ;; see ‘wisi-process-parse--execute’
+ (let ((pos (aref sexp 1))
+ err)
+
+ (goto-char pos);; for current-column
+
+ (setq err
+ (make-wisi--lexer-error
+ :pos (copy-marker pos)
+ :message
+ (format "%s:%d:%d: %s"
+ (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
+ ;; file-name can be nil during vc-resolve-conflict
+ (line-number-at-pos pos)
+ (current-column)
+ (aref sexp 2))
+ :inserted (when (= 4 (length sexp)) (aref sexp 3))))
+
+ (push err (wisi-parser-lexer-errors parser))
+ ))
+
+(defun wisi-process-parse--Parser_Error (parser sexp)
+ ;; sexp is [Parser_Error char-position <string>]
+ ;; see ‘wisi-process-parse--execute’
+ (let ((pos (aref sexp 1))
+ err)
+
+ (goto-char pos);; for current-column
+
+ (setq err
+ (make-wisi--parse-error
+ :pos (copy-marker pos)
+ :message
+ (format "%s:%d:%d: %s"
+ (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
+ ;; file-name can be nil during vc-resolve-conflict
+ (line-number-at-pos pos)
+ (1+ (current-column))
+ (aref sexp 2))))
+
+ (push err (wisi-parser-parse-errors parser))
+ ))
+
+(defun wisi-process-parse--Check_Error (parser sexp)
+ ;; sexp is [Check_Error code name-1-pos name-2-pos <string>]
+ ;; see ‘wisi-process-parse--execute’
+ (let* ((name-1-pos (aref sexp 2))
+ (name-1-col (1+ (progn (goto-char name-1-pos)(current-column)))) ;;
gnat columns are 1 + emacs columns
+ (name-2-pos (aref sexp 3))
+ (name-2-col (1+ (progn (goto-char name-2-pos)(current-column))))
+ (file-name (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) ""))
+ ;; file-name can be nil during vc-resolve-conflict
+ (err (make-wisi--parse-error
+ :pos (copy-marker name-1-pos)
+ :message
+ (format "%s:%d:%d: %s %s:%d:%d"
+ file-name (line-number-at-pos name-1-pos) name-1-col
+ (aref sexp 4)
+ file-name (line-number-at-pos name-2-pos) name-2-col)))
+ )
+
+ (push err (wisi-parser-parse-errors parser))
+ ))
+
+(defun wisi-process-parse--Recover (parser sexp)
+ ;; sexp is [Recover [pos [inserted] [deleted]]...]
+ ;; see ‘wisi-process-parse--execute’
+ ;; convert to list of wisi--parse-error-repair, add to last error
+ (let* ((token-table (wisi-process--parser-token-table parser))
+ (last-error (car (wisi-parser-parse-errors parser))))
+ (unless (= 1 (length sexp))
+ (cl-do ((i 1 (1+ i))) ((= i (length sexp)))
+ (push
+ (make-wisi--parse-error-repair
+ :pos (aref (aref sexp i) 0)
+ :inserted (mapcar (lambda (id) (aref token-table id)) (aref (aref
sexp i) 1))
+ :deleted (mapcar (lambda (id) (aref token-table id)) (aref (aref
sexp i) 2)))
+ (wisi--parse-error-repair last-error)))
+ )))
+
+(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
+ ;;
+ ;; Actions:
+ ;;
+ ;; [Navigate_Cache pos statement_id id length class containing_pos prev_pos
next_pos end_pos]
+ ;; Set a wisi-cache text-property.
+ ;; *pos : integer buffer position; -1 if nil (not set)
+ ;; *id : integer index into parser-token-table
+ ;; length : integer character count
+ ;; class : integer index into wisi-class-list
+ ;;
+ ;; [Face_Property first-pos last-pos face-index]
+ ;; Set a font-lock-face text-property
+ ;; face-index: integer index into parser-elisp-face-table
+ ;;
+ ;; [Indent line-number indent]
+ ;; Set an indent text property
+ ;;
+ ;; [Lexer_Error char-position <message> <repair-char>]
+ ;; The lexer detected an error at char-position.
+ ;;
+ ;; If <repair-char> is not ASCII NUL, it was inserted immediately
+ ;; after char-position to fix the error.
+ ;;
+ ;; [Parser_Error char-position <message>]
+ ;; The parser detected a syntax error; save information for later
+ ;; reporting.
+ ;;
+ ;; If error recovery is successful, there can be more than one
+ ;; error reported during a parse.
+ ;;
+ ;; [Check_Error code name-1-pos name-2-pos <string>]
+ ;; The parser detected a semantic check error; save information
+ ;; for later reporting.
+ ;;
+ ;; If error recovery is successful, there can be more than one
+ ;; error reported during a parse.
+ ;;
+ ;; [Recover [pos [inserted] [deleted]]...]
+ ;; The parser finished a successful error recovery.
+ ;;
+ ;; pos: Buffer position
+ ;;
+ ;; inserted: Virtual tokens (terminal or non-terminal) inserted before
pos.
+ ;;
+ ;; deleted: Tokens deleted after pos.
+ ;;
+ ;; Args are token ids; index into parser-token-table. Save the information
+ ;; for later use by ’wisi-repair-error’.
+ ;;
+ ;;
+ ;; Numeric action codes are given in the case expression below
+
+ (cl-ecase (aref sexp 0)
+ (1 (wisi-process-parse--Navigate_Cache parser sexp))
+ (2 (wisi-process-parse--Face_Property parser sexp))
+ (3 (wisi-process-parse--Indent parser sexp))
+ (4 (wisi-process-parse--Lexer_Error parser sexp))
+ (5 (wisi-process-parse--Parser_Error parser sexp))
+ (6 (wisi-process-parse--Check_Error parser sexp))
+ (7 (wisi-process-parse--Recover 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)
+ (when (process-live-p (wisi-process--parser-process parser))
+ (kill-process (wisi-process--parser-process parser)))
+ )
+ (setf (wisi-process--parser-busy parser) nil))
+
+(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."
+ (wisi-process-parse--require-process parser)
+
+ ;; font-lock can trigger a face parse while navigate or indent parse
+ ;; is active, due to ‘accept-process-output’ below. font-lock must
+ ;; not hang (it is called from an idle timer), so don’t
+ ;; wait. Signaling an error tells font-lock to try again later.
+ ;;
+ ;; If the parser is left busy due to some error, that is a bug. In
+ ;; order to detect such bugs, and avoid weird errors from
+ ;; wisi-indent-region, we signal an error here.
+ (if (wisi-process--parser-busy parser)
+ (progn
+ (setf (wisi-parser-parse-errors parser)
+ (list
+ (make-wisi--parse-error
+ :pos 0
+ :message (format "%s:%d:%d: parser busy (try
’wisi-kill-parser’)"
+ (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "") 1 1))
+ ))
+ (error "%s parse abandoned; parser busy" wisi--parse-action)
+ )
+
+ ;; It is not possible for a background elisp function (ie
+ ;; font-lock) to interrupt this code between checking and setting
+ ;; parser-busy; background elisp can only run when we call
+ ;; accept-process-output below.
+ (setf (wisi-process--parser-busy parser) t)
+
+ (condition-case-unless-debug err
+ (let* ((source-buffer (current-buffer))
+ (response-buffer (wisi-process--parser-buffer parser))
+ (process (wisi-process--parser-process parser))
+ (w32-pipe-read-delay 0) ;; fastest subprocess read
+ response
+ response-end
+ (response-count 0)
+ (sexp-start (point-min))
+ (wait-count 0)
+ (need-more nil) ;; point-max if need more, to check for new input
+ (done nil)
+ start-wait-time)
+
+ (setf (wisi-process--parser-total-wait-time parser) 0.0)
+
+ (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)
+
+ ;; We reset the elisp lexer, because post-parse actions may use it.
+ (when wisi--lexer
+ (wisi-elisp-lexer-reset line-count wisi--lexer))
+ )
+
+ (set-buffer response-buffer)
+
+ ;; process responses until prompt received
+ (while (not done)
+
+ ;; process all complete responses currently in buffer
+ (while (and (not need-more)
+ (not done))
+
+ (goto-char sexp-start)
+
+ (cond
+ ((eobp)
+ (setq need-more (point-max)))
+
+ ((looking-at wisi-process-parse-prompt)
+ (setq done t))
+
+ ((or (looking-at "\\[") ;; encoded action
+ (looking-at "(")) ;; error or other elisp expression to eval
+ (condition-case nil
+ (setq response-end (scan-sexps (point) 1))
+ (error
+ ;; incomplete response
+ (setq need-more (point-max))
+ nil))
+
+ (unless need-more
+ (setq response-count (1+ response-count))
+ (setq response (car (read-from-string
(buffer-substring-no-properties (point) response-end))))
+ (goto-char response-end)
+ (forward-line 1)
+ (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
+ (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)))))
+
+ (set-buffer response-buffer)
+ ))
+
+ (t
+ ;; debug output
+ (forward-line 1)
+ (setq sexp-start (point)))
+ )
+ )
+
+ (unless done
+ ;; end of response buffer
+ (unless (process-live-p process)
+ (wisi-process-parse-show-buffer parser)
+ (error "wisi-process-parse process died"))
+
+ (setq wait-count (1+ wait-count))
+ (setq start-wait-time (float-time))
+
+ ;; If we specify no time-out here, we get messages about
+ ;; "blocking call with quit inhibited", when this is
+ ;; called by font-lock from the display engine.
+ ;;
+ ;; Specifying just-this-one t prevents C-q from
+ ;; interrupting this?
+ (accept-process-output
+ process
+ wisi-process-time-out
+ nil ;; milliseconds
+ nil) ;; just-this-one
+
+ (setf (wisi-process--parser-total-wait-time parser)
+ (+ (wisi-process--parser-total-wait-time parser)
+ (- (float-time) start-wait-time)))
+
+ (when (and (= (point-max) need-more)
+ (> wait-count 5))
+ (error "wisi-process-parse not getting more text (or bad syntax
in process output)"))
+
+ (setq need-more nil))
+ );; while not done
+
+ ;; got command prompt
+ (unless (process-live-p process)
+ (wisi-process-parse-show-buffer parser)
+ (error "wisi-process-parse process died"))
+
+ (setf (wisi-process--parser-response-count parser) response-count)
+
+ (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))
+ )
+
+ (wisi-parse-error
+ (setf (wisi-process--parser-busy parser) nil)
+ (signal (car err) (cdr err)))
+
+ (error
+ (setf (wisi-process--parser-busy parser) nil)
+ (signal (car err) (cdr err))
+ ))))
+
+(defvar wisi--parser nil) ;; wisi.el
+
+(defun wisi-process-send-tokens-noop ()
+ "Run lexer, send tokens to subprocess; otherwise no operation.
+For use with ’wisi-time’."
+ (wisi-process-parse--require-process wisi--parser)
+ (if (wisi-process--parser-busy wisi--parser)
+ (error "%s parser busy" wisi--parse-action)
+
+ ;; not busy
+ (let* ((source-buffer (current-buffer))
+ (action-buffer (wisi-process--parser-buffer wisi--parser))
+ (process (wisi-process--parser-process wisi--parser))
+ (sexp-start (point-min))
+ (need-more nil)
+ (done nil))
+
+ (setf (wisi-process--parser-busy wisi--parser) t)
+ (wisi-process-parse--send-noop wisi--parser)
+
+ (set-buffer action-buffer)
+ (while (and (process-live-p process)
+ (not done))
+ (goto-char sexp-start)
+ (cond
+ ((eobp)
+ (setq need-more t))
+
+ ((looking-at wisi-process-parse-prompt)
+ (setq done t))
+
+ (t
+ (forward-line 1)
+ (setq sexp-start (point)))
+ )
+
+ (unless done
+ ;; end of response buffer
+ (unless (process-live-p process)
+ (wisi-process-parse-show-buffer wisi--parser)
+ (error "wisi-process-parse process died"))
+
+ (accept-process-output process 1.0 nil nil)
+ (setq need-more nil))
+ )
+ (set-buffer source-buffer)
+ (setf (wisi-process--parser-busy wisi--parser) nil)
+ )))
+
+;;;;; debugging
+(defun wisi-process-parse-ids-to-enum (token-table &rest int-ids)
+ "Translate INT-IDS from process integer token ids to elisp enumeral ids.
+Returns reversed sequence."
+ (let ((enum-ids nil))
+ (cl-dolist (i int-ids)
+ (push (aref token-table i) enum-ids))
+ enum-ids))
+
+(provide 'wisi-process-parse)
diff --git a/wisi.adb b/wisi.adb
new file mode 100644
index 0000000..9b184b7
--- /dev/null
+++ b/wisi.adb
@@ -0,0 +1,1891 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Bounded;
+with WisiToken.Semantic_Checks;
+package body Wisi is
+ use WisiToken;
+
+ Navigate_Cache_Code : constant String := "1 ";
+ Face_Property_Code : constant String := "2 ";
+ Indent_Code : constant String := "3 ";
+ Lexer_Error_Code : constant String := "4";
+ Parser_Error_Code : constant String := "5";
+ Check_Error_Code : constant String := "6";
+ Recover_Code : constant String := "7 ";
+
+ Chars_Per_Int : constant Integer := Integer'Width;
+
+ ----------
+ -- body subprogram specs (as needed), alphabetical
+
+ function Indent_Zero_P (Indent : in Indent_Type) return Boolean;
+
+ function Max_Anchor_ID
+ (Data : in out Parse_Data_Type;
+ First_Line : in Line_Number_Type;
+ Last_Line : in Line_Number_Type)
+ return Integer;
+
+ function Paren_In_Anchor_Line
+ (Data : in out Parse_Data_Type'Class;
+ Anchor_Token : in Augmented_Token;
+ Offset : in Integer)
+ return Integer;
+
+ ----------
+ -- body subprograms bodies, alphabetical
+
+ function Image (Anchor_IDs : in Anchor_ID_Vectors.Vector) return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := +"(";
+ begin
+ for I in Anchor_IDs.First_Index .. Anchor_IDs.Last_Index loop
+ Result := Result & Integer'Image (Anchor_IDs (I));
+ if I /= Anchor_IDs.Last_Index then
+ Result := Result & ", ";
+ else
+ Result := Result & ")";
+ end if;
+ end loop;
+ return -Result;
+ end Image;
+
+ function Image (Indent : in Indent_Type) return String
+ is begin
+ case Indent.Label is
+ when Not_Set =>
+ return "(" & Indent_Label'Image (Indent.Label) & ")";
+
+ when Int =>
+ return "(" & Indent_Label'Image (Indent.Label) & Integer'Image
(Indent.Int_Indent) & ")";
+
+ when Anchor =>
+ return "(" & Indent_Label'Image (Indent.Label) & Image
(Indent.Anchor_IDs) & ", " & Integer'Image
+ (Indent.Anchor_Indent) & ")";
+
+ when Anchored =>
+ return "(" & Indent_Label'Image (Indent.Label) & Integer'Image
(Indent.Anchored_ID) & ", " & Integer'Image
+ (Indent.Anchored_Delta) & ")";
+
+ when Anchor_Anchored =>
+ return "(" & Indent_Label'Image (Indent.Label) & Image
(Indent.Anchor_Anchored_IDs) & Integer'Image
+ (Indent.Anchor_Anchored_ID) & ", " & Integer'Image
(Indent.Anchor_Anchored_Delta) & ")";
+ end case;
+ end Image;
+
+ procedure Indent_Apply_Anchored
+ (Delta_Indent : in Anchored_Delta;
+ Indent : in out Indent_Type)
+ is begin
+ -- [2] wisi-elisp-parse--apply-anchored
+
+ case Indent.Label is
+ when Not_Set =>
+ Indent := (Anchored, Delta_Indent.Anchored_ID,
Delta_Indent.Anchored_Delta);
+
+ when Int =>
+ if Indent.Int_Indent = 0 or Delta_Indent.Anchored_Accumulate then
+ Indent := (Anchored, Delta_Indent.Anchored_ID, Indent.Int_Indent +
Delta_Indent.Anchored_Delta);
+ end if;
+
+ when Anchor =>
+ if Delta_Indent.Anchored_Accumulate or Indent.Anchor_Indent = 0 then
+ Indent :=
+ (Anchor_Anchored,
+ Indent.Anchor_IDs,
+ Delta_Indent.Anchored_ID,
+ Delta_Indent.Anchored_Delta + Indent.Anchor_Indent);
+ end if;
+
+ when Anchored | Anchor_Anchored =>
+ -- already anchored
+ null;
+ end case;
+ end Indent_Apply_Anchored;
+
+ procedure Indent_Apply_Int (Indent : in out Indent_Type; Offset : in
Integer)
+ is begin
+ -- [2] wisi-elisp-parse--apply-int
+ case Indent.Label is
+ when Not_Set =>
+ Indent := (Int, Offset);
+
+ when Int =>
+ Indent.Int_Indent := Indent.Int_Indent + Offset;
+
+ when Anchor =>
+ Indent.Anchor_Indent := Indent.Anchor_Indent + Offset;
+
+ when Anchored | Anchor_Anchored =>
+ null;
+ end case;
+ end Indent_Apply_Int;
+
+ procedure Indent_Line
+ (Data : in out Parse_Data_Type;
+ Line : in Line_Number_Type;
+ Delta_Indent : in Delta_Type)
+ is
+ -- See note in Indent_Anchored_2 for why we can't use renames here.
+ Indent : Indent_Type := Data.Indents (Line);
+ begin
+ case Delta_Indent.Label is
+ when Simple =>
+ case Delta_Indent.Simple_Delta.Label is
+ when Int =>
+ Indent_Apply_Int (Indent, Delta_Indent.Simple_Delta.Int_Delta);
+
+ when Anchored =>
+ Indent_Apply_Anchored (Delta_Indent.Simple_Delta, Indent);
+ end case;
+
+ when Hanging =>
+ if Delta_Indent.Hanging_Accumulate or Indent_Zero_P (Data.Indents
(Line)) then
+ if Line = Delta_Indent.Hanging_First_Line then
+ -- Apply delta_1
+ case Delta_Indent.Hanging_Delta_1.Label is
+ when Int =>
+ Indent_Apply_Int (Indent,
Delta_Indent.Hanging_Delta_1.Int_Delta);
+ when Anchored =>
+ Indent_Apply_Anchored (Delta_Indent.Hanging_Delta_1, Indent);
+ end case;
+ else
+ if Delta_Indent.Hanging_Paren_State = Data.Line_Paren_State
(Line) then
+ case Delta_Indent.Hanging_Delta_2.Label is
+ when Int =>
+ Indent_Apply_Int (Indent,
Delta_Indent.Hanging_Delta_2.Int_Delta);
+ when Anchored =>
+ Indent_Apply_Anchored (Delta_Indent.Hanging_Delta_2,
Indent);
+ end case;
+ end if;
+ end if;
+ end if;
+ end case;
+ Data.Indents.Replace_Element (Line, Indent);
+ end Indent_Line;
+
+ function Indent_Zero_P (Indent : in Indent_Type) return Boolean
+ is begin
+ -- wisi-elisp-parse--indent-zero-p
+ case Indent.Label is
+ when Not_Set =>
+ return True;
+
+ when Int =>
+ return Indent.Int_Indent = 0;
+
+ when Anchor =>
+ return Indent.Anchor_Indent = 0;
+
+ when Anchored =>
+ return Indent.Anchored_Delta = 0;
+
+ when Anchor_Anchored =>
+ return Indent.Anchor_Anchored_Delta = 0;
+ end case;
+ end Indent_Zero_P;
+
+ function Max_Anchor_ID
+ (Data : in out Parse_Data_Type;
+ First_Line : in Line_Number_Type;
+ Last_Line : in Line_Number_Type)
+ return Integer
+ is
+ Result : Integer := First_Anchor_ID - 1;
+ begin
+ for Line in First_Line .. Last_Line loop
+ declare
+ Indent : Indent_Type renames Data.Indents (Line);
+ begin
+ case Indent.Label is
+ when Not_Set | Int =>
+ null;
+ when Anchor =>
+ Result := Integer'Max (Result, Indent.Anchor_IDs
(Indent.Anchor_IDs.First_Index));
+ when Anchored =>
+ Result := Integer'Max (Result, Indent.Anchored_ID);
+ when Anchor_Anchored =>
+ Result := Integer'Max (Result, Indent.Anchor_Anchored_ID);
+ end case;
+ end;
+ end loop;
+ return Result;
+ end Max_Anchor_ID;
+
+ function Paren_In_Anchor_Line
+ (Data : in out Parse_Data_Type'Class;
+ Anchor_Token : in Augmented_Token;
+ 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;
+
+ I : Base_Token_Index := Anchor_Token.First_Terminals_Index;
+ Paren_Count : Integer := 0;
+ Paren_Char_Pos : Buffer_Pos := Invalid_Buffer_Pos;
+ Text_Begin_Pos : Buffer_Pos := Invalid_Buffer_Pos;
+ begin
+ -- [1] wisi-elisp-parse--paren-in-anchor-line. That uses elisp
syntax-ppss; here
+ -- we search Terminals.
+ loop
+ declare
+ Tok : Augmented_Token renames Data.Terminals (I);
+ begin
+ if Tok.ID = Left_Paren_ID then
+ Paren_Count := Paren_Count + 1;
+ if Paren_Count = 1 then
+ Paren_Char_Pos := Tok.Char_Region.First;
+ end if;
+
+ elsif Tok.ID = Right_Paren_ID then
+ Paren_Count := Paren_Count - 1;
+
+ end if;
+
+ if Tok.First then
+ Text_Begin_Pos := Tok.Char_Region.First;
+ exit;
+ end if;
+ end;
+ I := I - 1;
+ end loop;
+
+ if Paren_Char_Pos /= Invalid_Buffer_Pos and Text_Begin_Pos /=
Invalid_Buffer_Pos then
+ return 1 + Offset + Integer (Paren_Char_Pos - Text_Begin_Pos);
+ else
+ return Offset;
+ end if;
+ end Paren_In_Anchor_Line;
+
+ procedure Put (Cache : in Navigate_Cache_Type)
+ is
+ package Bounded is new Ada.Strings.Bounded.Generic_Bounded_Length (Max
=> 2 + 11 * Chars_Per_Int);
+ use Bounded;
+
+ Line : Bounded_String := To_Bounded_String ("[");
+
+ procedure Append (Item : in Nil_Buffer_Pos)
+ is begin
+ if Item.Set then
+ Append (Line, Buffer_Pos'Image (Item.Item));
+ else
+ Append (Line, " -1");
+ end if;
+ end Append;
+ 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, Integer'Image (Cache.Length));
+ Append (Line, Integer'Image (Navigate_Class_Type'Pos (Cache.Class)));
+ Append (Cache.Containing_Pos);
+ Append (Cache.Prev_Pos);
+ Append (Cache.Next_Pos);
+ Append (Cache.End_Pos);
+ Append (Line, ']');
+ Ada.Text_IO.Put_Line (To_String (Line));
+ end Put;
+
+ procedure Put (Cache : in Face_Cache_Type)
+ is
+ package Bounded is new Ada.Strings.Bounded.Generic_Bounded_Length (Max
=> 2 + 4 * Chars_Per_Int);
+ use Bounded;
+
+ Line : Bounded_String := To_Bounded_String ("[");
+ begin
+ if Cache.Face.Set then
+ Append (Line, Face_Property_Code);
+ Append (Line, Buffer_Pos'Image (Cache.Region.First));
+ Append (Line, Buffer_Pos'Image (Cache.Region.Last));
+ Append (Line, Integer'Image (Cache.Face.Item));
+ Append (Line, ']');
+ Ada.Text_IO.Put_Line (To_String (Line));
+ end if;
+ end Put;
+
+ procedure Put (Line_Number : in Line_Number_Type; Item : in Indent_Type)
+ is begin
+ -- All Anchors must be resolved at this point, but not all lines have
+ -- an indent computed. A negative indent is an error in either the
+ -- 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]");
+
+ when Int =>
+ declare
+ -- We can easily get negative indents when there are syntax
errors.
+ Ind : constant Integer := Integer'Max (0, Item.Int_Indent);
+ begin
+ Ada.Text_IO.Put_Line
+ ('[' & Indent_Code & Trimmed_Image (Integer (Line_Number)) &
Integer'Image (Ind) & ']');
+ end;
+
+ when Anchor | Anchored | Anchor_Anchored =>
+ raise SAL.Programmer_Error with "Indent item has non-int label: " &
Indent_Label'Image (Item.Label);
+ end case;
+ end Put;
+
+ procedure Put
+ (Item : in Parse.LR.Configuration;
+ Terminals : in Augmented_Token_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ use Ada.Containers;
+ use Ada.Strings.Unbounded;
+ use WisiToken.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));
+ end if;
+
+ Append (Line, Recover_Code);
+ if Item.Ops.Length = 0 then
+ Append (Line, "]");
+
+ else
+ for I in Item.Ops.First_Index .. Item.Ops.Last_Index loop
+ declare
+ Op : Config_Op renames Item.Ops (I);
+ begin
+ case Op.Op is
+ when Fast_Forward =>
+ if Last_Op.Op in Insert then
+ Append (Line, "][]]");
+ elsif Last_Op.Op in Delete then
+ Append (Line, "]]");
+ end if;
+
+ Last_Op := Op;
+
+ when Undo_Reduce | Push_Back =>
+ null;
+
+ when Insert =>
+ if Last_Op.Op = Fast_Forward then
+ Append (Line, "[");
+ Append (Line, Buffer_Pos'Image (Terminals
(Op.Token_Index).Char_Region.First));
+ Append (Line, "[");
+
+ elsif Last_Op.Op = Delete then
+ Append (Line, "]][");
+ Append (Line, Buffer_Pos'Image (Terminals
(Op.Token_Index).Char_Region.First));
+ Append (Line, "[");
+
+ else
+ -- Last_Op.Op = Insert
+ null;
+ end if;
+ Append (Line, Token_ID'Image (Op.ID));
+
+ Last_Op := Op;
+
+ when Delete =>
+ declare
+ Skip : Boolean := False;
+ begin
+ if Last_Op.Op = Fast_Forward then
+ Append (Line, "[");
+ Append (Line, Buffer_Pos'Image (Terminals
(Op.Token_Index).Char_Region.First));
+ Append (Line, "[][");
+
+ elsif Last_Op.Op = Insert then
+ Append (Line, "][");
+
+ elsif Last_Op.Op = Delete then
+ if Descriptor.Embedded_Quote_Escape_Doubled and then
+ ((Last_Op.ID = Descriptor.String_1_ID and Op.ID =
Descriptor.String_1_ID) or
+ (Last_Op.ID = Descriptor.String_2_ID and Op.ID =
Descriptor.String_2_ID))
+ then
+ declare
+ Tok_1 : Augmented_Token renames Terminals
(Last_Op.Token_Index);
+ Tok_2 : Augmented_Token renames Terminals
(Op.Token_Index);
+ begin
+ if Tok_1.Char_Region.Last + 1 =
Tok_2.Char_Region.First then
+ -- Buffer text was '"""', lexer repair
changed it to '""""'. The
+ -- repaired text looks like a single string
with an embedded quote.
+ -- But here, it is two STRING_LITERAL
tokens. Don't send the second
+ -- delete to elisp. See
test/ada_mode-recover_string_quote_1.adb
+ Skip := True;
+ end if;
+ end;
+ end if;
+
+ end if;
+
+ if not Skip then
+ Append (Line, Token_ID'Image (Op.ID));
+ end if;
+ end;
+ Last_Op := Op;
+ end case;
+ end;
+ end loop;
+
+ case Last_Op.Op is
+ when Fast_Forward =>
+ Append (Line, "]");
+
+ when Undo_Reduce | Push_Back =>
+ null;
+
+ when Insert =>
+ Append (Line, "][]]]");
+ when Delete =>
+ Append (Line, "]]]");
+ end case;
+ end if;
+ Ada.Text_IO.Put_Line (To_String (Line));
+ end Put;
+
+ procedure Resolve_Anchors (Data : in out Parse_Data_Type)
+ is
+ Anchor_Indent : array (First_Anchor_ID .. Data.Max_Anchor_ID) of Integer;
+ begin
+ if Trace_Action > Outline then
+ Ada.Text_IO.New_Line;
+ 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;
+
+ 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 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 if;
+ end Resolve_Anchors;
+
+ procedure Set_End
+ (Data : in out Parse_Data_Type;
+ Containing_Pos : in Buffer_Pos;
+ End_Pos : in Buffer_Pos)
+ is
+ use Navigate_Cursor_Lists;
+ I : Cursor := Data.End_Positions.First;
+ Delete_Cache : Boolean;
+ Temp : Cursor;
+ begin
+ loop
+ exit when not Has_Element (I);
+ declare
+ Cache : Navigate_Cache_Type renames Data.Navigate_Caches (Element
(I));
+ begin
+ if Cache.Pos in Containing_Pos .. End_Pos then
+ Cache.End_Pos := (True, End_Pos);
+ Delete_Cache := True;
+ else
+ Delete_Cache := False;
+ end if;
+ end;
+ if Delete_Cache then
+ Temp := Next (I);
+ Delete (Data.End_Positions, I);
+
+ I := Temp;
+ else
+ Next (I);
+ end if;
+
+ end loop;
+ end Set_End;
+
+ ----------
+ -- public subprograms (declaration order)
+
+ procedure Initialize
+ (Data : in out Parse_Data_Type;
+ Descriptor : access constant WisiToken.Descriptor;
+ Source_File_Name : in String;
+ Post_Parse_Action : in Post_Parse_Action_Type;
+ Line_Count : in Line_Number_Type;
+ Params : in String)
+ is
+ pragma Unreferenced (Params);
+ begin
+ -- + 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.Descriptor := Descriptor;
+ Data.Source_File_Name := +Source_File_Name;
+ Data.Post_Parse_Action := Post_Parse_Action;
+
+ case Post_Parse_Action is
+ when Navigate | Face =>
+ null;
+ when Indent =>
+ Data.Indents.Set_Length (Ada.Containers.Count_Type (Line_Count));
+ end case;
+
+ Data.Reset;
+ end Initialize;
+
+ overriding procedure Reset (Data : in out Parse_Data_Type)
+ is begin
+ Data.Terminals.Clear;
+ Data.Leading_Non_Grammar.Clear;
+ -- Data.Line_Begin_Pos set in Initialize, overwritten in
Lexer_To_Augmented
+ -- Data.Line_Begin_Token ""
+
+ for S of Data.Line_Paren_State loop
+ S := 0;
+ end loop;
+ Data.Current_Paren_State := 0;
+
+ Data.Navigate_Caches.Finalize;
+ Data.Navigate_Caches.Initialize;
+ Data.End_Positions.Clear;
+
+ Data.Face_Caches.Finalize;
+ Data.Face_Caches.Initialize;
+
+ for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop
+ Data.Indents.Replace_Element (I, (Label => Not_Set));
+ end loop;
+ Data.Max_Anchor_ID := First_Anchor_ID - 1;
+ end Reset;
+
+ function Source_File_Name (Data : in Parse_Data_Type) return String
+ is begin
+ return -Data.Source_File_Name;
+ end Source_File_Name;
+
+ function Post_Parse_Action (Data : in Parse_Data_Type) return
Post_Parse_Action_Type
+ is begin
+ return Data.Post_Parse_Action;
+ end Post_Parse_Action;
+
+ overriding
+ procedure Lexer_To_Augmented
+ (Data : in out Parse_Data_Type;
+ Token : in Base_Token;
+ Lexer : not null access WisiToken.Lexer.Instance'Class)
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Lexer.First then
+ Data.Line_Begin_Pos (Token.Line) := Token.Char_Region.First;
+ end if;
+
+ if Token.ID < Data.Descriptor.First_Terminal then
+ -- Non-grammar token
+
+ if Token.ID = Data.Descriptor.New_Line_ID then
+ Data.Line_Paren_State (Token.Line + 1) := Data.Current_Paren_State;
+ end if;
+
+ if Data.Terminals.Length = 0 then
+ Data.Leading_Non_Grammar.Append (Token);
+ else
+ declare
+ Containing_Token : Augmented_Token renames Data.Terminals
(Data.Terminals.Last_Index);
+
+ Trailing_Blank : constant Boolean :=
+ Token.ID = Data.Descriptor.New_Line_ID and
+ (Containing_Token.Non_Grammar.Length > 0 and then
+ Containing_Token.Non_Grammar
+ (Containing_Token.Non_Grammar.Last_Index).ID =
Data.Descriptor.New_Line_ID);
+ begin
+ if Lexer.First and (Token.ID = Data.Descriptor.Comment_ID or
Trailing_Blank) then
+ 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));
+ end;
+ end if;
+
+ else
+ -- grammar token
+ declare
+ Temp : constant Augmented_Token :=
+ (Token.ID,
+ Byte_Region => Token.Byte_Region,
+ Line => Token.Line,
+ Column => Token.Column,
+ Char_Region => Token.Char_Region,
+ Deleted => False,
+ First => Lexer.First,
+ Paren_State => Data.Current_Paren_State,
+ First_Terminals_Index => Data.Terminals.Last_Index + 1,
+ Last_Terminals_Index => Data.Terminals.Last_Index + 1,
+ First_Indent_Line => (if Lexer.First then Token.Line
else Invalid_Line_Number),
+ Last_Indent_Line => (if Lexer.First then Token.Line
else Invalid_Line_Number),
+ First_Trailing_Comment_Line => Invalid_Line_Number, -- Set by
Reduce
+ Last_Trailing_Comment_Line => Invalid_Line_Number,
+ Non_Grammar => <>);
+ begin
+ if Token.ID = Data.Descriptor.Left_Paren_ID then
+ Data.Current_Paren_State := Data.Current_Paren_State + 1;
+
+ elsif Token.ID = Data.Descriptor.Right_Paren_ID then
+ Data.Current_Paren_State := Data.Current_Paren_State - 1;
+ end if;
+
+ Data.Terminals.Append (Temp);
+ end;
+ end if;
+ end Lexer_To_Augmented;
+
+ overriding
+ procedure Delete_Token
+ (Data : in out Parse_Data_Type;
+ 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;
+ begin
+ pragma Assert (Deleted_Token.Deleted = False);
+ Deleted_Token.Deleted := True;
+ if Deleted_Token.Non_Grammar.Length = 0 then
+ return;
+ end if;
+
+ loop
+ if Prev_Token_Index = Base_Token_Index'First then
+ return;
+ end if;
+ exit when Data.Terminals (Prev_Token_Index).Deleted = False;
+ Prev_Token_Index := Prev_Token_Index - 1;
+ 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;
+ else
+ Prev_Token.First_Trailing_Comment_Line :=
Deleted_Token.First_Trailing_Comment_Line;
+ end if;
+ end if;
+ Prev_Token.Last_Trailing_Comment_Line :=
Deleted_Token.Last_Trailing_Comment_Line;
+ end if;
+ end;
+ end Delete_Token;
+
+ overriding
+ procedure Reduce
+ (Data : in out Parse_Data_Type;
+ Tree : in out Syntax_Trees.Tree'Class;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array)
+ is
+ Aug_Nonterm : constant Augmented_Token_Access := new Augmented_Token'
+ (ID => Tree.ID (Nonterm),
+ Byte_Region => Tree.Byte_Region (Nonterm),
+ others => <>);
+
+ Trailing_Comment_Done : Boolean := False;
+ begin
+ Tree.Set_Augmented (Nonterm, Base_Token_Class_Access (Aug_Nonterm));
+
+ for I in reverse Tokens'Range loop
+ -- 'reverse' to find token containing trailing comments; last
+ -- non-virtual and non-empty token.
+ if Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region then
+ -- Token not entirely virtual
+ declare
+ Aug_Token : constant Aug_Token_Ref := Get_Aug_Token (Data,
Tree, Tokens (I));
+ begin
+
+ if Data.Post_Parse_Action = Indent then
+ if Aug_Token.First_Terminals_Index /=
Augmented_Token_Arrays.No_Index then
+ Aug_Nonterm.First_Terminals_Index :=
Aug_Token.First_Terminals_Index;
+ end if;
+
+ if Aug_Nonterm.Last_Terminals_Index =
Augmented_Token_Arrays.No_Index then
+ Aug_Nonterm.Last_Terminals_Index :=
Aug_Token.Last_Terminals_Index;
+ end if;
+
+ 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_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;
+ end if;
+
+ if not Trailing_Comment_Done then
+ Aug_Nonterm.First_Trailing_Comment_Line :=
Aug_Token.First_Trailing_Comment_Line;
+ Aug_Nonterm.Last_Trailing_Comment_Line :=
Aug_Token.Last_Trailing_Comment_Line;
+ Trailing_Comment_Done := True;
+ end if;
+
+ end if; -- Compute_Indent
+
+ if Aug_Token.Line /= Invalid_Line_Number then
+ Aug_Nonterm.Line := Aug_Token.Line;
+ Aug_Nonterm.Column := Aug_Token.Column;
+ end if;
+
+ if Aug_Nonterm.Char_Region.First > Aug_Token.Char_Region.First
then
+ Aug_Nonterm.Char_Region.First := Aug_Token.Char_Region.First;
+ end if;
+
+ if Aug_Nonterm.Char_Region.Last < Aug_Token.Char_Region.Last
then
+ Aug_Nonterm.Char_Region.Last := Aug_Token.Char_Region.Last;
+ end if;
+
+ Aug_Nonterm.Paren_State := Aug_Token.Paren_State;
+ end;
+ end if; -- Aug_Token not virtual
+ end loop;
+ end Reduce;
+
+ procedure Statement_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Statement_Param_Array)
+ is
+ First_Item : Boolean := True;
+ Override_Start_Set : Boolean := False;
+ Override_Start : Navigate_Class_Type;
+ Containing_Pos : Nil_Buffer_Pos := Nil; -- wisi first-keyword-pos
+ begin
+ for Pair of Params loop
+ if Tree.Byte_Region (Tokens (Pair.Index)) /= Null_Buffer_Region then
+ declare
+ Token : constant Aug_Token_Ref := Get_Aug_Token (Data,
Tree, Tokens (Pair.Index));
+ Cursor : Navigate_Cache_Trees.Cursor :=
Navigate_Cache_Trees.Find
+ (Data.Navigate_Caches.Iterate, Token.Char_Region.First,
+ Direction => Navigate_Cache_Trees.Unknown);
+ begin
+ if Navigate_Cache_Trees.Has_Element (Cursor) then
+ declare
+ Cache : Navigate_Cache_Type renames Data.Navigate_Caches
(Cursor);
+ begin
+ Cache.Class := (if Override_Start_Set then
Override_Start else Pair.Class);
+ Cache.Statement_ID := Tree.ID (Nonterm);
+ Cache.Containing_Pos := Containing_Pos;
+ end;
+ else
+ Cursor := Data.Navigate_Caches.Insert
+ ((Pos => Token.Char_Region.First,
+ Statement_ID => Tree.ID (Nonterm),
+ ID => Token.ID,
+ Length => Length (Token.Char_Region),
+ Class => (if Override_Start_Set then
Override_Start else Pair.Class),
+ Containing_Pos => Containing_Pos,
+ others => Nil));
+ end if;
+
+ Data.End_Positions.Append (Cursor);
+
+ if First_Item then
+ First_Item := False;
+ if Override_Start_Set or Pair.Class = Statement_Start then
+ Override_Start_Set := False;
+ Containing_Pos := (True, Token.Char_Region.First);
+ end if;
+ end if;
+
+ if Pair.Class = Statement_End and Containing_Pos.Set then
+ Set_End (Data, Containing_Pos.Item, Token.Char_Region.First);
+ end if;
+ end;
+
+ else
+ -- Token.Byte_Region is null
+ if First_Item and Pair.Class = Statement_Start then
+ -- We don't reset First_Item here; next token may also be a
start, if
+ -- this one is empty.
+ Override_Start_Set := True;
+ Override_Start := Pair.Class;
+ end if;
+ end if;
+ end loop;
+ end Statement_Action;
+
+ procedure Containing_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ Containing : in Positive_Index_Type;
+ Contained : in Positive_Index_Type)
+ is
+ use all type WisiToken.Syntax_Trees.Node_Label;
+ pragma Unreferenced (Nonterm);
+
+ -- [2] wisi-containing-action.
+ --
+ -- Compute as much as possible with virtual tokens; see
+ -- test/format_paramlist.adb
+ begin
+ if Tree.Label (Tokens (Containing)) = Syntax_Trees.Virtual_Terminal or
+ Tree.Label (Tokens (Contained)) = Syntax_Trees.Virtual_Terminal
+ then
+ return;
+ end if;
+
+ declare
+ use Navigate_Cache_Trees;
+ Containing_Tok : constant Aug_Token_Ref := Get_Aug_Token (Data,
Tree, Tokens (Containing));
+ Containing_Region : Buffer_Region renames Containing_Tok.Char_Region;
+ Contained_Tok : constant Aug_Token_Ref := Get_Aug_Token (Data,
Tree, Tokens (Contained));
+ Contained_Region : Buffer_Region renames Contained_Tok.Char_Region;
+ Iterator : constant Navigate_Cache_Trees.Iterator :=
Data.Navigate_Caches.Iterate;
+ Cursor : Navigate_Cache_Trees.Cursor;
+ Mark : constant Buffer_Pos :=
Containing_Region.First;
+ begin
+ if Containing_Region = Null_Buffer_Region then
+ if Tree.Is_Virtual (Tokens (Containing)) then
+ return;
+ else
+ raise Fatal_Error with Error_Message
+ (File_Name => -Data.Source_File_Name,
+ Line => Containing_Tok.Line,
+ Column => Containing_Tok.Column,
+ Message => "wisi-containing-action: containing-region " &
+ Image (Containing_Tok.ID, Data.Descriptor.all) &
+ " is empty. grammar error; bad action.");
+ end if;
+ end if;
+
+ if not Data.Navigate_Caches.Present (Containing_Region.First) then
+ raise Fatal_Error with Error_Message
+ (File_Name => -Data.Source_File_Name,
+ Line => Containing_Tok.Line,
+ Column => Containing_Tok.Column,
+ Message => "wisi-containing-action: containing token " &
+ Image (Containing_Tok.ID, Data.Descriptor.all) &
+ " has no cache. grammar error; missing action.");
+ end if;
+
+ if Contained_Tok.Char_Region /= Null_Buffer_Region then
+ -- Contained region is nil in an empty production.
+ Cursor := Previous (Iterator, Contained_Tok.Char_Region.Last);
+
+ while Has_Element (Cursor) loop
+ declare
+ Cache : Navigate_Cache_Type renames Variable_Ref
(Data.Navigate_Caches, Cursor).Element.all;
+ begin
+
+ exit when Cache.Pos < Contained_Region.First or
+ (Containing_Region.First = Contained_Region.First and
+ Cache.Pos <= Contained_Region.First);
+
+ -- Skip blocks that are already marked.
+
+ if Cache.Containing_Pos.Set then
+ Cursor := Find (Iterator, Cache.Containing_Pos.Item,
Direction => Descending);
+ else
+ Cache.Containing_Pos := (True, Mark);
+ Cursor := Previous (Iterator, Cursor);
+ end if;
+
+ end;
+ end loop;
+ end if;
+ end;
+ end Containing_Action;
+
+ function "+" (Item : in WisiToken.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
+ 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
+ is begin
+ return Result : Token_ID_Lists.List do
+ Result.Append (Left);
+ Result.Append (Right);
+ end return;
+ end "&";
+
+ procedure Motion_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Motion_Param_Array)
+ is
+ pragma Unreferenced (Nonterm);
+
+ -- [2] wisi-motion-action
+ use Navigate_Cache_Trees;
+ use all type Ada.Containers.Count_Type;
+
+ Start : Nil_Buffer_Pos := (Set => False);
+ Prev_Keyword_Mark : Nil_Buffer_Pos := (Set => False);
+ Iter : constant Iterator := Data.Navigate_Caches.Iterate;
+ Prev_Cache_Cur : Cursor;
+ Cache_Cur : Cursor;
+ Point : Buffer_Pos;
+
+ function Match (IDs : in Token_ID_Lists.List) return Boolean
+ is
+ Cache : Navigate_Cache_Type renames Constant_Ref
(Data.Navigate_Caches, Cache_Cur).Element.all;
+ begin
+ -- [2] wisi-elisp-parse--match-token
+ if (Start.Set and then Point = Start.Item) or else
+ Cache.Containing_Pos = Start
+ then
+ for ID of IDs loop
+ if ID = Cache.ID then
+ return True;
+ end if;
+ end loop;
+ end if;
+ return False;
+ end Match;
+
+ begin
+ for Param of Params loop
+ if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then
+ declare
+ Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tokens (Param.Index));
+ Region : constant Buffer_Region := Token.Char_Region;
+ begin
+ if not Start.Set then
+ Start := (True, Region.First);
+ end if;
+
+ Cache_Cur := Find (Iter, Region.First, Direction => Ascending);
+ if not Has_Element (Cache_Cur) then
+ if Tree.Is_Virtual (Tokens (Param.Index)) then
+ return;
+ else
+ raise Fatal_Error with Error_Message
+ (File_Name => -Data.Source_File_Name,
+ Line => Token.Line,
+ Column => Token.Column,
+ Message => "wisi-motion-action: token " &
+ Token.Image (Data.Descriptor.all) &
+ " has no cache; add to statement-action.");
+ end if;
+ end if;
+
+ if Param.IDs.Length = 0 then
+ if Prev_Keyword_Mark.Set then
+ Variable_Ref (Data.Navigate_Caches,
Cache_Cur).Element.Prev_Pos := Prev_Keyword_Mark;
+ Variable_Ref (Data.Navigate_Caches,
Prev_Cache_Cur).Element.Next_Pos := (True, Region.First);
+ end if;
+
+ Prev_Keyword_Mark := (True, Region.First);
+ Prev_Cache_Cur := Cache_Cur;
+
+ else
+ Point := Region.First;
+ loop
+ exit when Point >= Region.Last;
+ if Match (Param.IDs) then
+ if Prev_Keyword_Mark.Set then
+ if not Constant_Ref (Data.Navigate_Caches,
Cache_Cur).Element.Prev_Pos.Set and
+ not Constant_Ref (Data.Navigate_Caches,
Prev_Cache_Cur).Element.Next_Pos.Set
+ then
+ Variable_Ref (Data.Navigate_Caches,
Cache_Cur).Element.Prev_Pos := Prev_Keyword_Mark;
+ Variable_Ref (Data.Navigate_Caches,
Prev_Cache_Cur).Element.Next_Pos := (True, Point);
+ Prev_Keyword_Mark := (True, Point);
+ Prev_Cache_Cur := Cache_Cur;
+ end if;
+ else
+ Prev_Keyword_Mark := (True, Point);
+ Prev_Cache_Cur := Cache_Cur;
+ end if;
+ end if;
+
+ Cache_Cur := Next (Iter, Cache_Cur);
+ exit when Cache_Cur = No_Element;
+
+ Point := Constant_Ref (Data.Navigate_Caches,
Cache_Cur).Element.Pos;
+ end loop;
+ end if;
+ end;
+ end if;
+ end loop;
+ end Motion_Action;
+
+ procedure Face_Apply_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Face_Apply_Param_Array)
+ is
+ pragma Unreferenced (Nonterm);
+
+ -- [2] wisi-face-apply-action
+ use Face_Cache_Trees;
+
+ Iter : constant Iterator := Data.Face_Caches.Iterate;
+ Cache_Cur : Cursor;
+ Suffix_Cur : Cursor;
+ begin
+ for Param of Params loop
+ if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then
+ declare
+ Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tokens (Param.Index));
+ begin
+ Cache_Cur := Find (Iter, Token.Char_Region.First, Direction =>
Ascending);
+ if Has_Element (Cache_Cur) then
+ declare
+ Cache : Face_Cache_Type renames Variable_Ref
(Data.Face_Caches, Cache_Cur).Element.all;
+ begin
+ case Cache.Class is
+ when Prefix =>
+ Cache.Face := (True, Param.Prefix_Face);
+
+ -- Check for suffix
+ Suffix_Cur := Next (Iter, Cache_Cur);
+ if Has_Element (Suffix_Cur) then
+ declare
+ Suf_Cache : Face_Cache_Type renames Variable_Ref
+ (Data.Face_Caches, Suffix_Cur).Element.all;
+ begin
+ if Suffix = Suf_Cache.Class and
+ Inside (Suf_Cache.Region.First,
Token.Char_Region)
+ then
+ Suf_Cache.Face := (True, Param.Suffix_Face);
+ end if;
+ end;
+ end if;
+
+ when Suffix =>
+ Cache.Face := (True, Param.Suffix_Face);
+ end case;
+ end;
+ else
+ Data.Face_Caches.Insert ((Token.Char_Region, Suffix, (True,
Param.Suffix_Face)));
+ end if;
+ end;
+ end if;
+ end loop;
+ end Face_Apply_Action;
+
+ procedure Face_Apply_List_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Face_Apply_Param_Array)
+ is
+ pragma Unreferenced (Nonterm);
+
+ -- [2] wisi-face-apply-list-action
+ use Face_Cache_Trees;
+
+ Iter : constant Iterator := Data.Face_Caches.Iterate;
+ Cache_Cur : Cursor;
+ begin
+ for Param of Params loop
+ if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then
+ declare
+ Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tokens (Param.Index));
+ begin
+ Cache_Cur := Find_In_Range (Iter, Ascending,
Token.Char_Region.First, Token.Char_Region.Last);
+ loop
+ exit when not Has_Element (Cache_Cur) or else
+ Constant_Ref (Data.Face_Caches,
Cache_Cur).Element.Region.First > Token.Char_Region.Last;
+ declare
+ Cache : Face_Cache_Type renames Variable_Ref
(Data.Face_Caches, Cache_Cur).Element.all;
+ begin
+ case Cache.Class is
+ when Prefix =>
+ Cache.Face := (True, Param.Prefix_Face);
+
+ when Suffix =>
+ Cache.Face := (True, Param.Suffix_Face);
+ end case;
+ end;
+ Cache_Cur := Next (Iter, Cache_Cur);
+ end loop;
+ end;
+ end if;
+ end loop;
+ end Face_Apply_List_Action;
+
+ procedure Face_Mark_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Face_Mark_Param_Array)
+ is
+ pragma Unreferenced (Nonterm);
+
+ -- [2] wisi-face-apply-action
+ use Face_Cache_Trees;
+
+ Iter : constant Iterator := Data.Face_Caches.Iterate;
+ Cache_Cur : Cursor;
+ begin
+ for Param of Params loop
+ if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then
+ declare
+ Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tokens (Param.Index));
+ begin
+ Cache_Cur := Find (Iter, Token.Char_Region.First, Direction =>
Ascending);
+ if Has_Element (Cache_Cur) then
+ declare
+ Cache : Face_Cache_Type renames Variable_Ref
(Data.Face_Caches, Cache_Cur).Element.all;
+ Other_Cur : Cursor := Find_In_Range
+ (Iter, Ascending, Cache.Region.Last + 1,
Token.Char_Region.Last);
+ Temp : Cursor;
+ begin
+ loop
+ exit when not Has_Element (Other_Cur) or else
+ Constant_Ref (Data.Face_Caches,
Other_Cur).Element.Region.First > Token.Char_Region.Last;
+ Temp := Other_Cur;
+ Other_Cur := Next (Iter, Other_Cur);
+ Delete (Data.Face_Caches, Temp);
+ end loop;
+
+ Cache.Class := Param.Class;
+ Cache.Region.Last := Token.Char_Region.Last;
+ end;
+ else
+ Data.Face_Caches.Insert ((Token.Char_Region, Param.Class,
(Set => False)));
+ end if;
+ end;
+ end if;
+ end loop;
+ end Face_Mark_Action;
+
+ procedure Face_Remove_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Face_Remove_Param_Array)
+ is
+ pragma Unreferenced (Nonterm);
+
+ -- [2] wisi-face-remove-action
+ use Face_Cache_Trees;
+
+ Iter : constant Iterator := Data.Face_Caches.Iterate;
+ Cache_Cur : Cursor;
+ Temp : Cursor;
+ begin
+ for I of Params loop
+ if Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region then
+ declare
+ Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tokens (I));
+ begin
+ Cache_Cur := Find_In_Range (Iter, Ascending,
Token.Char_Region.First, Token.Char_Region.Last);
+ loop
+ exit when not Has_Element (Cache_Cur) or else
+ Constant_Ref (Data.Face_Caches,
Cache_Cur).Element.Region.First > Token.Char_Region.Last;
+ Temp := Cache_Cur;
+ Cache_Cur := Next (Iter, Cache_Cur);
+ Delete (Data.Face_Caches, Temp);
+ end loop;
+ end;
+ end if;
+ end loop;
+ end Face_Remove_Action;
+
+ function "+" (Item : in Integer) return Indent_Arg_Arrays.Vector
+ is begin
+ return Result : Indent_Arg_Arrays.Vector do
+ Result.Append (Item);
+ end return;
+ end "+";
+
+ function "&" (List : in Indent_Arg_Arrays.Vector; Item : in Integer) return
Indent_Arg_Arrays.Vector
+ is begin
+ return Result : Indent_Arg_Arrays.Vector := List do
+ Result.Append (Item);
+ end return;
+ end "&";
+
+ function "&" (Left, Right : in Integer) return Indent_Arg_Arrays.Vector
+ is begin
+ return Result : Indent_Arg_Arrays.Vector do
+ Result.Append (Left);
+ Result.Append (Right);
+ end return;
+ end "&";
+
+ function Image (Item : in Simple_Indent_Param) return String
+ is begin
+ 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) & "," &
+ Integer'Image (Item.Anchored_Delta),
+ when Language => "<language_function>") & ")";
+ end Image;
+
+ function Image (Item : in Indent_Param) return String
+ is begin
+ return "(" & Indent_Param_Label'Image (Item.Label) & ", " &
+ (case Item.Label is
+ when Simple => Image (Item.Param),
+ when Hanging_Label =>
+ Image (Item.Hanging_Delta_1) & ", " & Image
(Item.Hanging_Delta_2) & ")");
+ end Image;
+
+ function Image (Item : in Indent_Pair) return String
+ is begin
+ return "(" & Image (Item.Code_Delta) &
+ (if Item.Comment_Present
+ then ", " & Image (Item.Comment_Delta)
+ else "") & ")";
+ end Image;
+
+ procedure Indent_Action_0
+ (Data : in out Parse_Data_Type'Class;
+ Tree : in Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ 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));
+ 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 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);
+ Pair : Indent_Pair renames Params (I);
+ Code_Delta : Delta_Type;
+ Comment_Param : Indent_Param;
+ 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));
+ 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;
+ end if;
+
+ if Token.First_Trailing_Comment_Line /= Invalid_Line_Number then
+ if Pair.Comment_Present then
+ Comment_Param := Pair.Comment_Delta;
+ Comment_Param_Set := True;
+
+ 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;
+ end if;
+ end if;
+ end;
+ end if;
+ end loop;
+ end Indent_Action_0;
+
+ procedure Indent_Action_1
+ (Data : in out Parse_Data_Type'Class;
+ Tree : in Syntax_Trees.Tree;
+ Nonterm : in Syntax_Trees.Valid_Node_Index;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ N : in Positive_Index_Type;
+ Params : in Indent_Param_Array)
+ is
+ use all type WisiToken.Syntax_Trees.Node_Label;
+ begin
+ -- [2] wisi-indent-action*
+ for I in Tokens'First .. N loop
+ if Tree.Label (Tokens (I)) /= Virtual_Terminal and then
+ Get_Aug_Token (Data, Tree, Tokens (I)).First
+ then
+ Indent_Action_0 (Data, Tree, Nonterm, Tokens, Params);
+ return;
+ end if;
+ end loop;
+ end Indent_Action_1;
+
+ function Indent_Hanging_1
+ (Data : in out Parse_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ Tree_Indenting : in Syntax_Trees.Valid_Node_Index;
+ Indenting_Comment : in Boolean;
+ Delta_1 : in Simple_Indent_Param;
+ Delta_2 : in Simple_Indent_Param;
+ Option : in Boolean;
+ Accumulate : in Boolean)
+ return Delta_Type
+ is
+ Indenting_Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tree_Indenting);
+ begin
+ -- [2] wisi-elisp-parse--hanging-1
+ if Indenting_Comment then
+ return Indent_Compute_Delta
+ (Data, Tree, Tokens, (Simple, Delta_1), Tree_Indenting,
Indenting_Comment);
+ else
+ return
+ (Hanging,
+ Hanging_First_Line => Indenting_Token.Line,
+ Hanging_Paren_State => Indenting_Token.Paren_State,
+ Hanging_Delta_1 => Indent_Compute_Delta
+ (Data, Tree, Tokens, (Simple, Delta_1), Tree_Indenting,
Indenting_Comment).Simple_Delta,
+ Hanging_Delta_2 =>
+ (if (not Option) or
+ Indenting_Token.Line = Indenting_Token.First_Indent_Line --
first token in tok is first on line
+ then Indent_Compute_Delta
+ (Data, Tree, Tokens, (Simple, Delta_2), Tree_Indenting,
Indenting_Comment).Simple_Delta
+ else Indent_Compute_Delta
+ (Data, Tree, Tokens, (Simple, Delta_1), Tree_Indenting,
Indenting_Comment).Simple_Delta),
+ Hanging_Accumulate => Accumulate);
+ end if;
+ end Indent_Hanging_1;
+
+ procedure Put (Data : in out Parse_Data_Type)
+ is begin
+ case Data.Post_Parse_Action is
+ when Navigate =>
+ for Cache of Data.Navigate_Caches loop
+ Put (Cache);
+ end loop;
+
+ when Face =>
+ for Cache of Data.Face_Caches loop
+ Put (Cache);
+ 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
+ Put (I, Data.Indents (I));
+ end loop;
+ end case;
+ end Put;
+
+ procedure Put
+ (Data : in Parse_Data_Type;
+ Lexer_Errors : in Lexer.Error_Lists.List;
+ Parse_Errors : in Parse.LR.Parse_Error_Lists.List;
+ Tree : in Syntax_Trees.Tree)
+ is
+ use all type SAL.Base_Peek_Type;
+ use Ada.Text_IO;
+ use Semantic_Checks;
+
+ function Safe_Pos (Node : in Syntax_Trees.Valid_Node_Index) return
Buffer_Pos
+ is
+ -- Return a reasonable position for the error at Node.
+ --
+ -- In a successful parse with error recovery, Node is a terminal with
+ -- an augmented token in Data.Terminals, so that is the first
+ -- choice.
+ --
+ -- If this is an error due to a bad recovery, Node may be a virtual
+ -- token, with no position information, so we try to get information
+ -- from its parent.
+ use Syntax_Trees;
+
+ N : Node_Index := Node;
+ begin
+ loop
+ if Tree.Label (N) /= Virtual_Terminal then
+ declare
+ Ref : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
N);
+ begin
+ if Ref.Char_Region /= Null_Buffer_Region then
+ return Ref.Element.Char_Region.First;
+ end if;
+
+ end;
+ end if;
+ N := Tree.Parent (N);
+ exit when N = Invalid_Node_Index;
+ end loop;
+ return Buffer_Pos'First;
+ end Safe_Pos;
+
+ function Safe_Pos (Token : in Recover_Token) return Buffer_Pos
+ is begin
+ if Token.Name /= Null_Buffer_Region then
+ return Token.Name.First;
+
+ elsif Token.Byte_Region = Null_Buffer_Region then
+ return Buffer_Pos'First;
+
+ else
+ return Token.Byte_Region.First;
+ end if;
+ 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;
+
+ for Item of Parse_Errors loop
+ -- We don't include parser id here; not very useful.
+ case Item.Label is
+ when Parse.LR.Action =>
+ Put_Line
+ ('[' & Parser_Error_Code & Buffer_Pos'Image (Safe_Pos
(Item.Error_Token)) &
+ " ""syntax error: expecting " & Image (Item.Expecting,
Data.Descriptor.all) &
+ ", found '" & Image (Tree.ID (Item.Error_Token),
Data.Descriptor.all) & "'""]");
+
+ when Parse.LR.Check =>
+ Put_Line
+ ('[' & Check_Error_Code & Integer'Image
+ (Semantic_Checks.Check_Status_Label'Pos
(Item.Check_Status.Label)) &
+ (case Item.Check_Status.Label is
+ when Ok => "",
+ when Error =>
+ Buffer_Pos'Image (Safe_Pos
(Item.Check_Status.Begin_Name)) &
+ Buffer_Pos'Image (Safe_Pos (Item.Check_Status.End_Name)) &
+ " ""block name error""]"));
+
+ when Parse.LR.Message =>
+ Put_Line
+ ('[' & Parser_Error_Code & Buffer_Pos'Image (Buffer_Pos'First) &
+ " """ & (-Item.Msg) & """]");
+ end case;
+
+ if Item.Recover.Stack.Depth > 0 then
+ Put (Item.Recover, Data.Terminals, Data.Descriptor.all);
+ end if;
+ end loop;
+ end Put;
+
+ procedure Put_Error (Data : in Parse_Data_Type; Line_Number : in
Line_Number_Type; Message : in String)
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("(error """ & Error_Message (-Data.Source_File_Name,
Line_Number, 0, Message) & """)");
+ end Put_Error;
+
+ ----------
+ -- Spec visible private subprograms, alphabetical
+
+ function Image (Item : in Simple_Delta_Type) return String
+ is begin
+ return "(" & Simple_Delta_Labels'Image (Item.Label) &
+ (case Item.Label is
+ when Int => Integer'Image (Item.Int_Delta),
+ when Anchored => Integer'Image (Item.Anchored_ID) & Integer'Image
(Item.Anchored_Delta) & " " &
+ Boolean'Image (Item.Anchored_Accumulate) & ")");
+ end Image;
+
+ function Image (Item : in Delta_Type) return String
+ is begin
+ return "(" & Delta_Labels'Image (Item.Label) &
+ (case Item.Label is
+ when Simple => " " & Image (Item.Simple_Delta),
+ when Hanging => Line_Number_Type'Image (Item.Hanging_First_Line) &
Integer'Image (Item.Hanging_Paren_State) &
+ " " & Image (Item.Hanging_Delta_1) & " " & Image
(Item.Hanging_Delta_2) & " " &
+ Boolean'Image (Item.Hanging_Accumulate)) & ")";
+ end Image;
+
+ function Current_Indent_Offset
+ (Data : in Parse_Data_Type;
+ Anchor_Token : in Augmented_Token'Class;
+ Offset : in Integer)
+ return Integer
+ is begin
+ return Offset + Integer (Anchor_Token.Char_Region.First -
Data.Line_Begin_Pos (Anchor_Token.Line));
+ end Current_Indent_Offset;
+
+ function Find
+ (Data : in Parse_Data_Type;
+ ID : in Token_ID;
+ Token : in Augmented_Token'Class)
+ return Base_Token_Index
+ is begin
+ -- linear search for ID.
+ for I in Token.First_Terminals_Index .. Token.Last_Terminals_Index loop
+ if Data.Terminals (I).ID = ID then
+ return I;
+ end if;
+ end loop;
+ return Augmented_Token_Arrays.No_Index;
+ end Find;
+
+ function First_Line
+ (Token : in Augmented_Token;
+ Indenting_Comment : in Boolean)
+ return Line_Number_Type
+ is begin
+ return
+ (if Indenting_Comment then
+ (if Token.First_Trailing_Comment_Line = Invalid_Line_Number
+ then Token.Line
+ else Token.First_Trailing_Comment_Line)
+ else
+ (if Token.First_Indent_Line = Invalid_Line_Number
+ then Token.Line
+ else Token.First_Indent_Line));
+ end First_Line;
+
+ function Get_Aug_Token
+ (Data : in Parse_Data_Type'Class;
+ Tree : in Syntax_Trees.Tree'Class;
+ Tree_Index : in Syntax_Trees.Valid_Node_Index)
+ return Aug_Token_Ref
+ is
+ use all type Syntax_Trees.Node_Label;
+ begin
+ return
+ (case Tree.Label (Tree_Index) is
+ when Shared_Terminal => Data.Terminals.Variable_Ref (Tree.Terminal
(Tree_Index)),
+ when Virtual_Terminal => raise SAL.Programmer_Error with
"wisi_runtime.get_aug_token virtual terminal",
+ when Nonterm => (Element => Augmented_Token_Access (Tree.Augmented
(Tree_Index))));
+ end Get_Aug_Token;
+
+ overriding
+ function Image
+ (Item : in Augmented_Token;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is
+ ID_Image : constant String := WisiToken.Image (Item.ID, Descriptor);
+ begin
+ if Item.Line /= Invalid_Line_Number and Trace_Action <= Detail then
+ return "(" & ID_Image &
+ Line_Number_Type'Image (Item.Line) & ":" & Trimmed_Image (Integer
(Item.Column)) & ")";
+
+ elsif Item.Char_Region = Null_Buffer_Region then
+ return "(" & ID_Image & ")";
+
+ else
+ return "(" & ID_Image & ", " & Image (Item.Char_Region) & ")";
+ end if;
+ end Image;
+
+ function Image
+ (Item : in Augmented_Token_Access_Array;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is
+ use all type SAL.Base_Peek_Type;
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := +"(";
+ begin
+ for I in Item'Range loop
+ Result := Result & Image (Item (I).all, Descriptor);
+ if I /= Item'Last then
+ Result := Result & ", ";
+ end if;
+ end loop;
+ Result := Result & ")";
+ return -Result;
+ end Image;
+
+ function Indent_Anchored_2
+ (Data : in out Parse_Data_Type;
+ Anchor_Line : in Line_Number_Type;
+ Last_Line : in Line_Number_Type;
+ Offset : in Integer;
+ Accumulate : in Boolean)
+ return Delta_Type
+ is
+ use Anchor_ID_Vectors;
+ -- We can't use a Reference here, because the Element in reference
+ -- types is constrained (as are all allocated objects of access
+ -- types; AARM 4.8 (6/3)), and we may need to change the Label.
+ Indent : Indent_Type := Data.Indents (Anchor_Line);
+ Anchor_ID : constant Integer := 1 + Max_Anchor_ID (Data, Anchor_Line,
Last_Line);
+ begin
+ -- [2] wisi-elisp-parse--anchored-2
+ Data.Max_Anchor_ID := Integer'Max (Data.Max_Anchor_ID, Anchor_ID);
+
+ case Indent.Label is
+ when Not_Set =>
+ Indent := (Anchor, To_Vector (Anchor_ID, 1), 0);
+
+ when Int =>
+ Indent := (Anchor, To_Vector (Anchor_ID, 1), Indent.Int_Indent);
+
+ when Anchor =>
+ Indent.Anchor_IDs := Anchor_ID & Indent.Anchor_IDs;
+
+ when Anchored =>
+ Indent := (Anchor_Anchored, To_Vector (Anchor_ID, 1),
Indent.Anchored_ID, Indent.Anchored_Delta);
+
+ when Anchor_Anchored =>
+ Indent.Anchor_Anchored_IDs := Anchor_ID & Indent.Anchor_Anchored_IDs;
+ end case;
+
+ Data.Indents.Replace_Element (Anchor_Line, Indent);
+
+ return (Simple, (Anchored, Anchor_ID, Offset, Accumulate));
+ end Indent_Anchored_2;
+
+ function Indent_Compute_Delta
+ (Data : in out Parse_Data_Type'Class;
+ Tree : in Syntax_Trees.Tree;
+ Tokens : in Syntax_Trees.Valid_Node_Index_Array;
+ Param : in Indent_Param;
+ Tree_Indenting : in Syntax_Trees.Valid_Node_Index;
+ Indenting_Comment : in Boolean)
+ return Delta_Type
+ is
+ Indenting_Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tree_Indenting);
+ begin
+ -- [2] wisi-elisp-parse--indent-compute-delta, which evals
wisi-anchored*, wisi-hanging*.
+ case Param.Label is
+ when Simple =>
+ case Param.Param.Label is
+ when Int =>
+ return (Simple, (Int, Param.Param.Int_Delta));
+
+ when Anchored_Label =>
+ if Indenting_Token.Byte_Region = Null_Buffer_Region or
+ Tree.Byte_Region (Tokens (Param.Param.Anchored_Index)) =
Null_Buffer_Region
+ then
+ -- One of these is an entirely virtual token
+ return Null_Delta;
+ else
+ declare
+ Anchor_Token : constant Aug_Token_Ref := Get_Aug_Token
+ (Data, Tree, Tokens (Param.Param.Anchored_Index));
+ begin
+ case Anchored_Label'(Param.Param.Label) is
+ when Anchored_0 =>
+ -- [2] wisi-anchored, wisi-anchored-1
+ return Indent_Anchored_2
+ (Data,
+ Anchor_Line => Anchor_Token.Line,
+ Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
+ Offset => Current_Indent_Offset (Data,
Anchor_Token, Param.Param.Anchored_Delta),
+ Accumulate => True);
+
+ when Anchored_1 =>
+ -- [2] wisi-anchored%
+ return Indent_Anchored_2
+ (Data,
+ Anchor_Line => Anchor_Token.Line,
+ Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
+ Offset => Paren_In_Anchor_Line (Data,
Anchor_Token, Param.Param.Anchored_Delta),
+ Accumulate => True);
+
+ when Anchored_2 =>
+ -- [2] wisi-anchored%-
+ return Indent_Anchored_2
+ (Data,
+ Anchor_Line => Anchor_Token.Line,
+ Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
+ Offset => Paren_In_Anchor_Line (Data,
Anchor_Token, Param.Param.Anchored_Delta),
+ Accumulate => False);
+
+ when Anchored_3 =>
+ -- [2] wisi-anchored*
+ if Indenting_Token.First then
+ return Indent_Anchored_2
+ (Data,
+ Anchor_Line => Anchor_Token.Line,
+ Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
+ Offset => Current_Indent_Offset (Data,
Anchor_Token, Param.Param.Anchored_Delta),
+ Accumulate => True);
+
+ else
+ return Null_Delta;
+ end if;
+
+ when Anchored_4 =>
+ -- [2] wisi-anchored*-
+ return Indent_Anchored_2
+ (Data,
+ Anchor_Line => Anchor_Token.Line,
+ Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
+ Offset => Current_Indent_Offset (Data,
Anchor_Token, Param.Param.Anchored_Delta),
+ Accumulate => False);
+
+ end case;
+ end;
+ end if;
+
+ when Language =>
+ return Param.Param.Function_Ptr
+ (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Param.Args);
+ end case;
+
+ when Hanging_Label =>
+ case Hanging_Label'(Param.Label) is
+ when Hanging_0 => -- wisi-hanging
+ return Indent_Hanging_1
+ (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
+ Param.Hanging_Delta_2,
+ Option => False, Accumulate => True);
+ when Hanging_1 => -- wisi-hanging%
+ return Indent_Hanging_1
+ (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
+ Param.Hanging_Delta_2,
+ Option => True, Accumulate => True);
+ when Hanging_2 => -- wisi-hanging%-
+ return Indent_Hanging_1
+ (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
+ Param.Hanging_Delta_2,
+ Option => True, Accumulate => False);
+ end case;
+ end case;
+ end Indent_Compute_Delta;
+
+ procedure Indent_Token_1
+ (Data : in out Parse_Data_Type;
+ Indenting_Token : in Augmented_Token'Class;
+ Delta_Indent : in Delta_Type;
+ Indenting_Comment : in Boolean)
+ is
+ First_Line : constant Line_Number_Type := Indenting_Token.First_Line
(Indenting_Comment);
+ Last_Line : constant Line_Number_Type := Indenting_Token.Last_Line
(Indenting_Comment);
+ begin
+ if Trace_Action > Detail then
+ Ada.Text_IO.Put_Line
+ ("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;
+
+ for Line in First_Line .. Last_Line loop
+ if Data.Indent_Comment_Col_0 then
+ declare
+ use all type Ada.Text_IO.Count;
+ Indent : Boolean := True;
+ begin
+ if Data.Line_Begin_Token.all (Line) /=
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
+ then
+ Indent := False;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Indent then
+ Indent_Line (Data, Line, Delta_Indent);
+ end if;
+ end;
+ else
+ Indent_Line (Data, Line, Delta_Indent);
+ end if;
+ end loop;
+ end Indent_Token_1;
+
+ function Last_Line
+ (Token : in Augmented_Token;
+ Indenting_Comment : in Boolean)
+ return Line_Number_Type
+ is begin
+ return
+ (if Indenting_Comment then
+ (if Token.Last_Trailing_Comment_Line = Invalid_Line_Number
+ then Token.Line
+ else Token.Last_Trailing_Comment_Line)
+ else
+ (if Token.Last_Indent_Line = Invalid_Line_Number
+ then Token.Line
+ else Token.Last_Indent_Line));
+ end Last_Line;
+
+end Wisi;
diff --git a/wisi.ads b/wisi.ads
new file mode 100644
index 0000000..cfc61e1
--- /dev/null
+++ b/wisi.ads
@@ -0,0 +1,666 @@
+-- Abstract :
+--
+-- Ada implementation of wisi parser actions.
+--
+-- References
+--
+-- [1] wisi.el - defines parse action functions.
+--
+-- [2] wisi-elisp-parse.el - defines parse action functions.
+--
+-- [3] wisi-process-parse.el - defines elisp/process API
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+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;
+with WisiToken.Parse.LR;
+with WisiToken.Lexer;
+with WisiToken.Syntax_Trees;
+package Wisi is
+ use all type WisiToken.Base_Buffer_Pos;
+
+ type Post_Parse_Action_Type is (Navigate, Face, Indent);
+
+ type Parse_Data_Type
+ (Line_Begin_Token : not null access constant
WisiToken.Line_Begin_Token_Vectors.Vector)
+ is new WisiToken.Syntax_Trees.User_Data_Type with private;
+
+ procedure Initialize
+ (Data : in out Parse_Data_Type;
+ 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;
+ 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.
+
+ overriding procedure Reset (Data : in out Parse_Data_Type);
+ -- Reset for a new parse, with data from previous Initialize.
+
+ function Source_File_Name (Data : in Parse_Data_Type) return String;
+ function Post_Parse_Action (Data : in Parse_Data_Type) return
Post_Parse_Action_Type;
+
+ overriding
+ procedure Lexer_To_Augmented
+ (Data : in out Parse_Data_Type;
+ Token : in WisiToken.Base_Token;
+ Lexer : not null access WisiToken.Lexer.Instance'Class);
+
+ overriding
+ procedure Delete_Token
+ (Data : in out Parse_Data_Type;
+ Token_Index : in WisiToken.Token_Index);
+
+ overriding
+ procedure Reduce
+ (Data : in out Parse_Data_Type;
+ Tree : in out WisiToken.Syntax_Trees.Tree'Class;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+
+ type Navigate_Class_Type is (Motion, Name, Statement_End,
Statement_Override, Statement_Start, Misc);
+ -- Matches [1] wisi-class-list.
+
+ type Index_Navigate_Class is record
+ Index : WisiToken.Positive_Index_Type; -- into Tokens
+ Class : Navigate_Class_Type;
+ end record;
+
+ type Statement_Param_Array is array (Natural range <>) of
Index_Navigate_Class;
+
+ procedure Statement_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Statement_Param_Array);
+
+ procedure Containing_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Containing : in WisiToken.Positive_Index_Type;
+ Contained : in WisiToken.Positive_Index_Type);
+
+ package Token_ID_Lists is new Ada.Containers.Doubly_Linked_Lists
(WisiToken.Token_ID, WisiToken."=");
+
+ Empty_IDs : constant Token_ID_Lists.List := Token_ID_Lists.Empty_List;
+
+ function "+" (Item : in WisiToken.Token_ID) return Token_ID_Lists.List;
+ function "&" (List : in Token_ID_Lists.List; Item : in WisiToken.Token_ID)
return Token_ID_Lists.List;
+ function "&" (Left, Right : in WisiToken.Token_ID) return
Token_ID_Lists.List;
+
+ type Index_IDs is record
+ Index : WisiToken.Positive_Index_Type; -- into Tokens
+ IDs : Token_ID_Lists.List;
+ end record;
+
+ package Index_IDs_Vectors is new Ada.Containers.Vectors
(Ada.Containers.Count_Type, Index_IDs);
+
+ subtype Motion_Param_Array is Index_IDs_Vectors.Vector;
+
+ procedure Motion_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Motion_Param_Array);
+ -- Implements [2] wisi-motion-action.
+
+ type Index_Faces is record
+ Index : WisiToken.Positive_Index_Type; -- into Tokens
+ Prefix_Face : Integer; -- into grammar.Face_List
+ Suffix_Face : Integer; -- into grammar.Face_List
+ end record;
+
+ type Face_Apply_Param_Array is array (Natural range <>) of Index_Faces;
+
+ procedure Face_Apply_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Face_Apply_Param_Array);
+ -- Implements [2] wisi-face-apply-action.
+
+ procedure Face_Apply_List_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Face_Apply_Param_Array);
+ -- Implements [2] wisi-face-apply-list-action.
+
+ type Face_Class_Type is (Prefix, Suffix);
+ -- Matches wisi-cache-class values set in [1] wisi-face-apply-action.
+
+ type Index_Face_Class is record
+ Index : WisiToken.Positive_Index_Type; -- into Tokens
+ Class : Face_Class_Type;
+ end record;
+
+ type Face_Mark_Param_Array is array (Natural range <>) of Index_Face_Class;
+
+ procedure Face_Mark_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Face_Mark_Param_Array);
+ -- Implements [2] wisi-face-mark-action.
+
+ type Face_Remove_Param_Array is array (Natural range <>) of
WisiToken.Positive_Index_Type;
+
+ procedure Face_Remove_Action
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Face_Remove_Param_Array);
+ -- Implements [2] wisi-face-remove-action.
+
+ ----------
+ -- Indent
+ --
+ -- elisp indent functions are represented by the Indent_Param type,
+ -- not Ada functions. This is to get the execution time right; in
+ -- elisp, the array of parameters to wisi-indent-action is not
+ -- evaluated when wisi-indent-action is called; each parameter is
+ -- evaluated by wisi-elisp-parse--indent-compute-delta.
+
+ type Simple_Indent_Param_Label is -- not hanging
+ (Int,
+ Anchored_0, -- wisi-anchored
+ Anchored_1, -- wisi-anchored%
+ Anchored_2, -- wisi-anchored%-
+ Anchored_3, -- wisi-anchored*
+ Anchored_4, -- wisi-anchored*-
+ Language -- language-specific function
+ );
+ subtype Anchored_Label is Simple_Indent_Param_Label range Anchored_0 ..
Anchored_4;
+
+ -- Arguments to language-specific functions are integers; one of
+ -- delta, Token_Number, or Token_ID - the syntax does not distinguish
+ -- among these three types.
+
+ package Indent_Arg_Arrays is new Ada.Containers.Vectors
(WisiToken.Positive_Index_Type, Integer);
+
+ function "+" (Item : in Integer) return Indent_Arg_Arrays.Vector;
+ function "&" (List : in Indent_Arg_Arrays.Vector; Item : in Integer) return
Indent_Arg_Arrays.Vector;
+ function "&" (Left, Right : in Integer) return Indent_Arg_Arrays.Vector;
+
+ type Delta_Type (<>) is private;
+
+ type Language_Indent_Function is access function
+ (Data : in out Parse_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tree_Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Tree_Indenting : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Indenting_Comment : in Boolean;
+ Args : in Indent_Arg_Arrays.Vector)
+ return Delta_Type;
+
+ Null_Args : Indent_Arg_Arrays.Vector renames Indent_Arg_Arrays.Empty_Vector;
+
+ type Simple_Indent_Param (Label : Simple_Indent_Param_Label := Int) is
+ record
+ case Label is
+ when Int =>
+ Int_Delta : Integer;
+
+ when Anchored_Label =>
+ Anchored_Index : WisiToken.Positive_Index_Type;
+ Anchored_Delta : Integer;
+
+ when Language =>
+ Function_Ptr : Language_Indent_Function;
+ Args : Indent_Arg_Arrays.Vector;
+ end case;
+ end record;
+
+ function Image (Item : in Simple_Indent_Param) return String;
+
+ type Indent_Param_Label is
+ (Simple,
+ Hanging_0, -- wisi-hanging
+ Hanging_1, -- wisi-hanging%
+ Hanging_2 -- wisi-hanging%-
+ );
+ subtype Hanging_Label is Indent_Param_Label range Hanging_0 .. Hanging_2;
+
+ type Indent_Param (Label : Indent_Param_Label := Simple) is
+ record
+ case Label is
+ when Simple =>
+ Param : Simple_Indent_Param;
+
+ when Hanging_Label =>
+ Hanging_Delta_1 : Simple_Indent_Param;
+ Hanging_Delta_2 : Simple_Indent_Param;
+
+ end case;
+ end record;
+
+ function Image (Item : in Indent_Param) return String;
+
+ type Indent_Pair (Comment_Present : Boolean := False) is
+ record
+ Code_Delta : Indent_Param;
+ case Comment_Present is
+ when True =>
+ Comment_Delta : Indent_Param;
+ when False =>
+ null;
+ end case;
+ end record;
+
+ function Image (Item : in Indent_Pair) return String;
+
+ type Indent_Param_Array is array (WisiToken.Positive_Index_Type range <>)
of Indent_Pair;
+
+ procedure Indent_Action_0
+ (Data : in out Parse_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Params : in Indent_Param_Array);
+ -- Implements [2] wisi-indent-action.
+
+ procedure Indent_Action_1
+ (Data : in out Parse_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ N : in WisiToken.Positive_Index_Type;
+ Params : in Indent_Param_Array);
+ -- Implements [2] wisi-indent-action*.
+
+ function Indent_Hanging_1
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Tree_Indenting : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Indenting_Comment : in Boolean;
+ Delta_1 : in Simple_Indent_Param;
+ Delta_2 : in Simple_Indent_Param;
+ Option : in Boolean;
+ Accumulate : in Boolean)
+ return Delta_Type;
+ -- [2] wisi-elisp-parse--hanging-1
+ --
+ -- 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
+ -- Ada.Text_IO.Current_Output, as encoded responses as defined in [3]
+ -- wisi-process-parse--execute.
+
+ procedure Put
+ (Data : in Parse_Data_Type;
+ Lexer_Errors : in WisiToken.Lexer.Error_Lists.List;
+ Parse_Errors : in WisiToken.Parse.LR.Parse_Error_Lists.List;
+ Tree : in WisiToken.Syntax_Trees.Tree);
+ -- Put Lexer_Errors and Parse_Errors to Ada.Text_IO.Current_Output,
+ -- as encoded error responses as defined in [3]
+ -- wisi-process-parse--execute.
+
+ procedure Put_Error (Data : in Parse_Data_Type; Line_Number : in
WisiToken.Line_Number_Type; Message : in String);
+ -- Put an error elisp form to Ada.Text_IO.Standard_Output.
+
+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.
+ end record;
+
+ package Non_Grammar_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
+ (WisiToken.Token_Index, Non_Grammar_Token);
+
+ type Augmented_Token is new WisiToken.Base_Token with record
+ -- Most fields are set by Lexer_To_Augmented at parse time; others
+ -- are set by Reduce for nonterminals.
+
+ Deleted : Boolean := False;
+ -- Set True by Parse_Data_Type.Delete_Token; Non_Grammar tokens are
+ -- moved to the previous non-deleted token.
+
+ -- 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 nonterminal, True if some contained token's First is True,
+ -- including trailing comments and blank lines.
+
+ Paren_State : Integer := 0;
+ -- Parenthesis nesting count, before token.
+
+ First_Terminals_Index : WisiToken.Base_Token_Index :=
WisiToken.Base_Token_Arrays.No_Index;
+ -- For virtual tokens, No_Index.
+ --
+ -- For terminal tokens, index of this token in Parser.Terminals.
+ --
+ -- For nonterminal tokens, index of first contained token in
+ -- Parser.Terminals.
+
+ Last_Terminals_Index : WisiToken.Base_Token_Index :=
WisiToken.Base_Token_Arrays.No_Index;
+ -- For non-virtual nonterminal tokens, index of last contained
+ -- token in Parser.Terminals.
+ --
+ -- For all others, same as First_Terminals_Index.
+
+ First_Indent_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
+ Last_Indent_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
+ -- Lines that need indenting; first token on these lines is contained
+ -- in this token. If First is False, these are Invalid_Line_Number.
+ --
+ -- First_, Last_Indent_Line include blank and comment lines between
+ -- grammar tokens, but exclude trailing blanks and comments after the
+ -- last token, so they can be indented differently.
+
+ First_Trailing_Comment_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
+ Last_Trailing_Comment_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
+ -- Trailing comment or blank lines (after the last contained grammar
+ -- token) that need indenting. Excludes comments following code on a
+ -- line. If there are no such lines, these are Invalid_Line_Number.
+
+ Non_Grammar : Non_Grammar_Token_Arrays.Vector;
+ -- For terminals, non-grammar tokens immediately following. For
+ -- nonterminals, empty.
+
+ end record;
+
+ overriding
+ function Image
+ (Item : in Augmented_Token;
+ Descriptor : in WisiToken.Descriptor)
+ return String;
+ -- Return a string for debug/test messages
+
+ function First_Line
+ (Token : in Augmented_Token;
+ Indenting_Comment : in Boolean)
+ return WisiToken.Line_Number_Type;
+ function Last_Line
+ (Token : in Augmented_Token;
+ Indenting_Comment : in Boolean)
+ return WisiToken.Line_Number_Type;
+ -- Return first and last line in Token's region.
+
+ type Augmented_Token_Access is access all Augmented_Token;
+ procedure Free is new Ada.Unchecked_Deallocation (Augmented_Token,
Augmented_Token_Access);
+
+ type Augmented_Token_Access_Array is array (WisiToken.Positive_Index_Type
range <>) of Augmented_Token_Access;
+ -- 1 indexed to match token numbers in grammar actions.
+
+ function Image
+ (Item : in Augmented_Token_Access_Array;
+ Descriptor : in WisiToken.Descriptor)
+ return String;
+
+ package Augmented_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(WisiToken.Token_Index, Augmented_Token);
+ -- Index matches Base_Token_Arrays.
+
+ package Line_Paren_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
(WisiToken.Line_Number_Type, Integer);
+ package Line_Begin_Pos_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
+ (WisiToken.Line_Number_Type, WisiToken.Buffer_Pos);
+
+ type Nil_Buffer_Pos (Set : Boolean := False) is record
+ case Set is
+ when True =>
+ Item : WisiToken.Buffer_Pos;
+ when False =>
+ null;
+ end case;
+ end record;
+
+ Nil : constant Nil_Buffer_Pos := (Set => False);
+
+ type Navigate_Cache_Type is record
+ Pos : WisiToken.Buffer_Pos; -- implicit in wisi-cache
+ Statement_ID : WisiToken.Token_ID; -- wisi-cache-nonterm
+ ID : WisiToken.Token_ID; -- wisi-cache-token
+ Length : Natural; -- wisi-cache-last
+ Class : Navigate_Class_Type; -- wisi-cache-class; one of
wisi-class-list
+ Containing_Pos : Nil_Buffer_Pos; -- wisi-cache-containing
+ Prev_Pos : Nil_Buffer_Pos; -- wisi-cache-prev
+ Next_Pos : Nil_Buffer_Pos; -- wisi-cache-next
+ End_Pos : Nil_Buffer_Pos; -- wisi-cache-end
+ end record;
+
+ function Key (Cache : in Navigate_Cache_Type) return WisiToken.Buffer_Pos
is (Cache.Pos);
+
+ function Key_Compare (Left, Right : in WisiToken.Buffer_Pos) return
SAL.Compare_Result is
+ (if Left > Right then SAL.Greater
+ elsif Left = Right then SAL.Equal
+ else SAL.Less);
+
+ package Navigate_Cache_Trees is new
SAL.Gen_Unbounded_Definite_Red_Black_Trees
+ (Navigate_Cache_Type, WisiToken.Buffer_Pos);
+
+ type Nil_Integer (Set : Boolean := False) is record
+ case Set is
+ when True =>
+ Item : Integer;
+ when False =>
+ null;
+ end case;
+ end record;
+
+ type Face_Cache_Type is record
+ Region : WisiToken.Buffer_Region;
+ Class : Face_Class_Type; -- wisi-cache-class; one of {'prefix | 'suffix}
+ Face : Nil_Integer; -- not set, or index into *-process-faces-names
+ end record;
+
+ function Key (Cache : in Face_Cache_Type) return WisiToken.Buffer_Pos is
(Cache.Region.First);
+
+ package Face_Cache_Trees is new SAL.Gen_Unbounded_Definite_Red_Black_Trees
(Face_Cache_Type, WisiToken.Buffer_Pos);
+
+ type Indent_Label is (Not_Set, Int, Anchor, Anchored, Anchor_Anchored);
+
+ package Anchor_ID_Vectors is new Ada.Containers.Vectors (Natural, Positive);
+
+ type Indent_Type (Label : Indent_Label := Not_Set) is record
+ -- [2] wisi-elisp-parse--indent elements. Indent values may be
+ -- negative while indents are being computed.
+ case Label is
+ when Not_Set =>
+ null;
+
+ when Int =>
+ Int_Indent : Integer;
+
+ when Anchor =>
+ Anchor_IDs : Anchor_ID_Vectors.Vector; -- Largest ID first.
+ Anchor_Indent : Integer;
+
+ when Anchored =>
+ Anchored_ID : Positive;
+ Anchored_Delta : Integer; -- added to Anchor_Indent of Anchor_ID
+
+ when Anchor_Anchored =>
+ Anchor_Anchored_IDs : Anchor_ID_Vectors.Vector;
+ Anchor_Anchored_ID : Natural;
+ Anchor_Anchored_Delta : Integer;
+ end case;
+ end record;
+ First_Anchor_ID : constant Positive := Positive'First;
+
+ package Indent_Vectors is new Ada.Containers.Vectors
(WisiToken.Line_Number_Type, Indent_Type);
+ package Navigate_Cursor_Lists is new Ada.Containers.Doubly_Linked_Lists
+ (Navigate_Cache_Trees.Cursor, Navigate_Cache_Trees."=");
+
+ type Parse_Data_Type
+ (Line_Begin_Token : not null access constant
WisiToken.Line_Begin_Token_Vectors.Vector)
+ is new WisiToken.Syntax_Trees.User_Data_Type with
+ record
+ -- Data from parsing
+
+ Terminals : Augmented_Token_Arrays.Vector;
+ -- All terminal grammar tokens, in lexical order. Each contains any
+ -- immediately following non-grammar tokens. Does not contain
+ -- nonterminal or virtual tokens.
+
+ Leading_Non_Grammar : WisiToken.Base_Token_Arrays.Vector;
+ -- non-grammar tokens before first grammar token.
+
+ Line_Begin_Pos : Line_Begin_Pos_Vectors.Vector;
+ -- Character position at the start of the first token on each line.
+
+ Line_Paren_State : Line_Paren_Vectors.Vector;
+ -- Parenthesis nesting state at the start of each line; used by
+ -- Indent. Set by Lexer_To_Augmented on New_Line_ID.
+
+ Current_Paren_State : Integer;
+ -- Current parenthesis nesting state; used by Indent. Set by
+ -- Lexer_To_Augmented on Left_Paren_ID, Right_Paren_ID.
+
+ -- Data for post-parse actions
+
+ Descriptor : access constant WisiToken.Descriptor;
+ Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Post_Parse_Action : Post_Parse_Action_Type;
+ Navigate_Caches : Navigate_Cache_Trees.Tree; -- Set by Navigate.
+ End_Positions : Navigate_Cursor_Lists.List; -- Dynamic data for
Navigate.
+ Face_Caches : Face_Cache_Trees.Tree; -- Set by Face.
+ Indents : Indent_Vectors.Vector; -- Set by Indent.
+
+ -- Copied from language-specific parameters
+ Indent_Comment_Col_0 : Boolean := False;
+
+ -- Dynamic data for Indent
+ Max_Anchor_ID : Integer;
+ end record;
+
+ type Simple_Delta_Labels is (Int, Anchored);
+
+ type Simple_Delta_Type (Label : Simple_Delta_Labels := Int) is
+ record
+ case Label is
+ when Int =>
+ Int_Delta : Integer;
+
+ when Anchored =>
+ Anchored_ID : Natural;
+ Anchored_Delta : Integer;
+ Anchored_Accumulate : Boolean;
+
+ end case;
+ end record;
+ subtype Anchored_Delta is Simple_Delta_Type (Anchored);
+
+ function Image (Item : in Simple_Delta_Type) return String;
+ -- For debugging
+
+ type Delta_Labels is (Simple, Hanging);
+
+ type Delta_Type (Label : Delta_Labels := Simple) is
+ record
+ -- Matches DELTA input to wisi--indent-token-1
+ case Label is
+ when Simple =>
+ Simple_Delta : Simple_Delta_Type;
+
+ when Hanging =>
+ Hanging_First_Line : WisiToken.Line_Number_Type;
+ Hanging_Paren_State : Integer;
+ Hanging_Delta_1 : Simple_Delta_Type; -- indentation of first line
+ Hanging_Delta_2 : Simple_Delta_Type; -- indentation of
continuation lines
+ Hanging_Accumulate : Boolean;
+ end case;
+ end record;
+
+ Null_Delta : constant Delta_Type := (Simple, (Int, 0));
+
+ function Image (Item : in Delta_Type) return String;
+ -- For debugging
+
+ ----------
+ -- Utilities for language-specific child packages
+
+ subtype Aug_Token_Ref is Augmented_Token_Arrays.Variable_Reference_Type;
+
+ function Current_Indent_Offset
+ (Data : in Parse_Data_Type;
+ Anchor_Token : in Augmented_Token'Class;
+ Offset : in Integer)
+ return Integer;
+ -- Return offset from beginning of first token on line containing
+ -- Anchor_Token, to beginning of Anchor_Token, plus Offset.
+
+ function Find
+ (Data : in Parse_Data_Type;
+ ID : in WisiToken.Token_ID;
+ Token : in Augmented_Token'Class)
+ return WisiToken.Base_Token_Index;
+ -- Return index in Parser.Terminals of first token in
+ -- Token.Char_Region with ID. If not found, return
+ -- No_Index.
+
+ function Get_Aug_Token
+ (Data : in Parse_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree'Class;
+ Tree_Index : in WisiToken.Syntax_Trees.Valid_Node_Index)
+ return Aug_Token_Ref;
+
+ function Indent_Anchored_2
+ (Data : in out Parse_Data_Type;
+ Anchor_Line : in WisiToken.Line_Number_Type;
+ Last_Line : in WisiToken.Line_Number_Type;
+ Offset : in Integer;
+ Accumulate : in Boolean)
+ return Delta_Type;
+ -- [2] wisi-elisp-parse--anchored-2
+
+ function Indent_Compute_Delta
+ (Data : in out Parse_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
+ Param : in Indent_Param;
+ Tree_Indenting : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Indenting_Comment : in Boolean)
+ return Delta_Type;
+
+ procedure Indent_Token_1
+ (Data : in out Parse_Data_Type;
+ Indenting_Token : in Augmented_Token'Class;
+ Delta_Indent : in Delta_Type;
+ Indenting_Comment : in Boolean);
+ -- [2] wisi-elisp-parse--indent-token-1. Sets Data.Indents, so caller
+ -- may not be in a renames for a Data.Indents element.
+
+end Wisi;
diff --git a/wisi.el b/wisi.el
index b063321..00719a2 100755
--- a/wisi.el
+++ b/wisi.el
@@ -1,1642 +1,1298 @@
-;;; wisi.el --- Utilities for implementing an indentation/navigation engine
using a generalized LALR parser -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2012 - 2017 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: 1.1.6
-;; package-requires: ((cl-lib "0.4") (emacs "24.3"))
-;; 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/>.
-;;
-
-;;; Commentary:
-
-;;;; History: see NEWS-wisi.text
-;;
-;;;; indentation algorithm overview
-;;
-;; This design is inspired in part by experience writing a SMIE
-;; indentation engine for Ada, and the wisent parser.
-;;
-;; The general approach to indenting a given token is to find the
-;; start of the statement it is part of, or some other relevant point
-;; in the statement, and indent relative to that. So we need a parser
-;; that lets us find statement indent points from arbitrary places in
-;; the code.
-;;
-;; For example, the grammar for Ada as represented by the EBNF in LRM
-;; Annex P is not LALR(1), so we use a generalized LALR(1) parser (see
-;; wisi-parse, wisi-compile).
-;;
-;; The parser actions cache indentation and other information as text
-;; properties of tokens in statements.
-;;
-;; An indentation engine moves text in the buffer, as does user
-;; editing, so we can't rely on character positions remaining
-;; constant. So the parser actions use markers to store
-;; positions. Text properties also move with the text.
-;;
-;; The stored information includes a marker at each statement indent
-;; point. Thus, the indentation algorithm is: find the previous token
-;; with cached information, and either indent from it, or fetch from
-;; it the marker for a previous statement indent point, and indent
-;; relative to that.
-;;
-;; Since we have a cache (the text properties), we need to consider
-;; when to invalidate it. Ideally, we invalidate only when a change to
-;; the buffer would change the result of a parse that crosses that
-;; change, or starts after that change. Changes in whitespace
-;; (indentation and newlines) do not affect an Ada parse. Other
-;; languages are sensitive to newlines (Bash for example) or
-;; indentation (Python). Adding comments does not change a parse,
-;; unless code is commented out. For now we invalidate the cache after
-;; the edit point if the change involves anything other than
-;; whitespace.
-;;
-;;; Handling parse errors:
-;;
-;; When a parse fails, the cache information before the failure point
-;; is only partly correct, and there is no cache informaiton after the
-;; failure point.
-;;
-;; However, in the case where a parse previously succeeded, and the
-;; current parse fails due to editing, we keep the preceding cache
-;; information by setting wisi-cache-max to the edit point in
-;; wisi-before change; the parser does not apply actions before that
-;; point.
-;;
-;; This allows navigation and indentation in the text preceding the
-;; edit point, and saves some time.
-;;
-;;;; comparison to the SMIE parser
-;;
-;; The central problem to be solved in building the SMIE parser is
-;; grammar precedence conflicts; the general solution is refining
-;; keywords so that each new keyword can be assigned a unique
-;; precedence. This means ad hoc code must be written to determine the
-;; correct refinement for each language keyword from the surrounding
-;; tokens. In effect, for a complex language like Ada, the knowledge
-;; of the language grammar is mostly embedded in the refinement code;
-;; only a small amount is in the refined grammar. Implementing a SMIE
-;; parser for a new language involves the same amount of work as the
-;; first language.
-;;
-;; Using a generalized LALR parser avoids that particular problem;
-;; assuming the language is already defined by a grammar, it is only a
-;; matter of a format change to teach the wisi parser the
-;; language. The problem in a wisi indentation engine is caching the
-;; output of the parser in a useful way, since we can't start the
-;; parser from arbitrary places in the code (as we can with the SMIE
-;; parser). A second problem is determining when to invalidate the
-;; cache. But these problems are independent of the language being
-;; parsed, so once we have one wisi indentation engine working,
-;; adapting it to new languages should be quite simple.
-;;
-;; The SMIE parser does not find the start of each statement, only the
-;; first language keyword in each statement; additional code must be
-;; written to find the statement start and indent points. The wisi
-;; parser finds the statement start and indent points directly.
-;;
-;; In SMIE, it is best if each grammar rule is a complete statement,
-;; so forward-sexp will traverse the entire statement. If nested
-;; non-terminals are used, forward-sexp may stop inside one of the
-;; nested non-terminals. This problem does not occur with the wisi
-;; parser.
-;;
-;; A downside of the wisi parser is conflicts in the grammar; they can
-;; be much more difficult to resolve than in the SMIE parser. The
-;; generalized parser helps by handling conflicts, but it does so by
-;; running multiple parsers in parallel, persuing each choice in the
-;; conflict. If the conflict is due to a genuine ambiguity, both paths
-;; will succeed, which causes the parse to fail, since it is not clear
-;; which set of text properties to store. Even if one branch
-;; ultimately fails, running parallel parsers over large sections of
-;; code is slow. Finally, this approach can lead to exponential growth
-;; in the number of parsers. So grammar conflicts must still be
-;; analyzed and minimized.
-;;
-;; In addition, the complete grammar must be specified; in smie, it is
-;; often possible to specify a subset of the grammar.
-;;
-;;;; grammar compiler and parser
-;;
-;; Since we are using a generalized LALR(1) parser, we cannot use any
-;; of the wisent grammar functions. We use OpenToken wisi-generate
-;; to compile BNF to Elisp source (similar to
-;; semantic-grammar-create-package), and wisi-compile-grammar to
-;; compile that to the parser table.
-;;
-;; Semantic provides a complex lexer, more complicated than we need
-;; for indentation. So we use the elisp lexer, which consists of
-;; `forward-comment', `skip-syntax-forward', and `scan-sexp'. We wrap
-;; that in functions that return tokens in the form wisi-parse
-;; expects.
-;;
-;;;; lexer
-;;
-;; The lexer is `wisi-forward-token'. It relies on syntax properties,
-;; so syntax-propertize must be called on the text to be lexed before
-;; wisi-forward-token is called. In general, it is hard to determine
-;; an appropriate end-point for syntax-propertize, other than
-;; point-max. So we call (syntax-propertize point-max) in wisi-setup,
-;; and also call syntax-propertize in wisi-after-change.
-;; FIXME: no longer needed in Emacs 25? (email from Stefan Monnier)
-;;
-;;;; code style
-;;
-;; 'wisi' was originally short for "wisent indentation engine", but
-;; now is just a name.
-;;
-;; not using lexical-binding because we support Emacs 23
-;;
-;;;;;
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'wisi-parse)
-
-;; WORKAROUND: for some reason, this condition doesn't work in batch mode!
-;; (when (and (= emacs-major-version 24)
-;; (= emacs-minor-version 2))
- (require 'wisi-compat-24.2)
-;;)
-
-(defcustom wisi-size-threshold 100000
- "Max size (in characters) for using wisi parser results for syntax
highlighting and file navigation."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-size-threshold)
-
-;;;; lexer
-
-(defvar-local wisi-class-list nil)
-(defvar-local wisi-keyword-table nil)
-(defvar-local wisi-punctuation-table nil)
-(defvar-local wisi-punctuation-table-max-length 0)
-(defvar-local wisi-string-double-term nil);; string delimited by double quotes
-(defvar-local wisi-string-quote-escape-doubled nil
- "Non-nil if a string delimiter is escaped by doubling it (as in Ada).")
-(defvar-local wisi-string-quote-escape nil
- "Cons (delim . character) where `character' escapes quotes in strings
delimited by `delim'.")
-(defvar-local wisi-string-single-term nil) ;; string delimited by single quotes
-(defvar-local wisi-symbol-term nil)
-(defvar-local wisi-number-term nil)
-(defvar-local wisi-number-p nil)
-
-(defun wisi-number-p (token-text)
- "Return t if TOKEN-TEXT plus text after point matches the
-syntax for a real literal; otherwise nil. Point is after
-TOKEN-TEXT; move point to just past token."
- ;; Typical literals:
- ;; 1234
- ;; 1234.5678
- ;; _not_ including non-decimal base, or underscores (see ada-wisi-number-p)
- ;;
- ;; Starts with a simple integer
- (when (string-match "^[0-9]+$" token-text)
- (when (looking-at "\\.[0-9]+")
- ;; real number
- (goto-char (match-end 0))
- (when (looking-at "[Ee][+-][0-9]+")
- ;; exponent
- (goto-char (match-end 0))))
-
- t
- ))
-
-(defun wisi-forward-token ()
- "Move point forward across one token, skipping leading whitespace and
comments.
-Return the corresponding token, in format: (token start . end) where:
-
-`token' is a token symbol (not string) from `wisi-punctuation-table',
-`wisi-keyword-table', `wisi-string-double-term', `wisi-string-double-term' or
`wisi-symbol-term'.
-
-`start, end' are the character positions in the buffer of the start
-and end of the token text.
-
-If at end of buffer, returns `wisent-eoi-term'."
- (forward-comment (point-max))
- ;; skips leading whitespace, comment, trailing whitespace.
-
- (let ((start (point))
- ;; (info "(elisp)Syntax Table Internals" "*info elisp syntax*")
- (syntax (syntax-class (syntax-after (point))))
- token-id token-text)
- (cond
- ((eobp)
- (setq token-id wisent-eoi-term))
-
- ((eq syntax 1)
- ;; punctuation. Find the longest matching string in
wisi-punctuation-table
- (forward-char 1)
- (let ((next-point (point))
- temp-text temp-id done)
- (while (not done)
- (setq temp-text (buffer-substring-no-properties start (point)))
- (setq temp-id (car (rassoc temp-text wisi-punctuation-table)))
- (when temp-id
- (setq token-id temp-id
- next-point (point)))
- (if (or
- (eobp)
- (= (- (point) start) wisi-punctuation-table-max-length))
- (setq done t)
- (forward-char 1))
- )
- (goto-char next-point)))
-
- ((memq syntax '(4 5)) ;; open, close parenthesis
- (forward-char 1)
- (setq token-text (buffer-substring-no-properties start (point)))
- (setq token-id (symbol-value (intern-soft token-text
wisi-keyword-table))))
-
- ((eq syntax 7)
- ;; string quote, either single or double. we assume point is
- ;; before the start quote, not the end quote
- (let ((delim (char-after (point)))
- (forward-sexp-function nil))
- (condition-case err
- (progn
- (forward-sexp)
-
- ;; point is now after the end quote; check for an escaped quote
- (while (or
- (and wisi-string-quote-escape-doubled
- (eq (char-after (point)) delim))
- (and (eq delim (car wisi-string-quote-escape))
- (eq (char-before (1- (point))) (cdr
wisi-string-quote-escape))))
- (forward-sexp))
- (setq token-id (if (= delim ?\") wisi-string-double-term
wisi-string-single-term)))
- (scan-error
- ;; Something screwed up; we should not get here if
- ;; syntax-propertize works properly.
- (signal 'wisi-parse-error (format "wisi-forward-token: forward-sexp
failed %s" err))
- ))))
-
- (t ;; assuming word or symbol syntax; includes numbers
- (skip-syntax-forward "w_'")
- (setq token-text (buffer-substring-no-properties start (point)))
- (setq token-id
- (or (symbol-value (intern-soft (downcase token-text)
wisi-keyword-table))
- (and (functionp wisi-number-p)
- (funcall wisi-number-p token-text)
- (setq token-text (buffer-substring-no-properties start
(point)))
- wisi-number-term)
- wisi-symbol-term))
- )
- );; cond
-
- (unless token-id
- (signal 'wisi-parse-error
- (wisi-error-msg "unrecognized token '%s'"
(buffer-substring-no-properties start (point)))))
-
- (cons token-id (cons start (point)))
- ))
-
-(defun wisi-backward-token ()
- "Move point backward across one token, skipping whitespace and comments.
-Does _not_ handle numbers with wisi-number-p; just sees lower-level syntax.
-Return (nil start . end) - same structure as
-wisi-forward-token, but does not look up symbol."
- (forward-comment (- (point)))
- ;; skips leading whitespace, comment, trailing whitespace.
-
- ;; (info "(elisp)Syntax Table Internals" "*info elisp syntax*")
- (let ((end (point))
- (syntax (syntax-class (syntax-after (1- (point))))))
- (cond
- ((bobp) nil)
-
- ((eq syntax 1)
- ;; punctuation. Find the longest matching string in
wisi-punctuation-table
- (backward-char 1)
- (let ((next-point (point))
- temp-text done)
- (while (not done)
- (setq temp-text (buffer-substring-no-properties (point) end))
- (when (car (rassoc temp-text wisi-punctuation-table))
- (setq next-point (point)))
- (if (or
- (bobp)
- (= (- end (point)) wisi-punctuation-table-max-length))
- (setq done t)
- (backward-char 1))
- )
- (goto-char next-point))
- )
-
- ((memq syntax '(4 5)) ;; open, close parenthesis
- (backward-char 1))
-
- ((eq syntax 7)
- ;; a string quote. we assume we are after the end quote, not the start
quote
- (let ((forward-sexp-function nil))
- (forward-sexp -1)))
-
- (t ;; assuming word or symbol syntax
- (if (zerop (skip-syntax-backward "."))
- (skip-syntax-backward "w_'")))
- )
- (cons nil (cons (point) end))
- ))
-
-;;;; token info cache
-;;
-;; the cache stores the results of parsing as text properties on
-;; keywords, for use by the indention and motion engines.
-
-(cl-defstruct
- (wisi-cache
- (:constructor wisi-cache-create)
- (:copier nil))
- nonterm;; nonterminal from parse (set by wisi-statement-action)
-
- token
- ;; terminal symbol from wisi-keyword-table or
- ;; wisi-punctuation-table, or lower-level nonterminal from parse
- ;; (set by wisi-statement-action)
-
- last ;; pos of last char in token, relative to first (0 indexed)
-
- class
- ;; arbitrary lisp symbol, used for indentation and navigation.
- ;; some classes are defined by wisi:
- ;;
- ;; 'block-middle - a block keyword (ie: if then else end), not at the start
of a statement
- ;;
- ;; 'block-start - a block keyword at the start of a statement
- ;;
- ;; 'statement-start - the start of a statement
- ;;
- ;; 'open-paren
- ;;
- ;; others are language-specific
-
- containing
- ;; Marker at the containing keyword for this token.
- ;; A containing keyword is an indent point; the start of a
- ;; statement, or 'begin', 'then' or 'else' for a block of
- ;; statements, etc.
- ;; 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
- )
-
-(defvar-local wisi-parse-table nil)
-
-(defvar-local wisi-parse-failed nil
- "Non-nil when a recent parse has failed - cleared when parse succeeds.")
-
-(defvar-local wisi-parse-try nil
- "Non-nil when parse is needed - cleared when parse succeeds.")
-
-(defvar-local wisi-change-need-invalidate nil
- "When non-nil, buffer position to invalidate from.
-Used in before/after change functions.")
-
-(defvar-local wisi-end-caches nil
- "List of buffer positions of caches in current statement that need
wisi-cache-end set.")
-
-(defun wisi-delete-cache (after)
- (with-silent-modifications
- (remove-text-properties after (point-max) '(wisi-cache nil))
- ;; We don't remove 'font-lock-face; that's annoying to the user,
- ;; since they won't be restored until a parse for some other
- ;; reason, and they are likely to be right anyway.
- ))
-
-(defun wisi-invalidate-cache(&optional after)
- "Invalidate parsing caches for the current buffer from AFTER to end of
buffer."
- (interactive)
- (if (not after)
- (setq after (point-min))
- (setq after
- (save-excursion
- (goto-char after)
- (line-beginning-position))))
- (when (> wisi-debug 0) (message "wisi-invalidate %s:%d" (current-buffer)
after))
- (setq wisi-cache-max after)
- (setq wisi-parse-try t)
- (syntax-ppss-flush-cache after)
- (wisi-delete-cache after)
- )
-
-;; To see the effects of wisi-before-change, wisi-after-change, you need:
-;; (global-font-lock-mode 0)
-;; (setq jit-lock-functions nil)
-;;
-;; otherwise jit-lock runs and overrides them
-
-(defun wisi-before-change (begin end)
- "For `before-change-functions'."
- ;; begin . end is range of text being deleted
-
- ;; If jit-lock-after-change is before wisi-after-change in
- ;; after-change-functions, it might use any invalid caches in the
- ;; inserted text.
- ;;
- ;; So we check for that here, and ensure it is after
- ;; wisi-after-change, which deletes the invalid caches
- (when (boundp 'jit-lock-mode)
- (when (memq 'wisi-after-change (memq 'jit-lock-after-change
after-change-functions))
- (setq after-change-functions (delete 'wisi-after-change
after-change-functions))
- (add-hook 'after-change-functions 'wisi-after-change nil t))
- )
-
- (setq wisi-change-need-invalidate nil)
-
- (when (> end begin)
- (save-excursion
- ;; (info "(elisp)Parser State")
- (let* ((begin-state (syntax-ppss begin))
- (end-state (syntax-ppss end))
- ;; syntax-ppss has moved point to "end".
- (word-end (progn (skip-syntax-forward "w_")(point))))
-
- ;; Remove grammar face from word(s) containing change region;
- ;; might be changing to/from a keyword. See
- ;; test/ada_mode-interactive_common.adb Obj_1
- (goto-char begin)
- (skip-syntax-backward "w_")
- (with-silent-modifications
- (remove-text-properties (point) word-end '(font-lock-face nil
fontified nil)))
-
- (if (<= wisi-cache-max begin)
- ;; Change is in unvalidated region; either the parse was
- ;; failing, or there is more than one top-level grammar
- ;; symbol in buffer.
- (when wisi-parse-failed
- ;; The parse was failing, probably due to bad syntax; this
- ;; change may have fixed it, so try reparse.
- (setq wisi-parse-try t))
-
- ;; else change is in validated region
- ;;
- ;; don't invalidate parse for whitespace, string, or comment changes
- (cond
- ((and
- (nth 3 begin-state); in string
- (nth 3 end-state)))
- ;; no easy way to tell if there is intervening non-string
-
- ((and
- (nth 4 begin-state); in comment
- (nth 4 end-state))
- ;; too hard to detect case where there is intervening
- ;; code; no easy way to go to end of comment if not
- ;; newline
- )
-
- ;; Deleting whitespace generally does not require parse, but
- ;; deleting all whitespace between two words does; check that
- ;; there is whitespace on at least one side of the deleted
- ;; text.
- ;;
- ;; We are not in a comment (checked above), so treat
- ;; comment end as whitespace in case it is newline, except
- ;; deleting a comment end at begin means commenting the
- ;; current line; requires parse.
- ((and
- (eq (car (syntax-after begin)) 0) ; whitespace
- (memq (car (syntax-after (1- end))) '(0 12)) ; whitespace, comment
end
- (or
- (memq (car (syntax-after (1- begin))) '(0 12))
- (memq (car (syntax-after end)) '(0 12)))
- (progn
- (goto-char begin)
- (skip-syntax-forward " >" end)
- (eq (point) end))))
-
- (t
- (setq wisi-change-need-invalidate
- (progn
- (goto-char begin)
- ;; note that because of the checks above, this never
- ;; triggers a parse, so it's fast
- (wisi-goto-statement-start)
- (point))))
- )))
- ))
- )
-
-(defun wisi-after-change (begin end length)
- "For `after-change-functions'."
- ;; begin . end is range of text being inserted (empty if equal);
- ;; length is the size of the deleted text.
-
- ;; (syntax-ppss-flush-cache begin) is in before-change-functions
-
- (syntax-propertize end) ;; see comments above on "lexer" re syntax-propertize
-
- ;; 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)))
-
- ;; Also remove grammar face from word(s) containing change region;
- ;; might be changing to/from a keyword. See
- ;; test/ada_mode-interactive_common.adb Obj_1
- (save-excursion
- ;; (info "(elisp)Parser State")
- (let ((need-invalidate wisi-change-need-invalidate)
- begin-state end-state word-end)
- (when (> end begin)
- (setq begin-state (syntax-ppss begin))
- (setq end-state (syntax-ppss end))
- ;; syntax-ppss has moved point to "end".
-
- ;; extend fontification over new text,
- (skip-syntax-forward "w_")
- (setq word-end (point))
- (goto-char begin)
- (skip-syntax-backward "w_")
- (with-silent-modifications
- (remove-text-properties (point) word-end '(font-lock-face nil
fontified nil))))
-
- (if (<= wisi-cache-max begin)
- ;; Change is in unvalidated region
- (when wisi-parse-failed
- ;; The parse was failing, probably due to bad syntax; this
- ;; change may have fixed it, so try reparse.
- (setq wisi-parse-try t))
-
- ;; Change is in validated region
- (cond
- (wisi-change-need-invalidate
- ;; wisi-before change determined the removed text alters the
- ;; parse
- )
-
- ((= end begin)
- (setq need-invalidate nil))
-
- ((and
- (nth 3 begin-state); in string
- (nth 3 end-state))
- ;; no easy way to tell if there is intervening non-string
- (setq need-invalidate nil))
-
- ((and
- (nth 4 begin-state)
- (nth 4 end-state)); in comment
- ;; no easy way to detect intervening code
- (setq need-invalidate nil)
- ;; no caches to remove
- )
-
- ;; Adding whitespace generally does not require parse, but in
- ;; the middle of word it does; check that there was
- ;; whitespace on at least one side of the inserted text.
- ;;
- ;; We are not in a comment (checked above), so treat
- ;; comment end as whitespace in case it is newline
- ((and
- (or
- (memq (car (syntax-after (1- begin))) '(0 12)); whitespace, comment
end
- (memq (car (syntax-after end)) '(0 12)))
- (progn
- (goto-char begin)
- (skip-syntax-forward " >" end)
- (eq (point) end)))
- (setq need-invalidate nil))
-
- (t
- (setq need-invalidate
- (progn
- (goto-char begin)
- ;; note that because of the checks above, this never
- ;; triggers a parse, so it's fast
- (wisi-goto-statement-start)
- (point))))
- )
-
- (if need-invalidate
- (wisi-invalidate-cache need-invalidate)
-
- ;; else move cache-max by the net change length.
- (setq wisi-cache-max
- (+ wisi-cache-max (- end begin length))) )
- ))
- ))
-
-(defun wisi-get-cache (pos)
- "Return `wisi-cache' struct from the `wisi-cache' text property at POS.
-If accessing cache at a marker for a token as set by `wisi-cache-tokens', POS
must be (1- mark)."
- (get-text-property pos 'wisi-cache))
-
-(defvar-local wisi-parse-error-msg nil)
-
-(defun wisi-goto-error ()
- "Move point to position in last error message (if any)."
- (when (and wisi-parse-error-msg
- (string-match ":\\([0-9]+\\):\\([0-9]+\\):" wisi-parse-error-msg))
- (let ((line (string-to-number (match-string 1 wisi-parse-error-msg)))
- (col (string-to-number (match-string 2 wisi-parse-error-msg))))
- (push-mark)
- (goto-char (point-min))
- (forward-line (1- line))
- (forward-char col))))
-
-(defun wisi-show-parse-error ()
- "Show last wisi-parse error."
- (interactive)
- (cond
- (wisi-parse-failed
- (wisi-goto-error)
- (message wisi-parse-error-msg))
-
- (wisi-parse-try
- (message "need parse"))
-
- (t
- (message "parse succeeded"))
- ))
-
-(defvar wisi-post-parse-succeed-hook nil
- "Hook run after parse succeeds.")
-
-(defun wisi-validate-cache (pos &optional error-on-fail)
- "Ensure cached data is valid at least up to POS in current buffer."
- (let ((msg (when (> wisi-debug 0) (format "wisi: parsing %s:%d ..."
(buffer-name) (line-number-at-pos pos)))))
- ;; If wisi-cache-max = pos, then there is no cache at pos; need parse
- (when (and wisi-parse-try
- (<= wisi-cache-max pos))
- (when (> wisi-debug 0)
- (message msg))
-
- ;; Don't keep retrying failed parse until text changes again.
- (setq wisi-parse-try nil)
-
- (setq wisi-parse-error-msg nil)
- (setq wisi-end-caches nil)
-
- (if (> wisi-debug 1)
- ;; let debugger stop in wisi-parse
- (progn
- (save-excursion
- (wisi-parse wisi-parse-table 'wisi-forward-token)
- (setq wisi-cache-max (point))
- (setq wisi-parse-failed nil))
- (run-hooks 'wisi-post-parse-succeed-hook))
-
- ;; else capture errors from bad syntax, so higher level
- ;; functions can try to continue and/or we don't bother the
- ;; user.
- (condition-case err
- (progn
- (save-excursion
- (wisi-parse wisi-parse-table 'wisi-forward-token)
- (setq wisi-cache-max (point))
- (setq wisi-parse-failed nil))
- (run-hooks 'wisi-post-parse-succeed-hook))
- (wisi-parse-error
- ;; delete caches past wisi-cache-max added by failed parse
- (wisi-delete-cache wisi-cache-max)
- (setq wisi-parse-failed t)
- (setq wisi-parse-error-msg (cdr err)))
- ))
- (if wisi-parse-error-msg
- ;; error
- (cond
- ((> wisi-debug 0)
- (message "%s error" msg)
- (wisi-goto-error)
- (error wisi-parse-error-msg)))
- ;; no msg; success
- (when (> wisi-debug 0)
- (message "%s done" msg)))
- )
- (when (and error-on-fail (not (>= wisi-cache-max pos)))
- (error "parse failed"))
- ))
-
-(defun wisi-fontify-region (_begin end)
- "For `jit-lock-functions'."
- (when (< (point-max) wisi-size-threshold)
- (wisi-validate-cache end)))
-
-(defun wisi-get-containing-cache (cache)
- "Return cache from (wisi-cache-containing CACHE)."
- (when cache
- (let ((containing (wisi-cache-containing cache)))
- (and containing
- (wisi-get-cache (1- containing))))))
-
-(defun wisi-cache-region (cache)
- "Return region designated by cache.
-Point must be at cache."
- (cons (point) (+ (point) (wisi-cache-last cache))))
-
-(defun wisi-cache-text (cache)
- "Return property-less buffer substring designated by cache.
-Point must be at cache."
- (buffer-substring-no-properties (point) (+ (point) (wisi-cache-last cache))))
-
-;;;; parse actions
-
-(defun wisi-set-end (start-mark end-mark)
- "Set END-MARK on all caches in `wisi-end-caches' in range START-MARK
END-MARK,
-delete from `wisi-end-caches'."
- (let ((i 0)
- pos cache)
- (while (< i (length wisi-end-caches))
- (setq pos (nth i wisi-end-caches))
- (setq cache (wisi-get-cache pos))
-
- (if (and (>= pos start-mark)
- (< pos end-mark))
- (progn
- (setf (wisi-cache-end cache) end-mark)
- (setq wisi-end-caches (delq pos wisi-end-caches)))
-
- ;; else not in range
- (setq i (1+ i)))
- )))
-
-(defvar wisi-tokens nil)
-(defvar $nterm nil)
-;; keep byte-compiler happy; `wisi-tokens' and `$nterm' are bound in
-;; action created by wisi-semantic-action, and in module parser.
-;; FIXME: $nterm should have wisi- prefix
-
-(defun wisi-statement-action (pairs)
- "Cache information in text properties of tokens.
-Intended as a grammar non-terminal action.
-
-PAIRS is a vector of the form [TOKEN-NUMBER CLASS TOKEN-NUMBER
-CLASS ...] where TOKEN-NUMBER is the (1 indexed) token number in
-the production, CLASS is the wisi class of that token. Use in a
-grammar action as:
- (wisi-statement-action [1 \\='statement-start 7 \\='statement-end])"
- (save-excursion
- (let ((first-item t)
- first-keyword-mark
- (override-start nil)
- (i 0))
- (while (< i (length pairs))
- (let* ((number (1- (aref pairs i)))
- (region (cdr (aref wisi-tokens number)));; wisi-tokens is
let-bound in wisi-parse-reduce
- (token (car (aref wisi-tokens number)))
- (class (aref pairs (setq i (1+ i))))
- (mark
- ;; Marker one char into token, so indent-line-to
- ;; inserts space before the mark, not after
- (when region (copy-marker (1+ (car region)))))
- cache)
-
- (setq i (1+ i))
-
- (unless (memq class wisi-class-list)
- (error "%s not in wisi-class-list" class))
-
- (if region
- (progn
- (if (setq cache (wisi-get-cache (car region)))
- ;; We are processing a previously set non-terminal; ie
generic_formal_part in
- ;;
- ;; generic_package_declaration : generic_formal_part
package_specification SEMICOLON
- ;; (wisi-statement-action 1 'block-start 2 'block-middle
3 'statement-end)
- ;;
- ;; or simple_statement in
- ;;
- ;; statement : label_opt simple_statement
- ;;
- ;; override nonterm, class, containing
- ;; set end only if not set yet (due to failed parse)
- (progn
- (cl-case (wisi-cache-class cache)
- (block-start
- (setf (wisi-cache-class cache)
- (cond
- ((eq override-start nil)
- (cond
- ((memq class '(block-start statement-start))
'block-start)
- (t 'block-middle)))
-
- ((memq override-start '(block-start
statement-start)) 'block-start)
-
- (t (error "unexpected override-start"))
- )))
- (t
- (setf (wisi-cache-class cache) (or override-start
class)))
- )
- (setf (wisi-cache-nonterm cache) $nterm)
- (setf (wisi-cache-containing cache) first-keyword-mark)
- (unless (wisi-cache-end cache)
- (if wisi-end-caches
- (push (car region) wisi-end-caches)
- (setq wisi-end-caches (list (car region)))
- ))
- )
-
- ;; else create new cache
- (with-silent-modifications
- (put-text-property
- (car region)
- (1+ (car region))
- 'wisi-cache
- (wisi-cache-create
- :nonterm $nterm
- :token token
- :last (- (cdr region) (car region))
- :class (or override-start class)
- :containing first-keyword-mark)
- ))
- (if wisi-end-caches
- (push (car region) wisi-end-caches)
- (setq wisi-end-caches (list (car region)))
- ))
-
- (when first-item
- (setq first-item nil)
- (when (or override-start
- (memq class '(block-start statement-start)))
- (setq override-start nil)
- (setq first-keyword-mark mark)))
-
- (when (eq class 'statement-end)
- (wisi-set-end (1- first-keyword-mark) (copy-marker (1+ (car
region)))))
- )
-
- ;; region is nil when a production is empty; if the first
- ;; token is a start, override the class on the next token.
- (when (and first-item
- (memq class '(block-middle block-start statement-start)))
- (setq override-start class)))
- ))
- )))
-
-(defun wisi-containing-action (containing-token contained-token)
- "Set containing marks in all tokens in CONTAINED-TOKEN with null containing
mark to marker pointing to CONTAINING-TOKEN.
-If CONTAINING-TOKEN is empty, the next token number is used."
- ;; wisi-tokens is is bound in action created by wisi-semantic-action
- (let* ((containing-region (cdr (aref wisi-tokens (1- containing-token))))
- (contained-region (cdr (aref wisi-tokens (1- contained-token)))))
-
- (unless containing-region ;;
- (signal 'wisi-parse-error
- (wisi-error-msg
- "wisi-containing-action: containing-region '%s' is empty.
grammar error; bad action"
- (wisi-token-text (aref wisi-tokens (1- containing-token))))))
-
- (unless (or (not contained-region) ;; contained-token is empty
- (wisi-get-cache (car containing-region)))
- (signal 'wisi-parse-error
- (wisi-error-msg
- "wisi-containing-action: containing-token '%s' has no cache.
grammar error; missing action"
- (wisi-token-text (aref wisi-tokens (1- containing-token))))))
-
- (while (not containing-region)
- ;; containing-token is empty; use next
- (setq containing-region (cdr (aref wisi-tokens containing-token))))
-
- (when contained-region
- ;; nil when empty production, may not contain any caches
- (save-excursion
- (goto-char (cdr contained-region))
- (let ((cache (wisi-backward-cache))
- (mark (copy-marker (1+ (car containing-region)))))
- (while cache
-
- ;; skip blocks that are already marked
- (while (and (>= (point) (car contained-region))
- (markerp (wisi-cache-containing cache)))
- (goto-char (1- (wisi-cache-containing cache)))
- (setq cache (wisi-get-cache (point))))
-
- (if (or (and (= (car containing-region) (car contained-region))
- (<= (point) (car contained-region)))
- (< (point) (car contained-region)))
- ;; done
- (setq cache nil)
-
- ;; else set mark, loop
- (setf (wisi-cache-containing cache) mark)
- (setq cache (wisi-backward-cache)))
- ))))))
-
-(defun wisi-match-class-token (cache class-tokens)
- "Return t if CACHE matches CLASS-TOKENS.
-CLASS-TOKENS is a vector [number class token_id class token_id ...].
-number is ignored."
- (let ((i 1)
- (done nil)
- (result nil)
- class token)
- (while (and (not done)
- (< i (length class-tokens)))
- (setq class (aref class-tokens i))
- (setq token (aref class-tokens (setq i (1+ i))))
- (setq i (1+ i))
- (when (and (eq class (wisi-cache-class cache))
- (eq token (wisi-cache-token cache)))
- (setq result t
- done t))
- )
- result))
-
-(defun wisi-motion-action (token-numbers)
- "Set prev/next marks in all tokens given by TOKEN-NUMBERS.
-TOKEN-NUMBERS is a vector with each element one of:
-
-number: the token number; mark that token
-
-vector [number class token_id]:
-vector [number class token_id class token_id ...]:
- mark all tokens in number nonterminal matching (class token_id) with nil
prev/next."
- (save-excursion
- (let (prev-keyword-mark
- prev-cache
- cache
- mark
- (i 0))
- (while (< i (length token-numbers))
- (let ((token-number (aref token-numbers i))
- region)
- (setq i (1+ i))
- (cond
- ((numberp token-number)
- (setq region (cdr (aref wisi-tokens (1- token-number))))
- (when region
- (setq cache (wisi-get-cache (car region)))
- (setq mark (copy-marker (1+ (car region))))
-
- (when (and prev-keyword-mark
- cache
- (null (wisi-cache-prev cache)))
- (setf (wisi-cache-prev cache) prev-keyword-mark)
- (setf (wisi-cache-next prev-cache) mark))
-
- (setq prev-keyword-mark mark)
- (setq prev-cache cache)
- ))
-
- ((vectorp token-number)
- ;; token-number may contain 0, 1, or more 'class token_id' pairs
- ;; the corresponding region may be empty
- ;; there must have been a prev keyword
- (setq region (cdr (aref wisi-tokens (1- (aref token-number 0)))))
- (when region ;; not an empty token
- ;; We must search for all targets at the same time, to
- ;; get the motion order right.
- (goto-char (car region))
- (setq cache (or (wisi-get-cache (point))
- (wisi-forward-cache)))
- (while (< (point) (cdr region))
- (when (wisi-match-class-token cache token-number)
- (when (null (wisi-cache-prev cache))
- (setf (wisi-cache-prev cache) prev-keyword-mark))
- (when (null (wisi-cache-next cache))
- (setq mark (copy-marker (1+ (point))))
- (setf (wisi-cache-next prev-cache) mark)
- (setq prev-keyword-mark mark)
- (setq prev-cache cache)))
-
- (setq cache (wisi-forward-cache))
- )))
-
- (t
- (error "unexpected token-number %s" token-number))
- )
-
- ))
- )))
-
-(defun wisi-extend-action (first last)
- "Extend text of cache at token FIRST to cover all tokens thru LAST."
- (let* ((first-region (cdr (aref wisi-tokens (1- first))));; wisi-tokens is
let-bound in wisi-parse-reduce
- (last-region (cdr (aref wisi-tokens (1- last))))
- cache)
-
- (when first-region
- (setq cache (wisi-get-cache (car first-region)))
- (setf (wisi-cache-last cache) (- (cdr last-region) (car first-region)))
- )
- ))
-
-(defun wisi-face-action-1 (face region &optional override-no-error)
- "Apply FACE to REGION.
-If OVERRIDE-NO-ERROR is non-nil, don't report an error for overriding an
existing face."
- (when region
- ;; We allow overriding a face property, because we don't want to
- ;; delete them in wisi-invalidate (see comments there). On the
- ;; other hand, it can be an error, so keep this debug
- ;; code. However, to validly report errors, note that
- ;; font-lock-face properties must be removed first, or the buffer
- ;; must be fresh (never parsed), and wisi-debug must be > 1.
- ;;
- ;; Grammar sets override-no-error when a higher-level production might
- ;; override a face in a lower-level production.
- (when (> wisi-debug 1)
- (let ((cur-face (get-text-property (car region) 'font-lock-face)))
- (when cur-face
- (unless override-no-error
- (message "%s:%d overriding face %s with %s on '%s'"
- (buffer-file-name)
- (line-number-at-pos (car region))
- face
- cur-face
- (buffer-substring-no-properties (car region) (cdr
region))))
-
- )))
- (with-silent-modifications
- (add-text-properties
- (car region) (cdr region)
- (list
- 'font-lock-face face
- 'fontified t)))
- ))
-
-(defun wisi-face-action (pairs &optional no-override)
- "Cache face information in text properties of tokens.
-Intended as a grammar non-terminal action.
-
-PAIRS is a vector of the form [token-number face token-number face ...]
-token-number may be an integer, or a vector [integer token_id token_id ...]
-
-For an integer token-number, apply face to the first cached token
-in the range covered by wisi-tokens[token-number]. If there are
-no cached tokens, apply face to entire wisi-tokens[token-number]
-region.
-
-For a vector token-number, apply face to the first cached token
-in the range matching one of token_id covered by
-wisi-tokens[token-number].
-
-If NO-OVERRIDE is non-nil, don't override existing face."
- (let (number region face (tokens nil) cache (i 0) (j 1))
- (while (< i (length pairs))
- (setq number (aref pairs i))
- (setq face (aref pairs (setq i (1+ i))))
- (cond
- ((integerp number)
- (setq region (cdr (aref wisi-tokens (1- number))));; wisi-tokens is
let-bound in wisi-parse-reduce
- (when region
- (save-excursion
- (goto-char (car region))
- (setq cache (or (wisi-get-cache (point))
- (wisi-forward-cache)))
- (if (< (point) (cdr region))
- (when cache
- (wisi-face-action-1 face (wisi-cache-region cache)
no-override))
-
- ;; no caches in region; just apply face to region
- (wisi-face-action-1 face region no-override))
- )))
-
- ((vectorp number)
- (setq region (cdr (aref wisi-tokens (1- (aref number 0)))))
- (when region
- (while (< j (length number))
- (setq tokens (cons (aref number j) tokens))
- (setq j (1+ j)))
- (save-excursion
- (goto-char (car region))
- (setq cache (wisi-forward-find-token tokens (cdr region) t))
- ;; might be looking for IDENTIFIER in name, but only have "*".
- (when cache
- (wisi-face-action-1 face (wisi-cache-region cache) no-override))
- )))
- )
- (setq i (1+ i))
-
- )))
-
-(defun wisi-face-list-action (pairs &optional no-override)
- "Cache face information in text properties of tokens.
-Intended as a grammar non-terminal action.
-
-PAIRS is a vector of the form [token-number face token-number face ...]
-token-number is an integer. Apply face to all cached tokens
-in the range covered by wisi-tokens[token-number].
-
-If NO-OVERRIDE is non-nil, don't override existing face."
- (let (number region face cache (i 0))
- (while (< i (length pairs))
- (setq number (aref pairs i))
- (setq face (aref pairs (setq i (1+ i))))
- (setq region (cdr (aref wisi-tokens (1- number))));; wisi-tokens is
let-bound in wisi-parse-reduce
- (when region
- (save-excursion
- (goto-char (car region))
- (setq cache (or (wisi-get-cache (point))
- (wisi-forward-cache)))
- (while (<= (point) (cdr region))
- (when cache
- (wisi-face-action-1 face (wisi-cache-region cache) no-override))
- (setq cache (wisi-forward-cache))
- )))
-
- (setq i (1+ i))
-
- )))
-
-;;;; motion
-(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."
- (let (cache pos)
- (setq pos (previous-single-property-change (point) 'wisi-cache))
- ;; There are three cases:
- ;;
- ;; 1) caches separated by non-cache chars: 'if ... then'
- ;; pos is before 'f', cache is on 'i'
- ;;
- ;; 2) caches not separated: ');'
- ;; pos is before ';', cache is on ';'
- ;;
- ;; 3) at bob; pos is nil
- ;;
- (if pos
- (progn
- (setq cache (get-text-property pos 'wisi-cache))
- (if cache
- ;; case 2
- (goto-char pos)
- ;; case 1
- (setq cache (get-text-property (1- pos) 'wisi-cache))
- (goto-char (1- pos))))
- ;; at bob
- (goto-char (point-min))
- (setq cache nil))
- 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-forward-find-class (class limit)
- "Search forward for a token that has a cache with CLASS.
-Return cache, or nil if at end of buffer.
-If LIMIT (a buffer position) is reached, throw an error."
- (let ((cache (wisi-forward-cache)))
- (while (not (eq class (wisi-cache-class cache)))
- (setq cache (wisi-forward-cache))
- (when (>= (point) limit)
- (error "cache with class %s not found" class)))
- cache))
-
-(defun wisi-forward-find-token (token limit &optional noerror)
- "Search forward for a token that has a cache with TOKEN.
-If point is at a matching token, return that token.
-TOKEN may be a list; stop on any cache that has a member of the list.
-Return cache, or nil if at end of buffer.
-If LIMIT (a buffer position) is reached, then if NOERROR is nil, throw an
-error, if non-nil, return nil."
- (let ((token-list (cond
- ((listp token) token)
- (t (list token))))
- (cache (wisi-get-cache (point)))
- (done nil))
- (while (not (or done
- (and cache
- (memq (wisi-cache-token cache) token-list))))
- (setq cache (wisi-forward-cache))
- (when (>= (point) limit)
- (if noerror
- (progn
- (setq done t)
- (setq cache nil))
- (error "cache with token %s not found" token))))
- cache))
-
-(defun wisi-forward-find-cache-token (ids limit)
- "Search forward for a cache with token in IDS (a list of token ids).
-Return cache, or nil if at LIMIT or end of buffer."
- (let ((cache (wisi-forward-cache)))
- (while (and (< (point) limit)
- (not (eobp))
- (not (memq (wisi-cache-token cache) ids)))
- (setq cache (wisi-forward-cache)))
- cache))
-
-(defun wisi-forward-find-nonterm (nonterm limit)
- "Search forward for a token that has a cache with NONTERM.
-NONTERM may be a list; stop on any cache that has a member of the list.
-Return cache, or nil if at end of buffer.
-If LIMIT (a buffer position) is reached, throw an error."
- (let ((nonterm-list (cond
- ((listp nonterm) nonterm)
- (t (list nonterm))))
- (cache (wisi-forward-cache)))
- (while (not (memq (wisi-cache-nonterm cache) nonterm-list))
- (setq cache (wisi-forward-cache))
- (when (>= (point) limit)
- (error "cache with nonterm %s not found" nonterm)))
- cache))
-
-(defun wisi-goto-cache-next (cache)
- (goto-char (1- (wisi-cache-next cache)))
- (wisi-get-cache (point))
- )
-
-(defun wisi-forward-statement-keyword ()
- "If not at a cached token, move forward to next
-cache. Otherwise move to cache-next, or cache-end, or next cache
-if both nil. Return cache found."
- (unless (eobp)
- (wisi-validate-cache (point-max) t) ;; ensure there is a next cache to
move to
- (let ((cache (wisi-get-cache (point))))
- (if (and cache
- (not (eq (wisi-cache-class cache) 'statement-end)))
- (let ((next (or (wisi-cache-next cache)
- (wisi-cache-end cache))))
- (if next
- (goto-char (1- next))
- (wisi-forward-token)
- (wisi-forward-cache)))
- (wisi-forward-cache))
- )
- (wisi-get-cache (point))
- ))
-
-(defun wisi-backward-statement-keyword ()
- "If not at a cached token, move backward to prev
-cache. Otherwise move to cache-prev, or prev cache if nil."
- (wisi-validate-cache (point) t)
- (let ((cache (wisi-get-cache (point))))
- (if cache
- (let ((prev (wisi-cache-prev cache)))
- (if prev
- (goto-char (1- prev))
- (wisi-backward-cache)))
- (wisi-backward-cache))
- ))
-
-(defun wisi-forward-sexp (&optional arg)
- "For `forward-sexp-function'."
- (interactive "^p")
- (or arg (setq arg 1))
- (cond
- ((and (> arg 0) (= 4 (syntax-class (syntax-after (point))))) ;; on open
paren
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- ((and (< arg 0) (= 5 (syntax-class (syntax-after (1- (point)))))) ;; after
close paren
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- ((and (> arg 0) (= 7 (syntax-class (syntax-after (point))))) ;; on (open)
string quote
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- ((and (< arg 0) (= 7 (syntax-class (syntax-after (1- (point)))))) ;; after
(close) string quote
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- (t
- (dotimes (_i (abs arg))
- (if (> arg 0)
- (wisi-forward-statement-keyword)
- (wisi-backward-statement-keyword))))
- ))
-
-(defun wisi-goto-containing (cache &optional error)
- "Move point to containing token for CACHE, return cache at that point.
-If ERROR, throw error when CACHE has no container; else return nil."
- (cond
- ((markerp (wisi-cache-containing cache))
- (goto-char (1- (wisi-cache-containing cache)))
- (wisi-get-cache (point)))
- (t
- (when error
- (error "already at outermost containing token")))
- ))
-
-(defun wisi-goto-containing-paren (cache)
- "Move point to just after the open-paren containing CACHE.
-Return cache for paren, or nil if no containing paren."
- (while (and cache
- (not (eq (wisi-cache-class cache) 'open-paren)))
- (setq cache (wisi-goto-containing cache)))
- (when cache
- (forward-char 1))
- cache)
-
-(defun wisi-goto-start (cache)
- "Move point to containing ancestor of CACHE that has class block-start or
statement-start.
-Return start cache."
- (when
- ;; cache nil at bob, or on cache in partially parsed statement
- (while (and cache
- (not (memq (wisi-cache-class cache) '(block-start
statement-start))))
- (setq cache (wisi-goto-containing cache)))
- )
- cache)
-
-(defun wisi-goto-end-1 (cache)
- (goto-char (1- (wisi-cache-end cache))))
-
-(defun wisi-goto-statement-start ()
- "Move point to token at start of statement point is in or after.
-Return start cache."
- (interactive)
- (wisi-validate-cache (point) t)
- (let ((cache (wisi-get-cache (point))))
- (unless cache
- (setq cache (wisi-backward-cache)))
- (wisi-goto-start 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)
- (let ((cache (or (wisi-get-cache (point))
- (wisi-forward-cache))))
- (when (wisi-cache-end cache)
- ;; nil when cache is statement-end
- (wisi-goto-end-1 cache))
- ))
-
-(defun wisi-next-statement-cache (cache)
- "Move point to CACHE-next, return cache; error if nil."
- (when (not (markerp (wisi-cache-next cache)))
- (error "no next statement cache"))
- (goto-char (1- (wisi-cache-next cache)))
- (wisi-get-cache (point)))
-
-(defun wisi-prev-statement-cache (cache)
- "Move point to CACHE-prev, return cache; error if nil."
- (when (not (markerp (wisi-cache-prev cache)))
- (error "no prev statement cache"))
- (goto-char (1- (wisi-cache-prev cache)))
- (wisi-get-cache (point)))
-
-;;;; indentation
-
-(defun wisi-comment-indent ()
- "For `comment-indent-function'. Indent single line comment to
-the comment on the previous line."
- ;; Called from `comment-indent', either to insert a new comment, or
- ;; to indent the first line of an existing one. In either case, the
- ;; comment may be after code on the same line. For an existing
- ;; comment, point is at the start of the starting delimiter.
- (or
- (save-excursion
- ;; Check for a preceding comment line; fail if comment follows code.
- (when (forward-comment -1)
- ;; For the case:
- ;;
- ;; code;-- comment
- ;;
- ;; point is on '--', and 'forward-comment' does not move point,
- ;; returns nil.
- (when (looking-at comment-start)
- (current-column))))
-
- (save-excursion
- (back-to-indentation)
- (if (looking-at comment-start)
- ;; An existing comment, no code preceding comment, and
- ;; no comment on preceding line. Return nil, so
- ;; `comment-indent' will call `indent-according-to-mode'
- nil
-
- ;; A comment after code on the same line.
- comment-column))
- ))
-
-(defun wisi-indent-current (offset)
- "Return indentation OFFSET relative to indentation of current line."
- (+ (current-indentation) offset)
- )
-
-(defun wisi-indent-paren (offset)
- "Return indentation OFFSET relative to preceding open paren."
- (save-excursion
- (goto-char (nth 1 (syntax-ppss)))
- (+ (current-column) offset)))
-
-(defun wisi-indent-start (offset cache)
- "Return indentation of OFFSET relative to containing ancestor
-of CACHE with class statement-start or block-start."
- (wisi-goto-start cache)
- (+ (current-indentation) offset))
-
-(defun wisi-indent-statement ()
- "Indent region given by `wisi-goto-start' on cache at or before point, then
wisi-cache-end."
- (wisi-validate-cache (point) t)
-
- (save-excursion
- (let ((cache (or (wisi-get-cache (point))
- (wisi-backward-cache))))
- (when cache
- ;; can be nil if in header comment
- (let ((start (progn (wisi-goto-start cache) (point)))
- (end (progn
- (when (wisi-cache-end cache)
- ;; nil when cache is statement-end
- (goto-char (1- (wisi-cache-end cache))))
- (point))))
- (indent-region start end)
- ))
- )))
-
-(defvar-local wisi-indent-calculate-functions nil
- "Functions to calculate indentation. Each called with point
- before a token at the beginning of a line (at current
- indentation); return indentation column for that token, or
- nil. May move point. Calling stops when first function returns
- non-nil.")
-
-(defvar-local wisi-post-parse-fail-hook
- "Function to reindent portion of buffer.
-Called from `wisi-indent-line' when a parse succeeds after
-failing; assumes user was editing code that is now syntactically
-correct. Must leave point at indentation of current line.")
-
-(defvar-local wisi-indent-failed nil
- "Non-nil when wisi-indent-line fails due to parse failing; cleared when
indent succeeds.")
-
-(defvar-local wisi-indent-fallback 'wisi-indent-fallback-default
- "Function to compute indent for current line when wisi parse fails.")
-
-(defun wisi-indent-fallback-default ()
- ;; no indent info at point. Assume user is
- ;; editing; indent to previous line, fix it
- ;; after parse succeeds
- (forward-line -1);; safe at bob
- (back-to-indentation)
- (current-column))
-
-(defun wisi-indent-line ()
- "Indent current line using the wisi indentation engine."
- (interactive)
-
- (let ((savep (point))
- indent)
- (save-excursion
- (back-to-indentation)
- (when (>= (point) savep) (setq savep nil))
-
- (when (>= (point) wisi-cache-max)
- (wisi-validate-cache (line-end-position))) ;; include at lease the
first token on this line
-
- (if (> (point) wisi-cache-max)
- (progn
- (setq wisi-indent-failed t)
- (setq indent (funcall wisi-indent-fallback)))
-
- ;; parse succeeded
- (when wisi-indent-failed
- ;; previous parse failed
- (setq wisi-indent-failed nil)
- (run-hooks 'wisi-post-parse-fail-hook))
-
- (when (> (point) wisi-cache-max)
- (error "wisi-post-parse-fail-hook invalidated parse."))
-
- (setq indent
- (with-demoted-errors
- (or (run-hook-with-args-until-success
'wisi-indent-calculate-functions) 0))
- )
- ))
-
- (if savep
- ;; point was inside line text; leave it there
- (save-excursion (indent-line-to indent))
- ;; point was before line text; move to start of text
- (indent-line-to indent))
- ))
-
-;;;; debug
-(defun wisi-parse-buffer ()
- (interactive)
- (syntax-propertize (point-max))
- (wisi-invalidate-cache)
- (wisi-validate-cache (point-max)) t)
-
-(defun wisi-lex-buffer ()
- (interactive)
- (syntax-propertize (point-max))
- (goto-char (point-min))
- (while (not (eq wisent-eoi-term (car (wisi-forward-token)))))
- )
-
-(defun wisi-show-cache ()
- "Show cache at point."
- (interactive)
- (message "%s" (wisi-get-cache (point))))
-
-(defun wisi-show-token ()
- "Move forward across one keyword, show token_id."
- (interactive)
- (let ((token (wisi-forward-token)))
- (message "%s" (car token))))
-
-(defun wisi-show-containing-or-previous-cache ()
- (interactive)
- (let ((cache (wisi-get-cache (point))))
- (if cache
- (message "containing %s" (wisi-goto-containing cache t))
- (message "previous %s" (wisi-backward-cache)))
- ))
-
-(defun wisi-show-cache-max ()
- (interactive)
- (push-mark)
- (goto-char wisi-cache-max))
-
-;;;;; setup
-
-(defun wisi-setup (indent-calculate post-parse-fail class-list keyword-table
token-table parse-table)
- "Set up a buffer for parsing files with wisi."
- (setq wisi-class-list class-list)
- (setq wisi-string-double-term (car (symbol-value (intern-soft
"string-double" token-table))))
- (setq wisi-string-single-term (car (symbol-value (intern-soft
"string-single" token-table))))
- (setq wisi-symbol-term (car (symbol-value (intern-soft "symbol"
token-table))))
-
- (let ((numbers (cadr (symbol-value (intern-soft "number" token-table)))))
- (setq wisi-number-term (car numbers))
- (setq wisi-number-p (cdr numbers)))
-
- (setq wisi-punctuation-table (symbol-value (intern-soft "punctuation"
token-table)))
- (setq wisi-punctuation-table-max-length 0)
- (let (fail)
- (dolist (item wisi-punctuation-table)
- (when item ;; default matcher can be nil
-
- ;; check that all chars used in punctuation tokens have punctuation
syntax
- (mapc (lambda (char)
- (when (not (= ?. (char-syntax char)))
- (setq fail t)
- (message "in %s, %c does not have punctuation syntax"
- (car item) char)))
- (cdr item))
-
- (when (< wisi-punctuation-table-max-length (length (cdr item)))
- (setq wisi-punctuation-table-max-length (length (cdr item)))))
- )
- (when fail
- (error "aborting due to punctuation errors")))
-
- (setq wisi-keyword-table keyword-table)
- (setq wisi-parse-table parse-table)
-
- ;; file local variables may have added opentoken, gnatprep
- (setq wisi-indent-calculate-functions (append
wisi-indent-calculate-functions indent-calculate))
- (set (make-local-variable 'indent-line-function) 'wisi-indent-line)
- (set (make-local-variable 'forward-sexp-function) #'wisi-forward-sexp)
-
- (setq wisi-post-parse-fail-hook post-parse-fail)
- (setq wisi-indent-failed nil)
-
- (add-hook 'before-change-functions 'wisi-before-change nil t)
- (add-hook 'after-change-functions 'wisi-after-change nil t)
-
- (jit-lock-register 'wisi-fontify-region)
-
- ;; see comments on "lexer" above re syntax-propertize
- (syntax-propertize (point-max))
-
- (wisi-invalidate-cache)
- )
-
-(provide 'wisi)
-;;; wisi.el ends here
+;;; wisi.el --- Utilities for implementing an indentation/navigation engine
using a generalized LALR parser -*- lexical-binding:t -*-
+;;
+;; Copyright (C) 2012 - 2018 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.0
+;; package-requires: ((cl-lib "1.0") (emacs "25.0") (seq "2.20"))
+;; 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/>.
+;;
+
+;;; Commentary:
+
+;;;; History: see NEWS-wisi.text
+;;
+;;;; Design:
+;;
+;; 'wisi' was originally short for "wisent indentation engine", but
+;; now is just a name. wisi was developed to support Emacs ada-mode
+;; 5.0 indentation, font-lock, and navigation, which are parser based.
+;;
+;; The approach to indenting a given token is to parse the buffer,
+;; computing a delta indent at each parse action.
+;;
+;; The parser actions also cache face and navigation information
+;; as text properties on tokens in statements.
+;;
+;; The three reasons to run the parser (indent, face, navigate) occur
+;; at different times (user indent, font-lock, user navigate), so only
+;; the relevant parser actions are run.
+;;
+;; Since we have a cache (the text properties), we need to consider
+;; when to invalidate it. Ideally, we invalidate only when a change
+;; to the buffer would change the result of a parse that crosses that
+;; change, or starts after that change. Changes in whitespace
+;; (indentation and newlines) do not affect an Ada parse. Other
+;; languages are sensitive to newlines (Bash for example) or
+;; indentation (Python). Adding comments does not change a parse,
+;; unless code is commented out.
+;;
+;; For font-lock and navigate, keeping track of the point after which
+;; caches have been deleted is sufficent (see `wisi-cache-max').
+;;
+;; 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
+;; 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.
+;;
+;; See `wisi--post-change' for the details of what we check for
+;; invalidating.
+;;
+;;;; Choice of grammar compiler and parser
+;;
+;; There are two other parsing engines available in Emacs:
+;;
+;; - SMIE
+;;
+;; We don't use this because it is designed to parse small snippets
+;; of code. For Ada indentation, we always need to parse the entire
+;; buffer.
+;;
+;; - semantic
+;;
+;; The Ada grammar as given in the Ada language reference manual is
+;; not LALR(1). So we use a generalized parser. In addition, the
+;; semantic lexer is more complex, and gives different information
+;; than we need.
+;;
+;; We use wisitoken wisi-generate to compile BNF to Elisp source, and
+;; wisi-compile-grammar to compile that to the parser table. See
+;; ada-mode info for more information on the developer tools used for
+;; ada-mode and wisi.
+;;
+;; Alternately, to gain speed and error handling, we use wisi-generate
+;; to generate Ada source, and run that in an external process. That
+;; supports error correction while parsing.
+;;
+;;;; syntax-propertize
+;;
+;; `wisi-forward-token' relies on syntax properties, so
+;; `syntax-propertize' must be called on the text to be lexed before
+;; wisi-forward-token is called.
+;;
+;; Emacs >= 25 calls syntax-propertize transparently in the low-level
+;; lexer functions.
+;;
+;; In Emacs < 25, we call syntax-propertize in wisi-setup, and in
+;; `wisi--post-change'.
+;;
+;;;;;
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'compile)
+(require 'seq)
+(require 'semantic/lex)
+(require 'wisi-parse-common)
+(require 'wisi-elisp-lexer)
+(require 'wisi-fringe)
+
+(defcustom wisi-size-threshold 100000
+ "Max size (in characters) for using wisi parser results for anything."
+ :type 'integer
+ :group 'wisi
+ :safe 'integerp)
+(make-variable-buffer-local 'wisi-size-threshold)
+
+(defvar wisi-inhibit-parse nil
+ "When non-nil, don't run the parser.
+Language code can set this non-nil when syntax is known to be
+invalid temporarily, or when making lots of changes.")
+
+(defcustom wisi-disable-face nil
+ "When non-nil, `wisi-setup' does not enable use of parser for font-lock.
+Useful when debugging parser or parser actions."
+ :type 'boolean
+ :group 'wisi
+ :safe 'booleanp)
+
+(defconst wisi-error-buffer-name "*wisi syntax errors*"
+ "Name of buffer for displaying syntax errors.")
+
+(defvar wisi-error-buffer nil
+ "Buffer for displaying syntax errors.")
+
+;;;; token info cache
+
+(defvar-local wisi-parse-failed nil
+ "Non-nil when a recent parse has failed - cleared when parse succeeds.")
+
+(defvar-local wisi--parse-try
+ (list
+ (cons 'face t)
+ (cons 'navigate t)
+ (cons 'indent t))
+ "Non-nil when parse is needed - cleared when parse succeeds.")
+
+(defun wisi-parse-try (&optional parse-action)
+ (cdr (assoc (or parse-action wisi--parse-action) wisi--parse-try)))
+
+(defun wisi-set-parse-try (value &optional parse-action)
+ (setcdr (assoc (or parse-action wisi--parse-action) wisi--parse-try) value))
+
+(defvar-local wisi--cache-max
+ (list
+ (cons 'face nil)
+ (cons 'navigate nil)
+ (cons 'indent nil))
+ "Alist of maximimum position in buffer where parser text properties are
valid.")
+
+(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))
+
+(defun wisi--delete-face-cache (after)
+ (with-silent-modifications
+ (remove-text-properties after (point-max) '(wisi-face nil 'font-lock-face
nil))
+ ))
+
+(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))
+ ))
+
+(defun wisi--delete-indent-cache (after)
+ (with-silent-modifications
+ (remove-text-properties after (point-max) '(wisi-indent nil))
+ ))
+
+(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-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))
+ ))
+
+ (setq after (point)))
+ (wisi--delete-navigate-cache after))
+
+ ((eq 'indent action)
+ ;; indent cache is stored on newline before line being indented.
+ (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))
+
+;; wisi--change-* keep track of buffer modifications.
+;; If wisi--change-end comes before wisi--change-beg, it means there were
+;; no modifications.
+(defvar-local wisi--change-beg most-positive-fixnum
+ "First position where a change may have taken place.")
+
+(defvar-local wisi--change-end nil
+ "Marker pointing to the last position where a change may have taken place.")
+
+(defvar-local wisi--deleted-syntax nil
+ "Worst syntax class of characters deleted in changes.
+One of:
+nil - no deletions since reset
+0 - only whitespace or comment deleted
+2 - some other syntax deleted
+
+Set by `wisi-before-change', used and reset by `wisi--post-change'.")
+
+(defvar-local wisi-indenting-p nil
+ "Non-nil when `wisi-indent-region' is actively indenting.
+Used to ignore whitespace changes in before/after change hooks.")
+
+(defvar-local wisi--parser nil
+ "Choice of wisi parser implementation; a ‘wisi-parser’ object.")
+
+(defvar-local wisi--last-parse-action nil
+ "Last value of `wisi--parse-action' when `wisi-validate-cache' was run.")
+
+(defun wisi-before-change (begin end)
+ "For `before-change-functions'."
+ ;; begin . (1- end) is range of text being deleted
+ (unless wisi-indenting-p
+ ;; We set wisi--change-beg, -end even if only inserting, so we
+ ;; don't have to do it again in wisi-after-change.
+ (setq wisi--change-beg (min wisi--change-beg begin))
+
+ (cond
+ ((null wisi--change-end)
+ (setq wisi--change-end (copy-marker end)))
+
+ ((> end wisi--change-end)
+ ;; `buffer-base-buffer' deals with edits in indirect buffers
+ ;; created by ediff-regions-*
+ (set-marker wisi--change-end end (buffer-base-buffer)))
+ )
+
+ (unless (= begin end)
+ (cond
+ ((or (null wisi--deleted-syntax)
+ (= 0 wisi--deleted-syntax))
+ (save-excursion
+ (if (or (nth 4 (syntax-ppss begin)) ; in comment, moves point to begin
+ (= end (skip-syntax-forward " " end)));; whitespace
+ (setq wisi--deleted-syntax 0)
+ (setq wisi--deleted-syntax 2))))
+
+ (t
+ ;; wisi--deleted-syntax is 2; no change.
+ )
+ ))))
+
+(defun wisi-after-change (begin end _length)
+ "For `after-change-functions'"
+ ;; begin . end is range of text being inserted (empty if equal);
+ ;; length is the size of the deleted text.
+ ;;
+ ;; 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
+ (save-excursion
+ (let (word-end)
+ (goto-char end)
+ (skip-syntax-forward "w_")
+ (setq word-end (point))
+ (goto-char begin)
+ (skip-syntax-backward "w_")
+ (with-silent-modifications
+ (remove-text-properties (point) word-end '(font-lock-face nil
fontified nil)))
+ )
+ )))
+
+(defun wisi--post-change (begin end)
+ "Update wisi text properties for changes in region BEG END."
+ ;; (syntax-ppss-flush-cache begin) is in before-change-functions
+
+ ;; see comments above on syntax-propertize
+ (when (< emacs-major-version 25) (syntax-propertize end))
+
+ ;; 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)
+ ;; non-nil if require a parse because the syntax may have
+ ;; changed.
+
+ (begin-state (syntax-ppss begin))
+ (end-state (syntax-ppss end)))
+ ;; (info "(elisp)Parser State")
+ ;; syntax-ppss has moved point to "end"; might be eob.
+
+ ;; consider deletion
+ (cond
+ ((null wisi--deleted-syntax)
+ ;; no deletions
+ )
+
+ ((= 0 wisi--deleted-syntax)
+ ;; Only deleted whitespace; may have joined two words
+ (when
+ (and (= begin end) ;; no insertions
+ (or
+ (= (point-min) begin)
+ (= 0 (syntax-class (syntax-after (1- begin))))
+ (= (point-max) end)
+ (= 0 (syntax-class (syntax-after end)))))
+ ;; More whitespace on at least one side of deletion; did not
+ ;; join two words.
+ (setq need-invalidate nil)
+ (setq done t)
+ ))
+
+ (t
+ ;; wisi--deleted-syntax is 2; need invalidate and parse for all
+ ;; parse actions
+ (setq done t)
+ ))
+
+ (setq wisi--deleted-syntax nil)
+
+ (unless done
+ ;; consider insertion
+ (cond
+ ((= begin end)
+ ;; no insertions
+ nil)
+
+ ((and
+ (nth 3 begin-state);; in string
+ (nth 3 end-state)
+ (= (nth 8 begin-state) (nth 8 end-state)));; no intervening
non-string
+ (setq need-invalidate nil))
+
+ ((and
+ (nth 4 begin-state) ; in comment
+ (nth 4 end-state)
+ (= (nth 8 begin-state) (nth 8 end-state))) ;; no intervening
non-comment
+ (setq need-invalidate nil))
+
+ ((and
+ (or
+ (= (point-min) begin)
+ (= 0 (syntax-class (syntax-after (1- begin)))); whitespace
+ (= (point-max) end)
+ (= 0 (syntax-class (syntax-after end))))
+ (progn
+ (goto-char begin)
+ (= (- end begin) (skip-syntax-forward " " end))
+ ))
+ ;; Inserted only whitespace, there is more whitespace on at
+ ;; least one side, and we are not in a comment or string
+ ;; (checked above). This may affect indentation, but not
+ ;; the indentation cache.
+ (setq need-invalidate nil))
+ ))
+
+ (when need-invalidate
+ (wisi-set-parse-try t 'face)
+ (wisi-set-parse-try t 'navigate)
+ (wisi-set-parse-try t 'indent)
+
+ (wisi-invalidate-cache 'face begin)
+ (wisi-invalidate-cache 'navigate begin)
+ (wisi-invalidate-cache 'indent begin))
+ )))
+
+(defun wisi-goto-error ()
+ "Move point to position in last error message (if any)."
+ (cond
+ ((wisi-parser-parse-errors wisi--parser)
+ (let ((data (car (wisi-parser-parse-errors wisi--parser))))
+ (cond
+ ((wisi--parse-error-pos data)
+ (push-mark)
+ (goto-char (wisi--parse-error-pos data)))
+
+ ((string-match ":\\([0-9]+\\):\\([0-9]+\\):" (wisi--parse-error-message
data))
+ (let* ((msg (wisi--parse-error-message data))
+ (line (string-to-number (match-string 1 msg)))
+ (col (string-to-number (match-string 2 msg))))
+ (push-mark)
+ (goto-char (point-min))
+ (condition-case nil
+ (progn
+ ;; line can be wrong if parser screws up, or user edits buffer
+ (forward-line (1- line))
+ (forward-char col))
+ (error
+ ;; just stay at eob.
+ nil))))
+ )))
+ ((wisi-parser-lexer-errors wisi--parser)
+ (push-mark)
+ (goto-char (wisi--lexer-error-pos (car (wisi-parser-lexer-errors
wisi--parser)))))
+ ))
+
+(defun wisi-show-parse-error ()
+ "Show current wisi-parse errors."
+ (interactive)
+ (cond
+ ((or (wisi-parser-lexer-errors wisi--parser)
+ (wisi-parser-parse-errors wisi--parser))
+ (if (and (= 1 (+ (length (wisi-parser-lexer-errors wisi--parser))
+ (length (wisi-parser-parse-errors wisi--parser))))
+ (or (and (wisi-parser-parse-errors wisi--parser)
+ (not (wisi--parse-error-repair (car
(wisi-parser-parse-errors wisi--parser)))))
+ (and (wisi-parser-lexer-errors wisi--parser)
+ (not (wisi--lexer-error-inserted (car
(wisi-parser-lexer-errors wisi--parser)))))))
+ ;; There is exactly one error; if there is error correction
+ ;; information, use a ’compilation’ buffer, so
+ ;; *-fix-compiler-error will call
+ ;; wisi-repair-error. Otherwise, just position cursor at
+ ;; error.
+ (progn
+ (wisi-goto-error)
+ (message (or (and (wisi-parser-parse-errors wisi--parser)
+ (wisi--parse-error-message (car
(wisi-parser-parse-errors wisi--parser))))
+ (and (wisi-parser-lexer-errors wisi--parser)
+ (wisi--lexer-error-message (car
(wisi-parser-lexer-errors wisi--parser)))))
+ ))
+
+ ;; else show all errors in a ’compilation’ buffer
+ (setq wisi-error-buffer (get-buffer-create wisi-error-buffer-name))
+
+ (let ((lexer-errs (nreverse (cl-copy-seq (wisi-parser-lexer-errors
wisi--parser))))
+ (parse-errs (nreverse (cl-copy-seq (wisi-parser-parse-errors
wisi--parser)))))
+ (with-current-buffer wisi-error-buffer
+ (compilation-mode)
+ (setq next-error-last-buffer (current-buffer))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ ;; compilation-nex-error-function assumes there is not an
+ ;; error at point min, so we need a comment.
+ (insert "wisi syntax errors")
+ (newline)
+ (dolist (err lexer-errs)
+ (insert (wisi--lexer-error-message err))
+ (put-text-property (line-beginning-position) (1+
(line-beginning-position)) 'wisi-error-data err)
+ (newline 2))
+ (dolist (err parse-errs)
+ (insert (wisi--parse-error-message err))
+ (put-text-property (line-beginning-position) (1+
(line-beginning-position)) 'wisi-error-data err)
+ (newline 2))
+ (compilation--flush-parse (point-min) (point-max))
+ (compilation--ensure-parse (point-max))
+ (when compilation-filter-hook
+ (let ((compilation-filter-start (point-min)))
+ (run-hooks 'compilation-filter-hook)))
+
+ (setq buffer-read-only t)
+ (goto-char (point-min)))
+
+ (display-buffer wisi-error-buffer
+ (cons #'display-buffer-at-bottom
+ (list (cons 'window-height
#'shrink-window-if-larger-than-buffer))))
+ (next-error))
+ ))
+
+ ((wisi-parse-try wisi--last-parse-action)
+ (message "need parse"))
+
+ (t
+ (message "parse succeeded"))
+ ))
+
+(defun wisi-kill-parser ()
+ "Kill the background process running the parser for the current buffer.
+Usefull if the parser appears to be hung."
+ (interactive)
+ (wisi-parse-kill wisi--parser)
+ ;; also force re-parse
+ (dolist (parse-action '(face navigate indent))
+ (wisi-set-parse-try t parse-action)
+ (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)
+ (message msg))
+
+ (setq wisi--last-parse-action wisi--parse-action)
+
+ (unless (eq wisi--parse-action 'face)
+ (when (buffer-live-p wisi-error-buffer)
+ (with-current-buffer wisi-error-buffer
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (setq buffer-read-only t))))
+
+ (condition-case-unless-debug err
+ (save-excursion
+ (wisi-parse-current wisi--parser)
+ (setq wisi-parse-failed nil)
+ (move-marker (wisi-cache-max) (point))
+ )
+ (wisi-parse-error
+ (cl-ecase wisi--parse-action
+ (face
+ ;; caches set by failed parse are ok
+ (wisi--delete-face-cache (wisi-cache-max)))
+
+ (navigate
+ ;; parse partially resets caches before and after wisi-cache-max
+ (move-marker (wisi-cache-max) (point-min))
+ (wisi--delete-navigate-cache (point-min)))
+
+ (indent
+ ;; parse does not set caches; see `wisi-indent-region'
+ nil))
+ (setq wisi-parse-failed t)
+ ;; parser should have stored this error message in parser-error-msgs
+ )
+ (error
+ ;; parser failed for other reason
+ (setq wisi-parse-failed t)
+ (signal (car err) (cdr err)))
+ )
+
+ (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)
+ (if (or (wisi-parser-lexer-errors wisi--parser)
+ (wisi-parser-parse-errors wisi--parser))
+ (progn
+ (message "%s error" msg)
+ (wisi-goto-error)
+ (error (or (and (wisi-parser-lexer-errors wisi--parser)
+ (wisi--lexer-error-message (car
(wisi-parser-lexer-errors wisi--parser))))
+ (and (wisi-parser-parse-errors wisi--parser)
+ (wisi--parse-error-message (car
(wisi-parser-parse-errors wisi--parser))))
+ )))
+
+ ;; no error
+ (message "%s done" msg))
+ ))))
+
+(defun wisi--check-change ()
+ "Process `wisi--change-beg', `wisi--change-end'.
+`wisi--parse-action' must be bound."
+ (when (and wisi--change-beg
+ wisi--change-end
+ (<= wisi--change-beg wisi--change-end))
+ (wisi--post-change wisi--change-beg (marker-position wisi--change-end))
+ (setq wisi--change-beg most-positive-fixnum)
+ (move-marker wisi--change-end (point-min))
+ ))
+
+(defun wisi-validate-cache (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)
+ (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))
+
+ ;; Don't keep retrying failed parse until text changes again.
+ (wisi-set-parse-try nil)
+
+ (wisi--run-parse))
+
+ ;; We want this error even if we did not try to parse; it means
+ ;; the parse results are not valid.
+ (when (and error-on-fail wisi-parse-failed)
+ (error "parse %s failed" parse-action))
+ )
+ (when (> wisi-debug 0)
+ (message "parse skipped due to ‘wisi-size-threshold’"))))
+
+(defun wisi-fontify-region (_begin end)
+ "For `jit-lock-functions'."
+ (wisi-validate-cache end nil 'face))
+
+(defun wisi-get-containing-cache (cache)
+ "Return cache from (wisi-cache-containing CACHE)."
+ (when cache
+ (let ((containing (wisi-cache-containing cache)))
+ (and containing
+ (wisi-get-cache containing)))))
+
+(defun wisi-cache-text (cache)
+ "Return property-less buffer substring designated by cache.
+Point must be at cache."
+ (buffer-substring-no-properties (point) (+ (point) (wisi-cache-last cache))))
+
+;;;; navigation
+
+(defun wisi-forward-find-class (class limit)
+ "Search at point or forward for a token that has a cache with CLASS.
+Return cache, or nil if at end of buffer.
+If LIMIT (a buffer position) is reached, throw an error."
+ (let ((cache (or (wisi-get-cache (point))
+ (wisi-forward-cache))))
+ (while (not (eq class (wisi-cache-class cache)))
+ (setq cache (wisi-forward-cache))
+ (when (>= (point) limit)
+ (error "cache with class %s not found" class)))
+ cache))
+
+(defun wisi-forward-find-token (token limit &optional noerror)
+ "Search forward for TOKEN.
+If point is at a matching token, return that token. TOKEN may be
+a list; stop on any member of the list. Return `wisi-tok'
+struct, or if LIMIT (a buffer position) is reached, then if
+NOERROR is nil, throw an error, if non-nil, return nil."
+ (let ((token-list (cond
+ ((listp token) token)
+ (t (list token))))
+ (tok (wisi-forward-token))
+ (done nil))
+ (while (not (or done
+ (memq (wisi-tok-token tok) token-list)))
+ (setq tok (wisi-forward-token))
+ (when (or (>= (point) limit)
+ (eobp))
+ (goto-char limit)
+ (setq tok nil)
+ (if noerror
+ (setq done t)
+ (error "token %s not found" token))))
+ tok))
+
+(defun wisi-forward-find-cache-token (ids limit)
+ "Search forward for a cache with token in IDS (a list of token ids).
+Return cache, or nil if at LIMIT or end of buffer."
+ (let ((cache (wisi-forward-cache)))
+ (while (and (< (point) limit)
+ (not (eobp))
+ (not (memq (wisi-cache-token cache) ids)))
+ (setq cache (wisi-forward-cache)))
+ cache))
+
+(defun wisi-forward-find-nonterm (nonterm limit)
+ "Search forward for a token that has a cache with NONTERM.
+NONTERM may be a list; stop on any cache that has a member of the list.
+Return cache, or nil if at end of buffer.
+If LIMIT (a buffer position) is reached, throw an error."
+ (let ((nonterm-list (cond
+ ((listp nonterm) nonterm)
+ (t (list nonterm))))
+ (cache (wisi-forward-cache)))
+ (while (not (memq (wisi-cache-nonterm cache) nonterm-list))
+ (setq cache (wisi-forward-cache))
+ (when (>= (point) limit)
+ (error "cache with nonterm %s not found" nonterm)))
+ cache))
+
+(defun wisi-goto-cache-next (cache)
+ (goto-char (wisi-cache-next cache))
+ (wisi-get-cache (point))
+ )
+
+(defun wisi-forward-statement-keyword ()
+ "If not at a cached token, move forward to next
+cache. Otherwise move to cache-next, or cache-end, or next cache
+if both nil. Return cache found."
+ (unless (eobp)
+ (wisi-validate-cache (point-max) t 'navigate) ;; ensure there is a next
cache to move to
+ (let ((cache (wisi-get-cache (point))))
+ (if (and cache
+ (not (eq (wisi-cache-class cache) 'statement-end)))
+ (let ((next (or (wisi-cache-next cache)
+ (wisi-cache-end cache))))
+ (if next
+ (goto-char next)
+ (wisi-forward-cache)))
+ (wisi-forward-cache))
+ )
+ (wisi-get-cache (point))
+ ))
+
+(defun wisi-backward-statement-keyword ()
+ "If not at a cached token, move backward to prev
+cache. Otherwise move to cache-prev, or prev cache if nil."
+ (wisi-validate-cache (point) t 'navigate)
+ (let ((cache (wisi-get-cache (point)))
+ prev)
+ (when cache
+ (setq prev (wisi-cache-prev cache))
+ (unless prev
+ (unless (eq 'statement-start (wisi-cache-class cache))
+ (setq prev (wisi-cache-containing cache)))))
+ (if prev
+ (goto-char prev)
+ (wisi-backward-cache))
+ ))
+
+(defun wisi-forward-sexp (&optional arg)
+ "For `forward-sexp-function'."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (cond
+ ((and (> arg 0) (= 4 (syntax-class (syntax-after (point))))) ;; on open
paren
+ (let ((forward-sexp-function nil))
+ (forward-sexp arg)))
+
+ ((and (< arg 0) (= 5 (syntax-class (syntax-after (1- (point)))))) ;; after
close paren
+ (let ((forward-sexp-function nil))
+ (forward-sexp arg)))
+
+ ((and (> arg 0) (= 7 (syntax-class (syntax-after (point))))) ;; on (open)
string quote
+ (let ((forward-sexp-function nil))
+ (forward-sexp arg)))
+
+ ((and (< arg 0) (= 7 (syntax-class (syntax-after (1- (point)))))) ;; after
(close) string quote
+ (let ((forward-sexp-function nil))
+ (forward-sexp arg)))
+
+ (t
+ (dotimes (_i (abs arg))
+ (if (> arg 0)
+ (wisi-forward-statement-keyword)
+ (wisi-backward-statement-keyword))))
+ ))
+
+(defun wisi-goto-containing (cache &optional error)
+ "Move point to containing token for CACHE, return cache at that point.
+If ERROR, throw error when CACHE has no container; else return nil."
+ (cond
+ ((and (markerp (wisi-cache-containing cache))
+
+ (not (= (wisi-cache-containing cache) (point))))
+ ;; This check is only needed if some cache points to itself as a
+ ;; container. Apparently that happend once that I caught in the
+ ;; debugger; emacs hung because we got here in the font-lock
+ ;; timer.
+
+ (goto-char (wisi-cache-containing cache))
+ (wisi-get-cache (point)))
+ (t
+ (when error
+ (error "already at outermost containing token")))
+ ))
+
+(defun wisi-goto-containing-paren (cache)
+ "Move point to just after the open-paren containing CACHE.
+Return cache for paren, or nil if no containing paren."
+ (while (and cache
+ (not (eq (wisi-cache-class cache) 'open-paren)))
+ (setq cache (wisi-goto-containing cache)))
+ (when cache
+ (forward-char 1))
+ cache)
+
+(defun wisi-goto-start (cache)
+ "Move point to containing ancestor of CACHE that has class statement-start.
+Return start cache."
+ ;; cache nil at bob, or on cache in partially parsed statement
+ (while (and cache
+ (not (eq (wisi-cache-class cache) 'statement-start)))
+ (setq cache (wisi-goto-containing cache)))
+ cache)
+
+(defun wisi-goto-end-1 (cache)
+ (goto-char (wisi-cache-end cache)))
+
+(defun wisi-goto-statement-start ()
+ "Move point to token at start of statement point is in or after.
+Return start cache."
+ (interactive)
+ (wisi-validate-cache (point) 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)
+ (let ((cache (or (wisi-get-cache (point))
+ (wisi-forward-cache))))
+ (when (wisi-cache-end cache)
+ ;; nil when cache is statement-end
+ (wisi-goto-end-1 cache))
+ ))
+
+(defun wisi-next-statement-cache (cache)
+ "Move point to CACHE-next, return cache; error if nil."
+ (when (not (markerp (wisi-cache-next cache)))
+ (error "no next statement cache"))
+ (goto-char (wisi-cache-next cache))
+ (wisi-get-cache (point)))
+
+(defun wisi-prev-statement-cache (cache)
+ "Move point to CACHE-prev, return cache; error if nil."
+ (when (not (markerp (wisi-cache-prev cache)))
+ (error "no prev statement cache"))
+ (goto-char (wisi-cache-prev cache))
+ (wisi-get-cache (point)))
+
+;;;; indentation
+
+(defun wisi-comment-indent ()
+ "For `comment-indent-function'. Indent single line comment to
+the comment on the previous line."
+ ;; Called from `comment-indent', either to insert a new comment, or
+ ;; to indent the first line of an existing one. In either case, the
+ ;; comment may be after code on the same line. For an existing
+ ;; comment, point is at the start of the starting delimiter.
+ (or
+ (save-excursion
+ ;; Check for a preceding comment line; fail if comment follows code.
+ (when (forward-comment -1)
+ ;; For the case:
+ ;;
+ ;; code;-- comment
+ ;;
+ ;; point is on '--', and 'forward-comment' does not move point,
+ ;; returns nil.
+ (when (looking-at comment-start)
+ (current-column))))
+
+ (save-excursion
+ (back-to-indentation)
+ (if (looking-at comment-start)
+ ;; An existing comment, no code preceding comment, and
+ ;; no comment on preceding line. Return nil, so
+ ;; `comment-indent' will call `indent-according-to-mode'
+ nil
+
+ ;; A comment after code on the same line.
+ comment-column))
+ ))
+
+(defun wisi-indent-statement ()
+ "Indent region given by `wisi-goto-start', `wisi-cache-end'."
+ (wisi-validate-cache (point) t 'navigate)
+
+ (save-excursion
+ (let ((cache (or (wisi-get-cache (point))
+ (wisi-backward-cache))))
+ (when cache
+ ;; can be nil if in header comment
+ (let ((start (progn (wisi-goto-start cache) (point)))
+ (end (if (wisi-cache-end cache)
+ ;; nil when cache is statement-end
+ (wisi-cache-end cache)
+ (point))))
+ (indent-region start end)
+ ))
+ )))
+
+(defvar-local wisi-indent-calculate-functions nil
+ "Functions to compute indentation special cases.
+Called with point at current indentation of a line; return
+indentation column, or nil if function does not know how to
+indent that line. Run after parser indentation, so other lines
+are indented correctly.")
+
+(defvar-local wisi-post-indent-fail-hook
+ "Function to reindent portion of buffer.
+Called from `wisi-indent-region' when a parse succeeds after
+failing; assumes user was editing code that is now syntactically
+correct. Must leave point at indentation of current line.")
+
+(defvar-local wisi-indent-failed nil
+ "Non-nil when wisi-indent-region fails due to parse failing; cleared when
indent succeeds.")
+
+(defvar-local wisi-indent-region-fallback 'wisi-indent-region-fallback-default
+ "Function to compute indent for lines in region when wisi parse fails.
+Called with BEGIN END.")
+
+(defun wisi-indent-region-fallback-default (begin end)
+ ;; Assume there is no indent info at point; user is editing. Indent
+ ;; to previous lines.
+ (goto-char begin)
+ (forward-line -1);; safe at bob
+ (back-to-indentation)
+ (let ((col (current-column)))
+ (while (and (not (eobp))
+ (< (point) end))
+ (forward-line 1)
+ (indent-line-to col)
+ (when (bobp)
+ ;; single line in buffer; terminate loop
+ (goto-char (point-max))))))
+
+(defun wisi-indent-region (begin end)
+ "For `indent-region-function', using the wisi indentation engine."
+ (let ((wisi--parse-action 'indent)
+ (parse-required nil)
+ (end-mark (copy-marker end))
+ (prev-indent-failed wisi-indent-failed))
+
+ (wisi--check-change)
+
+ ;; Always indent the line containing BEGIN.
+ (save-excursion
+ (goto-char begin)
+ (setq begin (line-beginning-position))
+
+ (when (bobp) (forward-line))
+ (while (and (not parse-required)
+ (<= (point) end)
+ (not (eobp)))
+ (unless (get-text-property (1- (point)) 'wisi-indent)
+ (setq parse-required t))
+ (forward-line))
+ )
+
+ ;; A parse either succeeds and sets the indent cache on all
+ ;; lines in the buffer, or fails and leaves valid caches
+ ;; untouched.
+ (when (and parse-required
+ (wisi-parse-try))
+
+ (wisi-set-parse-try nil)
+ (wisi--run-parse)
+
+ ;; 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)))))
+ )
+
+ (if wisi-parse-failed
+ (progn
+ ;; primary indent failed
+ (setq wisi-indent-failed t)
+ (when (functionp wisi-indent-region-fallback)
+ (funcall wisi-indent-region-fallback begin end)))
+
+ (save-excursion
+ ;; Apply cached indents.
+ (goto-char begin)
+ (let ((wisi-indenting-p t))
+ (while (and (not (eobp))
+ (<= (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)))
+
+ (when
+ (and prev-indent-failed
+ (not wisi-indent-failed))
+ ;; Previous parse failed or indent was potentially
+ ;; ambiguous, this one is not.
+ (goto-char end-mark)
+ (run-hooks 'wisi-post-indent-fail-hook))
+ ))
+ ))
+
+(defun wisi-indent-line ()
+ "For `indent-line-function'."
+ (let ((savep (copy-marker (point)))
+ (to-indent nil))
+ (back-to-indentation)
+ (when (>= (point) savep)
+ (setq to-indent t))
+
+ (wisi-indent-region (line-beginning-position) (line-end-position))
+
+ (goto-char savep)
+ (when to-indent (back-to-indentation))
+ ))
+
+(defun wisi-repair-error-1 (data)
+ "Repair error reported in DATA (a ’wisi--parse-error’ or
’wisi--lexer-error’)"
+ (let ((wisi--parse-action 'navigate) ;; tell wisi-forward-token not to
compute indent stuff.
+ tok-2)
+ (cond
+ ((wisi--lexer-error-p data)
+ (goto-char (1+ (wisi--lexer-error-pos data)))
+ (insert (wisi--lexer-error-inserted data)))
+ ((wisi--parse-error-p data)
+ (dolist (repair (wisi--parse-error-repair data))
+ (goto-char (wisi--parse-error-repair-pos repair))
+ (dolist (tok-1 (wisi--parse-error-repair-deleted repair))
+ (setq tok-2 (wisi-forward-token))
+ (if (eq tok-1 (wisi-tok-token tok-2))
+ (delete-region (car (wisi-tok-region tok-2)) (cdr
(wisi-tok-region tok-2)))
+ (error "mismatched tokens: %d: parser %s, buffer %s %s"
+ (point) tok-1 (wisi-tok-token tok-2) (wisi-tok-region
tok-2))))
+
+ (dolist (id (wisi--parse-error-repair-inserted repair))
+ (insert (cdr (assoc id (wisi-elisp-lexer-id-alist wisi--lexer))))
+ (insert " "))
+ ))
+ )))
+
+(defun wisi-repair-error ()
+ "Repair the current error."
+ (interactive)
+ (let ((wisi-inhibit-parse t)) ;; don’t let the error list change while we
are processing it.
+ (if (= 1 (+ (length (wisi-parser-lexer-errors wisi--parser))
+ (length (wisi-parser-parse-errors wisi--parser))))
+ (progn
+ (wisi-goto-error)
+ (wisi-repair-error-1 (or (car (wisi-parser-lexer-errors wisi--parser))
+ (car (wisi-parser-parse-errors
wisi--parser)))))
+ (if (buffer-live-p wisi-error-buffer)
+ (let ((err
+ (with-current-buffer wisi-error-buffer
+ ;; 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")
+ ))))
+
+(defun wisi-repair-errors (&optional beg end)
+ "Repair errors reported by last parse.
+If non-nil, only repair errors in BEG END region."
+ (interactive)
+ (let ((wisi-inhibit-parse t)) ;; don’t let the error list change while we
are processing it.
+ (dolist (data (wisi-parser-lexer-errors wisi--parser))
+ (when (or (null beg)
+ (and (not (= 0 (wisi--lexer-error-inserted data)))
+ (wisi--lexer-error-pos data)
+ (<= beg (wisi--lexer-error-pos data))
+ (<= (wisi--lexer-error-pos data) end)))
+ (wisi-repair-error-1 data)))
+
+ (dolist (data (wisi-parser-parse-errors wisi--parser))
+ (when (or (null beg)
+ (and (wisi--parse-error-pos data)
+ (<= beg (wisi--parse-error-pos data))
+ (<= (wisi--parse-error-pos data) end)))
+ (wisi-repair-error-1 data)))
+ ))
+
+;;;; debugging
+
+(defun wisi-debug-keys ()
+ "Add debug key definitions to `global-map'."
+ (interactive)
+ (define-key global-map "\M-h" 'wisi-show-containing-or-previous-cache)
+ (define-key global-map "\M-i" 'wisi-show-indent)
+ (define-key global-map "\M-j" 'wisi-show-cache)
+ )
+
+(defun wisi-parse-buffer (&optional parse-action)
+ (interactive)
+ (unless parse-action (setq parse-action '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))
+
+ (cl-ecase parse-action
+ (face
+ (with-silent-modifications
+ (remove-text-properties
+ (point-min) (point-max)
+ (list
+ 'font-lock-face nil
+ 'fontified nil)))
+ (wisi-validate-cache (point-max) t parse-action)
+ (when (fboundp 'font-lock-ensure) (font-lock-ensure))) ;; emacs < 25
+
+ (navigate
+ (wisi-validate-cache (point-max) t parse-action))
+
+ (indent
+ (wisi-indent-region (point-min) (point-max)))
+ ))
+
+(defun wisi-time (func count &optional report-wait-time)
+ "call FUNC COUNT times, show total time"
+ (interactive "afunction \nncount ")
+
+ (let ((start-time (float-time))
+ (start-gcs gcs-done)
+ (cum-wait-time 0.0)
+ (i 0)
+ diff-time
+ diff-gcs)
+ (while (not (eq (1+ count) (setq i (1+ i))))
+ (save-excursion
+ (funcall func))
+ (when report-wait-time
+ (setq cum-wait-time (+ cum-wait-time
(wisi-process--parser-total-wait-time wisi--parser)))))
+ (setq diff-time (- (float-time) start-time))
+ (setq diff-gcs (- gcs-done start-gcs))
+ (if report-wait-time
+ (progn
+ (message "Total %f seconds, %d gcs; per iteration %f seconds %d gcs
%d responses %f wait"
+ diff-time
+ diff-gcs
+ (/ diff-time count)
+ (/ (float diff-gcs) count)
+ (wisi-process--parser-response-count wisi--parser)
+ (/ cum-wait-time count)))
+
+ (message "Total %f seconds, %d gcs; per iteration %f seconds %d gcs"
+ diff-time
+ diff-gcs
+ (/ diff-time count)
+ (/ (float diff-gcs) count))
+ ))
+ nil)
+
+(defun wisi-time-indent-middle-line-cold-cache (count &optional
report-wait-time)
+ (goto-char (point-min))
+ (forward-line (1- (/ (count-lines (point-min) (point-max)) 2)))
+ (let ((cum-wait-time 0.0))
+ (wisi-time
+ (lambda ()
+ (wisi-set-parse-try t 'indent)
+ (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)
+ (setq cum-wait-time (+ cum-wait-time
(wisi-process--parser-total-wait-time wisi--parser)))))
+ count
+ report-wait-time)
+ ))
+
+(defun wisi-time-indent-middle-line-warm-cache (count)
+ (wisi-set-parse-try t 'indent)
+ (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))
+ (wisi-indent-line)
+ (wisi-time #'wisi-indent-line count))
+
+(defun wisi-show-indent ()
+ "Show indent cache for current line."
+ (interactive)
+ (message "%s" (get-text-property (1- (line-beginning-position))
'wisi-indent)))
+
+(defun wisi-show-cache ()
+ "Show navigation and face caches, and applied faces, at point."
+ (interactive)
+ (message "%s:%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)
+ ))
+
+(defun wisi-show-containing-or-previous-cache ()
+ (interactive)
+ (let ((cache (wisi-get-cache (point))))
+ (if cache
+ (message "containing %s" (wisi-goto-containing cache t))
+ (message "previous %s" (wisi-backward-cache)))
+ ))
+
+(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)
+ "Set up a buffer for parsing files with wisi."
+ (when wisi--parser
+ (wisi-kill-parser))
+
+ (setq wisi--parser parser)
+ (setq wisi--lexer lexer)
+
+ (setq wisi--cache-max
+ (list
+ (cons 'face (copy-marker (point-min)))
+ (cons 'navigate (copy-marker (point-min)))
+ (cons 'indent (copy-marker (point-min)))))
+
+ (setq wisi--parse-try
+ (list
+ (cons 'face t)
+ (cons 'navigate t)
+ (cons 'indent t)))
+
+ ;; file local variables may have added opentoken, gnatprep
+ (setq wisi-indent-calculate-functions (append
wisi-indent-calculate-functions indent-calculate))
+ (set (make-local-variable 'indent-line-function) #'wisi-indent-line)
+ (set (make-local-variable 'indent-region-function) #'wisi-indent-region)
+ (set (make-local-variable 'forward-sexp-function) #'wisi-forward-sexp)
+
+ (setq wisi-post-indent-fail-hook post-indent-fail)
+ (setq wisi-indent-failed nil)
+
+ (add-hook 'before-change-functions #'wisi-before-change 'append t)
+ (add-hook 'after-change-functions #'wisi-after-change nil t)
+ (setq wisi--change-end (copy-marker (point-min) t))
+
+ ;; See comments above on syntax-propertize.
+ (when (< emacs-major-version 25) (syntax-propertize (point-max)))
+
+ ;; In Emacs >= 26, ‘run-mode-hooks’ (in the major mode function)
+ ;; runs ‘hack-local-variables’ after ’*-mode-hooks’; we need
+ ;; ‘wisi-post-local-vars’ to run after ‘hack-local-variables’.
+ (add-hook 'hack-local-variables-hook 'wisi-post-local-vars nil t)
+ )
+
+(defun wisi-post-local-vars ()
+ "See wisi-setup."
+ (setq hack-local-variables-hook (delq 'wisi-post-local-vars
hack-local-variables-hook))
+
+ (unless wisi-disable-face
+ (jit-lock-register #'wisi-fontify-region)))
+
+
+(provide 'wisi)
+;;; wisi.el ends here
diff --git a/wisitoken-bnf-generate.adb b/wisitoken-bnf-generate.adb
new file mode 100644
index 0000000..7569ffb
--- /dev/null
+++ b/wisitoken-bnf-generate.adb
@@ -0,0 +1,522 @@
+-- Abstract :
+--
+-- Parser for Wisi grammar files, producing Ada or Elisp source
+-- files for a parser.
+--
+-- Copyright (C) 2012 - 2015, 2017, 2018 Stephen Leake. 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
+-- 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.
+
+pragma License (Modified_GPL);
+
+with Ada.Command_Line;
+with Ada.Directories;
+with Ada.Exceptions;
+with Ada.Real_Time;
+with Ada.Strings.Fixed;
+with Ada.Strings.Maps;
+with Ada.Strings.Unbounded;
+with Ada.Text_IO;
+with GNAT.Traceback.Symbolic;
+with WisiToken.BNF.Generate_Utils;
+with WisiToken.BNF.Output_Ada;
+with WisiToken.BNF.Output_Ada_Common;
+with WisiToken.BNF.Output_Ada_Emacs;
+with WisiToken.BNF.Output_Elisp;
+with WisiToken.BNF.Output_Elisp_Common;
+with WisiToken.Generate.Packrat;
+with WisiToken.Generate.LR.LALR_Generate;
+with WisiToken.Generate.LR.LR1_Generate;
+with WisiToken.Parse.LR.Parser_No_Recover; -- for reading BNF file
+with WisiToken.Productions;
+with WisiToken.Text_IO_Trace;
+with WisiToken_Grammar_Runtime;
+with Wisitoken_Grammar_Actions;
+with Wisitoken_Grammar_Main;
+procedure WisiToken.BNF.Generate
+is
+ use all type Ada.Containers.Count_Type;
+
+ procedure Put_Usage
+ is
+ use Ada.Text_IO;
+ First : Boolean := True;
+ begin
+ -- verbosity meaning is actually determined by output choice;
+ -- they should be consistent with this description.
+ Put_Line (Standard_Error, "version 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);
+ Put_Line (Standard_Error, "The following grammar file directives control
parser generation:");
+ Put_Line (Standard_Error,
+ "%generate <algorithm> <output language> [<lexer>]
[<interface>] [text_rep]");
+ Put_Line (Standard_Error, " specify one of each generate parameter.
May be repeated.");
+ Put (Standard_Error, " algorithm: ");
+ for I of Generate_Algorithm_Image loop
+ if First then
+ First := False;
+ else
+ Put (Standard_Error, " | ");
+ end if;
+ Put (Standard_Error, I.all);
+ end loop;
+ New_Line (Standard_Error);
+
+ Put (Standard_Error, " output language: ");
+ First := True;
+ for I of Output_Language_Image loop
+ if First then
+ First := False;
+ else
+ Put (Standard_Error, " | ");
+ end if;
+ Put (Standard_Error, I.all);
+ end loop;
+ New_Line (Standard_Error);
+
+ Put_Line (Standard_Error, " interface: interface Process | Module");
+ Put_Line (Standard_Error, " only valid with Ada_Emacs:");
+ Put_Line (Standard_Error, " Process is for an external subprocess
communicating with Emacs.");
+ Put_Line (Standard_Error, " Module is for a dynamically loaded
Emacs module.");
+ Put (Standard_Error, " lexer: ");
+ First := True;
+ for I of Output_Language_Image loop
+ if First then
+ First := False;
+ else
+ Put (Standard_Error, " | ");
+ end if;
+ Put (Standard_Error, I.all);
+ end loop;
+ New_Line (Standard_Error);
+ Put_Line
+ (Standard_Error, " text_rep: output LR parse table in a text file,
not as source code; for large tables");
+
+ New_Line (Standard_Error);
+ Put_Line (Standard_Error, "options:");
+ Put_Line (Standard_Error, " --help: show this help");
+ Put_Line (Standard_Error, " -v level: sets verbosity (default 0):");
+ Put_Line (Standard_Error, " 0 - only error messages to standard
error");
+ Put_Line (Standard_Error, " 1 - add diagnostics to standard out");
+ Put_Line (Standard_Error, " 2 - more diagnostics to standard out,
ignore unused tokens, unknown conflicts");
+ Put_Line (Standard_Error, " --generate ...: override grammar file
%generate directive");
+ Put_Line (Standard_Error, " --suffix <string>; appended to grammar file
name");
+ Put_Line (Standard_Error,
+ " --test_main; generate standalone main program for running
the generated parser, modify file names");
+ Put_Line (Standard_Error, " --time; output execution time of various
stages");
+
+ end Put_Usage;
+
+ Language_Name : Ada.Strings.Unbounded.Unbounded_String; -- The
language the grammar defines
+ Output_File_Name_Root : Ada.Strings.Unbounded.Unbounded_String;
+ Suffix : Ada.Strings.Unbounded.Unbounded_String;
+ Test_Main : Boolean := False;
+
+ Command_Generate_Set : Generate_Set_Access; -- override grammar file
declarations
+
+ Trace : aliased WisiToken.Text_IO_Trace.Trace
(Wisitoken_Grammar_Actions.Descriptor'Access);
+ Input_Data : aliased WisiToken_Grammar_Runtime.User_Data_Type;
+ Grammar_Parser : WisiToken.Parse.LR.Parser_No_Recover.Parser;
+
+ Do_Time : Boolean := False;
+
+ procedure Use_Input_File (File_Name : in String)
+ is
+ use Ada.Strings.Unbounded;
+ use Ada.Text_IO;
+ begin
+ Output_File_Name_Root := +Ada.Directories.Base_Name (File_Name) & Suffix;
+
+ Wisitoken_Grammar_Main.Create_Parser
+ (Parser => Grammar_Parser,
+ Trace => Trace'Unchecked_Access,
+ User_Data => Input_Data'Unchecked_Access);
+
+ Grammar_Parser.Lexer.Reset_With_File (File_Name);
+
+ declare
+ Language_Name_Dir : constant Integer := Ada.Strings.Fixed.Index
+ (File_Name, Ada.Strings.Maps.To_Set ("/\"), Going =>
Ada.Strings.Backward);
+ Language_Name_Ext : constant Integer := Ada.Strings.Fixed.Index
(File_Name, ".wy");
+ begin
+ Language_Name := +WisiToken.BNF.Output_Elisp_Common.Elisp_Name_To_Ada
+ (File_Name
+ ((if Language_Name_Dir = 0
+ then File_Name'First
+ else Language_Name_Dir + 1) ..
+ Language_Name_Ext - 1),
+ Append_ID => False,
+ Trim => 0);
+ end;
+ exception
+ when Name_Error | Use_Error =>
+ raise Name_Error with "input file '" & File_Name & "' could not be
opened.";
+ end Use_Input_File;
+
+begin
+ declare
+ use Ada.Command_Line;
+ Arg_Next : Integer := 1;
+ begin
+ loop
+ exit when Argument (Arg_Next)(1) /= '-';
+
+ -- --help, -v first, then alphabetical
+
+ if Argument (Arg_Next) = "--help" then
+ Put_Usage;
+ return;
+
+ elsif Argument (Arg_Next) = "-v" then
+ Arg_Next := Arg_Next + 1;
+ WisiToken.Trace_Generate := Integer'Value (Argument (Arg_Next));
+ Arg_Next := Arg_Next + 1;
+
+ elsif Argument (Arg_Next) = "--generate" then
+ Arg_Next := Arg_Next + 1;
+ declare
+ Tuple : Generate_Tuple;
+ Done : Boolean := False;
+ begin
+ begin
+ Tuple.Gen_Alg := Generate_Algorithm'Value (Argument
(Arg_Next));
+ Arg_Next := Arg_Next + 1;
+ exception
+ when Constraint_Error =>
+ raise User_Error with "invalid value for
generator_algorithm: '" & Argument (Arg_Next) & ";";
+ end;
+ begin
+ Tuple.Out_Lang := To_Output_Language (Argument (Arg_Next));
+ Arg_Next := Arg_Next + 1;
+ end;
+
+ loop
+ exit when Done;
+ declare
+ Text : constant String := Argument (Arg_Next);
+ begin
+ if Text = "text_rep" then
+ Tuple.Text_Rep := True;
+ Arg_Next := Arg_Next + 1;
+
+ elsif (for some I of Lexer_Image => To_Lower (Text) =
I.all) then
+ Tuple.Lexer := To_Lexer (Text);
+ Arg_Next := Arg_Next + 1;
+
+ elsif (for some I in Valid_Interface =>
+ To_Lower (Text) = To_Lower
(Valid_Interface'Image (I)))
+ then
+ Tuple.Interface_Kind :=
WisiToken.BNF.Valid_Interface'Value (Text);
+ Arg_Next := Arg_Next + 1;
+
+ else
+ Done := True;
+ end if;
+ end;
+ end loop;
+
+ Add (Command_Generate_Set, Tuple);
+ end;
+
+ elsif Argument (Arg_Next) = "--suffix" then
+ Arg_Next := Arg_Next + 1;
+ Suffix := +Argument (Arg_Next);
+ Arg_Next := Arg_Next + 1;
+
+ elsif Argument (Arg_Next) = "--test_main" then
+ Arg_Next := Arg_Next + 1;
+ Test_Main := True;
+
+ elsif Argument (Arg_Next) = "--time" then
+ Arg_Next := Arg_Next + 1;
+ Do_Time := True;
+
+ else
+ raise User_Error with "invalid argument '" & Argument (Arg_Next) &
"'";
+ end if;
+ end loop;
+
+ Use_Input_File (Argument (Arg_Next));
+
+ if Arg_Next /= Argument_Count then
+ raise User_Error with "arg count" & Integer'Image (Argument_Count) &
+ " different from expected count" & Integer'Image (Arg_Next);
+ end if;
+ end;
+
+ begin
+ Grammar_Parser.Parse;
+ exception
+ when WisiToken.Syntax_Error =>
+ Grammar_Parser.Put_Errors;
+ raise;
+ when E : WisiToken.Parse_Error =>
+ WisiToken.Generate.Put_Error (Ada.Exceptions.Exception_Message (E));
+ raise;
+ end;
+
+ declare
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+ use Ada.Text_IO;
+
+ -- Create a .parse_table file unless verbosity > 0
+ Parse_Table_File : File_Type;
+
+ Generate_Set : Generate_Set_Access;
+ Multiple_Tuples : Boolean;
+
+ Lexer_Done : Lexer_Set := (others => False);
+
+ -- In general, all of the data in Generate_Utils.Generate_Data
+ -- depends on the generate tuple parameters. However, if
+ -- 'If_Lexer_Present' is false, then they don't depend on the lexer,
+ -- and if 'If_Parser_Present' is false, then they don't depend on the
+ -- Gen_Alg, except for the parser table. But it's not worth trying to
+ -- cache results in those cases; they only happen in test grammars,
+ -- which are small.
+
+ procedure Parse_Check (Lexer : in Lexer_Type; Parser : in
Generate_Algorithm)
+ is begin
+ Input_Data.User_Parser := Parser;
+ Input_Data.User_Lexer := Lexer;
+ -- Specifying the parser and lexer can change the parsed grammar, due
+ -- to %if {parser | lexer}.
+
+ Input_Data.Reset;
+ Grammar_Parser.Execute_Actions;
+ -- Ensures Input_Data.User_{Parser|Lexer} are set if needed.
+
+ if Input_Data.Rule_Count = 0 or Input_Data.Tokens.Rules.Length = 0
then
+ raise WisiToken.Grammar_Error with "no rules";
+ end if;
+
+ end Parse_Check;
+
+ begin
+ if Command_Generate_Set = null then
+ -- Get the first quad from the input file
+ Parse_Check (None, None);
+
+ if Input_Data.Generate_Set = null then
+ raise User_Error with
+ WisiToken.Generate.Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, 1,
+ "generate algorithm, output_language, lexer, interface not
specified");
+ end if;
+
+ -- Input_Data.Generate_Set will be free'd and regenerated if
+ -- Parse_Check is called, but the content won't change. So make a
+ -- copy.
+ Generate_Set := new
WisiToken.BNF.Generate_Set'(Input_Data.Generate_Set.all);
+ else
+ Generate_Set := Command_Generate_Set;
+ end if;
+
+ Multiple_Tuples := Generate_Set'Length > 1;
+
+ for Tuple of Generate_Set.all loop
+
+ Input_Data.User_Parser := Tuple.Gen_Alg;
+ Input_Data.User_Lexer := Tuple.Lexer;
+
+ Parse_Check (Input_Data.User_Lexer, Input_Data.User_Parser);
+
+ declare
+ use Ada.Real_Time;
+
+ Time_Start : Time;
+ Time_End : Time;
+
+ Generate_Data : aliased WisiToken.BNF.Generate_Utils.Generate_Data
:=
+ WisiToken.BNF.Generate_Utils.Initialize (Input_Data);
+
+ Packrat_Data : WisiToken.Generate.Packrat.Data
+ (Generate_Data.Descriptor.First_Terminal,
Generate_Data.Descriptor.First_Nonterminal,
+ Generate_Data.Descriptor.Last_Nonterminal);
+ begin
+ if not Lexer_Done (Input_Data.User_Lexer) then
+ Lexer_Done (Input_Data.User_Lexer) := True;
+ if Input_Data.User_Lexer = re2c_Lexer then
+ WisiToken.BNF.Output_Ada_Common.Create_re2c
+ (Input_Data, Tuple, Generate_Data, -Output_File_Name_Root,
Input_Data.User_Names.Regexps);
+ end if;
+ end if;
+
+ if WisiToken.Trace_Generate = 0 and Tuple.Gen_Alg /= External then
+ Create
+ (Parse_Table_File, Out_File,
+ -Output_File_Name_Root & "_" & To_Lower
(Generate_Algorithm'Image (Tuple.Gen_Alg)) &
+ (if Input_Data.If_Lexer_Present
+ then "_" & Lexer_Image (Input_Data.User_Lexer).all
+ else "") &
+ ".parse_table");
+ Set_Output (Parse_Table_File);
+ end if;
+
+ case Tuple.Gen_Alg is
+ when LALR =>
+
+ Time_Start := Clock;
+
+ Generate_Data.LR_Parse_Table :=
WisiToken.Generate.LR.LALR_Generate.Generate
+ (Generate_Data.Grammar,
+ Generate_Data.Descriptor.all,
+ Generate_Utils.To_Conflicts
+ (Generate_Data, Input_Data.Conflicts,
Input_Data.Grammar_Lexer.File_Name),
+ Generate_Utils.To_McKenzie_Param
+ (Generate_Data, Input_Data.McKenzie_Recover,
Input_Data.Grammar_Lexer.File_Name),
+ Put_Parse_Table => True);
+
+ if Do_Time then
+ Time_End := Clock;
+
+ Put_Line
+ (Standard_Error,
+ "LALR " & Lexer_Image (Tuple.Lexer).all & " generate
time:" &
+ Duration'Image (To_Duration (Time_End - Time_Start)));
+ end if;
+
+ Generate_Data.Parser_State_Count :=
+ Generate_Data.LR_Parse_Table.State_Last -
Generate_Data.LR_Parse_Table.State_First + 1;
+ WisiToken.BNF.Generate_Utils.Count_Actions (Generate_Data);
+ WisiToken.BNF.Generate_Utils.Put_Stats (Input_Data,
Generate_Data);
+
+ when LR1 =>
+ Time_Start := Clock;
+
+ Generate_Data.LR_Parse_Table :=
WisiToken.Generate.LR.LR1_Generate.Generate
+ (Generate_Data.Grammar,
+ Generate_Data.Descriptor.all,
+ Generate_Utils.To_Conflicts
+ (Generate_Data, Input_Data.Conflicts,
Input_Data.Grammar_Lexer.File_Name),
+ Generate_Utils.To_McKenzie_Param
+ (Generate_Data, Input_Data.McKenzie_Recover,
Input_Data.Grammar_Lexer.File_Name),
+ Put_Parse_Table => True);
+
+ if Do_Time then
+ Time_End := Clock;
+
+ Put_Line
+ (Standard_Error,
+ "LR1 " & Lexer_Image (Tuple.Lexer).all & " generate
time:" &
+ Duration'Image (To_Duration (Time_End - Time_Start)));
+ end if;
+
+ Generate_Data.Parser_State_Count :=
+ Generate_Data.LR_Parse_Table.State_Last -
Generate_Data.LR_Parse_Table.State_First + 1;
+ WisiToken.BNF.Generate_Utils.Count_Actions (Generate_Data);
+ WisiToken.BNF.Generate_Utils.Put_Stats (Input_Data,
Generate_Data);
+
+ when Packrat_Generate_Algorithm =>
+ -- The only significant computation done for Packrat is First,
done
+ -- in Initialize; not worth timing.
+
+ Packrat_Data := WisiToken.Generate.Packrat.Initialize
+ (Input_Data.Grammar_Lexer.File_Name, Generate_Data.Grammar,
Generate_Data.Source_Line_Map,
+ Generate_Data.Descriptor.First_Terminal);
+
+ Put_Line ("Tokens:");
+ WisiToken.Put_Tokens (Generate_Data.Descriptor.all);
+ New_Line;
+ Put_Line ("Productions:");
+ WisiToken.Productions.Put (Generate_Data.Grammar,
Generate_Data.Descriptor.all);
+
+ Packrat_Data.Check_All (Generate_Data.Descriptor.all);
+
+ when External =>
+ null;
+ end case;
+
+ if WisiToken.Trace_Generate = 0 and Tuple.Gen_Alg /= External then
+ Set_Output (Standard_Output);
+ Close (Parse_Table_File);
+ end if;
+
+ if WisiToken.Generate.Error then
+ raise WisiToken.Grammar_Error with "errors: aborting";
+ end if;
+
+ case Tuple.Gen_Alg is
+ when LR_Generate_Algorithm =>
+ if Tuple.Text_Rep then
+ WisiToken.Generate.LR.Put_Text_Rep
+ (Generate_Data.LR_Parse_Table.all,
+ -Output_File_Name_Root & "_" &
+ To_Lower (Generate_Algorithm_Image (Tuple.Gen_Alg).all)
&
+ "_parse_table.txt",
+ Generate_Data.Action_Names.all,
Generate_Data.Check_Names.all);
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ case Tuple.Out_Lang is
+ when Ada_Lang =>
+ WisiToken.BNF.Output_Ada
+ (Input_Data, -Output_File_Name_Root, Generate_Data,
Packrat_Data, Tuple, Test_Main, Multiple_Tuples);
+
+ when Ada_Emacs_Lang =>
+ WisiToken.BNF.Output_Ada_Emacs
+ (Input_Data, -Output_File_Name_Root, Generate_Data,
Packrat_Data, Tuple, Test_Main, Multiple_Tuples,
+ -Language_Name);
+
+ when Elisp_Lang =>
+ WisiToken.BNF.Output_Elisp (Input_Data, -Output_File_Name_Root,
Generate_Data, Packrat_Data, Tuple);
+
+ end case;
+ end;
+ end loop;
+ end;
+exception
+when WisiToken.Syntax_Error | WisiToken.Parse_Error =>
+ -- error message already output
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+
+when E : User_Error =>
+ declare
+ use Ada.Command_Line;
+ use Ada.Exceptions;
+ use Ada.Text_IO;
+ begin
+ Put_Line (Standard_Error, Exception_Message (E));
+ Put_Command_Line (Ada_Comment);
+ Set_Exit_Status (Failure);
+ Put_Usage;
+ end;
+
+when E : WisiToken.Grammar_Error =>
+ -- error message not already output
+ declare
+ use Ada.Command_Line;
+ use Ada.Exceptions;
+ use Ada.Text_IO;
+ begin
+ Put_Line (Standard_Error, Exception_Message (E));
+ Set_Exit_Status (Failure);
+ end;
+
+when E : others =>
+ -- IMPROVEME: for some exceptions, Error message already output via
wisi.utils.Put_Error
+ declare
+ use Ada.Text_IO;
+ use Ada.Exceptions;
+ use Ada.Command_Line;
+ begin
+ Put_Line (Standard_Error, Exception_Name (E) & ": " & Exception_Message
(E));
+ Put_Line (Standard_Error, GNAT.Traceback.Symbolic.Symbolic_Traceback
(E));
+ Set_Exit_Status (Failure);
+ end;
+
+end WisiToken.BNF.Generate;
diff --git a/wisitoken-bnf-generate_grammar.adb
b/wisitoken-bnf-generate_grammar.adb
new file mode 100644
index 0000000..03ef661
--- /dev/null
+++ b/wisitoken-bnf-generate_grammar.adb
@@ -0,0 +1,86 @@
+-- Abstract :
+--
+-- Output Ada source code to recreate Grammar.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Text_IO; use Ada.Text_IO;
+with WisiToken.Generate;
+with WisiToken.Productions;
+procedure WisiToken.BNF.Generate_Grammar
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Action_Names : in WisiToken.Names_Array_Array)
+is
+ use all type Ada.Containers.Count_Type;
+ use Ada.Strings.Unbounded;
+ use WisiToken.Generate;
+ use WisiToken.Productions;
+ Text : Unbounded_String;
+ Need_Comma : Boolean := False;
+begin
+ Indent_Line ("Grammar.Set_First (" & Trimmed_Image (Grammar.First_Index) &
");");
+ Indent_Line ("Grammar.Set_Last (" & Trimmed_Image (Grammar.Last_Index) &
");");
+
+ for Prod of Grammar loop
+ Indent_Line ("declare");
+ Indent_Line (" Prod : Instance;");
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+ Indent_Line ("Prod.LHS := " & Trimmed_Image (Prod.LHS) & ";");
+ Indent_Line ("Prod.RHSs.Set_First (0);");
+ Indent_Line ("Prod.RHSs.Set_Last (" & Trimmed_Image
(Prod.RHSs.Last_Index) & ");");
+ for RHS_Index in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
+ declare
+ RHS : Right_Hand_Side renames Prod.RHSs (RHS_Index);
+ begin
+ Indent_Line ("declare");
+ Indent_Line (" RHS : Right_Hand_Side;");
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+ if RHS.Tokens.Length > 0 then
+ Indent_Line ("RHS.Tokens.Set_First (1);");
+ Indent_Line ("RHS.Tokens.Set_Last (" & Trimmed_Image (Prod.RHSs
(RHS_Index).Tokens.Last_Index) & ");");
+
+ if RHS.Tokens.Length = 1 then
+ Indent_Line ("To_Vector ((1 => " & Trimmed_Image (RHS.Tokens
(1)) & "), RHS.Tokens);");
+ else
+ Need_Comma := False;
+ Text := +"To_Vector ((";
+ for ID of RHS.Tokens loop
+ if Need_Comma then
+ Text := Text & ", ";
+ else
+ Need_Comma := True;
+ end if;
+ Text := Text & Trimmed_Image (ID);
+ end loop;
+ Text := Text & "), RHS.Tokens);";
+ Indent_Wrap (-Text);
+ end if;
+ end if;
+ if Action_Names (Prod.LHS) /= null and then Action_Names
(Prod.LHS)(RHS_Index) /= null then
+ Indent_Line ("RHS.Action := " & Action_Names
(Prod.LHS)(RHS_Index).all & "'Access;");
+ end if;
+ Indent_Line ("Prod.RHSs (" & Trimmed_Image (RHS_Index) & ") :=
RHS;");
+ Indent := Indent - 3;
+ Indent_Line ("end;");
+ end;
+ end loop;
+ Indent_Line ("Grammar (" & Trimmed_Image (Prod.LHS) & ") := Prod;");
+ Indent := Indent - 3;
+ Indent_Line ("end;");
+ end loop;
+end WisiToken.BNF.Generate_Grammar;
diff --git a/wisitoken-bnf-generate_packrat.adb
b/wisitoken-bnf-generate_packrat.adb
new file mode 100644
index 0000000..ee43b16
--- /dev/null
+++ b/wisitoken-bnf-generate_packrat.adb
@@ -0,0 +1,331 @@
+-- Abstract :
+--
+-- Generate Ada code for a Packrat parser.
+--
+-- References:
+--
+-- See wisitoken-parse-packrat.ads.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Text_IO; use Ada.Text_IO;
+with WisiToken.BNF.Generate_Utils;
+with WisiToken.Generate.Packrat;
+with WisiToken.Productions;
+procedure WisiToken.BNF.Generate_Packrat
+ (Data : in WisiToken.Generate.Packrat.Data;
+ Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data)
+is
+ use WisiToken.Generate;
+
+ Descriptor : WisiToken.Descriptor renames Generate_Data.Descriptor.all;
+ Action_Names : Names_Array_Array renames Generate_Data.Action_Names.all;
+
+ subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+
+ -- FIXME: optimize memoizing? small productions not worth the memory cost?
+ -- or just use langkit space optimization.
+
+ function Parser_Name (Nonterm : in Token_ID) return String
+ is begin
+ return "Parse_" & Image (Nonterm, Descriptor);
+ end Parser_Name;
+
+ procedure Put_Parser_Spec (Name : in String)
+ is begin
+ Indent_Line ("function " & Name);
+ Indent_Start (" (Parser : in out Generated.Parser; Last_Pos : in
Base_Token_Index) return Result_Type");
+ end Put_Parser_Spec;
+
+ function Var_Suffix (I, J : in Integer) return String
+ is begin
+ return Trimmed_Image (I) & '_' & Trimmed_Image (J);
+ end Var_Suffix;
+
+ procedure Generate_Parser_Body (Prod : in Productions.Instance)
+ is
+ use all type Ada.Containers.Count_Type;
+
+ Result_ID : constant String := Trimmed_Image (Prod.LHS);
+ begin
+ -- We use gotos and function scope vars rather than nested if/declare
+ -- to avoid excessive indenting for long productions.
+
+ Put_Parser_Spec (Parser_Name (Prod.LHS)); New_Line;
+ Indent_Line ("is");
+ Indent := Indent + 3;
+
+ Indent_Line ("Descriptor : WisiToken.Descriptor renames
Parser.Trace.Descriptor.all;");
+ Indent_Line ("Start_Pos : constant Token_Index := Last_Pos + 1; --
first token in current nonterm");
+ Indent_Line ("Pos : Base_Token_Index := Last_Pos; -- last token
parsed.");
+
+ for RHS_Index in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
+ declare
+ RHS : Productions.Right_Hand_Side renames Prod.RHSs (RHS_Index);
+ begin
+ for Token_Index in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index
loop
+ if RHS.Tokens (Token_Index) in Descriptor.First_Terminal ..
Descriptor.Last_Terminal then
+ Indent_Line ("Pos_" & Var_Suffix (RHS_Index, Token_Index) &
" : Token_Index;");
+ else
+ Indent_Line ("Memo_" & Var_Suffix (RHS_Index, Token_Index) &
" : Memo_Entry;");
+ end if;
+ end loop;
+ end;
+ end loop;
+
+ if Data.Direct_Left_Recursive (Prod.LHS) then
+ Indent_Line ("Pos_Recurse_Last : Base_Token_Index := Last_Pos;");
+ Indent_Line ("Result_Recurse : Memo_Entry;");
+ end if;
+
+ Indent := Indent - 3;
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+
+ Indent_Line ("if Pos = Parser.Terminals.Last_Index then");
+ Indent_Line (" return (State => Failure);");
+ Indent_Line ("end if;");
+ Indent_Line ("declare");
+ Indent_Line (" Memo : Memo_Entry renames Parser.Derivs (" & Result_ID
& ")(Start_Pos);");
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+ Indent_Line ("case Memo.State is");
+ Indent_Line ("when Success =>");
+ Indent_Line (" return Parser.Derivs (" & Result_ID & ")(Start_Pos);");
+ Indent_Line ("when Failure =>");
+
+ -- FIXME: Could simplify this when not doing left recursion
+ Indent_Line (" goto RHS_" & Trimmed_Image (Prod.RHSs.Last_Index) &
"_Fail;");
+
+ Indent_Line ("when No_Result =>");
+ Indent_Line (" if Memo.Recursive then");
+ Indent_Start (" raise Recursive with Image (" & Result_ID & ",
Descriptor) &");
+ Put_Line (" Token_Index'Image (Start_Pos) & "": recursive"";");
+ Indent_Line (" end if;");
+ Indent_Line (" Memo.Recursive := True;");
+ Indent_Line ("end case;");
+ Indent := Indent - 3;
+ Indent_Line ("end;");
+ New_Line;
+
+ if Data.Direct_Left_Recursive (Prod.LHS) then
+ -- This is the top of the 'while' loop in [warth 2008] figure 3
Grow-LR.
+ Indent_Line ("Parser.Derivs (" & Result_ID & ").Replace_Element
(Start_Pos, (State => Failure));");
+ Indent_Line ("<<Recurse_Start>>");
+ end if;
+
+ for RHS_Index in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
+ declare
+ RHS : Productions.Right_Hand_Side renames Prod.RHSs (RHS_Index);
+
+ procedure Finish
+ is begin
+ if Data.Direct_Left_Recursive (Prod.LHS) then
+ Indent_Line ("Result_Recurse :=");
+ Indent := Indent + 2;
+ else
+ Indent_Line ("Parser.Derivs (" & Result_ID &
").Replace_Element");
+ Indent_Line (" (Start_Pos,");
+ Indent := Indent + 3;
+ end if;
+ Indent_Line ("(State => Success,");
+ Indent_Line (" Result => Parser.Tree.Add_Nonterm");
+
+ Indent := Indent + 3;
+ Indent_Line ("(Production => (" & Result_ID & ", " &
Trimmed_Image (RHS_Index) & "),");
+ Indent_Line
+ (" Action => " &
+ (if Action_Names (Prod.LHS) = null or else Action_Names
(Prod.LHS)(RHS_Index) = null
+ then "null,"
+ else Action_Names (Prod.LHS)(RHS_Index).all &
"'Access,"));
+
+ if RHS.Tokens.Length = 0 then
+ Indent_Line (" Children => (1 .. 0 =>
Syntax_Trees.Invalid_Node_Index),");
+
+ elsif RHS.Tokens.Length = 1 then
+ Indent_Start (" Children => ");
+ if RHS.Tokens (RHS.Tokens.First_Index) in Terminal then
+ Put ("(1 => Tree_Index (Pos_" & Var_Suffix (RHS_Index,
RHS.Tokens.First_Index) & ")),");
+ else
+ Put ("(1 => Memo_" & Var_Suffix (RHS_Index,
RHS.Tokens.First_Index) & ".Result),");
+ end if;
+
+ else
+ Indent_Line (" Children =>");
+
+ for Token_Index in RHS.Tokens.First_Index ..
RHS.Tokens.Last_Index loop
+ if RHS.Tokens (Token_Index) in Terminal then
+ Indent_Start
+ ((if Token_Index = RHS.Tokens.First_Index
+ then " ("
+ else " ") &
+ "Tree_Index (Pos_" & Var_Suffix (RHS_Index,
Token_Index) & ")");
+ else
+ Indent_Start
+ ((if Token_Index = RHS.Tokens.First_Index
+ then " ("
+ else " ") &
+ "Memo_" & Var_Suffix (RHS_Index, Token_Index) &
".Result");
+ end if;
+ if Token_Index = RHS.Tokens.Last_Index then
+ Put_Line ("),");
+ else
+ Put_Line (",");
+ end if;
+ end loop;
+ end if;
+
+ Indent_Line (" Default_Virtual => False),");
+ Indent := Indent - 3;
+ Indent_Start (" Last_Token => Pos)");
+
+ if Data.Direct_Left_Recursive (Prod.LHS) then
+ Put_Line (";");
+ Indent := Indent - 2;
+ Indent_Line ("goto Finish;");
+ else
+ Put_Line (");");
+ Indent := Indent - 3;
+ Indent_Line ("goto Succeed;");
+ end if;
+ end Finish;
+
+ begin
+ Indent_Wrap_Comment (Productions.Image (Prod.LHS, RHS_Index,
RHS.Tokens, Descriptor), Ada_Comment);
+ Indent_Line ("Pos := Last_Pos;");
+
+ if RHS.Tokens.Length = 0 then
+ Finish;
+ else
+ for Token_Index in RHS.Tokens.First_Index ..
RHS.Tokens.Last_Index loop
+ declare
+ ID : constant String := Trimmed_Image (RHS.Tokens
(Token_Index));
+ Var_Suf : constant String := Var_Suffix (RHS_Index,
Token_Index);
+ begin
+ if RHS.Tokens (Token_Index) in Terminal then
+ Indent_Line ("if Parser.Terminals (Pos + 1).ID = " &
ID & " then");
+ Indent := Indent + 3;
+ Indent_Line ("Pos := Pos + 1;");
+ Indent_Line ("Pos_" & Var_Suf & " := Pos;");
+ if Token_Index = RHS.Tokens.Last_Index then
+ Finish;
+ end if;
+ Indent := Indent - 3;
+ Indent_Line ("else");
+ Indent_Line (" goto RHS_" & Trimmed_Image
(RHS_Index) & "_Fail;");
+ Indent_Line ("end if;");
+
+ else -- nonterminal
+ Indent_Line
+ ("Memo_" & Var_Suf & " := Parse_" & Image
(RHS.Tokens (Token_Index), Descriptor) &
+ " (Parser, Pos);");
+ Indent_Line ("case Result_States'(Memo_" & Var_Suf &
".State) is");
+ Indent_Line ("when Success =>");
+ Indent := Indent + 3;
+ Indent_Line ("Pos := Memo_" & Var_Suf &
".Last_Token;");
+ if Token_Index = RHS.Tokens.Last_Index then
+ Finish;
+ end if;
+ Indent := Indent - 3;
+ Indent_Line ("when Failure =>");
+ Indent_Line (" goto RHS_" & Trimmed_Image
(RHS_Index) & "_Fail;");
+ Indent_Line ("end case;");
+ end if;
+ end;
+ end loop;
+ end if;
+
+ Indent_Line ("<<RHS_" & Trimmed_Image (RHS_Index) & "_Fail>>");
+ New_Line;
+ end;
+ end loop;
+
+ -- We get here if the last alternative fails.
+ if Data.Direct_Left_Recursive (Prod.LHS) then
+ Indent_Line ("Result_Recurse := (State => Failure);");
+ else
+ Indent_Line ("Parser.Derivs (" & Result_ID & ").Replace_Element
(Start_Pos, (State => Failure));");
+ Indent_Line ("return Parser.Derivs (" & Result_ID & ")(Start_Pos);");
+ end if;
+
+ if Data.Direct_Left_Recursive (Prod.LHS) then
+ Indent_Line ("<<Finish>>");
+ Indent_Line ("if Result_Recurse.State = Success then");
+ Indent := Indent + 3;
+ Indent_Line ("if Pos > Pos_Recurse_Last then");
+ -- made progress, try again
+ Indent := Indent + 3;
+ Indent_Line ("Parser.Derivs (" & Result_ID & ").Replace_Element
(Start_Pos, Result_Recurse);");
+ Indent_Line ("Pos_Recurse_Last := Pos;");
+ Indent_Line ("if WisiToken.Trace_Parse > Detail then");
+ Indent_Line (" Parser.Trace.Put_Line");
+ Indent_Line
+ (" (Parser.Tree.Image (Result_Recurse.Result, Descriptor,
Include_Children => True));");
+ Indent_Line ("end if;");
+ Indent_Line ("goto Recurse_Start;");
+ Indent := Indent - 3;
+ Indent_Line ("elsif Pos = Pos_Recurse_Last and then
Parser.Tree.Is_Empty (Result_Recurse.Result) then");
+ -- Parse succeeded producing an empty nonterm; don't try again. This
+ -- special case is not in [warth 2008].
+ Indent_Line (" Parser.Derivs (8).Replace_Element (Start_Pos,
Result_Recurse);");
+ Indent_Line ("end if;");
+ Indent := Indent - 3;
+ Indent_Line ("end if;");
+ end if;
+ New_Line;
+
+ if not Data.Direct_Left_Recursive (Prod.LHS) then
+ Indent_Line ("<<Succeed>>");
+ Indent_Line ("if WisiToken.Trace_Parse > Detail then");
+ Indent := Indent + 3;
+ Indent_Line ("Parser.Trace.Put_Line");
+ Indent_Line (" (Parser.Tree.Image");
+ Indent_Line
+ (" (Parser.Derivs (" & Result_ID & ")(Start_Pos).Result,
Descriptor, Include_Children => True));");
+ Indent := Indent - 3;
+ Indent_Line ("end if;");
+ end if;
+
+ Indent_Line ("return Parser.Derivs (" & Result_ID & ")(Start_Pos);");
+ Indent := Indent - 3;
+ Indent_Line ("end " & Parser_Name (Prod.LHS) & ";");
+ New_Line;
+ end Generate_Parser_Body;
+
+begin
+ Indent_Line ("use WisiToken;");
+ Indent_Line ("use WisiToken.Parse.Packrat;");
+ Indent_Line ("use WisiToken.Parse.Packrat.Generated;");
+
+ for Prod of Data.Grammar loop
+ Put_Parser_Spec (Parser_Name (Prod.LHS)); Put_Line (";");
+ end loop;
+ New_Line;
+
+ for Prod of Data.Grammar loop
+ Generate_Parser_Body (Prod);
+ end loop;
+
+ Indent_Line ("function Parse_wisitoken_accept_1");
+ Indent_Line
+ -- WORKAROUND: using Parse.Packrat.Parser'Class here generates GNAT bug
box with GPL 2018
+ (" (Parser : in out WisiToken.Parse.Base_Parser'Class; Last_Pos : in
Base_Token_Index) return Result_Type");
+ Indent_Line ("is begin");
+ Indent_Line (" return Parse_wisitoken_accept (Generated.Parser (Parser),
Last_Pos);");
+ Indent_Line ("end Parse_wisitoken_accept_1;");
+ New_Line;
+
+end WisiToken.BNF.Generate_Packrat;
diff --git a/wisitoken-bnf-generate_utils.adb b/wisitoken-bnf-generate_utils.adb
new file mode 100644
index 0000000..01bc419
--- /dev/null
+++ b/wisitoken-bnf-generate_utils.adb
@@ -0,0 +1,818 @@
+-- Abstract :
+--
+-- see spec
+--
+-- Copyright (C) 2014, 2015, 2017, 2018 All Rights Reserved.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This program is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
+-- MA 02110-1335, USA.
+
+pragma License (GPL);
+
+with Ada.Exceptions;
+with Ada.Text_IO;
+with WisiToken.Generate; use WisiToken.Generate;
+with WisiToken.Syntax_Trees;
+with WisiToken.Wisi_Ada;
+package body WisiToken.BNF.Generate_Utils is
+
+ -- For Constant_Reference
+ Aliased_EOI_Name : aliased constant
Ada.Strings.Unbounded.Unbounded_String := +EOI_Name;
+ Aliased_WisiToken_Accept_Name : aliased constant
Ada.Strings.Unbounded.Unbounded_String :=
+ +WisiToken_Accept_Name;
+
+ -- body specs, as needed.
+
+ ----------
+ -- Body subprograms
+
+ function Find_Kind (Data : aliased Generate_Data; Target_Kind : in String)
return Token_ID
+ is begin
+ for Cursor in All_Tokens (Data).Iterate loop
+ if Kind (Cursor) = Target_Kind then
+ return ID (Cursor);
+ end if;
+ end loop;
+ return Invalid_Token_ID;
+ end Find_Kind;
+
+ function Name_1 (Cursor : in Token_Cursor) return String
+ is begin
+ -- This function is used to compute LR1_descriptor.Image
+ case Cursor.Kind is
+ when Non_Grammar_Kind =>
+ declare
+ Kind_Ref : constant
WisiToken.BNF.Token_Lists.Constant_Reference_Type :=
+ WisiToken.BNF.Token_Lists.Constant_Reference
(Cursor.Data.Tokens.Non_Grammar, Cursor.Token_Kind);
+
+ Item_Ref : constant String_Pair_Lists.Constant_Reference_Type :=
+ String_Pair_Lists.Constant_Reference (Kind_Ref.Element.Tokens,
Cursor.Token_Item);
+ begin
+ return -Item_Ref.Element.Name;
+ end;
+
+ when Terminals_Keywords =>
+ declare
+ Keyword_Ref : constant String_Pair_Lists.Constant_Reference_Type :=
+ String_Pair_Lists.Constant_Reference
(Cursor.Data.Tokens.Keywords, Cursor.Keyword);
+ begin
+ return -Keyword_Ref.Element.Name;
+ end;
+
+ when Terminals_Others =>
+ declare
+ Kind_Ref : constant
WisiToken.BNF.Token_Lists.Constant_Reference_Type :=
+ WisiToken.BNF.Token_Lists.Constant_Reference
(Cursor.Data.Tokens.Tokens, Cursor.Token_Kind);
+
+ Item_Ref : constant String_Pair_Lists.Constant_Reference_Type :=
+ String_Pair_Lists.Constant_Reference (Kind_Ref.Element.Tokens,
Cursor.Token_Item);
+ begin
+ return -Item_Ref.Element.Name;
+ end;
+
+ when EOI =>
+ return EOI_Name;
+
+ when WisiToken_Accept =>
+ return WisiToken_Accept_Name;
+
+ when Nonterminal =>
+ declare
+ Rule_Ref : constant Rule_Lists.Constant_Reference_Type :=
Rule_Lists.Constant_Reference
+ (Cursor.Data.Tokens.Rules, Cursor.Nonterminal);
+ begin
+ return -Rule_Ref.Element.Left_Hand_Side;
+ end;
+
+ when Done =>
+ raise SAL.Programmer_Error with "token cursor is done";
+ end case;
+ end Name_1;
+
+ procedure To_Grammar
+ (Data : aliased in out Generate_Data;
+ Source_File_Name : in String;
+ Start_Token : in String)
+ is
+ use WisiToken.Wisi_Ada;
+ Descriptor : WisiToken.Descriptor renames Data.Descriptor.all;
+ begin
+ Data.Grammar.Set_First (Descriptor.First_Nonterminal);
+ Data.Grammar.Set_Last (Descriptor.Last_Nonterminal);
+ Data.Source_Line_Map.Set_First (Descriptor.First_Nonterminal);
+ Data.Source_Line_Map.Set_Last (Descriptor.Last_Nonterminal);
+
+ Data.Action_Names := new Names_Array_Array (Descriptor.First_Nonterminal
.. Descriptor.Last_Nonterminal);
+ Data.Check_Names := new Names_Array_Array (Descriptor.First_Nonterminal
.. Descriptor.Last_Nonterminal);
+
+ pragma Assert (Descriptor.Accept_ID = Descriptor.First_Nonterminal);
+ begin
+ Data.Grammar (Descriptor.Accept_ID) :=
+ Descriptor.Accept_ID <= Only
+ (Find_Token_ID (Data, Start_Token) & Descriptor.EOF_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);
+ Data.Source_Line_Map (Descriptor.Accept_ID).RHS_Map.Set_Last (0);
+ Data.Source_Line_Map (Descriptor.Accept_ID).RHS_Map (0) :=
Line_Number_Type'First;
+ exception
+ when Not_Found =>
+ Put_Error
+ (Error_Message
+ (Source_File_Name, 1, "start token '" & (Start_Token) & "' not
found; need %start?"));
+ end;
+
+ for Rule of Data.Tokens.Rules loop
+ declare
+ RHS_Index : Natural := 0;
+ RHSs : WisiToken.Productions.RHS_Arrays.Vector;
+ LHS : Token_ID; -- not initialized for exception
handler
+ Action_Names : Names_Array (0 .. Integer
(Rule.Right_Hand_Sides.Length) - 1);
+ Action_All_Empty : Boolean := True;
+ Check_Names : Names_Array (0 .. Integer
(Rule.Right_Hand_Sides.Length) - 1);
+ Check_All_Empty : Boolean := True;
+ begin
+ LHS := Find_Token_ID (Data, -Rule.Left_Hand_Side);
+
+ RHSs.Set_First (RHS_Index);
+ RHSs.Set_Last (Natural (Rule.Right_Hand_Sides.Length) - 1);
+
+ Data.Source_Line_Map (LHS).Line := Rule.Source_Line;
+ Data.Source_Line_Map (LHS).RHS_Map.Set_First (RHSs.First_Index);
+ Data.Source_Line_Map (LHS).RHS_Map.Set_Last (RHSs.Last_Index);
+
+ for Right_Hand_Side of Rule.Right_Hand_Sides loop
+ declare
+ use Ada.Strings.Unbounded;
+ use all type Ada.Containers.Count_Type;
+ Tokens : WisiToken.Token_ID_Arrays.Vector;
+ I : Integer := 1;
+ begin
+ if Right_Hand_Side.Tokens.Length > 0 then
+ Tokens.Set_First (I);
+ Tokens.Set_Last (Integer (Right_Hand_Side.Tokens.Length));
+ for Token of Right_Hand_Side.Tokens loop
+ Tokens (I) := Find_Token_ID (Data, Token);
+ I := I + 1;
+ end loop;
+ end if;
+ RHSs (RHS_Index) := (Tokens => Tokens, Action => null, Check
=> null);
+ if Length (Right_Hand_Side.Action) > 0 then
+ Action_All_Empty := False;
+ Action_Names (RHS_Index) := new String'
+ (-Rule.Left_Hand_Side & '_' & WisiToken.Trimmed_Image
(RHS_Index));
+ end if;
+ if Length (Right_Hand_Side.Check) > 0 then
+ Check_All_Empty := False;
+ Check_Names (RHS_Index) := new String'
+ (-Rule.Left_Hand_Side & '_' & WisiToken.Trimmed_Image
(RHS_Index) & "_check");
+ end if;
+
+ Data.Source_Line_Map (LHS).RHS_Map (RHS_Index) :=
Right_Hand_Side.Source_Line;
+ exception
+ when E : Not_Found =>
+ -- From "&"
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Right_Hand_Side.Source_Line,
Ada.Exceptions.Exception_Message (E)));
+ end;
+ RHS_Index := RHS_Index + 1;
+ end loop;
+
+ Data.Grammar (LHS) := LHS <= RHSs;
+ if not Action_All_Empty then
+ Data.Action_Names (LHS) := new Names_Array'(Action_Names);
+ end if;
+ if not Check_All_Empty then
+ Data.Check_Names (LHS) := new Names_Array'(Check_Names);
+ end if;
+
+ exception
+ when E : Not_Found =>
+ -- From Find_Token_ID (left_hand_side)
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Rule.Source_Line,
Ada.Exceptions.Exception_Message (E)));
+ end;
+ end loop;
+
+ WisiToken.Generate.Check_Consistent (Data.Grammar, Descriptor,
Source_File_Name);
+ end To_Grammar;
+
+ ----------
+ -- Public subprograms, declaration order
+
+ function Initialize (Input_Data : aliased in
WisiToken_Grammar_Runtime.User_Data_Type) return Generate_Data
+ is
+ EOF_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
+ return Result : aliased Generate_Data :=
+ (Tokens => Input_Data.Tokens'Access,
+
+ Descriptor => new WisiToken.Descriptor
+ (First_Terminal =>
+ (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)),
+
+ others => <>)
+ do
+ Result.Descriptor.Case_Insensitive :=
Input_Data.Language_Params.Case_Insensitive;
+ Result.Descriptor.New_Line_ID := Find_Kind (Result, "new-line");
+ Result.Descriptor.Comment_ID := Find_Kind (Result, "comment");
+ Result.Descriptor.Left_Paren_ID := Find_Kind (Result,
"left-paren");
+ Result.Descriptor.Right_Paren_ID := Find_Kind (Result,
"right-paren");
+ Result.Descriptor.String_1_ID := Find_Kind (Result,
"string-single");
+ Result.Descriptor.String_2_ID := Find_Kind (Result,
"string-double");
+
+ Result.Descriptor.Embedded_Quote_Escape_Doubled :=
Input_Data.Language_Params.Embedded_Quote_Escape_Doubled;
+
+ -- Image set in loop below, which also updates these widths.
+ Result.Descriptor.Terminal_Image_Width := 0;
+ Result.Descriptor.Image_Width := 0;
+
+ Result.Descriptor.Last_Lookahead :=
+ (case (Input_Data.User_Parser) is
+ when None => raise
SAL.Programmer_Error,
+ when LR1 =>
Result.Descriptor.Last_Terminal,
+ when LALR =>
Result.Descriptor.First_Nonterminal,
+ when Packrat_Generate_Algorithm | External => Invalid_Token_ID);
+
+ for Cursor in All_Tokens (Result).Iterate loop
+ Result.Descriptor.Image (ID (Cursor)) := new String'(Name_1
(Cursor));
+ end loop;
+
+ for ID in Result.Descriptor.Image'Range loop
+ if ID in Result.Descriptor.First_Terminal ..
Result.Descriptor.Last_Terminal then
+ if Result.Descriptor.Image (ID).all'Length >
Result.Descriptor.Terminal_Image_Width then
+ Result.Descriptor.Terminal_Image_Width :=
Result.Descriptor.Image (ID).all'Length;
+ end if;
+ end if;
+
+ if Result.Descriptor.Image (ID).all'Length >
Result.Descriptor.Image_Width then
+ Result.Descriptor.Image_Width := Result.Descriptor.Image
(ID).all'Length;
+ end if;
+ end loop;
+
+ To_Grammar (Result, Input_Data.Grammar_Lexer.File_Name,
-Input_Data.Language_Params.Start_Token);
+ end return;
+ end Initialize;
+
+ function Find_Token_ID (Data : aliased in Generate_Data; Token : in String)
return Token_ID
+ is begin
+ for Cursor in All_Tokens (Data).Iterate loop
+ if Name (Cursor) = Token then
+ return ID (Cursor);
+ end if;
+ end loop;
+ raise Not_Found with "token '" & Token & "' not found";
+ end Find_Token_ID;
+
+ function All_Tokens (Data : aliased in Generate_Data) return Token_Container
+ is begin
+ return (Data => Data'Access);
+ end All_Tokens;
+
+ function Constant_Reference
+ (Container : aliased in Token_Container'Class;
+ Cursor : in Token_Cursor)
+ return Token_Constant_Reference_Type
+ is begin
+ case Cursor.Kind is
+ when Non_Grammar_Kind =>
+ declare
+ Token_Ref : constant
WisiToken.BNF.Token_Lists.Constant_Reference_Type :=
+ WisiToken.BNF.Token_Lists.Constant_Reference
(Container.Data.Tokens.Non_Grammar, Cursor.Token_Kind);
+
+ Item_Ref : constant String_Pair_Lists.Constant_Reference_Type :=
+ String_Pair_Lists.Constant_Reference (Token_Ref.Element.Tokens,
Cursor.Token_Item);
+ begin
+ return (Element => Item_Ref.Element.all.Name'Access);
+ end;
+
+ when Terminals_Keywords =>
+ declare
+ Keyword_Ref : constant String_Pair_Lists.Constant_Reference_Type :=
+ String_Pair_Lists.Constant_Reference
(Container.Data.Tokens.Keywords, Cursor.Keyword);
+ begin
+ return (Element => Keyword_Ref.Element.all.Name'Access);
+ end;
+
+ when Terminals_Others =>
+ declare
+ Token_Ref : constant
WisiToken.BNF.Token_Lists.Constant_Reference_Type :=
+ WisiToken.BNF.Token_Lists.Constant_Reference
(Container.Data.Tokens.Tokens, Cursor.Token_Kind);
+
+ Item_Ref : constant String_Pair_Lists.Constant_Reference_Type :=
+ String_Pair_Lists.Constant_Reference (Token_Ref.Element.Tokens,
Cursor.Token_Item);
+ begin
+ return (Element => Item_Ref.Element.all.Name'Access);
+ end;
+
+ when EOI =>
+ return (Element => Aliased_EOI_Name'Access);
+
+ when WisiToken_Accept =>
+ return (Element => Aliased_WisiToken_Accept_Name'Access);
+
+ when Nonterminal =>
+ declare
+ Rule_Ref : constant Rule_Lists.Constant_Reference_Type :=
Rule_Lists.Constant_Reference
+ (Container.Data.Tokens.Rules, Cursor.Nonterminal);
+ begin
+ return (Element => Rule_Ref.Element.all.Left_Hand_Side'Access);
+ end;
+
+ when Done =>
+ raise SAL.Programmer_Error with "token cursor is done";
+ end case;
+ end Constant_Reference;
+
+ type Token_Access_Constant is access constant Token_Container;
+ type Iterator is new Iterator_Interfaces.Forward_Iterator with record
+ Container : Token_Access_Constant;
+ Non_Grammar : Boolean;
+ Nonterminals : Boolean;
+ end record;
+
+ overriding function First (Object : Iterator) return Token_Cursor;
+ overriding function Next (Object : Iterator; Position : Token_Cursor)
return Token_Cursor;
+
+ overriding function First (Object : Iterator) return Token_Cursor
+ is begin
+ return First (Object.Container.Data.all, Object.Non_Grammar,
Object.Nonterminals);
+ end First;
+
+ overriding function Next (Object : Iterator; Position : Token_Cursor)
return Token_Cursor
+ is
+ Next_Position : Token_Cursor := Position;
+ begin
+ Next (Next_Position, Object.Nonterminals);
+ return Next_Position;
+ end Next;
+
+ function Iterate
+ (Container : aliased Token_Container;
+ Non_Grammar : in Boolean := True;
+ Nonterminals : in Boolean := True)
+ return Iterator_Interfaces.Forward_Iterator'Class
+ is begin
+ return Iterator'(Container'Access, Non_Grammar, Nonterminals);
+ end Iterate;
+
+ function Next_Kind_Internal
+ (Cursor : in out Token_Cursor;
+ Nonterminals : in Boolean)
+ return Boolean
+ is begin
+ -- Advance Cursor to the next kind; return True if any of that
+ -- kind exist, or kind is Done; False otherwise.
+ case Cursor.Kind is
+ when Non_Grammar_Kind =>
+
+ Cursor :=
+ (Data => Cursor.Data,
+ Kind => Terminals_Keywords,
+ ID => Cursor.Data.Descriptor.First_Terminal,
+ Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
+ Token_Item => String_Pair_Lists.No_Element,
+ Keyword => Cursor.Data.Tokens.Keywords.First,
+ Nonterminal => Rule_Lists.No_Element);
+
+ return String_Pair_Lists.Has_Element (Cursor.Keyword);
+
+ when Terminals_Keywords =>
+
+ Cursor :=
+ (Data => Cursor.Data,
+ Kind => Terminals_Others,
+ ID => Cursor.ID,
+ Token_Kind => Cursor.Data.Tokens.Tokens.First,
+ Token_Item => String_Pair_Lists.No_Element,
+ Keyword => String_Pair_Lists.No_Element,
+ Nonterminal => Rule_Lists.No_Element);
+
+ if WisiToken.BNF.Token_Lists.Has_Element (Cursor.Token_Kind) then
+ Cursor.Token_Item := Cursor.Data.Tokens.Tokens
(Cursor.Token_Kind).Tokens.First;
+ return WisiToken.BNF.String_Pair_Lists.Has_Element
(Cursor.Token_Item);
+ else
+ return False;
+ end if;
+
+ when Terminals_Others =>
+ Cursor :=
+ (Data => Cursor.Data,
+ Kind => EOI,
+ ID => Cursor.ID,
+ Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
+ Token_Item => String_Pair_Lists.No_Element,
+ Keyword => String_Pair_Lists.No_Element,
+ Nonterminal => Rule_Lists.No_Element);
+
+ return True;
+
+ when EOI =>
+ if Nonterminals then
+ if Rule_Lists.Has_Element (Cursor.Data.Tokens.Rules.First) then
+ Cursor :=
+ (Data => Cursor.Data,
+ Kind => WisiToken_Accept,
+ ID => Cursor.ID,
+ Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
+ Token_Item => String_Pair_Lists.No_Element,
+ Keyword => String_Pair_Lists.No_Element,
+ Nonterminal => Rule_Lists.No_Element);
+ else
+ Cursor.Kind := Done;
+ end if;
+ return True;
+ else
+ Cursor.Kind := Done;
+ return True;
+ end if;
+
+ when WisiToken_Accept =>
+ Cursor :=
+ (Data => Cursor.Data,
+ Kind => Nonterminal,
+ ID => Cursor.ID,
+ Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
+ Token_Item => String_Pair_Lists.No_Element,
+ Keyword => String_Pair_Lists.No_Element,
+ Nonterminal => Cursor.Data.Tokens.Rules.First);
+
+ -- Can't get here with no rules
+ return True;
+
+ when Nonterminal =>
+ Cursor.Kind := Done;
+
+ return True;
+
+ when Done =>
+ return True;
+ end case;
+ end Next_Kind_Internal;
+
+ function First
+ (Data : aliased in Generate_Data;
+ Non_Grammar : in Boolean;
+ Nonterminals : in Boolean)
+ return Token_Cursor
+ is
+ Cursor : Token_Cursor :=
+ (Data => Data'Access,
+ Kind => Non_Grammar_Kind,
+ ID => Token_ID'First,
+ Token_Kind => Data.Tokens.Non_Grammar.First,
+ Token_Item => String_Pair_Lists.No_Element,
+ Keyword => String_Pair_Lists.No_Element,
+ Nonterminal => Rule_Lists.No_Element);
+ begin
+ if Non_Grammar then
+ if WisiToken.BNF.Token_Lists.Has_Element (Cursor.Token_Kind) then
+ Cursor.Token_Item := Cursor.Data.Tokens.Non_Grammar
(Cursor.Token_Kind).Tokens.First;
+ if WisiToken.BNF.String_Pair_Lists.Has_Element (Cursor.Token_Item)
then
+ return Cursor;
+ end if;
+ end if;
+ end if;
+
+ -- There are no non_grammar tokens, or Non_Grammar false
+ loop
+ exit when Next_Kind_Internal (Cursor, Nonterminals);
+ end loop;
+ return Cursor;
+ end First;
+
+ procedure Next (Cursor : in out Token_Cursor; Nonterminals : in Boolean)
+ is begin
+ Cursor.ID := Cursor.ID + 1;
+
+ case Cursor.Kind is
+ when Non_Grammar_Kind =>
+ String_Pair_Lists.Next (Cursor.Token_Item);
+ if String_Pair_Lists.Has_Element (Cursor.Token_Item) then
+ return;
+ else
+ WisiToken.BNF.Token_Lists.Next (Cursor.Token_Kind);
+
+ if WisiToken.BNF.Token_Lists.Has_Element (Cursor.Token_Kind) then
+ Cursor.Token_Item := Cursor.Data.Tokens.Non_Grammar
(Cursor.Token_Kind).Tokens.First;
+ if String_Pair_Lists.Has_Element (Cursor.Token_Item) then
+ return;
+ end if;
+ end if;
+ end if;
+
+ loop
+ exit when Next_Kind_Internal (Cursor, Nonterminals);
+ end loop;
+ return;
+
+ when Terminals_Keywords =>
+ -- Keywords before other terminals, so they have precedence over
Identifiers
+
+ String_Pair_Lists.Next (Cursor.Keyword);
+ if String_Pair_Lists.Has_Element (Cursor.Keyword) then
+ return;
+ end if;
+
+ loop
+ exit when Next_Kind_Internal (Cursor, Nonterminals);
+ end loop;
+ return;
+
+ when Terminals_Others =>
+ WisiToken.BNF.String_Pair_Lists.Next (Cursor.Token_Item);
+ if WisiToken.BNF.String_Pair_Lists.Has_Element (Cursor.Token_Item)
then
+ return;
+ else
+ WisiToken.BNF.Token_Lists.Next (Cursor.Token_Kind);
+ if WisiToken.BNF.Token_Lists.Has_Element (Cursor.Token_Kind) then
+ Cursor.Token_Item := Cursor.Data.Tokens.Tokens
(Cursor.Token_Kind).Tokens.First;
+ if WisiToken.BNF.String_Pair_Lists.Has_Element
(Cursor.Token_Item) then
+ return;
+ end if;
+ end if;
+ end if;
+
+ loop
+ exit when Next_Kind_Internal (Cursor, Nonterminals);
+ end loop;
+ return;
+
+ when EOI =>
+ if Next_Kind_Internal (Cursor, Nonterminals) then
+ return;
+ else
+ raise SAL.Programmer_Error;
+ end if;
+
+ when WisiToken_Accept =>
+ if Next_Kind_Internal (Cursor, Nonterminals) then
+ return;
+ else
+ raise SAL.Programmer_Error;
+ end if;
+
+ when Nonterminal =>
+ Rule_Lists.Next (Cursor.Nonterminal);
+ if not Rule_Lists.Has_Element (Cursor.Nonterminal) then
+ Cursor.Kind := Done;
+ end if;
+
+ when Done =>
+ null;
+ end case;
+ end Next;
+
+ function Is_Done (Cursor : in Token_Cursor) return Boolean
+ is begin
+ return Cursor.Kind = Done;
+ end Is_Done;
+
+ function ID (Cursor : in Token_Cursor) return Token_ID
+ is begin
+ return Cursor.ID;
+ end ID;
+
+ function Name (Cursor : in Token_Cursor) return String
+ is begin
+ return Cursor.Data.Descriptor.Image (Cursor.ID).all;
+ end Name;
+
+ function Kind (Cursor : in Token_Cursor) return String
+ is begin
+ case Cursor.Kind is
+ when Non_Grammar_Kind =>
+ return -Token_Lists.Constant_Reference
(Cursor.Data.Tokens.Non_Grammar, Cursor.Token_Kind).Kind;
+
+ when Terminals_Keywords =>
+ return "keyword";
+
+ when Terminals_Others =>
+ return -Token_Lists.Constant_Reference (Cursor.Data.Tokens.Tokens,
Cursor.Token_Kind).Kind;
+
+ when EOI =>
+ return "EOI";
+
+ when WisiToken_Accept =>
+ return "accept";
+
+ when Nonterminal =>
+ return "nonterminal";
+
+ when Done =>
+ raise SAL.Programmer_Error with "token cursor is done";
+ end case;
+ end Kind;
+
+ function Value (Cursor : in Token_Cursor) return String
+ is begin
+ case Cursor.Kind is
+ when Non_Grammar_Kind =>
+ declare
+ Token_Ref : constant
WisiToken.BNF.Token_Lists.Constant_Reference_Type :=
+ WisiToken.BNF.Token_Lists.Constant_Reference
(Cursor.Data.Tokens.Non_Grammar, Cursor.Token_Kind);
+
+ Item_Ref : constant String_Pair_Lists.Constant_Reference_Type :=
+ String_Pair_Lists.Constant_Reference (Token_Ref.Element.Tokens,
Cursor.Token_Item);
+ begin
+ return -Item_Ref.Element.Value;
+ end;
+
+ when Terminals_Keywords =>
+ declare
+ Keyword_Ref : constant String_Pair_Lists.Constant_Reference_Type :=
+ String_Pair_Lists.Constant_Reference
(Cursor.Data.Tokens.Keywords, Cursor.Keyword);
+ begin
+ return -Keyword_Ref.Element.Value;
+ end;
+
+ when Terminals_Others =>
+ declare
+ Token_Ref : constant
WisiToken.BNF.Token_Lists.Constant_Reference_Type :=
+ WisiToken.BNF.Token_Lists.Constant_Reference
(Cursor.Data.Tokens.Tokens, Cursor.Token_Kind);
+
+ Item_Ref : constant String_Pair_Lists.Constant_Reference_Type :=
+ String_Pair_Lists.Constant_Reference (Token_Ref.Element.Tokens,
Cursor.Token_Item);
+ begin
+ return -Item_Ref.Element.Value;
+ end;
+
+ when EOI | WisiToken_Accept | Nonterminal =>
+ return "";
+
+ when Done =>
+ raise SAL.Programmer_Error with "token cursor is done";
+ end case;
+ end Value;
+
+ function To_Conflicts
+ (Data : aliased in out Generate_Data;
+ Conflicts : in WisiToken.BNF.Conflict_Lists.List;
+ Source_File_Name : in String)
+ return WisiToken.Generate.LR.Conflict_Lists.List
+ is
+ use WisiToken.Generate.LR;
+ use all type WisiToken.Parse.LR.Parse_Action_Verbs;
+ Result : WisiToken.Generate.LR.Conflict_Lists.List;
+ Conflict : WisiToken.Generate.LR.Conflict;
+ begin
+ Data.Accept_Reduce_Conflict_Count := 0;
+ Data.Shift_Reduce_Conflict_Count := 0;
+ Data.Reduce_Reduce_Conflict_Count := 0;
+
+ for Item of Conflicts loop
+ begin
+ Conflict :=
+ (Conflict_Parse_Actions'Value (-Item.Action_A),
+ Find_Token_ID (Data, -Item.LHS_A),
+ Conflict_Parse_Actions'Value (-Item.Action_B),
+ Find_Token_ID (Data, -Item.LHS_B),
+ -1,
+ Find_Token_ID (Data, -Item.On));
+
+ case Conflict.Action_A is
+ when Shift =>
+ Data.Shift_Reduce_Conflict_Count :=
Data.Shift_Reduce_Conflict_Count + 1;
+ when Reduce =>
+ Data.Reduce_Reduce_Conflict_Count :=
Data.Reduce_Reduce_Conflict_Count + 1;
+ when Accept_It =>
+ Data.Accept_Reduce_Conflict_Count :=
Data.Reduce_Reduce_Conflict_Count + 1;
+ end case;
+
+ Result.Append (Conflict);
+ exception
+ when E : Not_Found =>
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Item.Source_Line,
Ada.Exceptions.Exception_Message (E)));
+ end;
+ end loop;
+ return Result;
+ end To_Conflicts;
+
+ function To_Nonterminal_ID_Set
+ (Data : aliased in Generate_Data;
+ Item : in String_Lists.List)
+ return Token_ID_Set
+ is
+ Result : Token_ID_Set := (Data.Descriptor.First_Nonterminal ..
Data.Descriptor.Last_Nonterminal => False);
+ begin
+ for Token of Item loop
+ Result (Find_Token_ID (Data, Token)) := True;
+ end loop;
+ return Result;
+ end To_Nonterminal_ID_Set;
+
+ function To_McKenzie_Param
+ (Data : aliased in Generate_Data;
+ Item : in McKenzie_Recover_Param_Type;
+ Source_File_Name : in String)
+ return WisiToken.Parse.LR.McKenzie_Param_Type
+ is
+ use Ada.Strings.Unbounded;
+
+ Result : WisiToken.Parse.LR.McKenzie_Param_Type :=
+ -- We use an aggregate, and overwrite some below, so the compiler
+ -- reminds us to change this when we modify McKenzie_Param_Type.
+ (Data.Descriptor.First_Terminal,
+ Data.Descriptor.Last_Terminal,
+ Data.Descriptor.First_Nonterminal,
+ Data.Descriptor.Last_Nonterminal,
+ Insert => (others => Item.Default_Insert),
+ Delete => (others => Item.Default_Delete_Terminal),
+ Push_Back => (others => Item.Default_Push_Back),
+ Ignore_Check_Fail => Item.Ignore_Check_Fail,
+ Task_Count => 0,
+ Cost_Limit => Item.Cost_Limit,
+ Check_Limit => Item.Check_Limit,
+ Check_Delta_Limit => Item.Check_Delta_Limit,
+ Enqueue_Limit => Item.Enqueue_Limit);
+
+ ID : Token_ID;
+ begin
+ for Pair of Item.Delete loop
+ ID := Find_Token_ID (Data, -Pair.Name);
+ if ID in Result.Delete'Range then
+ Result.Delete (ID) := Natural'Value (-Pair.Value);
+ else
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Item.Source_Line, "delete cost is only
valid for terminals (" &
+ WisiToken.Image (ID, Data.Descriptor.all) & ")"));
+ end if;
+ end loop;
+ for Pair of Item.Insert loop
+ Result.Insert (Find_Token_ID (Data, -Pair.Name)) := Natural'Value
(-Pair.Value);
+ end loop;
+ for Pair of Item.Push_Back loop
+ Result.Push_Back (Find_Token_ID (Data, -Pair.Name)) := Natural'Value
(-Pair.Value);
+ end loop;
+
+ return Result;
+ end To_McKenzie_Param;
+
+ procedure Count_Actions (Data : in out Generate_Utils.Generate_Data)
+ is begin
+ Data.Table_Actions_Count := 0;
+ for State_Index in Data.LR_Parse_Table.States'Range loop
+ Data.Table_Actions_Count := Data.Table_Actions_Count +
+ Actions_Length (Data.LR_Parse_Table.States (State_Index)) + 1;
+ end loop;
+ end Count_Actions;
+
+ procedure Put_Stats
+ (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Generate_Data : in Generate_Utils.Generate_Data)
+ is
+ use Ada.Text_IO;
+ begin
+ New_Line;
+ Put_Line
+ (Integer'Image (Input_Data.Rule_Count) & " rules," &
+ Integer'Image (Input_Data.Action_Count) & " user actions," &
+ Integer'Image (Input_Data.Check_Count) & " checks," &
+ WisiToken.State_Index'Image (Generate_Data.Parser_State_Count) & "
states," &
+ Integer'Image (Generate_Data.Table_Actions_Count) & " parse
actions");
+ Put_Line
+ (Integer'Image (Generate_Data.Accept_Reduce_Conflict_Count) & "
accept/reduce conflicts," &
+ Integer'Image (Generate_Data.Shift_Reduce_Conflict_Count) & "
shift/reduce conflicts," &
+ Integer'Image (Generate_Data.Reduce_Reduce_Conflict_Count) & "
reduce/reduce conflicts");
+ end Put_Stats;
+
+ function Actions_Length (State : in Parse.LR.Parse_State) return Integer
+ is
+ use all type WisiToken.Parse.LR.Action_Node_Ptr;
+ Node : Parse.LR.Action_Node_Ptr := State.Action_List;
+ begin
+ return Result : Integer := 0
+ do
+ loop
+ exit when Node = null;
+ Result := Result + 1;
+ Node := Node.Next;
+ exit when Node.Next = null; -- don't count Error
+ end loop;
+ end return;
+ end Actions_Length;
+
+end WisiToken.BNF.Generate_Utils;
diff --git a/wisitoken-bnf-generate_utils.ads b/wisitoken-bnf-generate_utils.ads
new file mode 100644
index 0000000..d7347de
--- /dev/null
+++ b/wisitoken-bnf-generate_utils.ads
@@ -0,0 +1,176 @@
+-- Abstract :
+--
+-- Utilities for translating input file structures to WisiToken
+-- structures needed for LALR.Generate.
+--
+-- Copyright (C) 2014, 2015, 2017, 2018 Stephen Leake 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
+-- 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.
+
+pragma License (Modified_GPL);
+
+with Ada.Iterator_Interfaces;
+with WisiToken.Generate.LR;
+with WisiToken.Parse.LR;
+with WisiToken.Productions;
+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
+ -- wisi.el wisi-eoi-term. It must be a valid Ada identifier when
+ -- "_ID" is appended.
+
+ WisiToken_Accept_Name : constant String := "wisitoken_accept";
+
+ type Generate_Data is limited record
+ Tokens : access constant WisiToken.BNF.Tokens;
+ Descriptor : access WisiToken.Descriptor;
+ Grammar : WisiToken.Productions.Prod_Arrays.Vector;
+
+ Action_Names : access Names_Array_Array;
+ Check_Names : access Names_Array_Array;
+ -- Names of subprograms for each grammar semantic action and check;
+ -- non-null only if there is an action or check in the grammar.
+
+ Start_ID : WisiToken.Token_ID;
+ Source_Line_Map : WisiToken.Productions.Source_Line_Maps.Vector;
+
+ -- The following fields are LR specific; so far, it's not worth
+ -- splitting them out.
+
+ Conflicts : WisiToken.Generate.LR.Conflict_Lists.List;
+ LR_Parse_Table : WisiToken.Parse.LR.Parse_Table_Ptr;
+ Table_Actions_Count : Integer := -1; --
parse, not user, actions
+ Parser_State_Count : WisiToken.Unknown_State_Index := 0;
+ Accept_Reduce_Conflict_Count : Integer := 0;
+ Shift_Reduce_Conflict_Count : Integer := 0;
+ Reduce_Reduce_Conflict_Count : Integer := 0;
+ end record;
+
+ function Initialize (Input_Data : aliased in
WisiToken_Grammar_Runtime.User_Data_Type) return Generate_Data;
+
+ function Find_Token_ID (Data : aliased in Generate_Data; Token : in String)
return Token_ID;
+
+ type Token_Container (Data : not null access constant Generate_Data) is
tagged null record
+ with
+ Constant_Indexing => Constant_Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Ada.Strings.Unbounded.Unbounded_String;
+ -- We need a container type to define an iterator; the actual data is
+ -- in Data.Tokens. The Iterator_Element is given by Token_Name below.
+
+ function All_Tokens (Data : aliased in Generate_Data) return
Token_Container;
+
+ type Token_Constant_Reference_Type
+ (Element : not null access constant
Ada.Strings.Unbounded.Unbounded_String)
+ is null record
+ with Implicit_Dereference => Element;
+
+ type Token_Cursor is private;
+ -- Iterate thru Keywords, Tokens, Rules in a canonical order:
+ --
+ -- 1. Non_Grammar
+ -- 2. Keywords
+ -- 3. other terminal tokens, in declaration order
+ -- 4. EOI
+ -- 5. Accept
+ -- 6. Nonterminals
+ --
+ -- Within each group, tokens occur in the order they were declared in
+ -- the grammar file.
+
+ function Constant_Reference
+ (Container : aliased in Token_Container'Class;
+ Cursor : in Token_Cursor)
+ return Token_Constant_Reference_Type;
+
+ function Is_Done (Cursor : in Token_Cursor) return Boolean;
+ function Has_Element (Cursor : in Token_Cursor) return Boolean is (not
Is_Done (Cursor));
+ package Iterator_Interfaces is new Ada.Iterator_Interfaces (Token_Cursor,
Has_Element);
+ function Iterate
+ (Container : aliased Token_Container;
+ Non_Grammar : in Boolean := True;
+ Nonterminals : in Boolean := True)
+ return Iterator_Interfaces.Forward_Iterator'Class;
+
+ function First
+ (Data : aliased in Generate_Data;
+ Non_Grammar : in Boolean;
+ Nonterminals : in Boolean)
+ return Token_Cursor;
+ procedure Next (Cursor : in out Token_Cursor; Nonterminals : in Boolean);
+
+ function ID (Cursor : in Token_Cursor) return Token_ID;
+
+ function Name (Cursor : in Token_Cursor) return String;
+ -- Return the token name from the .wy file:
+ -- Keywords: Keywords (i).name
+ -- Tokens : Tokens (i).Tokens (j).name
+ -- Rules : Rules (i).Left_Hand_Side
+
+ function Kind (Cursor : in Token_Cursor) return String;
+ -- Return the token kind from the .wy file:
+ -- Keywords: "keyword"
+ -- Tokens : Tokens (i).Kind
+ -- Rules : "nonterminal"
+
+ function Value (Cursor : in Token_Cursor) return String;
+ -- Return the token value from the .wy file:
+ -- Keywords: Keywords (i).value
+ -- Tokens : Tokens (i).Tokens (j).Value
+ -- Rules : "" - they have no Value
+
+ function To_Conflicts
+ (Data : aliased in out Generate_Data;
+ Conflicts : in WisiToken.BNF.Conflict_Lists.List;
+ Source_File_Name : in String)
+ return WisiToken.Generate.LR.Conflict_Lists.List;
+ -- Not included in Initialize because algorithms have no conflicts.
+
+ function To_Nonterminal_ID_Set
+ (Data : aliased in Generate_Data;
+ Item : in String_Lists.List)
+ return Token_ID_Set;
+
+ function To_McKenzie_Param
+ (Data : aliased in Generate_Data;
+ Item : in McKenzie_Recover_Param_Type;
+ Source_File_Name : in String)
+ return WisiToken.Parse.LR.McKenzie_Param_Type;
+
+ procedure Count_Actions (Data : in out Generate_Utils.Generate_Data);
+
+ procedure Put_Stats
+ (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Generate_Data : in Generate_Utils.Generate_Data);
+
+ function Actions_Length (State : in Parse.LR.Parse_State) return Integer;
+ -- Not including Error.
+
+private
+
+ type Token_Cursor_Kind is
+ (Non_Grammar_Kind, Terminals_Keywords, Terminals_Others, EOI,
WisiToken_Accept, Nonterminal, Done);
+
+ type Token_Cursor is record
+ Data : not null access constant Generate_Data;
+ Kind : Token_Cursor_Kind;
+ ID : Token_ID;
+ Token_Kind : WisiToken.BNF.Token_Lists.Cursor; -- Non_Grammar or
Tokens, depending on Kind
+ Token_Item : String_Pair_Lists.Cursor;
+ Keyword : String_Pair_Lists.Cursor;
+ Nonterminal : Rule_Lists.Cursor;
+ end record;
+
+end WisiToken.BNF.Generate_Utils;
diff --git a/wisitoken-bnf-output_ada.adb b/wisitoken-bnf-output_ada.adb
new file mode 100644
index 0000000..ee24c7e
--- /dev/null
+++ b/wisitoken-bnf-output_ada.adb
@@ -0,0 +1,436 @@
+-- Abstract :
+--
+-- Output Ada code implementing the grammar defined by input
+-- parameters, and a parser for that grammar. The grammar parser
+-- actions must be Ada.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake. 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
+-- 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.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Fixed;
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.Regexp;
+with WisiToken.BNF.Generate_Packrat;
+with WisiToken.BNF.Generate_Utils;
+with WisiToken.BNF.Output_Ada_Common; use WisiToken.BNF.Output_Ada_Common;
+with WisiToken.Generate.Packrat;
+with WisiToken_Grammar_Runtime;
+procedure WisiToken.BNF.Output_Ada
+ (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Output_File_Name_Root : in String;
+ Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
+ Packrat_Data : in WisiToken.Generate.Packrat.Data;
+ Tuple : in Generate_Tuple;
+ Test_Main : in Boolean;
+ Multiple_Tuples : in Boolean)
+is
+ Common_Data : Output_Ada_Common.Common_Data :=
WisiToken.BNF.Output_Ada_Common.Initialize
+ (Input_Data, Tuple, Output_File_Name_Root, Check_Interface => False);
+
+ Gen_Alg_Name : constant String :=
+ (if Test_Main or Multiple_Tuples
+ then "_" & Generate_Algorithm_Image (Common_Data.Generate_Algorithm).all
+ else "");
+
+ function Symbol_Regexp (Item : in String) return String
+ is begin
+ -- Return a regular expression string that matches Item as a symbol;
+ -- it must be preceded and followed by non-symbol characters.
+ --
+ -- GNAT.Regexp does not have a char for 'end of string', so we hope
+ -- that doesn't occur. Sigh.
+ return ".*[ (\.]" & Item & "[ );\.,].*";
+ end Symbol_Regexp;
+
+ procedure Create_Ada_Actions_Body
+ (Action_Names : not null access WisiToken.Names_Array_Array;
+ Check_Names : not null access WisiToken.Names_Array_Array;
+ Package_Name : in String)
+ is
+ use GNAT.Regexp;
+ use Generate_Utils;
+ use WisiToken.Generate;
+
+ File_Name : constant String := Output_File_Name_Root & "_actions.adb";
+ -- No generate_algorithm when Test_Main; the generated actions file is
independent of that.
+
+ User_Data_Regexp : constant Regexp := Compile (Symbol_Regexp
("User_Data"), Case_Sensitive => False);
+ Tree_Regexp : constant Regexp := Compile (Symbol_Regexp ("Tree"),
Case_Sensitive => False);
+ Nonterm_Regexp : constant Regexp := Compile (Symbol_Regexp
("Nonterm"), Case_Sensitive => False);
+ Tokens_Regexp : constant Regexp := Compile (Symbol_Regexp ("Tokens"),
Case_Sensitive => False);
+
+ Body_File : File_Type;
+ begin
+ Create (Body_File, Out_File, File_Name);
+ Set_Output (Body_File);
+ Indent := 1;
+ Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Body_Context));
+ New_Line;
+
+ Put_Line ("package body " & Package_Name & " is");
+ Indent := Indent + 3;
+ New_Line;
+
+ if Input_Data.Check_Count > 0 then
+ Indent_Line ("use WisiToken.Semantic_Checks;");
+ New_Line;
+ end if;
+
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Body_Pre));
+
+ -- generate Action and Check subprograms.
+
+ for Rule of Input_Data.Tokens.Rules loop
+ -- No need for a Token_Cursor here, since we only need the
+ -- nonterminals.
+ declare
+ use Ada.Strings.Unbounded;
+
+ LHS_ID : constant WisiToken.Token_ID := Find_Token_ID
(Generate_Data, -Rule.Left_Hand_Side);
+ RHS_Index : Integer := 0;
+
+ function Is_Elisp (Action : in Unbounded_String) return Boolean
+ is begin
+ return Length (Action) >= 6 and then
+ (Slice (Action, 1, 6) = "(progn" or
+ Slice (Action, 1, 5) = "wisi-");
+ end Is_Elisp;
+
+ begin
+ for RHS of Rule.Right_Hand_Sides loop
+ if Length (RHS.Action) > 0 and then not Is_Elisp (RHS.Action)
then
+ declare
+ Line : constant String := -RHS.Action;
+ -- Actually multiple lines; we assume the formatting is
adequate.
+
+ Name : constant String := Action_Names
(LHS_ID)(RHS_Index).all;
+
+ Unref_User_Data : Boolean := True;
+ Unref_Tree : Boolean := True;
+ Unref_Nonterm : Boolean := True;
+ Unref_Tokens : Boolean := True;
+ Need_Comma : Boolean := False;
+
+ procedure Check_Unref (Line : in String)
+ is begin
+ if Match (Line, User_Data_Regexp) then
+ Unref_User_Data := False;
+ end if;
+ if Match (Line, Tree_Regexp) then
+ Unref_Tree := False;
+ end if;
+ if Match (Line, Nonterm_Regexp) then
+ Unref_Nonterm := False;
+ end if;
+ if Match (Line, Tokens_Regexp) then
+ Unref_Tokens := False;
+ end if;
+ end Check_Unref;
+
+ begin
+ Check_Unref (Line);
+ Indent_Line ("procedure " & Name);
+ Indent_Line (" (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class;");
+ Indent_Line (" Tree : in out
WisiToken.Syntax_Trees.Tree;");
+ Indent_Line (" Nonterm : in
WisiToken.Syntax_Trees.Valid_Node_Index;");
+ Indent_Line (" Tokens : in
WisiToken.Syntax_Trees.Valid_Node_Index_Array)");
+ Indent_Line ("is");
+
+ if Unref_User_Data or Unref_Tree or Unref_Nonterm or
Unref_Tokens then
+ Indent_Start (" pragma Unreferenced (");
+
+ if Unref_User_Data then
+ Put ((if Need_Comma then ", " else "") &
"User_Data");
+ Need_Comma := True;
+ end if;
+ if Unref_Tree then
+ Put ((if Need_Comma then ", " else "") & "Tree");
+ Need_Comma := True;
+ end if;
+ if Unref_Nonterm then
+ Put ((if Need_Comma then ", " else "") & "Nonterm");
+ Need_Comma := True;
+ end if;
+ if Unref_Tokens then
+ Put ((if Need_Comma then ", " else "") & "Tokens");
+ Need_Comma := True;
+ end if;
+ Put_Line (");");
+ end if;
+
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+
+ Indent_Line (Line);
+ Indent := Indent - 3;
+ Indent_Line ("end " & Name & ";");
+ New_Line;
+ end;
+ end if;
+
+ if Length (RHS.Check) > 0 and then not Is_Elisp (RHS.Check) then
+ declare
+ use Ada.Strings.Fixed;
+ Line : constant String := -RHS.Check;
+ Name : constant String := Check_Names
(LHS_ID)(RHS_Index).all;
+ Unref_Lexer : constant Boolean := 0 = Index (Line,
"Lexer");
+ Unref_Nonterm : constant Boolean := 0 = Index (Line,
"Nonterm");
+ Unref_Tokens : constant Boolean := 0 = Index (Line,
"Tokens");
+ 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 (" return
WisiToken.Semantic_Checks.Check_Status");
+ Indent_Line ("is");
+
+ if Unref_Lexer then
+ Indent_Line (" pragma Unreferenced (Lexer);");
+ end if;
+ if Unref_Nonterm then
+ Indent_Line (" pragma Unreferenced (Nonterm);");
+ end if;
+ if Unref_Tokens then
+ Indent_Line (" pragma Unreferenced (Tokens);");
+ end if;
+
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+ Indent_Line (Line);
+ Indent := Indent - 3;
+ Indent_Line ("end " & Name & ";");
+ New_Line;
+ end;
+ end if;
+
+ RHS_Index := RHS_Index + 1;
+ end loop;
+ end;
+ end loop;
+
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Body_Post));
+
+ Put_Line ("end " & Package_Name & ";");
+ Close (Body_File);
+
+ Set_Output (Standard_Output);
+
+ end Create_Ada_Actions_Body;
+
+ procedure Create_Ada_Main_Body
+ (Actions_Package_Name : in String;
+ Main_Package_Name : in String)
+ is
+ use WisiToken.Generate;
+
+ File_Name : constant String := To_Lower (Main_Package_Name) &
".adb";
+ re2c_Package_Name : constant String := -Common_Data.Lower_File_Name_Root
& "_re2c_c";
+
+ Body_File : File_Type;
+ begin
+ Create (Body_File, Out_File, File_Name);
+ Set_Output (Body_File);
+ Indent := 1;
+
+ Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
+ New_Line;
+
+ if (case Common_Data.Generate_Algorithm is
+ when LR_Generate_Algorithm => Input_Data.Action_Count > 0 or
Input_Data.Check_Count > 0,
+ when Packrat_Generate_Algorithm | External =>
Input_Data.Action_Count > 0)
+ then
+ Put_Line ("with " & Actions_Package_Name & "; use " &
Actions_Package_Name & ";");
+ end if;
+
+ case Common_Data.Lexer is
+ when None | Elisp_Lexer =>
+ null;
+
+ when re2c_Lexer =>
+ Put_Line ("with WisiToken.Lexer.re2c;");
+ Put_Line ("with " & re2c_Package_Name & ";");
+ end case;
+
+ case Common_Data.Generate_Algorithm is
+ when LR_Generate_Algorithm =>
+ if Tuple.Text_Rep then
+ Put_Line ("with WisiToken.Productions;");
+ end if;
+
+ when Packrat_Gen =>
+ Put_Line ("with WisiToken.Parse.Packrat.Generated;");
+
+ when Packrat_Proc =>
+ Put_Line ("with WisiToken.Parse.Packrat.Procedural;");
+ Put_Line ("with WisiToken.Productions;");
+
+ when External =>
+ null;
+ end case;
+
+ Put_Line ("package body " & Main_Package_Name & " is");
+ Indent := Indent + 3;
+ New_Line;
+
+ case Common_Data.Lexer is
+ when None | Elisp_Lexer =>
+ null;
+
+ when re2c_Lexer =>
+ Indent_Line ("package Lexer is new WisiToken.Lexer.re2c");
+ Indent_Line (" (" & re2c_Package_Name & ".New_Lexer,");
+ Indent_Line (" " & re2c_Package_Name & ".Free_Lexer,");
+ Indent_Line (" " & re2c_Package_Name & ".Reset_Lexer,");
+ Indent_Line (" " & re2c_Package_Name & ".Next_Token);");
+ New_Line;
+ end case;
+
+ case Common_Data.Generate_Algorithm is
+ when LR_Generate_Algorithm =>
+ LR_Create_Create_Parser (Input_Data, Common_Data, Generate_Data);
+
+ when Packrat_Gen =>
+ WisiToken.BNF.Generate_Packrat (Packrat_Data, Generate_Data);
+
+ Packrat_Create_Create_Parser (Common_Data, Generate_Data,
Packrat_Data);
+
+ when Packrat_Proc =>
+ Packrat_Create_Create_Parser (Common_Data, Generate_Data,
Packrat_Data);
+
+ when External =>
+ External_Create_Create_Grammar (Generate_Data);
+ end case;
+
+ Put_Line ("end " & Main_Package_Name & ";");
+ Close (Body_File);
+ Set_Output (Standard_Output);
+ end Create_Ada_Main_Body;
+
+ procedure Create_Ada_Test_Main
+ (Actions_Package_Name : in String;
+ Main_Package_Name : in String)
+ is
+ use WisiToken.Generate;
+
+ Generic_Package_Name : constant String :=
+ (case Common_Data.Generate_Algorithm is
+ when LR_Generate_Algorithm =>
+ (if Input_Data.Language_Params.Error_Recover then
+ (if Common_Data.Text_Rep
+ then "Gen_LR_Text_Rep_Parser_Run"
+ else "Gen_LR_Parser_Run")
+ else
+ (if Common_Data.Text_Rep
+ then "Gen_LR_Text_Rep_Parser_No_Recover_Run"
+ else "Gen_LR_Parser_No_Recover_Run")),
+
+ when Packrat_Generate_Algorithm => "Gen_Packrat_Parser_Run",
+ when External => raise SAL.Programmer_Error);
+
+ Unit_Name : constant String := File_Name_To_Ada (Output_File_Name_Root) &
+ "_" & Generate_Algorithm'Image (Common_Data.Generate_Algorithm) &
"_Run";
+
+ Language_Package_Name : constant String :=
"WisiToken.Parse.LR.McKenzie_Recover." & File_Name_To_Ada
+ (Output_File_Name_Root);
+
+ File_Name : constant String := To_Lower (Unit_Name) & ".ads";
+
+ File : File_Type;
+ begin
+ Create (File, Out_File, File_Name);
+ Set_Output (File);
+ Indent := 1;
+
+ Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
+ -- no Copyright_License; just a test file
+ New_Line;
+
+ Put_Line ("with " & Generic_Package_Name & ";");
+ Put_Line ("with " & Actions_Package_Name & ";");
+ Put_Line ("with " & Main_Package_Name & ";");
+ if Input_Data.Language_Params.Error_Recover then
+ Put_Line ("with " & Language_Package_Name & "; use " &
Language_Package_Name & ";");
+ end if;
+
+ Put_Line ("procedure " & Unit_Name & " is new " & Generic_Package_Name);
+ Put_Line (" (" & Actions_Package_Name & ".Descriptor,");
+ if Common_Data.Text_Rep then
+ Put_Line (" """ & Output_File_Name_Root & "_" &
+ To_Lower (Generate_Algorithm_Image (Tuple.Gen_Alg).all) &
+ "_parse_table.txt"",");
+ end if;
+ if Input_Data.Language_Params.Error_Recover then
+ Put_Line ("Fixes'Access, Use_Minimal_Complete_Actions'Access,
String_ID_Set'Access,");
+ end if;
+ Put_Line (Main_Package_Name & ".Create_Parser);");
+ Close (File);
+ Set_Output (Standard_Output);
+ end Create_Ada_Test_Main;
+
+begin
+ case Common_Data.Lexer is
+ when None | re2c_Lexer =>
+ null;
+
+ when Elisp_Lexer =>
+ raise User_Error with WisiToken.Generate.Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, 1, "Ada output language does not
support " & Lexer_Image
+ (Common_Data.Lexer).all & " lexer");
+ end case;
+
+ case Tuple.Interface_Kind is
+ when None =>
+ null;
+
+ when Module | Process =>
+ raise User_Error with WisiToken.Generate.Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, 1, "Ada output language does not
support setting Interface");
+ end case;
+
+ declare
+ Main_Package_Name : constant String := File_Name_To_Ada
(Output_File_Name_Root & Gen_Alg_Name) & "_Main";
+ Actions_Package_Name : constant String := File_Name_To_Ada
(Output_File_Name_Root) & "_Actions";
+ begin
+ if Input_Data.Action_Count > 0 or Input_Data.Check_Count > 0 then
+ -- Some WisiToken tests have no actions or checks.
+ Create_Ada_Actions_Body (Generate_Data.Action_Names,
Generate_Data.Check_Names, Actions_Package_Name);
+ end if;
+
+ Create_Ada_Actions_Spec
+ (Output_File_Name_Root & "_actions.ads", Actions_Package_Name,
Input_Data, Common_Data, Generate_Data);
+
+ if Tuple.Gen_Alg = External then
+ Create_External_Main_Spec (Main_Package_Name, Tuple, Input_Data);
+ Create_Ada_Main_Body (Actions_Package_Name, Main_Package_Name);
+ else
+ Create_Ada_Main_Body (Actions_Package_Name, Main_Package_Name);
+
+ Create_Ada_Main_Spec (To_Lower (Main_Package_Name) & ".ads",
Main_Package_Name, Input_Data, Common_Data);
+
+ if Test_Main then
+ Create_Ada_Test_Main (Actions_Package_Name, Main_Package_Name);
+ end if;
+ end if;
+ end;
+
+exception
+when others =>
+ Set_Output (Standard_Output);
+ raise;
+end WisiToken.BNF.Output_Ada;
diff --git a/wisitoken-bnf-output_ada_common.adb
b/wisitoken-bnf-output_ada_common.adb
new file mode 100644
index 0000000..3267ebb
--- /dev/null
+++ b/wisitoken-bnf-output_ada_common.adb
@@ -0,0 +1,1407 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (GPL);
+
+with Ada.Strings.Fixed;
+with Ada.Text_IO; use Ada.Text_IO;
+with System.Multiprocessors;
+with WisiToken.BNF.Generate_Grammar;
+with WisiToken.BNF.Utils;
+with WisiToken.Generate; use WisiToken.Generate;
+with WisiToken.Parse.LR;
+with WisiToken.Productions;
+with WisiToken.Syntax_Trees;
+package body WisiToken.BNF.Output_Ada_Common is
+
+ -- Body subprograms, alphabetical
+
+ function Duplicate_Reduce (State : in Parse.LR.Parse_State) return Boolean
+ is
+ use Parse.LR;
+ Node : Action_Node_Ptr := State.Action_List;
+ Action_Node : Parse_Action_Node_Ptr := Node.Action;
+ First : Boolean := True;
+ Action : Reduce_Action_Rec;
+ begin
+ loop
+ Action_Node := Node.Action;
+ if Action_Node.Next /= null then
+ -- conflict
+ return False;
+ elsif Action_Node.Item.Verb /= Reduce then
+ return False;
+ end if;
+
+ if First then
+ Action := Action_Node.Item;
+ First := False;
+ else
+ if not Equal (Action, Action_Node.Item) then
+ return False;
+ end if;
+ end if;
+ Node := Node.Next;
+ exit when Node.Next = null; -- Last entry is Error.
+ end loop;
+ return True;
+ end Duplicate_Reduce;
+
+ function Symbols_Image (State : in Parse.LR.Parse_State) return String
+ is
+ use Ada.Strings.Unbounded;
+ use Parse.LR;
+
+ Result : Unbounded_String;
+ Need_Comma : Boolean := False;
+ Node : Action_Node_Ptr := State.Action_List;
+ begin
+ if Generate_Utils.Actions_Length (State) = 1 then
+ return "(1 => " & Token_ID'Image (Node.Symbol) & ")";
+ else
+ Result := +"(";
+ loop
+ Result := Result &
+ (if Need_Comma then ", " else "") &
+ Trimmed_Image (Node.Symbol);
+ Need_Comma := True;
+ Node := Node.Next;
+ exit when Node.Next = null; -- last is Error
+ end loop;
+ Result := Result & ")";
+ return -Result;
+ end if;
+ end Symbols_Image;
+
+ ----------
+ -- Public subprograms in alphabetical order
+
+ procedure Create_Ada_Actions_Spec
+ (Output_File_Name : in String;
+ Package_Name : in String;
+ Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Common_Data : in Output_Ada_Common.Common_Data;
+ Generate_Data : aliased in WisiToken.BNF.Generate_Utils.Generate_Data)
+ is
+ use Generate_Utils;
+
+ Descriptor : WisiToken.Descriptor renames Generate_Data.Descriptor.all;
+ Spec_File : File_Type;
+ Paren_Done : Boolean := False;
+ Cursor : Token_Cursor := First (Generate_Data, Non_Grammar => True,
Nonterminals => True);
+ begin
+ Create (Spec_File, Out_File, Output_File_Name);
+ Set_Output (Spec_File);
+ Indent := 1;
+
+ Put_File_Header
+ (Ada_Comment, Use_Tuple => True, Tuple =>
+ (Common_Data.Generate_Algorithm, Common_Data.Output_Language,
Common_Data.Lexer, Common_Data.Interface_Kind,
+ Common_Data.Text_Rep));
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
+ New_Line;
+
+ if not (Input_Data.Action_Count > 0 or Input_Data.Check_Count > 0) then
+ Put_Line ("with WisiToken;");
+ end if;
+ if Input_Data.Action_Count > 0 then
+ Put_Line ("with WisiToken.Syntax_Trees;");
+ end if;
+ if Input_Data.Check_Count > 0 then
+ Put_Line ("with WisiToken.Lexer;");
+ Put_Line ("with WisiToken.Semantic_Checks;");
+ end if;
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Spec_Context));
+ Put_Line ("package " & Package_Name & " is");
+ Indent := Indent + 3;
+ New_Line;
+
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Spec_Pre));
+
+ Indent_Line ("Descriptor : aliased WisiToken.Descriptor :=");
+ Indent_Line (" (First_Terminal =>" &
WisiToken.Token_ID'Image (Descriptor.First_Terminal) & ",");
+ Indent := Indent + 3;
+ Indent_Line ("Last_Terminal =>" &
WisiToken.Token_ID'Image (Descriptor.Last_Terminal) & ",");
+ Indent_Line ("First_Nonterminal =>" &
WisiToken.Token_ID'Image (Descriptor.First_Nonterminal) & ",");
+ Indent_Line ("Last_Nonterminal =>" &
WisiToken.Token_ID'Image (Descriptor.Last_Nonterminal) & ",");
+ Indent_Line ("EOF_ID =>" &
WisiToken.Token_ID'Image (Descriptor.EOF_ID) & ",");
+ Indent_Line ("Accept_ID =>" &
WisiToken.Token_ID'Image (Descriptor.Accept_ID) & ",");
+ Indent_Line ("Case_Insensitive => " & Image
(Input_Data.Language_Params.Case_Insensitive) & ",");
+ Indent_Line ("New_Line_ID =>" &
WisiToken.Token_ID'Image (Descriptor.New_Line_ID) & ",");
+ Indent_Line ("Comment_ID =>" &
WisiToken.Token_ID'Image (Descriptor.Comment_ID) & ",");
+ Indent_Line ("Left_Paren_ID =>" &
WisiToken.Token_ID'Image (Descriptor.Left_Paren_ID) & ",");
+ Indent_Line ("Right_Paren_ID =>" &
WisiToken.Token_ID'Image (Descriptor.Right_Paren_ID) & ",");
+ Indent_Line ("String_1_ID =>" &
WisiToken.Token_ID'Image (Descriptor.String_1_ID) & ",");
+ Indent_Line ("String_2_ID =>" &
WisiToken.Token_ID'Image (Descriptor.String_2_ID) & ",");
+ Indent_Line ("Embedded_Quote_Escape_Doubled => " & Image
+
(Input_Data.Language_Params.Embedded_Quote_Escape_Doubled) & ",");
+ Indent_Line ("Image =>");
+ Indent_Start (" (");
+ Indent := Indent + 3;
+ loop
+ exit when Is_Done (Cursor);
+ if Paren_Done then
+ Indent_Start ("new String'(""" & (Name (Cursor)));
+ else
+ Put ("new String'(""" & (Name (Cursor)));
+ Paren_Done := True;
+ end if;
+ Next (Cursor, Nonterminals => True);
+ if Is_Done (Cursor) then
+ Put_Line (""")),");
+ else
+ Put_Line ("""),");
+ end if;
+ end loop;
+
+ Indent := Indent - 3;
+ Indent_Line ("Terminal_Image_Width =>" & Integer'Image
(Descriptor.Terminal_Image_Width) & ",");
+ Indent_Line ("Image_Width =>" & Integer'Image
(Descriptor.Image_Width) & ",");
+ Indent_Line ("Last_Lookahead =>" & WisiToken.Token_ID'Image
(Descriptor.Last_Lookahead) & ");");
+ Indent := Indent - 3;
+ New_Line;
+
+ if Input_Data.Language_Params.Declare_Enums then
+ Paren_Done := False;
+
+ Cursor := First (Generate_Data, Non_Grammar => True, Nonterminals =>
True);
+ Indent_Line ("type Token_Enum_ID is");
+ Indent_Start (" (");
+ Indent := Indent + 3;
+ loop
+ exit when Is_Done (Cursor);
+ if Paren_Done then
+ Indent_Start (To_Token_Ada_Name (Name (Cursor)));
+ else
+ Put (To_Token_Ada_Name (Name (Cursor)));
+ Paren_Done := True;
+ end if;
+ Next (Cursor, Nonterminals => True);
+ if Is_Done (Cursor) then
+ Put_Line (");");
+ else
+ Put_Line (",");
+ end if;
+ end loop;
+
+ Indent := Indent - 3;
+ New_Line;
+
+ Indent_Line ("type Token_Enum_ID_Array is array (Positive range <>)
of Token_Enum_ID;");
+ Indent_Line ("use all type WisiToken.Token_ID;");
+ Indent_Line ("function ""+"" (Item : in Token_Enum_ID) return
WisiToken.Token_ID");
+ Indent_Line (" is (WisiToken.Token_ID'First + Token_Enum_ID'Pos
(Item));");
+
+ Indent_Line ("function To_Token_Enum (Item : in WisiToken.Token_ID)
return Token_Enum_ID");
+ Indent_Line (" is (Token_Enum_ID'Val (Item -
WisiToken.Token_ID'First));");
+ Indent_Line ("function ""-"" (Item : in WisiToken.Token_ID) return
Token_Enum_ID renames To_Token_Enum;");
+ New_Line;
+
+ end if;
+
+ for Name_List of Generate_Data.Action_Names.all loop
+ if Name_List /= null then
+ for Name of Name_List.all loop
+ if Name /= null then
+ Indent_Line ("procedure " & Name.all);
+ Indent_Line (" (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class;");
+ Indent_Line (" Tree : in out
WisiToken.Syntax_Trees.Tree;");
+ Indent_Line (" Nonterm : in
WisiToken.Syntax_Trees.Valid_Node_Index;");
+ Indent_Line (" Tokens : in
WisiToken.Syntax_Trees.Valid_Node_Index_Array);");
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ for Name_List of Generate_Data.Check_Names.all loop
+ if Name_List /= null then
+ 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 (" return
WisiToken.Semantic_Checks.Check_Status;");
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Spec_Post));
+
+ Put_Line ("end " & Package_Name & ";");
+ Close (Spec_File);
+ Set_Output (Standard_Output);
+
+ end Create_Ada_Actions_Spec;
+
+ procedure Create_Ada_Main_Spec
+ (Output_File_Name : in String;
+ Main_Package_Name : in String;
+ Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Common_Data : in Output_Ada_Common.Common_Data)
+ is
+ Lower_Package_Name : constant String := To_Lower (Main_Package_Name);
+
+ Spec_File : File_Type;
+
+ procedure LR_Process
+ is begin
+ Indent_Line ("procedure Create_Parser");
+ if Input_Data.Language_Params.Error_Recover then
+ Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
+ Indent_Line (" Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;");
+ Indent_Line (" Language_Use_Minimal_Complete_Actions : in");
+ Indent_Line ("
WisiToken.Parse.LR.Parser.Language_Use_Minimal_Complete_Actions_Access;");
+ Indent_Line
+ (" Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;");
+ else
+ Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;");
+ end if;
+ Indent_Line (" Trace : not null access
WisiToken.Trace'Class;");
+ Indent_Start (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access");
+
+ if Common_Data.Text_Rep then
+ Put_Line (";");
+ Indent_Line (" Text_Rep_File_Name : in String);");
+ else
+ Put_Line (");");
+ end if;
+ New_Line;
+ end LR_Process;
+
+ procedure Packrat_Process
+ is begin
+ Indent_Line ("function Create_Parser");
+ Indent_Line (" (Trace : not null access WisiToken.Trace'Class;");
+ Indent_Line (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access)");
+ Indent_Line (" return WisiToken.Parse.Base_Parser'Class;");
+ New_Line;
+ end Packrat_Process;
+
+ begin
+ if Common_Data.Generate_Algorithm = External then
+ raise SAL.Programmer_Error;
+ end if;
+
+ Create (Spec_File, Out_File, Output_File_Name);
+ Set_Output (Spec_File);
+ Indent := 1;
+
+ Put_File_Header
+ (Ada_Comment, Use_Tuple => True, Tuple =>
+ (Common_Data.Generate_Algorithm, Common_Data.Output_Language,
Common_Data.Lexer, Common_Data.Interface_Kind,
+ Common_Data.Text_Rep));
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
+ New_Line;
+
+ case Common_Data.Output_Language is
+ when Ada_Lang =>
+ Put_Line ("with WisiToken.Syntax_Trees;");
+
+ when Ada_Emacs_Lang =>
+ case Common_Data.Interface_Kind is
+ when Process =>
+ Put_Line ("with WisiToken.Syntax_Trees;");
+
+ when Module =>
+ Put_Line ("with Emacs_Module_Aux;");
+ Put_Line ("with emacs_module_h;");
+ Put_Line ("with Interfaces.C;");
+ Put_Line ("with WisiToken.Semantic_State;");
+ end case;
+ end case;
+
+ case Common_Data.Generate_Algorithm is
+ when LR_Generate_Algorithm =>
+ if Input_Data.Language_Params.Error_Recover then
+ Put_Line ("with WisiToken.Parse.LR.Parser;");
+ else
+ Put_Line ("with WisiToken.Parse.LR.Parser_No_Recover;");
+ end if;
+
+ when Packrat_Generate_Algorithm =>
+ Put_Line ("with WisiToken.Parse;");
+
+ when External =>
+ null;
+ end case;
+
+ Put_Line ("package " & Main_Package_Name & " is");
+ Indent := Indent + 3;
+ New_Line;
+
+ case Common_Data.Output_Language is
+ when Ada_Lang =>
+ case Common_Data.Generate_Algorithm is
+ when LR_Generate_Algorithm =>
+ LR_Process;
+ when Packrat_Generate_Algorithm =>
+ Packrat_Process;
+ when External =>
+ null;
+ end case;
+
+ when Ada_Emacs_Lang =>
+ case Common_Data.Interface_Kind is
+ when Process =>
+ case Common_Data.Generate_Algorithm is
+ when LR_Generate_Algorithm =>
+ LR_Process;
+ when Packrat_Generate_Algorithm =>
+ Packrat_Process;
+ when External =>
+ null;
+ end case;
+
+ when Module =>
+ Indent_Line ("function Parse (Env :
Emacs_Module_Aux.Emacs_Env_Access) return emacs_module_h.emacs_value;");
+ Indent_Line ("pragma Export (C, Parse, """ & Lower_Package_Name &
"_wisi_module_parse"");");
+ Indent_Line ("function Init (Env :
Emacs_Module_Aux.Emacs_Env_Access) return Interfaces.C.int;");
+ Indent_Line ("pragma Export (C, Init, """ & Lower_Package_Name &
"_wisi_module_parse_init"");");
+ New_Line;
+
+ end case;
+ end case;
+
+ Put_Line ("end " & Main_Package_Name & ";");
+ Close (Spec_File);
+ Set_Output (Standard_Output);
+ end Create_Ada_Main_Spec;
+
+ procedure Create_External_Main_Spec
+ (Main_Package_Name : in String;
+ Tuple : in Generate_Tuple;
+ Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type)
+ is
+ File_Name : constant String := To_Lower (Main_Package_Name) & ".ads";
+ Spec_File : File_Type;
+ begin
+ Create (Spec_File, Out_File, File_Name);
+ Set_Output (Spec_File);
+ Indent := 1;
+
+ Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
+ New_Line;
+
+ Put_Line ("with WisiToken.Productions;");
+ Put_Line ("package " & Main_Package_Name & " is");
+ Indent := Indent + 3;
+ New_Line;
+
+ Indent_Line ("function Create_Grammar return
WisiToken.Productions.Prod_Arrays.Vector;");
+
+ Indent := Indent - 3;
+ Put_Line ("end " & Main_Package_Name & ";");
+ Close (Spec_File);
+ Set_Output (Standard_Output);
+ end Create_External_Main_Spec;
+
+ procedure Create_LR_Parser_Core_1
+ (Common_Data : in Output_Ada_Common.Common_Data;
+ Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data)
+ is
+ use Ada.Strings.Unbounded;
+ use all type Ada.Containers.Count_Type;
+
+ subtype Nonterminal_ID is Token_ID range
+ Generate_Data.Grammar.First_Index .. Generate_Data.Grammar.Last_Index;
+
+ Table : WisiToken.Parse.LR.Parse_Table_Ptr renames
Generate_Data.LR_Parse_Table;
+ Line : Unbounded_String;
+
+ procedure Append (Item : in String)
+ is begin
+ Line := Line & Item;
+ end Append;
+
+ procedure Put (Label : in String; Item : in Token_ID_Array_Natural)
+ is begin
+ Indent_Line (Label & " =>");
+ Indent_Start (" (");
+ Indent := Indent + 3;
+ Line := +"";
+ for I in Item'Range loop
+ Append (Trimmed_Image (Item (I)));
+
+ if I = Item'Last then
+ Append ("),");
+
+ else
+ Append (", ");
+ end if;
+ end loop;
+ Indent_Wrap (-Line);
+ Indent := Indent - 3;
+ end Put;
+
+ begin
+ Indent_Line ("McKenzie_Param : constant McKenzie_Param_Type :=");
+ Indent_Line (" (First_Terminal =>" & Token_ID'Image
(Table.McKenzie_Param.First_Terminal) & ",");
+ Indent := Indent + 3;
+ Indent_Line ("Last_Terminal =>" & Token_ID'Image
(Table.McKenzie_Param.Last_Terminal) & ",");
+ Indent_Line ("First_Nonterminal =>" & Token_ID'Image
(Table.McKenzie_Param.First_Nonterminal) & ",");
+ Indent_Line ("Last_Nonterminal =>" & Token_ID'Image
(Table.McKenzie_Param.Last_Nonterminal) & ",");
+ Put ("Insert", Table.McKenzie_Param.Insert);
+ Put ("Delete", Table.McKenzie_Param.Delete);
+ Put ("Push_Back", Table.McKenzie_Param.Push_Back);
+ Indent_Line ("Ignore_Check_Fail =>" & Integer'Image
(Table.McKenzie_Param.Ignore_Check_Fail) & ",");
+ Indent_Line ("Task_Count =>" & System.Multiprocessors.CPU_Range'Image
+ (Table.McKenzie_Param.Task_Count) & ",");
+ Indent_Line ("Cost_Limit =>" & Integer'Image
(Table.McKenzie_Param.Cost_Limit) & ",");
+ Indent_Line ("Check_Limit =>" & Token_Index'Image
(Table.McKenzie_Param.Check_Limit) & ",");
+ Indent_Line ("Check_Delta_Limit =>" & Integer'Image
(Table.McKenzie_Param.Check_Delta_Limit) & ",");
+ Indent_Line ("Enqueue_Limit =>" & Integer'Image
(Table.McKenzie_Param.Enqueue_Limit) & ");");
+ Indent := Indent - 3;
+ New_Line;
+
+ if Common_Data.Text_Rep then
+ Indent_Line ("function Productions return
WisiToken.Productions.Prod_Arrays.Vector");
+ Indent_Line ("is begin");
+ Indent := Indent + 3;
+ Indent_Line ("return Prods : WisiToken.Productions.Prod_Arrays.Vector
do");
+ Indent := Indent + 3;
+ Indent_Line
+ ("Prods.Set_First (" & Trimmed_Image
(Generate_Data.Grammar.First_Index) & ");");
+ Indent_Line
+ ("Prods.Set_Last (" & Trimmed_Image
(Generate_Data.Grammar.Last_Index) & ");");
+
+ for I in Nonterminal_ID loop
+ declare
+ P : Productions.Instance renames Generate_Data.Grammar (I);
+ begin
+ Indent_Line
+ ("Set_Production (Prods (" & Trimmed_Image (P.LHS) & "), " &
+ Trimmed_Image (P.LHS) & "," & Integer'Image
(P.RHSs.Last_Index) & ");");
+
+ for J in P.RHSs.First_Index .. P.RHSs.Last_Index loop
+ Line := +"Set_RHS (Prods (" & Trimmed_Image (P.LHS) & ")," &
Natural'Image (J) & ", (";
+ declare
+ RHS : Productions.Right_Hand_Side renames P.RHSs (J);
+ begin
+ if RHS.Tokens.Length = 0 then
+ Append ("1 .. 0 => <>");
+ elsif RHS.Tokens.Length = 1 then
+ Append ("1 => " & Trimmed_Image (RHS.Tokens (1)));
+ else
+ for I in RHS.Tokens.First_Index ..
RHS.Tokens.Last_Index loop
+ Append (Trimmed_Image (RHS.Tokens (I)));
+ if I < RHS.Tokens.Last_Index then
+ Append (", ");
+ end if;
+ end loop;
+ end if;
+
+ Append ("), ");
+ Append
+ ((if Generate_Data.Action_Names (P.LHS) = null then
"null"
+ elsif Generate_Data.Action_Names (P.LHS)(J) = null
then "null"
+ else Generate_Data.Action_Names (P.LHS)(J).all &
"'Access"));
+ Append (", ");
+ Append
+ ((if Generate_Data.Check_Names (P.LHS) = null then
"null"
+ elsif Generate_Data.Check_Names (P.LHS)(J) = null
then "null"
+ else Generate_Data.Check_Names (P.LHS)(J).all &
"'Access"));
+ end;
+ Append (");");
+ Indent_Wrap (-Line);
+ end loop;
+ end;
+ end loop;
+ Indent := Indent - 3;
+ Indent_Line ("end return;");
+ Indent := Indent - 3;
+ Indent_Line ("end Productions;");
+ New_Line;
+ end if;
+ end Create_LR_Parser_Core_1;
+
+ procedure Create_LR_Parser_Table
+ (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 Ada.Strings.Unbounded;
+
+ Table : WisiToken.Parse.LR.Parse_Table_Ptr renames
Generate_Data.LR_Parse_Table;
+ Lines_Per_Subr : constant := 1000;
+ Subr_Count : Integer := 1;
+ Last_Subr_Closed : Boolean := False;
+ Line : Unbounded_String;
+
+ procedure Append (Item : in String)
+ is begin
+ Line := Line & Item;
+ end Append;
+ begin
+ -- Optimize source structure for GNAT compile time; one subroutine
+ -- with thousands of "Table.States (*) := ..." takes forever to
+ -- compile (apparently depending on available memory). But hundreds
+ -- of subroutines, containing the same lines in chunks of 1000,
+ -- compiles in acceptable time.
+
+ Indent_Line ("declare");
+ Indent := Indent + 3;
+
+ Indent_Line ("procedure Subr_" & Trimmed_Image (Subr_Count));
+ Indent_Line ("is begin");
+ Indent := Indent + 3;
+ Line_Count := 0;
+
+ Declare_Subroutines :
+ for State_Index in Table.States'Range loop
+
+ if Input_Data.Language_Params.Error_Recover then
+ Indent_Wrap
+ ("Table.States (" & Trimmed_Image (State_Index) & ").Productions
:= WisiToken.To_Vector (" &
+ Image (Table.States (State_Index).Productions, Strict =>
True) & ");");
+ end if;
+
+ Actions :
+ declare
+ use Ada.Containers;
+ use WisiToken.Parse.LR;
+ Base_Indent : constant Ada.Text_IO.Count := Indent;
+ Node : Action_Node_Ptr := Table.States
(State_Index).Action_List;
+ begin
+ if Duplicate_Reduce (Table.States (State_Index)) then
+ declare
+ Action : constant Reduce_Action_Rec := Node.Action.Item;
+ begin
+ Set_Col (Indent);
+ Line := +"Add_Action (Table.States (" & Trimmed_Image
(State_Index) & "), " &
+ Symbols_Image (Table.States (State_Index)) & ", " &
+ Image (Action.Production) & "," &
+ Count_Type'Image (Action.Token_Count) & ", ";
+
+ Append
+ ((if Generate_Data.Action_Names (Action.Production.LHS) =
null then "null"
+ elsif Generate_Data.Action_Names
+ (Action.Production.LHS)(Action.Production.RHS) = null
then "null"
+ else Generate_Data.Action_Names
+ (Action.Production.LHS)(Action.Production.RHS).all &
"'Access"));
+ Append (", ");
+ Append
+ ((if Generate_Data.Check_Names (Action.Production.LHS) =
null then "null"
+ elsif Generate_Data.Check_Names
+ (Action.Production.LHS)(Action.Production.RHS) = null
then "null"
+ else Generate_Data.Check_Names
+ (Action.Production.LHS)(Action.Production.RHS).all &
"'Access"));
+
+ Indent_Wrap (-Line & ");");
+ Line_Count := Line_Count + 1;
+ Indent := Base_Indent;
+ end;
+
+ else
+ loop
+ exit when Node = null;
+ Set_Col (Indent);
+ declare
+ Action_Node : Parse_Action_Node_Ptr := Node.Action;
+ begin
+ case Action_Node.Item.Verb is
+ when Shift =>
+ Line := +"Add_Action (Table.States (" & Trimmed_Image
(State_Index) & "), " &
+ Trimmed_Image (Node.Symbol);
+ Append (", ");
+ Append (Trimmed_Image (Action_Node.Item.State));
+
+ when Reduce | Accept_It =>
+ Line := +"Add_Action (Table.States (" & Trimmed_Image
(State_Index) & "), " &
+ Trimmed_Image (Node.Symbol);
+ if Action_Node.Item.Verb = Reduce then
+ Append (", Reduce");
+ else
+ Append (", Accept_It");
+ end if;
+ Append (", ");
+ Append (Image (Action_Node.Item.Production) & ",");
+ Append (Count_Type'Image
(Action_Node.Item.Token_Count) & ", ");
+ Append
+ ((if Generate_Data.Action_Names
(Action_Node.Item.Production.LHS) = null then "null"
+ elsif Generate_Data.Action_Names
+
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS) = null
+ then "null"
+ else Generate_Data.Action_Names
+
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
+ "'Access"));
+ Append (", ");
+ Append
+ ((if Generate_Data.Check_Names
(Action_Node.Item.Production.LHS) = null then "null"
+ elsif Generate_Data.Check_Names
+
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS) = null
+ then "null"
+ else Generate_Data.Check_Names
+
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
+ "'Access"));
+
+ when Parse.LR.Error =>
+ Line := +"Add_Error (Table.States (" & Trimmed_Image
(State_Index) & ")";
+ end case;
+
+ Action_Node := Action_Node.Next;
+ if Action_Node /= null then
+ -- There is a conflict; must be Shift/{Reduce|Accept}
or Reduce/{Reduce|Accept}.
+ -- The added parameters are the same in either case.
+ case Action_Node.Item.Verb is
+ when Reduce | Accept_It =>
+ Append (", ");
+ Append (Image (Action_Node.Item.Production) & ",");
+ Append (Count_Type'Image
(Action_Node.Item.Token_Count) & ", ");
+ Append
+ ((if Generate_Data.Action_Names
(Action_Node.Item.Production.LHS) = null then "null"
+ elsif Generate_Data.Action_Names
+
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS) = null
+ then "null"
+ else Generate_Data.Action_Names
+
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
+ "'Access"));
+ Append (", ");
+ Append
+ ((if Generate_Data.Check_Names
(Action_Node.Item.Production.LHS) = null then "null"
+ elsif Generate_Data.Check_Names
+
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS) = null
+ then "null"
+ else Generate_Data.Check_Names
+
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
+ "'Access"));
+
+ when others =>
+ raise SAL.Programmer_Error with "conflict second
action verb: " &
+ Parse.LR.Parse_Action_Verbs'Image
(Action_Node.Item.Verb);
+ end case;
+ end if;
+ end;
+ Indent_Wrap (-Line & ");");
+ Line_Count := Line_Count + 1;
+ Indent := Base_Indent;
+ Node := Node.Next;
+ end loop;
+ end if;
+ end Actions;
+
+ Gotos :
+ declare
+ use WisiToken.Parse.LR;
+ Node : Goto_Node_Ptr := Table.States (State_Index).Goto_List;
+ begin
+ loop
+ exit when Node = null;
+ Set_Col (Indent);
+ Put ("Add_Goto (Table.States (" & Trimmed_Image (State_Index) &
"), ");
+ Put_Line (Trimmed_Image (Symbol (Node)) & ", " & Trimmed_Image
(State (Node)) & ");");
+ Line_Count := Line_Count + 1;
+ Node := Next (Node);
+ end loop;
+ end Gotos;
+
+ if Table.States (State_Index).Minimal_Complete_Actions.Length > 0 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) & ");");
+ end if;
+
+ if Line_Count > Lines_Per_Subr then
+ Line_Count := 0;
+ Indent := Indent - 3;
+ Indent_Line ("end Subr_" & Trimmed_Image (Subr_Count) & ";");
+
+ if State_Index < Table.States'Last then
+ Subr_Count := Subr_Count + 1;
+ Last_Subr_Closed := False;
+ Indent_Line ("procedure Subr_" & Trimmed_Image (Subr_Count));
+ Indent_Line ("is begin");
+ Indent := Indent + 3;
+ else
+ Last_Subr_Closed := True;
+ end if;
+ end if;
+
+ end loop Declare_Subroutines;
+
+ if not Last_Subr_Closed then
+ Indent := Indent - 3;
+ Indent_Line ("end Subr_" & Trimmed_Image (Subr_Count) & ";");
+ end if;
+
+ Indent := Indent - 3;
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+
+ for Subr in 1 .. Subr_Count loop
+ Indent_Line ("Subr_" & Trimmed_Image (Subr) & ";");
+ end loop;
+ Indent := Indent - 3;
+ Indent_Line ("end;");
+ end Create_LR_Parser_Table;
+
+ procedure LR_Create_Create_Parser
+ (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Common_Data : in out Output_Ada_Common.Common_Data;
+ Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data)
+ is
+ Table : WisiToken.Parse.LR.Parse_Table_Ptr renames
Generate_Data.LR_Parse_Table;
+ begin
+ Indent_Line ("procedure Create_Parser");
+ case Common_Data.Interface_Kind is
+ when Process =>
+ if Input_Data.Language_Params.Error_Recover then
+ Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
+ Indent_Line (" Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;");
+ Indent_Line (" Language_Use_Minimal_Complete_Actions : in");
+ Indent_Line ("
WisiToken.Parse.LR.Parser.Language_Use_Minimal_Complete_Actions_Access;");
+ Indent_Line
+ (" Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;");
+ else
+ Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;");
+ end if;
+ Indent_Line (" Trace : not null access
WisiToken.Trace'Class;");
+ Indent_Start (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access");
+
+ when Module =>
+ Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
+ Indent_Line (" Env : in Emacs_Env_Access;");
+ Indent_Start (" Lexer_Elisp_Symbols : in
Lexers.Elisp_Array_Emacs_Value");
+ end case;
+
+ if Common_Data.Text_Rep then
+ Put_Line (";");
+ Indent_Line (" Text_Rep_File_Name : in String)");
+ else
+ Put_Line (")");
+ end if;
+
+ Indent_Line ("is");
+ Indent := Indent + 3;
+
+ Indent_Line ("use WisiToken.Parse.LR;");
+
+ if Common_Data.Text_Rep then
+ Create_LR_Parser_Core_1 (Common_Data, Generate_Data);
+ Indent_Line ("Table : constant Parse_Table_Ptr := Get_Text_Rep");
+ Indent_Line (" (Text_Rep_File_Name, McKenzie_Param, Productions);");
+ Indent := Indent - 3;
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+
+ else
+ if Input_Data.Language_Params.Error_Recover then
+ Create_LR_Parser_Core_1 (Common_Data, Generate_Data);
+ end if;
+
+ Indent_Line ("Table : constant Parse_Table_Ptr := new Parse_Table");
+ Indent_Line (" (State_First => 0,");
+ Indent := Indent + 3;
+ Indent_Line ("State_Last =>" & State_Index'Image
(Table.State_Last) & ",");
+ Indent_Line ("First_Terminal =>" & Token_ID'Image
(Table.First_Terminal) & ",");
+ Indent_Line ("Last_Terminal =>" & Token_ID'Image
(Table.Last_Terminal) & ",");
+ Indent_Line ("First_Nonterminal =>" & Token_ID'Image
(Table.First_Nonterminal) & ",");
+ Indent_Line ("Last_Nonterminal =>" & Token_ID'Image
(Table.Last_Nonterminal) & ");");
+ Indent := Indent - 3;
+
+ Indent := Indent - 3;
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+ if Input_Data.Language_Params.Error_Recover then
+ Indent_Line ("Table.McKenzie_Param := McKenzie_Param;");
+ end if;
+ Create_LR_Parser_Table (Input_Data, Generate_Data);
+ New_Line;
+ end if;
+
+ if Input_Data.Language_Params.Error_Recover then
+ Indent_Line ("WisiToken.Parse.LR.Parser.New_Parser");
+ else
+ Indent_Line ("WisiToken.Parse.LR.Parser_No_Recover.New_Parser");
+ end if;
+ Indent_Line (" (Parser,");
+ case Common_Data.Interface_Kind is
+ when Process =>
+ Indent_Line (" Trace,");
+ Indent_Line (" Lexer.New_Lexer (Trace),");
+ Indent_Line (" Table,");
+ if Input_Data.Language_Params.Error_Recover then
+ Indent_Line (" Language_Fixes,");
+ Indent_Line (" Language_Use_Minimal_Complete_Actions,");
+ Indent_Line (" Language_String_ID_Set,");
+ end if;
+ Indent_Line (" User_Data,");
+ Indent_Line (" Max_Parallel => 15,");
+ Indent_Line (" Terminate_Same_State => True);");
+
+ when Module =>
+ Indent_Line (" Lexer.New_Lexer (Env, Lexer_Elisp_Symbols),");
+ Indent_Line (" Table, Max_Parallel => 15, Terminate_Same_State =>
True);");
+
+ end case;
+ Indent := Indent - 3;
+ Indent_Line ("end Create_Parser;");
+ end LR_Create_Create_Parser;
+
+ procedure Packrat_Create_Create_Parser
+ (Common_Data : in out Output_Ada_Common.Common_Data;
+ Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
+ Packrat_Data : in WisiToken.Generate.Packrat.Data)
+ is
+ use Ada.Strings.Unbounded;
+
+ Text : Unbounded_String;
+ Need_Bar : Boolean := True;
+ begin
+ Indent_Line ("function Create_Parser");
+ Indent_Line (" (Trace : not null access WisiToken.Trace'Class;");
+ Indent_Line (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access)");
+ Indent_Line (" return WisiToken.Parse.Base_Parser'Class");
+
+ case Packrat_Generate_Algorithm'(Common_Data.Generate_Algorithm) is
+ when Packrat_Gen =>
+ Indent_Line ("is begin");
+ Indent := Indent + 3;
+ 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.User_Data := User_Data;");
+ Indent_Line ("Parser.Parse_WisiToken_Accept :=
Parse_wisitoken_accept_1'Access;");
+ Indent := Indent - 3;
+ Indent_Line ("end return;");
+
+ when Packrat_Proc =>
+ Indent_Line ("is");
+ Indent := Indent + 3;
+ Indent_Line ("use WisiToken;");
+ Indent_Line ("use WisiToken.Productions;");
+ Indent_Line ("Grammar : Prod_Arrays.Vector;");
+ Indent_Line
+ ("Direct_Left_Recursive : constant WisiToken.Token_ID_Set (" &
+ Trimmed_Image (Generate_Data.Grammar.First_Index) & " .. " &
+ Trimmed_Image (Generate_Data.Grammar.Last_Index) & ") :=");
+
+ Need_Bar := False;
+ if Any (Packrat_Data.Direct_Left_Recursive) then
+ for I in Packrat_Data.Direct_Left_Recursive'Range loop
+ if Packrat_Data.Direct_Left_Recursive (I) then
+ if Need_Bar then
+ Text := Text & " | ";
+ else
+ Need_Bar := True;
+ end if;
+ Text := Text & Trimmed_Image (I);
+ end if;
+ end loop;
+ Indent_Start (" (");
+ Indent := Indent + 3;
+ Indent_Wrap (-Text & " => True,");
+ Indent_Line ("others => False);");
+ Indent := Indent - 3;
+ else
+ Indent_Line (" (others => False);");
+ end if;
+ Indent := Indent - 3;
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+ WisiToken.BNF.Generate_Grammar (Generate_Data.Grammar,
Generate_Data.Action_Names.all);
+
+ 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);");
+ end case;
+ Indent := Indent - 3;
+ Indent_Line ("end Create_Parser;");
+ New_Line;
+ end Packrat_Create_Create_Parser;
+
+ procedure External_Create_Create_Grammar
+ (Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data)
+ is begin
+ Indent_Line ("function Create_Grammar return
WisiToken.Productions.Prod_Arrays.Vector");
+ Indent_Line ("is");
+ Indent_Line (" use WisiToken;");
+ Indent_Line (" use WisiToken.Productions;");
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+ Indent_Line ("return Grammar : WisiToken.Productions.Prod_Arrays.Vector
do");
+ Indent := Indent + 3;
+ WisiToken.BNF.Generate_Grammar (Generate_Data.Grammar,
Generate_Data.Action_Names.all);
+ Indent := Indent - 3;
+ Indent_Line ("end return;");
+ Indent := Indent - 3;
+ Indent_Line ("end Create_Grammar;");
+ end External_Create_Create_Grammar;
+
+ procedure Create_re2c
+ (Input_Data : in
WisiToken_Grammar_Runtime.User_Data_Type;
+ Tuple : in Generate_Tuple;
+ Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
+ Output_File_Name_Root : in String;
+ Elisp_Regexps : in WisiToken.BNF.String_Pair_Lists.List)
+ is
+ use Ada.Strings.Fixed;
+ use Generate_Utils;
+ use WisiToken.BNF.Utils;
+ File : File_Type;
+ begin
+ Create (File, Out_File, Output_File_Name_Root & ".re2c");
+ Set_Output (File);
+ Indent := 1;
+
+ Put_File_Header (C_Comment, " -*- mode: C -*-", Use_Tuple => True, Tuple
=> Tuple);
+ Put_Raw_Code (C_Comment, Input_Data.Raw_Code (Copyright_License));
+ New_Line;
+
+ Indent_Line ("#include <stddef.h>"); -- size_t
+ Indent_Line ("#include <stdio.h>"); -- printf
+ Indent_Line ("#include <stdlib.h>"); -- malloc
+ New_Line;
+
+ Indent_Line ("typedef struct wisi_lexer");
+ Indent_Line ("{");
+ Indent := Indent + 3;
+ Indent_Line ("unsigned char* buffer; // input text, in utf-8
encoding");
+ Indent_Line ("unsigned char* buffer_last; // last byte in buffer");
+ Indent_Line ("unsigned char* cursor; // current byte");
+ Indent_Line ("unsigned char* byte_token_start; // byte position at start
of current token");
+ Indent_Line ("size_t char_pos; // character position of
current character");
+ Indent_Line ("size_t char_token_start; // character position at
start of current token");
+ Indent_Line ("int line; // 1 indexed");
+ 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 ("unsigned char* context; // saved cursor");
+ Indent_Line ("size_t context_pos; // saved character
position");
+ Indent_Line ("int context_line; // saved line");
+ Indent_Line ("int verbosity;");
+ New_Line;
+ Indent := Indent - 3;
+ Indent_Line ("} wisi_lexer;");
+ New_Line;
+ Indent_Line ("#define YYCTYPE unsigned char");
+ New_Line;
+
+ -- Status values:
+ Indent_Line ("#define NO_ERROR 0");
+ Indent_Line ("#define ERROR_unrecognized_character 1");
+
+ ----------
+ -- new_lexer, free_lexer, reset_lexer
+
+ -- It's normal to increment lexer->cursor one past the end of input,
+ -- but not to read that character. To support memory mapped files, we
+ -- enforce this strictly; YYPEEK returns EOT (end of text) when
+ -- reading past end of buffer; that's how we recognize the end of
+ -- text token.
+
+ Indent_Line ("wisi_lexer* " & Output_File_Name_Root & "_new_lexer");
+ 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 ("return result;");
+ Indent := Indent - 3;
+ Indent_Line ("}");
+ New_Line;
+
+ Indent_Line ("void");
+ Indent_Line (Output_File_Name_Root & "_free_lexer(wisi_lexer** lexer)");
+ Indent_Line ("{");
+ Indent := Indent + 3;
+ Indent_Line ("free(*lexer);");
+ Indent_Line ("*lexer = 0;");
+ Indent := Indent - 3;
+ Indent_Line ("}");
+ New_Line;
+
+ Indent_Line ("void");
+ Indent_Line (Output_File_Name_Root & "_reset_lexer(wisi_lexer* lexer)");
+ Indent_Line ("{");
+ Indent := Indent + 3;
+ Indent_Line ("lexer->cursor = lexer->buffer;");
+ Indent_Line ("lexer->char_pos = 1;");
+ Indent_Line ("lexer->line = (*lexer->cursor == 0x0A) ? 2 : 1;");
+ Indent := Indent - 3;
+ Indent_Line ("}");
+ New_Line;
+
+ ----------
+ -- next_token utils
+
+ Indent_Line ("static void debug(wisi_lexer* lexer, int state, unsigned
char ch)");
+ Indent_Line ("{");
+ Indent := Indent + 3;
+ Indent_Line ("if (lexer->verbosity > 0)");
+ Indent_Line (" {");
+ Indent_Line (" if (ch < ' ')");
+ Indent_Line (" printf (""lexer: %d, 0x%x\n"", state, ch);");
+ Indent_Line (" else");
+ Indent_Line (" printf (""lexer: %d, '%c' 0x%x\n"", state, ch,
ch);");
+ Indent_Line (" }");
+ Indent := Indent - 3;
+ Indent_Line ("}");
+ Indent_Line ("#define YYDEBUG(state, ch) debug(lexer, state, ch)");
+
+ -- YYCURSOR is only used in calls of YYDEBUG; we can't define it as
+ -- YYPEEK because it is used as '*YYCURSOR'.
+ Indent_Line ("#define YYCURSOR lexer->cursor");
+ New_Line;
+
+ Indent_Line ("#define YYPEEK() (lexer->cursor <= lexer->buffer_last) ?
*lexer->cursor : 4");
+ New_Line;
+
+ -- Don't count UTF-8 continuation bytes, or first byte of DOS newline
+ Indent_Line ("#define DO_COUNT ((*lexer->cursor & 0xC0) != 0xC0) &&
(*lexer->cursor != 0x0D)");
+ New_Line;
+
+ 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 (" if (DO_COUNT) ++lexer->char_pos;");
+ Indent_Line ("if (*lexer->cursor == 0x0A) ++lexer->line;");
+ Indent := Indent - 3;
+ Indent_Line ("}");
+ Indent_Start ("#define YYSKIP() skip(lexer)");
+ New_Line;
+
+ Indent_Line ("#define YYBACKUP() lexer->marker = lexer->cursor;
lexer->marker_pos = lexer->char_pos;" &
+ "lexer->marker_line = lexer->line");
+ Indent_Line ("#define YYRESTORE() lexer->cursor = lexer->marker;
lexer->char_pos = lexer->marker_pos;" &
+ "lexer->line = lexer->marker_line");
+ Indent_Line ("#define YYBACKUPCTX() lexer->context = lexer->cursor;
lexer->context_pos = lexer->char_pos;" &
+ "lexer->context_line = lexer->line");
+ Indent_Line ("#define YYRESTORECTX() lexer->cursor = lexer->context;
lexer->char_pos = lexer->context_pos;" &
+ "lexer->line = lexer->context_line");
+ New_Line;
+
+ if Is_In (Input_Data.Tokens.Tokens, "delimited-text") then
+ Indent_Line ("static void skip_to(wisi_lexer* lexer, char* target)");
+ Indent_Line ("{");
+ Indent_Line (" int i;");
+ New_Line;
+ Indent_Line (" while (lexer->cursor <= lexer->buffer_last)");
+ Indent_Line (" {");
+ Indent_Line (" if (*lexer->cursor == target[0])");
+ Indent_Line (" {");
+ Indent_Line (" i = 0;");
+ Indent_Line (" do");
+ Indent_Line (" i++;");
+ Indent_Line (" while (0 != target[i] &&");
+ Indent_Line (" lexer->cursor + i <= lexer->buffer_last
&&");
+ Indent_Line (" *(lexer->cursor + i) == target[i]);");
+ New_Line;
+ Indent_Line (" if (0 == target[i])");
+ Indent_Line (" {");
+ Indent_Line (" for (i = 0; 0 != target[i]; i++)");
+ Indent_Line (" skip(lexer);");
+ Indent_Line (" break;");
+ Indent_Line (" }");
+ Indent_Line (" }");
+ Indent_Line (" skip(lexer);");
+ Indent_Line (" };");
+ Indent_Line ("}");
+ New_Line;
+ end if;
+
+ ----------
+ -- next_token
+ Indent_Line ("int " & Output_File_Name_Root & "_next_token");
+ Indent_Line (" (wisi_lexer* lexer,");
+ Indent_Line (" int* id,");
+ Indent_Line (" size_t* byte_position,");
+ Indent_Line (" size_t* byte_length,");
+ Indent_Line (" size_t* char_position,");
+ Indent_Line (" size_t* char_length,");
+ Indent_Line (" int* line_start)");
+ Indent_Line ("{");
+ Indent := Indent + 3;
+
+ Indent_Line ("int status = NO_ERROR;");
+ Indent_Line ("*id = -1;"); -- Token_ID'First = 0; see dragon_4_43.wy
+
+ 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 ("*byte_position = lexer->buffer_last - lexer->buffer + 1;");
+ Indent_Line ("*byte_length = 0;");
+ Indent_Line ("*char_position = lexer->char_token_start;");
+ Indent_Line ("*char_length = 0;");
+ Indent_Line ("*line_start = lexer->line;");
+ Indent_Line ("return status;");
+ Indent := Indent - 3;
+ Indent_Line ("}");
+ 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 ("if (*lexer->cursor == 0x0A)");
+ Indent_Line (" lexer->line_token_start = lexer->line-1;");
+ Indent_Line ("else");
+ Indent_Line (" lexer->line_token_start = lexer->line;");
+ New_Line;
+
+ Indent_Line ("while (*id == -1 && status == 0)");
+ Indent_Line ("{");
+ Indent := Indent + 3;
+
+ Put_Line ("/*!re2c");
+ Indent_Line ("re2c:yyfill:enable = 0;");
+ New_Line;
+
+ -- Regexps used in definitions
+ for Pair of Input_Data.Tokens.Regexps loop
+ Indent_Line (-Pair.Name & " = " & (-Pair.Value) & ";");
+ end loop;
+ New_Line;
+
+ -- definitions
+ for I in All_Tokens (Generate_Data).Iterate (Non_Grammar => True,
Nonterminals => False) loop
+
+ declare
+ Val : constant String :=
+ (if Is_Present (Elisp_Regexps, Value (I))
+ then Value (Elisp_Regexps, Value (I))
+ else Value (I));
+ begin
+ if 0 /= Index (Source => Val, Pattern => "/") then
+ -- trailing context syntax; forbidden in definitions
+ null;
+
+ elsif Kind (I) = "EOI" then
+ Indent_Line (Name (I) & " = [\x04];");
+
+ elsif Kind (I) = "delimited-text" then
+ -- not declared in definitions
+ null;
+
+ elsif Kind (I) = "keyword" and
Input_Data.Language_Params.Case_Insensitive then
+ Indent_Line (Name (I) & " = '" & Strip_Quotes (Val) & "';");
+
+ else
+ -- Other kinds have values that are regular expressions, in
re2c syntax
+ Indent_Line (Name (I) & " = " & Val & ";");
+ end if;
+ end;
+ end loop;
+ New_Line;
+
+ -- lexer rules
+ for I in All_Tokens (Generate_Data).Iterate (Non_Grammar => True,
Nonterminals => False) loop
+ declare
+ Val : constant String :=
+ (if Is_Present (Elisp_Regexps, Value (I))
+ then Value (Elisp_Regexps, Value (I))
+ else Value (I));
+ begin
+
+ if Kind (I) = "non-reporting" then
+ Indent_Line (Name (I) & " { lexer->byte_token_start =
lexer->cursor;");
+ 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");
+ Indent_Line (" lexer->line_token_start = lexer->line;");
+ Indent_Line (" continue; }");
+
+ elsif Kind (I) = "delimited-text" then
+ -- Val contains the start and end strings, separated by space
+ declare
+ Start_Last : constant Integer := Index (Val, " ");
+ begin
+ Indent_Line
+ (Val (1 .. Start_Last - 1) & " {*id = " &
WisiToken.Token_ID'Image (ID (I)) &
+ "; skip_to(lexer, " & Val (Start_Last + 1 .. Val'Last)
& "); continue;}");
+ end;
+
+ elsif 0 /= Index (Source => Val, Pattern => "/") then
+ Indent_Line (Val & " {*id = " & WisiToken.Token_ID'Image (ID
(I)) & "; continue;}");
+
+ else
+ Indent_Line (Name (I) & " {*id = " & WisiToken.Token_ID'Image
(ID (I)) & "; continue;}");
+ end if;
+ end;
+ end loop;
+ New_Line;
+
+ -- Default action
+ Indent_Line ("* {status = ERROR_unrecognized_character; continue;}");
+
+ Put_Line ("*/");
+ Indent_Line ("}");
+ Indent := Indent - 3;
+
+ Indent_Line ("*byte_position = lexer->byte_token_start - lexer->buffer +
1;");
+ Indent_Line ("*byte_length = lexer->cursor -
lexer->byte_token_start;");
+ Indent_Line ("*char_position = lexer->char_token_start;");
+ Indent_Line ("if (DO_COUNT)");
+ Indent_Line (" *char_length = lexer->char_pos -
lexer->char_token_start;");
+ Indent_Line ("else");
+ Indent_Line (" *char_length = lexer->char_pos -
lexer->char_token_start + 1;");
+ Indent_Line ("*line_start = lexer->line_token_start;");
+ Indent_Line ("return status;");
+ Indent_Line ("}");
+ Indent := Indent - 3;
+ Set_Output (Standard_Output);
+ Close (File);
+
+ declare
+ Ada_Name : constant String := Output_File_Name_Root & "_re2c_c";
+ -- Output_File_Name_Root is the file name of the grammar file -
+ -- assume it is a legal Ada name.
+ begin
+ Create (File, Out_File, Output_File_Name_Root & "_re2c_c.ads");
+ Set_Output (File);
+ Indent := 1;
+ Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
+ New_Line;
+
+ Put_Line ("with Interfaces.C;");
+ Put_Line ("with WisiToken;");
+ Put_Line ("with System;");
+ Put_Line ("package " & Ada_Name & " is");
+ Indent := Indent + 3;
+ New_Line;
+
+ Indent_Line ("function New_Lexer");
+ Indent_Line (" (Buffer : in System.Address;");
+ Indent_Line (" Length : in Interfaces.C.size_t;");
+ Indent_Line (" Verbosity : in Interfaces.C.int)");
+ Indent_Line (" return System.Address");
+ Indent_Line ("with Import => True,");
+ Indent_Line (" Convention => C,");
+ Indent_Line (" External_Name => """ & Output_File_Name_Root &
"_new_lexer"";");
+ Indent_Line ("-- Create the lexer object, passing it the full text
to process.");
+ New_Line;
+ Indent_Line ("procedure Free_Lexer (Lexer : in out System.Address)");
+ Indent_Line ("with Import => True,");
+ Indent_Line (" Convention => C,");
+ Indent_Line (" External_Name => """ & Output_File_Name_Root &
"_free_lexer"";");
+ Indent_Line ("-- Free the lexer object");
+ New_Line;
+
+ Indent_Line ("procedure Reset_Lexer (Lexer : in System.Address)");
+ Indent_Line ("with Import => True,");
+ Indent_Line (" Convention => C,");
+ Indent_Line (" External_Name => """ & Output_File_Name_Root &
"_reset_lexer"";");
+ New_Line;
+
+ Indent_Line ("function Next_Token");
+ Indent_Line (" (Lexer : in System.Address;");
+ Indent_Line (" ID : out WisiToken.Token_ID;");
+ Indent_Line (" Byte_Position : out Interfaces.C.size_t;");
+ Indent_Line (" Byte_Length : out Interfaces.C.size_t;");
+ Indent_Line (" Char_Position : out Interfaces.C.size_t;");
+ Indent_Line (" Char_Length : out Interfaces.C.size_t;");
+ Indent_Line (" Line_Start : out Interfaces.C.int)");
+ Indent_Line (" return Interfaces.C.int");
+ Indent_Line ("with Import => True,");
+ Indent_Line (" Convention => C,");
+ Indent_Line (" External_Name => """ & Output_File_Name_Root &
"_next_token"";");
+ New_Line;
+
+ Indent := Indent - 3;
+ Put_Line ("end " & Ada_Name & ";");
+ Set_Output (Standard_Output);
+ Close (File);
+ end;
+ end Create_re2c;
+
+ function File_Name_To_Ada (File_Name : in String) return String
+ is
+ Result : String := File_Name;
+ begin
+ Result (Result'First) := To_Upper (Result (Result'First));
+ for I in Result'Range loop
+ if Result (I) = '-' then
+ Result (I) := '.';
+ Result (I + 1) := To_Upper (Result (I + 1));
+ elsif Result (I) = '_' then
+ Result (I + 1) := To_Upper (Result (I + 1));
+ end if;
+ end loop;
+ return Result;
+ end File_Name_To_Ada;
+
+ function Initialize
+ (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Tuple : in Generate_Tuple;
+ Output_File_Root : in String;
+ Check_Interface : in Boolean)
+ return Common_Data
+ is begin
+ return Data : Common_Data do
+ Data.Generate_Algorithm := Tuple.Gen_Alg;
+
+ Data.Output_Language := Ada_Output_Language (Tuple.Out_Lang);
+
+ if Tuple.Gen_Alg = External or else Input_Data.User_Lexer in
Valid_Lexer then
+ Data.Lexer := Input_Data.User_Lexer;
+ else
+ raise SAL.Programmer_Error with "tuple.alg " &
Generate_Algorithm'Image (Tuple.Gen_Alg) &
+ " input_data.user_lexer " & Lexer_Image
(Input_Data.User_Lexer).all;
+ end if;
+
+ if Check_Interface then
+ if Tuple.Interface_Kind in Valid_Interface then
+ Data.Interface_Kind := Valid_Interface (Tuple.Interface_Kind);
+ else
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, 1, "Interface_Kind
not set"));
+ end if;
+ else
+ Data.Interface_Kind := Process;
+ end if;
+
+ Data.Text_Rep := Tuple.Text_Rep;
+
+ Data.Lower_File_Name_Root := +To_Lower (Output_File_Root);
+ end return;
+ end Initialize;
+
+ function To_Token_Ada_Name (WY_Name : in String) return String
+ is
+ -- Convert WY_Name to a valid Ada identifier:
+ --
+ -- Add "_ID" to avoid collision with Ada reserved words
+ --
+ -- Replace '-' with '_'
+ Image : String := WY_Name;
+ begin
+ for I in Image'Range loop
+ if Image (I) = '-' then
+ Image (I) := '_';
+ end if;
+ end loop;
+ return Image & "_ID";
+ end To_Token_Ada_Name;
+
+end WisiToken.BNF.Output_Ada_Common;
diff --git a/wisitoken-bnf-output_ada_common.ads
b/wisitoken-bnf-output_ada_common.ads
new file mode 100644
index 0000000..b4d8923
--- /dev/null
+++ b/wisitoken-bnf-output_ada_common.ads
@@ -0,0 +1,91 @@
+-- Abstract :
+--
+-- Types and operations shared by Ada and Ada_Emacs outputs.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.BNF.Generate_Utils;
+with WisiToken.Generate.Packrat;
+with WisiToken_Grammar_Runtime;
+package WisiToken.BNF.Output_Ada_Common is
+
+ function To_Token_Ada_Name (WY_Name : in String) return String;
+
+ type Common_Data is limited record
+ -- Validated versions of Tuple values
+ Generate_Algorithm : WisiToken.BNF.Valid_Generate_Algorithm;
+ Lexer : Lexer_Type; -- 'none' valid for Libadalang
+ Output_Language : Ada_Output_Language;
+ Interface_Kind : Valid_Interface;
+ Text_Rep : Boolean;
+
+ Lower_File_Name_Root : Standard.Ada.Strings.Unbounded.Unbounded_String;
+ end record;
+
+ function Initialize
+ (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Tuple : in Generate_Tuple;
+ Output_File_Root : in String;
+ Check_Interface : in Boolean)
+ return Common_Data;
+
+ function File_Name_To_Ada (File_Name : in String) return String;
+
+ procedure Create_Ada_Actions_Spec
+ (Output_File_Name : in String;
+ Package_Name : in String;
+ Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Common_Data : in Output_Ada_Common.Common_Data;
+ Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data);
+
+ procedure Create_Ada_Main_Spec
+ (Output_File_Name : in String;
+ Main_Package_Name : in String;
+ Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Common_Data : in Output_Ada_Common.Common_Data)
+ with Pre => Common_Data.Generate_Algorithm /= External;
+
+ procedure Create_External_Main_Spec
+ (Main_Package_Name : in String;
+ Tuple : in Generate_Tuple;
+ Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type);
+
+ procedure LR_Create_Create_Parser
+ (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Common_Data : in out Output_Ada_Common.Common_Data;
+ Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data);
+ -- If not Common_Data.Text_Rep, includes LR parse table in generated
+ -- source. Otherwise, includes call to LR.Get_Text_Rep; caller must
+ -- call Put_Text_Rep to create file.
+
+ procedure Packrat_Create_Create_Parser
+ (Common_Data : in out Output_Ada_Common.Common_Data;
+ Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
+ Packrat_Data : in WisiToken.Generate.Packrat.Data);
+
+ procedure External_Create_Create_Grammar
+ (Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data);
+
+ procedure Create_re2c
+ (Input_Data : in
WisiToken_Grammar_Runtime.User_Data_Type;
+ Tuple : in Generate_Tuple;
+ Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
+ Output_File_Name_Root : in String;
+ Elisp_Regexps : in WisiToken.BNF.String_Pair_Lists.List);
+ -- Create_re2c is called from wisi-generate, which does not declare
+ -- Common_Data.
+
+end WisiToken.BNF.Output_Ada_Common;
diff --git a/wisitoken-bnf-output_ada_emacs.adb
b/wisitoken-bnf-output_ada_emacs.adb
new file mode 100644
index 0000000..136c6d3
--- /dev/null
+++ b/wisitoken-bnf-output_ada_emacs.adb
@@ -0,0 +1,1519 @@
+-- Abstract :
+--
+-- Output Ada code implementing the grammar defined by input
+-- parameters, and a parser for that grammar. The parser actions
+-- assume the Emacs Ada mode wisi indentation engine
+--
+-- If run in a separate process communicating over pipes with the
+-- Emacs process, the parser actions output encoded elisp actions;
+-- the protocol is documented in Emacs Ada mode wisi-process-parse.el,
+-- function wisi-process-parse-execute.
+--
+-- If run in an Emacs dynamically loaded module, the parser actions
+-- call the elisp actions directly.
+--
+-- Copyright (C) 2012 - 2015, 2017, 2018 Stephen Leake. 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
+-- 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.
+
+pragma License (Modified_GPL);
+
+with Ada.Exceptions;
+with Ada.Strings.Fixed;
+with Ada.Strings.Maps;
+with Ada.Text_IO; use Ada.Text_IO;
+with WisiToken.BNF.Generate_Packrat;
+with WisiToken.BNF.Generate_Utils;
+with WisiToken.BNF.Output_Ada_Common; use WisiToken.BNF.Output_Ada_Common;
+with WisiToken.BNF.Output_Elisp_Common; use WisiToken.BNF.Output_Elisp_Common;
+with WisiToken.Generate.Packrat;
+with WisiToken_Grammar_Runtime;
+procedure WisiToken.BNF.Output_Ada_Emacs
+ (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Output_File_Name_Root : in String;
+ Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
+ Packrat_Data : in WisiToken.Generate.Packrat.Data;
+ Tuple : in Generate_Tuple;
+ Test_Main : in Boolean;
+ Multiple_Tuples : in Boolean;
+ Language_Name : in String)
+is
+ use all type Ada.Containers.Count_Type;
+
+ Language_Runtime_Package : constant String := "Wisi." & Language_Name;
+
+ Blank_Set : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set (" ");
+
+ Common_Data : Output_Ada_Common.Common_Data :=
WisiToken.BNF.Output_Ada_Common.Initialize
+ (Input_Data, Tuple, Output_File_Name_Root, Check_Interface => True);
+
+ Gen_Alg_Name : constant String :=
+ (if Test_Main or Multiple_Tuples
+ then "_" & WisiToken.BNF.Generate_Algorithm_Image
(Common_Data.Generate_Algorithm).all
+ else "");
+
+ function Split_Sexp
+ (Item : in String;
+ Input_File_Name : in String;
+ Source_Line : in WisiToken.Line_Number_Type)
+ return String_Lists.List
+ is
+ -- Return one sexp per element. Remove comments, newlines, and outer
'(progn )'.
+
+ use WisiToken.Generate;
+
+ Progn_Index : constant Integer := Ada.Strings.Fixed.Index (Item,
"(progn");
+
+ Item_I : Integer := Item'First;
+
+ Buffer : String (Item'First .. Item'Last);
+ Buffer_J : Integer := Buffer'First;
+ Buffer_First : Integer := Buffer'First;
+ Paren_Count : Integer := 0;
+ In_Comment : Boolean := False;
+ Result : String_Lists.List;
+
+ Delete_Last_Paren : Boolean := False;
+ begin
+ -- Loop thru Item, copying chars to Buffer, ignoring comments, newlines.
+
+ if 0 /= Progn_Index then
+ Item_I := Progn_Index + 6;
+
+ Delete_Last_Paren := True;
+ end if;
+
+ loop
+ exit when Item_I > Item'Last;
+
+ if In_Comment then
+ if Item (Item_I) in ASCII.CR | ASCII.LF then
+ In_Comment := False;
+ end if;
+ else
+ if Item (Item_I) = '(' then
+ if Paren_Count = 0 then
+ Buffer_First := Buffer_J;
+ end if;
+ Paren_Count := Paren_Count + 1;
+
+ Buffer (Buffer_J) := Item (Item_I);
+ Buffer_J := Buffer_J + 1;
+
+ elsif Item (Item_I) = ')' then
+ Paren_Count := Paren_Count - 1;
+ if Paren_Count = 0 then
+ Buffer (Buffer_J) := Item (Item_I);
+ Result.Append (Buffer (Buffer_First .. Buffer_J));
+ Buffer_First := Buffer'First;
+ Buffer_J := Buffer'First;
+
+ elsif Paren_Count = -1 then
+ if Delete_Last_Paren then
+ -- all done
+ return Result;
+ else
+ Put_Error (Error_Message (Input_File_Name, Source_Line,
"mismatched parens"));
+ return String_Lists.Empty_List;
+ end if;
+ else
+ Buffer (Buffer_J) := Item (Item_I);
+ Buffer_J := Buffer_J + 1;
+ end if;
+
+ elsif Item (Item_I) in ASCII.CR | ASCII.LF then
+ null;
+
+ elsif Item (Item_I) = ';' and then Item_I < Item'Last and then
Item (Item_I + 1) = ';' then
+ In_Comment := True;
+
+ else
+ Buffer (Buffer_J) := Item (Item_I);
+ Buffer_J := Buffer_J + 1;
+ end if;
+ end if;
+ Item_I := Item_I + 1;
+ end loop;
+ if Paren_Count /= 0 then
+ Put_Error
+ (Error_Message
+ (Input_File_Name, Source_Line, "mismatched parens"));
+ end if;
+ return Result;
+ end Split_Sexp;
+
+ procedure Create_Ada_Action
+ (Name : in String;
+ RHS : in RHS_Type;
+ Unsplit_Lines : in Ada.Strings.Unbounded.Unbounded_String;
+ Check : in Boolean)
+ is
+ -- Create Action (if Check = False; Lines must be RHS.Action) or
+ -- Check (if Check = True; Lines must be RHS.Check) subprogram named
+ -- Name for RHS.
+
+ use Ada.Strings;
+ use Ada.Strings.Fixed;
+ use Ada.Strings.Unbounded;
+ use WisiToken.Generate;
+
+ Sexps : constant String_Lists.List := Split_Sexp
+ (-Unsplit_Lines, Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line);
+
+ use all type Ada.Strings.Maps.Character_Set;
+
+ Space_Paren_Set : constant Ada.Strings.Maps.Character_Set :=
+ Ada.Strings.Maps.To_Set ("])") or Blank_Set;
+
+ Navigate_Lines : String_Lists.List;
+ Face_Line : Unbounded_String;
+ Indent_Action_Line : Unbounded_String;
+ Check_Lines : String_Lists.List;
+
+ function Statement_Params (Params : in String) return String
+ is
+ -- Input looks like: [1 function 2 other ...]
+ Last : Integer := Index_Non_Blank (Params); -- skip [
+ First : Integer;
+ Second : Integer;
+ Need_Comma : Boolean := False;
+ Result : Unbounded_String;
+ Count : Integer := 0;
+ begin
+ loop
+ First := Last + 1;
+ Second := Index (Params, Blank_Set, First);
+ exit when Second = 0;
+
+ Count := Count + 1;
+ Last := Index (Params, Space_Paren_Set, Second + 1);
+
+ Result := Result & (if Need_Comma then ", " else "") &
+ "(" & Params (First .. Second - 1) & ", " &
+ Elisp_Name_To_Ada (Params (Second + 1 .. Last - 1), Append_ID =>
False, Trim => 0) & ")";
+
+ Need_Comma := True;
+ end loop;
+ if Count = 1 then
+ return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
+ else
+ return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
+ end if;
+ end Statement_Params;
+
+ function Containing_Params (Params : in String) return String
+ is
+ -- Input looks like: 1 2)
+ First : constant Integer := Index_Non_Blank (Params);
+ Second : constant Integer := Index (Params, Blank_Set, First);
+ begin
+ return " (Parse_Data, Tree, Nonterm, Tokens, " &
+ Params (First .. Second - 1) & ',' & Params (Second .. Params'Last);
+ end Containing_Params;
+
+ function Motion_Params (Params : in String) return String
+ is
+ -- Input looks like: [1 [2 EXCEPTION WHEN] 3 ...]
+ -- Result: (..., Motion_Param_Array'((1, Empty_IDs) & (2, (3 & 8)) &
(3, Empty_IDs))
+ use Generate_Utils;
+ use Ada.Strings.Maps;
+
+ Delim : constant Character_Set := To_Set ("]") or Blank_Set;
+
+ Last : Integer := Index_Non_Blank (Params); -- skip [
+ First : Integer;
+ Vector : Boolean;
+ Result : Unbounded_String := +" (Parse_Data, Tree, Nonterm, Tokens,
(";
+
+ Index_First : Integer;
+ Index_Last : Integer;
+ IDs : Unbounded_String;
+ IDs_Count : Integer;
+ Need_Comma_1 : Boolean := False;
+ Need_Comma_2 : Boolean := False;
+ begin
+ loop
+ Last := Index_Non_Blank (Params, Integer'Min (Params'Last, Last +
1));
+
+ exit when Params (Last) = ']' or Params (Last) = ')';
+
+ Vector := Params (Last) = '[';
+ if Vector then
+ Index_First := Last + 1;
+ Last := Index (Params, Delim, Index_First);
+ Index_Last := Last - 1;
+ IDs_Count := 0;
+ IDs := Null_Unbounded_String;
+ Need_Comma_2 := False;
+ loop
+ exit when Params (Last) = ']';
+ First := Last + 1;
+ Last := Index (Params, Delim, First);
+ IDs_Count := IDs_Count + 1;
+ begin
+ IDs := IDs & (if Need_Comma_2 then " & " else "") &
+ Trimmed_Image (Find_Token_ID (Generate_Data, Params
(First .. Last - 1)));
+ Need_Comma_2 := True;
+ exception
+ when E : Not_Found =>
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
+ Ada.Exceptions.Exception_Message (E)));
+ end;
+ end loop;
+
+ Result := Result & (if Need_Comma_1 then " & " else "") & "(" &
+ Params (Index_First .. Index_Last) & ", " &
+ (if IDs_Count = 1 then "+" else "") & IDs & ")";
+ else
+ First := Index_Non_Blank (Params, Last);
+ Last := Index (Params, Delim, First);
+ Result := Result & (if Need_Comma_1 then " & " else "") &
+ "(" & Params (First .. Last - 1) & ", Empty_IDs)";
+ end if;
+ Need_Comma_1 := True;
+ end loop;
+ return -(Result & "))");
+ end Motion_Params;
+
+ function Face_Apply_Params (Params : in String) return String
+ is
+ -- Params is a vector of triples: [1 nil font-lock-keyword-face 3
nil font-lock-function-name-face ...]
+ -- Result: ((1, 3, 1), (3, 3, 2), ...)
+ use Ada.Strings.Maps;
+ Delim : constant Character_Set := To_Set ("]") or Blank_Set;
+
+ Last : Integer := Index_Non_Blank (Params); -- skip [
+ First : Integer;
+ Result : Unbounded_String;
+ Need_Comma : Boolean := False;
+ Count : Integer := 0;
+ begin
+ loop
+ Last := Index_Non_Blank (Params, Last + 1);
+
+ exit when Params (Last) = ']' or Params (Last) = ')';
+
+ Count := Count + 1;
+ First := Last;
+ Last := Index (Params, Delim, First);
+ Result := Result & (if Need_Comma then ", (" else "(") & Params
(First .. Last - 1);
+
+ if Params (Last) = ']' then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"invalid wisi-face-apply argument"));
+ exit;
+ end if;
+
+ 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)));
+
+ if Params (Last) = ']' then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"invalid wisi-face-apply argument"));
+ exit;
+ end if;
+
+ 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))) & ")";
+
+ Need_Comma := True;
+ end loop;
+ if Count = 1 then
+ return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
+ else
+ return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
+ end if;
+ exception
+ when E : others =>
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "invalid
syntax: " &
+ Ada.Exceptions.Exception_Message (E)));
+ return "";
+ end Face_Apply_Params;
+
+ function Face_Mark_Params (Params : in String) return String
+ is
+ -- Params is a vector of pairs: [1 prefix 3 suffix ...]
+ -- Result: ((1, Prefix), (3, Suffix), ...)
+ use Ada.Strings.Maps;
+ Delim : constant Character_Set := To_Set ("]") or Blank_Set;
+
+ Last : Integer := Index_Non_Blank (Params); -- skip [
+ First : Integer;
+ Result : Unbounded_String;
+ Need_Comma : Boolean := False;
+ Count : Integer := 0;
+ begin
+ loop
+ Last := Index_Non_Blank (Params, Last + 1);
+
+ exit when Params (Last) = ']' or Params (Last) = ')';
+
+ Count := Count + 1;
+ First := Last;
+ Last := Index (Params, Delim, First);
+ Result := Result & (if Need_Comma then ", (" else "(") & Params
(First .. Last - 1);
+
+ if Params (Last) = ']' then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"invalid wisi-face-mark argument"));
+ exit;
+ end if;
+
+ First := Index_Non_Blank (Params, Last + 1);
+ Last := Index (Params, Delim, First);
+ Result := Result & ", " & Elisp_Name_To_Ada (Params (First .. Last
- 1), False, 0) & ")";
+
+ Need_Comma := True;
+ end loop;
+ if Count = 1 then
+ return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
+ else
+ return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
+ end if;
+ exception
+ when E : others =>
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "invalid
syntax: " &
+ Ada.Exceptions.Exception_Message (E)));
+ return "";
+ end Face_Mark_Params;
+
+ function Face_Remove_Params (Params : in String) return String
+ is
+ -- Params is a vector of token numbers: [1 3 ...]
+ -- Result: (1, 3, ...)
+ use Ada.Strings.Maps;
+ Delim : constant Character_Set := To_Set ("]") or Blank_Set;
+
+ Last : Integer := Index_Non_Blank (Params); -- skip [
+ First : Integer;
+ Result : Unbounded_String;
+ Need_Comma : Boolean := False;
+ Count : Integer := 0;
+ begin
+ loop
+ Last := Index_Non_Blank (Params, Last + 1);
+
+ exit when Params (Last) = ']' or Params (Last) = ')';
+
+ Count := Count + 1;
+ First := Last;
+ Last := Index (Params, Delim, First);
+ Result := Result & (if Need_Comma then ", " else "") & Params
(First .. Last - 1);
+
+ Need_Comma := True;
+ end loop;
+ if Count = 1 then
+ return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
+ else
+ return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
+ end if;
+ exception
+ when E : others =>
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "invalid
syntax: " &
+ Ada.Exceptions.Exception_Message (E)));
+ return "";
+ end Face_Remove_Params;
+
+ function Indent_Params (Params : in String; N : in String := "") return
String
+ is
+ -- If N is non-empty, it is the first arg in wisi-indent-action*,
followed by ','.
+ --
+ -- Params is a vector, one item for each token in Tokens. Each item
is one of:
+ --
+ -- - an integer; copy to output
+ --
+ -- - a symbol; convert to Ada name syntax
+ --
+ -- - a lisp function call with arbitrary args; convert to
Indent_Param type
+ --
+ -- - a vector with two elements [code_indent comment_indent];
convert to Indent_Pair.
+
+ use Ada.Strings.Maps;
+ use Ada.Containers;
+
+ Delim : constant Character_Set := To_Set ("])") or Blank_Set;
+
+ subtype Digit is Character range '0' .. '9';
+
+ Last : Integer := Index_Non_Blank (Params); -- skip [
+ Prefix : constant String := " (Parse_Data, Tree, Nonterm,
Tokens, " & N & "(";
+ Result : Unbounded_String;
+ Need_Comma : Boolean := False;
+ Param_Count : Count_Type := 0; -- in Params
+
+ function Indent_Label (Elisp_Name : in String) return String
+ is begin
+ if Elisp_Name = "wisi-anchored" then return "Anchored_0";
+ elsif Elisp_Name = "wisi-anchored%" then return "Anchored_1";
+ elsif Elisp_Name = "wisi-anchored%-" then return "Anchored_2";
+ elsif Elisp_Name = "wisi-anchored*" then return "Anchored_3";
+ elsif Elisp_Name = "wisi-anchored*-" then return "Anchored_4";
+ elsif Elisp_Name = "wisi-hanging" then return "Hanging_0";
+ elsif Elisp_Name = "wisi-hanging%" then return "Hanging_1";
+ elsif Elisp_Name = "wisi-hanging%-" then return "Hanging_2";
+ else
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"unrecognized wisi indent function: '" &
+ Elisp_Name & "'"));
+ return "";
+ end if;
+ end Indent_Label;
+
+ function Ensure_Simple_Indent (Item : in String) return String
+ is begin
+ -- Return an aggregate for Simple_Indent_Param. Item can be
anything
+ -- Expression returns except Hanging.
+
+ if Item (Item'First) = '(' then
+ -- Anchored or Language
+ return Item;
+
+ else
+ -- simple integer
+ return "(Int, " & Item & ")";
+ end if;
+ end Ensure_Simple_Indent;
+
+ function Expression (Param_First : in Integer) return String
+ is
+ -- Return a simple integer expression, or an aggregate for
+ -- Simple_Indent_Param or Indent_Param.
+ --
+ -- Handles this syntax:
+ --
+ -- integer literal:
+ -- 2 => 2
+ -- -1 => -1
+ --
+ -- variable name:
+ -- ada-indent => Ada_Indent
+ --
+ -- token_id literal:
+ -- 'TYPE => 13
+ --
+ -- simple expression with + - * :
+ -- (- ada-indent) => -Ada_Indent
+ -- (- ada-indent-when ada-indent) => Ada_Indent_When - Ada_Indent
+ --
+ -- if expression:
+ -- (if c a b) => (if c then a else b)
+ --
+ -- function call with expression args:
+ -- (wisi-hanging (wisi-anchored% 1 ada-indent)
+ -- (wisi-anchored% 1 (+ ada-indent
ada-indent-broken)))
+
+ use Generate_Utils;
+
+ First : Integer := Index_Non_Blank (Params, Param_First);
+
+ Function_Name : Unbounded_String;
+ Args : Unbounded_String;
+ Arg_Count : Count_Type := 0;
+ begin
+ if Params (First) in Digit or Params (First) = '-' then
+ Last := Index (Params, Delim, First);
+ return Params (First .. Last - 1);
+
+ elsif Params (First) = ''' then
+ Last := Index (Params, Delim, First);
+ return WisiToken.Trimmed_Image (Find_Token_ID (Generate_Data,
Params (First + 1 .. Last - 1)));
+
+ elsif Params (First) = '(' then
+ First := First + 1;
+ Last := Index (Params, Delim, First);
+ Function_Name := +Params (First .. Last - 1);
+
+ if Length (Function_Name) = 1 then
+ -- - + *
+ Last := Index (Params, Delim, Last + 1);
+ if Params (Last) = ')' then
+ return Result : constant String := -Function_Name &
Expression (First + 1)
+ do
+ Last := Last + 1; -- get past ')'
+ end return;
+ else
+ Args := +Expression (First + 1);
+ Args := Args & ' ' & Function_Name & ' ' & Expression
(Last + 1);
+
+ Last := Last + 1; -- get past ')'
+ return -Args;
+ end if;
+
+ elsif -Function_Name = "if" then
+ Args := +Expression (Last + 1);
+ Args := +"(if " & Args & " then " & Expression (Last + 1);
+ Args := Args & " else " & Expression (Last + 1) & ')';
+
+ Last := Last + 1; -- get past ')'
+ return -Args;
+
+ elsif Is_Present (Input_Data.User_Names.Indents,
-Function_Name) then
+ -- Language-specific function call
+ Function_Name := +Value (Input_Data.User_Names.Indents,
-Function_Name);
+ Arg_Count := 0;
+ loop
+ exit when Params (Last) = ')';
+
+ First := Last + 1;
+ if Arg_Count = 0 then
+ Args := +Expression (First);
+ else
+ Args := Args & " & " & Expression (First);
+ end if;
+ Arg_Count := Arg_Count + 1;
+ end loop;
+
+ Last := Last + 1; -- get past ')'
+
+ return "(Language, " & (-Function_Name) & "'Access, " &
+ (if Arg_Count = 0 then "Null_Args"
+ elsif Arg_Count = 1 then '+' & (-Args)
+ else -Args)
+ & ')';
+
+ else
+ -- wisi lisp function call
+ Function_Name := +Indent_Label (-Function_Name);
+ if Length (Function_Name) = 0 then
+ -- not a recognized function
+ Last := 1 + Index (Params, ")", Last);
+ return "";
+
+ elsif Slice (Function_Name, 1, 4) = "Hang" then
+ -- Arguments are 2 Simple_Indent_Param
+ Args := +Ensure_Simple_Indent (Expression (Last + 1));
+ Args := Args & ", " & Ensure_Simple_Indent (Expression
(Last + 1));
+ Last := Last + 1; -- get past ')'
+ return "(" & (-(Function_Name & ", " & Args)) & ")";
+ else
+ -- Arguments are 2 simple integer expressions
+ Args := +Expression (Last + 1);
+ Args := Args & ", " & Expression (Last + 1);
+ Last := Last + 1; -- get past ')'
+ return "(" & (-(Function_Name & ", " & Args)) & ")";
+ end if;
+ end if;
+
+ else
+ -- Assume it is a language-specific integer indent option,
like "ada-indent",
+ -- declared in Language_Runtime_Package, which is use-visible.
+ Last := Index (Params, Delim, First);
+ return Elisp_Name_To_Ada (Params (First .. Last - 1), False, 0);
+ end if;
+ exception
+ when E : others =>
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Ada.Exceptions.Exception_Message (E)));
+ return "";
+ end Expression;
+
+ function Ensure_Indent_Param (Item : in String) return String
+ is begin
+ -- Return an aggregate for Indent_Param. Item can be anything
+ -- Expression returns.
+ if Item'Length = 0 then
+ -- Expression could not find an indent function
+ return Item;
+
+ elsif Item'Length >= 5 and then Item (Item'First .. Item'First +
4) = "(Hang" then
+ return Item;
+
+ elsif Item (Item'First) = '(' then
+ -- Anchored or Language
+ return "(Simple, " & Item & ")";
+
+ else
+ -- simple integer
+ return "(Simple, (Int, " & Item & "))";
+ end if;
+ end Ensure_Indent_Param;
+
+ begin
+ loop
+ if Params (Last) /= ']' then
+ Last := Index_Non_Blank (Params, Last + 1);
+ end if;
+
+ exit when Params (Last) = ']';
+
+ if Need_Comma then
+ Result := Result & ", ";
+ else
+ Need_Comma := True;
+ end if;
+
+ case Params (Last) is
+ when '(' =>
+ Result := Result & "(False, " & Ensure_Indent_Param (Expression
(Last)) & ')';
+
+ when '[' =>
+ -- vector
+ Result := Result & "(True, " & Ensure_Indent_Param (Expression
(Last + 1));
+ Result := Result & ", " & Ensure_Indent_Param (Expression (Last
+ 1)) & ')';
+ if Params (Last) /= ']' then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"invalid indent syntax"));
+ end if;
+ Last := Last + 1;
+
+ when others =>
+ -- integer or symbol
+ Result := Result & "(False, " & Ensure_Indent_Param (Expression
(Last)) & ')';
+
+ end case;
+ Param_Count := Param_Count + 1;
+ end loop;
+
+ if Param_Count /= RHS.Tokens.Length then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "indent
parameters count of" & Count_Type'Image
+ (Param_Count) & " /= production token count of" &
Count_Type'Image (RHS.Tokens.Length)));
+ end if;
+
+ if Param_Count = 1 then
+ Result := Prefix & "1 => " & Result;
+ else
+ Result := Prefix & Result;
+ end if;
+
+ return -(Result & "))");
+ end Indent_Params;
+
+ function Merge_Names_Params (Params : in String) return String
+ is
+ -- Input looks like "1 2)"
+ First : constant Integer := Index_Non_Blank (Params);
+ Second : constant Integer := Index (Params, Blank_Set, First);
+ begin
+ return " (Nonterm, Tokens, " & Params (First .. Second - 1) & ',' &
+ Params (Second .. Params'Last);
+ end Merge_Names_Params;
+
+ function Match_Names_Params (Params : in String) return String
+ is
+ -- Input looks like: 1 2)
+ First : constant Integer := Index_Non_Blank (Params);
+ Second : constant Integer := Index (Params, Blank_Set, First);
+ begin
+ return " (Lexer, Descriptor, Tokens, " &
+ Params (First .. Second - 1) & ',' &
+ Params (Second .. Params'Last - 1) & ", " &
+ (if Length (Input_Data.Language_Params.End_Names_Optional_Option) > 0
+ then -Input_Data.Language_Params.End_Names_Optional_Option
+ else "False") & ")";
+ end Match_Names_Params;
+
+ procedure Translate_Line (Line : in String)
+ is
+ Last : constant Integer := Index (Line, Blank_Set);
+ Elisp_Name : constant String := Line (Line'First + 1 .. Last - 1);
+ begin
+ -- wisi action/check functions, in same order as typically used in
+ -- .wy files; Navigate, Face, Indent, Check.
+ if Elisp_Name = "wisi-statement-action" then
+ Navigate_Lines.Append
+ (Elisp_Name_To_Ada (Elisp_Name, False, 5) &
+ Statement_Params (Line (Last + 1 .. Line'Last)) & ";");
+
+ elsif Elisp_Name = "wisi-containing-action" then
+ Navigate_Lines.Append
+ (Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
+ Containing_Params (Line (Last + 1 .. Line'Last)) & ";");
+
+ elsif Elisp_Name = "wisi-motion-action" then
+ Navigate_Lines.Append
+ (Elisp_Name_To_Ada (Elisp_Name, False, Trim => 5) &
+ Motion_Params (Line (Last + 1 .. Line'Last)) & ";");
+
+ elsif Elisp_Name = "wisi-face-apply-action" then
+ if Length (Face_Line) = 0 then
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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) & ";");
+
+ 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)) & ";");
+
+ 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)) & ";");
+
+ else
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"unrecognized elisp action: '" &
+ Elisp_Name & "'"));
+ end if;
+ end Translate_Line;
+
+ begin
+ for Sexp of Sexps loop
+ begin
+ Translate_Line (Sexp);
+ exception
+ when E : Not_Found =>
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Ada.Exceptions.Exception_Message (E)));
+ end;
+ end loop;
+
+ 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 (" 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"));
+ begin
+ if Unref_Lexer or Unref_Nonterm then
+ Indent_Line ("is");
+ if Unref_Lexer then
+ Indent_Line (" pragma Unreferenced (Lexer);");
+ end if;
+ if Unref_Nonterm then
+ Indent_Line (" pragma Unreferenced (Nonterm);");
+ end if;
+ 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;
+ else
+ -- In an action
+ Indent_Line ("procedure " & Name);
+ Indent_Line (" (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class;");
+ Indent_Line (" Tree : in out WisiToken.Syntax_Trees.Tree;");
+ Indent_Line (" Nonterm : in
WisiToken.Syntax_Trees.Valid_Node_Index;");
+ Indent_Line (" Tokens : in
WisiToken.Syntax_Trees.Valid_Node_Index_Array)");
+ Indent_Line ("is");
+ Indent_Start (" Parse_Data : Wisi.Parse_Data_Type renames");
+ Put_Line (" Wisi.Parse_Data_Type (User_Data);");
+ Indent_Line ("begin");
+ Indent := Indent + 3;
+
+ Indent_Line ("case Parse_Data.Post_Parse_Action is");
+ Indent_Line ("when Navigate =>");
+ if Navigate_Lines.Length > 0 then
+ Indent := Indent + 3;
+ for Line of Navigate_Lines loop
+ Indent_Wrap (Line);
+ end loop;
+ Indent := Indent - 3;
+ else
+ Indent_Line (" null;");
+ end if;
+
+ Indent_Line ("when Face =>");
+ if Length (Face_Line) > 0 then
+ Indent := Indent + 3;
+ Indent_Wrap (-Face_Line);
+ Indent := Indent - 3;
+ else
+ Indent_Line (" null;");
+ end if;
+
+ Indent_Line ("when Indent =>");
+ if Length (Indent_Action_Line) > 0 then
+ Indent := Indent + 3;
+ Indent_Wrap (-Indent_Action_Line);
+ Indent := Indent - 3;
+ else
+ Indent_Line (" null;");
+ end if;
+ Indent_Line ("end case;");
+ end if;
+
+ Indent := Indent - 3;
+ Indent_Line ("end " & Name & ";");
+ New_Line;
+
+ end Create_Ada_Action;
+
+ function Any_Motion_Actions return Boolean
+ is begin
+ for Rule of Input_Data.Tokens.Rules loop
+ for RHS of Rule.Right_Hand_Sides loop
+ for Sexp of Split_Sexp (-RHS.Action,
Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line) loop
+ declare
+ Last : constant Integer := Ada.Strings.Fixed.Index
(Sexp, Blank_Set);
+ Elisp_Name : constant String := Sexp (Sexp'First + 1 ..
Last - 1);
+ begin
+ if Elisp_Name = "wisi-motion-action" then
+ return True;
+ end if;
+ end;
+ end loop;
+ end loop;
+ end loop;
+ return False;
+ end Any_Motion_Actions;
+
+ procedure Create_Ada_Actions_Body
+ (Action_Names : not null access WisiToken.Names_Array_Array;
+ Check_Names : not null access WisiToken.Names_Array_Array;
+ Package_Name : in String)
+ is
+ use Ada.Strings.Unbounded;
+ use Generate_Utils;
+ use WisiToken.Generate;
+
+ File_Name : constant String := Output_File_Name_Root &
+ (case Common_Data.Interface_Kind is
+ when Process => "_process_actions",
+ when Module => "_module_actions") &
+ ".adb";
+
+ Motion_Actions : constant Boolean := Any_Motion_Actions;
+
+ Body_File : File_Type;
+
+ begin
+ Create (Body_File, Out_File, File_Name);
+ Set_Output (Body_File);
+ Indent := 1;
+ Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
+ New_Line;
+
+ Put_Line ("with Wisi; use Wisi;");
+ if Input_Data.Language_Params.Language_Runtime then
+ Put_Line ("with " & Language_Runtime_Package & "; use " &
Language_Runtime_Package & ";");
+ -- For language-specific names in actions, checks.
+ end if;
+
+ case Common_Data.Interface_Kind is
+ when Process =>
+ null;
+
+ when Module =>
+ Put_Line ("with Emacs_Module_Aux; use Emacs_Module_Aux;");
+ Put_Line ("with Ada.Exceptions;");
+ Put_Line ("with Ada.Strings.Unbounded;");
+ end case;
+
+ Put_Line ("package body " & Package_Name & " is");
+ Indent := Indent + 3;
+ New_Line;
+
+ if Input_Data.Check_Count > 0 then
+ Indent_Line ("use WisiToken.Semantic_Checks;");
+ end if;
+ if Motion_Actions then
+ Indent_Line ("use all type Motion_Param_Array;");
+ end if;
+ New_Line;
+
+ -- generate Action and Check subprograms.
+
+ for Rule of Input_Data.Tokens.Rules loop
+ -- No need for a Token_Cursor here, since we only need the
+ -- nonterminals.
+ declare
+ LHS_ID : constant WisiToken.Token_ID := Find_Token_ID
(Generate_Data, -Rule.Left_Hand_Side);
+ Prod_Index : Integer := 0; -- Semantic_Action
defines Prod_Index as zero-origin
+ begin
+ for RHS of Rule.Right_Hand_Sides loop
+ if Length (RHS.Action) > 0 then
+ declare
+ Name : constant String := Action_Names
(LHS_ID)(Prod_Index).all;
+ begin
+ Create_Ada_Action (Name, RHS, RHS.Action, Check => False);
+ end;
+ end if;
+
+ if Length (RHS.Check) > 0 then
+ declare
+ Name : constant String := Check_Names
(LHS_ID)(Prod_Index).all;
+ begin
+ Create_Ada_Action (Name, RHS, RHS.Check, Check => True);
+ end;
+ end if;
+ Prod_Index := Prod_Index + 1;
+ end loop;
+ end;
+ end loop;
+
+ Put_Line ("end " & Package_Name & ";");
+ Close (Body_File);
+
+ Set_Output (Standard_Output);
+
+ end Create_Ada_Actions_Body;
+
+ procedure Create_Ada_Main_Body
+ (Actions_Package_Name : in String;
+ Main_Package_Name : in String)
+ is
+ use WisiToken.Generate;
+
+ File_Name : constant String := To_Lower (Main_Package_Name) & ".adb";
+ Body_File : File_Type;
+ begin
+ Create (Body_File, Out_File, File_Name);
+ Set_Output (Body_File);
+ Indent := 1;
+ Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
+ Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
+ New_Line;
+
+ Put_Line ("with " & Actions_Package_Name & "; use " &
Actions_Package_Name & ";");
+
+ case Common_Data.Lexer is
+ when None | Elisp_Lexer =>
+ null;
+
+ when re2c_Lexer =>
+ Put_Line ("with WisiToken.Lexer.re2c;");
+ Put_Line ("with " & Output_File_Name_Root & "_re2c_c;");
+
+ end case;
+
+ case Common_Data.Generate_Algorithm is
+ when LR_Generate_Algorithm =>
+ if Tuple.Text_Rep then
+ Put_Line ("with WisiToken.Productions;");
+ end if;
+
+ when Packrat_Generate_Algorithm =>
+ Put_Line ("with WisiToken.Parse;");
+
+ when External =>
+ null;
+ end case;
+
+ Put_Line ("package body " & Main_Package_Name & " is");
+ Indent := Indent + 3;
+ New_Line;
+
+ case Common_Data.Lexer is
+ when None | Elisp_Lexer =>
+ null;
+
+ when re2c_Lexer =>
+ Indent_Line ("package Lexer is new WisiToken.Lexer.re2c");
+ Indent_Line (" (" & Output_File_Name_Root & "_re2c_c.New_Lexer,");
+ Indent_Line (" " & Output_File_Name_Root & "_re2c_c.Free_Lexer,");
+ Indent_Line (" " & Output_File_Name_Root & "_re2c_c.Reset_Lexer,");
+ Indent_Line (" " & Output_File_Name_Root & "_re2c_c.Next_Token);");
+ New_Line;
+ end case;
+
+ case Common_Data.Generate_Algorithm is
+ when LR_Generate_Algorithm =>
+ LR_Create_Create_Parser (Input_Data, Common_Data, Generate_Data);
+
+ when Packrat_Gen =>
+ WisiToken.BNF.Generate_Packrat (Packrat_Data, Generate_Data);
+ Packrat_Create_Create_Parser (Common_Data, Generate_Data,
Packrat_Data);
+
+ when Packrat_Proc =>
+ Packrat_Create_Create_Parser (Common_Data, Generate_Data,
Packrat_Data);
+
+ when External =>
+ External_Create_Create_Grammar (Generate_Data);
+ end case;
+
+ case Common_Data.Interface_Kind is
+ when Process =>
+ null;
+ when Module =>
+ Indent_Line ("Parser : LR_Parser.Instance;");
+ New_Line;
+
+ Indent_Line ("function Parse (Env : Emacs_Env_Access) return
emacs_module_h.emacs_value");
+ Indent_Line ("is begin");
+ Indent := Indent + 3;
+ Indent_Line ("WisiToken.Trace_Parse := To_Integer (Env, Symbol_Value
(Env, Elisp_Symbols (Wisi_Debug_ID)));");
+ Indent_Line ("Wisi_Cache_Max := To_Integer (Env, Symbol_Value (Env,
Elisp_Symbols (Wisi_Cache_Max_ID)));");
+ Indent_Line ("Parser.Reset;");
+ Indent_Line ("Parser.Parse;");
+ Indent_Line ("return Env.Qnil;");
+ Indent := Indent - 3;
+ Indent_Line ("exception");
+ Indent_Line ("when E : WisiToken.Parse_Error | WisiToken.Syntax_Error
=>");
+ Indent_Line (" return To_Emacs (Env,
Ada.Exceptions.Exception_Message (E));");
+ Indent_Line ("when E : others =>");
+ Indent_Line (" declare");
+ Indent_Line (" use Ada.Exceptions;");
+ Indent_Line (" begin");
+ Indent_Line (" return To_Emacs (Env, Exception_Name (E) & "": ""
& Exception_Message (E));");
+ Indent_Line (" end;");
+ Indent_Line ("end Parse;");
+ New_Line;
+
+ Indent_Line ("function Init (Env : Emacs_Env_Access) return
Interfaces.C.int");
+ Indent_Line ("is");
+ Indent_Line (" Lexer_Elisp_Symbols :
Lexers.Elisp_Array_Emacs_Value;");
+ Indent_Line ("begin");
+ Indent_Line (" " & Main_Package_Name & ".Env := Env;");
+ Indent_Line (" Emacs_Module_Aux.Init (Env);");
+ Indent_Line (" for I in Token_Symbols'Range loop");
+ Indent_Line (" Token_Symbols (I) := Intern_Soft (Env,
Token_Images (I).all);");
+ Indent_Line (" end loop;");
+ Indent_Line (" for I in Elisp_Symbols'Range loop");
+ Indent_Line (" Elisp_Symbols (I) := Intern_Soft (Env, User_Names
(I).all);");
+ Indent_Line (" end loop;");
+ Indent_Line (" for I in Elisp_Numbers'Range loop");
+ 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 (" end loop;");
+ Indent_Line (" Parser := Create_Parser (Env,
Lexer_Elisp_Symbols);");
+ Indent_Line (" return 0;");
+ Indent_Line ("exception");
+ Indent_Line ("when E : others =>");
+ Indent_Line
+ (" Signal_Error (Env, " &
+ "Ada.Exceptions.Exception_Name (E) & "": "" &
Ada.Exceptions.Exception_Message (E), Env.Qnil);");
+ Indent_Line (" return 1;");
+ Indent_Line ("end Init;");
+ New_Line;
+ end case;
+
+ Put_Line ("end " & Main_Package_Name & ";");
+ Close (Body_File);
+
+ Set_Output (Standard_Output);
+
+ end Create_Ada_Main_Body;
+
+ procedure Create_Process_Elisp
+ is
+ use Generate_Utils;
+ use WisiToken.Generate;
+
+ File : File_Type;
+
+ Paren_1_Done : Boolean := False;
+ begin
+ Create (File, Out_File, Output_File_Name_Root & "-process.el");
+ Set_Output (File);
+ Indent := 1;
+
+ Put_Line
+ (";;; " & Output_File_Name_Root & "-process.el --- Generated parser
support file -*- lexical-binding:t -*-");
+ Put_Command_Line (Elisp_Comment & " ", Use_Tuple => True, Tuple =>
Tuple);
+ Put_Raw_Code (Elisp_Comment, Input_Data.Raw_Code (Copyright_License));
+ New_Line;
+ Put_Line ("(require 'wisi-process-parse)");
+ New_Line;
+
+ Indent_Line ("(defconst " & Output_File_Name_Root &
"-process-token-table");
+ Indent_Start (" [");
+ Indent := Indent + 3;
+ for Cursor in All_Tokens (Generate_Data).Iterate loop
+ if Paren_1_Done then
+ Indent_Line (Name (Cursor));
+ else
+ Paren_1_Done := True;
+ Put_Line (Name (Cursor));
+ end if;
+
+ end loop;
+ Indent_Line ("])");
+ Indent := Indent - 3;
+ New_Line;
+
+ Output_Elisp_Common.Indent_Name_Table
+ (Output_File_Name_Root, "process-face-table",
Input_Data.User_Names.Faces);
+
+ Put_Line ("(provide '" & Output_File_Name_Root & "-process)");
+ Set_Output (Standard_Output);
+ Close (File);
+
+ end Create_Process_Elisp;
+
+ procedure Create_Module_Elisp
+ is
+ use Ada.Strings.Unbounded;
+ use Generate_Utils;
+ use WisiToken.Generate;
+
+ Lower_Package_Name_Root : constant String := To_Lower (File_Name_To_Ada
(Output_File_Name_Root));
+
+ function To_ID_Image (Name : in Ada.Strings.Unbounded.Unbounded_String)
return String
+ is begin
+ -- Ada 'Val is 0 origin; Token_ID is 1 origin
+ return Token_ID'Image (-1 + Find_Token_ID (Generate_Data, -Name));
+ end To_ID_Image;
+
+ File : File_Type;
+ begin
+ Create (File, Out_File, Output_File_Name_Root & "-module.el");
+ Set_Output (File);
+ Indent := 1;
+
+ Put_Line (";; generated by WisiToken Wisi from " &
Input_Data.Grammar_Lexer.File_Name);
+ Put_Command_Line (";; ", Use_Tuple => True, Tuple => Tuple);
+ Put_Line (";;");
+
+ -- don't need the prologue here
+
+ Put_Line ("(require 'wisi-parse-common)");
+ New_Line;
+
+ -- Lexer tables; also contain terminals for wisi-tokens
+ Indent_Keyword_Table (Output_File_Name_Root, "elisp",
Input_Data.Tokens.Keywords, To_String'Access);
+ Indent_Keyword_Table (Output_File_Name_Root, "module",
Input_Data.Tokens.Keywords, To_ID_Image'Access);
+ Indent_Token_Table (Output_File_Name_Root, "elisp",
Input_Data.Tokens.Tokens, To_String'Access);
+ Indent_Token_Table (Output_File_Name_Root, "module",
Input_Data.Tokens.Tokens, To_ID_Image'Access);
+
+ -- non-terminals. We only need the ones that actually have
+ -- actions, and thus will appear in a call to To_Emacs. But
+ -- Token_Symbols must be indexed by Token_ID, so we declare
+ -- all of them.
+ Indent_Line ("(defconst " & Output_File_Name_Root & "-module-nonterms");
+ Indent_Line (" '(");
+ Indent := Indent + 3;
+ Indent_Line (WisiToken_Accept_Name);
+ for Rule of Input_Data.Tokens.Rules loop
+ Indent_Line (-Rule.Left_Hand_Side);
+ end loop;
+ Indent_Line ("))");
+ Indent := Indent - 3;
+ New_Line;
+
+ Indent_Line
+ ("(cl-defstruct (" & Lower_Package_Name_Root &
+ "-wisi-module-parser (:include wisi-parser)))");
+ New_Line;
+ Indent_Line ("(defun " & Lower_Package_Name_Root &
"-wisi-module-parser-make (dll-name)");
+ Indent_Line (" (module-load dll-name)");
+ Indent_Line (" (make-" & Lower_Package_Name_Root &
"-wisi-module-parser))");
+ New_Line;
+
+ Indent_Line ("(defvar " & Lower_Package_Name_Root & "-module-lexer
nil)");
+ Indent_Line
+ ("(declare-function " &
+ Lower_Package_Name_Root &
+ "-wisi-module-parse """ &
+ Lower_Package_Name_Root &
+ "-wisi-module-parse.c"")");
+ New_Line;
+
+ Indent_Line
+ ("(cl-defmethod wisi-parse-current ((parser " &
+ Lower_Package_Name_Root &
+ "-wisi-module-parser))");
+ Indent := Indent + 2;
+ Indent_Line ("(let* ((wisi-lexer " & Lower_Package_Name_Root &
"-module-lexer)");
+ Indent_Line (" (result (" & Lower_Package_Name_Root &
"-wisi-module-parse)))");
+ -- Result is nil for no errors, a string for some error.
+ -- Ada code has already added line:column, but not file name
+ Indent_Line (" (when result");
+ Indent_Line (" (signal 'wisi-parse-error (format ""%s:%s""
(buffer-name) result)))))");
+ New_Line;
+ Indent := Indent - 2;
+
+ Indent_Line ("(provide '" & Output_File_Name_Root & "-module)");
+ Set_Output (Standard_Output);
+ Close (File);
+
+ end Create_Module_Elisp;
+
+ procedure Create_Module_Aux
+ is
+ use WisiToken.Generate;
+
+ Package_Name_Root : constant String := File_Name_To_Ada
(Output_File_Name_Root);
+ Lower_Package_Name_Root : constant String := To_Lower
(Package_Name_Root);
+
+ File : File_Type;
+ begin
+ Create (File, Out_File, Output_File_Name_Root &
"_wisi_module_parse.gpr");
+ Set_Output (File);
+ Indent := 1;
+ Put_Line ("-- generated by WisiToken Wisi from " &
Input_Data.Grammar_Lexer.File_Name);
+ Put_Command_Line ("-- ", Use_Tuple => True, Tuple => Tuple);
+ Indent_Line ("with ""wisi_module_parse_common"";");
+ Indent_Line ("library project " & Package_Name_Root &
"_Wisi_Module_Parse is");
+ New_Line;
+ Indent := Indent + 3;
+ Indent_Line ("for Languages use (""Ada"");");
+ Indent_Line ("for Source_Dirs use (""../.."", ""."");");
+ New_Line;
+ Indent_Line ("for Source_Files use");
+ Indent_Line (" (");
+ Indent := Indent + 3;
+ Indent_Line ("""emacs_module_aux.ads"",");
+ Indent_Line ("""emacs_module_aux.adb"",");
+ Indent_Line ("""emacs_module_h.ads"",");
+ Indent_Line ("""fasttoken-lexer-wisi_elisp.adb"",");
+ Indent_Line ("""fasttoken-lexer-wisi_elisp.ads"",");
+ Indent_Line ("""" & Lower_Package_Name_Root & "_module.adb"",");
+ Indent_Line ("""" & Lower_Package_Name_Root & "_module.ads""");
+ Indent := Indent - 3;
+ Indent_Line (" );");
+ New_Line;
+ Indent_Line ("for Object_Dir use ""libobjsjlj"";");
+ Indent_Line ("for Library_Name use """ & Lower_Package_Name_Root &
"_wisi_module_parse"";");
+ Indent_Line ("for Library_Dir use ""libsjlj"";");
+ -- This library is linked with *_wisi_module_parse_wrapper.c to
+ -- make a dynamic library
+ Indent_Line ("for Library_Kind use ""static"";");
+ New_Line;
+ Indent_Line ("package Compiler is");
+ Indent := Indent + 3;
+ Indent_Line
+ ("for Default_Switches (""Ada"") use
Wisi_Module_Parse_Common.Compiler'Default_Switches (""Ada"");");
+
+ -- Grammar files can get very large, so they need some special switches:
+ --
+ -- 'Wisi_Module_Parse_Common.Compiler'Default_Switches' includes
'gnatn', but that hangs
+ Indent_Line ("case Wisi_Module_Parse_Common.Build is");
+ Indent_Line ("when ""Debug"" =>");
+ Indent_Line (" for Switches (""" & Lower_Package_Name_Root &
"_module.adb"") use");
+ Indent_Line (" Wisi_Module_Parse_Common.Compiler.Common_Switches &");
+ Indent_Line (" Wisi_Module_Parse_Common.Compiler.Standard_Style &");
+ Indent_Line (" (""-O0"");");
+ Indent_Line ("when ""Normal"" =>");
+ Indent_Line (" for Switches (""" & Lower_Package_Name_Root &
"_module.adb"") use");
+ Indent_Line (" Wisi_Module_Parse_Common.Compiler.Common_Switches &");
+ Indent_Line (" Wisi_Module_Parse_Common.Compiler.Standard_Style &");
+ Indent_Line (" (""-O2"");");
+ Indent_Line ("end case;");
+
+ Indent := Indent - 3;
+ Indent_Line ("end Compiler;");
+ New_Line;
+ Indent_Line ("package Builder is");
+ Indent_Line
+ (" for Default_Switches (""Ada"") use
Wisi_Module_Parse_Common.Builder'Default_Switches (""Ada"");");
+ Indent_Line ("end Builder;");
+ Indent := Indent - 3;
+ New_Line;
+ Indent_Line ("end " & Package_Name_Root & "_Wisi_Module_Parse;");
+ Set_Output (Standard_Output);
+ Close (File);
+
+ Create (File, Out_File, Output_File_Name_Root &
"_wisi_module_parse_agg.gpr");
+ Set_Output (File);
+ Indent := 1;
+ Put_Line ("-- generated by WisiToken Wisi from " &
Input_Data.Grammar_Lexer.File_Name);
+ Put_Command_Line ("-- ", Use_Tuple => True, Tuple => Tuple);
+ Indent_Line ("aggregate project " & Package_Name_Root &
"_Wisi_Module_Parse_Agg is");
+ Indent_Line (" for Project_Path use (external (""WISI_FASTTOKEN""));");
+ Indent_Line (" for Project_files use (""" & Lower_Package_Name_Root &
"_wisi_module_parse.gpr"");");
+ Indent_Line ("end " & Package_Name_Root & "_Wisi_Module_Parse_Agg;");
+ Set_Output (Standard_Output);
+ Close (File);
+
+ Create (File, Out_File, Output_File_Name_Root &
"_wisi_module_parse_wrapper.c");
+ Set_Output (File);
+ Indent := 1;
+ Put_Line ("// generated by WisiToken Wisi from " &
Input_Data.Grammar_Lexer.File_Name);
+ Put_Command_Line ("// ", Use_Tuple => True, Tuple => Tuple);
+ Indent_Line ("// This file is just a wrapper around the Ada code in");
+ Indent_Line ("// *_wisi_module_parse.adb; it is needed to call
adainit.");
+ Indent_Line ("#include <emacs_module.h>");
+ Indent_Line ("int plugin_is_GPL_compatible;");
+ Indent_Line ("extern void adainit(void);");
+ Indent_Line ("extern int " & Lower_Package_Name_Root &
"_wisi_module_parse_init (emacs_env *env);");
+ Indent_Line ("/* Parse current buffer, using parser in current module.
*/");
+ Indent_Line ("extern emacs_value " & Lower_Package_Name_Root &
"_wisi_module_parse (emacs_env *env);");
+ Indent_Line ("static emacs_value Fparse (emacs_env *env, int nargs,
emacs_value args[])");
+ Indent_Line ("{");
+ Indent_Line (" return " & Lower_Package_Name_Root & "_wisi_module_parse
(env);");
+ Indent_Line ("}");
+ New_Line;
+ Indent_Line ("int emacs_module_init (struct emacs_runtime *ert)");
+ Indent_Line ("{");
+ Indent_Line (" emacs_env *env = ert->get_environment (ert);");
+ Indent_Line
+ (" env->bind_function (env, """ & Lower_Package_Name_Root &
+ "-wisi-module-parse"", env->make_function (env, 1, 1, Fparse));");
+ Indent_Line (" adainit();");
+ Indent_Line (" return " & Lower_Package_Name_Root &
"_wisi_module_parse_init (env);");
+ Indent_Line ("}");
+ Set_Output (Standard_Output);
+ Close (File);
+ end Create_Module_Aux;
+
+begin
+ case Common_Data.Lexer is
+ when None | re2c_Lexer =>
+ null;
+
+ when Elisp_Lexer =>
+ raise User_Error with WisiToken.Generate.Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, 1, "Ada_Emacs output language
does not support " &
+ Lexer_Image (Common_Data.Lexer).all & " lexer");
+ end case;
+
+ declare
+ Actions_Package_Name : constant String := File_Name_To_Ada
(Output_File_Name_Root) &
+ (case Common_Data.Interface_Kind is
+ when Process => "_Process_Actions",
+ when Module => "_Module_Actions");
+
+ Main_Package_Name : constant String := File_Name_To_Ada
(Output_File_Name_Root) &
+ (case Common_Data.Interface_Kind is
+ when Process => "_Process",
+ when Module => "_Module") &
+ Gen_Alg_Name & "_Main";
+ begin
+ Create_Ada_Actions_Body (Generate_Data.Action_Names,
Generate_Data.Check_Names, Actions_Package_Name);
+
+ Create_Ada_Actions_Spec
+ (Output_File_Name => Output_File_Name_Root &
+ (case Common_Data.Interface_Kind is
+ when Process => "_process_actions.ads",
+ when Module => "_module_actions.ads"),
+ Package_Name => Actions_Package_Name,
+ Input_Data => Input_Data,
+ Common_Data => Common_Data,
+ Generate_Data => Generate_Data);
+
+ if Tuple.Gen_Alg = External then
+ Create_External_Main_Spec (Main_Package_Name, Tuple, Input_Data);
+
+ Create_Ada_Main_Body (Actions_Package_Name, Main_Package_Name);
+ else
+ Create_Ada_Main_Body (Actions_Package_Name, Main_Package_Name);
+
+ Create_Ada_Main_Spec
+ (Output_File_Name => Output_File_Name_Root & "_" &
+ To_Lower (Interface_Type'Image (Common_Data.Interface_Kind)) &
+ To_Lower (Gen_Alg_Name) & "_main.ads",
+ Main_Package_Name => Main_Package_Name,
+ Common_Data => Common_Data,
+ Input_Data => Input_Data);
+ end if;
+ end;
+
+ case Common_Data.Interface_Kind is
+ when Process =>
+ Create_Process_Elisp;
+
+ when Module =>
+ Create_Module_Elisp;
+ Create_Module_Aux;
+ end case;
+exception
+when others =>
+ Set_Output (Standard_Output);
+ raise;
+end WisiToken.BNF.Output_Ada_Emacs;
diff --git a/wisitoken-bnf-output_elisp.adb b/wisitoken-bnf-output_elisp.adb
new file mode 100644
index 0000000..8317ac7
--- /dev/null
+++ b/wisitoken-bnf-output_elisp.adb
@@ -0,0 +1,293 @@
+-- Abstract :
+--
+-- Output Elisp code implementing the grammar defined by the parameters.
+--
+-- Copyright (C) 2012 - 2015, 2017, 2018 Stephen Leake. 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
+-- 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.
+
+pragma License (Modified_GPL);
+
+with Ada.Text_IO; use Ada.Text_IO;
+with WisiToken.BNF.Generate_Utils;
+with WisiToken.BNF.Output_Elisp_Common;
+with WisiToken.Generate.Packrat;
+with WisiToken.Parse.LR;
+with WisiToken_Grammar_Runtime;
+procedure WisiToken.BNF.Output_Elisp
+ (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Elisp_Package : in String;
+ Generate_Data : aliased in WisiToken.BNF.Generate_Utils.Generate_Data;
+ Packrat_Data : in WisiToken.Generate.Packrat.Data;
+ Tuple : in Generate_Tuple)
+is
+ pragma Unreferenced (Packrat_Data);
+
+ procedure Action_Table (Table : in WisiToken.Parse.LR.Parse_Table;
Descriptor : in WisiToken.Descriptor)
+ is
+ use WisiToken.Parse.LR;
+ begin
+ Put (" [");
+ for State in Table.States'Range loop
+ if State = Table.States'First then
+ Put ("(");
+ else
+ Put (" (");
+ end if;
+
+ Put ("(default . error)");
+
+ declare
+ Action : Action_Node_Ptr := Table.States (State).Action_List;
+ begin
+ loop
+ declare
+ Parse_Action_Node : Parse_Action_Node_Ptr := Action.Action;
+ Conflict : constant Boolean :=
Parse_Action_Node.Next /= null;
+ begin
+ Put (" (" & Image (Action.Symbol, Descriptor) & " . ");
+
+ if Conflict then
+ Put ("(");
+ end if;
+
+ loop
+ declare
+ Parse_Action : Parse_Action_Rec renames
Parse_Action_Node.Item;
+ begin
+ case Parse_Action.Verb is
+ when Accept_It =>
+ Put ("accept");
+
+ when Error =>
+ Put ("error");
+
+ when Reduce =>
+ Put
+ ("(" & Image (Parse_Action.Production.LHS,
Descriptor) & " ." &
+ Integer'Image (Parse_Action.Production.RHS) &
")");
+
+ when Shift =>
+ Put (State_Index'Image (Parse_Action.State));
+
+ end case;
+
+ if Parse_Action_Node.Next = null then
+ if Conflict then
+ Put (")");
+ end if;
+ Put (")");
+ exit;
+ else
+ Put (" ");
+ Parse_Action_Node := Parse_Action_Node.Next;
+ end if;
+ end;
+ end loop;
+ end;
+
+ Action := Action.Next;
+
+ if Action.Next = null then
+ if Action.Action.Item.Verb /= Error then
+ raise SAL.Programmer_Error with "state" &
+ State_Index'Image (State) & ": default action is not
error";
+ end if;
+ -- let default handle it
+ Action := null;
+ end if;
+
+ if Action = null then
+ if State = Table.States'Last then
+ Put (")");
+ else
+ Put_Line (")");
+ end if;
+ exit;
+ end if;
+ end loop;
+ end;
+ end loop;
+ Put_Line ("]");
+ end Action_Table;
+
+ procedure Goto_Table (Table : in WisiToken.Parse.LR.Parse_Table; Descriptor
: in WisiToken.Descriptor)
+ is
+ use WisiToken.Parse.LR;
+
+ subtype Nonterminals is Token_ID range Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal;
+
+ function Count_Nonterminals (List : in Goto_Node_Ptr) return Integer
+ is
+ Item : Goto_Node_Ptr := List;
+ Count : Integer := 0;
+ begin
+ while Item /= null loop
+ if Symbol (Item) in Nonterminals then
+ Count := Count + 1;
+ end if;
+ Item := Next (Item);
+ end loop;
+ return Count;
+ end Count_Nonterminals;
+
+ begin
+ Put (" [");
+ for State in Table.States'Range loop
+ declare
+ Nonterminal_Count : constant Integer := Count_Nonterminals
(Table.States (State).Goto_List);
+ Gotos : Goto_Node_Ptr := Table.States
(State).Goto_List;
+ begin
+ if Nonterminal_Count = 0 then
+ if State = Table.States'First then
+ Put_Line ("nil");
+ else
+ if State = Table.States'Last then
+ Put (" nil");
+ else
+ Put_Line (" nil");
+ end if;
+ end if;
+ else
+ if State = Table.States'First then
+ Put ("(");
+ else
+ Put (" (");
+ end if;
+ loop
+ if Symbol (Gotos) in Nonterminals then
+ Put ("(" & Image (Symbol (Gotos), Descriptor) & " ." &
+ State_Index'Image (Parse.LR.State (Gotos)) & ")");
+ end if;
+ Gotos := Next (Gotos);
+ exit when Gotos = null;
+ end loop;
+ if State = Table.States'Last then
+ Put (")");
+ else
+ Put_Line (")");
+ end if;
+ end if;
+ end;
+ end loop;
+ Put ("]");
+ end Goto_Table;
+
+ procedure Output
+ (Elisp_Package : in String;
+ Tokens : in WisiToken.BNF.Tokens;
+ Parser : in WisiToken.Parse.LR.Parse_Table_Ptr;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ use Ada.Strings.Unbounded;
+ use Ada.Containers; -- count_type
+
+ Rule_Length : constant Count_Type := Tokens.Rules.Length;
+ Rule_Count : Count_Type := 1;
+
+ RHS_Length : Count_Type;
+ RHS_Count : Count_Type;
+ begin
+ Put_Line ("(defconst " & Elisp_Package & "-elisp-parse-table");
+ Put_Line (" (wisi-compile-grammar");
+
+ -- nonterminal productions
+ Put (" '((");
+ for Rule of Tokens.Rules loop
+ if Rule_Count = 1 then
+ Put ("(");
+ else
+ Put (" (");
+ end if;
+ Put_Line (-Rule.Left_Hand_Side);
+
+ RHS_Length := Rule.Right_Hand_Sides.Length;
+ RHS_Count := 1;
+ for RHS of Rule.Right_Hand_Sides loop
+ Put (" ((");
+ for Token of RHS.Tokens loop
+ Put (Token & " ");
+ end loop;
+ if Length (RHS.Action) = 0 then
+ Put (")");
+ else
+ Put_Line (")");
+ Put (" " & (-RHS.Action));
+ end if;
+
+ if RHS_Count = RHS_Length then
+ Put (")");
+ else
+ Put_Line (")");
+ end if;
+ RHS_Count := RHS_Count + 1;
+ end loop;
+ if Rule_Count = Rule_Length then
+ Put (")");
+ else
+ Put_Line (")");
+ end if;
+ Rule_Count := Rule_Count + 1;
+ end loop;
+ Put_Line (")");
+
+ Action_Table (Parser.all, Descriptor);
+ Goto_Table (Parser.all, Descriptor);
+ Put_Line ("))");
+
+ Put_Line (" ""Parser table."")");
+ end Output;
+
+ procedure Create_Elisp (Algorithm : in LR_Generate_Algorithm)
+ is
+ use Ada.Strings.Unbounded;
+ File : File_Type;
+ Elisp_Package_1 : constant String :=
+ (case Algorithm is
+ when LALR => Elisp_Package & "-lalr",
+ when LR1 => Elisp_Package & "-lr1");
+ begin
+ Create (File, Out_File, Elisp_Package_1 & "-elisp.el");
+ Set_Output (File);
+
+ Put_Line (";;; " & Elisp_Package_1 & "-elisp.el --- Generated parser
support file -*- lexical-binding:t -*-");
+ Put_Command_Line (Elisp_Comment & " ", Use_Tuple => True, Tuple =>
Tuple);
+ Put_Raw_Code (Elisp_Comment, Input_Data.Raw_Code (Copyright_License));
+ Put_Raw_Code (Elisp_Comment, Input_Data.Raw_Code (Actions_Spec_Context));
+ New_Line;
+
+ Put_Line ("(require 'wisi)");
+ Put_Line ("(require 'wisi-compile)");
+ Put_Line ("(require 'wisi-elisp-parse)");
+ New_Line;
+ Output_Elisp_Common.Indent_Keyword_Table
+ (Elisp_Package_1, "elisp", Input_Data.Tokens.Keywords,
To_String'Access);
+ New_Line;
+ Output_Elisp_Common.Indent_Token_Table (Elisp_Package_1, "elisp",
Input_Data.Tokens.Tokens, To_String'Access);
+ New_Line;
+ Output (Elisp_Package_1, Input_Data.Tokens,
Generate_Data.LR_Parse_Table, Generate_Data.Descriptor.all);
+ New_Line;
+ Put_Line ("(provide '" & Elisp_Package_1 & "-elisp)");
+ Put_Line (";; end of file");
+ Close (File);
+
+ Set_Output (Standard_Output);
+ end Create_Elisp;
+
+begin
+ Create_Elisp (Tuple.Gen_Alg);
+
+ if WisiToken.Trace_Generate > 0 then
+ WisiToken.BNF.Generate_Utils.Put_Stats (Input_Data, Generate_Data);
+ end if;
+end WisiToken.BNF.Output_Elisp;
diff --git a/wisitoken-bnf-output_elisp_common.adb
b/wisitoken-bnf-output_elisp_common.adb
new file mode 100644
index 0000000..fc37469
--- /dev/null
+++ b/wisitoken-bnf-output_elisp_common.adb
@@ -0,0 +1,145 @@
+-- Abstract :
+--
+-- See spec
+--
+-- Copyright (C) 2012, 2013, 2015, 2017, 2018 Stephen Leake. All Rights
Reserved.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This program is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
+-- MA 02110-1335, USA.
+
+pragma License (GPL);
+
+with Ada.Text_IO;
+with WisiToken.Generate;
+package body WisiToken.BNF.Output_Elisp_Common is
+
+ function Find_Elisp_ID (List : in String_Lists.List; Elisp_Name : in
String) return Integer
+ is
+ I : Integer := 0; -- match elisp array
+ begin
+ for Name of List loop
+ if Name = Elisp_Name then
+ return I;
+ end if;
+ I := I + 1;
+ end loop;
+ raise Not_Found with "unknown elisp name: '" & Elisp_Name & "'";
+ end Find_Elisp_ID;
+
+ function Elisp_Name_To_Ada
+ (Elisp_Name : in String;
+ Append_ID : in Boolean;
+ Trim : in Integer)
+ return String
+ is
+ Result : String := Elisp_Name (Elisp_Name'First + Trim ..
Elisp_Name'Last);
+ begin
+ Result (Result'First) := To_Upper (Result (Result'First));
+ for I in Result'Range loop
+ if Result (I) = '-' then
+ Result (I) := '_';
+ Result (I + 1) := To_Upper (Result (I + 1));
+ elsif Result (I) = '_' then
+ Result (I + 1) := To_Upper (Result (I + 1));
+ end if;
+ end loop;
+ if Append_ID then
+ return Result & "_ID"; -- Some elisp names may be Ada reserved words;
+ else
+ return Result;
+ end if;
+ end Elisp_Name_To_Ada;
+
+ procedure Indent_Keyword_Table
+ (Output_File_Root : in String;
+ Label : in String;
+ Keywords : in String_Pair_Lists.List;
+ Image : access function (Name : in
Ada.Strings.Unbounded.Unbounded_String) return String)
+ is
+ use Ada.Text_IO;
+ use WisiToken.Generate;
+ begin
+ Indent_Line ("(defconst " & Output_File_Root & "-" & Label &
"-keyword-table-raw");
+ Indent_Line (" '(");
+ Indent := Indent + 3;
+ for Pair of Keywords loop
+ Indent_Line ("(" & (-Pair.Value) & " . " & Image (Pair.Name) & ")");
+ end loop;
+ Indent_Line ("))");
+ Indent := Indent - 3;
+ end Indent_Keyword_Table;
+
+ procedure Indent_Token_Table
+ (Output_File_Root : in String;
+ Label : in String;
+ Tokens : in Token_Lists.List;
+ Image : access function (Name : in
Ada.Strings.Unbounded.Unbounded_String) return String)
+ is
+ use Ada.Strings.Unbounded;
+ use Ada.Text_IO;
+ use WisiToken.Generate;
+ begin
+ Indent_Line ("(defconst " & Output_File_Root & "-" & Label &
"-token-table-raw");
+ Indent_Line (" '(");
+ Indent := Indent + 3;
+ for Kind of Tokens loop
+ -- We don't use All_Tokens.Iterate here, because we need the
+ -- Kind/token nested list structure, and the order is not important.
+ if not (-Kind.Kind = "line_comment" or -Kind.Kind = "whitespace") then
+ Indent_Line ("(""" & (-Kind.Kind) & """");
+ Indent := Indent + 1;
+ for Token of Kind.Tokens loop
+ if 0 = Length (Token.Value) then
+ Indent_Line ("(" & Image (Token.Name) & ")");
+ else
+ if -Kind.Kind = "number" then
+ -- allow for (<token> <number-p> <require>)
+ Indent_Line ("(" & Image (Token.Name) & " " &
(-Token.Value) & ")");
+ elsif -Kind.Kind = "symbol" or
+ -Kind.Kind = "string-double" or
+ -Kind.Kind = "string-single"
+ then
+ -- value not used by elisp
+ Indent_Line ("(" & Image (Token.Name) & " . """")");
+ else
+ Indent_Line ("(" & Image (Token.Name) & " . " &
(-Token.Value) & ")");
+ end if;
+ end if;
+ end loop;
+ Indent_Line (")");
+ Indent := Indent - 1;
+ end if;
+ end loop;
+ Indent_Line ("))");
+ Indent := Indent - 3;
+ end Indent_Token_Table;
+
+ procedure Indent_Name_Table
+ (Output_File_Root : in String;
+ Label : in String;
+ Names : in String_Lists.List)
+ is
+ use Ada.Text_IO;
+ use WisiToken.Generate;
+ begin
+ Indent_Line ("(defconst " & Output_File_Root & "-" & Label);
+ Indent_Line (" [");
+ Indent := Indent + 3;
+ for Name of Names loop
+ Indent_Line (Name);
+ end loop;
+ Indent_Line ("])");
+ Indent := Indent - 3;
+ New_Line;
+ end Indent_Name_Table;
+
+end WisiToken.BNF.Output_Elisp_Common;
diff --git a/wisitoken-bnf-output_elisp_common.ads
b/wisitoken-bnf-output_elisp_common.ads
new file mode 100644
index 0000000..cb4e94b
--- /dev/null
+++ b/wisitoken-bnf-output_elisp_common.ads
@@ -0,0 +1,49 @@
+-- Abstract :
+--
+-- Subprograms common to Output_Elisp and Output_Ada_Emacs
+--
+-- Copyright (C) 2012, 2013, 2015, 2017, 2018 Stephen Leake. 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
+-- 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.
+
+pragma License (Modified_GPL);
+
+package WisiToken.BNF.Output_Elisp_Common is
+
+ function Find_Elisp_ID (List : in WisiToken.BNF.String_Lists.List;
Elisp_Name : in String) return Integer;
+
+ function Elisp_Name_To_Ada
+ (Elisp_Name : in String;
+ Append_ID : in Boolean;
+ Trim : in Integer)
+ return String;
+ -- Drop Trim chars from beginning of Elisp_Name, capitalize.
+
+ procedure Indent_Keyword_Table
+ (Output_File_Root : in String;
+ Label : in String;
+ Keywords : in String_Pair_Lists.List;
+ Image : access function (Name : in
Ada.Strings.Unbounded.Unbounded_String) return String);
+
+ procedure Indent_Token_Table
+ (Output_File_Root : in String;
+ Label : in String;
+ Tokens : in Token_Lists.List;
+ Image : access function (Name : in
Ada.Strings.Unbounded.Unbounded_String) return String);
+
+ procedure Indent_Name_Table
+ (Output_File_Root : in String;
+ Label : in String;
+ Names : in String_Lists.List);
+
+end WisiToken.BNF.Output_Elisp_Common;
diff --git a/wisitoken-bnf-utils.adb b/wisitoken-bnf-utils.adb
new file mode 100644
index 0000000..4ff91b6
--- /dev/null
+++ b/wisitoken-bnf-utils.adb
@@ -0,0 +1,45 @@
+-- Abstract :
+--
+-- See spec
+--
+-- Copyright (C) 2012, 2013, 2015, 2017, 2018 Stephen Leake. All Rights
Reserved.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This program is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
+-- MA 02110-1335, USA.
+
+pragma License (GPL);
+
+package body WisiToken.BNF.Utils is
+
+ function Strip_Quotes (Item : in String) return String
+ is begin
+ if Item'Length < 2 then
+ return Item;
+ else
+ return Item
+ ((if Item (Item'First) = '"' then Item'First + 1 else Item'First) ..
+ (if Item (Item'Last) = '"' then Item'Last - 1 else Item'Last));
+ end if;
+ end Strip_Quotes;
+
+ function Strip_Parens (Item : in String) return String
+ is begin
+ if Item'Length < 2 then
+ return Item;
+ else
+ return Item
+ ((if Item (Item'First) = '(' then Item'First + 1 else Item'First) ..
+ (if Item (Item'Last) = ')' then Item'Last - 1 else Item'Last));
+ end if;
+ end Strip_Parens;
+
+end WisiToken.BNF.Utils;
diff --git a/wisitoken-bnf-utils.ads b/wisitoken-bnf-utils.ads
new file mode 100644
index 0000000..4d82f32
--- /dev/null
+++ b/wisitoken-bnf-utils.ads
@@ -0,0 +1,29 @@
+-- Abstract :
+--
+-- Utilities for generating source code from Wisi source files
+--
+-- Copyright (C) 2012, 2013, 2015, 2017, 2018 Stephen Leake. 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
+-- 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.
+
+pragma License (Modified_GPL);
+
+package WisiToken.BNF.Utils is
+
+ function Strip_Quotes (Item : in String) return String;
+ -- Remove leading and trailing '"', if any.
+
+ function Strip_Parens (Item : in String) return String;
+ -- Remove leading and trailing '()', if any.
+
+end WisiToken.BNF.Utils;
diff --git a/wisitoken-bnf.adb b/wisitoken-bnf.adb
new file mode 100644
index 0000000..cd49de7
--- /dev/null
+++ b/wisitoken-bnf.adb
@@ -0,0 +1,337 @@
+-- Abstract :
+--
+-- see spec
+--
+-- Copyright (C) 2012 - 2015, 2017, 2018 Stephen Leake. All Rights Reserved.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This program is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+-- PURPOSE. See the GNU General Public License for more details. You
+-- should have received a copy of the GNU General Public License
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
+-- MA 02110-1335, USA.
+
+pragma License (GPL);
+
+with Ada.Command_Line;
+with Ada.Directories;
+with Ada.Text_IO;
+with Ada.Strings.Fixed;
+package body WisiToken.BNF is
+
+ procedure Add
+ (Set : in out Generate_Set_Access;
+ Tuple : in Generate_Tuple)
+ is
+ Prev : Generate_Set_Access := Set;
+ Last : constant Integer := (if Prev = null then 1 else
Prev.all'Length + 1);
+ begin
+ Set := new Generate_Set (1 .. Last);
+ for I in 1 .. Last - 1 loop
+ Set (I) := Prev (I);
+ end loop;
+ Set (Last) := Tuple;
+ Free (Prev);
+ end Add;
+
+ function To_Output_Language (Item : in String) return Output_Language
+ is begin
+ for I in Output_Language loop
+ if To_Lower (Output_Language_Image (I).all) = To_Lower (Item) then
+ return I;
+ end if;
+ end loop;
+ raise User_Error with "invalid output language name: '" & Item & "'";
+ end To_Output_Language;
+
+ function To_Lexer (Item : in String) return Lexer_Type
+ is begin
+ for I in Valid_Lexer loop
+ if Lexer_Image (I).all = To_Lower (Item) then
+ return I;
+ end if;
+ end loop;
+ raise User_Error with "invalid lexer name: '" & Item & "'";
+ end To_Lexer;
+
+ function Split_Lines (Item : in String) return String_Lists.List
+ is
+ CR : Character renames ASCII.CR;
+ LF : Character renames ASCII.LF;
+
+ Result : WisiToken.BNF.String_Lists.List;
+ I : Integer := Item'First;
+ First : Integer := Item'First;
+ Last_Char : Character := ' ';
+ begin
+ loop
+ exit when I > Item'Last;
+ if Item (I) = LF then
+ Result.Append (Item (First .. I - (if Last_Char = CR then 2 else
1)));
+ First := I + 1;
+
+ elsif I = Item'Last then
+ Result.Append (Item (First .. I));
+ end if;
+
+ Last_Char := Item (I);
+
+ I := I + 1;
+ end loop;
+ return Result;
+ end Split_Lines;
+
+ function Trim (Item : in String_Lists.List; Comment_Start : in String)
return String_Lists.List
+ is
+ use Ada.Strings;
+ use Ada.Strings.Fixed;
+ Result : String_Lists.List;
+ Comment : Integer;
+
+ procedure Maybe_Append (Line : in String)
+ is begin
+ if Line'Length > 0 then
+ Result.Append (Line);
+ end if;
+ end Maybe_Append;
+
+ begin
+ for Line of Item loop
+ Comment := Index (Line, Comment_Start, Going => Backward);
+ if Comment /= 0 then
+ Maybe_Append (Trim (Line (Line'First .. Comment - 1), Both));
+ else
+ Maybe_Append (Trim (Line, Both));
+ end if;
+ end loop;
+ return Result;
+ end Trim;
+
+ procedure Put_Raw_Code
+ (Comment_Syntax : in String_2;
+ Code : in String_Lists.List;
+ Comment_Only : in Boolean := False)
+ is
+ use Ada.Text_IO;
+ Real_Comment_Only : Boolean := Comment_Only;
+ begin
+ for Line of Code loop
+ if Line'Length >= 2 and then
+ ((Line (Line'First) = Line (Line'First + 1)) and
+ Line (Line'First) /= ' ')
+ then
+ -- The line is a comment.
+ Real_Comment_Only := Real_Comment_Only or Line (Line'First ..
Line'First + 1) /= Comment_Syntax;
+
+ Put_Line (Comment_Syntax & Line (Line'First + 2 .. Line'Last));
+
+ elsif Comment_Syntax = Elisp_Comment and (Line'Length > 0 and then
Line (Line'First) /= '(') then
+ null;
+
+ elsif not Comment_Only then
+ Put_Line (Line);
+ end if;
+ end loop;
+ end Put_Raw_Code;
+
+ procedure Put_File_Header
+ (Comment_Syntax : in String_2;
+ Emacs_Mode : in String := "";
+ Use_Tuple : in Boolean := False;
+ Tuple : in Generate_Tuple := (others => <>))
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line (Comment_Syntax & " generated parser support file." &
Emacs_Mode);
+ Put_Command_Line (Comment_Syntax & " ", Use_Tuple, Tuple);
+ Put_Line (Comment_Syntax);
+ end Put_File_Header;
+
+ function Is_Present (List : in WisiToken.BNF.String_Pair_Lists.List; Name :
in String) return Boolean
+ is
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+ begin
+ for Pair of List loop
+ if Pair.Name = Name then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Is_Present;
+
+ function Value (List : in WisiToken.BNF.String_Pair_Lists.List; Name : in
String) return String
+ is
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+ begin
+ for Pair of List loop
+ if Pair.Name = Name then
+ return -Pair.Value;
+ end if;
+ end loop;
+ raise Not_Found;
+ end Value;
+
+ function Count (Tokens : in Token_Lists.List) return Integer
+ is
+ Result : Integer := 0;
+ begin
+ for Kind of Tokens loop
+ Result := Result + Integer (Kind.Tokens.Length);
+ end loop;
+ return Result;
+ end Count;
+
+ procedure Add_Token
+ (Tokens : in out Token_Lists.List;
+ Kind : in String;
+ Name : in String;
+ Value : in String)
+ is
+ use type Ada.Strings.Unbounded.Unbounded_String;
+ begin
+ for Token_Kind of Tokens loop
+ if Token_Kind.Kind = Kind then
+ Token_Kind.Tokens.Append ((+Name, +Value));
+ return;
+ end if;
+ end loop;
+
+ -- Kind not found; add it
+ declare
+ Temp : String_Pair_Lists.List;
+ begin
+ Temp.Append ((+Name, +Value));
+ Tokens.Append ((+Kind, Temp));
+ end;
+ end Add_Token;
+
+ function Is_In (Tokens : in Token_Lists.List; Kind : in String) return
Boolean
+ is begin
+ for Token of Tokens loop
+ if -Token.Kind = Kind then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Is_In;
+
+ function Is_In
+ (Tokens : in Token_Lists.List;
+ Kind : in String;
+ Value : in String)
+ return Boolean
+ is begin
+ for Token of Tokens loop
+ if -Token.Kind = Kind then
+ for Item of Token.Tokens loop
+ if -Item.Value = Value then
+ return True;
+ end if;
+ end loop;
+ end if;
+ end loop;
+ return False;
+ end Is_In;
+
+ function Is_Present (Rules : in Rule_Lists.List; LHS : in String) return
Boolean
+ is
+ use Rule_Lists;
+
+ Found : Boolean := False;
+
+ procedure Process (Position : in Cursor)
+ is begin
+ if -Rules (Position).Left_Hand_Side = LHS then
+ Found := True;
+ end if;
+ end Process;
+
+ begin
+ Rules.Iterate (Process'Access);
+ return Found;
+ end Is_Present;
+
+ function "+" (List : in String_Lists.List; Item : in String) return
String_Lists.List
+ is
+ Result : String_Lists.List := List;
+ begin
+ Result.Append (Item);
+ return Result;
+ end "+";
+
+ function String_To_String_List (Item : in String) return String_Lists.List
+ is
+ Result : String_Lists.List;
+ begin
+ Result.Append (Item);
+ return Result;
+ end String_To_String_List;
+
+ function RHS_To_RHS_List (Item : in RHS_Type) return RHS_Lists.List
+ is
+ Result : RHS_Lists.List;
+ begin
+ Result.Append (Item);
+ return Result;
+ end RHS_To_RHS_List;
+
+ function "+" (List : in RHS_Lists.List; Item : in RHS_Type) return
RHS_Lists.List
+ is
+ Result : RHS_Lists.List := List;
+ begin
+ Result.Append (Item);
+ return Result;
+ end "+";
+
+ procedure Put_Command_Line
+ (Comment_Prefix : in String;
+ Use_Tuple : in Boolean := False;
+ Tuple : in Generate_Tuple := (others => <>))
+ is
+ use Ada.Command_Line;
+ use Ada.Text_IO;
+
+ Max_Line_Length : constant := 120;
+ Col : Integer := 0;
+
+ procedure Put (Item : in String; Leading_Space : in Boolean)
+ is begin
+ if Col > 0 and Col + Item'Length + 1 > Max_Line_Length then
+ New_Line;
+ Col := Comment_Prefix'Length;
+ Put (Comment_Prefix);
+ else
+ if Leading_Space then
+ Put (" ");
+ Col := Col + 1;
+ end if;
+ end if;
+
+ Col := Col + Item'Length;
+ Put (Item);
+ end Put;
+ begin
+ Put (Comment_Prefix & "command line:", False);
+ Put (Ada.Directories.Simple_Name (Command_Name), True);
+ if Use_Tuple then
+ Put (" --generate " & Generate_Algorithm'Image (Tuple.Gen_Alg) & " " &
+ Output_Language_Image (Tuple.Out_Lang).all &
+ (if Tuple.Lexer /= None then " " & Lexer_Image
(Tuple.Lexer).all else "") &
+ (if Tuple.Interface_Kind /= None then " " &
Interface_Type'Image (Tuple.Interface_Kind) else "") &
+ (if Tuple.Text_Rep then " text_rep" else "") &
+ " " & Argument (Argument_Count), -- .wy file
+ True);
+ else
+ for I in 1 .. Argument_Count loop
+ Put (Argument (I), True);
+ end loop;
+ end if;
+ New_Line;
+ end Put_Command_Line;
+
+end WisiToken.BNF;
diff --git a/wisitoken-bnf.ads b/wisitoken-bnf.ads
new file mode 100644
index 0000000..60fb96a
--- /dev/null
+++ b/wisitoken-bnf.ads
@@ -0,0 +1,310 @@
+-- Abstract :
+--
+-- Root package for generating a parser from a BNF source file; see [2]
+--
+-- The input file syntax is based on BNF syntax [1] with declarations
+-- and grammar actions.
+--
+-- The Elisp and Ada_Emacs output languages are for use with the
+-- Emacs wisi package.
+--
+-- Reference :
+--
+-- [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 Stephen Leake. 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
+-- 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.
+
+pragma License (Modified_GPL);
+
+with Ada.Characters.Handling;
+with Ada.Containers.Doubly_Linked_Lists;
+with Ada.Containers.Indefinite_Doubly_Linked_Lists;
+with Ada.Strings.Unbounded;
+with Ada.Unchecked_Deallocation;
+with WisiToken;
+package WisiToken.BNF is
+
+ -- See also WisiToken exceptions
+
+ Not_Found : exception;
+ -- something not found; should be handled and converted to Syntax_ or
Grammar_Error
+
+ type Generate_Algorithm is (None, LALR, LR1, Packrat_Gen, Packrat_Proc,
External);
+ subtype Valid_Generate_Algorithm is Generate_Algorithm range LALR ..
Generate_Algorithm'Last;
+ subtype LR_Generate_Algorithm is Generate_Algorithm range LALR .. LR1;
+ subtype Packrat_Generate_Algorithm is Generate_Algorithm range Packrat_Gen
.. Packrat_Proc;
+
+ Generate_Algorithm_Image : constant array (Valid_Generate_Algorithm) of
access constant String :=
+ (LALR => new String'("LALR"),
+ LR1 => new String'("LR1"),
+ Packrat_Gen => new String'("Packrat_Gen"),
+ Packrat_Proc => new String'("Packrat_Proc"),
+ External => new String'("External"));
+ -- Suitable for Ada package names.
+
+ type Generate_Algorithm_Set is array (Generate_Algorithm) of Boolean;
+ type Generate_Algorithm_Set_Access is access Generate_Algorithm_Set;
+
+ type Output_Language is (Ada_Lang, Ada_Emacs_Lang, Elisp_Lang);
+ subtype Ada_Output_Language is Output_Language range Ada_Lang ..
Ada_Emacs_Lang;
+ -- _Lang to avoid colliding with the standard package Ada and
+ -- WisiToken packages named *.Ada. In the grammar file, they
+ -- are named by (case insensitive):
+ Output_Language_Image : constant array (Output_Language) of access constant
String :=
+ (Ada_Lang => new String'("Ada"),
+ Ada_Emacs_Lang => new String'("Ada_Emacs"),
+ Elisp_Lang => new String'("elisp"));
+
+ function To_Output_Language (Item : in String) return Output_Language;
+ -- Raises User_Error for invalid Item
+
+ type Lexer_Type is (None, Elisp_Lexer, re2c_Lexer);
+ subtype Valid_Lexer is Lexer_Type range Elisp_Lexer .. Lexer_Type'Last;
+ -- We append "_Lexer" to these names to avoid colliding with the
+ -- similarly-named WisiToken packages. In the grammar file, they
+ -- are named by:
+ Lexer_Image : constant array (Lexer_Type) of access constant String :=
+ (None => new String'("none"),
+ Elisp_Lexer => new String'("elisp"),
+ re2c_Lexer => new String'("re2c"));
+
+ function To_Lexer (Item : in String) return Lexer_Type;
+ -- Raises User_Error for invalid Item
+
+ type Lexer_Set is array (Lexer_Type) of Boolean;
+
+ type Lexer_Generate_Algorithm_Set is array (Lexer_Type) of
Generate_Algorithm_Set;
+ -- %if lexer change change the generated parse table
+
+ type Interface_Type is (None, Process, Module);
+ subtype Valid_Interface is Interface_Type range Process .. Module;
+
+ type Generate_Tuple is record
+ Gen_Alg : Valid_Generate_Algorithm;
+ Out_Lang : Output_Language;
+ Lexer : Lexer_Type := None;
+ Interface_Kind : Interface_Type := None;
+ Text_Rep : Boolean := False;
+ end record;
+
+ type Generate_Set is array (Natural range <>) of Generate_Tuple;
+ type Generate_Set_Access is access Generate_Set;
+ procedure Free is new Ada.Unchecked_Deallocation (Generate_Set,
Generate_Set_Access);
+
+ procedure Add
+ (Set : in out Generate_Set_Access;
+ Tuple : in Generate_Tuple);
+
+ package String_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists
(String);
+
+ type Language_Param_Type is record
+ -- Set by grammar file declarations or command line options. Error
+ -- recover parameters are in McKenzie_Recover_Param_Type below.
+ Case_Insensitive : Boolean := False;
+ Embedded_Quote_Escape_Doubled : Boolean := False;
+ End_Names_Optional_Option : Ada.Strings.Unbounded.Unbounded_String;
+ Language_Runtime : Boolean := True;
+ Declare_Enums : Boolean := True;
+ Error_Recover : Boolean := False;
+ Start_Token : Ada.Strings.Unbounded.Unbounded_String;
+ end record;
+
+ type Raw_Code_Location is
+ (Copyright_License,
+ Actions_Spec_Context, Actions_Spec_Pre, Actions_Spec_Post,
+ Actions_Body_Context, Actions_Body_Pre, Actions_Body_Post);
+ -- So far we have not needed raw code other than license in the main
+ -- package.
+
+ type Raw_Code is array (Raw_Code_Location) of String_Lists.List;
+
+ subtype String_2 is String (1 .. 2);
+
+ Ada_Comment : constant String_2 := "--";
+ C_Comment : constant String_2 := "//";
+ Elisp_Comment : constant String_2 := ";;";
+
+ function Split_Lines (Item : in String) return String_Lists.List;
+
+ function Trim (Item : in String_Lists.List; Comment_Start : in String)
return String_Lists.List;
+ -- From each element, delete trailing comments starting with
+ -- Comment_Start; delete leading and trailing spaces.
+
+ procedure Put_Raw_Code
+ (Comment_Syntax : in String_2;
+ Code : in String_Lists.List;
+ Comment_Only : in Boolean := False);
+ -- Output Code to Ada.Text_IO.Current_Output.
+ --
+ -- If first two characters of a line are the same and not ' ', it is
+ -- assumed to be a comment; ensure the output line has
+ -- Comment_Syntax.
+ --
+ -- If Comment_Only is True, or if the comment syntax used in Code
+ -- does not equal Comment_Syntax, only output comment lines.
+ --
+ -- If Comment_Syntax is Elisp_Comment, only output lines that are
+ -- valid elisp comments or forms (ie start with ';;' or '(').
+ --
+ -- Otherwise output all lines.
+
+ procedure Put_File_Header
+ (Comment_Syntax : in String_2;
+ Emacs_Mode : in String := "";
+ Use_Tuple : in Boolean := False;
+ Tuple : in Generate_Tuple := (others => <>));
+ -- Output "parser support file <emacs_mode> /n command line: " comment to
Ada.Text_IO.Current_Output.
+
+ type String_Pair_Type is record
+ Name : aliased Ada.Strings.Unbounded.Unbounded_String;
+ Value : Ada.Strings.Unbounded.Unbounded_String;
+ end record;
+
+ package String_Pair_Lists is new Ada.Containers.Doubly_Linked_Lists
(String_Pair_Type);
+
+ function Is_Present (List : in String_Pair_Lists.List; Name : in String)
return Boolean;
+ function Value (List : in String_Pair_Lists.List; Name : in String) return
String;
+
+ type McKenzie_Recover_Param_Type is record
+ Source_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
+ -- Of the %mckenzie_cost_default declaration; we assume the others
+ -- are near.
+
+ Default_Insert : Natural := 0;
+ Default_Delete_Terminal : Natural := 0;
+ Default_Push_Back : Natural := 0;
+ Delete : String_Pair_Lists.List;
+ Insert : String_Pair_Lists.List;
+ Push_Back : String_Pair_Lists.List;
+ Ignore_Check_Fail : Natural := 0;
+ Cost_Limit : Natural := Integer'Last;
+ Check_Limit : WisiToken.Token_Index :=
WisiToken.Token_Index'Last;
+ Check_Delta_Limit : Natural := Integer'Last;
+ Enqueue_Limit : Natural := Integer'Last;
+ end record;
+
+ type Token_Kind_Type is record
+ Kind : Ada.Strings.Unbounded.Unbounded_String;
+ Tokens : String_Pair_Lists.List;
+ end record;
+
+ package Token_Lists is new Ada.Containers.Doubly_Linked_Lists
(Token_Kind_Type);
+
+ function Count (Tokens : in Token_Lists.List) return Integer;
+ -- Count of all leaves.
+
+ procedure Add_Token
+ (Tokens : in out Token_Lists.List;
+ Kind : in String;
+ Name : in String;
+ Value : in String);
+ -- Add Name, Value to Kind list in Tokens.
+
+ function Is_In (Tokens : in Token_Lists.List; Kind : in String) return
Boolean;
+ function Is_In
+ (Tokens : in Token_Lists.List;
+ Kind : in String;
+ Value : in String)
+ return Boolean;
+
+ type Conflict is record
+ Source_Line : WisiToken.Line_Number_Type;
+ Action_A : Ada.Strings.Unbounded.Unbounded_String;
+ LHS_A : Ada.Strings.Unbounded.Unbounded_String;
+ Action_B : Ada.Strings.Unbounded.Unbounded_String;
+ LHS_B : Ada.Strings.Unbounded.Unbounded_String;
+ On : Ada.Strings.Unbounded.Unbounded_String;
+ end record;
+
+ package Conflict_Lists is new Ada.Containers.Doubly_Linked_Lists (Conflict);
+
+ type RHS_Type is record
+ Tokens : String_Lists.List;
+ Action : Ada.Strings.Unbounded.Unbounded_String;
+ Check : Ada.Strings.Unbounded.Unbounded_String;
+ Source_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
+ end record;
+ package RHS_Lists is new Ada.Containers.Doubly_Linked_Lists (RHS_Type, "=");
+
+ type Rule_Type is record
+ Left_Hand_Side : aliased Ada.Strings.Unbounded.Unbounded_String;
+ Right_Hand_Sides : RHS_Lists.List;
+ Source_Line : WisiToken.Line_Number_Type;
+ end record;
+
+ package Rule_Lists is new Ada.Containers.Doubly_Linked_Lists (Rule_Type);
+
+ function Is_Present (Rules : in Rule_Lists.List; LHS : in String) return
Boolean;
+
+ type Tokens is record
+ Non_Grammar : Token_Lists.List;
+ Keywords : String_Pair_Lists.List;
+ Tokens : Token_Lists.List;
+ Rules : Rule_Lists.List;
+ -- Rules included here because they define the nonterminal tokens, as
+ -- well as the productions.
+
+ Regexps : String_Pair_Lists.List;
+ -- Regexps 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
+ -- 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
+ Regexps : String_Pair_Lists.List; -- %regexp_name
+ end record;
+
+ 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 To_Lower (Item : in String) return String
+ renames Ada.Characters.Handling.To_Lower;
+
+ function To_Upper (Item : in String) return String
+ renames Ada.Characters.Handling.To_Upper;
+
+ function To_Upper (Item : in Character) return Character
+ renames Ada.Characters.Handling.To_Upper;
+
+ function "+" (List : in String_Lists.List; Item : in String) return
String_Lists.List;
+
+ function String_To_String_List (Item : in String) return String_Lists.List;
+ function "+" (Item : in String) return String_Lists.List renames
String_To_String_List;
+
+ function RHS_To_RHS_List (Item : in RHS_Type) return RHS_Lists.List;
+ function "+" (Item : in RHS_Type) return RHS_Lists.List renames
RHS_To_RHS_List;
+
+ function "+" (List : in RHS_Lists.List; Item : in RHS_Type) return
RHS_Lists.List;
+
+ function Image (Item : in Boolean) return String
+ is (if Item then "True" else "False");
+ -- Match casing in Standard.
+
+ procedure Put_Command_Line
+ (Comment_Prefix : in String;
+ Use_Tuple : in Boolean := False;
+ Tuple : in Generate_Tuple := (others => <>));
+ -- Put command line to current output; indicate current tuple.
+
+end WisiToken.BNF;
diff --git a/wisitoken-gen_token_enum.adb b/wisitoken-gen_token_enum.adb
new file mode 100644
index 0000000..87e5f6d
--- /dev/null
+++ b/wisitoken-gen_token_enum.adb
@@ -0,0 +1,133 @@
+-- Abstract :
+--
+-- See spec
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (GPL);
+
+with Ada.Characters.Handling;
+with WisiToken.Wisi_Ada;
+package body WisiToken.Gen_Token_Enum is
+
+ function Token_Enum_Image return Token_ID_Array_String
+ is
+ use Ada.Characters.Handling;
+ Result : Token_ID_Array_String (Token_ID'First .. +Last_Nonterminal);
+ begin
+ for I in Token_Enum_ID loop
+ if I <= Last_Terminal then
+ Result (+I) := new String'(Token_Enum_ID'Image (I));
+ else
+ Result (+I) := new String'(To_Lower (Token_Enum_ID'Image (I)));
+ end if;
+ end loop;
+ return Result;
+ end Token_Enum_Image;
+
+ function To_Syntax (Item : in Enum_Syntax) return
WisiToken.Lexer.Regexp.Syntax
+ is
+ Result : WisiToken.Lexer.Regexp.Syntax (Token_ID'First ..
+Last_Terminal);
+ begin
+ for I in Result'Range loop
+ Result (I) := Item (-I);
+ end loop;
+ return Result;
+ end To_Syntax;
+
+ function "&" (Left, Right : in Token_Enum_ID) return Token_ID_Arrays.Vector
+ is begin
+ return Result : Token_ID_Arrays.Vector do
+ Result.Append (+Left);
+ Result.Append (+Right);
+ end return;
+ end "&";
+
+ function "&"
+ (Left : in Token_ID_Arrays.Vector;
+ Right : in Token_Enum_ID)
+ return Token_ID_Arrays.Vector
+ is begin
+ return Result : Token_ID_Arrays.Vector := Left do
+ Result.Append (+Right);
+ end return;
+ end "&";
+
+ function "+"
+ (Left : in Token_Enum_ID;
+ Right : in WisiToken.Syntax_Trees.Semantic_Action)
+ return WisiToken.Productions.Right_Hand_Side
+ is begin
+ return WisiToken.Wisi_Ada."+" (+Left, Right);
+ end "+";
+
+ function "<="
+ (Left : in Token_Enum_ID;
+ Right : in WisiToken.Productions.Right_Hand_Side)
+ return WisiToken.Productions.Instance
+ is begin
+ return WisiToken.Wisi_Ada."<=" (+Left, Productions.RHS_Arrays.To_Vector
(Right, 1));
+ end "<=";
+
+ function To_Nonterminal_Array_Token_Set
+ (Item : in Nonterminal_Array_Token_Set)
+ return WisiToken.Token_Array_Token_Set
+ is
+ Result : Token_Array_Token_Set :=
+ (LR1_Descriptor.First_Nonterminal .. LR1_Descriptor.Last_Nonterminal =>
+ (LR1_Descriptor.First_Terminal .. LR1_Descriptor.Last_Nonterminal
=> False));
+ begin
+ for I in Item'Range (1) loop
+ for J in Item'Range (2) loop
+ Result (+I, +J) := Item (I, J);
+ end loop;
+ end loop;
+ return Result;
+ end To_Nonterminal_Array_Token_Set;
+
+ function To_Nonterminal_Array_Terminal_Set
+ (Item : in Nonterminal_Array_Terminal_Set)
+ return WisiToken.Token_Array_Token_Set
+ is
+ Result : Token_Array_Token_Set :=
+ (LR1_Descriptor.First_Nonterminal .. LR1_Descriptor.Last_Nonterminal =>
+ (LR1_Descriptor.First_Terminal .. LR1_Descriptor.Last_Terminal =>
False));
+ begin
+ for I in Item'Range (1) loop
+ for J in Item'Range (2) loop
+ Result (+I, +J) := Item (I, J);
+ end loop;
+ end loop;
+ return Result;
+ end To_Nonterminal_Array_Terminal_Set;
+
+ function "+" (Item : in Token_Array) return WisiToken.Token_ID_Set
+ is
+ Result : Token_ID_Set := (LR1_Descriptor.First_Terminal ..
LR1_Descriptor.Last_Terminal => False);
+ begin
+ for I in Item'Range loop
+ Result (+Item (I)) := True;
+ end loop;
+ return Result;
+ end "+";
+
+ function "+" (Item : in Token_Enum_ID) return WisiToken.Token_ID_Set
+ is begin
+ return +Token_Array'(1 => Item);
+ end "+";
+
+begin
+ LR1_Descriptor.Image := Token_Enum_Image;
+ LALR_Descriptor.Image := LR1_Descriptor.Image;
+end WisiToken.Gen_Token_Enum;
diff --git a/wisitoken-gen_token_enum.ads b/wisitoken-gen_token_enum.ads
new file mode 100644
index 0000000..b14be0d
--- /dev/null
+++ b/wisitoken-gen_token_enum.ads
@@ -0,0 +1,130 @@
+-- Abstract :
+--
+-- Support for an enumerated token type
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (GPL);
+
+with WisiToken.Lexer.Regexp;
+with WisiToken.Productions;
+with WisiToken.Syntax_Trees;
+generic
+ type Token_Enum_ID is (<>);
+ First_Terminal : Token_Enum_ID;
+ Last_Terminal : Token_Enum_ID;
+ First_Nonterminal : Token_Enum_ID;
+ Last_Nonterminal : Token_Enum_ID;
+ EOF_ID : Token_Enum_ID;
+ Accept_ID : Token_Enum_ID;
+ Case_Insensitive : Boolean;
+package WisiToken.Gen_Token_Enum is
+
+ function "+" (Item : in Token_Enum_ID) return Token_ID
+ is (Token_ID'First + Token_Enum_ID'Pos (Item));
+
+ function "-" (Item : in Token_ID) return Token_Enum_ID
+ is (Token_Enum_ID'Val (Item - Token_ID'First));
+
+ function Token_Enum_Image return Token_ID_Array_String;
+
+ subtype Terminal_Enum_ID is Token_Enum_ID range First_Terminal ..
Last_Terminal;
+ subtype Nonterminal_Enum_ID is Token_Enum_ID range First_Nonterminal ..
Last_Nonterminal;
+
+ LR1_Descriptor : aliased WisiToken.Descriptor :=
+ (First_Terminal => +First_Terminal,
+ Last_Terminal => +Last_Terminal,
+ First_Nonterminal => +First_Nonterminal,
+ Last_Nonterminal => +Last_Nonterminal,
+ EOF_ID => +EOF_ID,
+ Accept_ID => +Accept_ID,
+ Case_Insensitive => Case_Insensitive,
+ New_Line_ID => Invalid_Token_ID,
+ Comment_ID => Invalid_Token_ID,
+ Left_Paren_ID => Invalid_Token_ID,
+ Right_Paren_ID => Invalid_Token_ID,
+ String_1_ID => Invalid_Token_ID,
+ String_2_ID => Invalid_Token_ID,
+ Embedded_Quote_Escape_Doubled => False,
+ Image => (others => null), -- set in body
elaboration time code
+ Terminal_Image_Width => Terminal_Enum_ID'Width,
+ Image_Width => Token_Enum_ID'Width,
+ Last_Lookahead => +Last_Terminal);
+
+ LALR_Descriptor : aliased WisiToken.Descriptor :=
+ (First_Terminal => +First_Terminal,
+ Last_Terminal => +Last_Terminal,
+ First_Nonterminal => +First_Nonterminal,
+ Last_Nonterminal => +Last_Nonterminal,
+ EOF_ID => +EOF_ID,
+ Accept_ID => +Accept_ID,
+ Case_Insensitive => Case_Insensitive,
+ New_Line_ID => Invalid_Token_ID,
+ Comment_ID => Invalid_Token_ID,
+ Left_Paren_ID => Invalid_Token_ID,
+ Right_Paren_ID => Invalid_Token_ID,
+ String_1_ID => Invalid_Token_ID,
+ String_2_ID => Invalid_Token_ID,
+ Embedded_Quote_Escape_Doubled => False,
+ Image => (others => null),
+ Terminal_Image_Width => Terminal_Enum_ID'Width,
+ Image_Width => Token_Enum_ID'Width,
+ Last_Lookahead => +First_Nonterminal);
+
+ type Enum_Syntax is array (Token_Enum_ID range Token_Enum_ID'First ..
Last_Terminal) of
+ WisiToken.Lexer.Regexp.Syntax_Item;
+
+ function To_Syntax (Item : in Enum_Syntax) return
WisiToken.Lexer.Regexp.Syntax;
+
+ function "&" (Left, Right : in Token_Enum_ID) return Token_ID_Arrays.Vector;
+
+ function "&"
+ (Left : in Token_ID_Arrays.Vector;
+ Right : in Token_Enum_ID)
+ return Token_ID_Arrays.Vector;
+
+ function "+" (Left : in Token_Enum_ID; Right : in
Syntax_Trees.Semantic_Action) return Productions.Right_Hand_Side;
+
+ function "<="
+ (Left : in Token_Enum_ID;
+ Right : in WisiToken.Productions.Right_Hand_Side)
+ return WisiToken.Productions.Instance;
+
+ ----------
+ -- For unit tests
+
+ subtype Terminal_ID is Token_Enum_ID range First_Terminal .. Last_Terminal;
+ subtype Nonterminal_ID is Token_Enum_ID range First_Nonterminal ..
Last_Nonterminal;
+ subtype Grammar_ID is Token_Enum_ID range First_Terminal ..
Last_Nonterminal;
+
+ type Nonterminal_Array_Token_Set is array (Nonterminal_ID, Grammar_ID) of
Boolean;
+
+ function To_Nonterminal_Array_Token_Set
+ (Item : in Nonterminal_Array_Token_Set)
+ return WisiToken.Token_Array_Token_Set;
+
+ type Nonterminal_Array_Terminal_Set is array (Nonterminal_ID, Terminal_ID)
of Boolean;
+
+ function To_Nonterminal_Array_Terminal_Set
+ (Item : in Nonterminal_Array_Terminal_Set)
+ return WisiToken.Token_Array_Token_Set;
+
+ type Nonterminal_ID_Set is array (Nonterminal_ID) of Boolean;
+
+ type Token_Array is array (Positive range <>) of Token_Enum_ID;
+
+ function "+" (Item : in Token_Array) return WisiToken.Token_ID_Set;
+ function "+" (Item : in Token_Enum_ID) return WisiToken.Token_ID_Set;
+
+end WisiToken.Gen_Token_Enum;
diff --git a/wisitoken-generate-lr-lalr_generate.adb
b/wisitoken-generate-lr-lalr_generate.adb
new file mode 100644
index 0000000..d886077
--- /dev/null
+++ b/wisitoken-generate-lr-lalr_generate.adb
@@ -0,0 +1,593 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2002 - 2005, 2008 - 2015, 2017, 2018 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers;
+with Ada.Text_IO;
+with SAL.Gen_Definite_Doubly_Linked_Lists;
+package body WisiToken.Generate.LR.LALR_Generate is
+
+ package Item_List_Cursor_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists
(LR1_Items.Item_Lists.Cursor);
+
+ type Item_Map is record
+ -- Keep track of all copies of Item, so Lookaheads can be updated
+ -- after they are initially copied.
+ From : LR1_Items.Item_Lists.Cursor;
+ To : Item_List_Cursor_Lists.List;
+ end record;
+
+ package Item_Map_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists
(Item_Map);
+ -- IMPROVEME: should be a 3D array indexed by Prod, rhs_index,
+ -- dot_index. But it's not broken or slow, so we're not fixing it.
+
+ function Propagate_Lookahead (Descriptor : in WisiToken.Descriptor) return
access LR1_Items.Lookahead
+ is begin
+ return new Token_ID_Set'(LR1_Items.To_Lookahead
(Descriptor.Last_Lookahead, Descriptor));
+ end Propagate_Lookahead;
+
+ function Null_Lookahead (Descriptor : in WisiToken.Descriptor) return
access LR1_Items.Lookahead
+ is begin
+ return new Token_ID_Set'(Descriptor.First_Terminal ..
Descriptor.Last_Lookahead => False);
+ end Null_Lookahead;
+
+ ----------
+ -- Debug output
+
+ procedure Put
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Propagations : in Item_Map_Lists.List)
+ is
+ use LR1_Items.Item_Lists;
+ begin
+ for Map of Propagations loop
+ Ada.Text_IO.Put ("From ");
+ LR1_Items.Put (Grammar, Descriptor, Constant_Ref (Map.From),
Show_Lookaheads => True);
+ Ada.Text_IO.New_Line;
+
+ for Cur of Map.To loop
+ Ada.Text_IO.Put ("To ");
+ LR1_Items.Put (Grammar, Descriptor, Constant_Ref (Cur),
Show_Lookaheads => True);
+ Ada.Text_IO.New_Line;
+ end loop;
+ end loop;
+ end Put;
+
+ ----------
+ -- Generate utils
+
+ function LALR_Goto_Transitions
+ (Kernel : in LR1_Items.Item_Set;
+ Symbol : in Token_ID;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set
+ is
+ use Token_ID_Arrays;
+ use LR1_Items;
+ use LR1_Items.Item_Lists;
+
+ Goto_Set : Item_Set;
+ Dot_ID : Token_ID;
+ begin
+ for Item of Kernel.Set loop
+
+ if Has_Element (Item.Dot) then
+
+ Dot_ID := Element (Item.Dot);
+ -- ID of token after Dot
+
+ -- If Symbol = EOF_Token, this is the start symbol accept
+ -- production; don't need a kernel with dot after EOF.
+ if (Dot_ID = Symbol and Symbol /= Descriptor.EOF_ID) and then
+ not Has_Element (Find (Item.Prod, Next (Item.Dot), Goto_Set))
+ then
+ Goto_Set.Set.Insert
+ ((Prod => Item.Prod,
+ Dot => Next (Item.Dot),
+ Lookaheads => new Token_ID_Set'(Item.Lookaheads.all)));
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line ("LALR_Goto_Transitions 1 " & Image
(Symbol, Descriptor));
+ Put (Grammar, Descriptor, Goto_Set);
+ end if;
+ end if;
+
+ if Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
+ First_Nonterm_Set (Dot_ID, Symbol)
+ then
+ -- Find the production(s) that create Dot_ID with first token
Symbol
+ -- and put them in.
+ --
+ -- This is equivalent to Filter (LR1_Items.Closure,
In_Kernel), but
+ -- more efficient, because it does not generate non-kernel
items. See
+ -- Test/compare_goto_transitions.adb.
+ for Prod of Grammar loop
+ for RHS_2_I in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index
loop
+ declare
+ P_ID : constant Production_ID := (Prod.LHS,
RHS_2_I);
+ Dot_2 : constant Token_ID_Arrays.Cursor := Prod.RHSs
(RHS_2_I).Tokens.First;
+ begin
+ if (Dot_ID = Prod.LHS or First_Nonterm_Set (Dot_ID,
Prod.LHS)) and
+ (Has_Element (Dot_2) and then Element (Dot_2) =
Symbol)
+ then
+ if not Has_Element (Find (P_ID, Next (Dot_2),
Goto_Set)) then
+ Goto_Set.Set.Insert
+ ((Prod => P_ID,
+ Dot => Next (Dot_2),
+ Lookaheads => Null_Lookahead (Descriptor)));
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line ("LALR_Goto_Transitions
2 " & Image (Symbol, Descriptor));
+ Put (Grammar, Descriptor, Goto_Set);
+ end if;
+
+ -- else already in goto set
+ end if;
+ end if;
+ end;
+ end loop;
+ end loop;
+ end if;
+ end if; -- item.dot /= null
+ end loop;
+
+ return Goto_Set;
+ end LALR_Goto_Transitions;
+
+ function LALR_Kernels
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set_List
+ is
+ use all type Token_ID_Arrays.Cursor;
+ use all type Ada.Containers.Count_Type;
+ use LR1_Items;
+
+ First_State_Index : constant State_Index := 0;
+ Kernels : LR1_Items.Item_Set_List;
+ Kernel_Tree : LR1_Items.Item_Set_Trees.Tree; -- for fast find
+ States_To_Check : State_Index_Queues.Queue;
+ Checking_State : State_Index;
+
+ New_Item_Set : Item_Set :=
+ (Set => Item_Lists.To_List
+ ((Prod => (Grammar.First_Index, 0),
+ Dot => Grammar (Grammar.First_Index).RHSs (0).Tokens.First,
+ Lookaheads => Null_Lookahead (Descriptor))),
+ Goto_List => <>,
+ Dot_IDs => <>,
+ State => First_State_Index);
+
+ Found_State : Unknown_State_Index;
+ begin
+ Kernels.Set_First (First_State_Index);
+
+ Add (New_Item_Set, Kernels, Kernel_Tree, Descriptor, Include_Lookaheads
=> False);
+
+ States_To_Check.Put (First_State_Index);
+ loop
+ exit when States_To_Check.Is_Empty;
+ Checking_State := States_To_Check.Get;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put ("Checking ");
+ Put (Grammar, Descriptor, Kernels (Checking_State));
+ end if;
+
+ for Symbol in Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal loop
+ -- LALR_Goto_Transitions does _not_ ignore Symbol if it is not in
+ -- Item_Set.Dot_IDs, so we can't iterate on that here as we do in
+ -- LR1_Generate.
+
+ New_Item_Set := LALR_Goto_Transitions
+ (Kernels (Checking_State), Symbol, First_Nonterm_Set, Grammar,
Descriptor);
+
+ if New_Item_Set.Set.Length > 0 then
+
+ Found_State := Find (New_Item_Set, Kernel_Tree,
Match_Lookaheads => False);
+
+ if Found_State = Unknown_State then
+ New_Item_Set.State := Kernels.Last_Index + 1;
+
+ States_To_Check.Put (New_Item_Set.State);
+
+ Add (New_Item_Set, Kernels, Kernel_Tree, Descriptor,
Include_Lookaheads => False);
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line (" adding state" &
Unknown_State_Index'Image (Kernels.Last_Index));
+ end if;
+
+ Kernels (Checking_State).Goto_List.Insert ((Symbol,
Kernels.Last_Index));
+ else
+
+ -- If there's not already a goto entry between these two
sets, create one.
+ if not Is_In ((Symbol, Found_State), Kernels
(Checking_State).Goto_List) then
+ if Trace_Generate > Detail then
+ Ada.Text_IO.Put_Line
+ (" state" & Unknown_State_Index'Image
(Checking_State) &
+ " adding goto on " & Image (Symbol, Descriptor) &
" to state" &
+ Unknown_State_Index'Image (Found_State));
+
+ end if;
+
+ Kernels (Checking_State).Goto_List.Insert ((Symbol,
Found_State));
+ end if;
+ end if;
+ end if;
+ end loop;
+ end loop;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.New_Line;
+ end if;
+
+ return Kernels;
+ end LALR_Kernels;
+
+ -- Add a propagation entry (if it doesn't already exist) from From in
+ -- From_Set to To_Item.
+ procedure Add_Propagation
+ (From : in LR1_Items.Item;
+ From_Set : in LR1_Items.Item_Set;
+ To_Item : in LR1_Items.Item_Lists.Cursor;
+ Propagations : in out Item_Map_Lists.List)
+ is
+ use Item_Map_Lists;
+ use Item_List_Cursor_Lists;
+ use LR1_Items;
+ use LR1_Items.Item_Lists;
+
+ From_Cur : constant Item_Lists.Cursor := Find (From, From_Set);
+
+ From_Match : Item_Map_Lists.Cursor := Propagations.First;
+ To_Match : Item_List_Cursor_Lists.Cursor;
+ begin
+ Find_From :
+ loop
+ exit Find_From when not Has_Element (From_Match);
+
+ declare
+ Map : Item_Map renames Constant_Ref (From_Match);
+ begin
+ if From_Cur = Map.From then
+
+ To_Match := Map.To.First;
+ loop
+ exit when not Has_Element (To_Match);
+
+ declare
+ use all type SAL.Compare_Result;
+ Cur : Item_Lists.Cursor renames Constant_Ref
(To_Match);
+ Test_Item : LR1_Items.Item renames Constant_Ref (Cur);
+ begin
+ if Equal = LR1_Items.Item_Compare (Test_Item,
Constant_Ref (To_Item)) then
+ exit Find_From;
+ end if;
+ end;
+ Next (To_Match);
+ end loop;
+ exit Find_From;
+ end if;
+ end;
+
+ Next (From_Match);
+ end loop Find_From;
+
+ if not Has_Element (From_Match) then
+ Propagations.Append ((From_Cur, To_List (To_Item)));
+
+ elsif not Has_Element (To_Match) then
+ Ref (From_Match).To.Append (To_Item);
+
+ else
+ raise SAL.Programmer_Error with "Add_Propagation: unexpected case";
+ end if;
+ end Add_Propagation;
+
+ -- Calculate the lookaheads from Closure_Item for Source_Item.
+ -- Source_Item must be one of the kernel items in Source_Set.
+ -- Closure_Item must be an item in the lookahead closure of Source_Item
for #.
+ --
+ -- Spontaneous lookaheads are put in Source_Item.Lookahead,
+ -- propagated lookaheads in Propagations.
+ --
+ -- Set Used_Tokens = True for all tokens in lookaheads.
+ procedure Generate_Lookahead_Info
+ (Source_Item : in LR1_Items.Item;
+ Source_Set : in LR1_Items.Item_Set;
+ Closure_Item : in LR1_Items.Item;
+ Propagations : in out Item_Map_Lists.List;
+ Descriptor : in WisiToken.Descriptor;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Kernels : in out LR1_Items.Item_Set_List)
+ is
+ use LR1_Items;
+ use LR1_Items.Item_Lists;
+ use Token_ID_Arrays;
+
+ Spontaneous_Count : Integer := 0;
+ begin
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line (" closure_item: ");
+ LR1_Items.Put (Grammar, Descriptor, Closure_Item);
+ Ada.Text_IO.New_Line;
+ end if;
+
+ if not Has_Element (Closure_Item.Dot) then
+ return;
+ end if;
+
+ declare
+ ID : constant Token_ID := Element
(Closure_Item.Dot);
+ Next_Dot : constant Token_ID_Arrays.Cursor := Next
(Closure_Item.Dot);
+ Goto_State : constant Unknown_State_Index := LR1_Items.Goto_State
(Source_Set, ID);
+ To_Item : constant Item_Lists.Cursor :=
+ (if Goto_State = Unknown_State then Item_Lists.No_Element
+ else LR1_Items.Find (Closure_Item.Prod, Next_Dot, Kernels
(Goto_State)));
+ begin
+ if Closure_Item.Lookaheads (Descriptor.Last_Lookahead) and
Has_Element (To_Item) then
+ Add_Propagation
+ (From => Source_Item,
+ From_Set => Source_Set,
+ To_Item => To_Item,
+ Propagations => Propagations);
+ end if;
+
+ if Has_Element (To_Item) then
+ if Trace_Generate > Outline then
+ Spontaneous_Count := Spontaneous_Count + 1;
+ Ada.Text_IO.Put_Line (" spontaneous: " & Lookahead_Image
(Closure_Item.Lookaheads.all, Descriptor));
+ end if;
+
+ LR1_Items.Include (Ref (To_Item), Closure_Item.Lookaheads.all,
Descriptor);
+ end if;
+ end;
+ end Generate_Lookahead_Info;
+
+ procedure Propagate_Lookaheads
+ (List : in Item_Map_Lists.List;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ -- In List, update all To lookaheads from From lookaheads,
+ -- recursively.
+
+ use LR1_Items.Item_Lists;
+
+ More_To_Check : Boolean := True;
+ Added_One : Boolean;
+ begin
+ while More_To_Check loop
+
+ More_To_Check := False;
+ for Mapping of List loop
+ for Copy of Mapping.To loop
+ LR1_Items.Include (Ref (Copy), Constant_Ref
(Mapping.From).Lookaheads.all, Added_One, Descriptor);
+
+ More_To_Check := More_To_Check or Added_One;
+ end loop;
+ end loop;
+ end loop;
+ end Propagate_Lookaheads;
+
+ -- Calculate the LALR(1) lookaheads for Grammar.
+ -- Kernels should be the sets of LR(0) kernels on input, and will
+ -- become the set of LALR(1) kernels on output.
+ procedure Fill_In_Lookaheads
+ (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Kernels : in out LR1_Items.Item_Set_List;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ pragma Warnings (Off, """Kernel_Item_Set"" is not modified, could be
declared constant");
+ -- WORKAROUND: GNAT GPL 2018 complains Kernel_Item_Set could be a
constant, but
+ -- when we declare that, it complains the target of the assignment of
+ -- .Prod, .Dot below must be a variable.
+
+ Kernel_Item_Set : LR1_Items.Item_Set := -- used for temporary arg to
Closure
+ (Set => LR1_Items.Item_Lists.To_List
+ ((Prod => <>,
+ Dot => <>,
+ Lookaheads => Propagate_Lookahead (Descriptor))),
+ Goto_List => <>,
+ Dot_IDs => <>,
+ State => <>);
+
+ Closure : LR1_Items.Item_Set;
+
+ Propagation_List : Item_Map_Lists.List;
+
+ begin
+ for Kernel of Kernels loop
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put ("Adding lookaheads for ");
+ LR1_Items.Put (Grammar, Descriptor, Kernel);
+ end if;
+
+ for Kernel_Item of Kernel.Set loop
+ Kernel_Item_Set.Set (Kernel_Item_Set.Set.First).Prod :=
Kernel_Item.Prod;
+ Kernel_Item_Set.Set (Kernel_Item_Set.Set.First).Dot :=
Kernel_Item.Dot;
+
+ Closure := LR1_Items.Closure
+ (Kernel_Item_Set, Has_Empty_Production, First_Terminal_Sequence,
Grammar, Descriptor);
+
+ for Closure_Item of Closure.Set loop
+ Generate_Lookahead_Info
+ (Kernel_Item, Kernel, Closure_Item, Propagation_List,
Descriptor, Grammar, Kernels);
+ end loop;
+ end loop;
+ end loop;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Propagations:");
+ Put (Grammar, Descriptor, Propagation_List);
+ Ada.Text_IO.New_Line;
+ end if;
+
+ Propagate_Lookaheads (Propagation_List, Descriptor);
+ end Fill_In_Lookaheads;
+
+ -- Add actions for all Kernels to Table.
+ procedure Add_Actions
+ (Kernels : in LR1_Items.Item_Set_List;
+ Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Conflicts : out Conflict_Lists.List;
+ Table : in out Parse_Table;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ Closure : LR1_Items.Item_Set;
+ begin
+ for Kernel of Kernels loop
+ -- IMPROVEME: there are three "closure" computations that could
+ -- probably be refactored to save computation; in
+ -- LALR_Goto_Transitions, Fill_In_Lookaheads, and here.
+ Closure := LR1_Items.Closure (Kernel, Has_Empty_Production,
First_Terminal_Sequence, Grammar, Descriptor);
+
+ Add_Actions (Closure, Table, Grammar, Has_Empty_Production,
First_Nonterm_Set, Conflicts, Descriptor);
+ end loop;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.New_Line;
+ end if;
+ end Add_Actions;
+
+ function Generate
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
+ McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
+ Put_Parse_Table : in Boolean := False)
+ return Parse_Table_Ptr
+ is
+ use all type Ada.Containers.Count_Type;
+
+ Ignore_Unused_Tokens : constant Boolean := WisiToken.Trace_Generate
> Detail;
+ Ignore_Unknown_Conflicts : constant Boolean := WisiToken.Trace_Generate
> Detail;
+ Unused_Tokens : constant Boolean :=
WisiToken.Generate.Check_Unused_Tokens (Descriptor, Grammar);
+
+ Table : Parse_Table_Ptr;
+
+ Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Grammar);
+
+ Minimal_Terminal_First : constant Token_Array_Token_ID :=
+ WisiToken.Generate.LR.Minimal_Terminal_First (Grammar, Descriptor);
+
+ Ancestors : constant Token_Array_Token_Set :=
WisiToken.Generate.Ancestors (Grammar, Descriptor);
+
+ First_Nonterm_Set : constant Token_Array_Token_Set :=
WisiToken.Generate.First
+ (Grammar, Has_Empty_Production, Descriptor.First_Terminal);
+
+ First_Terminal_Sequence : constant Token_Sequence_Arrays.Vector :=
+ WisiToken.Generate.To_Terminal_Sequence_Array (First_Nonterm_Set,
Descriptor);
+
+ Kernels : LR1_Items.Item_Set_List := LALR_Kernels (Grammar,
First_Nonterm_Set, Descriptor);
+
+ Unknown_Conflicts : Conflict_Lists.List;
+ Known_Conflicts_Edit : Conflict_Lists.List := Known_Conflicts;
+
+ begin
+ WisiToken.Generate.Error := False; -- necessary in unit tests; some
previous test might have encountered an error.
+
+ Fill_In_Lookaheads (Grammar, Has_Empty_Production,
First_Terminal_Sequence, Kernels, Descriptor);
+
+ if Unused_Tokens then
+ WisiToken.Generate.Error := not Ignore_Unused_Tokens;
+ Ada.Text_IO.New_Line;
+ end if;
+
+ if Trace_Generate > Detail then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("LR(1) Kernels:");
+ LR1_Items.Put (Grammar, Descriptor, Kernels, Show_Lookaheads => True);
+ end if;
+
+ Table := new Parse_Table
+ (State_First => Kernels.First_Index,
+ State_Last => Kernels.Last_Index,
+ First_Terminal => Descriptor.First_Terminal,
+ Last_Terminal => Descriptor.Last_Terminal,
+ First_Nonterminal => Descriptor.First_Nonterminal,
+ Last_Nonterminal => Descriptor.Last_Nonterminal);
+
+ if McKenzie_Param = Default_McKenzie_Param then
+ -- Descriminants in Default are wrong
+ Table.McKenzie_Param :=
+ (First_Terminal => Descriptor.First_Terminal,
+ Last_Terminal => Descriptor.Last_Terminal,
+ First_Nonterminal => Descriptor.First_Nonterminal,
+ Last_Nonterminal => Descriptor.Last_Nonterminal,
+ Insert => (others => 0),
+ Delete => (others => 0),
+ Push_Back => (others => 0),
+ Ignore_Check_Fail => Default_McKenzie_Param.Ignore_Check_Fail,
+ Task_Count => Default_McKenzie_Param.Task_Count,
+ Cost_Limit => Default_McKenzie_Param.Cost_Limit,
+ Check_Limit => Default_McKenzie_Param.Check_Limit,
+ Check_Delta_Limit => Default_McKenzie_Param.Check_Delta_Limit,
+ Enqueue_Limit => Default_McKenzie_Param.Enqueue_Limit);
+ else
+ Table.McKenzie_Param := McKenzie_Param;
+ end if;
+
+ Add_Actions
+ (Kernels, Grammar, Has_Empty_Production, First_Nonterm_Set,
First_Terminal_Sequence, Unknown_Conflicts,
+ Table.all, Descriptor);
+
+ -- Set Table.States.Productions, Minimal_Terminal_First for
McKenzie_Recover
+ for State in Table.States'Range loop
+ Table.States (State).Productions := LR1_Items.Productions (Kernels
(State));
+ WisiToken.Generate.LR.Set_Minimal_Complete_Actions
+ (Table.States (State), Kernels (State), Minimal_Terminal_First,
Ancestors, Descriptor, Grammar);
+ end loop;
+
+ if Put_Parse_Table then
+ WisiToken.Generate.LR.Put_Parse_Table
+ (Table, "LALR", Grammar, Kernels, Ancestors, Unknown_Conflicts,
Descriptor);
+ end if;
+
+ Delete_Known (Unknown_Conflicts, Known_Conflicts_Edit);
+
+ if Unknown_Conflicts.Length > 0 then
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "unknown
conflicts:");
+ Put (Unknown_Conflicts, Ada.Text_IO.Current_Error, Descriptor);
+ Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
+ WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
+ end if;
+
+ if Known_Conflicts_Edit.Length > 0 then
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "excess known
conflicts:");
+ Put (Known_Conflicts_Edit, Ada.Text_IO.Current_Error, Descriptor);
+ Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
+ WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
+ end if;
+
+ return Table;
+ end Generate;
+
+end WisiToken.Generate.LR.LALR_Generate;
diff --git a/wisitoken-generate-lr-lalr_generate.ads
b/wisitoken-generate-lr-lalr_generate.ads
new file mode 100644
index 0000000..01c65ca
--- /dev/null
+++ b/wisitoken-generate-lr-lalr_generate.ads
@@ -0,0 +1,67 @@
+-- Abstract :
+--
+-- Generalized LALR parse table generator.
+--
+-- Copyright (C) 2002 - 2003, 2009 - 2010, 2013 - 2015, 2017, 2018 Stephe
Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Generate.LR1_Items;
+with WisiToken.Productions;
+package WisiToken.Generate.LR.LALR_Generate is
+
+ function Generate
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
+ McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
+ Put_Parse_Table : in Boolean := False)
+ return Parse_Table_Ptr
+ with Pre =>
+ Descriptor.Last_Lookahead = Descriptor.First_Nonterminal and
+ Descriptor.First_Nonterminal = Descriptor.Accept_ID;
+ -- Generate a generalized LALR parse table for Grammar. The
+ -- grammar start symbol is the LHS of the first production in
+ -- Grammar.
+ --
+ -- Unless Ignore_Unused_Tokens is True, raise Grammar_Error if
+ -- there are unused tokens.
+ --
+ -- Unless Ignore_Unknown_Conflicts is True, raise Grammar_Error if there
+ -- are unknown conflicts.
+
+ ----------
+ -- Visible for unit tests
+
+ function LALR_Goto_Transitions
+ (Kernel : in LR1_Items.Item_Set;
+ Symbol : in Token_ID;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set;
+ -- Return the Item_Set that is the goto for Symbol from Kernel.
+ -- If there is no such Item_Set, Result.Set is null.
+
+ function LALR_Kernels
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set_List;
+
+end WisiToken.Generate.LR.LALR_Generate;
diff --git a/wisitoken-generate-lr-lr1_generate.adb
b/wisitoken-generate-lr-lr1_generate.adb
new file mode 100644
index 0000000..14fa5db
--- /dev/null
+++ b/wisitoken-generate-lr-lr1_generate.adb
@@ -0,0 +1,315 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2018 Stephe Leake
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers;
+with Ada.Text_IO;
+with WisiToken.Generate;
+package body WisiToken.Generate.LR.LR1_Generate is
+
+ function LR1_Goto_Transitions
+ (Set : in LR1_Items.Item_Set;
+ Symbol : in Token_ID;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set
+ is
+ use all type Ada.Containers.Count_Type;
+ use Token_ID_Arrays;
+ use LR1_Items;
+
+ Goto_Set : Item_Set;
+ begin
+ for Item of Set.Set loop
+ if Item.Dot /= No_Element then
+ if Element (Item.Dot) = Symbol and
+ -- We don't need a state with dot after EOF in the
+ -- accept production. EOF should only appear in the
+ -- accept production.
+ Symbol /= Descriptor.EOF_ID
+ then
+ Goto_Set.Set.Insert ((Item.Prod, Next (Item.Dot), new
Token_ID_Set'(Item.Lookaheads.all)));
+ end if;
+ end if;
+ end loop;
+
+ if Goto_Set.Set.Length > 0 then
+ return Closure (Goto_Set, Has_Empty_Production,
First_Terminal_Sequence, Grammar, Descriptor);
+ else
+ return Goto_Set;
+ end if;
+ end LR1_Goto_Transitions;
+
+ function LR1_Item_Sets
+ (Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set_List
+ is
+ use all type Ada.Containers.Count_Type;
+
+ -- [dragon] algorithm 4.9 pg 231; figure 4.38 pg 232; procedure
+ -- "items", with some optimizations.
+
+ use LR1_Items;
+
+ First_State_Index : constant State_Index := 0;
+
+ C : LR1_Items.Item_Set_List; -- result
+ C_Tree : LR1_Items.Item_Set_Trees.Tree; -- for fast find
+ States_To_Check : State_Index_Queues.Queue;
+ -- [dragon] specifies 'until no more items can be added', but we use
+ -- a queue to avoid checking unecessary states. Ada LR1 has over
+ -- 100,000 states, so this is a significant gain (reduced time from
+ -- 600 seconds to 40).
+
+ I : State_Index;
+ Dot_IDs : Token_ID_Arrays.Vector;
+
+ New_Item_Set : Item_Set := Closure
+ ((Set => Item_Lists.To_List
+ ((Prod => (Grammar.First_Index, 0),
+ Dot => Grammar (Grammar.First_Index).RHSs
(0).Tokens.First,
+ Lookaheads => new Token_ID_Set'(To_Lookahead (Descriptor.EOF_ID,
Descriptor)))),
+ Goto_List => <>,
+ Dot_IDs => <>,
+ State => First_State_Index),
+ Has_Empty_Production, First_Terminal_Sequence, Grammar, Descriptor);
+
+ Found_State : Unknown_State_Index;
+
+ begin
+ C.Set_First (First_State_Index);
+
+ Add (New_Item_Set, C, C_Tree, Descriptor, Include_Lookaheads => True);
+
+ States_To_Check.Put (First_State_Index);
+ loop
+ exit when States_To_Check.Is_Empty;
+ I := States_To_Check.Get;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put ("Checking ");
+ Put (Grammar, Descriptor, C (I), Show_Lookaheads => True,
Show_Goto_List => True);
+ end if;
+
+ Dot_IDs := C (I).Dot_IDs;
+ -- We can't iterate on C (I).Dot_IDs when the loop adds items to C;
+ -- it might be reallocated to grow.
+
+ for Symbol of Dot_IDs loop
+ -- [dragon] has 'for each grammar symbol X', but
LR1_Goto_Transitions
+ -- rejects Symbol that is not in Dot_IDs, so we iterate over that.
+
+ New_Item_Set := LR1_Goto_Transitions
+ (C (I), Symbol, Has_Empty_Production, First_Terminal_Sequence,
Grammar, Descriptor);
+
+ if New_Item_Set.Set.Length > 0 then -- 'goto (I, X) not empty'
+
+ Found_State := Find (New_Item_Set, C_Tree, Match_Lookaheads =>
True); -- 'not in C'
+
+ if Found_State = Unknown_State then
+ New_Item_Set.State := C.Last_Index + 1;
+
+ States_To_Check.Put (New_Item_Set.State);
+
+ Add (New_Item_Set, C, C_Tree, Descriptor, Include_Lookaheads
=> True);
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line
+ (" adding state" & Unknown_State_Index'Image
(C.Last_Index) & ": from state" &
+ Unknown_State_Index'Image (I) & " on " & Image
(Symbol, Descriptor));
+ Put (Grammar, Descriptor, New_Item_Set, Show_Lookaheads
=> True);
+ end if;
+
+ C (I).Goto_List.Insert ((Symbol, C.Last_Index));
+ else
+
+ -- If there's not already a goto entry between these two
sets, create one.
+ if not Is_In ((Symbol, Found_State), Goto_List => C
(I).Goto_List) then
+ if Trace_Generate > Outline then
+ Ada.Text_IO.Put_Line
+ (" adding goto on " & Image (Symbol, Descriptor) &
" to state" &
+ Unknown_State_Index'Image (Found_State));
+
+ end if;
+
+ C (I).Goto_List.Insert ((Symbol, Found_State));
+ end if;
+ end if;
+ end if;
+ end loop;
+ end loop;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ end if;
+
+ return C;
+ end LR1_Item_Sets;
+
+ procedure Add_Actions
+ (Item_Sets : in LR1_Items.Item_Set_List;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Nonterm_Set : in Token_Array_Token_Set;
+ Conflicts : out Conflict_Lists.List;
+ Table : in out Parse_Table;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ -- Add actions for all Item_Sets to Table.
+ begin
+ for Item_Set of Item_Sets loop
+ Add_Actions (Item_Set, Table, Grammar, Has_Empty_Production,
First_Nonterm_Set, Conflicts, Descriptor);
+ end loop;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ end if;
+ end Add_Actions;
+
+ function Generate
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
+ McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
+ Put_Parse_Table : in Boolean := False)
+ return Parse_Table_Ptr
+ is
+ use type Ada.Containers.Count_Type;
+
+ Ignore_Unused_Tokens : constant Boolean := WisiToken.Trace_Generate
> Detail;
+ Ignore_Unknown_Conflicts : constant Boolean := WisiToken.Trace_Generate
> Detail;
+ Unused_Tokens : constant Boolean :=
WisiToken.Generate.Check_Unused_Tokens (Descriptor, Grammar);
+
+ Table : Parse_Table_Ptr;
+
+ Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Grammar);
+
+ Minimal_Terminal_First : constant Token_Array_Token_ID :=
+ WisiToken.Generate.LR.Minimal_Terminal_First (Grammar, Descriptor);
+
+ Ancestors : constant Token_Array_Token_Set :=
WisiToken.Generate.Ancestors (Grammar, Descriptor);
+
+ First_Nonterm_Set : constant Token_Array_Token_Set :=
WisiToken.Generate.First
+ (Grammar, Has_Empty_Production, Descriptor.First_Terminal);
+
+ First_Terminal_Sequence : constant Token_Sequence_Arrays.Vector :=
+ WisiToken.Generate.To_Terminal_Sequence_Array (First_Nonterm_Set,
Descriptor);
+
+ Item_Sets : constant LR1_Items.Item_Set_List := LR1_Item_Sets
+ (Has_Empty_Production, First_Terminal_Sequence, Grammar, Descriptor);
+
+ Unknown_Conflicts : Conflict_Lists.List;
+ Known_Conflicts_Edit : Conflict_Lists.List := Known_Conflicts;
+ begin
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("LR(1) Item_Sets:");
+ LR1_Items.Put (Grammar, Descriptor, Item_Sets);
+ end if;
+
+ Table := new Parse_Table
+ (State_First => Item_Sets.First_Index,
+ State_Last => Item_Sets.Last_Index,
+ First_Terminal => Descriptor.First_Terminal,
+ Last_Terminal => Descriptor.Last_Terminal,
+ First_Nonterminal => Descriptor.First_Nonterminal,
+ Last_Nonterminal => Descriptor.Last_Nonterminal);
+
+ if McKenzie_Param = Default_McKenzie_Param then
+ -- Descriminants in Default are wrong
+ Table.McKenzie_Param :=
+ (First_Terminal => Descriptor.First_Terminal,
+ Last_Terminal => Descriptor.Last_Terminal,
+ First_Nonterminal => Descriptor.First_Nonterminal,
+ Last_Nonterminal => Descriptor.Last_Nonterminal,
+ Insert => (others => 0),
+ Delete => (others => 0),
+ Push_Back => (others => 0),
+ Ignore_Check_Fail => Default_McKenzie_Param.Ignore_Check_Fail,
+ Task_Count => Default_McKenzie_Param.Task_Count,
+ Cost_Limit => Default_McKenzie_Param.Cost_Limit,
+ Check_Limit => Default_McKenzie_Param.Check_Limit,
+ Check_Delta_Limit => Default_McKenzie_Param.Check_Delta_Limit,
+ Enqueue_Limit => Default_McKenzie_Param.Enqueue_Limit);
+ else
+ Table.McKenzie_Param := McKenzie_Param;
+ end if;
+
+ Add_Actions
+ (Item_Sets, Grammar, Has_Empty_Production, First_Nonterm_Set,
Unknown_Conflicts, Table.all, Descriptor);
+
+ -- Set Table.States.Productions, Minimal_Terminal_First 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));
+ 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);
+ end loop;
+
+ if Put_Parse_Table then
+ WisiToken.Generate.LR.Put_Parse_Table
+ (Table, "LR1", Grammar, Item_Sets, Ancestors, Unknown_Conflicts,
Descriptor);
+ end if;
+
+ if Trace_Generate > Outline then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Has_Empty_Production: " & Image
(Has_Empty_Production, Descriptor));
+
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Minimal_Terminal_First:");
+ for ID in Minimal_Terminal_First'Range loop
+ Ada.Text_IO.Put_Line
+ (Image (ID, Descriptor) & " =>" &
+ (if Minimal_Terminal_First (ID) = Invalid_Token_ID
+ then ""
+ else ' ' & Image (Minimal_Terminal_First (ID), Descriptor)));
+ end loop;
+ end if;
+
+ Delete_Known (Unknown_Conflicts, Known_Conflicts_Edit);
+
+ if Unknown_Conflicts.Length > 0 then
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "unknown
conflicts:");
+ Put (Unknown_Conflicts, Ada.Text_IO.Current_Error, Descriptor);
+ Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
+ WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
+ end if;
+
+ if Known_Conflicts_Edit.Length > 0 then
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "excess known
conflicts:");
+ Put (Known_Conflicts_Edit, Ada.Text_IO.Current_Error, Descriptor);
+ Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
+ WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
+ end if;
+
+ WisiToken.Generate.Error := WisiToken.Generate.Error or (Unused_Tokens
and not Ignore_Unused_Tokens);
+
+ return Table;
+ end Generate;
+
+end WisiToken.Generate.LR.LR1_Generate;
diff --git a/wisitoken-generate-lr-lr1_generate.ads
b/wisitoken-generate-lr-lr1_generate.ads
new file mode 100644
index 0000000..7dea371
--- /dev/null
+++ b/wisitoken-generate-lr-lr1_generate.ads
@@ -0,0 +1,76 @@
+-- Abstract :
+--
+-- LR1 (Left-to-right scanning 1 look-ahead) parser table generator.
+--
+-- References:
+--
+-- [dragon] "Compilers Principles, Techniques, and Tools" by Aho,
+-- Sethi, and Ullman (aka: "The [Red] Dragon Book").
+--
+-- Copyright (C) 2017, 2018 Stephe Leake
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Generate.LR1_Items;
+with WisiToken.Productions;
+package WisiToken.Generate.LR.LR1_Generate is
+
+ function Generate
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Known_Conflicts : in Conflict_Lists.List := Conflict_Lists.Empty_List;
+ McKenzie_Param : in McKenzie_Param_Type := Default_McKenzie_Param;
+ Put_Parse_Table : in Boolean := False)
+ return Parse_Table_Ptr
+ with Pre => Descriptor.First_Nonterminal = Descriptor.Accept_ID;
+ -- Generate a generalized LR1 parse table for Grammar. The
+ -- grammar start symbol is the LHS of the first production in
+ -- Grammar.
+ --
+ -- If Trace, output debug info to Standard_Error about generation
+ -- process. We don't use WisiToken.Trace here; we often want to
+ -- see a trace of the parser execution without the parser
+ -- generation.
+ --
+ -- Unless Ignore_Unused_Tokens is True, raise Grammar_Error if
+ -- there are unused tokens.
+ --
+ -- Unless Ignore_Unknown_Conflicts is True, raise Grammar_Error if there
+ -- are unknown conflicts.
+
+ ----------
+ -- visible for unit test
+
+ function LR1_Goto_Transitions
+ (Set : in LR1_Items.Item_Set;
+ Symbol : in Token_ID;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set;
+ -- 'goto' from [dragon] algorithm 4.9
+
+ function LR1_Item_Sets
+ (Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return LR1_Items.Item_Set_List;
+ -- [dragon] algorithm 4.9 pg 231; figure 4.38 pg 232; procedure "items"
+
+end WisiToken.Generate.LR.LR1_Generate;
diff --git a/wisitoken-generate-lr.adb b/wisitoken-generate-lr.adb
new file mode 100644
index 0000000..32689c0
--- /dev/null
+++ b/wisitoken-generate-lr.adb
@@ -0,0 +1,1141 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (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;
diff --git a/wisitoken-generate-lr.ads b/wisitoken-generate-lr.ads
new file mode 100644
index 0000000..6000dab
--- /dev/null
+++ b/wisitoken-generate-lr.ads
@@ -0,0 +1,176 @@
+-- Abstract :
+--
+-- Common utilities for LR parser table generators.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers.Doubly_Linked_Lists;
+with WisiToken.Generate.LR1_Items;
+with WisiToken.Parse.LR;
+with WisiToken.Productions;
+package WisiToken.Generate.LR is
+ use WisiToken.Parse.LR;
+
+ subtype Conflict_Parse_Actions is Parse_Action_Verbs range Shift ..
Accept_It;
+ type Conflict is record
+ -- A typical conflict is:
+ --
+ -- SHIFT/REDUCE in state: 11 on token IS
+ --
+ -- State numbers change with minor changes in the grammar, so we
+ -- attempt to identify the state by the LHS of the two productions
+ -- involved; this is _not_ guarranteed to be unique, but is good
+ -- enough for our purposes. We also store the state number for
+ -- generated conflicts (not for known conflicts from the grammar
+ -- definition file), for debugging.
+ Action_A : Conflict_Parse_Actions;
+ LHS_A : Token_ID;
+ Action_B : Conflict_Parse_Actions;
+ LHS_B : Token_ID;
+ State_Index : Unknown_State_Index;
+ On : Token_ID;
+ end record;
+
+ package Conflict_Lists is new Ada.Containers.Doubly_Linked_Lists (Conflict);
+
+ procedure Put
+ (Item : in Conflict_Lists.List;
+ File : in Ada.Text_IO.File_Type;
+ Descriptor : in WisiToken.Descriptor);
+
+ 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);
+ -- Add (Symbol, Action) to Action_List; check for conflicts
+ --
+ -- Closure .. Conflicts are for conflict reporting
+
+ 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);
+ -- Add actions for Closure to Table. Has_Empty_Production, First,
+ -- Conflicts used for conflict reporting.
+
+ 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);
+ -- Add actions for Item.Lookaheads to Action_List
+ -- Closure must be from the item set containing Item.
+ -- Has_Empty_Production .. Closure used for conflict reporting.
+
+ procedure Delete_Known
+ (Conflicts : in out Conflict_Lists.List;
+ Known_Conflicts : in out Conflict_Lists.List);
+ -- Delete Known_Conflicts from Conflicts.
+
+ function Find
+ (Symbol : in Token_ID;
+ Action_List : in Action_Node_Ptr)
+ return Action_Node_Ptr;
+
+ function Find
+ (Closure : in LR1_Items.Item_Set;
+ Action : in Parse_Action_Rec;
+ Lookahead : in Token_ID;
+ 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;
+ -- Return the LHS of a production in kernel of Closure, for an Action
+ -- conflict on Lookahead; for naming a Conflict object.
+
+ function Image (Item : in Conflict; Descriptor : in WisiToken.Descriptor)
return String;
+
+ function Is_Present (Item : in Conflict; Conflicts : in
Conflict_Lists.List) return Boolean;
+
+ 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);
+ -- 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.
+
+ function Minimal_Terminal_First
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ 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
+ -- 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.
+
+ ----------
+ -- 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);
+ -- Write machine-readable text format of Table.States to a file
+ -- File_Name, to be read by the parser executable at startup, using
+ -- WisiToken.Parse.LR.Get_Text_Rep.
+
+ procedure Put (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor);
+ procedure Put (Item : in McKenzie_Param_Type; Descriptor : in
WisiToken.Descriptor);
+ procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Parse_Action_Rec);
+ procedure Put (Descriptor : in WisiToken.Descriptor; Action : in
Parse_Action_Node_Ptr);
+ procedure Put (Descriptor : in WisiToken.Descriptor; State : in
Parse_State);
+ -- Put Item to Ada.Text_IO.Current_Output in parse table format.
+
+ procedure Put_Parse_Table
+ (Table : in Parse_Table_Ptr;
+ Title : in String;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Kernels : in LR1_Items.Item_Set_List;
+ Ancestors : in Token_Array_Token_Set;
+ Conflicts : in Conflict_Lists.List;
+ Descriptor : in WisiToken.Descriptor);
+
+end WisiToken.Generate.LR;
diff --git a/wisitoken-generate-lr1_items.adb b/wisitoken-generate-lr1_items.adb
new file mode 100644
index 0000000..a62a4af
--- /dev/null
+++ b/wisitoken-generate-lr1_items.adb
@@ -0,0 +1,580 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2002, 2003, 2008, 2009, 2012 - 2015, 2017, 2018 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Text_IO;
+with Ada.Strings.Unbounded;
+package body WisiToken.Generate.LR1_Items is
+ use type Ada.Strings.Unbounded.Unbounded_String;
+
+ ----------
+ -- body subprograms
+
+ function Get_Dot_IDs (Set : in Item_Lists.List; Descriptor : in
WisiToken.Descriptor) return Token_ID_Arrays.Vector
+ is
+ use all type Token_ID_Arrays.Cursor;
+ use Item_Lists;
+ IDs : Token_ID_Set (Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal) := (others => False);
+ begin
+ for Item of Set loop
+ if Item.Dot /= Token_ID_Arrays.No_Element then
+ if Element (Item.Dot) /= Descriptor.EOF_ID then
+ IDs (Element (Item.Dot)) := True;
+ end if;
+ end if;
+ end loop;
+ return To_Array (IDs);
+ end Get_Dot_IDs;
+
+ function Merge
+ (Prod : in Production_ID;
+ Dot : in Token_ID_Arrays.Cursor;
+ Lookaheads : in Lookahead;
+ Existing_Set : in out Item_Set)
+ return Boolean
+ is
+ -- Merge item into Existing_Set. Return True if Existing_Set
+ -- is modified.
+
+ use Item_Lists;
+
+ Found : constant Item_Lists.Cursor := Find (Prod, Dot, Existing_Set);
+ Modified : Boolean := False;
+ begin
+ if Found = No_Element then
+ Existing_Set.Set.Insert ((Prod, Dot, new Token_ID_Set'(Lookaheads)));
+
+ Modified := True;
+ else
+ Include (Ref (Found), Lookaheads, Modified);
+ end if;
+
+ return Modified;
+ end Merge;
+
+ ----------
+ -- Public subprograms, declaration order
+
+ function To_Lookahead (Item : in Token_ID; Descriptor : in
WisiToken.Descriptor) return Lookahead
+ is begin
+ return Result : Token_ID_Set := (Descriptor.First_Terminal ..
Descriptor.Last_Lookahead => False) do
+ Result (Item) := True;
+ end return;
+ end To_Lookahead;
+
+ function Lookahead_Image (Item : in Lookahead; Descriptor : in
WisiToken.Descriptor) return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := Null_Unbounded_String;
+ begin
+ for I in Item'Range loop
+ if Item (I) then
+ if Length (Result) > 0 then
+ Result := Result & "/";
+ end if;
+ Result := Result & Image (I, Descriptor);
+ end if;
+ end loop;
+ return To_String (Result);
+ end Lookahead_Image;
+
+ function Item_Compare (Left, Right : in Item) return SAL.Compare_Result
+ is begin
+ if Left.Prod.LHS > Right.Prod.LHS then
+ return SAL.Greater;
+ elsif Left.Prod.LHS < Right.Prod.LHS then
+ return SAL.Less;
+
+ elsif Left.Prod.RHS > Right.Prod.RHS then
+ return SAL.Greater;
+ elsif Left.Prod.RHS < Right.Prod.RHS then
+ return SAL.Less;
+
+ else
+ declare
+ Left_Index : Integer renames Token_ID_Arrays.To_Index (Left.Dot);
+ Right_Index : Integer renames Token_ID_Arrays.To_Index (Right.Dot);
+ begin
+ if Left_Index > Right_Index then
+ return SAL.Greater;
+ elsif Left_Index < Right_Index then
+ return SAL.Less;
+ else
+ return SAL.Equal;
+ end if;
+ end;
+ end if;
+ end Item_Compare;
+
+ procedure Include
+ (Item : in out LR1_Items.Item;
+ Value : in Lookahead;
+ Added : out Boolean)
+ is begin
+ Added := False;
+
+ for I in Item.Lookaheads'Range loop
+ if Value (I) then
+ Added := Added or not Item.Lookaheads (I);
+ Item.Lookaheads (I) := True;
+ end if;
+ end loop;
+ end Include;
+
+ procedure Include
+ (Item : in out LR1_Items.Item;
+ Value : in Lookahead;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ Added : Boolean;
+ pragma Unreferenced (Added);
+ begin
+ Include (Item, Value, Added, Descriptor);
+ end Include;
+
+ procedure Include
+ (Item : in out LR1_Items.Item;
+ Value : in Lookahead;
+ Added : out Boolean;
+ Descriptor : in WisiToken.Descriptor)
+ is begin
+ Added := False;
+
+ for I in Item.Lookaheads'Range loop
+ if I = Descriptor.Last_Lookahead then
+ null;
+ else
+ if Value (I) then
+ Added := Added or not Item.Lookaheads (I);
+ Item.Lookaheads (I) := True;
+ end if;
+ end if;
+ end loop;
+ end Include;
+
+ function Filter
+ (Set : in Item_Set;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Include : access function
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Item : in LR1_Items.Item)
+ return Boolean)
+ return Item_Set
+ is begin
+ return Result : Item_Set := (Set => <>, Goto_List => Set.Goto_List,
Dot_IDs => Set.Dot_IDs, State => Set.State)
+ do
+ for Item of Set.Set loop
+ if Include (Grammar, Descriptor, Item) then
+ Result.Set.Insert (Item);
+ end if;
+ end loop;
+ end return;
+ end Filter;
+
+ function In_Kernel
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Item : in LR1_Items.Item)
+ return Boolean
+ is
+ use Token_ID_Arrays;
+ Prod : WisiToken.Productions.Instance renames Grammar (Item.Prod.LHS);
+ RHS : WisiToken.Productions.Right_Hand_Side renames Prod.RHSs
(Item.Prod.RHS);
+ begin
+ return
+ No_Element /= RHS.Tokens.First and
+ (Item.Dot = No_Element or else
+ ((Prod.LHS = Descriptor.Accept_ID and
+ Item.Dot = RHS.Tokens.First)
+ -- Start symbol production with dot before first token.
+ or
+ Item.Dot /= RHS.Tokens.First));
+ end In_Kernel;
+
+ function Find
+ (Item : in LR1_Items.Item;
+ Set : in Item_Set)
+ return Item_Lists.Cursor
+ is begin
+ return Find (Item.Prod, Item.Dot, Set);
+ end Find;
+
+ function Find
+ (Prod : in Production_ID;
+ Dot : in Token_ID_Arrays.Cursor;
+ Right : in Item_Set)
+ return Item_Lists.Cursor
+ is begin
+ return Right.Set.Find ((Prod, Dot, null));
+ end Find;
+
+ function Find
+ (Prod : in Production_ID;
+ Dot : in Token_ID_Arrays.Cursor;
+ Right : in Item_Set;
+ Lookaheads : in Lookahead)
+ return Item_Lists.Cursor
+ is
+ use Item_Lists;
+ Result : constant Cursor := Right.Set.Find ((Prod, Dot, null));
+ begin
+ -- Item_Equal does not consider lookaheads
+ if Result = No_Element then
+ return Result;
+ elsif Constant_Ref (Result).Lookaheads.all = Lookaheads then
+ return Result;
+ else
+ return No_Element;
+ end if;
+ end Find;
+
+ function To_Item_Set_Tree_Key
+ (Item_Set : in LR1_Items.Item_Set;
+ Include_Lookaheads : in Boolean)
+ return Item_Set_Tree_Key
+ is
+ use Interfaces;
+ use Item_Lists;
+ Cur : Item_Lists.Cursor := Item_Set.Set.First;
+ begin
+ return Result : Item_Set_Tree_Key do
+ Result.Append (Integer_16 (Item_Set.Set.Length));
+ -- Int_Arrays."<" compares length, but only after everything else; we
+ -- want it to compare first, since it is most likely to be different.
+
+ loop
+ exit when Cur = No_Element;
+ declare
+ Item_1 : Item renames Item_Set.Set (Cur);
+ begin
+ Result.Append (Integer_16 (Item_1.Prod.LHS));
+ Result.Append (Integer_16 (Item_1.Prod.RHS));
+ Result.Append (Integer_16 (Token_ID_Arrays.To_Index
(Item_1.Dot)));
+ if Include_Lookaheads then
+ for ID in Item_1.Lookaheads'Range loop
+ if Item_1.Lookaheads (ID) then
+ Result.Append (Integer_16 (ID));
+ end if;
+ end loop;
+ end if;
+ end;
+ Next (Cur);
+ end loop;
+ end return;
+ end To_Item_Set_Tree_Key;
+
+ function Find
+ (New_Item_Set : in Item_Set;
+ Item_Set_Tree : in Item_Set_Trees.Tree;
+ Match_Lookaheads : in Boolean)
+ return Unknown_State_Index
+ is
+ use all type Item_Set_Trees.Cursor;
+
+ Tree_It : constant Item_Set_Trees.Iterator := Item_Set_Trees.Iterate
(Item_Set_Tree);
+ Key : constant Item_Set_Tree_Key := To_Item_Set_Tree_Key
+ (New_Item_Set, Include_Lookaheads => Match_Lookaheads);
+ Found_Tree : constant Item_Set_Trees.Cursor := Tree_It.Find (Key);
+ begin
+ if Found_Tree = Item_Set_Trees.No_Element then
+ return Unknown_State;
+ else
+ return Item_Set_Tree.Constant_Ref (Found_Tree).State;
+ end if;
+ end Find;
+
+ procedure Add
+ (New_Item_Set : in out Item_Set;
+ Item_Set_Vector : in out Item_Set_List;
+ Item_Set_Tree : in out Item_Set_Trees.Tree;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Lookaheads : in Boolean)
+ is
+ use Item_Set_Trees;
+ Key : constant Item_Set_Tree_Key := To_Item_Set_Tree_Key (New_Item_Set,
Include_Lookaheads);
+ begin
+ New_Item_Set.Dot_IDs := Get_Dot_IDs (New_Item_Set.Set, Descriptor);
+ Item_Set_Vector.Append (New_Item_Set);
+ Item_Set_Tree.Insert ((Key, New_Item_Set.State));
+ end Add;
+
+ function Is_In
+ (Item : in Goto_Item;
+ Goto_List : in Goto_Item_Lists.List)
+ return Boolean
+ is begin
+ for List_Item of Goto_List loop
+ if List_Item = Item then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Is_In;
+
+ function Goto_State
+ (From : in Item_Set;
+ Symbol : in Token_ID)
+ return Unknown_State_Index
+ is begin
+ for Item of From.Goto_List loop
+ if Item.Symbol = Symbol then
+ return Item.State;
+ end if;
+ end loop;
+
+ return Unknown_State;
+ end Goto_State;
+
+ function Closure
+ (Set : in Item_Set;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return Item_Set
+ is
+ use all type Item_Lists.Cursor;
+ use Token_ID_Arrays;
+
+ -- [dragon] algorithm 4.9 pg 231; figure 4.38 pg 232; procedure
"closure"
+ --
+ -- Taken literally, the algorithm modifies its input; we make a
+ -- copy instead.
+
+ I : Item_Set; -- The result.
+
+ Item_I : Item_Lists.Cursor; -- iterator 'for each item in I'
+ Added_Item : Boolean := False; -- 'until no more items can be added'
+
+ Beta : Token_ID_Arrays.Cursor; -- into RHS.Tokens
+ begin
+ I := Set;
+
+ Item_I := I.Set.First;
+ loop
+ declare
+ Item : LR1_Items.Item renames I.Set (Item_I);
+ begin
+ -- An item has the structure [A -> alpha Dot B Beta, a].
+ --
+ -- If B is a nonterminal, find its productions and place
+ -- them in the set with lookaheads from FIRST(Beta a).
+ if Item.Dot /= No_Element and then
+ Element (Item.Dot) in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal
+ then
+ declare
+ Prod : WisiToken.Productions.Instance renames Grammar
(Element (Item.Dot));
+ begin
+
+ For_Each_RHS :
+ for B in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
+ declare
+ RHS : WisiToken.Productions.Right_Hand_Side renames
Prod.RHSs (B);
+ P_ID : constant Production_ID := (Prod.LHS, B);
+ begin
+ -- Compute FIRST (<tail of right hand side> a); loop
+ -- until find a terminal, a nonterminal that
+ -- cannot be empty, or end of production, adding
+ -- items on the way.
+
+ Beta := Next (Item.Dot); -- tokens after nonterminal,
possibly null
+
+ First_Tail :
+ loop
+ if Beta = No_Element then
+ -- Use FIRST (a); a = Item.Lookaheads.
+ -- Lookaheads are all terminals, so
+ -- FIRST (a) = a.
+ Added_Item := Added_Item or
+ Merge (P_ID, RHS.Tokens.First,
Item.Lookaheads.all, I);
+ exit First_Tail;
+
+ elsif Element (Beta) in Descriptor.First_Terminal
.. Descriptor.Last_Terminal then
+ -- FIRST (Beta) = Beta
+ Added_Item := Added_Item or Merge
+ (P_ID, RHS.Tokens.First, To_Lookahead (Element
(Beta), Descriptor), I);
+ exit First_Tail;
+
+ else
+ -- Beta is a nonterminal; use FIRST (Beta)
+ for Terminal of First_Terminal_Sequence (Element
(Beta)) loop
+ Added_Item := Added_Item or
+ Merge (P_ID, RHS.Tokens.First, To_Lookahead
(Terminal, Descriptor), I);
+ end loop;
+
+ if Has_Empty_Production (Element (Beta)) then
+ -- Process the next token in the tail, or "a"
+ Beta := Next (Beta);
+ else
+ exit First_Tail;
+ end if;
+ end if;
+ end loop First_Tail;
+ end;
+ end loop For_Each_RHS;
+ end;
+ end if; -- Dot is at non-terminal
+ end;
+
+ if Item_Lists.Next (Item_I) = Item_Lists.No_Element then
+ exit when not Added_Item;
+
+ Item_I := I.Set.First;
+ Added_Item := False;
+
+ if Trace_Generate > Extra then
+ Ada.Text_IO.Put_Line ("I:");
+ Put (Grammar, Descriptor, I);
+ Ada.Text_IO.New_Line;
+ end if;
+ else
+ Item_I := Item_Lists.Next (Item_I);
+ end if;
+ end loop;
+
+ return I;
+ end Closure;
+
+ function Productions (Set : in Item_Set) return Production_ID_Arrays.Vector
+ is begin
+ return Result : Production_ID_Arrays.Vector do
+ for Item of Set.Set loop
+ Result.Append (Item.Prod);
+ end loop;
+ end return;
+ end Productions;
+
+ function Image
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Item : in LR1_Items.Item;
+ Show_Lookaheads : in Boolean)
+ return String
+ is
+ use Token_ID_Arrays;
+
+ I : Cursor;
+
+ Prod : WisiToken.Productions.Instance renames Grammar (Item.Prod.LHS);
+ RHS : WisiToken.Productions.Right_Hand_Side renames Prod.RHSs
(Item.Prod.RHS);
+ Result : Ada.Strings.Unbounded.Unbounded_String :=
+ +Padded_Image (Item.Prod, Width => Prod_ID_Image_Width) & ":" & Image
(Prod.LHS, Descriptor) & " <=";
+ begin
+ I := RHS.Tokens.First;
+
+ while I /= No_Element loop
+ if I = Item.Dot then
+ Result := Result & " ^ ";
+ else
+ Result := Result & " ";
+ end if;
+ Result := Result & Image (Element (I), Descriptor);
+ Next (I);
+ end loop;
+
+ if Item.Dot = No_Element then
+ Result := Result & " ^";
+ end if;
+
+ if Show_Lookaheads then
+ Result := Result & ", " & Lookahead_Image (Item.Lookaheads.all,
Descriptor);
+ end if;
+
+ return Ada.Strings.Unbounded.To_String (Result);
+ end Image;
+
+ procedure Put
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Item : in LR1_Items.Item;
+ Show_Lookaheads : in Boolean := True)
+ is begin
+ Ada.Text_IO.Put (Image (Grammar, Descriptor, Item, Show_Lookaheads =>
Show_Lookaheads));
+ end Put;
+
+ procedure Put
+ (Descriptor : in WisiToken.Descriptor;
+ List : in Goto_Item_Lists.List)
+ is
+ use Ada.Text_IO;
+ begin
+ for Item of List loop
+ Put_Line
+ (" on " & Image (Item.Symbol, Descriptor) &
+ " => State" & Unknown_State_Index'Image (Item.State));
+ 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;
+ Show_Goto_List : in Boolean := False)
+ is
+ use Ada.Text_IO;
+ begin
+ if Item.State /= Unknown_State then
+ 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;
+
+ if Show_Goto_List then
+ Put (Descriptor, Item.Goto_List);
+ end if;
+ end Put;
+
+ procedure Put
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Item : in Item_Set_List;
+ Show_Lookaheads : in Boolean := True)
+ is
+ use Ada.Text_IO;
+ begin
+ for Set of Item loop
+ Put (Grammar, Descriptor, Set, Show_Lookaheads);
+ Put_Line (" Goto:");
+ Put (Descriptor, Set.Goto_List);
+ end loop;
+ end Put;
+
+end WisiToken.Generate.LR1_Items;
diff --git a/wisitoken-generate-lr1_items.ads b/wisitoken-generate-lr1_items.ads
new file mode 100644
index 0000000..ff90e4a
--- /dev/null
+++ b/wisitoken-generate-lr1_items.ads
@@ -0,0 +1,332 @@
+-- Abstract :
+--
+-- Types and operatorion for LR(1) items.
+--
+-- Copyright (C) 2003, 2008, 2013-2015, 2017, 2018 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Interfaces;
+with SAL.Gen_Definite_Doubly_Linked_Lists_Sorted;
+with SAL.Gen_Unbounded_Definite_Red_Black_Trees;
+with SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable;
+with WisiToken.Productions;
+package WisiToken.Generate.LR1_Items is
+
+ use all type Interfaces.Integer_16;
+
+ subtype Lookahead is Token_ID_Set;
+ -- Picking a type for Lookahead is not straight-forward. The
+ -- operations required are (called numbers are for LR1 generate
+ -- ada_lite):
+ --
+ -- to_lookahead (token_id)
+ -- Requires allocating memory dynamically:
+ -- an unconstrained array range (first_terminal .. last_terminal)
for (1),
+ -- a smaller unconstrained array for (2), that grows as items are
added
+ -- individual list elements for (3).
+ --
+ -- lr1_items.to_lookahead called 4_821_256 times in (2)
+ -- sorted_token_id_lists.to_list called 4_821_256 times in (3)
+ --
+ -- for tok_id of lookaheads loop
+ -- sorted_token_id_lists__iterate called 5_687 times in (3)
+ --
+ -- if lookaheads.contains (tok_id) then
+ -- token_id_arrays__contains called 22_177_109 in (2)
+ --
+ -- new_item := (... , lookaheads => old_item.lookaheads)
+ -- new_item := (... , lookaheads => null_lookaheads)
+ -- new_item := (... , lookaheads => propagate_lookahead)
+ -- token_id_arrays.adjust called 8_437_967 times in (2)
+ -- sorted_token_id_lists.adjust 8_435_797 times in (3)
+ --
+ -- include: add tok_id to lookaheads
+ --
+ -- keep sorted in token_id order, so rest of algorithm is
+ -- stable/faster
+ --
+ -- lr1_items.include called 6_818_725 times in (2)
+ --
+ -- lookaheads /= lookaheads
+ -- if using a container, container must override "="
+ --
+ -- We've tried:
+ --
+ -- (1) Token_ID_Set (unconstrained array of boolean, allocated directly) -
fastest
+ --
+ -- Allocates more memory than (2), but everything else is fast,
+ -- and it's not enough memory to matter.
+ --
+ -- Loop over lookaheads is awkward:
+ -- for tok_id in lookaheads'range loop
+ -- if lookaheads (tok_id) then
+ -- ...
+ -- But apparently it's fast enough.
+ --
+ -- (2) Instantiation of SAL.Gen_Unbounded_Definite_Vectors
(token_id_arrays) - slower than (1).
+ --
+ -- Productions RHS is also token_id_arrays, so gprof numbers are
+ -- hard to sort out. Could be improved with a custom container, that
+ -- does sort and insert internally. Insert is inherently slow.
+ --
+ -- (3) Instantiation of SAL.Gen_Definite_Doubly_Linked_Lists_Sorted -
slower than (2)
+
+ type Item is record
+ Prod : Production_ID;
+ Dot : Token_ID_Arrays.Cursor; -- token after item Dot
+ Lookaheads : access Lookahead := null;
+ -- Programmer must remember to copy Item.Lookaheads.all, not
+ -- Item.Lookaheads. Wrapping this in Ada.Finalization.Controlled
+ -- would just slow it down.
+ --
+ -- We don't free Lookaheads; we assume the user is running
+ -- wisi-generate, and not keeping LR1_Items around.
+ end record;
+
+ function To_Lookahead (Item : in Token_ID; Descriptor : in
WisiToken.Descriptor) return Lookahead;
+
+ function Contains (Item : in Lookahead; ID : in Token_ID) return Boolean
+ is (Item (ID));
+
+ function Lookahead_Image (Item : in Lookahead; Descriptor : in
WisiToken.Descriptor) return String;
+ -- Returns the format used in parse table output.
+
+ function Item_Compare (Left, Right : in Item) return SAL.Compare_Result;
+ -- Sort Item_Lists in ascending order of Prod.Nonterm, Prod.RHS, Dot;
+ -- ignores Lookaheads.
+
+ package Item_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists_Sorted
(Item, Item_Compare);
+
+ procedure Include
+ (Item : in out LR1_Items.Item;
+ Value : in Lookahead;
+ Added : out Boolean);
+ -- Add Value to Item.Lookahead, if not already present.
+ --
+ -- Added is True if Value was not already present.
+ --
+ -- Does not exclude Propagate_ID.
+
+ procedure Include
+ (Item : in out LR1_Items.Item;
+ Value : in Lookahead;
+ Descriptor : in WisiToken.Descriptor);
+ -- Add Value to Item.Lookahead. Does not check if already present.
+ -- Excludes Propagate_ID.
+
+ procedure Include
+ (Item : in out LR1_Items.Item;
+ Value : in Lookahead;
+ Added : out Boolean;
+ Descriptor : in WisiToken.Descriptor);
+ -- Add Value to Item.Lookahead.
+
+ type Goto_Item is record
+ Symbol : Token_ID;
+ -- If Symbol is a terminal, this is a shift and goto state action.
+ -- If Symbol is a non-terminal, this is a post-reduce goto state action.
+ State : State_Index;
+ end record;
+
+ function Goto_Item_Compare (Left, Right : in Goto_Item) return
SAL.Compare_Result is
+ (if Left.Symbol > Right.Symbol then SAL.Greater
+ elsif Left.Symbol < Right.Symbol then SAL.Less
+ else SAL.Equal);
+ -- Sort Goto_Item_Lists in ascending order of Symbol.
+
+ package Goto_Item_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists_Sorted
+ (Goto_Item, Goto_Item_Compare);
+
+ type Item_Set is record
+ Set : Item_Lists.List;
+ Goto_List : Goto_Item_Lists.List;
+ Dot_IDs : Token_ID_Arrays.Vector;
+ State : Unknown_State_Index := Unknown_State;
+ end record;
+
+ function Filter
+ (Set : in Item_Set;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Include : access function
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Item : in LR1_Items.Item)
+ return Boolean)
+ return Item_Set;
+ -- Return a deep copy of Set, including only items for which Include
returns True.
+
+ function In_Kernel
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Item : in LR1_Items.Item)
+ return Boolean;
+ -- For use with Filter; [dragon] sec 4.7 pg 240
+
+ function Find
+ (Item : in LR1_Items.Item;
+ Set : in Item_Set)
+ return Item_Lists.Cursor;
+ -- Return an item from Set that matches Item.Prod, Item.Dot.
+ --
+ -- Return No_Element if not found.
+
+ function Find
+ (Prod : in Production_ID;
+ Dot : in Token_ID_Arrays.Cursor;
+ Right : in Item_Set)
+ return Item_Lists.Cursor;
+ -- Return an item from Right that matches Prod, Dot.
+ --
+ -- Return No_Element if not found.
+
+ function Find
+ (Prod : in Production_ID;
+ Dot : in Token_ID_Arrays.Cursor;
+ Right : in Item_Set;
+ Lookaheads : in Lookahead)
+ return Item_Lists.Cursor;
+ -- Return an item from Right that matches Prod, Dot, and
+ -- Lookaheads.
+ --
+ -- Return No_Element if not found.
+ --
+ -- 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);
+ 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);
+ 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
+ else SAL.Equal);
+
+ package Int_Arrays_Comparable is new Int_Arrays.Gen_Comparable
(Compare_Integer_16);
+
+ subtype Item_Set_Tree_Key is Int_Arrays_Comparable.Vector;
+ -- We want a key that is fast to compare, and has enough info to
+ -- significantly speed the search for an item set. So we convert all
+ -- relevant data in an item into a string of integers. We need 16 bit
+ -- because Ada token_ids max is 332. LR1 keys include lookaheads,
+ -- LALR keys do not.
+
+ type Item_Set_Tree_Node is record
+ Key : Item_Set_Tree_Key;
+ State : Unknown_State_Index;
+ end record;
+
+ function To_Item_Set_Tree_Key
+ (Item_Set : in LR1_Items.Item_Set;
+ Include_Lookaheads : in Boolean)
+ return Item_Set_Tree_Key;
+
+ function To_Item_Set_Tree_Key (Node : in Item_Set_Tree_Node) return
Item_Set_Tree_Key is
+ (Node.Key);
+
+ package Item_Set_Trees is new SAL.Gen_Unbounded_Definite_Red_Black_Trees
+ (Element_Type => Item_Set_Tree_Node,
+ Key_Type => Item_Set_Tree_Key,
+ Key => To_Item_Set_Tree_Key,
+ Key_Compare => Int_Arrays_Comparable.Compare);
+ -- Item_Set_Arrays.Vector holds state item sets indexed by state, for
+ -- iterating in state order. Item_Set_Trees.Tree holds lists of state
+ -- indices sorted by LR1 item info, for fast Find in LR1_Item_Sets
+ -- and LALR_Kernels.
+
+ function Find
+ (New_Item_Set : in Item_Set;
+ Item_Set_Tree : in Item_Set_Trees.Tree;
+ Match_Lookaheads : in Boolean)
+ return Unknown_State_Index;
+ -- Return the State of an element in Item_Set_Tree matching
+ -- New_Item_Set, Unknown_State if not found.
+ --
+ -- Match_Lookaheads is True in LR1_Generate.
+
+ procedure Add
+ (New_Item_Set : in out Item_Set;
+ Item_Set_Vector : in out Item_Set_List;
+ Item_Set_Tree : in out Item_Set_Trees.Tree;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Lookaheads : in Boolean);
+ -- Set New_Item_Set.Dot_IDs, add New_Item_Set to Item_Set_Vector,
Item_Set_Tree
+
+ function Is_In
+ (Item : in Goto_Item;
+ Goto_List : in Goto_Item_Lists.List)
+ return Boolean;
+ -- Return True if a goto on Symbol to State is found in Goto_List
+
+ function Goto_State
+ (From : in Item_Set;
+ Symbol : in Token_ID)
+ return Unknown_State_Index;
+ -- Return state from From.Goto_List where the goto symbol is
+ -- Symbol; Unknown_State if not found.
+
+ function Closure
+ (Set : in Item_Set;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return Item_Set;
+ -- Return the closure of Set over Grammar. First must be the
+ -- result of First above. Makes a deep copy of Goto_List.
+ -- Implements 'closure' from [dragon] algorithm 4.9 pg 232, but
+ -- allows merging lookaheads into one item..
+
+ function Productions (Set : in Item_Set) return Production_ID_Arrays.Vector;
+
+ procedure Put
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Item : in LR1_Items.Item;
+ Show_Lookaheads : in Boolean := True);
+
+ 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;
+ Show_Goto_List : in Boolean := False);
+
+ procedure Put
+ (Descriptor : in WisiToken.Descriptor;
+ List : in Goto_Item_Lists.List);
+ procedure Put
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Item : in Item_Set_List;
+ Show_Lookaheads : in Boolean := True);
+ -- Put Item to Ada.Text_IO.Standard_Output. Does not end with New_Line.
+
+end WisiToken.Generate.LR1_Items;
diff --git a/wisitoken-generate-packrat.adb b/wisitoken-generate-packrat.adb
new file mode 100644
index 0000000..068b6d0
--- /dev/null
+++ b/wisitoken-generate-packrat.adb
@@ -0,0 +1,247 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Generate.Packrat is
+
+ function Potential_Direct_Right_Recursive
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Empty : in Token_ID_Set)
+ return Token_ID_Set
+ is
+ subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
+ begin
+ return Result : Token_ID_Set (Nonterminal) := (others => False) do
+ for Prod of Grammar loop
+ RHS_Loop :
+ for RHS of Prod.RHSs loop
+ ID_Loop :
+ for I in reverse RHS.Tokens.First_Index + 1 ..
RHS.Tokens.Last_Index loop
+ declare
+ ID : constant Token_ID := RHS.Tokens (I);
+ begin
+ if ID = Prod.LHS then
+ Result (ID) := True;
+ exit RHS_Loop;
+ elsif not (ID in Nonterminal) then
+ exit ID_Loop;
+ elsif not Empty (ID) then
+ exit ID_Loop;
+ end if;
+ end;
+ end loop ID_Loop;
+ end loop RHS_Loop;
+ end loop;
+ end return;
+ end Potential_Direct_Right_Recursive;
+
+ procedure Indirect_Left_Recursive (Data : in out Packrat.Data)
+ is
+ begin
+ for Prod_I of Data.Grammar loop
+ for Prod_J of Data.Grammar loop
+ Data.Involved (Prod_I.LHS, Prod_J.LHS) :=
+ Data.First (Prod_I.LHS, Prod_J.LHS) and
+ Data.First (Prod_J.LHS, Prod_I.LHS);
+ end loop;
+ end loop;
+ end Indirect_Left_Recursive;
+
+ ----------
+ -- Public subprograms
+
+ function Initialize
+ (Source_File_Name : in String;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Source_Line_Map : in Productions.Source_Line_Maps.Vector;
+ First_Terminal : in Token_ID)
+ return Packrat.Data
+ is
+ Empty : constant Token_ID_Set := WisiToken.Generate.Has_Empty_Production
(Grammar);
+ begin
+ return Result : Packrat.Data :=
+ (First_Terminal => First_Terminal,
+ First_Nonterminal => Grammar.First_Index,
+ Last_Nonterminal => Grammar.Last_Index,
+ Source_File_Name => +Source_File_Name,
+ Grammar => Grammar,
+ Source_Line_Map => Source_Line_Map,
+ Empty => Empty,
+ Direct_Left_Recursive => Potential_Direct_Left_Recursive (Grammar,
Empty),
+ First => WisiToken.Generate.First (Grammar, Empty,
First_Terminal => First_Terminal),
+ Involved => (others => (others => False)))
+ do
+ Indirect_Left_Recursive (Result);
+ end return;
+ end Initialize;
+
+ procedure Check_Recursion (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
+ is
+ Right_Recursive : constant Token_ID_Set :=
Potential_Direct_Right_Recursive (Data.Grammar, Data.Empty);
+ begin
+ for Prod of Data.Grammar loop
+ if Data.Direct_Left_Recursive (Prod.LHS) and Right_Recursive
(Prod.LHS) then
+ -- We only implement the simplest left recursion solution ([warth
+ -- 2008] figure 3); [tratt 2010] section 6.3 gives this condition
for
+ -- that to be valid.
+ -- FIXME: not quite? definite direct right recursive ok?
+ -- FIXME: for indirect left recursion, need potential indirect
right recursive check?
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
+ "' is both left and right recursive; not supported."));
+ end if;
+
+ for I in Data.Involved'Range (2) loop
+ if Prod.LHS /= I and then Data.Involved (Prod.LHS, I) then
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
+ "' is indirect recursive with " & Image (I, Descriptor)
& ", not supported"));
+ end if;
+ end loop;
+ end loop;
+ end Check_Recursion;
+
+ procedure Check_RHS_Order (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ for Prod of Data.Grammar loop
+ -- Empty must be last
+ for I in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index - 1 loop
+ if Prod.RHSs (I).Tokens.Length = 0 then
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).RHS_Map (I),
+ "right hand side" & Integer'Image (I) & " in " & Image
(Prod.LHS, Descriptor) &
+ " is empty, but not last; no later right hand side will
match."));
+ WisiToken.Generate.Error := True;
+ end if;
+ end loop;
+
+ for I in Prod.RHSs.First_Index + 1 .. Prod.RHSs.Last_Index loop
+ declare
+ Cur : Token_ID_Arrays.Vector renames Prod.RHSs (I).Tokens;
+ begin
+ -- Shared prefix; longer must be first
+ for J in Prod.RHSs.First_Index .. I - 1 loop
+ declare
+ Prev : Token_ID_Arrays.Vector renames Prod.RHSs
(J).Tokens;
+ K : constant Natural := Shared_Prefix (Prev, Cur);
+ begin
+ if K > 0 and Prev.Length < Cur.Length then
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).RHS_Map (I),
+ "right hand side" & Integer'Image (I) & " in " &
Image (Prod.LHS, Descriptor) &
+ " may never match; it shares a prefix with a
shorter previous rhs" &
+ Integer'Image (J) & "."));
+ end if;
+ end;
+ end loop;
+
+ -- recursion; typical LALR list is written:
+ --
+ -- statement_list
+ -- : statement
+ -- | statement_list statement
+ -- ;
+ -- association_list
+ -- : association
+ -- | association_list COMMA association
+ -- ;
+ --
+ -- a different recursive definition:
+ --
+ -- name
+ -- : IDENTIFIER
+ -- | name LEFT_PAREN range_list RIGHT_PAREN
+ -- | name actual_parameter_part
+ -- ...
+ -- ;
+ --
+ -- For packrat, the recursive RHSs must come before others:
+ --
+ -- statement_list
+ -- : statement_list statement
+ -- | statement
+ -- ;
+ -- association_list
+ -- : association_list COMMA association
+ -- | association
+ -- ;
+ -- name
+ -- : name LEFT_PAREN range_list RIGHT_PAREN
+ -- | name actual_parameter_part
+ -- | IDENTIFIER
+ -- ...
+ -- ;
+ declare
+ Prev : Token_ID_Arrays.Vector renames Prod.RHSs (I -
1).Tokens;
+ begin
+ if Cur.Length > 0 and then Prev.Length > 0 and then
+ Cur (1) = Prod.LHS and then Prev (1) /= Prod.LHS
+ then
+ Put_Error
+ (Error_Message
+ (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line,
+ "recursive right hand sides must be before
others."));
+ end if;
+ end;
+ end;
+ end loop;
+ end loop;
+ end Check_RHS_Order;
+
+ procedure Check_All (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
+ is begin
+ Check_Recursion (Data, Descriptor);
+ Check_RHS_Order (Data, Descriptor);
+ end Check_All;
+
+ function Potential_Direct_Left_Recursive
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Empty : in Token_ID_Set)
+ return Token_ID_Set
+ is
+ subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
+ begin
+ -- FIXME: this duplicates the computation of First; if keep First,
+ -- change this to use it.
+ return Result : Token_ID_Set (Nonterminal) := (others => False) do
+ for Prod of Grammar loop
+ RHS_Loop :
+ for RHS of Prod.RHSs loop
+ ID_Loop :
+ for ID of RHS.Tokens loop
+ if ID = Prod.LHS then
+ Result (ID) := True;
+ exit RHS_Loop;
+ elsif not (ID in Nonterminal) then
+ exit ID_Loop;
+ elsif not Empty (ID) then
+ exit ID_Loop;
+ end if;
+ end loop ID_Loop;
+ end loop RHS_Loop;
+ end loop;
+ end return;
+ end Potential_Direct_Left_Recursive;
+
+end WisiToken.Generate.Packrat;
diff --git a/wisitoken-generate-packrat.ads b/wisitoken-generate-packrat.ads
new file mode 100644
index 0000000..152dd99
--- /dev/null
+++ b/wisitoken-generate-packrat.ads
@@ -0,0 +1,75 @@
+-- Abstract :
+--
+-- Types and operations for computing grammar properties used in
+-- generating a packrat parser.
+--
+-- We use the terminology in [tratt 2010] for recursion in
+-- productions.
+--
+-- References :
+--
+-- See wisitoken-parse-packrat.ads.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package WisiToken.Generate.Packrat is
+
+ type Data (First_Terminal, First_Nonterminal, Last_Nonterminal : Token_ID)
is tagged
+ record
+ -- Data needed to check a grammar and generate code. Tagged to allow
+ -- Object.Method syntax. Descriptor not included to avoid duplicating
+ -- lots of discriminants.
+ Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Grammar : WisiToken.Productions.Prod_Arrays.Vector;
+ Source_Line_Map : Productions.Source_Line_Maps.Vector;
+ Empty : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
+ Direct_Left_Recursive : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
+ First : Token_Array_Token_Set
+ (First_Nonterminal .. Last_Nonterminal, First_Terminal ..
Last_Nonterminal);
+ Involved : Token_Array_Token_Set
+ (First_Nonterminal .. Last_Nonterminal, First_Nonterminal ..
Last_Nonterminal);
+ end record;
+
+ function Initialize
+ (Source_File_Name : in String;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Source_Line_Map : in Productions.Source_Line_Maps.Vector;
+ First_Terminal : in Token_ID)
+ return Packrat.Data;
+
+ procedure Check_Recursion (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
+ -- Check that any rule recursion present is supported.
+
+ procedure Check_RHS_Order (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
+ -- For each production, check that right hand sides that share
+ -- prefixes have the longest right hand side first, and that any
+ -- empty right hand side is last.
+ --
+ -- Violations output a message to Ada.Text_IO.Standard_Error, and
+ -- set WisiToken.Generate.Error True.
+
+ procedure Check_All (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
+ -- Run all the above checks.
+ --
+ -- Note that WisiToken.Generate.Check_Consistent is run in
+ -- wisi-gen_generate_utils.To_Grammar.
+
+ function Potential_Direct_Left_Recursive
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Empty : in Token_ID_Set)
+ return Token_ID_Set;
+
+end WisiToken.Generate.Packrat;
diff --git a/wisitoken-generate.adb b/wisitoken-generate.adb
new file mode 100644
index 0000000..aba997b
--- /dev/null
+++ b/wisitoken-generate.adb
@@ -0,0 +1,495 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Directories;
+with Ada.Text_IO;
+with Ada.Strings.Fixed;
+package body WisiToken.Generate is
+
+ function Error_Message
+ (File_Name : in String;
+ File_Line : in Line_Number_Type;
+ Message : in String)
+ return String
+ is
+ use Ada.Directories;
+ use Ada.Strings.Fixed;
+ use Ada.Strings;
+ begin
+ return Simple_Name (File_Name) & ":" &
+ Trim (Line_Number_Type'Image (File_Line), Left) & ":0: " & Message;
+ end Error_Message;
+
+ procedure Put_Error (Message : in String)
+ is begin
+ Error := True;
+ Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, Message);
+ end Put_Error;
+
+ procedure Check_Consistent
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Source_File_Name : in String)
+ is begin
+ if Descriptor.Accept_ID /= Descriptor.First_Nonterminal then
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Line_Number_Type'First,
+ "Descriptor.Accept_ID /= Descriptor.First_Nonterminal"));
+ end if;
+ if Grammar.First_Index /= Descriptor.First_Nonterminal then
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Line_Number_Type'First,
+ "Grammar.First_Index /= Descriptor.First_Nonterminal"));
+ end if;
+ if Grammar.Last_Index /= Descriptor.Last_Nonterminal then
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Line_Number_Type'First,
+ "Grammar.Last_Index /= Descriptor.Last_Nonterminal"));
+ end if;
+
+ for Nonterm in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal loop
+ if Grammar (Nonterm).LHS /= Nonterm then
+ Put_Error
+ (Error_Message
+ (Source_File_Name, Line_Number_Type'First,
+ "Grammar (" & Image (Nonterm, Descriptor) & ").LHS /= " &
+ Image (Nonterm, Descriptor)));
+ end if;
+ end loop;
+ end Check_Consistent;
+
+ function Check_Unused_Tokens
+ (Descriptor : in WisiToken.Descriptor;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
+ return Boolean
+ is
+ subtype Terminals is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+ subtype Nonterminals is Token_ID range Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal;
+
+ Used_Tokens : Token_ID_Set := (Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal => False);
+
+ Changed : Boolean := False;
+ Abort_Generate : Boolean := False;
+ Unused_Tokens : Boolean := False;
+ begin
+ Used_Tokens (Descriptor.Accept_ID) := True;
+
+ -- First mark all nonterminals that occur in used nonterminals as
+ -- used.
+ loop
+ for Prod of Grammar loop
+ if Used_Tokens (Prod.LHS) then
+ for RHS of Prod.RHSs loop
+ for J of RHS.Tokens loop
+ if J in Nonterminals then
+ Changed := Changed or else not Used_Tokens (J);
+ Used_Tokens (J) := True;
+ end if;
+ end loop;
+ end loop;
+ end if;
+ end loop;
+ exit when not Changed;
+ Changed := False;
+ end loop;
+
+ -- Now mark terminals used in used nonterminals
+ for Prod of Grammar loop
+ if Used_Tokens (Prod.LHS) then
+ for RHS of Prod.RHSs loop
+ for J of RHS.Tokens loop
+ if not (J in Used_Tokens'Range) then
+ WisiToken.Generate.Put_Error
+ ("non-grammar token " & Image (J, Descriptor) & " used
in grammar");
+
+ -- This causes lots of problems with token_id not in
terminal or
+ -- nonterminal range, so abort early.
+ Abort_Generate := True;
+ end if;
+
+ if J in Terminals then
+ Used_Tokens (J) := True;
+ end if;
+ end loop;
+ end loop;
+ end if;
+ end loop;
+
+ for I in Used_Tokens'Range loop
+ if not Used_Tokens (I) then
+ if not Unused_Tokens then
+ WisiToken.Generate.Put_Error ("Unused tokens:");
+ Unused_Tokens := True;
+ end if;
+ WisiToken.Generate.Put_Error (Image (I, Descriptor));
+ end if;
+ end loop;
+
+ if Abort_Generate then
+ raise Grammar_Error;
+ end if;
+
+ return Unused_Tokens;
+ end Check_Unused_Tokens;
+
+ function Has_Empty_Production (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Token_ID_Set
+ is
+ use all type Ada.Containers.Count_Type;
+
+ subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
+
+ Result : Token_ID_Set := (Nonterminal => False);
+ Changed : Boolean := True;
+ begin
+ loop
+ exit when not Changed;
+ Changed := False;
+
+ for Prod of Grammar loop
+ for RHS of Prod.RHSs loop
+ if (RHS.Tokens.Length = 0 or else
+ (RHS.Tokens (1) in Nonterminal and then Result
(RHS.Tokens (1)))) and
+ not Result (Prod.LHS)
+ then
+ Result (Prod.LHS) := True;
+ Changed := True;
+ end if;
+ end loop;
+ end loop;
+ end loop;
+ return Result;
+ end Has_Empty_Production;
+
+ function First
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal : in Token_ID;
+ Non_Terminal : in Token_ID)
+ return Token_ID_Set
+ is
+ Derivations : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
+ Added_Tokens : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
+ Search_Tokens : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
+
+ function Compute_Non_Terminals return Token_ID_Set
+ is
+ Result : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
+ begin
+ -- Can't use a simple aggregate for this; bounds are non-static.
+ Result (First_Terminal .. Grammar.First_Index - 1) := (others =>
False);
+ Result (Grammar.First_Index .. Grammar.Last_Index) := (others =>
True);
+ return Result;
+ end Compute_Non_Terminals;
+
+ Non_Terminals : constant Token_ID_Set := Compute_Non_Terminals;
+
+ begin
+ Search_Tokens (Non_Terminal) := True;
+
+ while Any (Search_Tokens) loop
+
+ Added_Tokens := (others => False);
+
+ for Prod of Grammar loop
+ if Search_Tokens (Prod.LHS) then
+ for RHS of Prod.RHSs loop
+ for Derived_Token of RHS.Tokens loop
+ if not Derivations (Derived_Token) then
+ Added_Tokens (Derived_Token) := True;
+ end if;
+
+ if Non_Terminals (Derived_Token) and then
Has_Empty_Production (Derived_Token) then
+ null;
+ else
+ exit;
+ end if;
+ end loop;
+ end loop;
+ end if;
+ end loop;
+
+ Derivations := Derivations or Added_Tokens;
+ Search_Tokens := Added_Tokens and Non_Terminals;
+ end loop;
+
+ return Derivations;
+ end First;
+
+ function First
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal : in Token_ID)
+ return Token_Array_Token_Set
+ is
+ Matrix : Token_Array_Token_Set :=
+ (Grammar.First_Index .. Grammar.Last_Index =>
+ (First_Terminal .. Grammar.Last_Index => False));
+
+ procedure Set_Slice (Matrix : in out Token_Array_Token_Set; I :
Token_ID; Value : in Token_ID_Set)
+ is begin
+ for J in Matrix'Range (2) loop
+ Matrix (I, J) := Value (J);
+ end loop;
+ end Set_Slice;
+
+ begin
+ for NT_Index in Matrix'Range loop
+ Set_Slice (Matrix, NT_Index, First (Grammar, Has_Empty_Production,
First_Terminal, NT_Index));
+ end loop;
+
+ return Matrix;
+ end First;
+
+ function To_Terminal_Sequence_Array
+ (First : in Token_Array_Token_Set;
+ Descriptor : in WisiToken.Descriptor)
+ return Token_Sequence_Arrays.Vector
+ is
+ subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+ begin
+ return Result : Token_Sequence_Arrays.Vector do
+ Result.Set_First (First'First (1));
+ Result.Set_Last (First'Last (1));
+
+ for I in First'Range (1) loop
+ declare
+ Row : Token_ID_Arrays.Vector renames Result (I);
+ begin
+ for J in First'Range (2) loop
+ if First (I, J) and then J in Terminal then
+ Row.Append (J);
+ end if;
+ end loop;
+ end;
+ end loop;
+ end return;
+ end To_Terminal_Sequence_Array;
+
+ function Follow
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ First : in Token_Array_Token_Set;
+ Has_Empty_Production : in Token_ID_Set)
+ return Token_Array_Token_Set
+ is
+ subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+ subtype Nonterminal is Token_ID range Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal;
+
+ Prev_Result : Token_Array_Token_Set := (Nonterminal => (Terminal =>
False));
+ Result : Token_Array_Token_Set := (Nonterminal => (Terminal =>
False));
+
+ ID : Token_ID;
+ begin
+ -- [dragon] pgp 189:
+ --
+ -- Rule 1 Follow (S, EOF) = True; EOF is explicit in the
+ -- start symbol production, so this is covered by Rule 2.
+ --
+ -- Rule 2: If A => alpha B Beta, add First (Beta) to Follow (B)
+ --
+ -- Rule 3; if A => alpha B, or A -> alpha B Beta and Beta
+ -- can be null, add Follow (A) to Follow (B)
+ --
+ -- We don't assume any order in the productions list, so we
+ -- have to keep applying rule 3 until nothing changes.
+
+ for B in Nonterminal loop
+ for Prod of Grammar loop
+ for A of Prod.RHSs loop
+ for I in A.Tokens.First_Index .. A.Tokens.Last_Index loop
+ if A.Tokens (I) = B then
+ if I < A.Tokens.Last_Index then
+ -- Rule 1
+ ID := A.Tokens (1 + I);
+ if ID in Terminal then
+ Result (B, ID) := True;
+ else
+ Or_Slice (Result, B, Slice (First, ID));
+ end if;
+ end if;
+ end if;
+ end loop;
+ end loop;
+ end loop;
+ end loop;
+
+ Prev_Result := Result;
+ loop
+ for B in Nonterminal loop
+ for Prod of Grammar loop
+ for A of Prod.RHSs loop
+ for I in A.Tokens.First_Index .. A.Tokens.Last_Index loop
+ if A.Tokens (I) = B then
+ if I = A.Tokens.Last_Index or else
+ (A.Tokens (1 + I) in Nonterminal and then
+ Has_Empty_Production (A.Tokens (1 + I)))
+ then
+ -- rule 3
+ Or_Slice (Result, B, Slice (Result, Prod.LHS));
+ end if;
+ end if;
+ end loop;
+ end loop;
+ end loop;
+ end loop;
+
+ exit when Prev_Result = Result;
+ Prev_Result := Result;
+ end loop;
+ return Result;
+ end Follow;
+
+ 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
+
+ procedure Indent_Line (Text : in String)
+ is
+ use Ada.Text_IO;
+ begin
+ Set_Col (Indent);
+ Put_Line (Text);
+ Line_Count := Line_Count + 1;
+ end Indent_Line;
+
+ procedure Indent_Start (Text : in String)
+ is
+ use Ada.Text_IO;
+ begin
+ Set_Col (Indent);
+ Put (Text);
+ end Indent_Start;
+
+ procedure Indent_Wrap (Text : in String)
+ is
+ use all type Ada.Text_IO.Count;
+ use Ada.Strings;
+ use Ada.Strings.Fixed;
+ I : Natural;
+ First : Integer := Text'First;
+ begin
+ if Text'Length + Indent <= Max_Line_Length then
+ Indent_Line (Text);
+ else
+ loop
+ I := Text'Last;
+ loop
+ I := Index (Text (First .. Text'Last), " ", From => I, Going =>
Backward);
+ exit when I - First + Integer (Indent) <= Max_Line_Length;
+ I := I - 1;
+ end loop;
+ Indent_Line (Text (First .. I - 1));
+ First := I + 1;
+ exit when Text'Last - First + Integer (Indent) <= Max_Line_Length;
+ end loop;
+ Indent_Line (Text (First .. Text'Last));
+ end if;
+ end Indent_Wrap;
+
+ procedure Indent_Wrap_Comment (Text : in String; Comment_Syntax : in String)
+ is
+ use all type Ada.Text_IO.Count;
+ use Ada.Strings;
+ use Ada.Strings.Fixed;
+ Prefix : constant String := Comment_Syntax & " ";
+ I : Natural;
+ First : Integer := Text'First;
+ begin
+ if Text'Length + Indent <= Max_Line_Length - 4 then
+ Indent_Line (Prefix & Text);
+ else
+ loop
+ I := Text'Last;
+ loop
+ I := Index (Text (First .. Text'Last), " ", From => I, Going =>
Backward);
+ exit when I - First + Integer (Indent) <= Max_Line_Length - 4;
+ I := I - 1;
+ end loop;
+ Indent_Line (Prefix & Text (First .. I - 1));
+ First := I + 1;
+ exit when Text'Last - First + Integer (Indent) <= Max_Line_Length
- 4;
+ end loop;
+ Indent_Line (Prefix & Text (First .. Text'Last));
+ end if;
+ end Indent_Wrap_Comment;
+
+end WisiToken.Generate;
diff --git a/wisitoken-generate.ads b/wisitoken-generate.ads
new file mode 100644
index 0000000..19648d2
--- /dev/null
+++ b/wisitoken-generate.ads
@@ -0,0 +1,136 @@
+-- Abstract :
+--
+-- Types and operations for generating parsers, common to all parser
+-- types.
+--
+-- The wisi* packages deal with reading *.wy files and generating
+-- source code files. The wisitoken-generate* packages deal with
+-- computing parser properties from the grammar. (For historical
+-- reasons, not all packages follow this naming convention yet).
+--
+-- References :
+--
+-- See wisitoken.ads
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Productions;
+package WisiToken.Generate is
+
+ Error : Boolean := False;
+ -- Set True by errors during grammar generation
+
+ function Error_Message
+ (File_Name : in String;
+ File_Line : in WisiToken.Line_Number_Type;
+ Message : in String)
+ return String;
+
+ procedure Put_Error (Message : in String);
+ -- Set Error True, output Message to Standard_Error
+
+ procedure Check_Consistent
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Source_File_Name : in String);
+ -- Check requirements on Descriptor values.
+
+ function Check_Unused_Tokens
+ (Descriptor : in WisiToken.Descriptor;
+ Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
+ return Boolean;
+ -- Return False if there is a terminal or nonterminal that is not
+ -- used in the grammar.
+ --
+ -- Raises Grammar_Error if there is a non-grammar token used in the
+ -- grammar.
+
+ function Has_Empty_Production (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Token_ID_Set;
+ -- Result (ID) is True if any production for ID can be an empty
+ -- production, recursively.
+
+ function First
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal : in Token_ID)
+ return Token_Array_Token_Set;
+ -- For each nonterminal in Grammar, find the set of tokens
+ -- (terminal or nonterminal) that any string derived from it can
+ -- start with. Together with Has_Empty_Production, implements
+ -- algorithm FIRST from [dragon], augmented with nonterminals.
+ --
+ -- LALR, LR1 generate want First as both Token_Sequence_Arrays.Vector
+ -- and Token_Array_Token_Set, Packrat wants Token_Array_Token_Set,
+ -- existing tests all use Token_Array_Token_Set. So for LR1 we use
+ -- To_Terminal_Sequence_Array.
+
+ function To_Terminal_Sequence_Array
+ (First : in Token_Array_Token_Set;
+ Descriptor : in WisiToken.Descriptor)
+ return Token_Sequence_Arrays.Vector;
+ -- Only includes terminals.
+
+ function Follow
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ First : in Token_Array_Token_Set;
+ Has_Empty_Production : in Token_ID_Set)
+ return Token_Array_Token_Set;
+ -- For each nonterminal in Grammar, find the set of terminal
+ -- tokens that can follow it. Implements algorithm FOLLOW from
+ -- [dragon] pg 189.
+
+ 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.
+
+ Max_Line_Length : constant := 120;
+
+ Indent : Standard.Ada.Text_IO.Positive_Count := 1;
+ Line_Count : Integer;
+
+ procedure Indent_Line (Text : in String);
+ -- Put Text, indented to Indent, to Current_Output, with newline.
+
+ procedure Indent_Start (Text : in String);
+ -- Put Text indented to Indent to Current_Output, without newline.
+ -- Should be followed by Put_Line, not Indent_Line.
+
+ procedure Indent_Wrap (Text : in String);
+ -- Put Text, indented to Indent, wrapped at Max_Line_Length, to
+ -- Current_Output, ending with newline.
+
+ procedure Indent_Wrap_Comment (Text : in String; Comment_Syntax : in
String);
+ -- Put Text, prefixed by Comment_Syntax and two spaces, indented to
+ -- Indent, wrapped at Max_Line_Length, to Current_Output, ending with
+ -- newline.
+
+end WisiToken.Generate;
diff --git a/wisitoken-lexer-re2c.adb b/wisitoken-lexer-re2c.adb
new file mode 100644
index 0000000..c5bc6af
--- /dev/null
+++ b/wisitoken-lexer-re2c.adb
@@ -0,0 +1,244 @@
+-- Abstract:
+--
+-- see spec.
+--
+-- Copyright (C) 2017, 2018 Stephe Leake
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Directories;
+with Ada.Strings.Unbounded;
+with GNATCOLL.Mmap;
+package body WisiToken.Lexer.re2c is
+
+ overriding procedure Finalize (Object : in out Instance)
+ is
+ use all type System.Address;
+ begin
+ if Object.Lexer /= System.Null_Address then
+ Free_Lexer (Object.Lexer);
+ Object.Lexer := System.Null_Address;
+ end if;
+
+ Finalize (Object.Source);
+ end Finalize;
+
+ type Instance_Access is access Instance; -- silence compiler warning
+
+ function New_Lexer
+ (Trace : not null access WisiToken.Trace'Class)
+ return Handle
+ is begin
+ return Handle (Instance_Access'(new Instance (Trace)));
+ end New_Lexer;
+
+ overriding procedure Reset_With_String (Lexer : in out Instance; Input : in
String)
+ 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);
+
+ Lexer.Lexer := New_Lexer
+ (Buffer => Lexer.Source.Buffer.all'Address,
+ Length => Interfaces.C.size_t (Input'Length),
+ Verbosity => Interfaces.C.int (if Trace_Parse > 3 then Trace_Parse -
3 else 0));
+
+ 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)
+ is begin
+ Finalize (Lexer);
+
+ -- We assume Input is in UTF-8 encoding
+ Lexer.Source :=
+ (Label => String_Label,
+ File_Name =>
+ +(if Ada.Strings.Unbounded.Length (File_Name) = 0 then ""
+ else Ada.Directories.Simple_Name (-File_Name)),
+ Buffer => Input,
+ User_Buffer => True);
+
+ Lexer.Lexer := New_Lexer
+ (Buffer => Lexer.Source.Buffer.all'Address,
+ Length => Interfaces.C.size_t (Input'Length),
+ Verbosity => Interfaces.C.int (if Trace_Parse > 3 then Trace_Parse -
3 else 0));
+
+ Reset (Lexer);
+ end Reset_With_String_Access;
+
+ overriding procedure Reset_With_File (Lexer : in out Instance; File_Name :
in String)
+ is
+ use GNATCOLL.Mmap;
+ 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);
+
+ 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)),
+ Verbosity => Interfaces.C.int (if Trace_Parse > 3 then Trace_Parse -
3 else 0));
+
+ Reset (Lexer);
+ end Reset_With_File;
+
+ overriding procedure Reset (Lexer : in out Instance)
+ is begin
+ Reset_Lexer (Lexer.Lexer);
+ Lexer.Line := 1;
+ 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
+ then Invalid_Token_ID
+ else Lexer.Trace.Descriptor.New_Line_ID);
+ end Reset;
+
+ overriding function Find_Next
+ (Lexer : in out Instance;
+ Token : out Base_Token)
+ return Boolean
+ is
+ use Interfaces.C;
+
+ procedure Build_Token
+ is begin
+ Token :=
+ (ID => Lexer.ID,
+
+ Byte_Region =>
+ (Buffer_Pos (Lexer.Byte_Position),
+ Base_Buffer_Pos (Lexer.Byte_Position + Lexer.Byte_Length - 1)),
+
+ Line => Lexer.Line,
+
+ Column =>
+ (if Lexer.ID = Lexer.Trace.Descriptor.New_Line_ID or
+ Lexer.ID = Lexer.Trace.Descriptor.EOF_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)));
+ end Build_Token;
+
+ begin
+ Lexer.Prev_ID := Lexer.ID;
+ loop
+ declare
+ Status : constant int := Next_Token
+ (Lexer.Lexer, Lexer.ID,
+ Byte_Position => Interfaces.C.size_t (Lexer.Byte_Position),
+ Byte_Length => Interfaces.C.size_t (Lexer.Byte_Length),
+ Char_Position => Interfaces.C.size_t (Lexer.Char_Position),
+ Char_Length => Interfaces.C.size_t (Lexer.Char_Length),
+ Line_Start => Interfaces.C.int (Lexer.Line));
+ begin
+ case Status is
+ when 0 =>
+ if Lexer.ID = Lexer.Trace.Descriptor.New_Line_ID then
+ Lexer.Char_Line_Start := Lexer.Char_Position + 1;
+ end if;
+
+ Build_Token;
+ return False;
+
+ when 1 =>
+ -- Unrecognized character from lexer. Handle missing quotes by
+ -- inserting a virtual quote at the existing quote, and
telling the
+ -- lexer to skip the char.
+ declare
+ Buffer : constant GNATCOLL.Mmap.Str_Access :=
WisiToken.Lexer.Buffer (Lexer.Source);
+ begin
+ 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)));
+
+ Lexer.ID := Lexer.Trace.Descriptor.String_1_ID;
+ Build_Token;
+ return True;
+
+ elsif 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)));
+
+ Lexer.ID := Lexer.Trace.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)));
+ end if;
+ end;
+
+ when others =>
+ raise Fatal_Error with " lexer returned unrecognized status
code" & int'Image (Status);
+ end case;
+ end;
+ end loop;
+ end Find_Next;
+
+ 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;
+ 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)));
+ end Buffer_Text;
+
+ overriding function File_Name (Lexer : in Instance) return String
+ is begin
+ return File_Name (Lexer.Source);
+ end File_Name;
+
+end WisiToken.Lexer.re2c;
diff --git a/wisitoken-lexer-re2c.ads b/wisitoken-lexer-re2c.ads
new file mode 100644
index 0000000..9bb33f5
--- /dev/null
+++ b/wisitoken-lexer-re2c.ads
@@ -0,0 +1,129 @@
+-- Abstract:
+--
+-- WisiToken wrapper around the re2c lexer
+--
+-- References:
+--
+-- [1] http://re2c.org/
+--
+-- Copyright (C) 2017, 2018 Stephe Leake
+--
+-- 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.
+
+pragma License (GPL); -- GNATCOLL.Mmap
+
+pragma Warnings (Off, "license of withed unit ""GNATCOLL.Mmap"" may be
inconsistent");
+
+pragma Warnings (On);
+with Interfaces.C;
+with System;
+generic
+ -- These subprograms are provided by generated source code.
+
+ with function New_Lexer
+ (Buffer : in System.Address;
+ Length : in Interfaces.C.size_t;
+ Verbosity : in Interfaces.C.int)
+ return System.Address;
+ -- Create the re2c lexer object, passing it the full text to process.
+ -- Length is buffer length in 8 bit bytes.
+
+ with procedure Free_Lexer (Lexer : in out System.Address);
+ -- Destruct the re2c lexer object
+
+ with procedure Reset_Lexer (Lexer : in System.Address);
+ -- Restart lexing, with previous input buffer.
+
+ with function Next_Token
+ (Lexer : in System.Address;
+ ID : out Token_ID;
+ Byte_Position : out Interfaces.C.size_t;
+ Byte_Length : out Interfaces.C.size_t;
+ Char_Position : out Interfaces.C.size_t;
+ Char_Length : out Interfaces.C.size_t;
+ Line_Start : out Interfaces.C.int)
+ return Interfaces.C.int;
+ -- *_Position and *_Length give the position and length in bytes and
+ -- characters of the token from the start of the buffer, 0 indexed.
+ --
+ -- Line_Start gives the line number in the source file that the first
+ -- character of the token is in, 1 indexed.
+ --
+ -- Result values:
+ --
+ -- 0 - no error
+ -- 1 - there is an unrecognized character at Position.
+
+package WisiToken.Lexer.re2c is
+
+ Invalid_Input : exception;
+
+ type Instance is new WisiToken.Lexer.Instance with private;
+
+ overriding procedure Finalize (Object : in out Instance);
+
+ function New_Lexer
+ (Trace : not null access WisiToken.Trace'Class)
+ 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);
+ -- 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);
+ -- Uses memory mapped file; no copies.
+
+ overriding procedure Discard_Rest_Of_Input (Lexer : in out Instance) is
null;
+
+ overriding procedure Reset (Lexer : in out Instance);
+
+ overriding function Buffer_Text (Lexer : in Instance; Byte_Bounds : in
Buffer_Region) return String;
+
+ overriding function First (Lexer : in Instance) return Boolean;
+
+ overriding
+ function Find_Next
+ (Lexer : in out Instance;
+ Token : out Base_Token)
+ return Boolean;
+
+ overriding function File_Name (Lexer : in Instance) return String;
+
+private
+
+ type Instance is new WisiToken.Lexer.Instance with
+ record
+ 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_Length : Natural;
+ Char_Position : Natural;
+ Char_Length : Natural;
+ -- Position and length in bytes and characters of last token from
+ -- 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
+ Prev_ID : Token_ID; -- previous token_id
+ end record;
+
+end WisiToken.Lexer.re2c;
diff --git a/wisitoken-lexer-regexp.adb b/wisitoken-lexer-regexp.adb
new file mode 100644
index 0000000..d355080
--- /dev/null
+++ b/wisitoken-lexer-regexp.adb
@@ -0,0 +1,240 @@
+-- Abstract:
+--
+-- See spec
+--
+-- Copyright (C) 2015, 2017, 2018 Stephe Leake
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Characters.Latin_1;
+with SAL;
+package body WisiToken.Lexer.Regexp is
+
+ function Find_Best_Match (Lexer : in out Instance) return Boolean
+ is
+ -- Find the longest matching character sequence in the buffer that
+ -- matches a token.
+ --
+ -- Return True if a token is matched, False if not.
+
+ use WisiToken.Regexp;
+
+ Current_Char : Integer := Lexer.Buffer_Head;
+ Current_State : Match_State;
+ Current_Match_Length : Integer := 0;
+ Best_Match_ID : Token_ID;
+ Best_Match_Length : Natural := 0;
+ Still_Matching : Boolean := False;
+ begin
+ -- We only support Reset_With_String.
+
+ if Current_Char > Lexer.Source.Buffer'Last then
+ Lexer.ID := Lexer.Trace.Descriptor.EOF_ID;
+ Lexer.Lexeme_Head := Lexer.Buffer_Head;
+ Lexer.Lexeme_Tail := Lexer.Buffer_Head - 1;
+ return True;
+ end if;
+
+ for I in Lexer.Syntax'Range loop
+ Clear (Lexer.Syntax (I).Regexp);
+ end loop;
+
+ loop
+ Still_Matching := False;
+
+ for I in Lexer.Syntax'Range loop
+ if State (Lexer.Syntax (I).Regexp) /= WisiToken.Regexp.Error then
+ Current_State := Match
+ (Lexer.Syntax (I).Regexp,
+ Lexer.Source.Buffer (Lexer.Buffer_Head ..
Lexer.Source.Buffer'Last),
+ Current_Char);
+
+ case Current_State is
+ when Matching =>
+ Still_Matching := True;
+
+ when Final =>
+ Still_Matching := True;
+
+ Current_Match_Length := Current_Char - Lexer.Buffer_Head + 1;
+
+ if Best_Match_Length < Current_Match_Length then
+ Best_Match_ID := I;
+ Best_Match_Length := Current_Match_Length;
+ end if;
+
+ when WisiToken.Regexp.Error =>
+ null;
+ end case;
+ end if;
+ end loop;
+
+ exit when (not Still_Matching) or else (Current_Char =
Lexer.Source.Buffer'Last);
+
+ if Best_Match_Length = Lexer.Source.Buffer'Length then
+ raise SAL.Programmer_Error with
+ "token larger than buffer size of" & Integer'Image
(Lexer.Source.Buffer'Length);
+ end if;
+
+ Current_Char := Current_Char + 1;
+ end loop;
+
+ if Best_Match_Length > 0 then
+ Lexer.Lexeme_Head := Lexer.Buffer_Head;
+ Lexer.Lexeme_Tail := Lexer.Buffer_Head + Best_Match_Length - 1;
+ Lexer.ID := Best_Match_ID;
+
+ if Lexer.Lexeme_Head = Lexer.Source.Buffer'Last and
+ Lexer.Source.Buffer (Lexer.Lexeme_Head) = Ada.Characters.Latin_1.EOT
+ then
+ -- matched EOF; repeat that next time
+ null;
+ else
+ Lexer.Buffer_Head := Lexer.Lexeme_Tail + 1;
+ end if;
+ return True;
+
+ elsif Current_Char = Lexer.Source.Buffer'Last then
+ Lexer.ID := Lexer.Trace.Descriptor.EOF_ID;
+ Lexer.Buffer_Head := Lexer.Buffer_Head + 1;
+ return True;
+
+ else
+ return False;
+ end if;
+
+ end Find_Best_Match;
+
+ ----------
+ -- Public subprograms
+
+ function Get
+ (Regexp : in String;
+ Case_Sensitive : in Boolean := True;
+ Report : in Boolean := True)
+ return Syntax_Item
+ is begin
+ return (WisiToken.Regexp.Compile (Regexp, Case_Sensitive), Report);
+ end Get;
+
+ 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)
+ return WisiToken.Lexer.Handle
+ is
+ New_Lexer : constant Instance_Access := new Instance (Trace,
Syntax'Last);
+ begin
+ New_Lexer.Syntax := Syntax;
+
+ return Handle (New_Lexer);
+ end New_Lexer;
+
+ overriding procedure Finalize (Object : in out Instance)
+ is begin
+ Finalize (Object.Source);
+ end Finalize;
+
+ overriding procedure Reset_With_String (Lexer : in out Instance; Input : in
String)
+ is begin
+ Finalize (Lexer);
+
+ Lexer.Source :=
+ (Label => String_Label,
+ File_Name => +"",
+ 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)
+ is begin
+ Finalize (Lexer);
+
+ Lexer.Source :=
+ (Label => String_Label,
+ File_Name => File_Name,
+ 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)
+ is
+ pragma Unreferenced (File_Name);
+ begin
+ Finalize (Lexer);
+
+ raise SAL.Not_Implemented;
+ end Reset_With_File;
+
+ overriding procedure Reset
+ (Lexer : in out Instance)
+ is begin
+ Lexer.Lexeme_Head := Lexer.Source.Buffer'First;
+ Lexer.Lexeme_Tail := Lexer.Source.Buffer'First - 1;
+ Lexer.ID := Invalid_Token_ID;
+ Lexer.Buffer_Head := Lexer.Source.Buffer'First;
+ end Reset;
+
+ overriding function Find_Next
+ (Lexer : in out Instance;
+ Token : out Base_Token)
+ return Boolean
+ is begin
+ loop
+ if not Find_Best_Match (Lexer) then
+ if Lexer.Buffer_Head > Lexer.Source.Buffer'Last then
+ raise Syntax_Error with "Unrecognized EOF";
+ else
+ raise Syntax_Error with "Unrecognized character '" &
Lexer.Source.Buffer (Lexer.Buffer_Head) & "'";
+ end if;
+ end if;
+
+ exit when Lexer.Syntax (Lexer.ID).Report;
+
+ end loop;
+
+ Token :=
+ (ID => Lexer.ID,
+ Byte_Region => (Buffer_Pos (Lexer.Lexeme_Head), Buffer_Pos
(Lexer.Lexeme_Tail)),
+ Line => Invalid_Line_Number,
+ Column => Ada.Text_IO.Count (Lexer.Lexeme_Head),
+ Char_Region => (Buffer_Pos (Lexer.Lexeme_Head), Buffer_Pos
(Lexer.Lexeme_Tail)));
+
+ return False;
+ end Find_Next;
+
+ overriding function Buffer_Text (Lexer : in Instance; Byte_Region : in
Buffer_Region) return String
+ is begin
+ return Lexer.Source.Buffer (Integer (Byte_Region.First) .. Integer
(Byte_Region.Last));
+ end Buffer_Text;
+
+end WisiToken.Lexer.Regexp;
diff --git a/wisitoken-lexer-regexp.ads b/wisitoken-lexer-regexp.ads
new file mode 100644
index 0000000..33bda9b
--- /dev/null
+++ b/wisitoken-lexer-regexp.ads
@@ -0,0 +1,102 @@
+-- Abstract:
+--
+-- WisiToken lexer using compiled regular expressions interpreted at runtime.
+--
+-- This is slower, but easier to use, than the Aflex lexer; it is
+-- 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 Stephe Leake
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Unchecked_Deallocation;
+with WisiToken.Regexp;
+package WisiToken.Lexer.Regexp is
+
+ type Syntax_Item is record
+ Regexp : WisiToken.Regexp.Regexp;
+ Report : Boolean;
+ end record;
+
+ function Get
+ (Regexp : in String;
+ Case_Sensitive : in Boolean := True;
+ Report : in Boolean := True)
+ return Syntax_Item;
+ -- Compiles Regexp with Case_Sensitive.
+
+ type Syntax is array (Token_ID range <>) of Syntax_Item;
+
+ type Instance
+ (Trace : not null access WisiToken.Trace'Class;
+ 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)
+ 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_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);
+ overriding procedure Reset (Lexer : in out Instance);
+
+ overriding procedure Discard_Rest_Of_Input (Lexer : in out Instance) is
null;
+
+ overriding function Find_Next
+ (Lexer : in out Instance;
+ Token : out Base_Token)
+ return Boolean;
+
+ overriding function Buffer_Text (Lexer : in Instance; Byte_Region : in
Buffer_Region) return String;
+
+ overriding function First (Lexer : in Instance) return Boolean is (False);
+
+ overriding function File_Name (Lexer : in Instance) return String is ("");
+
+private
+
+ type String_Access is access String;
+ procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);
+
+ type Instance
+ (Trace : not null access WisiToken.Trace'Class;
+ Last_Terminal : Token_ID)
+ is new WisiToken.Lexer.Instance (Trace => Trace) with
+ record
+ ID : Token_ID; -- last token read by find_next
+ Syntax : WisiToken.Lexer.Regexp.Syntax (Token_ID'First ..
Last_Terminal);
+ Source : Lexer.Source;
+ Buffer_Head : Integer;
+ Lexeme_Head : Integer;
+ Lexeme_Tail : Integer;
+ end record;
+
+end WisiToken.Lexer.Regexp;
diff --git a/wisitoken-lexer.adb b/wisitoken-lexer.adb
new file mode 100644
index 0000000..6d3d546
--- /dev/null
+++ b/wisitoken-lexer.adb
@@ -0,0 +1,56 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with GNAT.Strings;
+package body WisiToken.Lexer is
+
+ procedure Finalize (Object : in out Source)
+ is begin
+ case Object.Label is
+ when String_Label =>
+ if not Object.User_Buffer then
+ Ada.Strings.Unbounded.Free (Object.Buffer);
+ end if;
+
+ when File_Label =>
+ GNATCOLL.Mmap.Free (Object.Region);
+ GNATCOLL.Mmap.Close (Object.File);
+ end case;
+ end Finalize;
+
+ function Buffer (Source : in Lexer.Source) return GNATCOLL.Mmap.Str_Access
+ is
+ use GNATCOLL.Mmap;
+ begin
+ case Source.Label is
+ when String_Label =>
+ return Short.To_Str_Access (GNAT.Strings.String_Access
(Source.Buffer));
+
+ when File_Label =>
+ return Data (Source.Region);
+ end case;
+
+ end Buffer;
+
+ function File_Name (Source : in Lexer.Source) return String
+ is begin
+ return -Source.File_Name;
+ end File_Name;
+
+end WisiToken.Lexer;
diff --git a/wisitoken-lexer.ads b/wisitoken-lexer.ads
new file mode 100644
index 0000000..b854004
--- /dev/null
+++ b/wisitoken-lexer.ads
@@ -0,0 +1,161 @@
+-- Abstract :
+--
+-- An abstract lexer interface.
+--
+-- Copyright (C) 2014 - 2015, 2017, 2018 Stephe Leake
+--
+-- 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);
+
+pragma Warnings (Off, "license of withed unit ""GNATCOLL.Mmap"" may be
inconsistent");
+
+with Ada.Containers.Doubly_Linked_Lists;
+with Ada.Finalization;
+with Ada.Strings.Unbounded;
+with GNATCOLL.Mmap;
+package WisiToken.Lexer is
+
+ type Error is record
+ Char_Pos : Buffer_Pos := Invalid_Buffer_Pos;
+ -- Character at that position is not recognized as part of a token.
+
+ Recover_Token : Base_Token_Index := Invalid_Token_Index;
+ -- If the error was corrected by inserting a missing quote, the token
+ -- (in shared parser Terminals) that was returned.
+
+ Recover_Char : String (1 .. 4) := (others => ASCII.NUL);
+ -- If the error was corrected, the character (in UTF-8 encoding) that
+ -- was inserted; unused trailing bytes set to ASCII.NUL. Otherwise,
+ -- all ASCII.Nul.
+ end record;
+
+ package Error_Lists is new Ada.Containers.Doubly_Linked_Lists (Error);
+
+ type Instance (Trace : not null access WisiToken.Trace'Class)
+ is abstract new Ada.Finalization.Limited_Controlled with record
+ Errors : Error_Lists.List;
+ end record;
+
+ subtype Class is Instance'Class;
+
+ type Handle is access all Class;
+
+ procedure Reset_With_String (Lexer : in out Instance; Input : in String) 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)
+ 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.
+ --
+ -- Raises Ada.IO_Exceptions.Name_Error if File_Name cannot be opened.
+
+ procedure Reset (Lexer : in out Instance) is abstract;
+ -- Reset Lexer, read from previous source.
+
+ procedure Discard_Rest_Of_Input (Lexer : in out Instance) is abstract;
+ -- If reading input from a stream, abort reading (or force it to
+ -- complete); Find_Next will not be called before another Reset.
+
+ function Buffer_Text (Lexer : in Instance; Byte_Region : in Buffer_Region)
return String is abstract;
+ -- Return text from internal buffer, given region in byte position.
+
+ function First (Lexer : in Instance) return Boolean is abstract;
+ -- True if most recent token is first on a line.
+
+ function Find_Next
+ (Lexer : in out Instance;
+ Token : out Base_Token)
+ return Boolean is abstract;
+ -- Set Token to the next token from the input stream.
+ --
+ -- If there is a recovered error, adds an entry to Lexer.Errors (with
+ -- Recover_Token invalid). Unrecognized characters are skipped;
+ -- missing quotes are inserted at the found quote. There can be more
+ -- than one error entry for one call to Find_Next, if several
+ -- unrecognized characters are skipped. If the recovery inserted a
+ -- missing quote, it is the last entry in Errors, the returned token
+ -- is an empty string literal, and Find_Next returns True.
+ --
+ -- If there is a non-recoverable error, raises Fatal_Error with an
+ -- appropriate message.
+ --
+ -- Otherwise returns False.
+ --
+ -- Token.Char_Region, Token.Byte_Region are the character and byte
+ -- position of the start and end of token, in the internal buffer,
+ -- 1-indexed. Char_Region and Byte_Region differ when text is UTF-8
+ -- or other multi-byte encoding, and when line endings are two byte.
+ --
+ -- Token.Line is the line number in which recent token starts.
+ -- 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
+ -- indexed. If the underlying text feeder does not support the notion
+ -- of 'line', returns byte position in internal buffer.
+
+ function File_Name (Lexer : in Instance) return String is abstract;
+ -- Return input file name; empty string if there is no file.
+
+private
+
+ type Source_Labels is (String_Label, File_Label);
+
+ type Source (Label : Source_Labels := Source_Labels'First) is record
+ File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ -- Not saved in Mapped_File, may be empty for String_Label
+
+ case Label is
+ when String_Label =>
+ Buffer : Ada.Strings.Unbounded.String_Access;
+ User_Buffer : Boolean := False;
+ -- If User_Buffer is True, user provided buffer and will deallocate
+ -- it. Otherwise we must deallocate it.
+
+ 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;
+ end case;
+ end record;
+
+ procedure Finalize (Object : in out Source);
+
+ function Buffer (Source : in Lexer.Source) return GNATCOLL.Mmap.Str_Access;
+ -- The bounds on the result are not present; 'First, 'Last are not
+ -- reliable. If Source_Label is String_label, actual bounds are
+ -- Source.Buffer'First, 'Last. Otherwise, actual bounds are 1 ..
+ -- Source.Buffer_Last. Indexing is reliable.
+
+ function File_Name (Source : in Lexer.Source) return String;
+
+end WisiToken.Lexer;
diff --git a/wisitoken-parse-lr-mckenzie_recover-base.adb
b/wisitoken-parse-lr-mckenzie_recover-base.adb
new file mode 100644
index 0000000..52ddeac
--- /dev/null
+++ b/wisitoken-parse-lr-mckenzie_recover-base.adb
@@ -0,0 +1,433 @@
+-- Abstract :
+--
+-- Base utilities for McKenzie_Recover
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Task_Identification;
+with GNAT.Traceback.Symbolic;
+package body WisiToken.Parse.LR.McKenzie_Recover.Base is
+
+ function Get_Barrier
+ (Parsers : not null access Parser_Lists.List;
+ Parser_Status : in Parser_Status_Array;
+ Cost_Limit : in Natural;
+ Min_Success_Check_Count : in Natural;
+ Check_Delta_Limit : in Natural;
+ Enqueue_Limit : in Natural)
+ return Boolean
+ is
+ use all type SAL.Base_Peek_Type;
+ Done_Count : SAL.Base_Peek_Type := 0;
+ begin
+ -- Return True if all parsers are done, or if any parser has a config
+ -- available to check.
+ for P_Status of Parser_Status loop
+ case P_Status.Recover_State is
+ when Active =>
+ if P_Status.Parser_State.Recover.Check_Count - Check_Delta_Limit
>= Min_Success_Check_Count then
+ -- fail; another parser succeeded, this one taking too long.
+ Done_Count := Done_Count + 1;
+
+ elsif P_Status.Parser_State.Recover.Enqueue_Count >= Enqueue_Limit
then
+ -- fail
+ Done_Count := Done_Count + 1;
+
+ elsif P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
+ if P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
Cost_Limit then
+ return True;
+ else
+ if P_Status.Active_Workers = 0 then
+ -- fail; remaining configs exceed cost limit
+ Done_Count := Done_Count + 1;
+ end if;
+ end if;
+
+ else
+ if P_Status.Active_Workers = 0 then
+ -- fail; no configs left to check (rarely happens with real
+ -- languages).
+ Done_Count := Done_Count + 1;
+ end if;
+ end if;
+
+ when Ready =>
+ -- We don't check Enqueue_Limit here; there will only be a few
more
+ -- to find all the same-cost solutions.
+
+ if P_Status.Parser_State.Recover.Config_Heap.Count > 0 and then
+ P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
P_Status.Parser_State.Recover.Results.Min_Key
+ then
+ -- Still more to check.
+ return True;
+
+ elsif P_Status.Active_Workers = 0 then
+ Done_Count := Done_Count + 1;
+ end if;
+
+ when Success | Fail =>
+ Done_Count := Done_Count + 1;
+ end case;
+ end loop;
+
+ return Done_Count = Parsers.Count;
+ end Get_Barrier;
+
+ protected body Supervisor is
+
+ procedure Initialize
+ (Parsers : not null access Parser_Lists.List;
+ Terminals : not null access constant Base_Token_Arrays.Vector)
+ is
+ use all type SAL.Base_Peek_Type;
+ Index : SAL.Peek_Type := 1;
+ begin
+ Supervisor.Parsers := Parsers;
+ Supervisor.Terminals := Terminals;
+ All_Parsers_Done := False;
+ Success_Counter := 0;
+ Min_Success_Check_Count := Natural'Last;
+ Fatal_Called := False;
+ Result := Recover_Status'First;
+ Error_ID := Ada.Exceptions.Null_Id;
+
+ for I in Parsers.Iterate loop
+ if Parsers.Reference (I).Recover_Insert_Delete.Length > 0 then
+ -- Previous error recovery resume not finished; this is
supposed to
+ -- be checked in Parser.
+ raise SAL.Programmer_Error;
+ end if;
+
+ Parser_Status (Index) :=
+ (Recover_State => Active,
+ Parser_State => Parser_Lists.Persistent_State_Ref (I),
+ Fail_Mode => Success,
+ Active_Workers => 0);
+
+ declare
+ Data : McKenzie_Data renames Parsers.Reference (I).Recover;
+ begin
+ Data.Config_Heap.Clear;
+ Data.Results.Clear;
+ Data.Enqueue_Count := 0;
+ Data.Check_Count := 0;
+ Data.Success := False;
+ end;
+
+ Index := Index + 1;
+ end loop;
+ end Initialize;
+
+ entry Get
+ (Parser_Index : out SAL.Base_Peek_Type;
+ Config : out Configuration;
+ Status : out Config_Status)
+ when (Fatal_Called or All_Parsers_Done) or else
+ Get_Barrier (Parsers, Parser_Status, Cost_Limit,
Min_Success_Check_Count, Check_Delta_Limit, Enqueue_Limit)
+ is
+ use all type SAL.Base_Peek_Type;
+ Done_Count : SAL.Base_Peek_Type := 0;
+ Min_Cost : Integer := Integer'Last;
+ Min_Cost_Index : SAL.Base_Peek_Type;
+
+ procedure Set_Outputs (I : in SAL.Peek_Type)
+ is begin
+ Parser_Index := I;
+ Config := Parser_Status
(I).Parser_State.Recover.Config_Heap.Remove;
+ Status := Valid;
+
+ Parser_Status (I).Parser_State.Recover.Check_Count :=
+ Parser_Status (I).Parser_State.Recover.Check_Count + 1;
+
+ Parser_Status (I).Active_Workers := Parser_Status
(I).Active_Workers + 1;
+ end Set_Outputs;
+
+ procedure Set_All_Done
+ is begin
+ Parser_Index := SAL.Base_Peek_Type'First;
+ Config := (others => <>);
+ Status := All_Done;
+ end Set_All_Done;
+
+ begin
+ if Fatal_Called or All_Parsers_Done then
+ Set_All_Done;
+ return;
+ end if;
+
+ -- Same logic as in Get_Barrier, but different actions.
+ for I in Parser_Status'Range loop
+ declare
+ P_Status : Base.Parser_Status renames Parser_Status (I);
+ begin
+ case P_Status.Recover_State is
+ when Active =>
+ if P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
+ if P_Status.Parser_State.Recover.Check_Count -
Check_Delta_Limit >= Min_Success_Check_Count then
+ if Trace_McKenzie > Outline then
+ Put_Line (Trace.all, P_Status.Parser_State.Label,
"fail; check delta (limit" &
+ Integer'Image (Min_Success_Check_Count
+ Check_Delta_Limit) & ")");
+ end if;
+ P_Status.Recover_State := Fail;
+ P_Status.Fail_Mode := Fail_Check_Delta;
+
+ Done_Count := Done_Count + 1;
+
+ elsif P_Status.Parser_State.Recover.Enqueue_Count >=
Enqueue_Limit then
+ if Trace_McKenzie > Outline then
+ Put_Line (Trace.all, P_Status.Parser_State.Label,
"fail; enqueue limit (" &
+ Integer'Image (Enqueue_Limit) & ")");
+ end if;
+ P_Status.Recover_State := Fail;
+ P_Status.Fail_Mode := Fail_Enqueue_Limit;
+
+ Done_Count := Done_Count + 1;
+
+ elsif P_Status.Parser_State.Recover.Config_Heap.Min_Key
<= Cost_Limit then
+ if P_Status.Parser_State.Recover.Config_Heap.Min_Key <
Min_Cost then
+ Min_Cost :=
P_Status.Parser_State.Recover.Config_Heap.Min_Key;
+ Min_Cost_Index := I;
+ end if;
+
+ else
+ if P_Status.Active_Workers = 0 then
+ if Trace_McKenzie > Outline then
+ Put_Line (Trace.all,
P_Status.Parser_State.Label, "fail; cost");
+ end if;
+ P_Status.Recover_State := Fail;
+ P_Status.Fail_Mode := Fail_Cost;
+
+ Done_Count := Done_Count + 1;
+ end if;
+ end if;
+ else
+ if P_Status.Active_Workers = 0 then
+ -- No configs left to check (rarely happens with real
languages).
+ if Trace_McKenzie > Outline then
+ Put_Line (Trace.all, P_Status.Parser_State.Label,
"fail; no configs left");
+ end if;
+ P_Status.Recover_State := Fail;
+ P_Status.Fail_Mode := Fail_No_Configs_Left;
+
+ Done_Count := Done_Count + 1;
+ end if;
+ end if;
+
+ when Ready =>
+ if P_Status.Parser_State.Recover.Enqueue_Count >=
Enqueue_Limit then
+ if Trace_McKenzie > Outline then
+ Put_Line (Trace.all, P_Status.Parser_State.Label,
"fail; enqueue limit (" &
+ Integer'Image (Enqueue_Limit) & ")");
+ end if;
+ P_Status.Recover_State := Fail;
+ P_Status.Fail_Mode := Fail_Enqueue_Limit;
+
+ Done_Count := Done_Count + 1;
+
+ elsif P_Status.Parser_State.Recover.Config_Heap.Count > 0
and then
+ P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
P_Status.Parser_State.Recover.Results.Min_Key
+ then
+ -- Still more to check.
+ Set_Outputs (I);
+ return;
+
+ elsif P_Status.Active_Workers = 0 then
+ P_Status.Recover_State := Success;
+ Done_Count := Done_Count + 1;
+ end if;
+
+ when Success | Fail =>
+ Done_Count := Done_Count + 1;
+ end case;
+ end;
+ end loop;
+
+ if Min_Cost /= Integer'Last then
+ Set_Outputs (Min_Cost_Index);
+
+ elsif Done_Count = Parsers.Count then
+ if Trace_McKenzie > Extra then
+ Trace.Put_Line ("Supervisor: done, " & (if Success_Counter > 0
then "succeed" else "fail"));
+ end if;
+
+ Set_All_Done;
+ All_Parsers_Done := True;
+ else
+ raise SAL.Programmer_Error with "Get_Barrier and Get logic do not
match";
+ end if;
+ end Get;
+
+ procedure Success
+ (Parser_Index : in SAL.Peek_Type;
+ Config : in Configuration;
+ Configs : in out Config_Heaps.Heap_Type)
+ is
+ use all type SAL.Base_Peek_Type;
+ Data : McKenzie_Data renames Parser_Status
(Parser_Index).Parser_State.Recover;
+ begin
+ Put (Parser_Index, Configs); -- Decrements Active_Worker_Count.
+
+ if Trace_McKenzie > Detail then
+ Put
+ ("succeed: enqueue" & Integer'Image (Data.Enqueue_Count) & ",
check " & Integer'Image (Data.Check_Count),
+ Trace.all, Parser_Status (Parser_Index).Parser_State.Label,
Terminals.all, Config);
+ end if;
+
+ if Force_Full_Explore then
+ return;
+ end if;
+
+ Success_Counter := Success_Counter + 1;
+ Result := Success;
+
+ Data.Success := True;
+
+ if Data.Check_Count < Min_Success_Check_Count then
+ Min_Success_Check_Count := Data.Check_Count;
+ end if;
+
+ if Force_High_Cost_Solutions then
+ Data.Results.Add (Config);
+ if Data.Results.Count > 3 then
+ Parser_Status (Parser_Index).Recover_State := Ready;
+ end if;
+ else
+ if Data.Results.Count = 0 then
+ Data.Results.Add (Config);
+
+ Parser_Status (Parser_Index).Recover_State := Ready;
+
+ elsif Config.Cost < Data.Results.Min_Key then
+ -- delete higher cost configs from Results
+ loop
+ Data.Results.Drop;
+ exit when Data.Results.Count = 0 or else
+ Config.Cost >= Data.Results.Min_Key;
+ end loop;
+
+ Data.Results.Add (Config);
+
+ elsif Config.Cost = Data.Results.Min_Key then
+ Data.Results.Add (Config);
+
+ else
+ -- Config.Cost > Results.Min_Key
+ null;
+ end if;
+ end if;
+ end Success;
+
+ procedure Put (Parser_Index : in SAL.Peek_Type; Configs : in out
Config_Heaps.Heap_Type)
+ is
+ use all type SAL.Base_Peek_Type;
+ Configs_Count : constant SAL.Base_Peek_Type := Configs.Count; --
Before it is emptied, for Trace.
+
+ P_Status : Base.Parser_Status renames Parser_Status (Parser_Index);
+ Data : McKenzie_Data renames P_Status.Parser_State.Recover;
+ begin
+ P_Status.Active_Workers := P_Status.Active_Workers - 1;
+
+ loop
+ exit when Configs.Count = 0;
+
+ -- [1] has a check for duplicate configs here; that only happens
with
+ -- higher costs, which take too long for our application.
+ Data.Config_Heap.Add (Configs.Remove);
+ Data.Enqueue_Count := Data.Enqueue_Count + 1;
+ end loop;
+
+ if Trace_McKenzie > Detail then
+ Put_Line
+ (Trace.all, P_Status.Parser_State.Label,
+ "enqueue:" & SAL.Base_Peek_Type'Image (Configs_Count) &
+ "/" & SAL.Base_Peek_Type'Image (Data.Config_Heap.Count) &
+ "/" & Trimmed_Image (Data.Enqueue_Count) &
+ "/" & Trimmed_Image (Data.Check_Count) &
+ ", min cost:" &
+ (if Data.Config_Heap.Count > 0
+ then Integer'Image (Data.Config_Heap.Min_Key)
+ else " ? ") &
+ ", active workers:" & Integer'Image
(P_Status.Active_Workers));
+ end if;
+ end Put;
+
+ function Recover_Result return Recover_Status
+ is
+ Temp : Recover_Status := Result;
+ begin
+ if Result = Success then
+ return Success;
+ else
+ for S of Parser_Status loop
+ Temp := Recover_Status'Max (Result, S.Fail_Mode);
+ end loop;
+ return Temp;
+ end if;
+ end Recover_Result;
+
+ procedure Fatal (E : in Ada.Exceptions.Exception_Occurrence)
+ is
+ use Ada.Exceptions;
+ Task_ID : constant String := Ada.Task_Identification.Image
(Ada.Task_Identification.Current_Task);
+ begin
+ if Trace_McKenzie > Outline then
+ Trace.Put_Line (Task_ID & " Supervisor: Error");
+ end if;
+ Fatal_Called := True;
+ Error_ID := Exception_Identity (E);
+ Error_Message := +Exception_Message (E);
+ if Debug_Mode then
+ Trace.Put_Line (Exception_Name (E) & ": " & Exception_Message (E));
+ Trace.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
+ end if;
+ end Fatal;
+
+ entry Done (Error_ID : out Ada.Exceptions.Exception_Id; Message : out
Ada.Strings.Unbounded.Unbounded_String)
+ when All_Parsers_Done or Fatal_Called
+ is begin
+ Error_ID := Supervisor.Error_ID;
+ Message := Error_Message;
+ if Trace_McKenzie > Detail then
+ Trace.New_Line;
+ Trace.Put_Line ("Supervisor: Done");
+ end if;
+ end Done;
+
+ function Parser_State (Parser_Index : in SAL.Peek_Type) return
Parser_Lists.Constant_Reference_Type
+ is begin
+ return (Element => Parser_Status (Parser_Index).Parser_State);
+ end Parser_State;
+
+ function Label (Parser_Index : in SAL.Peek_Type) return Natural
+ is begin
+ return Parser_Status (Parser_Index).Parser_State.Label;
+ end Label;
+
+ end Supervisor;
+
+ procedure Put
+ (Message : in String;
+ Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Config : in Configuration;
+ Task_ID : in Boolean := True)
+ is begin
+ Put (Message, Super.Trace.all, Super.Parser_State (Parser_Index).Label,
+ Shared.Terminals.all, Config, Task_ID);
+ end Put;
+
+end WisiToken.Parse.LR.McKenzie_Recover.Base;
diff --git a/wisitoken-parse-lr-mckenzie_recover-base.ads
b/wisitoken-parse-lr-mckenzie_recover-base.ads
new file mode 100644
index 0000000..1d292d6
--- /dev/null
+++ b/wisitoken-parse-lr-mckenzie_recover-base.ads
@@ -0,0 +1,180 @@
+-- Abstract :
+--
+-- Base utilities for McKenzie_Recover
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Exceptions;
+with WisiToken.Parse.LR.Parser_Lists;
+private package WisiToken.Parse.LR.McKenzie_Recover.Base is
+
+ ----------
+ -- Protected object specs.
+ --
+ -- Tasking design requirements:
+ --
+ -- 1) For each parse_state, find all solutions of the same lowest
+ -- cost.
+ --
+ -- 2) use as many CPUs as available as fully as possible.
+ --
+ -- 3) avoid
+ -- a) busy waits
+ -- b) race conditions
+ -- c) deadlocks.
+ --
+ -- For 2), we use worker_tasks to perform the check computations on
+ -- each configuration. We allocate N - 1 worker_tasks, where N is the
+ -- number of available CPUs, saving one CPU for Supervisor and the
+ -- foreground IDE.
+ --
+ -- For 1), worker_tasks always get the lowest cost configuration
+ -- available. However, some active worker_task may have a lower cost
+ -- configuration that it has not yet delivered to Supervisor.
+ -- Therefore we always wait until all current active worker_tasks
+ -- deliver their results before deciding we are done.
+ --
+ -- For 3a) we have one Supervisor protected object that controls
+ -- access to all Parse_States and configurations, and a Shared object
+ -- that provides appropriate access to the Shared_Parser components.
+ --
+ -- It is tempting to try to reduce contention for Supervisor by
+ -- having one protected object per parser, but that requires the
+ -- worker tasks to busy loop checking all the parsers.
+ --
+ -- There is still a race condition on Success; the solutions can be
+ -- delivered in different orders on different runs. This matters
+ -- because each solution results in a successful parse, possibly with
+ -- different actions (different indentation computed, for example).
+ -- Which solution finally succeeds depends on which are terminated
+ -- due to identical parser stacks, which in turn depends on the order
+ -- they were delivered. See ada-mode/tests/ada_mode-interactive_2.adb
+ -- for an example.
+ --
+ -- There is also a race condition on how many failed or higher cost
+ -- configurations are checked, before the final solutions are found.
+
+ type Config_Status is (Valid, All_Done);
+ type Recover_State is (Active, Ready, Success, Fail);
+
+ type Parser_Status is record
+ Recover_State : Base.Recover_State;
+ Parser_State : Parser_Lists.State_Access;
+ Fail_Mode : Recover_Status;
+
+ Active_Workers : Natural;
+ -- Count of Worker_Tasks that have done Get but not Put or Success.
+ end record;
+
+ type Parser_Status_Array is array (SAL.Peek_Type range <>) of Parser_Status;
+
+ protected type Supervisor
+ (Trace : not null access WisiToken.Trace'Class;
+ Cost_Limit : Natural;
+ Check_Delta_Limit : Natural;
+ Enqueue_Limit : Natural;
+ Parser_Count : SAL.Peek_Type)
+ is
+ -- There is only one object of this type, declared in Recover.
+
+ procedure Initialize
+ (Parsers : not null access Parser_Lists.List;
+ Terminals : not null access constant Base_Token_Arrays.Vector);
+
+ entry Get
+ (Parser_Index : out SAL.Base_Peek_Type;
+ Config : out Configuration;
+ Status : out Config_Status);
+ -- Get a new configuration to check. Available when there is a
+ -- configuration to get, or when all configs have been checked.
+ --
+ -- Increments active worker count.
+ --
+ -- Status values mean:
+ --
+ -- Valid - Parser_Index, Config are valid, should be checked.
+ --
+ -- All_Done - Parser_Index, Config are not valid.
+
+ procedure Success
+ (Parser_Index : in SAL.Peek_Type;
+ Config : in Configuration;
+ Configs : in out Config_Heaps.Heap_Type);
+ -- Report that Configuration succeeds for Parser_Label, and enqueue
+ -- Configs.
+ --
+ -- Decrements active worker count.
+
+ procedure Put (Parser_Index : in SAL.Peek_Type; Configs : in out
Config_Heaps.Heap_Type);
+ -- Add Configs to the McKenzie_Data Config_Heap for Parser_Label
+ --
+ -- Decrements active worker count.
+
+ function Recover_Result return Recover_Status;
+
+ procedure Fatal (E : in Ada.Exceptions.Exception_Occurrence);
+ -- Report a fatal error; abort all processing, make Done
+ -- available.
+
+ entry Done (Error_ID : out Ada.Exceptions.Exception_Id; Message : out
Ada.Strings.Unbounded.Unbounded_String);
+ -- Available when all parsers have failed or succeeded, or an error
+ -- occured.
+ --
+ -- If Error_ID is not Null_Id, an error occured.
+
+ function Parser_State (Parser_Index : in SAL.Peek_Type) return
Parser_Lists.Constant_Reference_Type;
+ function Label (Parser_Index : in SAL.Peek_Type) return Natural;
+
+ private
+ Parsers : access Parser_Lists.List;
+ Terminals : access constant Base_Token_Arrays.Vector;
+
+ All_Parsers_Done : Boolean;
+ Success_Counter : Natural;
+ Min_Success_Check_Count : Natural;
+ Fatal_Called : Boolean;
+ Result : Recover_Status;
+ Error_ID : Ada.Exceptions.Exception_Id;
+ Error_Message : Ada.Strings.Unbounded.Unbounded_String;
+ Parser_Status : Parser_Status_Array (1 .. Parser_Count);
+ end Supervisor;
+
+ type Shared
+ (Trace : not null access
WisiToken.Trace'Class;
+ Lexer : not null access constant
WisiToken.Lexer.Instance'Class;
+ Table : not null access constant
Parse_Table;
+ Language_Fixes :
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Use_Minimal_Complete_Actions :
WisiToken.Parse.LR.Parser.Language_Use_Minimal_Complete_Actions_Access;
+ Language_String_ID_Set :
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+ Terminals : not null access constant
Base_Token_Arrays.Vector;
+ Line_Begin_Token : not null access constant
Line_Begin_Token_Vectors.Vector)
+ is null record;
+ -- There is only one object of this type, declared in Recover. It
+ -- provides appropriate access to Shared_Parser components.
+ --
+ -- Since all the accesible objects are read-only (except Trace),
+ -- there are no protected operations, and this is not a protected
+ -- type.
+
+ procedure Put
+ (Message : in String;
+ Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Config : in Configuration;
+ Task_ID : in Boolean := True);
+
+end WisiToken.Parse.LR.McKenzie_Recover.Base;
diff --git a/wisitoken-parse-lr-mckenzie_recover-explore.adb
b/wisitoken-parse-lr-mckenzie_recover-explore.adb
new file mode 100644
index 0000000..15910f7
--- /dev/null
+++ b/wisitoken-parse-lr-mckenzie_recover-explore.adb
@@ -0,0 +1,1301 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Parse.LR.McKenzie_Recover.Parse;
+package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
+
+ procedure Do_Shift
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type;
+ Config : in out Configuration;
+ State : in State_Index;
+ ID : in Token_ID;
+ Cost_Delta : in Integer)
+ 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
+ begin
+ if Config.Current_Ops = No_Insert_Delete then
+ Config.Ops.Append (Op);
+ else
+ Config.Ops.Insert (Op, Before => Config.Current_Ops);
+ Config.Current_Ops := Config.Current_Ops + 1;
+ end if;
+ exception
+ when SAL.Container_Full =>
+ if Trace_McKenzie > Outline then
+ Put_Line (Super.Trace.all, Super.Label (Parser_Index), "config.ops
is full");
+ end if;
+ raise Bad_Config;
+ end;
+
+ if Cost_Delta = 0 then
+ Config.Cost := Config.Cost + McKenzie_Param.Insert (ID);
+ else
+ -- Cost_Delta /= 0 comes from Try_Insert_Terminal when
+ -- Minimal_Complete_Actions is useful. That doesn't mean it is better
+ -- than any other solution, so don't let cost be 0.
+ Config.Cost := Integer'Max (1, Config.Cost + McKenzie_Param.Insert
(ID) + Cost_Delta);
+ end if;
+
+ Config.Error_Token.ID := Invalid_Token_ID;
+
+ Config.Stack.Push ((State, Syntax_Trees.Invalid_Node_Index, (ID, Virtual
=> True, others => <>)));
+ if Trace_McKenzie > Detail then
+ Base.Put ("insert " & Image (ID, Super.Trace.Descriptor.all), Super,
Shared, Parser_Index, Config);
+ end if;
+
+ Local_Config_Heap.Add (Config);
+ end Do_Shift;
+
+ function Do_Reduce_1
+ (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
+ 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;
+ begin
+ Config.Check_Status := Parse.Reduce_Stack (Shared, Config.Stack, Action,
Nonterm, Default_Virtual => True);
+ case Config.Check_Status.Label is
+ when Ok =>
+ null;
+
+ when Semantic_Checks.Error =>
+ Config.Error_Token := Nonterm;
+ Config.Check_Token_Count := Action.Token_Count;
+
+ if 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;
+
+ -- Finish the reduce; ignore the check fail.
+ Config.Stack.Pop (SAL.Base_Peek_Type (Config.Check_Token_Count));
+ Config.Error_Token.ID := Invalid_Token_ID;
+ Config.Check_Status := (Label => Ok);
+ end case;
+
+ if Config.Stack.Depth = 0 or else Config.Stack (1).State = Unknown_State
then
+ raise Bad_Config;
+ end if;
+
+ New_State := Goto_For (Table, Config.Stack (1).State,
Action.Production.LHS);
+
+ if New_State = Unknown_State then
+ raise Bad_Config;
+ end if;
+
+ Config.Stack.Push ((New_State, Syntax_Trees.Invalid_Node_Index,
Nonterm));
+ return Continue;
+ end Do_Reduce_1;
+
+ procedure Do_Reduce_2
+ (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)
+ is
+ -- Perform reduce actions until shift Inserted_Token; 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;
+ 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
+ New_Config : Configuration := Config;
+ Action : Parse_Action_Rec renames Next_Action.Next.Item;
+ begin
+ case Action.Verb is
+ when Shift =>
+ Do_Shift
+ (Super, Shared, Parser_Index, Local_Config_Heap, New_Config,
Action.State, Inserted_ID, Cost_Delta);
+
+ 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;
+
+ when Accept_It =>
+ raise SAL.Programmer_Error with "found test case for Do_Reduce
Accept_It conflict";
+
+ when Error =>
+ null;
+ end case;
+ end;
+
+ -- There can be only one conflict.
+ end if;
+
+ case Next_Action.Item.Verb is
+ when Shift =>
+ Do_Shift
+ (Super, Shared, Parser_Index, Local_Config_Heap, Config,
Next_Action.Item.State, Inserted_ID, Cost_Delta);
+
+ 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;
+
+ when Accept_It =>
+ raise SAL.Programmer_Error with "found test case for Do_Reduce
Accept_It";
+
+ when Error =>
+ null;
+ end case;
+
+ exception
+ when Bad_Config =>
+ null;
+ end Do_Reduce_2;
+
+ function Fast_Forward
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type;
+ Config : in out Configuration)
+ return Non_Success_Status
+ is
+ -- Apply the ops in Config; they were inserted by some fix.
+ -- Return Abandon if Config should be abandoned, otherwise Continue.
+ -- Leaves Config.Error_Token, Config.Check_Status set.
+ --
+ -- If there are conflicts, all are parsed; if more than one succeed,
+ -- all are enqueued in Local_Config_Heap, and this returns Abandon.
+
+ use all type SAL.Base_Peek_Type;
+ use all type Ada.Containers.Count_Type;
+
+ Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ begin
+ if Parse.Parse
+ (Super, Shared, Parser_Index, Parse_Items, Config,
+ Shared_Token_Goal => Invalid_Token_Index,
+ All_Conflicts => True,
+ Trace_Prefix => "fast_forward")
+ then
+ -- At least one config parsed without error, so continue with them.
+ if Parse_Items.Length = 1 then
+ Config := Parse_Items (1).Config;
+ Config.Current_Ops := No_Insert_Delete;
+ Config.Ops.Append ((Fast_Forward, Config.Current_Shared_Token));
+ return Continue;
+ else
+ -- Enqueue all passing configs, abandon current.
+ for Item of Parse_Items loop
+ if Item.Parsed and Item.Config.Error_Token.ID =
Invalid_Token_ID then
+ Item.Config.Ops.Append ((Fast_Forward,
Item.Config.Current_Shared_Token));
+ Config.Current_Ops := No_Insert_Delete;
+ Local_Config_Heap.Add (Item.Config);
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("fast forward conflict", Super, Shared,
Parser_Index, Item.Config);
+ end if;
+ end if;
+ end loop;
+ return Abandon;
+ end if;
+
+ else
+ -- No parse item parsed without error. This indicates that Config.Ops
+ -- (enqueued by language_fixes) did not fix all the problems; see
+ -- test_mckenzie_recover Two_Missing_Ends. If it made progress we try
+ -- more fixes.
+ for Item of Parse_Items loop
+ declare
+ Parsed_Config : Configuration renames Item.Config;
+ Remaining : SAL.Base_Peek_Type;
+ begin
+ if Parsed_Config.Current_Insert_Delete = No_Insert_Delete then
+ -- Insert_Delete contains only Deletes, and the next token
caused an
+ -- error.
+ Parsed_Config.Ops.Append ((Fast_Forward,
Config.Current_Shared_Token));
+ Local_Config_Heap.Add (Parsed_Config);
+ if Trace_McKenzie > Detail then
+ Base.Put ("fast forward failure", Super, Shared,
Parser_Index, Item.Config);
+ end if;
+
+ elsif Parsed_Config.Current_Insert_Delete = 1 then
+ -- No progress made; abandon config
+ null;
+
+ else
+ -- Find fixes at the failure point. We don't reset
+ -- Config.Current_Insert_Delete here, to allow skipping
Check.
+ --
+ -- If the unparsed ops are at Config.Current_Shared_Token,
then new
+ -- ops applied in Process_One below must be inserted in
Config.Ops
+ -- before the unparsed ops, so the final order applied to
the full
+ -- parser is correct.
+ if Parsed_Config.Insert_Delete
(Parsed_Config.Current_Insert_Delete).Token_Index =
+ Parsed_Config.Current_Shared_Token
+ then
+ Parsed_Config.Current_Ops := Parsed_Config.Ops.Last_Index;
+ Remaining := Parsed_Config.Insert_Delete.Last_Index -
Parsed_Config.Current_Insert_Delete;
+ loop
+ exit when Remaining = 0;
+ if Parsed_Config.Ops (Parsed_Config.Current_Ops).Op in
Insert_Delete_Op_Label then
+ Remaining := Remaining - 1;
+ end if;
+ Parsed_Config.Current_Ops := Parsed_Config.Current_Ops
- 1;
+ if Parsed_Config.Current_Ops <
Parsed_Config.Ops.First_Index then
+ if Trace_McKenzie > Outline then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
+ "Insert_Delete is out of sync with Ops");
+ end if;
+ raise Bad_Config;
+ end if;
+ end loop;
+ end if;
+
+ if Parsed_Config.Current_Insert_Delete > 1 then
+ if Parsed_Config.Current_Ops = No_Insert_Delete then
+ Parsed_Config.Ops.Append ((Fast_Forward,
Config.Current_Shared_Token));
+ else
+ Parsed_Config.Ops.Insert
+ ((Fast_Forward, Config.Current_Shared_Token), Before
=> Parsed_Config.Current_Ops);
+ Parsed_Config.Current_Ops := Parsed_Config.Current_Ops
+ 1;
+ end if;
+ end if;
+ Local_Config_Heap.Add (Parsed_Config);
+ if Trace_McKenzie > Detail then
+ Base.Put ("fast forward failure", Super, Shared,
Parser_Index, Item.Config);
+ end if;
+ end if;
+ end;
+ end loop;
+ return Abandon;
+ end if;
+ exception
+ when SAL.Container_Full | Bad_Config =>
+ return Abandon;
+ end Fast_Forward;
+
+ function Check
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ return Check_Status
+ is
+ use all type Ada.Containers.Count_Type;
+ use all type Semantic_Checks.Check_Status_Label;
+ use all type Parser.Language_Fixes_Access;
+
+ Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ begin
+ if Parse.Parse
+ (Super, Shared, Parser_Index, Parse_Items, Config,
Config.Resume_Token_Goal,
+ All_Conflicts => False,
+ Trace_Prefix => "check")
+ then
+ Config.Error_Token.ID := Invalid_Token_ID;
+ return Success;
+ end if;
+
+ -- All Parse_Items failed; enqueue them so Language_Fixes can try to
fix them.
+ declare
+ Parse_Error_Found : Boolean := False;
+ begin
+ for Item of Parse_Items loop
+
+ if Item.Config.Error_Token.ID /= Invalid_Token_ID and
Item.Config.Check_Status.Label = Ok then
+ Parse_Error_Found := True;
+
+ if Item.Shift_Count = 0 or
+ ((Item.Config.Ops.Length > 0 and then
+ Item.Config.Ops (Item.Config.Ops.Last_Index).Op in
Undo_Reduce | Push_Back) and
+ Item.Config.Current_Shared_Token =
Config.Current_Shared_Token)
+ then
+ -- (Item.config.ops is empty on the very first Check). This
is the
+ -- same error Config originally found; report it in Config,
so
+ -- Use_Minimal_Complete_Actions can see it.
+ Config.Error_Token := Item.Config.Error_Token;
+ Config.Check_Status := (Label => Ok);
+ end if;
+ end if;
+
+ if Item.Shift_Count > 0 and then
+ (Item.Config.Check_Status.Label /= Ok or
+ Item.Config.Error_Token.ID /= Invalid_Token_ID)
+ then
+ -- Some progress was made; let Language_Fixes try to fix the
new
+ -- error.
+ --
+ -- This is abandoning the original location of the error,
which may
+ -- not be entirely fixed. So we increase the cost. See
+ -- test_mckenzie_recover Loop_Bounds.
+ Item.Config.Cost := Item.Config.Cost + 1;
+ begin
+ if Item.Config.Ops (Item.Config.Ops.Last_Index).Op =
Fast_Forward then
+ Item.Config.Ops
(Item.Config.Ops.Last_Index).FF_Token_Index :=
+ Item.Config.Current_Shared_Token;
+ else
+ Item.Config.Ops.Append ((Fast_Forward,
Item.Config.Current_Shared_Token));
+ end if;
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end;
+ Local_Config_Heap.Add (Item.Config);
+ if Trace_McKenzie > Detail then
+ Base.Put ("for Language_Fixes ", Super, Shared,
Parser_Index, Item.Config);
+ end if;
+ end if;
+ end loop;
+
+ if Parse_Error_Found then
+ return Continue;
+ else
+ -- Failed due to Semantic_Check
+ if Shared.Language_Fixes = null then
+ -- Only fix is to ignore the error
+ return Continue;
+ else
+ -- Assume Language_Fixes handles this, not Explore.
+ return Abandon;
+ end if;
+ end if;
+ end;
+ exception
+ when Bad_Config =>
+ return Abandon;
+ end Check;
+
+ procedure Try_Push_Back
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+ McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
+
+ Token : constant Recover_Token := Config.Stack (1).Token;
+ begin
+ -- Try pushing back the stack top, to allow insert and other
+ -- operations at that point.
+ --
+ -- Since we are not actually changing the source text, it is tempting
+ -- to give this operation zero cost. But then we keep doing push_back
+ -- forever, making no progress. So we give it a cost.
+
+ if not Token.Virtual then
+ -- If Virtual, this is from earlier in this recover session; no point
+ -- in trying to redo it.
+
+ declare
+ New_Config : Configuration := Config;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ New_Config.Stack.Pop;
+
+ if Token.Min_Terminal_Index = Invalid_Token_Index then
+ -- Token is empty; Config.current_shared_token does not
change, no
+ -- cost increase.
+ New_Config.Ops.Append ((Push_Back, Token.ID,
New_Config.Current_Shared_Token));
+ else
+ New_Config.Cost := New_Config.Cost + McKenzie_Param.Push_Back
(Token.ID);
+ New_Config.Ops.Append ((Push_Back, Token.ID,
Token.Min_Terminal_Index));
+ New_Config.Current_Shared_Token := Token.Min_Terminal_Index;
+ end if;
+
+ Local_Config_Heap.Add (New_Config);
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("push_back " & Image (Token.ID,
Trace.Descriptor.all), Super, Shared,
+ Parser_Index, New_Config);
+ end if;
+ end;
+ end if;
+ exception
+ when SAL.Container_Full =>
+ if Trace_McKenzie > Outline then
+ Put_Line (Super.Trace.all, Super.Label (Parser_Index), "config.ops is
full");
+ end if;
+ end Try_Push_Back;
+
+ procedure Insert_From_Action_List
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ use all type Ada.Containers.Count_Type;
+
+ Table : Parse_Table renames Shared.Table.all;
+ EOF_ID : Token_ID renames Super.Trace.Descriptor.EOF_ID;
+
+ -- Find terminal insertions from the current state's action_list to try.
+ --
+ -- We perform any needed reductions and one shift, so the config is
+ -- in a consistent state, and enqueue the result. If there are any
+ -- conflicts or semantic check fails encountered, they create other
+ -- configs to enqueue.
+
+ I : Action_List_Iterator := First (Table.States (Config.Stack
(1).State));
+
+ Cached_Config : Configuration;
+ Cached_Action : Reduce_Action_Rec;
+ 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.
+ begin
+ loop
+ exit when I.Is_Done;
+
+ declare
+ ID : constant Token_ID := I.Symbol;
+ Action : Parse_Action_Rec renames I.Action;
+ begin
+ if ID /= EOF_ID and then -- can't insert eof
+ ID /= Invalid_Token_ID and then -- invalid when Verb = Error
+ (Config.Ops.Length = 0 or else -- don't insert an id we just
pushed back; we know that failed.
+ Config.Ops (Config.Ops.Last_Index) /= (Push_Back, ID,
Config.Current_Shared_Token))
+ then
+ case Action.Verb is
+ when Shift =>
+ declare
+ New_Config : Configuration := Config;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ Do_Shift
+ (Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Action.State, ID, Cost_Delta => 0);
+ end;
+
+ when Reduce =>
+ if not Equal (Action, Cached_Action) then
+ declare
+ New_Config : Configuration := Config;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ Cached_Status := Do_Reduce_1
+ (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;
+ 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;
+ end if;
+
+ when Accept_It =>
+ raise SAL.Programmer_Error with "found test case for
Process_One Accept_It";
+
+ when Error =>
+ null;
+ end case;
+ end if;
+ end;
+ I.Next;
+ end loop;
+ end Insert_From_Action_List;
+
+ procedure 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)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ Table : Parse_Table renames Shared.Table.all;
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+
+ 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;
+
+ 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;
+
+ begin
+ Work.Put ((Orig_Config, Table.States
(Orig_Config.Stack.Peek.State).Minimal_Complete_Actions));
+ loop
+ exit when Work.Length = 0;
+ declare
+ Item : constant Work_Type := Work.Get;
+ 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);
+
+ 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;
+
+ 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;
+
+ Temp_Actions := Reduce_Only
+ (Table.States
(New_Config.Stack.Peek.State).Minimal_Complete_Actions);
+
+ exit when Temp_Actions.Length = 0;
+
+ Reduce_Action := To_Reduce_Action
(Temp_Actions.Pop);
+
+ 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;
+
+ Insert_Minimal_Complete_Actions (Super, Shared,
Parser_Index, New_Config, Local_Config_Heap);
+
+ <<Abandon_Reduce>>
+ end;
+
+ 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_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;
+
+ 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)
+ is begin
+ if Use_Minimal_Complete_Actions then
+ Insert_Minimal_Complete_Actions (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+ else
+ Insert_From_Action_List (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+ end if;
+
+ -- It is tempting to use the Goto_List to find nonterms to insert.
+ -- But that can easily lead to error states, and it turns out to be
+ -- not useful, especially if the grammar has been relaxed so most
+ -- expressions and lists can be empty.
+
+ exception
+ when Bad_Config =>
+ null;
+ end Try_Insert_Terminal;
+
+ procedure Try_Insert_Quote
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ use all type Parser.Language_String_ID_Set_Access;
+ 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;
+
+ Current_Line : constant Line_Number_Type :=
Shared.Terminals.all (Config.Current_Shared_Token).Line;
+ Lexer_Error_Token_Index : Base_Token_Index;
+ Lexer_Error_Token : Base_Token;
+
+ function Recovered_Lexer_Error (Line : in Line_Number_Type) return
Base_Token_Index
+ is
+ use WisiToken.Lexer;
+ use WisiToken.Lexer.Error_Lists;
+ begin
+ -- We are assuming the list of lexer errors is short, so binary
+ -- search would not be significantly faster.
+ for Err of reverse Shared.Lexer.Errors loop
+ if Err.Recover_Token /= Invalid_Token_Index and then
+ Shared.Terminals.all (Err.Recover_Token).Line = Line
+ then
+ return Err.Recover_Token;
+ end if;
+ end loop;
+ return Invalid_Token_Index;
+ end Recovered_Lexer_Error;
+
+ function String_ID_Set (String_ID : in Token_ID) return Token_ID_Set
+ is begin
+ return
+ (if Shared.Language_String_ID_Set = null
+ then (Descriptor.First_Terminal .. Descriptor.Last_Terminal =>
True)
+ else Shared.Language_String_ID_Set (Descriptor, String_ID));
+ end String_ID_Set;
+
+ procedure String_Literal_In_Stack
+ (New_Config : in out Configuration;
+ Matching : in SAL.Peek_Type;
+ String_Literal_ID : in Token_ID)
+ is
+ Saved_Shared_Token : constant Token_Index :=
New_Config.Current_Shared_Token;
+
+ Tok : Recover_Token;
+ J : Token_Index;
+ Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ begin
+ -- Matching is the index of a token on New_Config.Stack containing a
string
+ -- literal. Push back thru that token, then delete all tokens after
+ -- the string literal to Saved_Shared_Token.
+ for I in 1 .. Matching loop
+ Tok := New_Config.Stack.Pop.Token;
+ New_Config.Ops.Append ((Push_Back, Tok.ID,
Tok.Min_Terminal_Index));
+ end loop;
+
+ New_Config.Current_Shared_Token := Tok.Min_Terminal_Index;
+
+ -- Find last string literal in pushed back terminals.
+ J := Saved_Shared_Token - 1;
+ loop
+ exit when Shared.Terminals.all (J).ID = String_Literal_ID;
+ J := J - 1;
+ end loop;
+
+ begin
+ if Parse.Parse
+ (Super, Shared, Parser_Index, Parse_Items, New_Config,
+ Shared_Token_Goal => J,
+ All_Conflicts => False,
+ Trace_Prefix => "insert quote parse pushback")
+ then
+ -- The non-deleted tokens parsed without error. We don't care
if any
+ -- conflicts were encountered; we are not using the parse
result.
+ New_Config := Parse_Items (1).Config;
+ New_Config.Ops.Append ((Fast_Forward,
New_Config.Current_Shared_Token));
+ else
+ raise SAL.Programmer_Error;
+ end if;
+ exception
+ when Bad_Config =>
+ raise SAL.Programmer_Error;
+ end;
+ J := New_Config.Current_Shared_Token; -- parse result
+ loop
+ exit when J = Saved_Shared_Token;
+ New_Config.Ops.Append ((Delete, Shared.Terminals.all (J).ID, J));
+ J := J + 1;
+ end loop;
+
+ New_Config.Current_Shared_Token := Saved_Shared_Token;
+
+ end String_Literal_In_Stack;
+
+ procedure Finish
+ (Label : in String;
+ New_Config : in out Configuration;
+ First, Last : in Base_Token_Index)
+ is begin
+ -- Delete tokens First .. Last; either First - 1 or Last + 1 should
+ -- be a String_Literal. Leave Current_Shared_Token at Last + 1.
+
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
+
+ -- This is a guess, so we give it a nominal cost
+ New_Config.Cost := New_Config.Cost + 1;
+
+ for I in First .. Last loop
+ if New_Config.Ops.Is_Full then
+ if Trace_McKenzie > Outline then
+ Put_Line (Super.Trace.all, Super.Label (Parser_Index),
"config.ops is full");
+ end if;
+ raise Bad_Config;
+ end if;
+ New_Config.Ops.Append ((Delete, Shared.Terminals.all (I).ID, I));
+ end loop;
+ New_Config.Current_Shared_Token := Last + 1;
+
+ -- Allow insert/delete tokens
+ New_Config.Ops.Append ((Fast_Forward,
New_Config.Current_Shared_Token));
+
+ if New_Config.Resume_Token_Goal - Check_Limit <
New_Config.Current_Shared_Token then
+ New_Config.Resume_Token_Goal := New_Config.Current_Shared_Token +
Check_Limit;
+ if Trace_McKenzie > Detail then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"resume_token_goal:" & Token_Index'Image
+ (New_Config.Resume_Token_Goal));
+ end if;
+ end if;
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("insert missing quote " & Label & " ", Super, Shared,
Parser_Index, New_Config);
+ end if;
+ end Finish;
+
+ begin
+ -- When the lexer finds an unbalanced quote, it inserts a virtual
+ -- balancing quote at the same character position as the unbalanced
+ -- quote, returning an empty string literal token there. The parser
+ -- does not see that as an error; it encounters a syntax error
+ -- before, at, or after that string literal.
+ --
+ -- Here we assume the parse error in Config.Error_Token is due to
+ -- putting the balancing quote in the wrong place, and attempt to
+ -- find a better place to put the balancing quote. Then all tokens
+ -- from the balancing quote to the unbalanced quote are now part of a
+ -- string literal, so delete them, leaving just the string literal
+ -- created by Lexer error recovery.
+
+ -- First we check to see if there is an unbalanced quote in the
+ -- current line; if not, just return. Some lexer errors are for other
+ -- unrecognized characters; see ada_mode-recover_bad_char.adb.
+ --
+ -- An alternate strategy is to treat the lexer error as a parse error
+ -- immediately, but that complicates the parse logic.
+
+ Config.String_Quote_Checked := Current_Line;
+
+ Lexer_Error_Token_Index := Recovered_Lexer_Error (Current_Line);
+
+ if Lexer_Error_Token_Index = Invalid_Token_Index then
+ return;
+ end if;
+
+ Lexer_Error_Token := Shared.Terminals.all (Lexer_Error_Token_Index);
+
+ -- It is not possible to tell where the best place to put the
+ -- balancing quote is, so we always try all reasonable places.
+
+ if Lexer_Error_Token.Byte_Region.First =
Config.Error_Token.Byte_Region.First then
+ -- The parse error token is the string literal at the lexer error.
+ --
+ -- case a: Insert the balancing quote somewhere before the error
+ -- point. There is no way to tell how far back to put the balancing
+ -- quote, so we just do one non-empty token. See
+ -- test_mckenzie_recover.adb String_Quote_0. So far we have not found
+ -- a test case for more than one token.
+ declare
+ New_Config : Configuration := Config;
+ Token : Recover_Token;
+ begin
+ loop
+ Token := New_Config.Stack.Pop.Token;
+ if Token.Byte_Region /= Null_Buffer_Region then
+ New_Config.Ops.Append ((Push_Back, Token.ID,
Token.Min_Terminal_Index));
+ exit;
+ end if;
+ end loop;
+
+ Finish ("a", New_Config, Token.Min_Terminal_Index,
Config.Current_Shared_Token - 1);
+ Local_Config_Heap.Add (New_Config);
+ end;
+
+ -- Note that it is not reasonable to insert a quote after the error
+ -- in this case. If that were the right solution, the parser error
+ -- token would not be the lexer repaired string literal, since a
+ -- string literal would be legal here.
+
+ elsif Lexer_Error_Token.Byte_Region.First <
Config.Error_Token.Byte_Region.First then
+ -- The unbalanced quote is before the parse error token; see
+ -- test_mckenzie_recover.adb String_Quote_2.
+ --
+ -- The missing quote belongs after the parse error token, before or
+ -- at the end of the current line; try inserting it at the end of
+ -- the current line.
+ --
+ -- The lexer repaired string literal may be in a reduced token on the
+ -- stack.
+
+ declare
+ use all type SAL.Base_Peek_Type;
+ Matching : SAL.Peek_Type := 1;
+ begin
+ Find_Descendant_ID
+ (Super.Parser_State (Parser_Index).Tree, Config,
Lexer_Error_Token.ID,
+ String_ID_Set (Lexer_Error_Token.ID), Matching);
+
+ if Matching = Config.Stack.Depth then
+ -- String literal is in a virtual nonterm; give up. So far
this only
+ -- happens in a high cost non critical config.
+ if Trace_McKenzie > Detail then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index), "abandon
missing quote b; string literal in virtual");
+ end if;
+ return;
+ end if;
+
+ declare
+ New_Config : Configuration := Config;
+ begin
+ String_Literal_In_Stack (New_Config, Matching,
Lexer_Error_Token.ID);
+
+ Finish
+ ("b", New_Config, Config.Current_Shared_Token,
Shared.Line_Begin_Token.all (Current_Line + 1) - 1);
+ Local_Config_Heap.Add (New_Config);
+ end;
+ end;
+
+ else
+ -- The unbalanced quote is after the parse error token.
+
+ -- case c: Assume a missing quote belongs immediately before the
current token.
+ -- See test_mckenzie_recover.adb String_Quote_3.
+ declare
+ New_Config : Configuration := Config;
+ begin
+ Finish ("c", New_Config, Config.Current_Shared_Token,
Lexer_Error_Token_Index - 1);
+ Local_Config_Heap.Add (New_Config);
+ exception
+ when Bad_Config =>
+ null;
+ end;
+
+ -- case d: Assume a missing quote belongs somewhere farther before
+ -- the current token; try one non-empty (as in case a above). See
+ -- test_mckenzie_recover.adb String_Quote_4.
+ declare
+ New_Config : Configuration := Config;
+ Token : Recover_Token;
+ begin
+ loop
+ Token := New_Config.Stack.Pop.Token;
+ if Token.Byte_Region /= Null_Buffer_Region then
+ New_Config.Ops.Append ((Push_Back, Token.ID,
Token.Min_Terminal_Index));
+ exit;
+ end if;
+ end loop;
+
+ Finish ("d", New_Config, Token.Min_Terminal_Index,
Lexer_Error_Token_Index - 1);
+ Local_Config_Heap.Add (New_Config);
+ exception
+ when Bad_Config =>
+ null;
+ end;
+
+ -- case e: Assume the actual error is an extra quote that terminates
+ -- an intended string literal early, in which case there is a token
+ -- on the stack containing the string literal that should be extended
+ -- to the found quote. See test_mckenzie_recover.adb String_Quote_1.
+ declare
+ use all type SAL.Base_Peek_Type;
+ Matching : SAL.Peek_Type := 1;
+ begin
+ -- Lexer_Error_Token is a string literal; find a matching one.
+ Find_Descendant_ID
+ (Super.Parser_State (Parser_Index).Tree, Config,
Lexer_Error_Token.ID, String_ID_Set
+ (Lexer_Error_Token.ID), Matching);
+
+ if Matching = Config.Stack.Depth then
+ -- No matching string literal, so this case does not apply.
+ null;
+ else
+ declare
+ New_Config : Configuration := Config;
+ begin
+ String_Literal_In_Stack (New_Config, Matching,
Lexer_Error_Token.ID);
+
+ Finish ("e", New_Config, Config.Current_Shared_Token,
Lexer_Error_Token_Index);
+ Local_Config_Heap.Add (New_Config);
+ end;
+ end if;
+ end;
+ end if;
+ exception
+ when SAL.Container_Full =>
+ if Trace_McKenzie > Outline then
+ Put_Line (Super.Trace.all, Super.Label (Parser_Index), "config.ops is
full");
+ end if;
+
+ when Bad_Config =>
+ null;
+ end Try_Insert_Quote;
+
+ procedure Try_Delete_Input
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Base_Peek_Type;
+ Config : in out Configuration;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type)
+ is
+ -- Try deleting (= skipping) the current shared input token.
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+ EOF_ID : Token_ID renames Trace.Descriptor.EOF_ID;
+ Check_Limit : Token_Index renames
Shared.Table.McKenzie_Param.Check_Limit;
+
+ McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
+
+ ID : constant Token_ID := Shared.Terminals.all
(Config.Current_Shared_Token).ID;
+ begin
+ if ID /= EOF_ID then
+ -- can't delete EOF
+ declare
+ New_Config : Configuration := Config;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ New_Config.Cost := New_Config.Cost + McKenzie_Param.Delete (ID);
+
+ if Match_Since_FF (Config.Ops, (Push_Back, ID,
Config.Current_Shared_Token))
+ then
+ -- We are deleting a push_back; cancel the push_back cost, to
make
+ -- this the same as plain deleting.
+ New_Config.Cost := Natural'Max (Natural'First, New_Config.Cost
- McKenzie_Param.Push_Back (ID));
+ end if;
+
+ New_Config.Ops.Append ((Delete, ID, Config.Current_Shared_Token));
+ New_Config.Current_Shared_Token := New_Config.Current_Shared_Token
+ 1;
+
+ if New_Config.Resume_Token_Goal - Check_Limit <
New_Config.Current_Shared_Token then
+ New_Config.Resume_Token_Goal := New_Config.Current_Shared_Token
+ Check_Limit;
+ end if;
+
+ Local_Config_Heap.Add (New_Config);
+
+ if Trace_McKenzie > Detail then
+ Base.Put
+ ("delete " & Image (ID, Trace.Descriptor.all), Super, Shared,
Parser_Index, New_Config);
+ end if;
+ end;
+ end if;
+ exception
+ when SAL.Container_Full =>
+ if Trace_McKenzie > Outline then
+ Put_Line (Super.Trace.all, Super.Label (Parser_Index), "config.ops is
full");
+ end if;
+ end Try_Delete_Input;
+
+ procedure Process_One
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Config_Status : out Base.Config_Status)
+ is
+ -- Get one config from Super, check to see if it is a viable
+ -- solution. If not, enqueue variations to check.
+
+ use all type Base.Config_Status;
+ use all type Parser.Language_Fixes_Access;
+ use all type SAL.Base_Peek_Type;
+ use all type Semantic_Checks.Check_Status_Label;
+
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+ Table : Parse_Table renames Shared.Table.all;
+
+ Parser_Index : SAL.Base_Peek_Type;
+ Config : Configuration;
+
+ Local_Config_Heap : Config_Heaps.Heap_Type;
+ -- We collect all the variants to enqueue, then deliver them all at
+ -- once to Super, to minimizes task interactions.
+
+ Use_Minimal_Complete_Actions : Boolean := False;
+
+ 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);
+
+ if Use_Minimal_Complete_Actions then
+ if Table.States
(Config.Stack.Peek.State).Minimal_Complete_Actions.Length = 0 then
+ -- This happens when there is an extra token after an
acceptable
+ -- grammar statement. There is no production to complete, so
try
+ -- other things.
+ Use_Minimal_Complete_Actions := False;
+ else
+ if Trace_McKenzie > Detail then
+ Put_Line (Super.Trace.all, Super.Label (Parser_Index), "use
Minimal_Complete_Actions");
+ end if;
+ return True;
+ end if;
+ end if;
+ return None_Since_FF (Config.Ops, Delete);
+ end Allow_Insert_Terminal;
+
+ begin
+ Super.Get (Parser_Index, Config, Config_Status);
+
+ if Config_Status = All_Done then
+ return;
+ end if;
+
+ if Trace_McKenzie > Extra then
+ Base.Put ("dequeue", Super, Shared, Parser_Index, Config);
+ Put_Line (Trace, Super.Label (Parser_Index), "stack: " & Image
(Config.Stack, Trace.Descriptor.all));
+ end if;
+
+ if Config.Current_Insert_Delete = 1 then
+ -- If Config.Current_Insert_Delete > 1 then Fast_Forward failed on
this
+ -- config; don't fast_forward again.
+
+ case Fast_Forward (Super, Shared, Parser_Index, Local_Config_Heap,
Config) is
+ when Abandon =>
+ -- We know Local_Config_Heap is empty; just tell
+ -- Super we are done working.
+ Super.Put (Parser_Index, Local_Config_Heap);
+ return;
+ when Continue =>
+ -- We don't increase cost for this Fast_Forward, since it is due
to a
+ -- Language_Fixes.
+ null;
+ end case;
+ end if;
+
+ if Config.Error_Token.ID /= Invalid_Token_ID then
+ if Shared.Language_Fixes = null then
+ null;
+ else
+ Shared.Language_Fixes
+ (Trace, Shared.Lexer, Super.Label (Parser_Index),
Shared.Table.all,
+ Shared.Terminals.all, Super.Parser_State (Parser_Index).Tree,
Local_Config_Heap,
+ Config);
+
+ -- The solutions provided by Language_Fixes should be lower cost
than
+ -- others (typically 0), so they will be checked first.
+
+ if Config.Check_Status.Label = Ok then
+ -- Parse table Error action.
+ --
+ -- We don't clear Config.Error_Token here, because Try_Insert
calls
+ -- Language_Use_Minimal_Complete_Actions, which needs it. We
only clear it
+ -- when a parse results in no error (or a different error), or
a
+ -- push_back moves the Current_Token.
+ null;
+
+ else
+ -- Assume "ignore check error" is a viable solution. But give
it a
+ -- cost, so a solution provided by Language_Fixes is preferred.
+
+ declare
+ New_State : Unknown_State_Index;
+ begin
+ Config.Cost := Config.Cost +
Table.McKenzie_Param.Ignore_Check_Fail;
+
+ -- finish reduce.
+ Config.Stack.Pop (SAL.Base_Peek_Type
(Config.Check_Token_Count));
+
+ New_State := Goto_For (Table, Config.Stack (1).State,
Config.Error_Token.ID);
+
+ if New_State = Unknown_State then
+ if Config.Stack.Depth = 1 then
+ -- Stack is empty, and we did not get Accept; really
bad syntax got
+ -- us here; abandon this config. See
ada_mode-recover_bad_char.adb.
+ Super.Put (Parser_Index, Local_Config_Heap);
+ return;
+ else
+ raise SAL.Programmer_Error with
+ "process_one found test case for new_state =
Unknown; old state " &
+ Trimmed_Image (Config.Stack (1).State) & " nonterm "
& Image
+ (Config.Error_Token.ID, Trace.Descriptor.all);
+ end if;
+ end if;
+
+ Config.Stack.Push ((New_State,
Syntax_Trees.Invalid_Node_Index, Config.Error_Token));
+
+ -- We must clear Check_Status here, so if this config comes
back
+ -- here, we don't try to reduce the stack again. We also
clear
+ -- Error_Token, so this doesn't look like a parse error.
+ Config.Check_Status := (Label => Ok);
+
+ Config.Error_Token.ID := Invalid_Token_ID;
+ end;
+ end if;
+ end if;
+ end if;
+
+ if Config.Current_Insert_Delete > 1 then
+ -- Fast_Forward failed on this config; no need to check it. Remove
+ -- already parsed items from Insert_Delete, setting
+ -- Current_Insert_Delete to 1, so it will be checked after the Ops
+ -- applied below.
+ Config.Insert_Delete.Delete_First (Config.Current_Insert_Delete - 1);
+ Config.Current_Insert_Delete := 1;
+ else
+ case Check (Super, Shared, Parser_Index, Config, Local_Config_Heap) is
+ when Success =>
+ Super.Success (Parser_Index, Config, Local_Config_Heap);
+ return;
+
+ when Abandon =>
+ Super.Put (Parser_Index, Local_Config_Heap);
+ return;
+
+ when Continue =>
+ null;
+
+ end case;
+ end if;
+
+ if Trace_McKenzie > Detail then
+ Base.Put ("continuing", Super, Shared, Parser_Index, Config);
+ if Trace_McKenzie > Extra then
+ Put_Line (Trace, Super.Label (Parser_Index), "stack: " & Image
(Config.Stack, Trace.Descriptor.all));
+ end if;
+ end if;
+
+ -- Grouping these operations ensures that there are no duplicate
+ -- solutions found. We reset the grouping after each fast_forward.
+ --
+ -- All possible permutations will be explored.
+
+ if None_Since_FF (Config.Ops, Delete) and
+ None_Since_FF (Config.Ops, Insert) and
+ Config.Stack.Depth > 1 -- can't delete the first state
+ 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);
+ end if;
+
+ if Config.Current_Insert_Delete = No_Insert_Delete then
+ if Config.Check_Status.Label = Ok and
+ (Descriptor.String_1_ID /= Invalid_Token_ID or
Descriptor.String_2_ID /= Invalid_Token_ID) and
+ (Config.String_Quote_Checked = Invalid_Line_Number or else
+ Config.String_Quote_Checked < Shared.Terminals.all
(Config.Current_Shared_Token).Line)
+ then
+ -- See if there is a mismatched quote. The solution is to delete
+ -- tokens, replacing them with a string literal. So we try this
when
+ -- it is ok to try delete.
+ Try_Insert_Quote (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+ end if;
+
+ Try_Delete_Input (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
+ end if;
+
+ Super.Put (Parser_Index, Local_Config_Heap);
+ exception
+ when others =>
+ -- Just abandon this config; tell Super we are done.
+ Super.Put (Parser_Index, Local_Config_Heap);
+ if Debug_Mode then
+ raise;
+ end if;
+ end Process_One;
+
+end WisiToken.Parse.LR.McKenzie_Recover.Explore;
diff --git a/wisitoken-parse-lr-mckenzie_recover-explore.ads
b/wisitoken-parse-lr-mckenzie_recover-explore.ads
new file mode 100644
index 0000000..12e4871
--- /dev/null
+++ b/wisitoken-parse-lr-mckenzie_recover-explore.ads
@@ -0,0 +1,28 @@
+-- Abstract :
+--
+-- Code to explore parse table, enqueuing new configs to check.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Parse.LR.McKenzie_Recover.Base;
+private package WisiToken.Parse.LR.McKenzie_Recover.Explore is
+
+ procedure Process_One
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Config_Status : out Base.Config_Status);
+
+end WisiToken.Parse.LR.McKenzie_Recover.Explore;
diff --git a/wisitoken-parse-lr-mckenzie_recover-parse.adb
b/wisitoken-parse-lr-mckenzie_recover-parse.adb
new file mode 100644
index 0000000..0d78fcd
--- /dev/null
+++ b/wisitoken-parse-lr-mckenzie_recover-parse.adb
@@ -0,0 +1,302 @@
+-- Abstract :
+--
+-- See spec
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
+
+ procedure Compute_Nonterm
+ (ID : in Token_ID;
+ Stack : in Recover_Stacks.Stack;
+ Tokens : in out Recover_Token_Array;
+ Nonterm : out Recover_Token;
+ Default_Virtual : in Boolean)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ Min_Terminal_Index_Set : Boolean := False;
+ begin
+ Nonterm :=
+ (ID => ID,
+ Virtual => (if Tokens'Length = 0 then Default_Virtual else False),
+ others => <>);
+
+ for I in Tokens'Range loop
+ Tokens (I) := Stack (Tokens'Last - I + 1).Token;
+ end loop;
+
+ for T of Tokens loop
+ Nonterm.Virtual := Nonterm.Virtual or T.Virtual;
+
+ if Nonterm.Byte_Region.First > T.Byte_Region.First then
+ Nonterm.Byte_Region.First := T.Byte_Region.First;
+ end if;
+
+ if Nonterm.Byte_Region.Last < T.Byte_Region.Last then
+ Nonterm.Byte_Region.Last := T.Byte_Region.Last;
+ end if;
+
+ if not Min_Terminal_Index_Set then
+ if T.Min_Terminal_Index /= Invalid_Token_Index then
+ Min_Terminal_Index_Set := True;
+ Nonterm.Min_Terminal_Index := T.Min_Terminal_Index;
+ end if;
+ end if;
+ end loop;
+ end Compute_Nonterm;
+
+ function Reduce_Stack
+ (Shared : not null access Base.Shared;
+ Stack : in out Recover_Stacks.Stack;
+ Action : in Reduce_Action_Rec;
+ Nonterm : out Recover_Token;
+ Default_Virtual : in Boolean)
+ return Semantic_Checks.Check_Status
+ is
+ use all type SAL.Base_Peek_Type;
+ use all type Semantic_Checks.Semantic_Check;
+ use all type Semantic_Checks.Check_Status_Label;
+
+ Last : constant SAL.Base_Peek_Type := SAL.Base_Peek_Type
(Action.Token_Count);
+ Tokens : Recover_Token_Array (1 .. Last);
+ begin
+ Compute_Nonterm (Action.Production.LHS, Stack, Tokens, Nonterm,
Default_Virtual);
+
+ if Action.Check = null then
+ -- Now we can pop the stack.
+ Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
+ return (Label => Ok);
+ else
+ return Status : constant Semantic_Checks.Check_Status :=
+ Action.Check (Shared.Lexer, Nonterm, Tokens)
+ do
+ if Status.Label = Ok then
+ Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
+ end if;
+ end return;
+ end if;
+ end Reduce_Stack;
+
+ function Parse_One_Item
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Parse_Items : in out Parse_Item_Arrays.Vector;
+ Parse_Item_Index : in Positive;
+ Shared_Token_Goal : in Base_Token_Index;
+ Trace_Prefix : in String)
+ return Boolean
+ is
+ -- Perform parse actions on Parse_Items (Parse_Item_Index), until one
+ -- fails (return False) or Shared_Token_Goal is shifted (return
+ -- True).
+ --
+ -- We return Boolean, not Check_Status, because Abandon and Continue
+ -- are up to the caller.
+ --
+ -- If any actions have a conflict, append the conflict config and
action to
+ -- Parse_Items.
+
+ use all type Ada.Containers.Count_Type;
+ use all type SAL.Base_Peek_Type;
+ use all type Semantic_Checks.Check_Status_Label;
+
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+ Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
+ Table : Parse_Table renames Shared.Table.all;
+
+ Item : Parse_Item renames Parse_Items (Parse_Item_Index);
+ Config : Configuration renames Item.Config;
+ Action : Parse_Action_Node_Ptr renames Item.Action;
+
+ Restore_Terminals_Current : Base_Token_Index;
+ Current_Token : Base_Token := McKenzie_Recover.Current_Token
+ (Terminals => Shared.Terminals.all,
+ Terminals_Current => Config.Current_Shared_Token,
+ Restore_Terminals_Current => Restore_Terminals_Current,
+ Insert_Delete => Config.Insert_Delete,
+ Current_Insert_Delete => Config.Current_Insert_Delete);
+
+ New_State : Unknown_State_Index;
+ Success : Boolean := True;
+
+ begin
+ if Trace_McKenzie > Detail then
+ Base.Put (Trace_Prefix & ": " & Image (Current_Token, Descriptor),
Super, Shared, Parser_Index, Config);
+ if Shared_Token_Goal /= Invalid_Token_Index then
+ Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
Shared_Token_Goal :" &
+ Token_Index'Image (Shared_Token_Goal));
+ end if;
+ end if;
+
+ Item.Parsed := True;
+
+ if Action = null then
+ Action := Action_For (Table, Config.Stack (1).State,
Current_Token.ID);
+ end if;
+
+ loop
+ if Action.Next /= null then
+ if Parse_Items.Is_Full then
+ if Trace_McKenzie > Outline then
+ Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix &
": too many conflicts; abandoning");
+ end if;
+ else
+ if Trace_McKenzie > Detail then
+ Put_Line
+ (Trace, Super.Label (Parser_Index), Trace_Prefix & ":" &
State_Index'Image
+ (Config.Stack.Peek.State) & ": add conflict " &
+ Image (Action.Next.Item, Descriptor));
+ end if;
+
+ Parse_Items.Append ((Config, Action.Next, Parsed => False,
Shift_Count => 0));
+ end if;
+ end if;
+
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Trace, Super.Label (Parser_Index), Trace_Prefix & ":" &
State_Index'Image (Config.Stack.Peek.State) &
+ " :" & Token_Index'Image (Config.Current_Shared_Token) &
+ " : " & Image (Current_Token, Descriptor) &
+ " : " & Image (Action.Item, Descriptor));
+ end if;
+
+ case Action.Item.Verb is
+ when Shift =>
+ Item.Shift_Count := Item.Shift_Count + 1;
+
+ Config.Stack.Push
+ ((Action.Item.State,
+ Syntax_Trees.Invalid_Node_Index,
+ (Current_Token.ID,
+ Byte_Region => Current_Token.Byte_Region,
+ Min_Terminal_Index =>
+ (if Config.Current_Insert_Delete = No_Insert_Delete
+ then Config.Current_Shared_Token
+ else Invalid_Token_Index),
+ Name => Null_Buffer_Region,
+ Virtual => Config.Current_Insert_Delete /=
No_Insert_Delete)));
+
+ Current_Token := Next_Token
+ (Terminals => Shared.Terminals.all,
+ Terminals_Current => Config.Current_Shared_Token,
+ Restore_Terminals_Current => Restore_Terminals_Current,
+ Insert_Delete => Config.Insert_Delete,
+ Current_Insert_Delete => Config.Current_Insert_Delete);
+
+ when Reduce =>
+ declare
+ Nonterm : Recover_Token;
+ begin
+ Config.Check_Status := Reduce_Stack
+ (Shared, Config.Stack, Action.Item, Nonterm,
+ Default_Virtual => Config.Current_Insert_Delete /=
No_Insert_Delete);
+
+ case Config.Check_Status.Label is
+ when Ok =>
+ New_State := Config.Stack.Peek.State;
+ New_State := Goto_For (Table, New_State,
Action.Item.Production.LHS);
+
+ if New_State = Unknown_State then
+ -- Most likely from an inappropriate language fix.
+ if Trace_McKenzie > Outline then
+ Base.Put (Trace_Prefix & ": Unknown_State: ", Super,
Shared, Parser_Index, Config);
+ Put_Line (Trace, Trace_Prefix & ": stack: " & Image
(Config.Stack, Descriptor));
+ end if;
+
+ -- We can't just return False here; user must abandon
this config.
+ raise Bad_Config;
+ end if;
+
+ Config.Stack.Push ((New_State,
Syntax_Trees.Invalid_Node_Index, Nonterm));
+
+ when Semantic_Checks.Error =>
+ Config.Error_Token := Nonterm;
+ Config.Check_Token_Count := Action.Item.Token_Count;
+ Success := False;
+ end case;
+ end;
+
+ when Error =>
+
+ Config.Error_Token :=
+ (ID => Current_Token.ID,
+ Byte_Region => Current_Token.Byte_Region,
+ others => <>);
+ Success := False;
+
+ when Accept_It =>
+ null;
+ end case;
+
+ exit when not Success or
+ Action.Item.Verb = Accept_It or
+ (if Shared_Token_Goal = Invalid_Token_Index
+ then Config.Insert_Delete.Length = 0
+ else Config.Current_Shared_Token > Shared_Token_Goal);
+
+ Action := Action_For (Table, Config.Stack (1).State,
Current_Token.ID);
+ end loop;
+
+ Config.Current_Shared_Token := Restore_Terminals_Current;
+
+ return Success;
+ end Parse_One_Item;
+
+ function Parse
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Parse_Items : out Parse_Item_Arrays.Vector;
+ Config : in Configuration;
+ Shared_Token_Goal : in Base_Token_Index;
+ All_Conflicts : in Boolean;
+ Trace_Prefix : in String)
+ return Boolean
+ is
+ Trace : WisiToken.Trace'Class renames Super.Trace.all;
+
+ Last_Index : Positive;
+ Success : Boolean;
+ begin
+ Parse_Items.Clear;
+ Parse_Items.Append ((Config, Action => null, Parsed => False,
Shift_Count => 0));
+
+ -- Clear any errors; so they reflect the parse result.
+ Parse_Items (Parse_Items.First_Index).Config.Error_Token.ID :=
Invalid_Token_ID;
+ Parse_Items (Parse_Items.First_Index).Config.Check_Status := (Label =>
Semantic_Checks.Ok);
+
+ loop
+ -- Loop over initial config and any conflicts.
+ Last_Index := Parse_Items.Last_Index;
+
+ Success := Parse_One_Item
+ (Super, Shared, Parser_Index, Parse_Items, Last_Index,
Shared_Token_Goal, Trace_Prefix);
+
+ exit when Parse_Items.Last_Index = Last_Index;
+
+ exit when Success and not All_Conflicts;
+
+ if Trace_McKenzie > Detail then
+ Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
parse conflict");
+ end if;
+ end loop;
+
+ return Success;
+ end Parse;
+
+end WisiToken.Parse.LR.McKenzie_Recover.Parse;
diff --git a/wisitoken-parse-lr-mckenzie_recover-parse.ads
b/wisitoken-parse-lr-mckenzie_recover-parse.ads
new file mode 100644
index 0000000..eb1eeee
--- /dev/null
+++ b/wisitoken-parse-lr-mckenzie_recover-parse.ads
@@ -0,0 +1,77 @@
+-- Abstract :
+--
+-- Config parsing subprograms.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Parse.LR.McKenzie_Recover.Base;
+private package WisiToken.Parse.LR.McKenzie_Recover.Parse is
+
+ function Reduce_Stack
+ (Shared : not null access Base.Shared;
+ Stack : in out Recover_Stacks.Stack;
+ Action : in Reduce_Action_Rec;
+ Nonterm : out Recover_Token;
+ Default_Virtual : in Boolean)
+ return Semantic_Checks.Check_Status;
+ -- Reduce Stack according to Action, setting Nonterm. If
+ -- Action.Token_Count = 0, set Nonterm.Virtual := Default_Virtual.
+
+ type Parse_Item is record
+ Config : Configuration;
+ Action : Parse_Action_Node_Ptr;
+ Parsed : Boolean;
+ Shift_Count : Natural := 0;
+
+ -- On return from Parse, if Parsed = False, this item was queued by a
+ -- conflict, but not parsed; it should be ignored.
+ --
+ -- Otherwise, if Config.Error_Token.ID = Invalid_Token_ID and
+ -- Config.Check_Status.Label = Ok, Config was parsed successfully to
+ -- the goal.
+ --
+ -- Otherwise, the parser failed a semantic check, or encountered an
+ -- Error action. Shift_Count gives the number of shifts performed. If
+ -- Check_Status.Label is Error, Action.Item.Verb must be Reduce, and
+ -- Config is in the pre-reduce state.
+ end record;
+
+ package Parse_Item_Arrays is new SAL.Gen_Bounded_Definite_Vectors
(Positive, Parse_Item, Capacity => 10);
+ -- Parse_Item_Arrays.Capacity sets maximum conflicts in one call to Parse
+
+ function Parse
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Parse_Items : out Parse_Item_Arrays.Vector;
+ Config : in Configuration;
+ Shared_Token_Goal : in Base_Token_Index;
+ All_Conflicts : in Boolean;
+ Trace_Prefix : in String)
+ return Boolean;
+ -- Attempt to parse Config until Config.Inserted is all shifted, and
+ -- either Shared_Token_Goal = Invalid_Token_Index or
+ -- Shared_Token_Goal is shifted.
+ --
+ -- Parsed configs are in Parse_Items; there is more than one if a
+ -- conflict is encountered. Parse returns True if at least one
+ -- Parse_Item parsed successfully to the goal. In that case, the
+ -- other items are either not parsed or failed. See comment in
+ -- Parse_Item for more detail.
+ --
+ -- Raises Bad_Config if parse encounters Unknown_State.
+
+end WisiToken.Parse.LR.McKenzie_Recover.Parse;
diff --git a/wisitoken-parse-lr-mckenzie_recover.adb
b/wisitoken-parse-lr-mckenzie_recover.adb
new file mode 100644
index 0000000..26d75df
--- /dev/null
+++ b/wisitoken-parse-lr-mckenzie_recover.adb
@@ -0,0 +1,1062 @@
+-- Abstract :
+--
+-- See spec
+--
+-- Copyright (C) 2017 - 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Characters.Handling;
+with Ada.Exceptions;
+with Ada.Task_Identification;
+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
+
+ 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.
+
+ entry Done;
+ -- Available when task is ready to terminate; after this rendezvous,
+ -- task discriminants may be freed.
+
+ end Worker_Task;
+
+ task body Worker_Task
+ is
+ use all type Base.Config_Status;
+ Status : Base.Config_Status;
+ begin
+ accept Start;
+
+ loop
+ Explore.Process_One (Super, Shared, Status);
+
+ exit when Status = All_Done;
+ end loop;
+
+ accept Done;
+ exception
+ when E : others =>
+ Super.Fatal (E);
+ end Worker_Task;
+
+ function To_Recover
+ (Parser_Stack : in Parser_Lists.Parser_Stacks.Stack;
+ Tree : in Syntax_Trees.Tree)
+ return Recover_Stacks.Stack
+ is
+ use all type SAL.Base_Peek_Type;
+ Result : Recover_Stacks.Stack;
+ Depth : constant SAL.Peek_Type := Parser_Stack.Depth;
+ begin
+ Result.Set_Depth (Depth);
+ for I in 1 .. Depth loop
+ declare
+ Item : Parser_Lists.Parser_Stack_Item renames Parser_Stack (I);
+ Token : constant Recover_Token := (if I = Depth then (others =>
<>) else Tree.Recover_Token (Item.Token));
+ begin
+ Result.Set (I, Depth, (Item.State, Item.Token, Token));
+ end;
+ end loop;
+ return Result;
+ end To_Recover;
+
+ procedure Recover_Init
+ (Shared_Parser : in out LR.Parser.Parser;
+ Parser_State : in out Parser_Lists.Parser_State)
+ is
+ use all type WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+ Config : constant Configuration_Access :=
Parser_State.Recover.Config_Heap.Add (Configuration'(others => <>));
+ Error : Parse_Error renames Parser_State.Errors
(Parser_State.Errors.Last);
+ begin
+ Parser_State.Recover.Enqueue_Count := Parser_State.Recover.Enqueue_Count
+ 1;
+
+ Config.Resume_Token_Goal := Parser_State.Shared_Token +
Shared_Parser.Table.McKenzie_Param.Check_Limit;
+
+ if Trace_McKenzie > Outline then
+ Trace.New_Line;
+ Trace.Put_Line
+ ("parser" & Integer'Image (Parser_State.Label) &
+ ": State" & State_Index'Image (Parser_State.Stack (1).State) &
+ " Current_Token" & Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) &
+ " Resume_Token_Goal" & Token_Index'Image
(Config.Resume_Token_Goal));
+ Trace.Put_Line (Image (Error, Parser_State.Tree,
Trace.Descriptor.all));
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Trace, Parser_State.Label, Parser_Lists.Image
+ (Parser_State.Stack, Trace.Descriptor.all,
Parser_State.Tree));
+ end if;
+ end if;
+
+ -- Additional initialization of Parser_State.Recover is done in
+ -- Supervisor.Initialize.
+
+ Config.Stack := To_Recover (Parser_State.Stack, Parser_State.Tree);
+
+ -- Parser_State.Recover_Insert_Delete must be empty (else we would not
get
+ -- here). Therefore Parser_State current token is in
+ -- Shared_Parser.Shared_Token.
+
+ Config.Current_Shared_Token := Parser_State.Shared_Token;
+
+ case Error.Label is
+ when Action =>
+ Config.Error_Token := Parser_State.Tree.Recover_Token
(Error.Error_Token);
+ if Trace_McKenzie > Detail then
+ Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config.all,
+ Task_ID => False);
+ end if;
+
+ when Check =>
+ if Shared_Parser.Language_Fixes = null then
+ -- The only fix is to ignore the error.
+ if Trace_McKenzie > Detail then
+ Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config.all,
+ Task_ID => False);
+ end if;
+
+ else
+ -- Undo the reduction that encountered the error, let Process_One
+ -- enqueue possible solutions. We leave the cost at 0, since this
is
+ -- the root config. Later logic will enqueue the 'ignore error'
+ -- solution; see McKenzie_Recover.Explore Process_One.
+
+ Config.Check_Status := Error.Check_Status;
+ Config.Error_Token := Config.Stack (1).Token;
+ Config.Check_Token_Count := Undo_Reduce (Config.Stack,
Parser_State.Tree);
+
+ Config.Ops.Append ((Undo_Reduce, Config.Error_Token.ID,
Config.Check_Token_Count));
+
+ if Trace_McKenzie > Detail then
+ Put ("undo_reduce " & Image
+ (Config.Error_Token.ID, Trace.Descriptor.all), Trace,
Parser_State.Label,
+ Shared_Parser.Terminals, Config.all, Task_ID => False);
+ end if;
+ end if;
+
+ when Message =>
+ -- Last error entry should be the failure that caused us to enter
+ -- recovery.
+ raise SAL.Programmer_Error;
+ end case;
+ end Recover_Init;
+
+ function Recover (Shared_Parser : in out LR.Parser.Parser) return
Recover_Status
+ is
+ use all type Parser.Post_Recover_Access;
+ use all type SAL.Base_Peek_Type;
+ use all type System.Multiprocessors.CPU_Range;
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+
+ Parsers : Parser_Lists.List renames Shared_Parser.Parsers;
+
+ Current_Parser : Parser_Lists.Cursor;
+
+ Super : aliased Base.Supervisor
+ (Trace'Access,
+ Cost_Limit => Shared_Parser.Table.McKenzie_Param.Cost_Limit,
+ Check_Delta_Limit =>
Shared_Parser.Table.McKenzie_Param.Check_Delta_Limit,
+ Enqueue_Limit => Shared_Parser.Table.McKenzie_Param.Enqueue_Limit,
+ Parser_Count => Parsers.Count);
+
+ Shared : aliased Base.Shared
+ (Shared_Parser.Trace,
+ Shared_Parser.Lexer.all'Access,
+ Shared_Parser.Table,
+ Shared_Parser.Language_Fixes,
+ Shared_Parser.Language_Use_Minimal_Complete_Actions,
+ Shared_Parser.Language_String_ID_Set,
+ Shared_Parser.Terminals'Access,
+ Shared_Parser.Line_Begin_Token'Access);
+
+ Task_Count : constant System.Multiprocessors.CPU_Range :=
+ (if Shared_Parser.Table.McKenzie_Param.Task_Count = 0
+ then System.Multiprocessors.CPU_Range'Max (1,
System.Multiprocessors.Number_Of_CPUs - 1)
+ -- 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;
+ Trace.Put_Line (" McKenzie error recovery");
+ end if;
+
+ Super.Initialize (Parsers'Unrestricted_Access,
Shared_Parser.Terminals'Unrestricted_Access);
+
+ for Parser_State of Parsers loop
+ Recover_Init (Shared_Parser, Parser_State);
+ end loop;
+
+ if Trace_McKenzie > Outline then
+ Trace.New_Line;
+ Trace.Put_Line (System.Multiprocessors.CPU_Range'Image
(Worker_Tasks'Last) & " parallel tasks");
+ end if;
+
+ for I in Worker_Tasks'Range loop
+ Worker_Tasks (I).Start;
+ end loop;
+
+ declare
+ use Ada.Exceptions;
+ ID : Exception_Id;
+ Message : Ada.Strings.Unbounded.Unbounded_String;
+ begin
+ Super.Done (ID, Message); -- Wait for all parsers to fail or succeed
+ 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
+ -- cost fix. However, the normal reason for having multiple parsers
+ -- is to resolve a grammar ambiguity; the least cost fix might
+ -- resolve the ambiguity the wrong way. As could any other fix, of
+ -- course.
+
+ -- Spawn new parsers for multiple solutions
+ declare
+ use Parser_Lists;
+ Cur : Cursor := Parsers.First;
+ Solutions : SAL.Base_Peek_Type := 0;
+ Spawn_Limit : SAL.Base_Peek_Type := Shared_Parser.Max_Parallel; --
per parser
+ begin
+ for Parser of Parsers loop
+ if Parser.Recover.Success then
+ Solutions := Solutions + Parser.Recover.Results.Count;
+ end if;
+ end loop;
+
+ if Solutions > Shared_Parser.Max_Parallel and Trace_McKenzie >
Outline then
+ Trace.Put_Line ("too many parallel parsers required in recover;
dropping some solutions");
+ Spawn_Limit := Shared_Parser.Max_Parallel / Parsers.Count;
+ end if;
+
+ loop
+ declare
+ Data : McKenzie_Data renames State_Ref (Cur).Recover;
+ begin
+ if Data.Success then
+ if Trace_McKenzie > Outline then
+ Trace.Put_Line
+ (Integer'Image (Label (Cur)) &
+ ": succeed" & SAL.Base_Peek_Type'Image
(Data.Results.Count) &
+ ", enqueue" & Integer'Image (Data.Enqueue_Count) &
+ ", check " & Integer'Image (Data.Check_Count) &
+ ", cost: " & Integer'Image (Data.Results.Min_Key));
+ end if;
+
+ if Data.Results.Count > 1 then
+ for I in 1 .. SAL.Base_Peek_Type'Min (Spawn_Limit,
Data.Results.Count - 1) loop
+ Parsers.Prepend_Copy (Cur); -- does not copy recover
+ if Trace_McKenzie > Outline or Trace_Parse > Outline
then
+ Trace.Put_Line
+ ("spawn parser" & Integer'Image
(Parsers.First.Label) & " from " &
+ Trimmed_Image (Cur.Label) & " (" &
Trimmed_Image (Integer (Parsers.Count)) &
+ " active)");
+ Put ("", Trace, Parsers.First.Label,
Shared_Parser.Terminals,
+ Data.Results.Peek, Task_ID => False);
+ end if;
+
+ State_Ref (Parsers.First).Recover.Results.Add
(Data.Results.Remove);
+ State_Ref (Parsers.First).Recover.Success := True;
+ end loop;
+ end if;
+
+ if Trace_McKenzie > Outline or Trace_Parse > Outline then
+ Put ("", Trace, Cur.State_Ref.Label,
Shared_Parser.Terminals, Data.Results.Peek,
+ Task_ID => False);
+ end if;
+ else
+ if Trace_McKenzie > Outline then
+ Trace.Put_Line
+ (Integer'Image (Cur.Label) &
+ ": fail, enqueue" & Integer'Image
(Data.Enqueue_Count) &
+ ", check " & Integer'Image (Data.Check_Count) &
+ ", cost_limit: " & Integer'Image
(Shared_Parser.Table.McKenzie_Param.Cost_Limit) &
+ ", max shared_token " & Token_Index'Image
(Shared_Parser.Terminals.Last_Index));
+ end if;
+ end if;
+
+ end;
+ Next (Cur);
+ exit when Is_Done (Cur);
+ end loop;
+ end;
+
+ -- Edit Parser_State to apply solutions.
+
+ -- We don't use 'for Parser_State of Parsers loop' here,
+ -- because we might need to terminate a parser.
+ Current_Parser := Parsers.First;
+ loop
+ exit when Current_Parser.Is_Done;
+
+ if Current_Parser.State_Ref.Recover.Success then
+ begin
+ -- Can't have active 'renames State_Ref' when terminate a
parser
+ declare
+ use all type Syntax_Trees.Node_Index;
+ use Parser_Lists;
+
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+
+ Descriptor : WisiToken.Descriptor renames
Shared_Parser.Trace.Descriptor.all;
+ Tree : Syntax_Trees.Tree renames Parser_State.Tree;
+ Data : McKenzie_Data renames Parser_State.Recover;
+ Result : Configuration renames Data.Results.Peek;
+
+ Min_Op_Token_Index : WisiToken.Token_Index :=
WisiToken.Token_Index'Last;
+ Min_Push_Back_Token_Index : WisiToken.Token_Index :=
WisiToken.Token_Index'Last;
+
+ Stack_Matches_Ops : Boolean := True;
+ Shared_Token_Changed : Boolean := False;
+ Current_Token_Virtual : Boolean := False;
+
+ Sorted_Insert_Delete : Sorted_Insert_Delete_Arrays.Vector;
+ begin
+ Parser_State.Errors (Parser_State.Errors.Last).Recover :=
Result;
+
+ Parser_State.Resume_Token_Goal := Result.Resume_Token_Goal;
+
+ if Trace_McKenzie > Extra then
+ Put_Line (Trace, Parser_State.Label, "before Ops
applied:", Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "stack " & Image
(Parser_State.Stack, Descriptor, Tree),
+ Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "Shared_Token " & Image
+ (Parser_State.Shared_Token, Shared_Parser.Terminals,
Descriptor),
+ Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "Current_Token " &
Parser_State.Tree.Image
+ (Parser_State.Current_Token, Descriptor),
+ Task_ID => False);
+ end if;
+
+ -- We don't apply all Ops to the parser stack here, because
that
+ -- requires updating the syntax tree as well, and we want
to let the
+ -- main parser do that, partly as a double check on the
algorithms
+ -- here.
+ --
+ -- However, the main parser can only apply Insert and
Delete ops; we
+ -- must apply Push_Back and Undo_Reduce here. Note that
Fast_Forward
+ -- ops are just for bookkeeping.
+ --
+ -- In order to apply Undo_Reduce, we also need to apply any
preceding
+ -- ops. See test_mckenzie_recover.adb Missing_Name_2 for an
example
+ -- of multiple Undo_Reduce. On the other hand, Push_Back
can be
+ -- applied without the preceding ops.
+ --
+ -- A Push_Back can go back past preceding ops, including
Undo_Reduce;
+ -- there's no point in applying ops that are later
superceded by such
+ -- a Push_Back. See test_mckenzie_recover.adb
Out_Of_Order_Ops for an
+ -- example.
+ --
+ -- So first we go thru Ops to find the earliest Push_Back.
Then we
+ -- apply ops that are before that point, up to the first
Insert or
+ -- Fast_Forward. After that, we enqueue Insert and Delete
ops on
+ -- Parser_State.Recover_Insert_Delete, in token_index
order, and any
+ -- Undo_Reduce are rejected.
+ --
+ -- Then the main parser parses the edited input stream.
+ --
+ -- There's no need to modify Parser_State.Tree. Any tree
nodes
+ -- created by the failed parse that are pushed back are
useful for
+ -- error repair, and will just be ignored in future
parsing. This
+ -- also avoids enlarging a non-flushed branched tree, which
saves
+ -- time and space.
+
+ for Op of Result.Ops loop
+ case Op.Op is
+ when Fast_Forward =>
+ if Op.FF_Token_Index < Min_Op_Token_Index then
+ Min_Op_Token_Index := Op.FF_Token_Index;
+ end if;
+
+ when Undo_Reduce =>
+ null;
+
+ when Push_Back | Insert | Delete =>
+ if Op.Token_Index /= Invalid_Token_Index then
+ if Op.Token_Index < Min_Op_Token_Index then
+ Min_Op_Token_Index := Op.Token_Index;
+ end if;
+ if Op.Token_Index < Min_Push_Back_Token_Index then
+ Min_Push_Back_Token_Index := Op.Token_Index;
+ end if;
+ end if;
+
+ end case;
+ end loop;
+
+ for Op of Result.Ops loop
+ case Op.Op is
+ when Fast_Forward =>
+ Stack_Matches_Ops := False;
+
+ when Undo_Reduce =>
+ if not Stack_Matches_Ops then
+ if Trace_McKenzie > Outline then
+ Put_Line
+ (Trace, Parser_State.Label, "Undo_Reduce after
insert or fast_forward",
+ Task_ID => False);
+ end if;
+ raise Bad_Config;
+ end if;
+
+ declare
+ Item : constant Parser_Lists.Parser_Stack_Item :=
Parser_State.Stack.Pop;
+ begin
+ case Tree.Label (Item.Token) is
+ when Syntax_Trees.Shared_Terminal |
Syntax_Trees.Virtual_Terminal =>
+ raise Bad_Config;
+
+ when Syntax_Trees.Nonterm =>
+ for C of Tree.Children (Item.Token) loop
+ Parser_State.Stack.Push ((Tree.State (C), C));
+ end loop;
+ end case;
+ end;
+
+ when Push_Back =>
+ if Stack_Matches_Ops then
+ Parser_State.Stack.Pop;
+ if Op.Token_Index /= Invalid_Token_Index then
+ Parser_State.Shared_Token := Op.Token_Index;
+ Shared_Token_Changed := True;
+ end if;
+
+ elsif Op.Token_Index = Min_Op_Token_Index then
+ loop
+ -- Multiple push_backs can have the same
Op.Token_Index, so we may
+ -- already be at the target.
+ exit when Parser_State.Shared_Token <=
Op.Token_Index and
+ Tree.Min_Terminal_Index (Parser_State.Stack
(1).Token) /= Invalid_Token_Index;
+ -- also push back empty tokens.
+
+ declare
+ Item : constant
Parser_Lists.Parser_Stack_Item := Parser_State.Stack.Pop;
+
+ Min_Index : constant Base_Token_Index :=
+ Parser_State.Tree.Min_Terminal_Index
(Item.Token);
+ begin
+ if Min_Index /= Invalid_Token_Index then
+ Shared_Token_Changed := True;
+ Parser_State.Shared_Token := Min_Index;
+ end if;
+ end;
+ end loop;
+ pragma Assert (Parser_State.Shared_Token =
Op.Token_Index);
+ end if;
+
+ when Insert =>
+ if Stack_Matches_Ops and Op.Token_Index =
Parser_State.Shared_Token then
+ -- This is the first Insert. Even if a later
Push_Back supercedes it,
+ -- we record Stack_Matches_Ops false here.
+ Stack_Matches_Ops := False;
+
+ if Op.Token_Index <= Min_Push_Back_Token_Index then
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (Op.ID);
+ Current_Token_Virtual := True;
+ else
+ Sorted_Insert_Delete.Insert (Op);
+ end if;
+ else
+ Sorted_Insert_Delete.Insert (Op);
+ end if;
+
+ when Delete =>
+ if Stack_Matches_Ops and Op.Token_Index =
Parser_State.Shared_Token then
+ -- We can apply multiple deletes.
+ Parser_State.Shared_Token := Op.Token_Index + 1;
+ Shared_Token_Changed := True;
+ else
+ Sorted_Insert_Delete.Insert (Op);
+ end if;
+ end case;
+ end loop;
+
+ -- We may not have processed the current Insert or Delete
above, if
+ -- they are after a fast_forward.
+ for Op of Sorted_Insert_Delete loop
+ if Op.Token_Index = Parser_State.Shared_Token and not
Current_Token_Virtual then
+ case Insert_Delete_Op_Label'(Op.Op) is
+ when Insert =>
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (Op.ID);
+ Current_Token_Virtual := True;
+
+ when Delete =>
+ Parser_State.Shared_Token := Op.Token_Index + 1;
+ Shared_Token_Changed := True;
+ end case;
+ else
+ Parser_State.Recover_Insert_Delete.Put (Op);
+ end if;
+ end loop;
+
+ -- If not Shared_Token_Changed, Shared_Token is the error
token,
+ -- which is the next token to read. If
Shared_Token_Changed, we
+ -- have set Shared_Token consistent with that; it is the
next token to
+ -- read.
+
+ if (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
+ (Trace, Parser_State.Label, "stack " &
Parser_Lists.Image
+ (Parser_State.Stack, Descriptor, Tree),
+ Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "Shared_Token " & Image
+ (Parser_State.Shared_Token, Shared_Parser.Terminals,
Descriptor), Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "Current_Token " &
Parser_State.Tree.Image
+ (Parser_State.Current_Token, Descriptor), Task_ID =>
False);
+ Put_Line
+ (Trace, Parser_State.Label, "recover_insert_delete " &
Image
+ (Parser_State.Recover_Insert_Delete, Descriptor),
Task_ID => False);
+ Put_Line
+ (Trace, Parser_State.Label, "inc_shared_token " &
Boolean'Image (Parser_State.Inc_Shared_Token) &
+ " parser verb " & All_Parse_Action_Verbs'Image
(Parser_State.Verb),
+ Task_ID => False);
+
+ 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
+ when Bad_Config =>
+ if Parsers.Count = 1 then
+ -- Oops. just give up
+ return Fail_Programmer_Error;
+ end if;
+ Parsers.Terminate_Parser (Current_Parser, "bad config in
recover", Trace);
+ end;
+ end if;
+ Current_Parser.Next;
+ end loop;
+
+ if Shared_Parser.Post_Recover /= null then
+ Shared_Parser.Post_Recover.all;
+ end if;
+
+ return Super.Recover_Result;
+
+ exception
+ when others =>
+ Cleanup;
+ return Fail_Programmer_Error;
+ end Recover;
+
+ ----------
+ -- Spec private subprograms; for language-specific
+ -- child packages.
+
+ procedure Check (ID : Token_ID; Expected_ID : in Token_ID)
+ is begin
+ pragma Assert (ID = Expected_ID, Token_ID'Image (ID) & " /=" &
Token_ID'Image (Expected_ID));
+ end Check;
+
+ function Current_Token
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out WisiToken.Base_Token_Index;
+ Restore_Terminals_Current : out WisiToken.Base_Token_Index;
+ Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type)
+ return Base_Token
+ is
+ use all type SAL.Base_Peek_Type;
+
+ procedure Inc_I_D
+ is begin
+ Current_Insert_Delete := Current_Insert_Delete + 1;
+ if Current_Insert_Delete > Insert_Delete.Last_Index then
+ Current_Insert_Delete := No_Insert_Delete;
+ Insert_Delete.Clear;
+ end if;
+ end Inc_I_D;
+
+ begin
+ if Terminals_Current = Base_Token_Index'First then
+ -- Happens with really bad syntax; see test_mckenzie_recover.adb
Error_4.
+ raise Bad_Config;
+ end if;
+
+ loop
+ if Current_Insert_Delete = No_Insert_Delete then
+ Restore_Terminals_Current := Terminals_Current;
+ return Terminals (Terminals_Current);
+
+ elsif Insert_Delete (Current_Insert_Delete).Token_Index =
Terminals_Current then
+ declare
+ Op : Insert_Delete_Op renames Insert_Delete
(Current_Insert_Delete);
+ begin
+ case Insert_Delete_Op_Label (Op.Op) is
+ when Insert =>
+ -- Decrement Terminals_Current so Next_Token knows it
should always
+ -- increment it. Save the initial value, to restore in case
of error.
+ Restore_Terminals_Current := Terminals_Current;
+ Terminals_Current := Terminals_Current - 1;
+ return (ID => Op.ID, others => <>);
+
+ when Delete =>
+ Terminals_Current := Terminals_Current + 1;
+ Restore_Terminals_Current := Terminals_Current;
+ Inc_I_D;
+ end case;
+ end;
+ else
+ return Terminals (Terminals_Current);
+ end if;
+ end loop;
+ end Current_Token;
+
+ function Current_Token_ID_Peek
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in SAL.Base_Peek_Type)
+ return Token_ID
+ is
+ use all type SAL.Base_Peek_Type;
+ 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;
+
+ if Current_Insert_Delete = No_Insert_Delete then
+ return Terminals (Terminals_Current).ID;
+
+ elsif Insert_Delete (Current_Insert_Delete).Token_Index =
Terminals_Current then
+ declare
+ Op : Insert_Delete_Op renames Insert_Delete
(Current_Insert_Delete);
+ begin
+ case Insert_Delete_Op_Label (Op.Op) is
+ when Insert =>
+ return Op.ID;
+
+ when Delete =>
+ -- This should have been handled in Check
+ raise SAL.Programmer_Error;
+ end case;
+ end;
+ else
+ return Terminals (Terminals_Current).ID;
+ end if;
+ end Current_Token_ID_Peek;
+
+ procedure Delete (Config : in out Configuration; ID : in Token_ID)
+ is
+ Op : constant Config_Op := (Delete, ID, Config.Current_Shared_Token);
+ begin
+ Config.Ops.Append (Op);
+ Config.Insert_Delete.Insert (Op);
+ Config.Current_Insert_Delete := 1;
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end Delete;
+
+ procedure Find_ID
+ (Config : in Configuration;
+ ID : in Token_ID;
+ Matching_Index : in out SAL.Peek_Type)
+ is
+ use all type SAL.Peek_Type;
+ begin
+ loop
+ exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ declare
+ Stack_ID : Token_ID renames Config.Stack (Matching_Index).Token.ID;
+ begin
+ exit when Stack_ID = ID;
+ end;
+ Matching_Index := Matching_Index + 1;
+ end loop;
+ end Find_ID;
+
+ procedure Find_ID
+ (Config : in Configuration;
+ IDs : in Token_ID_Set;
+ Matching_Index : in out SAL.Peek_Type)
+ is
+ use all type SAL.Peek_Type;
+ begin
+ loop
+ exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ declare
+ ID : Token_ID renames Config.Stack (Matching_Index).Token.ID;
+ begin
+ exit when ID in IDs'First .. IDs'Last and then IDs (ID);
+ end;
+ Matching_Index := Matching_Index + 1;
+ end loop;
+ end Find_ID;
+
+ procedure Find_Descendant_ID
+ (Tree : in Syntax_Trees.Tree;
+ Config : in Configuration;
+ ID : in Token_ID;
+ ID_Set : in Token_ID_Set;
+ Matching_Index : in out SAL.Peek_Type)
+ is
+ use Syntax_Trees;
+ use all type SAL.Peek_Type;
+ begin
+ loop
+ exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ exit when ID_Set (Config.Stack (Matching_Index).Token.ID) and
+ (Config.Stack (Matching_Index).Tree_Index /= Invalid_Node_Index and
then
+ Tree.Find_Descendant (Config.Stack (Matching_Index).Tree_Index,
ID) /= Invalid_Node_Index);
+
+ Matching_Index := Matching_Index + 1;
+ end loop;
+ end Find_Descendant_ID;
+
+ procedure Find_Matching_Name
+ (Config : in Configuration;
+ Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Name : in String;
+ Matching_Name_Index : in out SAL.Peek_Type;
+ Case_Insensitive : in Boolean)
+ is
+ use Ada.Characters.Handling;
+ use all type SAL.Peek_Type;
+ Match_Name : constant String := (if Case_Insensitive then To_Lower
(Name) else Name);
+ begin
+ loop
+ exit when Matching_Name_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ declare
+ Token : Recover_Token renames Config.Stack
(Matching_Name_Index).Token;
+ Name_Region : constant Buffer_Region :=
+ (if Token.Name = Null_Buffer_Region
+ then Token.Byte_Region
+ else Token.Name);
+ begin
+ exit when Name_Region /= Null_Buffer_Region and then
+ Match_Name =
+ (if Case_Insensitive
+ then To_Lower (Lexer.Buffer_Text (Name_Region))
+ else Lexer.Buffer_Text (Name_Region));
+
+ Matching_Name_Index := Matching_Name_Index + 1;
+ end;
+ end loop;
+ end Find_Matching_Name;
+
+ procedure Find_Matching_Name
+ (Config : in Configuration;
+ Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Name : in String;
+ Matching_Name_Index : in out SAL.Peek_Type;
+ Other_ID : in Token_ID;
+ Other_Count : out Integer;
+ Case_Insensitive : in Boolean)
+ is
+ use Ada.Characters.Handling;
+ use all type SAL.Peek_Type;
+ Match_Name : constant String := (if Case_Insensitive then To_Lower
(Name) else Name);
+ begin
+ Other_Count := 0;
+
+ loop
+ exit when Matching_Name_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ declare
+ Token : Recover_Token renames Config.Stack
(Matching_Name_Index).Token;
+ Name_Region : constant Buffer_Region :=
+ (if Token.Name = Null_Buffer_Region
+ then Token.Byte_Region
+ else Token.Name);
+ begin
+ exit when Name_Region /= Null_Buffer_Region and then
+ Match_Name =
+ (if Case_Insensitive
+ then To_Lower (Lexer.Buffer_Text (Name_Region))
+ else Lexer.Buffer_Text (Name_Region));
+
+ if Other_ID = Token.ID then
+ Other_Count := Other_Count + 1;
+ end if;
+
+ Matching_Name_Index := Matching_Name_Index + 1;
+ end;
+ end loop;
+ end Find_Matching_Name;
+
+ procedure Insert (Config : in out Configuration; ID : in Token_ID)
+ is
+ Op : constant Config_Op := (Insert, ID, Config.Current_Shared_Token);
+ begin
+ Config.Ops.Append (Op);
+ Config.Insert_Delete.Insert (Op);
+ Config.Current_Insert_Delete := 1;
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end Insert;
+
+ procedure Insert (Config : in out Configuration; IDs : in Token_ID_Array)
+ is begin
+ for ID of IDs loop
+ Insert (Config, ID);
+ end loop;
+ end Insert;
+
+ function Next_Token
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out Base_Token_Index;
+ Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
+ Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type)
+ return Base_Token
+ is
+ use all type SAL.Base_Peek_Type;
+ 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);
+
+ elsif Current_Insert_Delete = No_Insert_Delete then
+ Terminals_Current := Terminals_Current + 1;
+ Restore_Terminals_Current := Terminals_Current;
+ return Terminals (Terminals_Current);
+
+ elsif Insert_Delete (Current_Insert_Delete + 1).Token_Index =
Terminals_Current + 1 then
+ Current_Insert_Delete := Current_Insert_Delete + 1;
+ declare
+ Op : constant Insert_Delete_Op := Insert_Delete
(Current_Insert_Delete);
+ begin
+ case Insert_Delete_Op_Label'(Op.Op) is
+ when Insert =>
+ return (ID => Op.ID, others => <>);
+
+ when Delete =>
+ Terminals_Current := Terminals_Current + 1;
+ Restore_Terminals_Current := Terminals_Current;
+ end case;
+ end;
+
+ else
+ Terminals_Current := Terminals_Current + 1;
+ Restore_Terminals_Current := Terminals_Current;
+ return Terminals (Terminals_Current);
+ end if;
+ end loop;
+ end Next_Token;
+
+ procedure Push_Back (Config : in out Configuration)
+ is
+ Item : constant Recover_Stack_Item := Config.Stack.Pop;
+ Token_Index : constant Base_Token_Index :=
Item.Token.Min_Terminal_Index;
+
+ function Compare (Left : in Base_Token_Index; Right : in Config_Op)
return Boolean
+ is (case Right.Op is
+ when Fast_Forward => False,
+ when Undo_Reduce => False,
+ when Push_Back => False,
+ when Insert | Delete => Left < Right.Token_Index);
+ -- If Left = Right.Token_Index, we assume the Right ops go _after_
+ -- the Left, so the Left do not need to be repeated.
+ begin
+ if Token_Index /= Invalid_Token_Index then
+ Config.Current_Shared_Token := Token_Index;
+ for I in Config.Ops.First_Index .. Config.Ops.Last_Index loop
+ if Compare (Token_Index, Config.Ops (I)) then
+ Config.Insert_Delete.Insert (Config.Ops (I));
+ end if;
+ end loop;
+ end if;
+
+ Config.Ops.Append ((Push_Back, Item.Token.ID,
Config.Current_Shared_Token));
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end Push_Back;
+
+ procedure Push_Back_Check (Config : in out Configuration; Expected_ID : in
Token_ID)
+ is begin
+ Check (Config.Stack (1).Token.ID, Expected_ID);
+ Push_Back (Config);
+ end Push_Back_Check;
+
+ procedure Push_Back_Check (Config : in out Configuration; Expected : in
Token_ID_Array)
+ is begin
+ for ID of Expected loop
+ Push_Back_Check (Config, ID);
+ end loop;
+ end Push_Back_Check;
+
+ procedure Put
+ (Message : in String;
+ Trace : in out WisiToken.Trace'Class;
+ Parser_Label : in Natural;
+ Terminals : in Base_Token_Arrays.Vector;
+ Config : in Configuration;
+ Task_ID : in Boolean := True)
+ is
+ -- For debugging output
+
+ -- Build a string, call trace.put_line once, so output from multiple
+ -- tasks is not interleaved (mostly).
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+ use all type SAL.Base_Peek_Type;
+ use all type WisiToken.Semantic_Checks.Check_Status_Label;
+
+ Descriptor : WisiToken.Descriptor renames Trace.Descriptor.all;
+
+ Result : Ada.Strings.Unbounded.Unbounded_String :=
+ (if Task_ID then +Ada.Task_Identification.Image
(Ada.Task_Identification.Current_Task) else +"") &
+ Integer'Image (Parser_Label) & ": " &
+ (if Message'Length > 0 then Message & ":" else "");
+ begin
+ Result := Result & Natural'Image (Config.Cost) & ", ";
+ if Config.Check_Status.Label /= Ok then
+ Result := Result & Semantic_Checks.Check_Status_Label'Image
(Config.Check_Status.Label) & " ";
+ elsif Config.Error_Token.ID /= Invalid_Token_ID then
+ Result := Result & "Error " & Image (Config.Error_Token, Descriptor)
& " ";
+ end if;
+ Result := Result & Image (Config.Stack, Descriptor, Depth => 1);
+
+ if Config.Current_Insert_Delete = No_Insert_Delete then
+ Result := Result & "|" & Image (Config.Current_Shared_Token,
Terminals, Descriptor) & "|";
+ else
+ Result := Result & "/" & Trimmed_Image (Config.Current_Insert_Delete)
& ":" &
+ Image (Config.Insert_Delete (Config.Current_Insert_Delete),
Descriptor) & "/";
+ end if;
+
+ Result := Result & Image (Config.Ops, Descriptor);
+ Trace.Put_Line (-Result);
+ end Put;
+
+ procedure Put_Line
+ (Trace : in out WisiToken.Trace'Class;
+ Parser_Label : in Natural;
+ Message : in String;
+ Task_ID : in Boolean := True)
+ is begin
+ Trace.Put_Line
+ ((if Task_ID then Ada.Task_Identification.Image
(Ada.Task_Identification.Current_Task) else "") &
+ Integer'Image (Parser_Label) & ": " & Message);
+ end Put_Line;
+
+ function Undo_Reduce
+ (Stack : in out Recover_Stacks.Stack;
+ Tree : in Syntax_Trees.Tree)
+ return Ada.Containers.Count_Type
+ is
+ Nonterm_Item : constant Recover_Stack_Item := Stack.Pop;
+ Children : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Children (Nonterm_Item.Tree_Index);
+ begin
+ for C of Children loop
+ Stack.Push ((Tree.State (C), C, Tree.Recover_Token (C)));
+ end loop;
+ return Children'Length;
+ end Undo_Reduce;
+
+ procedure Undo_Reduce_Check
+ (Config : in out Configuration;
+ Tree : in Syntax_Trees.Tree;
+ Expected : in Token_ID)
+ is begin
+ Check (Config.Stack (1).Token.ID, Expected);
+ Config.Ops.Append ((Undo_Reduce, Expected, Undo_Reduce (Config.Stack,
Tree)));
+ exception
+ when SAL.Container_Full =>
+ raise Bad_Config;
+ end Undo_Reduce_Check;
+
+ procedure Undo_Reduce_Check
+ (Config : in out Configuration;
+ Tree : in Syntax_Trees.Tree;
+ Expected : in Token_ID_Array)
+ is begin
+ for ID of Expected loop
+ Undo_Reduce_Check (Config, Tree, ID);
+ end loop;
+ end Undo_Reduce_Check;
+
+end WisiToken.Parse.LR.McKenzie_Recover;
diff --git a/wisitoken-parse-lr-mckenzie_recover.ads
b/wisitoken-parse-lr-mckenzie_recover.ads
new file mode 100644
index 0000000..533ed87
--- /dev/null
+++ b/wisitoken-parse-lr-mckenzie_recover.ads
@@ -0,0 +1,220 @@
+-- Abstract :
+--
+-- Implement [McKenzie] error recovery, extended to parallel parsers.
+--
+-- References:
+--
+-- [McKenzie] McKenzie, Bruce J., Yeatman, Corey, and De Vere,
+-- Lorraine. Error repair in shift reduce parsers. ACM Trans. Prog.
+-- Lang. Syst., 17(4):672-689, July 1995. Described in [Grune 2008] ref 321.
+--
+-- [Grune 2008] Parsing Techniques, A Practical Guide, Second
+-- Edition. Dick Grune, Ceriel J.H. Jacobs.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Parse.LR.Parser;
+with WisiToken.Lexer;
+package WisiToken.Parse.LR.McKenzie_Recover is
+
+ Bad_Config : exception;
+ -- Raised when a config is determined to violate some programming
+ -- convention; abandon it.
+
+ type Recover_Status is
+ (Fail_Check_Delta, Fail_Enqueue_Limit, Fail_Cost, Fail_No_Configs_Left,
Fail_Programmer_Error,
+ Success);
+
+ function Recover (Shared_Parser : in out WisiToken.Parse.LR.Parser.Parser)
return Recover_Status;
+ -- Attempt to modify Parser.Parsers state and Parser.Lookahead to
+ -- allow recovering from an error state.
+
+ Force_Full_Explore : Boolean := False;
+ -- Sometimes recover throws an exception in a race condition case
+ -- that is hard to reproduce. Setting this True ignores all Success,
+ -- so all configs are checked.
+
+ Force_High_Cost_Solutions : Boolean := False;
+ -- Similarly, setting this true keeps all solutions that are found,
+ -- and forces at least three.
+
+private
+
+ ----------
+ -- Visible for language-specific child packages. Alphabetical.
+
+ procedure Check (ID : Token_ID; Expected_ID : in Token_ID)
+ with Inline => True;
+ -- Check that ID = Expected_ID; raise Assertion_Error if not.
+ -- Implemented using 'pragma Assert'.
+
+ function Current_Token
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out Base_Token_Index;
+ Restore_Terminals_Current : out WisiToken.Base_Token_Index;
+ Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type)
+ return Base_Token;
+ -- Return the current token, from either Terminals or Insert_Delete;
+ -- set up for Next_Token.
+ --
+ -- See Next_Token for more info.
+
+ function Current_Token_ID_Peek
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in SAL.Base_Peek_Type)
+ return Token_ID;
+ -- Return the current token, from either Terminals or Insert_Delete,
+ -- without setting up for Next_Token.
+
+ procedure Delete (Config : in out Configuration; ID : in Token_ID);
+ -- Append a Delete op to Config.Ops, and insert it in
+ -- Config.Insert_Deleted in token_index order.
+
+ procedure Find_ID
+ (Config : in Configuration;
+ ID : in Token_ID;
+ Matching_Index : in out SAL.Peek_Type);
+ -- Search Config.Stack for a token with ID, starting at
+ -- Matching_Index. If found, Matching_Index points to it.
+ -- If not found, Matching_Index = Config.Stack.Depth.
+
+ procedure Find_ID
+ (Config : in Configuration;
+ IDs : in Token_ID_Set;
+ Matching_Index : in out SAL.Peek_Type);
+ -- Search Config.Stack for a token with ID in IDs, starting at
+ -- Matching_Index. If found, Matching_Index points to it.
+ -- If not found, Matching_Index = Config.Stack.Depth.
+
+ procedure Find_Descendant_ID
+ (Tree : in Syntax_Trees.Tree;
+ Config : in Configuration;
+ ID : in Token_ID;
+ ID_Set : in Token_ID_Set;
+ Matching_Index : in out SAL.Peek_Type);
+ -- Search Config.Stack for a token with id in ID_Set, with a
+ -- descendant with id = ID, starting at Matching_Index. If found,
+ -- Matching_Index points to it. If not found, Matching_Index =
+ -- Config.Stack.Depth.
+
+ procedure Find_Matching_Name
+ (Config : in Configuration;
+ Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Name : in String;
+ Matching_Name_Index : in out SAL.Peek_Type;
+ Case_Insensitive : in Boolean);
+ -- Search Config.Stack for a token matching Name, starting at
+ -- Matching_Name_Index. If found, Matching_Name_Index points to it.
+ -- If not found, Matching_Name_Index = Config.Stack.Depth.
+
+ procedure Find_Matching_Name
+ (Config : in Configuration;
+ Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Name : in String;
+ Matching_Name_Index : in out SAL.Peek_Type;
+ Other_ID : in Token_ID;
+ Other_Count : out Integer;
+ Case_Insensitive : in Boolean);
+ -- Search Config.Stack for a token matching Name, starting at
+ -- Matching_Name_Index. If found, Matching_Name_Index points to it.
+ -- If not found, Matching_Name_Index = Config.Stack.Depth.
+ --
+ -- Also count tokens with ID = Other_ID.
+
+ procedure Insert (Config : in out Configuration; ID : in Token_ID);
+ -- Append an Insert op to Config.Ops, and insert it in
+ -- Config.Insert_Deleted in token_index order.
+
+ procedure Insert (Config : in out Configuration; IDs : in Token_ID_Array);
+ -- Call Insert for each item in IDs.
+
+ function Next_Token
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out Base_Token_Index;
+ Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
+ Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type)
+ return Base_Token;
+ -- Return the next token, from either Terminals or Insert_Delete;
+ -- update Terminals_Current or Current_Insert_Delete.
+ --
+ -- If result is Insert_Delete.Last_Index, Current_Insert_Delete =
+ -- Last_Index; Insert_Delete is cleared and Current_Insert_Delete
+ -- reset on next call.
+ --
+ -- When done parsing, reset actual Terminals_Current to
+ -- Restore_Terminals_Current.
+ --
+ -- Insert_Delete contains only Insert and Delete ops, in token_index
+ -- order. Those ops are applied when Terminals_Current =
+ -- op.token_index.
+
+ procedure Push_Back (Config : in out Configuration);
+ -- Pop the top Config.Stack item, set Config.Current_Shared_Token to
+ -- the first terminal in that item. If the item is empty,
+ -- Config.Current_Shared_Token is unchanged.
+ --
+ -- If any earlier Insert or Delete items in Config.Ops are for a
+ -- token_index after that first terminal, they are added to
+ -- Config.Insert_Delete in token_index order.
+
+ procedure Push_Back_Check (Config : in out Configuration; Expected_ID : in
Token_ID);
+ -- In effect, call Check and Push_Back.
+
+ procedure Push_Back_Check (Config : in out Configuration; Expected : in
Token_ID_Array);
+ -- Call Push_Back_Check for each item in Expected.
+
+ procedure Put
+ (Message : in String;
+ Trace : in out WisiToken.Trace'Class;
+ Parser_Label : in Natural;
+ Terminals : in Base_Token_Arrays.Vector;
+ Config : in Configuration;
+ Task_ID : in Boolean := True);
+ -- Put Message and an image of Config to Trace.
+
+ procedure Put_Line
+ (Trace : in out WisiToken.Trace'Class;
+ Parser_Label : in Natural;
+ Message : in String;
+ Task_ID : in Boolean := True);
+ -- Put message to Trace, with parser and task info.
+
+ function Undo_Reduce
+ (Stack : in out Recover_Stacks.Stack;
+ Tree : in Syntax_Trees.Tree)
+ return Ada.Containers.Count_Type
+ with Pre => Tree.Is_Nonterm (Stack (1).Tree_Index);
+ -- Undo the reduction that produced the top stack item, return the
+ -- token count for that reduction.
+
+ procedure Undo_Reduce_Check
+ (Config : in out Configuration;
+ Tree : in Syntax_Trees.Tree;
+ Expected : in Token_ID)
+ with Inline => True;
+ -- Call Check, Undo_Reduce.
+
+ procedure Undo_Reduce_Check
+ (Config : in out Configuration;
+ Tree : in Syntax_Trees.Tree;
+ Expected : in Token_ID_Array);
+ -- Call Undo_Reduce_Check for each item in Expected.
+
+end WisiToken.Parse.LR.McKenzie_Recover;
diff --git a/wisitoken-parse-lr-parser.adb b/wisitoken-parse-lr-parser.adb
new file mode 100644
index 0000000..5d3eedb
--- /dev/null
+++ b/wisitoken-parse-lr-parser.adb
@@ -0,0 +1,1105 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2002 - 2005, 2008 - 2015, 2017, 2018 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Calendar.Formatting;
+with Ada.Exceptions;
+with WisiToken.Parse.LR.McKenzie_Recover;
+package body WisiToken.Parse.LR.Parser is
+
+ function Reduce_Stack_1
+ (Current_Parser : in Parser_Lists.Cursor;
+ Action : in Reduce_Action_Rec;
+ Nonterm : out WisiToken.Syntax_Trees.Valid_Node_Index;
+ Lexer : in WisiToken.Lexer.Handle;
+ Trace : in out WisiToken.Trace'Class)
+ return WisiToken.Semantic_Checks.Check_Status_Label
+ is
+ -- We treat semantic check errors as parse errors here, to allow
+ -- error recovery to take better advantage of them. One recovery
+ -- strategy is to fix things so the semantic check passes.
+
+ use all type SAL.Base_Peek_Type;
+ use all type Semantic_Checks.Check_Status_Label;
+ use all type Semantic_Checks.Semantic_Check;
+
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
+ Children_Tree : Syntax_Trees.Valid_Node_Index_Array (1 ..
SAL.Base_Peek_Type (Action.Token_Count));
+ begin
+ for I in reverse Children_Tree'Range loop
+ Children_Tree (I) := Parser_State.Stack.Pop.Token;
+ end loop;
+
+ Nonterm := Parser_State.Tree.Add_Nonterm
+ (Action.Production, Children_Tree, Action.Action,
+ Default_Virtual => Parser_State.Tree.Is_Virtual
(Parser_State.Current_Token));
+ -- Computes Nonterm.Byte_Region, Virtual
+
+ if Trace_Parse > Detail then
+ Trace.Put_Line (Parser_State.Tree.Image (Nonterm,
Trace.Descriptor.all, Include_Children => True));
+ end if;
+
+ if Action.Check = null then
+ return Ok;
+
+ else
+ declare
+ Nonterm_Token : Recover_Token := Parser_State.Tree.Recover_Token
(Nonterm);
+ Children_Token : constant Recover_Token_Array :=
Parser_State.Tree.Recover_Token_Array (Children_Tree);
+ Status : constant Semantic_Checks.Check_Status := Action.Check
+ (Lexer, Nonterm_Token, Children_Token);
+ begin
+ Parser_State.Tree.Set_Name_Region (Nonterm, Nonterm_Token.Name);
+
+ if Trace_Parse > Detail then
+ Trace.Put_Line ("semantic check " & Semantic_Checks.Image
(Status, Trace.Descriptor.all));
+ end if;
+
+ case Status.Label is
+ when Ok =>
+ return Ok;
+
+ when Semantic_Checks.Error =>
+ if Parser_State.Resume_Active then
+ -- Ignore this error; that's how McKenzie_Recover decided
to fix it
+ return Ok;
+
+ else
+ Parser_State.Errors.Append
+ ((Label => Check,
+ First_Terminal => Trace.Descriptor.First_Terminal,
+ Last_Terminal => Trace.Descriptor.Last_Terminal,
+ Check_Status => Status,
+ Recover => (others => <>)));
+ return Status.Label;
+ end if;
+ end case;
+ end;
+ end if;
+ end Reduce_Stack_1;
+
+ procedure Do_Action
+ (Action : in Parse_Action_Rec;
+ Current_Parser : in Parser_Lists.Cursor;
+ Shared_Parser : in LR.Parser.Parser)
+ is
+ use all type Semantic_Checks.Check_Status_Label;
+
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+ Nonterm : WisiToken.Syntax_Trees.Valid_Node_Index;
+ Status : Semantic_Checks.Check_Status_Label;
+ begin
+ if Trace_Parse > Detail then
+ Trace.Put
+ (Integer'Image (Current_Parser.Label) & ": " &
+ Trimmed_Image (Parser_State.Stack.Peek.State) & ": " &
+ Parser_State.Tree.Image (Parser_State.Current_Token,
Trace.Descriptor.all) & " : ");
+ Put (Trace, Action);
+ Trace.New_Line;
+ end if;
+
+ case Action.Verb is
+ when Shift =>
+ Current_Parser.Set_Verb (Shift);
+ Parser_State.Stack.Push ((Action.State, Parser_State.Current_Token));
+ Parser_State.Tree.Set_State (Parser_State.Current_Token,
Action.State);
+
+ when Reduce =>
+ Status := Reduce_Stack_1 (Current_Parser, Action, Nonterm,
Shared_Parser.Lexer, Trace);
+
+ -- Even when Reduce_Stack_1 returns Error, it did reduce the stack,
so
+ -- push Nonterm.
+ Parser_State.Stack.Push
+ ((State => Goto_For
+ (Table => Shared_Parser.Table.all,
+ State => Parser_State.Stack (1).State,
+ ID => Action.Production.LHS),
+ Token => Nonterm));
+
+ Parser_State.Tree.Set_State (Nonterm, Parser_State.Stack (1).State);
+
+ case Status is
+ when Ok =>
+ Current_Parser.Set_Verb (Reduce);
+
+ if Trace_Parse > Detail then
+ Trace.Put_Line (" ... goto state " & Trimmed_Image
(Parser_State.Stack.Peek.State));
+ end if;
+
+ when Semantic_Checks.Error =>
+ Current_Parser.Set_Verb (Error);
+ Parser_State.Zombie_Token_Count := 1;
+ end case;
+
+ when Accept_It =>
+ case Reduce_Stack_1
+ (Current_Parser,
+ (Reduce, Action.Production, Action.Action, Action.Check,
Action.Token_Count),
+ Nonterm, Shared_Parser.Lexer, Trace)
+ is
+ when Ok =>
+ Current_Parser.Set_Verb (Action.Verb);
+
+ Parser_State.Tree.Set_Root (Nonterm);
+
+ when Semantic_Checks.Error =>
+ Current_Parser.Set_Verb (Error);
+ Parser_State.Zombie_Token_Count := 1;
+ end case;
+
+ when Error =>
+ Current_Parser.Set_Verb (Action.Verb);
+
+ Parser_State.Zombie_Token_Count := 1;
+
+ declare
+ Expecting : constant Token_ID_Set := LR.Expecting
+ (Shared_Parser.Table.all,
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;
+
+ procedure Do_Deletes
+ (Shared_Parser : in out LR.Parser.Parser;
+ Parser_State : in out Parser_Lists.Parser_State)
+ is
+ use all type SAL.Base_Peek_Type;
+ begin
+ if Trace_Parse > Extra then
+ Shared_Parser.Trace.Put_Line
+ (Integer'Image (Parser_State.Label) & ": recover_insert_delete: " &
+ Image (Parser_State.Recover_Insert_Delete,
Shared_Parser.Trace.Descriptor.all));
+ end if;
+
+ loop
+ if Parser_State.Recover_Insert_Delete.Length > 0 and then
+ Parser_State.Recover_Insert_Delete.Peek.Op = Delete and then
+ Parser_State.Recover_Insert_Delete.Peek.Token_Index =
+ (if Parser_State.Inc_Shared_Token
+ then Parser_State.Shared_Token + 1
+ else Parser_State.Shared_Token)
+ then
+ Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
+ Parser_State.Recover_Insert_Delete.Drop;
+ else
+ exit;
+ end if;
+ end loop;
+ end Do_Deletes;
+
+ -- Verb: the type of parser cycle to execute;
+ --
+ -- Accept : all Parsers.Verb return Accept - done parsing.
+ --
+ -- Shift : some Parsers.Verb return Shift, all with the same current
+ -- token in Shared_Parser.Terminals.
+ --
+ -- 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.
+ --
+ -- Reduce : some Parsers.Verb return Reduce.
+ --
+ -- Error : all Parsers.Verb return Error.
+ --
+ -- Zombie_Count: count of parsers in Error state
+ procedure Parse_Verb
+ (Shared_Parser : in out LR.Parser.Parser;
+ Verb : out All_Parse_Action_Verbs;
+ Zombie_Count : out SAL.Base_Peek_Type)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ Shift_Count : SAL.Base_Peek_Type := 0;
+ 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;
+ begin
+ Zombie_Count := 0;
+
+ for Parser_State of Shared_Parser.Parsers loop
+ case Parser_State.Verb is
+ when Pause | Shift_Recover | 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;
+
+ if Parser_State.Resume_Active then
+ if Parser_State.Resume_Token_Goal <= Parser_State.Shared_Token
then
+ Parser_State.Resume_Active := False;
+ if Trace_Parse > Detail then
+ Shared_Parser.Trace.Put_Line (Integer'Image
(Parser_State.Label) & ": resume_active: False");
+ end if;
+ else
+ Resume_Active := True;
+ end if;
+ end if;
+
+ when Reduce =>
+ Verb := Reduce;
+ return;
+
+ when Accept_It =>
+ Accept_Count := Accept_Count + 1;
+
+ when Error =>
+ if Shared_Parser.Enable_McKenzie_Recover then
+ -- This parser is waiting for others to error; they can
continue
+ -- parsing.
+ Zombie_Count := Zombie_Count + 1;
+ else
+ Error_Count := Error_Count + 1;
+ end if;
+ end case;
+ end loop;
+
+ if Accept_Count > 0 and Shared_Parser.Parsers.Count = Accept_Count +
Zombie_Count then
+ Verb := Accept_It;
+
+ elsif Shared_Parser.Parsers.Count = Error_Count + Zombie_Count then
+ Verb := Error;
+
+ elsif Shift_Recover_Count > 0 then
+ Verb := Shift_Recover;
+
+ elsif Shift_Count > 0 then
+ Verb := Shift;
+
+ else
+ raise SAL.Programmer_Error;
+ end if;
+
+ if Resume_Active then
+ for Parser_State of Shared_Parser.Parsers loop
+ if Parser_State.Verb in Shift | Shift_Recover and not
Parser_State.Resume_Active then
+ Parser_State.Set_Verb (Pause);
+ end if;
+ end loop;
+ end if;
+ end Parse_Verb;
+
+ ----------
+ -- Public subprograms, declaration order
+
+ overriding procedure Finalize (Object : in out LR.Parser.Parser)
+ is begin
+ Free_Table (Object.Table);
+ end Finalize;
+
+ procedure New_Parser
+ (Parser : out LR.Parser.Parser;
+ Trace : not null access
WisiToken.Trace'Class;
+ Lexer : in
WisiToken.Lexer.Handle;
+ Table : in Parse_Table_Ptr;
+ Language_Fixes : in
Language_Fixes_Access;
+ Language_Use_Minimal_Complete_Actions : in
Language_Use_Minimal_Complete_Actions_Access;
+ Language_String_ID_Set : in
Language_String_ID_Set_Access;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
+ Max_Parallel : in
SAL.Base_Peek_Type := Default_Max_Parallel;
+ Terminate_Same_State : in Boolean
:= True)
+ is
+ use all type Syntax_Trees.User_Data_Access;
+ begin
+ Parser.Lexer := Lexer;
+ Parser.Trace := Trace;
+ Parser.Table := Table;
+ Parser.Language_Fixes := Language_Fixes;
+ Parser.Language_Use_Minimal_Complete_Actions :=
Language_Use_Minimal_Complete_Actions;
+ Parser.Language_String_ID_Set := Language_String_ID_Set;
+ Parser.User_Data := User_Data;
+
+ -- We can't use Table.McKenzie_Param /= Default_McKenzie_Param here,
+ -- because the discriminants are different. We also can't use just
+ -- Table.McKenzie_Param.Cost_Limit /=
+ -- Default_McKenzie_Param.Cost_Limit, because some grammars don't set
+ -- a Cost_Limit, just some other limit.
+ Parser.Enable_McKenzie_Recover :=
+ Table.McKenzie_Param.Cost_Limit /= Default_McKenzie_Param.Cost_Limit or
+ Table.McKenzie_Param.Check_Limit /=
Default_McKenzie_Param.Check_Limit or
+ Table.McKenzie_Param.Check_Delta_Limit /=
Default_McKenzie_Param.Check_Delta_Limit or
+ Table.McKenzie_Param.Enqueue_Limit /=
Default_McKenzie_Param.Enqueue_Limit;
+
+ Parser.Max_Parallel := Max_Parallel;
+ Parser.Terminate_Same_State := Terminate_Same_State;
+
+ if User_Data /= null then
+ User_Data.Set_Lexer_Terminals (Lexer,
Parser.Terminals'Unchecked_Access);
+ end if;
+ end New_Parser;
+
+ overriding procedure Parse (Shared_Parser : aliased in out LR.Parser.Parser)
+ is
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+ use all type Syntax_Trees.User_Data_Access;
+ use all type Ada.Containers.Count_Type;
+ use all type SAL.Base_Peek_Type;
+
+ Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
+
+ Current_Verb : All_Parse_Action_Verbs;
+ Current_Parser : Parser_Lists.Cursor;
+ Action : Parse_Action_Node_Ptr;
+ Zombie_Count : SAL.Base_Peek_Type;
+
+ procedure Check_Error (Check_Parser : in out Parser_Lists.Cursor)
+ is begin
+ if Check_Parser.Verb = Error then
+ -- This parser errored on last input. This is how grammar
conflicts
+ -- are resolved when the input text is valid, in which case we
should
+ -- just terminate this parser. However, this may be due to invalid
+ -- input text, so we keep the parser alive but suspended for a few
+ -- tokens, to see if the other parsers also error, in which case
they
+ -- all participate in error recovery.
+
+ -- We do not create zombie parsers during resume.
+ if not Check_Parser.State_Ref.Resume_Active then
+ -- Parser is now a zombie
+ if Trace_Parse > Detail then
+ Trace.Put_Line (Integer'Image (Check_Parser.Label) & ":
zombie");
+ end if;
+ Check_Parser.Next;
+
+ else
+ if Shared_Parser.Parsers.Count = 1 then
+ if Trace_Parse > Outline then
+ Trace.Put_Line (Integer'Image (Check_Parser.Label) & ":
error during resume");
+ end if;
+ Shared_Parser.Parsers.First_State_Ref.Errors.Append
+ ((Label => LR.Message,
+ First_Terminal => Trace.Descriptor.First_Terminal,
+ Last_Terminal => Trace.Descriptor.Last_Terminal,
+ Recover => <>,
+ Msg => +"error during resume"));
+ raise Syntax_Error;
+
+ else
+ -- This is ok if a conflict occured during resume - we
assume this is
+ -- a branch that failed during recover as well. Otherwise
it's a
+ -- programmer error.
+ if Check_Parser.State_Ref.Conflict_During_Resume then
+ Shared_Parser.Parsers.Terminate_Parser
+ (Check_Parser, "error in conflict during resume",
Shared_Parser.Trace.all);
+ else
+ raise SAL.Programmer_Error with "error during resume";
+ end if;
+ end if;
+ end if;
+ else
+ Check_Parser.Next;
+ end if;
+ end Check_Error;
+
+ begin
+ if Shared_Parser.User_Data /= null then
+ Shared_Parser.User_Data.Reset;
+ end if;
+
+ Shared_Parser.Lex_All;
+
+ Shared_Parser.String_Quote_Checked := Invalid_Line_Number;
+ Shared_Parser.Shared_Tree.Clear;
+ Shared_Parser.Parsers := Parser_Lists.New_List
+ (Shared_Tree => Shared_Parser.Shared_Tree'Unchecked_Access);
+
+ Shared_Parser.Parsers.First.State_Ref.Stack.Push
((Shared_Parser.Table.State_First, others => <>));
+
+ Main_Loop :
+ loop
+ -- exit on Accept_It action or syntax error.
+
+ Parse_Verb (Shared_Parser, Current_Verb, Zombie_Count);
+
+ if Trace_Parse > Extra then
+ Trace.Put_Line ("cycle start; current_verb: " &
Parse_Action_Verbs'Image (Current_Verb));
+ end if;
+
+ case Current_Verb is
+ when Pause =>
+ null;
+
+ when Shift =>
+ -- We just shifted a token; get the next token from
+ -- Shared_Parser.Terminals.
+
+ for Parser_State of Shared_Parser.Parsers loop
+ if Parser_State.Verb = Error then
+ if Shared_Parser.Enable_McKenzie_Recover then
+ Parser_State.Zombie_Token_Count :=
Parser_State.Zombie_Token_Count + 1;
+ if Trace_Parse > Extra then
+ Trace.Put_Line
+ (Integer'Image (Parser_State.Label) & ": zombie (" &
+ Token_Index'Image
+ (Shared_Parser.Table.McKenzie_Param.Check_Limit
- Parser_State.Zombie_Token_Count) &
+ " tokens remaining)");
+ end if;
+ end if;
+
+ elsif Parser_State.Verb = Shift then
+ if Parser_State.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 =
+ (if Parser_State.Inc_Shared_Token
+ then Parser_State.Shared_Token + 1
+ else Parser_State.Shared_Token)
+ then
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
+ (Parser_State.Recover_Insert_Delete.Get.ID);
+
+ 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.
+ 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;
+
+ else
+ -- Set_Verb set the wrong verb.
+ raise SAL.Programmer_Error;
+ end if;
+ end if;
+ end loop;
+
+ when Accept_It =>
+ -- All parsers accepted or are zombies.
+ declare
+ Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
+ Temp : Parser_Lists.Cursor;
+ begin
+ if Count = 1 then
+ -- Nothing more to do
+ if Trace_Parse > Outline then
+ Trace.Put_Line (Integer'Image
(Shared_Parser.Parsers.First.Label) & ": succeed");
+ end if;
+ exit Main_Loop;
+
+ elsif Zombie_Count + 1 = Count then
+ -- All but one are zombies
+ Current_Parser := Shared_Parser.Parsers.First;
+ loop
+ if Current_Parser.Verb = Accept_It then
+ if Trace_Parse > Outline then
+ Trace.Put_Line (Integer'Image
(Current_Parser.Label) & ": succeed with zombies");
+ end if;
+ Current_Parser.Next;
+ else
+ Temp := Current_Parser;
+ Current_Parser.Next;
+ Shared_Parser.Parsers.Terminate_Parser (Temp,
"zombie", Shared_Parser.Trace.all);
+ end if;
+ exit when Current_Parser.Is_Done;
+ end loop;
+
+ exit Main_Loop;
+
+ else
+ -- More than one parser is active.
+ declare
+ use all type Parser_Lists.Cursor;
+ Error_Parser_Count : Integer := (if
Shared_Parser.Lexer.Errors.Length > 0 then 1 else 0);
+ Recover_Ops_Length : Ada.Containers.Count_Type;
+ Min_Recover_Ops_Length : Ada.Containers.Count_Type :=
Ada.Containers.Count_Type'Last;
+ Min_Recover_Ops_Cur : Parser_Lists.Cursor;
+ begin
+ Current_Parser := Shared_Parser.Parsers.First;
+ loop
+ if Current_Parser.Verb = Accept_It then
+ if Current_Parser.State_Ref.Errors.Length > 0 then
+ Error_Parser_Count := Error_Parser_Count + 1;
+ end if;
+ Current_Parser.Next;
+ else
+ Temp := Current_Parser;
+ Current_Parser.Next;
+ Shared_Parser.Parsers.Terminate_Parser (Temp,
"zombie", Shared_Parser.Trace.all);
+ end if;
+ exit when Current_Parser.Is_Done;
+ end loop;
+
+ if Error_Parser_Count > 0 then
+ -- There was at least one error. We assume that
caused the ambiguous
+ -- parse, and we pick the parser with the minimum
recover ops length
+ -- to allow the parse to succeed. We terminate the
other parsers so
+ -- the first parser executes actions.
+ --
+ -- Note all surviving parsers must have the same
error count, or only
+ -- the one with the lowest would get here.
+ Current_Parser := Shared_Parser.Parsers.First;
+ loop
+ Recover_Ops_Length :=
Current_Parser.Max_Recover_Ops_Length;
+ if Recover_Ops_Length < Min_Recover_Ops_Length then
+ Min_Recover_Ops_Length := Recover_Ops_Length;
+ Min_Recover_Ops_Cur := Current_Parser;
+ end if;
+ Current_Parser.Next;
+ exit when Current_Parser.Is_Done;
+ end loop;
+
+ Current_Parser := Shared_Parser.Parsers.First;
+ loop
+ if Current_Parser = Min_Recover_Ops_Cur then
+ Current_Parser.Next;
+ else
+ Temp := Current_Parser;
+ Current_Parser.Next;
+ Shared_Parser.Parsers.Terminate_Parser (Temp,
"errors", Shared_Parser.Trace.all);
+ 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
+ -- There were no previous errors. We allow the parse
to fail, on the
+ -- assumption that an otherwise correct input should
not yield an
+ -- ambiguous parse.
+ declare
+ Token : Base_Token renames Shared_Parser.Terminals
(Shared_Parser.Terminals.Last_Index);
+ begin
+ raise WisiToken.Parse_Error with Error_Message
+ (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
+ "Ambiguous parse:" & SAL.Base_Peek_Type'Image
(Count) & " parsers active.");
+ end;
+ end if;
+ end;
+ end if;
+ end;
+
+ when Reduce =>
+ null;
+
+ when Error =>
+ -- All parsers errored; attempt recovery
+ declare
+ use all type McKenzie_Recover.Recover_Status;
+ Recover_Result : McKenzie_Recover.Recover_Status :=
McKenzie_Recover.Recover_Status'First;
+ begin
+ -- Recover algorithms expect current token at
+ -- Parsers(*).Current_Token, will set
+ -- Parsers(*).Recover_Insert_Delete with new input tokens and
+ -- deletions, adjust Parsers(*).Stack, and set
+ -- Parsers(*).Current_Token and Parsers(*).Verb.
+
+ if Shared_Parser.Enable_McKenzie_Recover then
+ if Trace_Parse > Outline then
+ Trace.Put_Line ("recover");
+ end if;
+ Recover_Result := McKenzie_Recover.Recover (Shared_Parser);
+
+ if Trace_Parse > Outline then
+ if Recover_Result = Success then
+ Trace.Put_Line
+ ("recover: succeed, parser count" &
SAL.Base_Peek_Type'Image (Shared_Parser.Parsers.Count));
+ else
+ Trace.Put_Line
+ ("recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result) &
+ ", parser count" & SAL.Base_Peek_Type'Image
(Shared_Parser.Parsers.Count));
+ end if;
+ end if;
+
+ if Ada.Text_IO.Is_Open (Shared_Parser.Recover_Log_File) then
+ declare
+ use Ada.Text_IO;
+ 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) & " '" &
+ Shared_Parser.Lexer.File_Name & "'");
+
+ for Parser of Shared_Parser.Parsers loop
+ 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;
+ 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");
+ 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;
+
+ 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;
+
+ when Error =>
+ -- Force this parser to be terminated.
+ if Shared_Parser.Enable_McKenzie_Recover then
+ Parser_State.Zombie_Token_Count :=
Shared_Parser.Table.McKenzie_Param.Check_Limit + 1;
+ end if;
+
+ when Shift =>
+ if Current_Verb /= Reduce then
+ Current_Verb := Shift;
+ end if;
+
+ when Pause | Accept_It =>
+ raise SAL.Programmer_Error;
+ end case;
+ end loop;
+
+ if Shift_Recover_Count > 0 then
+ Current_Verb := Shift_Recover;
+ end if;
+ end;
+
+ else
+ -- Terminate with error. Parser_State has all the required
info on
+ -- the original error (recorded by Error in Do_Action);
report reason
+ -- recover failed.
+ for Parser_State of Shared_Parser.Parsers loop
+ Parser_State.Errors.Append
+ ((Label => LR.Message,
+ First_Terminal => Trace.Descriptor.First_Terminal,
+ Last_Terminal => Trace.Descriptor.Last_Terminal,
+ Recover => <>,
+ Msg => +"recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result)));
+ end loop;
+ raise WisiToken.Syntax_Error;
+ end if;
+ end;
+ end case;
+
+ -- We don't use 'for Parser_State of Parsers loop' here,
+ -- because terminate on error and spawn on conflict require
+ -- changing the parser list.
+ Current_Parser := Shared_Parser.Parsers.First;
+ Action_Loop :
+ loop
+ exit Action_Loop when Current_Parser.Is_Done;
+
+ if Shared_Parser.Terminate_Same_State and
+ Current_Verb in Shift | Shift_Recover 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);
+ -- If Duplicate_State terminated Current_Parser,
Current_Parser now
+ -- points to the next parser. Otherwise it is unchanged.
+ end if;
+
+ exit Action_Loop when Current_Parser.Is_Done;
+
+ if Trace_Parse > Extra then
+ 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 = Error then
+ -- This parser is a zombie; see Check_Error above.
+ --
+ -- Check to see if it is time to terminate it
+ if Shared_Parser.Enable_McKenzie_Recover and then
+ Current_Parser.State_Ref.Zombie_Token_Count <=
Shared_Parser.Table.McKenzie_Param.Check_Limit
+ then
+ if Trace_Parse > Detail then
+ Trace.Put_Line (Integer'Image (Current_Parser.Label) & ":
zombie");
+ end if;
+
+ Current_Parser.Next;
+ else
+ Shared_Parser.Parsers.Terminate_Parser (Current_Parser,
"zombie", Shared_Parser.Trace.all);
+ end if;
+
+ elsif 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).
+
+ Current_Parser.State_Ref.Conflict_During_Resume :=
Current_Parser.State_Ref.Resume_Active;
+
+ if Shared_Parser.Parsers.Count = Shared_Parser.Max_Parallel
then
+ -- If errors were recovered, terminate a parser that
used the
+ -- highest cost solution.
+ declare
+ use all type WisiToken.Parse.LR.Parser_Lists.Cursor;
+ Max_Recover_Cost : Integer := 0;
+ Max_Parser : Parser_Lists.Cursor;
+ Cur : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
+ begin
+ loop
+ exit when Cur.Is_Done;
+ if Cur.Total_Recover_Cost > Max_Recover_Cost then
+ Max_Parser := Cur;
+ Max_Recover_Cost := Cur.Total_Recover_Cost;
+ end if;
+ Cur.Next;
+ end loop;
+
+ if Max_Recover_Cost > 0 then
+ if Max_Parser = Current_Parser then
+ Current_Parser.Next;
+ Shared_Parser.Parsers.Terminate_Parser
+ (Current_Parser, "too many parsers; max error
repair cost", Trace);
+ exit Action_Loop;
+ else
+ Shared_Parser.Parsers.Terminate_Parser
+ (Max_Parser, "too many parsers; max error
repair cost", Trace);
+ end if;
+ end if;
+ end;
+ end if;
+
+ if Shared_Parser.Parsers.Count = Shared_Parser.Max_Parallel
then
+ declare
+ Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
+ Token : Base_Token renames Shared_Parser.Terminals
(Parser_State.Shared_Token);
+ begin
+ raise WisiToken.Parse_Error with Error_Message
+ (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
+ "too many parallel parsers required in grammar
state" &
+ State_Index'Image (Parser_State.Stack.Peek.State)
&
+ "; simplify grammar, or increase max-parallel (" &
+ SAL.Base_Peek_Type'Image
(Shared_Parser.Max_Parallel) & ")");
+ end;
+
+ else
+ if Trace_Parse > Outline then
+ 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)");
+ end if;
+
+ Shared_Parser.Parsers.Prepend_Copy (Current_Parser);
+ Do_Action (Action.Next.Item, Shared_Parser.Parsers.First,
Shared_Parser);
+
+ -- We must terminate error parsers immediately in order
to avoid
+ -- zombie parsers during recovery.
+ declare
+ Temp : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
+ begin
+ Check_Error (Temp);
+ end;
+ end if;
+ end if;
+
+ Do_Action (Action.Item, Current_Parser, Shared_Parser);
+ Check_Error (Current_Parser);
+
+ else
+ -- Current parser is waiting for others to catch up
+ Current_Parser.Next;
+ end if;
+ end loop Action_Loop;
+ 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.
+ exception
+ when Syntax_Error | WisiToken.Parse_Error =>
+ 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));
+
+ -- Emacs displays the exception message in the echo area; easy to
miss
+ raise WisiToken.Parse_Error with Msg;
+ end;
+ end Parse;
+
+ 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;
+
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ procedure Process_Node
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Syntax_Trees.Valid_Node_Index)
+ is
+ use all type Syntax_Trees.Node_Label;
+ begin
+ if Tree.Label (Node) /= Nonterm then
+ return;
+ end if;
+
+ declare
+ 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 (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;
+ end if;
+
+ for Parser_State of Parser.Parsers loop
+ if Trace_Action > Outline then
+ Parser.Trace.Put_Line
+ (Integer'Image (Parser_State.Label) & ": root node: " &
Parser_State.Tree.Image
+ (Parser_State.Tree.Root, Descriptor));
+ end if;
+
+ Parser_State.Tree.Process_Tree (Process_Node'Access);
+ end loop;
+ end if;
+ end Execute_Actions;
+
+ overriding function Any_Errors (Parser : in LR.Parser.Parser) return Boolean
+ is
+ use all type SAL.Base_Peek_Type;
+ use all type Ada.Containers.Count_Type;
+ Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
+ begin
+ pragma Assert (Parser_State.Tree.Flushed);
+ return Parser.Parsers.Count > 1 or Parser_State.Errors.Length > 0 or
Parser.Lexer.Errors.Length > 0;
+ end Any_Errors;
+
+ overriding procedure Put_Errors (Parser : in LR.Parser.Parser)
+ is
+ use all type SAL.Base_Peek_Type;
+ use Ada.Text_IO;
+
+ Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+ begin
+ for Item of Parser.Lexer.Errors loop
+ Put_Line
+ (Current_Error,
+ Parser.Lexer.File_Name & ":0:0: lexer unrecognized character at" &
Buffer_Pos'Image (Item.Char_Pos));
+ end loop;
+
+ for Item of Parser_State.Errors loop
+ case Item.Label is
+ when Action =>
+ declare
+ Index : constant Base_Token_Index :=
Parser_State.Tree.Min_Terminal_Index (Item.Error_Token);
+ begin
+ if Index = Invalid_Token_Index then
+ -- Error_Token is virtual
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Parser.Lexer.File_Name, 1, 0,
+ "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
+ ", found " & Image (Parser_State.Tree.ID
(Item.Error_Token), Descriptor)));
+ else
+ declare
+ Token : Base_Token renames Parser.Terminals (Index);
+ begin
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Parser.Lexer.File_Name, Token.Line, Token.Column,
+ "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
+ ", found '" & Parser.Lexer.Buffer_Text
(Token.Byte_Region) & "'"));
+ end;
+ end if;
+ end;
+ when Check =>
+ Put_Line
+ (Current_Error,
+ Parser.Lexer.File_Name & ":0:0: semantic check error: " &
+ Semantic_Checks.Image (Item.Check_Status, Descriptor));
+ when Message =>
+ Put_Line (Current_Error, -Item.Msg);
+ end case;
+
+ if Item.Recover.Stack.Depth /= 0 then
+ Put_Line (Current_Error, " recovered: " & Image
(Item.Recover.Ops, Descriptor));
+ end if;
+ end loop;
+ end Put_Errors;
+
+end WisiToken.Parse.LR.Parser;
diff --git a/wisitoken-parse-lr-parser.ads b/wisitoken-parse-lr-parser.ads
new file mode 100644
index 0000000..8aa5906
--- /dev/null
+++ b/wisitoken-parse-lr-parser.ads
@@ -0,0 +1,145 @@
+-- Abstract :
+--
+-- A generalized LR parser.
+--
+-- 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 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Parse.LR.Parser_Lists;
+with WisiToken.Lexer;
+with WisiToken.Parse;
+with WisiToken.Syntax_Trees;
+package WisiToken.Parse.LR.Parser is
+
+ Default_Max_Parallel : constant := 15;
+
+ type Language_Fixes_Access is access procedure
+ (Trace : in out WisiToken.Trace'Class;
+ Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Parser_Label : in Natural;
+ Parse_Table : in WisiToken.Parse.LR.Parse_Table;
+ Terminals : in Base_Token_Arrays.Vector;
+ Tree : in Syntax_Trees.Tree;
+ Local_Config_Heap : in out Config_Heaps.Heap_Type;
+ Config : in Configuration);
+ -- Config encountered a parse table Error action, or failed a
+ -- semantic check; attempt to provide a language-specific fix,
+ -- enqueuing new configs on Local_Config_Heap.
+ --
+ -- For a failed semantic check, Config.Stack is in the pre-reduce
+ -- state, Config.Error_Token gives the nonterm token,
+ -- Config.Check_Token_Count the token count for the reduce. May be
+ -- called with Nonterm.Virtual = True or Tree.Valid_Indices (stack
+ -- top token_count items) false.
+ --
+ -- 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.
+ --
+ -- For example, if Next_Token is a block end, return True to complete
+ -- the current statement/declaration as quickly as possible..
+
+ type Language_String_ID_Set_Access is access function
+ (Descriptor : in WisiToken.Descriptor;
+ String_Literal_ID : in Token_ID)
+ return Token_ID_Set;
+ -- Return a Token_ID_Set containing String_Literal_ID and
+ -- nonterminals that can contain String_Literal_ID as part of an
+ -- expression.
+
+ type Post_Recover_Access is access procedure;
+
+ type Parser is new WisiToken.Parse.Base_Parser with record
+ Table : Parse_Table_Ptr;
+ Language_Fixes : Language_Fixes_Access;
+ Language_Use_Minimal_Complete_Actions :
Language_Use_Minimal_Complete_Actions_Access;
+ Language_String_ID_Set : Language_String_ID_Set_Access;
+
+ String_Quote_Checked : Line_Number_Type := Invalid_Line_Number;
+ -- Max line checked for missing string quote.
+
+ Post_Recover : Post_Recover_Access;
+ -- Gather data for tests.
+
+ Shared_Tree : aliased Syntax_Trees.Base_Tree;
+ -- Each parser (normal and recover) has its own branched syntax tree,
+ -- all branched from this tree. Terminals are added to the tree when
+ -- they become the current token.
+ --
+ -- It is never the case that terminals are added to this shared tree
+ -- when there is more than one task active, so we don't need a
+ -- protected tree.
+ --
+ -- See WisiToken.LR.Parser_Lists Parser_State for more discussion of
+ -- Shared_Tree.
+
+ Parsers : aliased Parser_Lists.List;
+
+ Max_Parallel : SAL.Base_Peek_Type;
+ Terminate_Same_State : Boolean;
+ Enable_McKenzie_Recover : Boolean;
+ Recover_Log_File : Ada.Text_IO.File_Type;
+ end record;
+
+ overriding procedure Finalize (Object : in out LR.Parser.Parser);
+ -- Deep free Object.Table.
+
+ procedure New_Parser
+ (Parser : out LR.Parser.Parser;
+ Trace : not null access
WisiToken.Trace'Class;
+ Lexer : in
WisiToken.Lexer.Handle;
+ Table : in Parse_Table_Ptr;
+ Language_Fixes : in
Language_Fixes_Access;
+ Language_Use_Minimal_Complete_Actions : in
Language_Use_Minimal_Complete_Actions_Access;
+ Language_String_ID_Set : in
Language_String_ID_Set_Access;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
+ Max_Parallel : in
SAL.Base_Peek_Type := Default_Max_Parallel;
+ Terminate_Same_State : in Boolean
:= True);
+
+ overriding procedure Parse (Shared_Parser : aliased in out
LR.Parser.Parser);
+ -- Attempt a parse. Calls Parser.Lexer.Reset, runs lexer to end of
+ -- input setting Shared_Parser.Terminals, then parses tokens.
+ --
+ -- If an error is encountered, Parser.Lexer_Errors and
+ -- Parsers(*).Errors contain information about the errors. If a
+ -- recover strategy succeeds, no exception is raised. If recover does
+ -- not succeed, raises Syntax_Error.
+ --
+ -- For errors where no recovery is possible, raises Parse_Error with
+ -- an appropriate error message.
+
+ overriding procedure Execute_Actions (Parser : in out LR.Parser.Parser);
+ -- Execute the grammar actions in Parser.
+
+ overriding function Any_Errors (Parser : in LR.Parser.Parser) return
Boolean;
+ -- Return True if any errors where encountered, recovered or not.
+
+ overriding procedure Put_Errors (Parser : in LR.Parser.Parser);
+ -- Put user-friendly error messages from the parse to
+ -- Ada.Text_IO.Current_Error.
+
+end WisiToken.Parse.LR.Parser;
diff --git a/wisitoken-parse-lr-parser_lists.adb
b/wisitoken-parse-lr-parser_lists.adb
new file mode 100644
index 0000000..b2ba8be
--- /dev/null
+++ b/wisitoken-parse-lr-parser_lists.adb
@@ -0,0 +1,405 @@
+-- Abstract :
+--
+-- see spec
+--
+-- Copyright (C) 2014-2018 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
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Parse.LR.Parser_Lists is
+
+ function Parser_Stack_Image
+ (Stack : in Parser_Stacks.Stack;
+ Descriptor : in WisiToken.Descriptor;
+ Tree : in Syntax_Trees.Tree;
+ Depth : in SAL.Base_Peek_Type := 0)
+ return String
+ is
+ use all type Syntax_Trees.Node_Index;
+ use all type SAL.Base_Peek_Type;
+ use Ada.Strings.Unbounded;
+
+ Last : constant SAL.Base_Peek_Type :=
+ (if Depth = 0
+ then Stack.Depth
+ else SAL.Base_Peek_Type'Min (Depth, Stack.Depth));
+
+ Result : Unbounded_String := +"(";
+ begin
+ for I in 1 .. Last loop
+ declare
+ Item : Parser_Stack_Item renames Stack.Peek (I);
+ begin
+ Result := Result &
+ ((if Item.State = Unknown_State then " " else Trimmed_Image
(Item.State)) & " :" &
+ (if I = Stack.Depth
+ then ""
+ else
+ (if Item.Token = Syntax_Trees.Invalid_Node_Index -- From
recover fast-forward
+ then ""
+ else Tree.Image (Item.Token, Descriptor) & ", ")));
+ end;
+ end loop;
+ return To_String (Result & ")");
+ end Parser_Stack_Image;
+
+ function New_List (Shared_Tree : in Syntax_Trees.Base_Tree_Access) return
List
+ is
+ First_Parser_Label : constant := 0;
+ Parser : Parser_State := (Label => First_Parser_Label, others => <>);
+ begin
+ Parser.Tree.Initialize (Shared_Tree, Flush => True);
+
+ return Result : List
+ do
+ Result.Parser_Label := First_Parser_Label;
+
+ Result.Elements.Append (Parser);
+ end return;
+ end New_List;
+
+ function Last_Label (List : in Parser_Lists.List) return Natural
+ is begin
+ return List.Parser_Label;
+ end Last_Label;
+
+ function Count (List : in Parser_Lists.List) return SAL.Base_Peek_Type
+ is begin
+ return List.Elements.Length;
+ end Count;
+
+ function First (List : aliased in out Parser_Lists.List'Class) return Cursor
+ is begin
+ return (Elements => List.Elements'Access, Ptr => List.Elements.First);
+ end First;
+
+ procedure Next (Cursor : in out Parser_Lists.Cursor)
+ is begin
+ Parser_State_Lists.Next (Cursor.Ptr);
+ end Next;
+
+ function Is_Done (Cursor : in Parser_Lists.Cursor) return Boolean
+ is
+ use Parser_State_Lists;
+ begin
+ return Cursor.Ptr = No_Element;
+ end Is_Done;
+
+ function Active_Parser_Count (Cursor : in Parser_Lists.Cursor) return
SAL.Base_Peek_Type
+ is begin
+ return Cursor.Elements.Length;
+ end Active_Parser_Count;
+
+ function Label (Cursor : in Parser_Lists.Cursor) return Natural
+ is begin
+ return Parser_State_Lists.Constant_Reference (Cursor.Ptr).Label;
+ end Label;
+
+ function Total_Recover_Cost (Cursor : in Parser_Lists.Cursor) return Integer
+ is
+ Result : Integer := 0;
+ begin
+ for Error of Parser_State_Lists.Constant_Reference (Cursor.Ptr).Errors
loop
+ Result := Error.Recover.Cost;
+ end loop;
+ return Result;
+ end Total_Recover_Cost;
+
+ function Max_Recover_Ops_Length (Cursor : in Parser_Lists.Cursor) return
Ada.Containers.Count_Type
+ is
+ use Ada.Containers;
+ Result : Count_Type := 0;
+ Errors : Parse_Error_Lists.List renames
Parser_State_Lists.Constant_Reference (Cursor.Ptr).Errors;
+ begin
+ for Error of Errors loop
+ if Error.Recover.Ops.Length > Result then
+ Result := Error.Recover.Ops.Length;
+ end if;
+ end loop;
+ return Result;
+ end Max_Recover_Ops_Length;
+
+ procedure Set_Verb (Cursor : in Parser_Lists.Cursor; Verb : in
All_Parse_Action_Verbs)
+ is begin
+ Parser_State_Lists.Reference (Cursor.Ptr).Verb := Verb;
+ end Set_Verb;
+
+ function Verb (Cursor : in Parser_Lists.Cursor) return
All_Parse_Action_Verbs
+ 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)
+ is
+ use all type SAL.Base_Peek_Type;
+ 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 ""));
+ end if;
+
+ Current.Free;
+
+ if Parsers.Count = 1 then
+ Parsers.First.State_Ref.Tree.Flush;
+ end if;
+ end Terminate_Parser;
+
+ procedure Duplicate_State
+ (Parsers : in out List;
+ Current : in out Cursor'Class;
+ Trace : in out WisiToken.Trace'Class)
+ is
+ use all type SAL.Base_Peek_Type;
+ use all type Ada.Containers.Count_Type;
+
+ function Compare
+ (Stack_1 : in Parser_Stacks.Stack;
+ Tree_1 : in Syntax_Trees.Tree;
+ Stack_2 : in Parser_Stacks.Stack;
+ Tree_2 : in Syntax_Trees.Tree)
+ return Boolean
+ is
+ begin
+ if Stack_1.Depth /= Stack_2.Depth then
+ return False;
+ else
+ for I in reverse 1 .. Stack_1.Depth - 1 loop
+ -- Assume they differ near the top; no point in comparing
bottom
+ -- item. The syntax trees will differ even if the tokens on
the stack
+ -- are the same, so compare the tokens.
+ declare
+ Item_1 : Parser_Stack_Item renames Stack_1 (I);
+ Item_2 : Parser_Stack_Item renames Stack_2 (I);
+ begin
+ if Item_1.State /= Item_2.State then
+ return False;
+ else
+ if not Syntax_Trees.Same_Token (Tree_1, Item_1.Token,
Tree_2, Item_2.Token) then
+ return False;
+ end if;
+ end if;
+ end;
+ end loop;
+ return True;
+ end if;
+ end Compare;
+
+ Other : Cursor := Parsers.First;
+ begin
+ loop
+ exit when Other.Is_Done;
+ declare
+ Other_Parser : Parser_State renames Other.State_Ref;
+ begin
+ if Other.Label /= Current.Label and then
+ Other.Verb /= Error and then
+ Compare
+ (Other_Parser.Stack, Other_Parser.Tree,
Current.State_Ref.Stack, Current.State_Ref.Tree)
+ then
+ exit;
+ end if;
+ end;
+ Other.Next;
+ end loop;
+
+ if not Other.Is_Done then
+ -- Both have the same number of errors, otherwise one would have been
+ -- 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);
+ else
+ if Other.Max_Recover_Ops_Length >
Current.Max_Recover_Ops_Length then
+ null;
+ else
+ Other := Cursor (Current);
+ Current.Next;
+ end if;
+ Parsers.Terminate_Parser (Other, "duplicate state: ops length",
Trace);
+ end if;
+ else
+ if Other.Total_Recover_Cost > Current.Total_Recover_Cost then
+ null;
+ else
+ Other := Cursor (Current);
+ Current.Next;
+ end if;
+ Parsers.Terminate_Parser (Other, "duplicate state: cost", Trace);
+ end if;
+ end if;
+ end Duplicate_State;
+
+ function State_Ref (Position : in Cursor) return State_Reference
+ is begin
+ return (Element => Parser_State_Lists.Constant_Reference
(Position.Ptr).Element);
+ end State_Ref;
+
+ function First_State_Ref (List : in Parser_Lists.List'Class) return
State_Reference
+ is begin
+ return (Element => Parser_State_Lists.Constant_Reference
(List.Elements.First).Element);
+ end First_State_Ref;
+
+ function First_Constant_State_Ref (List : in Parser_Lists.List'Class)
return Constant_State_Reference
+ is begin
+ return (Element => Parser_State_Lists.Constant_Reference
(List.Elements.First).Element);
+ end First_Constant_State_Ref;
+
+ procedure Put_Top_10 (Trace : in out WisiToken.Trace'Class; Cursor : in
Parser_Lists.Cursor)
+ is
+ Parser_State : Parser_Lists.Parser_State renames
Parser_State_Lists.Constant_Reference (Cursor.Ptr);
+ begin
+ Trace.Put (Natural'Image (Parser_State.Label) & " stack: ");
+ Trace.Put_Line (Image (Parser_State.Stack, Trace.Descriptor.all,
Parser_State.Tree, Depth => 10));
+ end Put_Top_10;
+
+ procedure Prepend_Copy
+ (List : in out Parser_Lists.List;
+ Cursor : in Parser_Lists.Cursor'Class)
+ is
+ New_Item : Parser_State;
+ begin
+ List.Parser_Label := List.Parser_Label + 1;
+ declare
+ Item : Parser_State renames Parser_State_Lists.Reference
(Cursor.Ptr).Element.all;
+ -- We can't do 'Prepend' in the scope of this 'renames';
+ -- that would be tampering with cursors.
+ begin
+ Item.Tree.Set_Flush_False;
+
+ -- We specify all items individually, rather copy Item and then
+ -- override a few, to avoid copying large items like Recover.
+ -- We copy Recover.Enqueue_Count, .Check_Count for unit tests.
+ New_Item :=
+ (Shared_Token => Item.Shared_Token,
+ Recover_Insert_Delete => Item.Recover_Insert_Delete,
+ Current_Token => Item.Current_Token,
+ Inc_Shared_Token => Item.Inc_Shared_Token,
+ Stack => Item.Stack,
+ Tree => Item.Tree,
+ Recover =>
+ (Enqueue_Count => Item.Recover.Enqueue_Count,
+ Check_Count => Item.Recover.Check_Count,
+ others => <>),
+ Resume_Active => Item.Resume_Active,
+ Resume_Token_Goal => Item.Resume_Token_Goal,
+ Conflict_During_Resume => Item.Conflict_During_Resume,
+ Zombie_Token_Count => 0,
+ Errors => Item.Errors,
+ Label => List.Parser_Label,
+ Verb => Item.Verb);
+ end;
+ List.Elements.Prepend (New_Item);
+ end Prepend_Copy;
+
+ procedure Free (Cursor : in out Parser_Lists.Cursor'Class)
+ is
+ Temp : Parser_State_Lists.Cursor := Cursor.Ptr;
+ begin
+ Parser_State_Lists.Next (Cursor.Ptr);
+ Parser_State_Lists.Delete (Cursor.Elements.all, Temp);
+ end Free;
+
+ ----------
+ -- stuff for iterators
+
+ function To_Cursor (Ptr : in Parser_Node_Access) return Cursor
+ is begin
+ return (Ptr.Elements, Ptr.Ptr);
+ end To_Cursor;
+
+ function Constant_Reference
+ (Container : aliased in List'Class;
+ Position : in Parser_Node_Access)
+ return Constant_Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ return (Element => Parser_State_Lists.Constant_Reference
(Position.Ptr).Element);
+ end Constant_Reference;
+
+ function Reference
+ (Container : aliased in out List'Class;
+ Position : in Parser_Node_Access)
+ return State_Reference
+ is
+ pragma Unreferenced (Container);
+ begin
+ return (Element => Parser_State_Lists.Reference (Position.Ptr).Element);
+ end Reference;
+
+ function Persistent_State_Ref (Position : in Parser_Node_Access) return
State_Access
+ is begin
+ return State_Access (Parser_State_Lists.Persistent_Ref (Position.Ptr));
+ end Persistent_State_Ref;
+
+ type List_Access is access all List;
+
+ type Iterator is new Iterator_Interfaces.Forward_Iterator with record
+ Container : List_Access;
+ end record;
+
+ overriding function First (Object : Iterator) return Parser_Node_Access;
+ overriding function Next
+ (Object : in Iterator;
+ Position : in Parser_Node_Access)
+ return Parser_Node_Access;
+
+ overriding function First (Object : Iterator) return Parser_Node_Access
+ is begin
+ return (Elements => Object.Container.Elements'Access, Ptr =>
Object.Container.Elements.First);
+ end First;
+
+ overriding function Next
+ (Object : in Iterator;
+ Position : in Parser_Node_Access)
+ return Parser_Node_Access
+ is
+ pragma Unreferenced (Object);
+ begin
+ return (Position.Elements, Parser_State_Lists.Next (Position.Ptr));
+ end Next;
+
+ function Iterate (Container : aliased in out List) return
Iterator_Interfaces.Forward_Iterator'Class
+ is begin
+ return Iterator'(Container => Container'Access);
+ end Iterate;
+
+ function Has_Element (Iterator : in Parser_Node_Access) return Boolean
+ is begin
+ return Parser_State_Lists.Has_Element (Iterator.Ptr);
+ end Has_Element;
+
+ function Label (Iterator : in Parser_State) return Natural
+ is begin
+ return Iterator.Label;
+ end Label;
+
+ function Verb (Iterator : in Parser_State) return All_Parse_Action_Verbs
+ is begin
+ return Iterator.Verb;
+ end Verb;
+
+ procedure Set_Verb (Iterator : in out Parser_State; Verb : in
All_Parse_Action_Verbs)
+ is begin
+ Iterator.Verb := Verb;
+ end Set_Verb;
+
+end WisiToken.Parse.LR.Parser_Lists;
diff --git a/wisitoken-parse-lr-parser_lists.ads
b/wisitoken-parse-lr-parser_lists.ads
new file mode 100644
index 0000000..6c44892
--- /dev/null
+++ b/wisitoken-parse-lr-parser_lists.ads
@@ -0,0 +1,260 @@
+-- Abstract :
+--
+-- Generalized LR parser state.
+--
+-- Copyright (C) 2014-2015, 2017, 2018 Stephe Leake
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Iterator_Interfaces;
+with SAL.Gen_Indefinite_Doubly_Linked_Lists;
+with WisiToken.Syntax_Trees;
+package WisiToken.Parse.LR.Parser_Lists is
+
+ type Parser_Stack_Item is record
+ State : Unknown_State_Index := Unknown_State;
+ Token : Syntax_Trees.Node_Index := Syntax_Trees.Invalid_Node_Index;
+ end record;
+
+ package Parser_Stacks is new SAL.Gen_Unbounded_Definite_Stacks
(Parser_Stack_Item);
+
+ function Parser_Stack_Image
+ (Stack : in Parser_Stacks.Stack;
+ Descriptor : in WisiToken.Descriptor;
+ Tree : in Syntax_Trees.Tree;
+ Depth : in SAL.Base_Peek_Type := 0)
+ return String;
+ -- If Depth = 0, put all of Stack. Otherwise put Min (Depth,
+ -- Stack.Depth) items.
+ --
+ -- Unique name for calling from debugger
+
+ function Image
+ (Stack : in Parser_Stacks.Stack;
+ Descriptor : in WisiToken.Descriptor;
+ Tree : in Syntax_Trees.Tree;
+ Depth : in SAL.Base_Peek_Type := 0)
+ return String renames Parser_Stack_Image;
+
+ type Base_Parser_State is tagged
+ record
+ -- Visible components for direct access
+
+ Shared_Token : Base_Token_Index := Invalid_Token_Index;
+ -- Last token read from Shared_Parser.Terminals.
+
+ 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.
+
+ Current_Token : Syntax_Trees.Node_Index :=
Syntax_Trees.Invalid_Node_Index;
+ -- Current terminal, in Tree
+
+ Inc_Shared_Token : Boolean := True;
+
+ Stack : Parser_Stacks.Stack;
+ -- There is no need to use a branched stack; max stack length is
+ -- proportional to source text nesting depth, not source text length.
+
+ Tree : Syntax_Trees.Tree;
+ -- We use a branched tree to avoid copying large trees for each
+ -- spawned parser; tree size is proportional to source text size. In
+ -- normal parsing, parallel parsers are short-lived; they each process
+ -- a few tokens, to resolve a grammar conflict.
+ --
+ -- When there is only one parser, tree nodes are written directly to
+ -- the shared tree (via the branched tree, with Flush => True).
+ --
+ -- When there is more than one, tree nodes are written to the
+ -- branched tree. Then when all but one parsers are terminated, the
+ -- remaining branched tree is flushed into the shared tree.
+
+ Recover : aliased LR.McKenzie_Data := (others => <>);
+
+ Zombie_Token_Count : Base_Token_Index := 0;
+ -- If Zombie_Token_Count > 0, this parser has errored, but is waiting
+ -- to see if other parsers do also.
+
+ Resume_Active : Boolean := False;
+ Resume_Token_Goal : Base_Token_Index := Invalid_Token_Index;
+ Conflict_During_Resume : Boolean := False;
+ -- Resume is complete for this parser Shared_Token reaches this
+ -- Resume_Token_Goal.
+
+ Errors : Parse_Error_Lists.List;
+ end record;
+
+ type Parser_State is new Base_Parser_State with private;
+ type State_Access is access all Parser_State;
+
+ type List is tagged private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Parser_State;
+
+ function New_List (Shared_Tree : in Syntax_Trees.Base_Tree_Access) return
List;
+
+ function Last_Label (List : in Parser_Lists.List) return Natural;
+
+ function Count (List : in Parser_Lists.List) return SAL.Base_Peek_Type;
+
+ type Cursor is tagged private;
+
+ function First (List : aliased in out Parser_Lists.List'Class) return
Cursor;
+ procedure Next (Cursor : in out Parser_Lists.Cursor);
+ function Is_Done (Cursor : in Parser_Lists.Cursor) return Boolean;
+ function Has_Element (Cursor : in Parser_Lists.Cursor) return Boolean is
(not Is_Done (Cursor));
+
+ function Active_Parser_Count (Cursor : in Parser_Lists.Cursor) return
SAL.Base_Peek_Type;
+
+ function Label (Cursor : in Parser_Lists.Cursor) return Natural;
+ function Total_Recover_Cost (Cursor : in Parser_Lists.Cursor) return
Integer;
+ function Max_Recover_Ops_Length (Cursor : in Parser_Lists.Cursor) return
Ada.Containers.Count_Type;
+
+ procedure Set_Verb (Cursor : in Parser_Lists.Cursor; Verb : in
All_Parse_Action_Verbs);
+ function Verb (Cursor : in Parser_Lists.Cursor) return
All_Parse_Action_Verbs;
+
+ procedure Terminate_Parser
+ (Parsers : in out List;
+ Current : in out Cursor'Class;
+ Message : in String;
+ Trace : in out WisiToken.Trace'Class);
+ -- Terminate Current. Current is set to no element.
+
+ procedure Duplicate_State
+ (Parsers : in out List;
+ Current : in out Cursor'Class;
+ Trace : in out WisiToken.Trace'Class);
+ -- 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.
+
+ type State_Reference (Element : not null access Parser_State) is null record
+ with Implicit_Dereference => Element;
+
+ function State_Ref (Position : in Cursor) return State_Reference;
+ -- Direct access to visible components of Parser_State
+
+ function First_State_Ref (List : in Parser_Lists.List'Class) return
State_Reference;
+ -- Direct access to visible components of first parser's Parser_State
+
+ type Constant_State_Reference (Element : not null access constant
Parser_State) is null record
+ with Implicit_Dereference => Element;
+
+ function First_Constant_State_Ref (List : in Parser_Lists.List'Class)
return Constant_State_Reference;
+ -- Direct access to visible components of first parser's Parser_State
+
+ procedure Put_Top_10 (Trace : in out WisiToken.Trace'Class; Cursor : in
Parser_Lists.Cursor);
+ -- Put image of top 10 stack items to Trace.
+
+ procedure Prepend_Copy (List : in out Parser_Lists.List; Cursor : in
Parser_Lists.Cursor'Class);
+ -- Copy parser at Cursor, prepend to current list. New copy will not
+ -- appear in Cursor.Next ...; it is accessible as First (List).
+ --
+ -- Copy.Recover is set to default.
+
+ procedure Free (Cursor : in out Parser_Lists.Cursor'Class);
+ -- Delete the Cursor parser. It will not appear in future
+ -- iterations. On return, Cursor points to next parser, or none.
+
+ ----------
+ -- Stuff for iterators, to allow
+ -- 'for Parser of Parsers loop'
+ -- 'for I in Parsers.Iterate loop'
+ --
+ -- requires Parser_State to be not an incomplete type.
+
+ -- We'd like to use Cursor here, but we want that to be tagged, to
+ -- allow 'Cursor.operation' syntax, and the requirements of
+ -- iterators prevent a tagged iterator type (two tagged types on
+ -- First in this package body). So we use Parser_Node_Access as
+ -- the iterator type for Iterators, and typical usage is:
+ --
+ -- for I in Parsers.Iterate loop
+ -- declare
+ -- Cursor : Parser_Lists.Cursor renames To_Cursor (Parsers, I);
+ -- begin
+ -- Cursor.<cursor operation>
+ --
+ -- ... Parsers (I).<visible parser_state component> ...
+ -- end;
+ -- end loop;
+ --
+ -- or:
+ -- for Current_Parser of Parsers loop
+ -- ... Current_Parser.<visible parser_state component> ...
+ -- end loop;
+
+ type Parser_Node_Access is private;
+
+ function To_Cursor (Ptr : in Parser_Node_Access) return Cursor;
+
+ type Constant_Reference_Type (Element : not null access constant
Parser_State) is null record
+ with Implicit_Dereference => Element;
+
+ function Constant_Reference
+ (Container : aliased in List'Class;
+ Position : in Parser_Node_Access)
+ return Constant_Reference_Type;
+
+ function Reference
+ (Container : aliased in out List'Class;
+ Position : in Parser_Node_Access)
+ return State_Reference;
+
+ function Persistent_State_Ref (Position : in Parser_Node_Access) return
State_Access;
+
+ function Has_Element (Iterator : in Parser_Node_Access) return Boolean;
+
+ package Iterator_Interfaces is new Ada.Iterator_Interfaces
(Parser_Node_Access, Has_Element);
+
+ function Iterate (Container : aliased in out List) return
Iterator_Interfaces.Forward_Iterator'Class;
+
+ -- Access to some private Parser_State components
+
+ function Label (Iterator : in Parser_State) return Natural;
+ procedure Set_Verb (Iterator : in out Parser_State; Verb : in
All_Parse_Action_Verbs);
+ function Verb (Iterator : in Parser_State) return All_Parse_Action_Verbs;
+
+private
+
+ type Parser_State is new Base_Parser_State with record
+ Label : Natural; -- for debugging/verbosity
+
+ Verb : All_Parse_Action_Verbs := Shift; -- current action to perform
+ end record;
+
+ package Parser_State_Lists is new SAL.Gen_Indefinite_Doubly_Linked_Lists
(Parser_State);
+
+ type List is tagged record
+ Elements : aliased Parser_State_Lists.List;
+ Parser_Label : Natural; -- label of last added parser.
+ end record;
+
+ type Cursor is tagged record
+ Elements : access Parser_State_Lists.List;
+ Ptr : Parser_State_Lists.Cursor;
+ end record;
+
+ type Parser_Node_Access is record
+ Elements : access Parser_State_Lists.List;
+ Ptr : Parser_State_Lists.Cursor;
+ end record;
+
+end WisiToken.Parse.LR.Parser_Lists;
diff --git a/wisitoken-parse-lr-parser_no_recover.adb
b/wisitoken-parse-lr-parser_no_recover.adb
new file mode 100644
index 0000000..c82544a
--- /dev/null
+++ b/wisitoken-parse-lr-parser_no_recover.adb
@@ -0,0 +1,492 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2002 - 2005, 2008 - 2015, 2017, 2018 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- 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;
diff --git a/wisitoken-parse-lr-parser_no_recover.ads
b/wisitoken-parse-lr-parser_no_recover.ads
new file mode 100644
index 0000000..17d1766
--- /dev/null
+++ b/wisitoken-parse-lr-parser_no_recover.ads
@@ -0,0 +1,84 @@
+-- Abstract :
+--
+-- A generalized LR parser, with no error recovery, no semantic checks.
+--
+-- This allows wisi-generate (which uses the generated wisi_grammar)
+-- 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 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Lexer;
+with WisiToken.Parse.LR.Parser_Lists;
+with WisiToken.Syntax_Trees;
+package WisiToken.Parse.LR.Parser_No_Recover is
+
+ Default_Max_Parallel : constant := 15;
+
+ type Parser is new WisiToken.Parse.Base_Parser with record
+ Table : Parse_Table_Ptr;
+ Shared_Tree : aliased Syntax_Trees.Base_Tree;
+ -- Each parser has its own branched syntax tree, all branched from
+ -- this tree.
+ --
+ -- See WisiToken.LR.Parser_Lists Parser_State for more discussion of
+ -- Shared_Tree.
+
+ Parsers : aliased Parser_Lists.List;
+
+ Max_Parallel : SAL.Base_Peek_Type;
+ First_Parser_Label : Integer;
+ Terminate_Same_State : Boolean;
+ end record;
+
+ overriding procedure Finalize (Object : in out LR.Parser_No_Recover.Parser);
+ -- Deep free Object.Table.
+
+ 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 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);
+
+ overriding procedure Parse (Shared_Parser : aliased in out
LR.Parser_No_Recover.Parser);
+ -- Attempt a parse. Calls Parser.Lexer.Reset, runs lexer to end of
+ -- input setting Shared_Parser.Terminals, then parses tokens.
+ --
+ -- If a parse error is encountered, raises Syntax_Error.
+ -- Parser.Lexer_Errors and Parsers(*).Errors contain information
+ -- about the errors.
+ --
+ -- For other errors, raises Parse_Error with an appropriate error
+ -- message.
+
+ overriding function Any_Errors (Parser : in LR.Parser_No_Recover.Parser)
return Boolean;
+
+ overriding procedure Put_Errors (Parser : in LR.Parser_No_Recover.Parser);
+ -- Put user-friendly error messages from the parse to
+ -- Ada.Text_IO.Current_Error.
+
+ overriding procedure Execute_Actions (Parser : in out
LR.Parser_No_Recover.Parser);
+ -- Execute the grammar actions in Parser.
+
+end WisiToken.Parse.LR.Parser_No_Recover;
diff --git a/wisitoken-parse-lr.adb b/wisitoken-parse-lr.adb
new file mode 100644
index 0000000..307985c
--- /dev/null
+++ b/wisitoken-parse-lr.adb
@@ -0,0 +1,856 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2013-2015, 2017, 2018 Stephe Leake
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (GPL);
+
+with Ada.Exceptions;
+with Ada.Strings.Maps;
+with Ada.Text_IO;
+package body WisiToken.Parse.LR is
+
+ ----------
+ -- Public subprograms, declaration order
+
+ function Image (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor) return String
+ is
+ use Ada.Containers;
+ begin
+ case Item.Verb is
+ when Shift =>
+ return "(Shift," & State_Index'Image (Item.State) & ")";
+
+ when Reduce =>
+ return "(Reduce," & Count_Type'Image (Item.Token_Count) & ", " &
+ Image (Item.Production.LHS, Descriptor) & "," & Trimmed_Image
(Item.Production.RHS) & ")";
+ when Accept_It =>
+ return "(Accept It)";
+ when Error =>
+ return "(Error)";
+ end case;
+ end Image;
+
+ procedure Put (Trace : in out WisiToken.Trace'Class; Item : in
Parse_Action_Rec)
+ is
+ use Ada.Containers;
+ begin
+ case Item.Verb is
+ when Shift =>
+ Trace.Put ("shift and goto state" & State_Index'Image (Item.State));
+
+ when Reduce =>
+ Trace.Put
+ ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
+ Image (Item.Production.LHS, Trace.Descriptor.all));
+ when Accept_It =>
+ Trace.Put ("accept it");
+ when Error =>
+ Trace.Put ("ERROR");
+ end case;
+ end Put;
+
+ function Equal (Left, Right : in Parse_Action_Rec) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Left.Verb = Right.Verb then
+ case Left.Verb is
+ when Shift =>
+ return Left.State = Right.State;
+
+ when Reduce | Accept_It =>
+ return Left.Production.LHS = Right.Production.LHS and
Left.Token_Count = Right.Token_Count;
+
+ when Error =>
+ return True;
+ end case;
+ else
+ return False;
+ end if;
+ end Equal;
+
+ procedure Add
+ (List : in out Action_Node_Ptr;
+ Symbol : in Token_ID;
+ Action : in Parse_Action_Rec)
+ is
+ New_Item : constant Action_Node_Ptr := new Action_Node'(Symbol, new
Parse_Action_Node'(Action, null), null);
+ I : Action_Node_Ptr := List;
+ begin
+ if I = null then
+ List := New_Item;
+ else
+ if List.Symbol > Symbol then
+ New_Item.Next := List;
+ List := New_Item;
+ else
+ if List.Next = null then
+ List.Next := New_Item;
+ else
+ I := List;
+ loop
+ exit when I.Next = null or else I.Next.Symbol > Symbol;
+ I := I.Next;
+ end loop;
+ New_Item.Next := I.Next;
+ I.Next := New_Item;
+ end if;
+ end if;
+ end if;
+ end Add;
+
+ function Symbol (List : in Goto_Node_Ptr) return Token_ID
+ is begin
+ return List.Symbol;
+ end Symbol;
+
+ function State (List : in Goto_Node_Ptr) return State_Index
+ is begin
+ return List.State;
+ end State;
+
+ function Next (List : in Goto_Node_Ptr) return Goto_Node_Ptr
+ is begin
+ return List.Next;
+ end Next;
+
+ function 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 Shift =>
+ return "(Shift," & Token_ID'Image (Item.ID) & "," & State_Index'Image
(Item.State) & ")";
+ when Reduce =>
+ return "(Reduce," & Token_ID'Image (Item.Nonterm) & "," &
+ Ada.Containers.Count_Type'Image (Item.Token_Count) & ")";
+ end case;
+ end Strict_Image;
+
+ 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
+ loop
+ exit when Iter.Node = null;
+ Iter.Item := Iter.Node.Action;
+ exit when Iter.Item /= null;
+ Iter.Node := Iter.Node.Next;
+ end loop;
+ end return;
+ end First;
+
+ function Is_Done (Iter : in Action_List_Iterator) return Boolean
+ is begin
+ return Iter.Node = null;
+ end Is_Done;
+
+ procedure Next (Iter : in out Action_List_Iterator)
+ is begin
+ if Iter.Node = null then
+ return;
+ end if;
+
+ if Iter.Item.Next = null then
+ loop
+ Iter.Node := Iter.Node.Next;
+ exit when Iter.Node = null;
+ Iter.Item := Iter.Node.Action;
+ exit when Iter.Item /= null;
+ end loop;
+ else
+ Iter.Item := Iter.Item.Next; -- a conflict
+ end if;
+ end Next;
+
+ function Symbol (Iter : in Action_List_Iterator) return Token_ID
+ is begin
+ return Iter.Node.Symbol;
+ end Symbol;
+
+ function Action (Iter : in Action_List_Iterator) return Parse_Action_Rec
+ is begin
+ return Iter.Item.Item;
+ end Action;
+
+ procedure Add_Action
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ State_Index : in WisiToken.State_Index)
+ is
+ Action : constant Parse_Action_Rec := (Shift, State_Index);
+ New_Node : constant Action_Node_Ptr := new Action_Node'(Symbol, new
Parse_Action_Node'(Action, null), null);
+ Node : Action_Node_Ptr;
+ begin
+ if State.Action_List = null then
+ State.Action_List := New_Node;
+ else
+ Node := State.Action_List;
+ loop
+ exit when Node.Next = null;
+ Node := Node.Next;
+ end loop;
+ Node.Next := New_Node;
+ end if;
+ end Add_Action;
+
+ procedure Add_Action
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ Verb : in LR.Parse_Action_Verbs;
+ Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in Semantic_Checks.Semantic_Check)
+ is
+ Action : Parse_Action_Rec;
+ New_Node : Action_Node_Ptr;
+ Node : Action_Node_Ptr;
+ begin
+ case Verb is
+ when Reduce =>
+ Action := (Reduce, Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
+ when Accept_It =>
+ Action := (Accept_It, Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
+ when others =>
+ null;
+ end case;
+ New_Node := new Action_Node'(Symbol, new Parse_Action_Node'(Action,
null), null);
+ if State.Action_List = null then
+ State.Action_List := New_Node;
+ else
+ Node := State.Action_List;
+ loop
+ exit when Node.Next = null;
+ Node := Node.Next;
+ end loop;
+ Node.Next := New_Node;
+ end if;
+ end Add_Action;
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbols : in Token_ID_Array;
+ Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check)
+ is begin
+ -- We assume Duplicate_Reduce is True for this state; no
+ -- conflicts, all the same action.
+ for Symbol of Symbols loop
+ Add_Action
+ (State, Symbol, Reduce, Production, RHS_Token_Count,
+ Semantic_Action, Semantic_Check);
+ end loop;
+ Add_Error (State);
+ end Add_Action;
+
+ procedure Add_Action
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ State_Index : in WisiToken.State_Index;
+ Reduce_Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in Semantic_Checks.Semantic_Check)
+ is
+ Action_1 : constant Parse_Action_Rec := (Shift, State_Index);
+ Action_2 : constant Parse_Action_Rec :=
+ (Reduce, Reduce_Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
+ begin
+ State.Action_List := new Action_Node'
+ (Symbol, new Parse_Action_Node'(Action_1, new
Parse_Action_Node'(Action_2, null)), State.Action_List);
+ end Add_Action;
+
+ procedure Add_Action
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ Verb : in LR.Parse_Action_Verbs;
+ Production_1 : in Production_ID;
+ RHS_Token_Count_1 : in Ada.Containers.Count_Type;
+ Semantic_Action_1 : in Syntax_Trees.Semantic_Action;
+ Semantic_Check_1 : in Semantic_Checks.Semantic_Check;
+ Production_2 : in Production_ID;
+ RHS_Token_Count_2 : in Ada.Containers.Count_Type;
+ Semantic_Action_2 : in Syntax_Trees.Semantic_Action;
+ Semantic_Check_2 : in Semantic_Checks.Semantic_Check)
+ is
+ Action_1 : constant Parse_Action_Rec :=
+ (case Verb is
+ when Reduce =>
+ (Reduce, Production_1, Semantic_Action_1, Semantic_Check_1,
RHS_Token_Count_1),
+ when Accept_It =>
+ (Accept_It, Production_1, Semantic_Action_1, Semantic_Check_1,
RHS_Token_Count_1),
+ when others => raise SAL.Programmer_Error);
+
+ Action_2 : constant Parse_Action_Rec :=
+ (Reduce, Production_2, Semantic_Action_2, Semantic_Check_2,
RHS_Token_Count_2);
+ begin
+ State.Action_List := new Action_Node'
+ (Symbol, new Parse_Action_Node'(Action_1, new
Parse_Action_Node'(Action_2, null)), State.Action_List);
+ end Add_Action;
+
+ procedure Add_Error (State : in out LR.Parse_State)
+ is
+ Action : constant Parse_Action_Rec := (Verb => Error);
+ Node : Action_Node_Ptr := State.Action_List;
+ begin
+ if Node = null then
+ raise SAL.Programmer_Error with "adding an error action to a parse
table state before other actions.";
+ end if;
+ loop
+ exit when Node.Next = null;
+ Node := Node.Next;
+ end loop;
+ Node.Next := new Action_Node'(Invalid_Token_ID, new
Parse_Action_Node'(Action, null), null);
+ end Add_Error;
+
+ procedure Add_Goto
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ To_State : in State_Index)
+ is
+ List : Goto_Node_Ptr renames State.Goto_List;
+ New_Item : constant Goto_Node_Ptr := new Goto_Node'(Symbol, To_State,
null);
+ I : Goto_Node_Ptr := List;
+ begin
+ if I = null then
+ List := New_Item;
+ else
+ if List.Symbol > Symbol then
+ New_Item.Next := List;
+ List := New_Item;
+ else
+ if List.Next = null then
+ List.Next := New_Item;
+ else
+ I := List;
+ loop
+ exit when I.Next = null or List.Symbol > Symbol;
+ I := I.Next;
+ end loop;
+ New_Item.Next := I.Next;
+ I.Next := New_Item;
+ end if;
+ end if;
+ end if;
+ end Add_Goto;
+
+ procedure Set_Production
+ (Prod : in out Productions.Instance;
+ LHS : in Token_ID;
+ RHS_Last : in Natural)
+ is begin
+ Prod.LHS := LHS;
+ Prod.RHSs.Set_First (0);
+ Prod.RHSs.Set_Last (RHS_Last);
+ end Set_Production;
+
+ procedure Set_RHS
+ (Prod : in out Productions.Instance;
+ RHS_Index : in Natural;
+ Tokens : in Token_ID_Array;
+ Action : in WisiToken.Syntax_Trees.Semantic_Action := null;
+ Check : in WisiToken.Semantic_Checks.Semantic_Check := null)
+ is begin
+ if Tokens'Length > 0 then
+ Prod.RHSs (RHS_Index).Tokens.Set_First (1);
+ Prod.RHSs (RHS_Index).Tokens.Set_Last (Tokens'Length);
+ for I in Tokens'Range loop
+ Prod.RHSs (RHS_Index).Tokens (I) := Tokens (I);
+ end loop;
+ Prod.RHSs (RHS_Index).Action := Action;
+ Prod.RHSs (RHS_Index).Check := Check;
+ end if;
+ end Set_RHS;
+
+ function Goto_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Unknown_State_Index
+ is
+ Goto_Node : constant Goto_Node_Ptr := Goto_For (Table, State, ID);
+ begin
+ if Goto_Node = null then
+ -- We can only get here during error recovery.
+ return Unknown_State;
+ else
+ return Goto_Node.State;
+ end if;
+ end Goto_For;
+
+ function Goto_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Goto_Node_Ptr
+ is
+ Goto_Node : Goto_Node_Ptr := Table.States (State).Goto_List;
+ begin
+ while Goto_Node /= null and then Goto_Node.Symbol /= ID loop
+ Goto_Node := Goto_Node.Next;
+ end loop;
+
+ return Goto_Node;
+ end Goto_For;
+
+ function Action_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Parse_Action_Node_Ptr
+ is
+ Action_Node : Action_Node_Ptr := Table.States (State).Action_List;
+ begin
+ if Action_Node = null then
+ raise SAL.Programmer_Error with "no actions for state" &
Unknown_State_Index'Image (State);
+ end if;
+
+ while Action_Node.Next /= null and Action_Node.Symbol /= ID loop
+ Action_Node := Action_Node.Next;
+ end loop;
+
+ return Action_Node.Action;
+ end Action_For;
+
+ function Expecting (Table : in Parse_Table; State : in State_Index) return
Token_ID_Set
+ is
+ Result : Token_ID_Set := (Table.First_Terminal .. Table.Last_Terminal
=> False);
+ Action : Action_Node_Ptr := Table.States (State).Action_List;
+ begin
+ loop
+ -- Last action is error; don't include it.
+ exit when Action.Next = null;
+
+ Result (Action.Symbol) := True;
+ Action := Action.Next;
+ end loop;
+ return Result;
+ end Expecting;
+
+ procedure Free_Table (Table : in out Parse_Table_Ptr)
+ is
+
+ procedure Free is new Ada.Unchecked_Deallocation (Parse_Table,
Parse_Table_Ptr);
+ Action : Action_Node_Ptr;
+ Temp_Action : Action_Node_Ptr;
+ Parse_Action : Parse_Action_Node_Ptr;
+ Temp_Parse_Action : Parse_Action_Node_Ptr;
+ Got : Goto_Node_Ptr;
+ Temp_Got : Goto_Node_Ptr;
+ begin
+ if Table = null then
+ return;
+ end if;
+
+ for State of Table.States loop
+ Action := State.Action_List;
+ loop
+ exit when Action = null;
+ Parse_Action := Action.Action;
+ loop
+ exit when Parse_Action = null;
+ Temp_Parse_Action := Parse_Action;
+ Parse_Action := Parse_Action.Next;
+ Free (Temp_Parse_Action);
+ end loop;
+
+ Temp_Action := Action;
+ Action := Action.Next;
+ Free (Temp_Action);
+ end loop;
+
+ Got := State.Goto_List;
+ loop
+ exit when Got = null;
+ Temp_Got := Got;
+ Got := Got.Next;
+ Free (Temp_Got);
+ end loop;
+ end loop;
+
+ Free (Table);
+ end Free_Table;
+
+ function Get_Action
+ (Prod : in Production_ID;
+ Productions : in WisiToken.Productions.Prod_Arrays.Vector)
+ return WisiToken.Syntax_Trees.Semantic_Action
+ is begin
+ return Productions (Prod.LHS).RHSs (Prod.RHS).Action;
+ end Get_Action;
+
+ function Get_Check
+ (Prod : in Production_ID;
+ Productions : in WisiToken.Productions.Prod_Arrays.Vector)
+ return WisiToken.Semantic_Checks.Semantic_Check
+ is begin
+ return Productions (Prod.LHS).RHSs (Prod.RHS).Check;
+ end Get_Check;
+
+ function Get_Text_Rep
+ (File_Name : in String;
+ McKenzie_Param : in McKenzie_Param_Type;
+ Productions : in WisiToken.Productions.Prod_Arrays.Vector)
+ return Parse_Table_Ptr
+ is
+ use Ada.Text_IO;
+ use Ada.Strings.Unbounded;
+
+ File : File_Type;
+ Line : Unbounded_String;
+ First : Integer;
+ Last : Integer := 0;
+
+ Delimiters : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set (" ;");
+
+ function Last_Char return Character
+ is begin
+ if Last = 0 then
+ return Element (Line, Last + 1);
+ else
+ return Element (Line, Last);
+ end if;
+ end Last_Char;
+
+ procedure Skip_Char
+ 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);
+ end if;
+ end Skip_Char;
+
+ function Next_Value return String
+ 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);
+ end if;
+ end return;
+ end Next_Value;
+
+ generic
+ type Value_Type is (<>);
+ Name : in String;
+ function Gen_Next_Value return Value_Type;
+
+ function Gen_Next_Value return Value_Type
+ is
+ Val : constant String := Next_Value;
+ begin
+ return Value_Type'Value (Val);
+ 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 & "'");
+ end Gen_Next_Value;
+
+ function Next_State_Index is new Gen_Next_Value (State_Index,
"State_Index");
+ function Next_Token_ID is new Gen_Next_Value (Token_ID, "Token_ID");
+ function Next_Integer is new Gen_Next_Value (Integer, "Integer");
+ function Next_Parse_Action_Verbs is new Gen_Next_Value
(Parse_Action_Verbs, "Parse_Action_Verbs");
+ function Next_Boolean is new Gen_Next_Value (Boolean, "Boolean");
+ function Next_Count_Type is new Gen_Next_Value
(Ada.Containers.Count_Type, "Count_Type");
+ begin
+ Open (File, In_File, File_Name);
+ Line := +Get_Line (File);
+
+ declare
+ -- We don't read the discriminants in the aggregate, because
+ -- aggregate evaluation order is not guaranteed.
+ State_First : constant State_Index := Next_State_Index;
+ State_Last : constant State_Index := Next_State_Index;
+ First_Terminal : constant Token_ID := Next_Token_ID;
+ Last_Terminal : constant Token_ID := Next_Token_ID;
+ First_Nonterminal : constant Token_ID := Next_Token_ID;
+ Last_Nonterminal : constant Token_ID := Next_Token_ID;
+
+ Table : constant Parse_Table_Ptr := new Parse_Table
+ (State_First, State_Last, First_Terminal, Last_Terminal,
First_Nonterminal, Last_Nonterminal);
+ begin
+ Table.McKenzie_Param := McKenzie_Param;
+
+ for State of Table.States loop
+ State.Productions.Set_First (Next_Integer);
+ State.Productions.Set_Last (Next_Integer);
+ for I in State.Productions.First_Index ..
State.Productions.Last_Index loop
+ State.Productions (I).LHS := Next_Token_ID;
+ State.Productions (I).RHS := Next_Integer;
+ end loop;
+
+ declare
+ Node_I : Action_Node_Ptr := new Action_Node;
+ Actions_Done : Boolean := False;
+ begin
+ State.Action_List := Node_I;
+ loop
+ declare
+ Node_J : Parse_Action_Node_Ptr := new
Parse_Action_Node;
+ Action_Done : Boolean := False;
+ Verb : Parse_Action_Verbs;
+ begin
+ Node_I.Action := Node_J;
+ loop
+ Verb := Next_Parse_Action_Verbs;
+ Node_J.Item :=
+ (case Verb is
+ when Shift => (Verb => Shift, others => <>),
+ when Reduce => (Verb => Reduce, others => <>),
+ when Accept_It => (Verb => Accept_It, others => <>),
+ when Error => (Verb => Error));
+
+ case Verb is
+ when Shift =>
+ Node_J.Item.State := Next_State_Index;
+
+ when Reduce | Accept_It =>
+ Node_J.Item.Production.LHS := Next_Token_ID;
+ Node_J.Item.Production.RHS := Next_Integer;
+ if Next_Boolean then
+ Node_J.Item.Action := Get_Action
(Node_J.Item.Production, Productions);
+ else
+ Node_J.Item.Action := null;
+ end if;
+ if Next_Boolean then
+ Node_J.Item.Check := Get_Check
(Node_J.Item.Production, Productions);
+ else
+ Node_J.Item.Check := null;
+ end if;
+ Node_J.Item.Token_Count := Next_Count_Type;
+
+ when Error =>
+ Actions_Done := True;
+ end case;
+
+ if Element (Line, Last) = ';' then
+ Skip_Char;
+ Action_Done := True;
+
+ if not Actions_Done then
+ Node_I.Symbol := Next_Token_ID;
+ end if;
+ end if;
+
+ exit when Action_Done;
+
+ Node_J.Next := new Parse_Action_Node;
+ Node_J := Node_J.Next;
+ end loop;
+ end;
+
+ exit when Actions_Done;
+ Node_I.Next := new Action_Node;
+ Node_I := Node_I.Next;
+ end loop;
+ end;
+
+ if Element (Line, 1) = ';' then
+ -- No Gotos
+ Skip_Char;
+ else
+ declare
+ Node_I : Goto_Node_Ptr := new Goto_Node;
+ begin
+ State.Goto_List := Node_I;
+ loop
+ Node_I.Symbol := Next_Token_ID;
+ Node_I.State := Next_State_Index;
+ exit when Element (Line, Last) = ';';
+ Node_I.Next := new Goto_Node;
+ Node_I := Node_I.Next;
+ end loop;
+ Skip_Char;
+ end;
+ end if;
+
+ 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;
+ case Verb is
+ when Shift =>
+ ID := Next_Token_ID;
+ Action_State := Next_State_Index;
+ State.Minimal_Complete_Actions.Insert ((Shift, ID,
Action_State));
+ when Reduce =>
+ ID := Next_Token_ID;
+ Count := Next_Count_Type;
+ State.Minimal_Complete_Actions.Insert ((Reduce, ID,
Count));
+ end case;
+ end loop;
+ end;
+ -- loop exits on End_Error
+ 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
+ when Name_Error =>
+ 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),
+ Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
+ end Get_Text_Rep;
+
+ function Compare (Left, Right : in Insert_Delete_Op) return
SAL.Compare_Result
+ is begin
+ if Left.Token_Index < Right.Token_Index then
+ return SAL.Less;
+ elsif Left.Token_Index = Right.Token_Index then
+ return SAL.Equal;
+ else
+ return SAL.Greater;
+ end if;
+ end Compare;
+
+ function None_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
+ is begin
+ for O of reverse Ops loop
+ exit when O.Op = Fast_Forward;
+ if O.Op = Op then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end None_Since_FF;
+
+ function Match_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op) return Boolean
+ is begin
+ for O of reverse Ops loop
+ exit when O.Op = Fast_Forward;
+ if O = Op then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Match_Since_FF;
+
+ function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean
+ is
+ use all type Syntax_Trees.Node_Index;
+ begin
+ for I in 1 .. Depth loop
+ if Stack (I).Tree_Index = Syntax_Trees.Invalid_Node_Index then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end Valid_Tree_Indices;
+
+ procedure Set_Key (Item : in out Configuration; Key : in Integer)
+ is begin
+ Item.Cost := Key;
+ end Set_Key;
+
+ function Image
+ (Item : in Parse_Error;
+ Tree : in Syntax_Trees.Tree;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is begin
+ case Item.Label is
+ when Action =>
+ return "Action, expecting: " & Image (Item.Expecting, Descriptor) &
+ ", found" & Tree.Image (Item.Error_Token, Descriptor);
+
+ when Check =>
+ return "Check, " & Semantic_Checks.Image (Item.Check_Status,
Descriptor);
+
+ when Message =>
+ return -Item.Msg;
+ end case;
+ end Image;
+
+end WisiToken.Parse.LR;
diff --git a/wisitoken-parse-lr.ads b/wisitoken-parse-lr.ads
new file mode 100644
index 0000000..7bd38ad
--- /dev/null
+++ b/wisitoken-parse-lr.ads
@@ -0,0 +1,624 @@
+-- Abstract :
+--
+-- Root package of an implementation of an LR (Left-to-right scanning
+-- Rightmost-deriving) parser. Includes operations for building the
+-- parse table at runtime. See the child packages .Parse and
+-- .Parse_No_Recover for running the parser.
+--
+-- References :
+--
+-- See wisitoken.ads
+--
+-- Copyright (C) 2002, 2003, 2009, 2010, 2013-2015, 2017 - 2018 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers.Indefinite_Doubly_Linked_Lists;
+with Ada.Unchecked_Deallocation;
+with SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted;
+with SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux;
+with SAL.Gen_Definite_Doubly_Linked_Lists_Sorted.Gen_Image;
+with SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci;
+with SAL.Gen_Unbounded_Definite_Queues.Gen_Image_Aux;
+with SAL.Gen_Unbounded_Definite_Stacks.Gen_Image_Aux;
+with System.Multiprocessors;
+with WisiToken.Productions;
+with WisiToken.Semantic_Checks;
+with WisiToken.Syntax_Trees;
+package WisiToken.Parse.LR is
+
+ type All_Parse_Action_Verbs is (Pause, Shift_Recover, 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.
+
+ type Parse_Action_Rec (Verb : Parse_Action_Verbs := Shift) is record
+ case Verb is
+ when Shift =>
+ State : State_Index := State_Index'Last;
+
+ when Reduce | Accept_It =>
+ Production : Production_ID;
+ -- The result nonterm and production index. Most uses need only
+ -- Production.LHS; elisp code generation, and debug output, needs
+ -- Production.RHS
+
+ Action : WisiToken.Syntax_Trees.Semantic_Action := null;
+ Check : WisiToken.Semantic_Checks.Semantic_Check := null;
+ Token_Count : Ada.Containers.Count_Type := 0;
+
+ when Error =>
+ null;
+ end case;
+ end record;
+ subtype Shift_Action_Rec is Parse_Action_Rec (Shift);
+ subtype Reduce_Action_Rec is Parse_Action_Rec (Reduce);
+
+ function Image (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor) return String;
+ -- Ada aggregate syntax, leaving out Action, Check in reduce; for debug
output
+
+ procedure Put (Trace : in out WisiToken.Trace'Class; Item : in
Parse_Action_Rec);
+ -- Put a line for Item in parse trace format.
+
+ function Equal (Left, Right : in Parse_Action_Rec) return Boolean;
+ -- Ignore Action, Check.
+
+ type Parse_Action_Node;
+ type Parse_Action_Node_Ptr is access Parse_Action_Node;
+
+ type Parse_Action_Node is record
+ Item : Parse_Action_Rec;
+ Next : Parse_Action_Node_Ptr; -- non-null only for conflicts
+ end record;
+ procedure Free is new Ada.Unchecked_Deallocation (Parse_Action_Node,
Parse_Action_Node_Ptr);
+
+ type Action_Node;
+ type Action_Node_Ptr is access Action_Node;
+
+ type Action_Node is record
+ Symbol : Token_ID := Invalid_Token_ID; -- ignored if Action is Error
+ Action : Parse_Action_Node_Ptr;
+ Next : Action_Node_Ptr;
+ end record;
+ procedure Free is new Ada.Unchecked_Deallocation (Action_Node,
Action_Node_Ptr);
+
+ procedure Add
+ (List : in out Action_Node_Ptr;
+ Symbol : in Token_ID;
+ Action : in Parse_Action_Rec);
+ -- Add action to List, sorted on ascending Symbol.
+
+ type Goto_Node is private;
+ type Goto_Node_Ptr is access Goto_Node;
+
+ function Symbol (List : in Goto_Node_Ptr) return Token_ID;
+ function State (List : in Goto_Node_Ptr) return State_Index;
+ function Next (List : in Goto_Node_Ptr) return Goto_Node_Ptr;
+
+ type Minimal_Action (Verb : Minimal_Verbs := Shift) is record
+ case Verb is
+ when Shift =>
+ ID : Token_ID;
+ State : State_Index;
+
+ when Reduce =>
+ Nonterm : Token_ID;
+ Token_Count : Ada.Containers.Count_Type;
+ 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.
+ 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
+ end record;
+
+ type Parse_State_Array is array (State_Index range <>) of Parse_State;
+
+ type Action_List_Iterator is tagged private;
+ -- Iterates over all shift/reduce actions for a state, including
+ -- conflicts.
+
+ function First (State : in Parse_State) return Action_List_Iterator;
+ function Is_Done (Iter : in Action_List_Iterator) return Boolean;
+ procedure Next (Iter : in out Action_List_Iterator);
+
+ function Symbol (Iter : in Action_List_Iterator) return Token_ID;
+ function Action (Iter : in Action_List_Iterator) return Parse_Action_Rec;
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbol : in Token_ID;
+ State_Index : in WisiToken.State_Index);
+ -- Add a Shift action to tail of State action list.
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbol : in Token_ID;
+ Verb : in Parse_Action_Verbs;
+ Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
+ -- Add a Reduce or Accept_It action to tail of State action list.
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbols : in Token_ID_Array;
+ Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
+ -- Add duplicate Reduce actions, and final Error action, to tail of
+ -- State action list.
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbol : in Token_ID;
+ State_Index : in WisiToken.State_Index;
+ Reduce_Production : in Production_ID;
+ RHS_Token_Count : in Ada.Containers.Count_Type;
+ Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
+ -- Add a Shift/Reduce conflict to State.
+
+ procedure Add_Action
+ (State : in out Parse_State;
+ Symbol : in Token_ID;
+ Verb : in Parse_Action_Verbs;
+ Production_1 : in Production_ID;
+ RHS_Token_Count_1 : in Ada.Containers.Count_Type;
+ Semantic_Action_1 : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check_1 : in WisiToken.Semantic_Checks.Semantic_Check;
+ Production_2 : in Production_ID;
+ RHS_Token_Count_2 : in Ada.Containers.Count_Type;
+ Semantic_Action_2 : in WisiToken.Syntax_Trees.Semantic_Action;
+ Semantic_Check_2 : in WisiToken.Semantic_Checks.Semantic_Check);
+ -- Add an Accept/Reduce or Reduce/Reduce conflict action to State.
+
+ procedure Add_Error (State : in out Parse_State);
+ -- Add an Error action to State, at tail of action list.
+
+ procedure Add_Goto
+ (State : in out Parse_State;
+ Symbol : in Token_ID;
+ To_State : in State_Index);
+ -- Add a goto item to State goto list; keep goto list sorted in ascending
order on Symbol.
+
+ type McKenzie_Param_Type
+ (First_Terminal : Token_ID;
+ Last_Terminal : Token_ID;
+ First_Nonterminal : Token_ID;
+ Last_Nonterminal : Token_ID)
+ is record
+ Insert : Token_ID_Array_Natural (First_Terminal .. Last_Terminal);
+ Delete : Token_ID_Array_Natural (First_Terminal .. Last_Terminal);
+ Push_Back : Token_ID_Array_Natural (First_Terminal .. Last_Nonterminal);
+ -- Cost of operations on config stack, input.
+
+ Ignore_Check_Fail : Natural;
+ -- Cost of ignoring a semantic check failure. Should be at least the
+ -- cost of a typical fix for such a failure.
+
+ Task_Count : System.Multiprocessors.CPU_Range;
+ -- Number of parallel tasks during recovery. If 0, use
+ -- System.Multiprocessors.Number_Of_CPUs - 1.
+
+ Cost_Limit : Natural; -- max cost of configurations to look at
+ Check_Limit : Token_Index; -- max tokens to parse ahead when
checking a configuration.
+ Check_Delta_Limit : Natural; -- max configs checked, delta over
successful parser.
+ Enqueue_Limit : Natural; -- max configs enqueued.
+ end record;
+
+ Default_McKenzie_Param : constant McKenzie_Param_Type :=
+ (First_Terminal => Token_ID'Last,
+ Last_Terminal => Token_ID'First,
+ First_Nonterminal => Token_ID'Last,
+ Last_Nonterminal => Token_ID'First,
+ Insert => (others => 0),
+ Delete => (others => 0),
+ Push_Back => (others => 0),
+ Ignore_Check_Fail => 0,
+ Task_Count => System.Multiprocessors.CPU_Range'Last,
+ Cost_Limit => Natural'Last,
+ Check_Limit => Token_Index'Last,
+ Check_Delta_Limit => Natural'Last,
+ Enqueue_Limit => Natural'Last);
+
+ procedure Set_Production
+ (Prod : in out Productions.Instance;
+ LHS : in Token_ID;
+ RHS_Last : in Natural);
+
+ procedure Set_RHS
+ (Prod : in out Productions.Instance;
+ RHS_Index : in Natural;
+ Tokens : in Token_ID_Array;
+ Action : in WisiToken.Syntax_Trees.Semantic_Action := null;
+ Check : in WisiToken.Semantic_Checks.Semantic_Check := null);
+
+ type Parse_Table
+ (State_First : State_Index;
+ State_Last : State_Index;
+ First_Terminal : Token_ID;
+ Last_Terminal : Token_ID;
+ First_Nonterminal : Token_ID;
+ Last_Nonterminal : Token_ID)
+ is tagged
+ record
+ States : Parse_State_Array (State_First .. State_Last);
+ McKenzie_Param : McKenzie_Param_Type (First_Terminal, Last_Terminal,
First_Nonterminal, Last_Nonterminal);
+ end record;
+
+ function Goto_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Unknown_State_Index;
+ function Goto_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Goto_Node_Ptr;
+ -- Return next state after reducing stack by nonterminal ID;
+ -- Unknown_State if none (only possible during error recovery).
+ -- Second form allows retrieving Production.
+
+ function Action_For
+ (Table : in Parse_Table;
+ State : in State_Index;
+ ID : in Token_ID)
+ return Parse_Action_Node_Ptr;
+ -- Return the action for State, terminal ID.
+
+ function Expecting (Table : in Parse_Table; State : in State_Index) return
Token_ID_Set;
+
+ type Parse_Table_Ptr is access Parse_Table;
+ procedure Free_Table (Table : in out Parse_Table_Ptr);
+
+ function Get_Action
+ (Prod : in Production_ID;
+ Productions : in WisiToken.Productions.Prod_Arrays.Vector)
+ return WisiToken.Syntax_Trees.Semantic_Action;
+
+ function Get_Check
+ (Prod : in Production_ID;
+ Productions : in WisiToken.Productions.Prod_Arrays.Vector)
+ return WisiToken.Semantic_Checks.Semantic_Check;
+
+ function Get_Text_Rep
+ (File_Name : in String;
+ McKenzie_Param : in McKenzie_Param_Type;
+ Productions : in WisiToken.Productions.Prod_Arrays.Vector)
+ return Parse_Table_Ptr;
+ -- Read machine-readable text format of states from a file File_Name.
+ -- Result has actions, checks from Productions.
+
+ ----------
+ -- For McKenzie_Recover. Declared here because Parser_Lists needs
+ -- these, Mckenzie_Recover needs Parser_Lists.
+ --
+ -- We don't maintain a syntax tree during recover; it's too slow, and
+ -- not needed for any operations. The parser syntax tree is used for
+ -- Undo_Reduce, which is only done on nonterms reduced by the main
+ -- parser, not virtual nonterms produced by recover.
+
+ package Fast_Token_ID_Arrays is new SAL.Gen_Bounded_Definite_Vectors
+ (SAL.Peek_Type, Token_ID, Capacity => 20);
+
+ No_Insert_Delete : constant SAL.Base_Peek_Type := 0;
+
+ function Image
+ (Index : in SAL.Peek_Type;
+ Tokens : in Fast_Token_ID_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is (SAL.Peek_Type'Image (Index) & ":" & SAL.Peek_Type'Image
(Tokens.Last_Index) & ":" &
+ Image (Tokens (Index), Descriptor));
+
+ type Config_Op_Label is (Fast_Forward, Undo_Reduce, Push_Back, Insert,
Delete);
+ subtype Insert_Delete_Op_Label is Config_Op_Label range Insert .. Delete;
+ -- Fast_Forward is a placeholder to mark a fast_forward parse; that
+ -- resets what operations are allowed to be done on a config.
+ --
+ -- Undo_Reduce is the inverse of Reduce.
+ --
+ -- Push_Back pops the top stack item, and moves the input stream
+ -- pointer back to the first shared_terminal contained by that item.
+ --
+ -- Insert inserts a new token in the token input stream, before the
+ -- given point in Terminals.
+ --
+ -- Delete deletes one item from the token input stream, at the given
+ -- point.
+
+ type Config_Op (Op : Config_Op_Label := Fast_Forward) is record
+ -- We store enough information to perform the operation on the main
+ -- parser stack and input stream point when the config is the result
+ -- of a successful recover.
+ --
+ -- After a recover, the main parser must reparse any inserted tokens,
+ -- and skip any deleted tokens. Therefore, when all the recover ops
+ -- are applied, the main parser stack will be the same or shorter
+ -- than it was, so we only need to store token counts for stack
+ -- operations (Unknown_State is pushed when a state is needed; none
+ -- will be left on the main stack). We also store IDs, so we can
+ -- check that everything is in sync, and for debugging.
+
+ case Op is
+ when Fast_Forward =>
+ FF_Token_Index : WisiToken.Token_Index;
+ -- Config.Current_Shared_Token after the operation is done; the last
+ -- token shifted.
+
+ when Undo_Reduce =>
+ Nonterm : Token_ID;
+ -- The nonterminal popped off the stack.
+
+ Token_Count : Ada.Containers.Count_Type;
+ -- The number of tokens pushed on the stack.
+
+ when Push_Back | Insert | Delete =>
+ ID : Token_ID;
+ -- For Push_Back, ID is the nonterm ID popped off the stack.
+ -- For Insert | Delete, ID is the token inserted or deleted.
+
+ Token_Index : WisiToken.Base_Token_Index;
+ -- For Push_Back, Token_Index is Config.Current_Shared_Token after
+ -- the operation is done. If the token is empty, Token_Index is
+ -- Invalid_Token_Index.
+ --
+ -- For Insert, ID is inserted before Token_Index.
+ --
+ -- For Delete, token at Token_Index is deleted.
+
+ end case;
+ end record;
+ subtype Insert_Delete_Op is Config_Op with Dynamic_Predicate =>
(Insert_Delete_Op.Op in Insert_Delete_Op_Label);
+
+ function Compare (Left, Right : in Insert_Delete_Op) return
SAL.Compare_Result;
+
+ package Config_Op_Queues is new SAL.Gen_Unbounded_Definite_Queues
(Config_Op);
+
+ package Config_Op_Arrays is new SAL.Gen_Bounded_Definite_Vectors
+ (Positive_Index_Type, Config_Op, Capacity => 80);
+ -- Using a fixed size vector significantly speeds up
+ -- McKenzie_Recover. The capacity is determined by the maximum number
+ -- of repair operations, which is limited by the cost_limit McKenzie
+ -- parameter plus an arbitrary number from the language-specific
+ -- repairs; in practice, a capacity of 80 is enough so far. If a
+ -- config does hit that limit, it is abandoned; some other config is
+ -- likely to be cheaper.
+
+ package Insert_Delete_Arrays is new SAL.Gen_Bounded_Definite_Vectors
+ (Positive_Index_Type, Insert_Delete_Op, Capacity => 80);
+
+ package Sorted_Insert_Delete_Arrays is new Insert_Delete_Arrays.Gen_Sorted
(Compare);
+
+ function Config_Op_Image (Item : in Config_Op; Descriptor : in
WisiToken.Descriptor) return String
+ is ("(" & Config_Op_Label'Image (Item.Op) & ", " &
+ (case Item.Op is
+ when Fast_Forward => WisiToken.Token_Index'Image
(Item.FF_Token_Index),
+ when Undo_Reduce => Image (Item.Nonterm, Descriptor) & "," &
+ Ada.Containers.Count_Type'Image (Item.Token_Count),
+ when Push_Back | Insert | Delete => Image (Item.ID, Descriptor) &
"," &
+ WisiToken.Token_Index'Image (Item.Token_Index))
+ & ")");
+
+ function Image (Item : in Config_Op; Descriptor : in WisiToken.Descriptor)
return String
+ renames Config_Op_Image;
+
+ function Image is new Config_Op_Queues.Gen_Image_Aux (WisiToken.Descriptor,
Image);
+ function Config_Op_Array_Image is new Config_Op_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
+ function Image (Item : in Config_Op_Arrays.Vector; Descriptor : in
WisiToken.Descriptor) return String
+ renames Config_Op_Array_Image;
+
+ function None (Ops : in Config_Op_Arrays.Vector; Op : in Config_Op_Label)
return Boolean
+ is (for all O of Ops => O.Op /= Op);
+ -- True if Ops contains no Op.
+
+ function None_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
+ -- True if Ops contains no Op after the last Fast_Forward (or ops.first, if
+ -- no Fast_Forward).
+
+ function Match_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op) return Boolean;
+ -- True if Ops contains an Op after the last Fast_Forward (or ops.first, if
+ -- no Fast_Forward) that equals Op.
+
+ function Any (Ops : in Config_Op_Arrays.Vector; Op : in Config_Op_Label)
return Boolean
+ is (for some O of Ops => O.Op = Op);
+ -- True if Ops contains at least one Op.
+
+ type Recover_Stack_Item is record
+ State : Unknown_State_Index;
+ Tree_Index : Syntax_Trees.Node_Index;
+ Token : Recover_Token;
+ end record;
+
+ package Recover_Stacks is new SAL.Gen_Unbounded_Definite_Stacks
(Recover_Stack_Item);
+
+ function Image (Item : in Recover_Stack_Item; Descriptor : in
WisiToken.Descriptor) return String
+ is ((if Item.State = Unknown_State then " " else Trimmed_Image
(Item.State)) & " : " &
+ Image (Item.Token, Descriptor));
+
+ function Recover_Stack_Image is new Recover_Stacks.Gen_Image_Aux
(WisiToken.Descriptor, Image);
+ -- Unique name for calling from debugger
+
+ function Image
+ (Stack : in Recover_Stacks.Stack;
+ Descriptor : in WisiToken.Descriptor;
+ Depth : in SAL.Base_Peek_Type := 0)
+ return String
+ renames Recover_Stack_Image;
+
+ function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean;
+ -- Return True if Stack top Depth items have valid Tree_Indices,
+ -- which is true if they were copied from the parser stack, and not
+ -- pushed by recover.
+
+ type Configuration is record
+ Stack : Recover_Stacks.Stack;
+ -- Initially built from the parser stack, then the stack after the
+ -- Ops below have been performed.
+
+ Resume_Token_Goal : Token_Index := Token_Index'Last;
+ -- A successful solution shifts this token. Per-config because it
+ -- increases with Delete; we increase Shared_Parser.Resume_Token_Goal
+ -- only from successful configs.
+
+ Current_Shared_Token : Base_Token_Index := Token_Index'Last;
+ -- Index into Shared_Parser.Terminals for current input token, after
+ -- all of Inserted is input. Initially the error token.
+
+ String_Quote_Checked : Line_Number_Type := Invalid_Line_Number;
+ -- Max line checked for missing string quote.
+
+ Insert_Delete : Sorted_Insert_Delete_Arrays.Vector;
+ -- Edits to the input stream that are not yet parsed; contains only
+ -- Insert and Delete ops, in token_index order.
+
+ Current_Insert_Delete : SAL.Base_Peek_Type := No_Insert_Delete;
+ -- Index of the next op in Insert_Delete. If No_Insert_Delete, use
+ -- Current_Shared_Token.
+
+ Error_Token : Recover_Token;
+ Check_Token_Count : Ada.Containers.Count_Type;
+ Check_Status : Semantic_Checks.Check_Status;
+ -- If parsing this config ended with a parse error, Error_Token is
+ -- the token that failed to shift, Check_Status.Label is Ok.
+ --
+ -- If parsing this config ended with a semantic check fail,
+ -- Error_Token is the nonterm created by the reduction,
+ -- Check_Token_Count the number of tokens in the right hand side, and
+ -- Check_Status is the error.
+ --
+ -- Error_Token is set to Invalid_Token_ID when Config is parsed
+ -- successfully, or modified so the error is no longer meaningful (ie
+ -- in explore when adding an op, or in language_fixes when adding a
+ -- fix).
+
+ Ops : Config_Op_Arrays.Vector;
+ -- Record of operations applied to this Config, in application order.
+ -- Insert and Delete ops that are not yet parsed are reflected in
+ -- Insert_Delete, in token_index order.
+
+ Current_Ops : SAL.Base_Peek_Type := No_Insert_Delete;
+ -- If No_Insert_Delete, append new ops to Ops. Otherwise insert
+ -- before Current_Ops. This happens when Fast_Forward fails with the
+ -- remaining ops at Current_Shared_Token.
+
+ Cost : Natural := 0;
+ end record;
+ type Configuration_Access is access all Configuration;
+ for Configuration_Access'Storage_Size use 0;
+
+ function Key (A : in Configuration) return Integer is (A.Cost);
+
+ procedure Set_Key (Item : in out Configuration; Key : in Integer);
+
+ package Config_Heaps is new SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci
+ (Element_Type => Configuration,
+ Element_Access => Configuration_Access,
+ Key_Type => Integer,
+ Key => Key,
+ Set_Key => Set_Key);
+
+ type Check_Status is (Success, Abandon, Continue);
+ subtype Non_Success_Status is Check_Status range Abandon .. Continue;
+
+ type McKenzie_Data is tagged record
+ Config_Heap : Config_Heaps.Heap_Type;
+ Enqueue_Count : Integer := 0;
+ Check_Count : Integer := 0;
+ Results : Config_Heaps.Heap_Type;
+ Success : Boolean := False;
+ end record;
+
+ type McKenzie_Access is access all McKenzie_Data;
+
+ type Parse_Error_Label is (Action, Check, Message);
+
+ type Parse_Error
+ (Label : Parse_Error_Label;
+ First_Terminal : Token_ID;
+ Last_Terminal : Token_ID)
+ is record
+ Recover : Configuration;
+
+ case Label is
+ when Action =>
+ Error_Token : Syntax_Trees.Valid_Node_Index; -- index into Parser.Tree
+ Expecting : Token_ID_Set (First_Terminal .. Last_Terminal);
+
+ when Check =>
+ Check_Status : Semantic_Checks.Check_Status;
+
+ when Message =>
+ Msg : Ada.Strings.Unbounded.Unbounded_String;
+ end case;
+ end record;
+
+ package Parse_Error_Lists is new
Ada.Containers.Indefinite_Doubly_Linked_Lists (Parse_Error);
+
+ function Image
+ (Item : in Parse_Error;
+ Tree : in Syntax_Trees.Tree;
+ Descriptor : in WisiToken.Descriptor)
+ return String;
+
+private
+
+ type Goto_Node is record
+ Symbol : Token_ID;
+ State : State_Index;
+ Next : Goto_Node_Ptr;
+ end record;
+ procedure Free is new Ada.Unchecked_Deallocation (Goto_Node, Goto_Node_Ptr);
+
+ type Action_List_Iterator is tagged record
+ Node : Action_Node_Ptr;
+ Item : Parse_Action_Node_Ptr;
+ end record;
+
+end WisiToken.Parse.LR;
diff --git a/wisitoken-parse-packrat-generated.adb
b/wisitoken-parse-packrat-generated.adb
new file mode 100644
index 0000000..c71e57c
--- /dev/null
+++ b/wisitoken-parse-packrat-generated.adb
@@ -0,0 +1,86 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+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
+ -- 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.
+
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ Junk : WisiToken.Syntax_Trees.Valid_Node_Index;
+ pragma Unreferenced (Junk);
+
+ Result : Memo_Entry;
+ begin
+ Parser.Base_Tree.Clear;
+ Parser.Tree.Initialize (Parser.Base_Tree'Unchecked_Access, Flush =>
True);
+ Parser.Lex_All;
+ Parser.Derivs.Set_First (Descriptor.First_Nonterminal);
+ Parser.Derivs.Set_Last (Descriptor.Last_Nonterminal);
+
+ for Nonterm in Descriptor.First_Nonterminal ..
Parser.Trace.Descriptor.Last_Nonterminal loop
+ Parser.Derivs (Nonterm).Clear;
+ Parser.Derivs (Nonterm).Set_First (Parser.Terminals.First_Index);
+ Parser.Derivs (Nonterm).Set_Last (Parser.Terminals.Last_Index);
+ end loop;
+
+ for Token_Index in Parser.Terminals.First_Index ..
Parser.Terminals.Last_Index loop
+ Junk := Parser.Tree.Add_Terminal (Token_Index, Parser.Terminals);
+ -- FIXME: move this into Lex_All, delete Terminals, just use
Syntax_Tree
+ end loop;
+
+ Result := Parser.Parse_WisiToken_Accept (Parser,
Parser.Terminals.First_Index - 1);
+
+ if Result.State /= Success then
+ if Trace_Parse > Outline then
+ Parser.Trace.Put_Line ("parse failed");
+ end if;
+
+ raise Syntax_Error with "parse failed"; -- FIXME: need better error
message!
+ else
+ Parser.Tree.Set_Root (Result.Result);
+ end if;
+
+ end Parse;
+
+ overriding function Any_Errors (Parser : in Generated.Parser) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ return Parser.Lexer.Errors.Length > 0;
+ end Any_Errors;
+
+ overriding procedure Put_Errors (Parser : in Generated.Parser)
+ is
+ use Ada.Text_IO;
+ 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;
+
+ -- FIXME: Packrat parser does not report errors yet.
+ end Put_Errors;
+
+end WisiToken.Parse.Packrat.Generated;
diff --git a/wisitoken-parse-packrat-generated.ads
b/wisitoken-parse-packrat-generated.ads
new file mode 100644
index 0000000..408d48e
--- /dev/null
+++ b/wisitoken-parse-packrat-generated.ads
@@ -0,0 +1,70 @@
+-- Abstract :
+--
+-- Types and operations for a packrat parser runtime, with nonterm
+-- parsing subprograms generated by wisi-generate.
+--
+-- References:
+--
+-- see parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+with WisiToken.Syntax_Trees;
+package WisiToken.Parse.Packrat.Generated is
+
+ Recursive : exception; -- FIXME: delete
+
+ type Memo_State is (No_Result, Failure, Success);
+ subtype Result_States is Memo_State range Failure .. Success;
+
+ type Memo_Entry (State : Memo_State := No_Result) is record
+
+ case State is
+ when No_Result =>
+ Recursive : Boolean := False; -- FIXME: delete
+
+ when Failure =>
+ null;
+
+ when Success =>
+ Result : aliased WisiToken.Syntax_Trees.Valid_Node_Index;
+
+ Last_Token : Base_Token_Index; -- FIXME: change to Last_Pos
+
+ end case;
+ end record;
+
+ package Memos is new SAL.Gen_Unbounded_Definite_Vectors (Token_Index,
Memo_Entry);
+
+ 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);
+
+ type Parse_WisiToken_Accept is access
+ -- WORKAROUND: using Packrat.Parser'Class here hits a GNAT Bug box in
GPL 2018.
+ function (Parser : in out Base_Parser'Class; Last_Pos : in
Base_Token_Index) return Result_Type;
+
+ type Parser is new Packrat.Parser with record
+ Derivs : Generated.Derivs.Vector; -- FIXME: use discriminated array, as
in procedural
+
+ Parse_WisiToken_Accept : Generated.Parse_WisiToken_Accept;
+ end record;
+
+ overriding procedure Parse (Parser : aliased in out Generated.Parser);
+ overriding function Any_Errors (Parser : in Generated.Parser) return
Boolean;
+ overriding procedure Put_Errors (Parser : in Generated.Parser);
+
+end WisiToken.Parse.Packrat.Generated;
diff --git a/wisitoken-parse-packrat-procedural.adb
b/wisitoken-parse-packrat-procedural.adb
new file mode 100644
index 0000000..8ec9559
--- /dev/null
+++ b/wisitoken-parse-packrat-procedural.adb
@@ -0,0 +1,251 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Parse.Packrat.Procedural is
+
+ function Apply_Rule
+ (Parser : in out Procedural.Parser;
+ R : in Token_ID;
+ Last_Pos : in Base_Token_Index)
+ return Memo_Entry
+ with Post => Apply_Rule'Result.State in Failure .. Success;
+
+ function Eval
+ (Parser : in out Procedural.Parser;
+ R : in Token_ID;
+ Last_Pos : in Base_Token_Index)
+ return Memo_Entry
+ with Post => Eval'Result.State in Failure .. Success;
+
+ ----------
+ -- bodies
+
+ function Eval
+ (Parser : in out Procedural.Parser;
+ R : in Token_ID;
+ Last_Pos : in Base_Token_Index)
+ return Memo_Entry
+ is
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
+
+ Pos : Base_Token_Index := Last_Pos; -- last token parsed.
+ begin
+ for RHS_Index in Parser.Grammar (R).RHSs.First_Index .. Parser.Grammar
(R).RHSs.Last_Index loop
+ declare
+ use all type Ada.Containers.Count_Type;
+ RHS : WisiToken.Productions.Right_Hand_Side renames
Parser.Grammar (R).RHSs (RHS_Index);
+ Memo : Memo_Entry; -- for temporary or intermediate results
+ begin
+ if RHS.Tokens.Length = 0 then
+ return
+ (State => Success,
+ Result => Parser.Tree.Add_Nonterm
+ (Production => (R, RHS_Index),
+ Action => RHS.Action,
+ Children => (1 .. 0 =>
Syntax_Trees.Invalid_Node_Index),
+ Default_Virtual => False),
+ Last_Pos => Pos);
+ else
+ declare
+ Children : Syntax_Trees.Valid_Node_Index_Array
+ (SAL.Base_Peek_Type (RHS.Tokens.First_Index) ..
SAL.Base_Peek_Type (RHS.Tokens.Last_Index));
+ begin
+ for I in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index loop
+ if RHS.Tokens (I) in Terminal then
+ if Pos = Parser.Terminals.Last_Index then
+ goto Fail_RHS;
+
+ elsif Parser.Terminals (Pos + 1).ID = RHS.Tokens (I)
then
+ Pos := Pos + 1;
+ Children (SAL.Base_Peek_Type (I)) := Tree_Index
(Pos);
+ else
+ goto Fail_RHS;
+ end if;
+ else
+ Memo := Apply_Rule (Parser, RHS.Tokens (I), Pos);
+ case Memo.State is
+ when Success =>
+ Children (SAL.Base_Peek_Type (I)) := Memo.Result;
+ Pos := Memo.Last_Pos;
+
+ when Failure =>
+ goto Fail_RHS;
+ when No_Result =>
+ raise SAL.Programmer_Error;
+ end case;
+ end if;
+ end loop;
+
+ return
+ (State => Success,
+ Result => Parser.Tree.Add_Nonterm
+ (Production => (R, RHS_Index),
+ Action => RHS.Action,
+ Children => Children,
+ Default_Virtual => False),
+ Last_Pos => Pos);
+
+ <<Fail_RHS>>
+ Pos := Last_Pos;
+ end;
+ end if;
+ end;
+ end loop;
+ -- get here when all RHSs fail
+
+ return (State => Failure);
+ end Eval;
+
+ function Apply_Rule
+ (Parser : in out Procedural.Parser;
+ R : in Token_ID;
+ Last_Pos : in Base_Token_Index)
+ return Memo_Entry
+ is
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ Pos : Base_Token_Index := Last_Pos; -- last token parsed.
+ Start_Pos : constant Token_Index := Last_Pos + 1; -- first token in
current nonterm
+ Memo : Memo_Entry := Parser.Derivs (R)(Start_Pos);
+
+ Pos_Recurse_Last : Base_Token_Index := Last_Pos;
+ Result_Recurse : Memo_Entry;
+ begin
+ case Memo.State is
+ when Success =>
+ return Memo;
+
+ when Failure =>
+ return (State => Failure);
+
+ when No_Result =>
+ if Parser.Direct_Left_Recursive (R) then
+ Parser.Derivs (R).Replace_Element (Start_Pos, (State => Failure));
+ else
+ Memo := Eval (Parser, R, Last_Pos);
+ if Trace_Parse > Detail and then Memo.State = Success then
+ Parser.Trace.Put_Line (Parser.Tree.Image (Memo.Result,
Descriptor, Include_Children => True));
+ end if;
+ Parser.Derivs (R).Replace_Element (Start_Pos, Memo);
+ return Memo;
+ end if;
+ end case;
+
+ loop
+ Pos := Last_Pos;
+
+ if Pos > Parser.Terminals.Last_Index then -- FIXME: this can't pass
here; Last_Pos never > last_index
+ -- There might be an empty nonterm after the last token
+ return (State => Failure);
+ end if;
+
+ Result_Recurse := Eval (Parser, R, Pos);
+
+ if Result_Recurse.State = Success then
+ if Result_Recurse.Last_Pos > Pos_Recurse_Last then
+ Parser.Derivs (R).Replace_Element (Start_Pos, Result_Recurse);
+ Pos := Result_Recurse.Last_Pos;
+ Pos_Recurse_Last := Pos;
+
+ if WisiToken.Trace_Parse > Detail then
+ Parser.Trace.Put_Line
+ (Parser.Tree.Image (Result_Recurse.Result, Descriptor,
Include_Children => True));
+ end if;
+ -- continue looping
+
+ elsif Result_Recurse.Last_Pos = Pos_Recurse_Last then
+ if Parser.Tree.Is_Empty (Result_Recurse.Result) then
+ Parser.Derivs (R).Replace_Element (Start_Pos,
Result_Recurse);
+ end if;
+ exit;
+ else
+ -- Result_Recurse.Last_Pos < Pos_Recurse_Last
+ exit;
+ end if;
+ else
+ exit;
+ end if;
+ end loop;
+ return Parser.Derivs (R)(Start_Pos);
+ end Apply_Rule;
+
+ ----------
+ -- Public subprograms
+
+ function Create
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Direct_Left_Recursive : in Token_ID_Set;
+ Start_ID : in Token_ID;
+ Trace : access WisiToken.Trace'Class;
+ Lexer : WisiToken.Lexer.Handle;
+ User_Data : WisiToken.Syntax_Trees.User_Data_Access)
+ return Procedural.Parser
+ is begin
+ return Parser : Procedural.Parser (Grammar.First_Index,
Grammar.Last_Index) do
+ Parser.Trace := Trace;
+ Parser.Lexer := Lexer;
+ Parser.User_Data := User_Data;
+ Parser.Grammar := Grammar;
+ Parser.Start_ID := Start_ID;
+ Parser.Direct_Left_Recursive := Direct_Left_Recursive;
+ end return;
+ end Create;
+
+ overriding procedure Parse (Parser : aliased in out Procedural.Parser)
+ is
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ Junk : WisiToken.Syntax_Trees.Valid_Node_Index;
+ pragma Unreferenced (Junk);
+
+ Result : Memo_Entry;
+ begin
+ Parser.Base_Tree.Clear;
+ Parser.Tree.Initialize (Parser.Base_Tree'Unchecked_Access, Flush =>
True);
+ Parser.Lex_All;
+
+ for Nonterm in Descriptor.First_Nonterminal ..
Parser.Trace.Descriptor.Last_Nonterminal loop
+ Parser.Derivs (Nonterm).Clear;
+ Parser.Derivs (Nonterm).Set_First (Parser.Terminals.First_Index);
+
+ -- There might be an empty nonterm after the last token
+ Parser.Derivs (Nonterm).Set_Last (Parser.Terminals.Last_Index + 1);
+ end loop;
+
+ for Token_Index in Parser.Terminals.First_Index ..
Parser.Terminals.Last_Index loop
+ Junk := Parser.Tree.Add_Terminal (Token_Index, Parser.Terminals);
+ -- FIXME: move this into Lex_All, delete Terminals, just use
Syntax_Tree
+ end loop;
+
+ Result := Apply_Rule (Parser, Parser.Start_ID,
Parser.Terminals.First_Index - 1);
+
+ if Result.State /= Success then
+ if Trace_Parse > Outline then
+ Parser.Trace.Put_Line ("parse failed");
+ end if;
+
+ raise Syntax_Error with "parse failed"; -- FIXME: need better error
message!
+ else
+ Parser.Tree.Set_Root (Result.Result);
+ end if;
+ end Parse;
+
+end WisiToken.Parse.Packrat.Procedural;
diff --git a/wisitoken-parse-packrat-procedural.ads
b/wisitoken-parse-packrat-procedural.ads
new file mode 100644
index 0000000..bd6d86f
--- /dev/null
+++ b/wisitoken-parse-packrat-procedural.ads
@@ -0,0 +1,80 @@
+-- Abstract :
+--
+-- Procedural packrat parser, supporting only direct left recursion.
+--
+-- Coding style, algorithm is the same as generated by
+-- wisi-generate_packrat, but in procedural form.
+--
+-- References:
+--
+-- See parent.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Productions;
+package WisiToken.Parse.Packrat.Procedural is
+
+ -- These types duplicate Packrat.Generated. We keep them separate so
+ -- we can experiment with ways of implementing indirect left
+ -- recursion.
+
+ type Memo_State is (No_Result, Failure, Success);
+ subtype Result_States is Memo_State range Failure .. Success;
+
+ type Memo_Entry (State : Memo_State := No_Result) is record
+ case State is
+ when No_Result =>
+ null;
+
+ when Failure =>
+ null;
+
+ when Success =>
+ Result : WisiToken.Syntax_Trees.Valid_Node_Index;
+ Last_Pos : Base_Token_Index;
+
+ end case;
+ end record;
+
+ package Memos is new SAL.Gen_Unbounded_Definite_Vectors (Token_Index,
Memo_Entry);
+ type Derivs is array (Token_ID range <>) of Memos.Vector;
+
+ type Parser (First_Nonterminal, Last_Nonterminal : Token_ID) is new
Packrat.Parser with
+ record
+ Grammar : WisiToken.Productions.Prod_Arrays.Vector;
+ Start_ID : Token_ID;
+ Direct_Left_Recursive : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
+ Derivs : Procedural.Derivs (First_Nonterminal ..
Last_Nonterminal);
+ end record;
+
+ function Create
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Direct_Left_Recursive : in Token_ID_Set;
+ Start_ID : in Token_ID;
+ Trace : access WisiToken.Trace'Class;
+ Lexer : WisiToken.Lexer.Handle;
+ User_Data : WisiToken.Syntax_Trees.User_Data_Access)
+ return Procedural.Parser;
+
+ overriding procedure Parse (Parser : aliased in out Procedural.Parser);
+ overriding function Any_Errors (Parser : in Procedural.Parser) return
Boolean
+ is (False);
+ -- All errors are reported by Parse raising Syntax_Error.
+
+ overriding procedure Put_Errors (Parser : in Procedural.Parser)
+ is null;
+
+end WisiToken.Parse.Packrat.Procedural;
diff --git a/wisitoken-parse-packrat.adb b/wisitoken-parse-packrat.adb
new file mode 100644
index 0000000..fd5f586
--- /dev/null
+++ b/wisitoken-parse-packrat.adb
@@ -0,0 +1,56 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Parse.Packrat is
+
+ overriding procedure Execute_Actions (Parser : in out Packrat.Parser)
+ is
+ Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
+
+ procedure Process_Node
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Syntax_Trees.Valid_Node_Index)
+ is
+ use all type Syntax_Trees.Node_Label;
+ begin
+ if Tree.Label (Node) /= Nonterm then
+ return;
+ end if;
+
+ declare
+ 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 Trace_Action > Outline then
+ Parser.Trace.Put_Line ("root node: " & Parser.Tree.Image
(Parser.Tree.Root, Descriptor));
+ end if;
+
+ Parser.Tree.Process_Tree (Process_Node'Access);
+ end Execute_Actions;
+
+end WisiToken.Parse.Packrat;
diff --git a/wisitoken-parse-packrat.ads b/wisitoken-parse-packrat.ads
new file mode 100644
index 0000000..50ff2f0
--- /dev/null
+++ b/wisitoken-parse-packrat.ads
@@ -0,0 +1,71 @@
+-- Abstract :
+--
+-- Types and operations for a packrat parser runtime.
+--
+-- References:
+--
+-- [ford thesis] Bryan Ford thesis http://bford.info/pub/lang/thesis
+--
+-- [langkit] AdaCore langkit https://github.com/adacore/langkit
+--
+-- [tratt 2010] http://tratt.net/laurie/research/pubs/papers/
+-- tratt__direct_left_recursive_parsing_expression_grammars.pdf
+--
+-- [warth 2008] Warth, A., Douglass, J.R. and Millstein, T.D., 2008. Packrat
+-- parsers can support left recursion. PEPM, 8, pp.103-110.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+-- Design:
+--
+-- [ford thesis] uses Haskell lazy evaluation, and does not use a
+-- lexer. We use a lexer to reduce the memory requirement. Although
+-- eliminating the lexer would make it easier to support additional
+-- syntax for a preprocessor or template generator.
+--
+-- [langkit] uses a lexer, and implements lazy evaluation via
+-- Memo_State, Memo_Entry as we do here, except that their result
+-- type is a specific AST type provided by a generic parameter; we
+-- use the general purpose Syntax_Tree.Tree type.
+--
+-- [langkit] also applies a memory optimization; it only saves the
+-- last 16 results for each nonterminal. We don't do that yet, so we
+-- can get some data on how well that works.
+
+pragma License (Modified_GPL);
+with WisiToken.Syntax_Trees;
+package WisiToken.Parse.Packrat is
+
+ function Tree_Index (Terminal_Index : in Token_Index) return
Syntax_Trees.Valid_Node_Index
+ is (Syntax_Trees.Valid_Node_Index (Terminal_Index));
+ -- All tokens are read and entered into the syntax tree before any
+ -- nonterms are reduced, so the mapping from Terminals token_index to
+ -- Tree node_index is identity.
+
+ type Parser is abstract new Base_Parser with record
+ -- Dynamic parsing data
+
+ Base_Tree : aliased WisiToken.Syntax_Trees.Base_Tree;
+ Tree : WisiToken.Syntax_Trees.Tree;
+ -- FIXME: Current we only need Base_Tree for Execute_Actions, except
+ -- that Syntax_Trees only declares the needed operations on Tree. But
+ -- we may need more trees for error recovery; if not, fix
+ -- Syntax_Trees, move Base_Tree and Execute_Actions up to
+ -- base_parser.
+
+ end record;
+
+ overriding procedure Execute_Actions (Parser : in out Packrat.Parser);
+
+end WisiToken.Parse.Packrat;
diff --git a/wisitoken-parse.adb b/wisitoken-parse.adb
new file mode 100644
index 0000000..0573a95
--- /dev/null
+++ b/wisitoken-parse.adb
@@ -0,0 +1,88 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Parse is
+
+ function Next_Grammar_Token (Parser : in out Base_Parser) return Token_ID
+ is
+ use all type Syntax_Trees.User_Data_Access;
+
+ Token : Base_Token;
+ Error : Boolean;
+ begin
+ loop
+ Error := Parser.Lexer.Find_Next (Token);
+
+ -- We don't handle Error until later; we assume it was recovered.
+
+ if Parser.User_Data /= null then
+ Parser.User_Data.Lexer_To_Augmented (Token, Parser.Lexer);
+ end if;
+
+ if Token.Line /= Invalid_Line_Number then
+ -- Some lexers don't support line numbers.
+ if Parser.Lexer.First then
+ Parser.Line_Begin_Token.Set_Length (Ada.Containers.Count_Type
(Token.Line));
+ 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
+ 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;
+ end if;
+
+ if Trace_Parse > Lexer_Debug then
+ Parser.Trace.Put_Line (Image (Token, Parser.Trace.Descriptor.all));
+ end if;
+
+ exit when Token.ID >= Parser.Trace.Descriptor.First_Terminal;
+ end loop;
+ Parser.Terminals.Append (Token);
+
+ if Error then
+ declare
+ Error : WisiToken.Lexer.Error renames
Parser.Lexer.Errors.Reference (Parser.Lexer.Errors.Last);
+ begin
+ if Error.Recover_Char (1) /= ASCII.NUL then
+ Error.Recover_Token := Parser.Terminals.Last_Index;
+ end if;
+ end;
+ end if;
+
+ return Token.ID;
+ end Next_Grammar_Token;
+
+ procedure Lex_All (Parser : in out Base_Parser)
+ is
+ EOF_ID : constant Token_ID := Parser.Trace.Descriptor.EOF_ID;
+ begin
+ Parser.Lexer.Errors.Clear;
+ Parser.Terminals.Clear;
+ Parser.Line_Begin_Token.Clear;
+ loop
+ exit when EOF_ID = Next_Grammar_Token (Parser);
+ end loop;
+ if Trace_Parse > Outline then
+ Parser.Trace.Put_Line (Token_Index'Image
(Parser.Terminals.Last_Index) & " tokens lexed");
+ end if;
+
+ end Lex_All;
+
+end WisiToken.Parse;
diff --git a/wisitoken-parse.ads b/wisitoken-parse.ads
new file mode 100644
index 0000000..271163f
--- /dev/null
+++ b/wisitoken-parse.ads
@@ -0,0 +1,66 @@
+-- Abstract :
+--
+-- Subprograms common to more than one parser, higher-level than in
wisitoken.ads
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with WisiToken.Lexer;
+with WisiToken.Syntax_Trees;
+package WisiToken.Parse is
+
+ type Base_Parser is abstract new Ada.Finalization.Limited_Controlled with
record
+ Trace : access WisiToken.Trace'Class;
+ Lexer : WisiToken.Lexer.Handle;
+ User_Data : WisiToken.Syntax_Trees.User_Data_Access;
+ Terminals : aliased WisiToken.Base_Token_Arrays.Vector;
+ Line_Begin_Token : aliased WisiToken.Line_Begin_Token_Vectors.Vector;
+ end record;
+ -- Common to all parsers. Finalize should free any allocated objects.
+
+ function Next_Grammar_Token (Parser : in out Base_Parser) return Token_ID;
+ -- Get next token from Lexer, call User_Data.Lexer_To_Augmented. If
+ -- it is a grammar token, store in Terminals and return its id.
+ -- Otherwise, repeat.
+ --
+ -- Propagates Fatal_Error from Lexer.
+
+ procedure Lex_All (Parser : in out Base_Parser);
+ -- Clear Terminals, Line_Begin_Token; reset User_Data. Then call
+ -- Next_Grammar_Token repeatedly until EOF_ID is returned.
+ --
+ -- The user must first call Lexer.Reset_* to set the input text.
+
+ procedure Parse (Shared_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.
+ --
+ -- If a parse error is encountered, raises Syntax_Error.
+ -- Parser.Lexer_Errors and Parser contain information about the
+ -- errors.
+ --
+ -- For other errors, raises Parse_Error with an appropriate error
+ -- message.
+
+ function Any_Errors (Parser : in Base_Parser) return Boolean is abstract;
+
+ procedure Put_Errors (Parser : in Base_Parser) is abstract;
+ -- Output error messages to Ada.Text_IO.Current_Error.
+
+ procedure Execute_Actions (Parser : in out Base_Parser) is abstract;
+ -- Execute all actions in Parser.Tree.
+
+end WisiToken.Parse;
diff --git a/wisitoken-productions.adb b/wisitoken-productions.adb
new file mode 100644
index 0000000..4d5079a
--- /dev/null
+++ b/wisitoken-productions.adb
@@ -0,0 +1,51 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephe Leake
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Text_IO;
+package body WisiToken.Productions is
+
+ function Image
+ (LHS : in Token_ID;
+ RHS_Index : in Natural;
+ RHS : in Token_ID_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := +Trimmed_Image ((LHS, RHS_Index)) & ": " &
Image (LHS, Descriptor) & " <=";
+ begin
+ for ID of RHS loop
+ Result := Result & ' ' & Image (ID, Descriptor);
+ end loop;
+ return To_String (Result);
+ end Image;
+
+ procedure Put (Grammar : Prod_Arrays.Vector; Descriptor : in
WisiToken.Descriptor)
+ is begin
+ for P of Grammar loop
+ for R in P.RHSs.First_Index .. P.RHSs.Last_Index loop
+ Ada.Text_IO.Put_Line (Image (P.LHS, R, P.RHSs (R).Tokens,
Descriptor));
+ end loop;
+ end loop;
+ end Put;
+
+end WisiToken.Productions;
diff --git a/wisitoken-productions.ads b/wisitoken-productions.ads
new file mode 100644
index 0000000..19f8dfa
--- /dev/null
+++ b/wisitoken-productions.ads
@@ -0,0 +1,64 @@
+-- Abstract :
+--
+-- Type and operations for building grammar productions.
+--
+-- Copyright (C) 2018 Stephe Leake
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. This library is distributed in
+-- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
+-- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
+-- PARTICULAR PURPOSE.
+--
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with SAL.Gen_Unbounded_Definite_Vectors;
+with WisiToken.Semantic_Checks;
+with WisiToken.Syntax_Trees;
+package WisiToken.Productions is
+
+ type Right_Hand_Side is record
+ Tokens : Token_ID_Arrays.Vector;
+ Action : WisiToken.Syntax_Trees.Semantic_Action;
+ Check : WisiToken.Semantic_Checks.Semantic_Check;
+ end record;
+
+ package RHS_Arrays is new SAL.Gen_Unbounded_Definite_Vectors (Natural,
Right_Hand_Side);
+
+ 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);
+
+ function Image
+ (LHS : in Token_ID;
+ RHS_Index : in Natural;
+ RHS : in Token_ID_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return String;
+ -- For comments in generated code, diagnostic messages.
+
+ 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);
+
+ type Prod_Source_Line_Map is record
+ Line : Line_Number_Type;
+ 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);
+ -- For line numbers of productions in source files.
+
+end WisiToken.Productions;
diff --git a/wisitoken-regexp.adb b/wisitoken-regexp.adb
new file mode 100644
index 0000000..b978bf9
--- /dev/null
+++ b/wisitoken-regexp.adb
@@ -0,0 +1,1347 @@
+-- Abstract:
+--
+-- See spec.
+--
+-- Copyright (C) 2015, 2017 Stephen Leake
+-- Copyright (C) 1998-2010, AdaCore
+--
+-- 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.
+--
+-- 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.
+--
+-- You should have received a copy of the GNU General Public License
+-- and a copy of the GCC Runtime Library Exception distributed with
+-- the WisiToken package; see files GPL.txt and GPL_runtime.txt. If
+-- not, see <http://www.gnu.org/licenses/>.
+
+pragma License (Modified_GPL);
+
+with Ada.Unchecked_Deallocation;
+with GNAT.Case_Util;
+package body WisiToken.Regexp is
+
+ Initial_Max_States_In_Primary_Table : constant := 100;
+ -- Initial size for the number of states in the indefinite state
+ -- machine. The number of states will be increased as needed.
+ --
+ -- This is also used as the maximal number of meta states (groups of
+ -- states) in the secondary table.
+
+ Open_Paren : constant Character := '(';
+ Close_Paren : constant Character := ')';
+ Open_Bracket : constant Character := '[';
+ Close_Bracket : constant Character := ']';
+
+ type State_Index is new Natural;
+ type Column_Index is new Natural;
+
+ type Regexp_Array is array
+ (State_Index range <>, Column_Index range <>) of State_Index;
+ -- First index is for the state number. Second index is for the character
+ -- type. Contents is the new State.
+
+ type Regexp_Array_Access is access Regexp_Array;
+ -- Use this type through the functions Set below, so that it can grow
+ -- dynamically depending on the needs.
+
+ type Mapping is array (Character'Range) of Column_Index;
+ -- Mapping between characters and column in the Regexp_Array
+
+ type Boolean_Array is array (State_Index range <>) of Boolean;
+
+ type Regexp_Value
+ (Alphabet_Size : Column_Index;
+ Num_States : State_Index) is
+ record
+ Map : Mapping;
+ States : Regexp_Array (1 .. Num_States, 0 .. Alphabet_Size);
+ Is_Final : Boolean_Array (1 .. Num_States);
+ Case_Sensitive : Boolean;
+ State : State_Index;
+ end record;
+ -- Deterministic finite-state machine
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Set
+ (Table : in out Regexp_Array_Access;
+ State : State_Index;
+ Column : Column_Index;
+ Value : State_Index);
+ -- Sets a value in the table. If the table is too small, reallocate it
+ -- dynamically so that (State, Column) is a valid index in it.
+
+ function Get
+ (Table : Regexp_Array_Access;
+ State : State_Index;
+ Column : Column_Index) return State_Index;
+ -- Returns the value in the table at (State, Column). If this index does
+ -- not exist in the table, returns zero.
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Regexp_Array, Regexp_Array_Access);
+
+ overriding procedure Adjust (R : in out Regexp) is
+ Tmp : Regexp_Access;
+ begin
+ if R.R /= null then
+ Tmp := new Regexp_Value (Alphabet_Size => R.R.Alphabet_Size,
+ Num_States => R.R.Num_States);
+ Tmp.all := R.R.all;
+ R.R := Tmp;
+ end if;
+ end Adjust;
+
+ procedure Clear (R : in out Regexp)
+ is begin
+ R.R.State := 1;
+ end Clear;
+
+ function Compile
+ (Pattern : String;
+ Case_Sensitive : Boolean := True) return Regexp
+ is
+ S : String := Pattern;
+ -- The pattern which is really compiled (when the pattern is case
+ -- insensitive, we convert this string to lower-cases
+
+ Map : Mapping := (others => 0);
+ -- Mapping between characters and columns in the tables
+
+ Alphabet_Size : Column_Index := 0;
+ -- Number of significant characters in the regular expression.
+ -- This total does not include special operators, such as *, (, ...
+
+ procedure Check_Well_Formed_Pattern;
+ -- Check that the pattern to compile is well-formed, so that subsequent
+ -- code can rely on this without performing each time the checks to
+ -- avoid accessing the pattern outside its bounds. However, not all
+ -- well-formedness rules are checked. In particular, rules about special
+ -- characters not being treated as regular characters are not checked.
+
+ procedure Create_Mapping;
+ -- Creates a mapping between characters in the regexp and columns
+ -- in the tables representing the regexp. Test that the regexp is
+ -- well-formed Modifies Alphabet_Size and Map
+
+ procedure Create_Primary_Table
+ (Table : out Regexp_Array_Access;
+ Num_States : out State_Index;
+ Start_State : out State_Index;
+ End_State : out State_Index);
+ -- Creates the first version of the regexp (this is a non deterministic
+ -- finite state machine, which is unadapted for a fast pattern
+ -- matching algorithm). We use a recursive algorithm to process the
+ -- parenthesis sub-expressions.
+ --
+ -- Table : at the end of the procedure : Column 0 is for any character
+ -- ('.') and the last columns are for no character (closure). Num_States
+ -- is set to the number of states in the table Start_State is the number
+ -- of the starting state in the regexp End_State is the number of the
+ -- final state when the regexp matches.
+
+ function Create_Secondary_Table
+ (First_Table : Regexp_Array_Access;
+ Start_State : State_Index;
+ End_State : State_Index) return Regexp;
+ -- Creates the definitive table representing the regular expression
+ -- This is actually a transformation of the primary table First_Table,
+ -- where every state is grouped with the states in its 'no-character'
+ -- columns. The transitions between the new states are then recalculated
+ -- and if necessary some new states are created.
+ --
+ -- Note that the resulting finite-state machine is not optimized in
+ -- terms of the number of states : it would be more time-consuming to
+ -- add a third pass to reduce the number of states in the machine, with
+ -- no speed improvement...
+
+ procedure Raise_Exception (M : String; Index : Integer);
+ pragma No_Return (Raise_Exception);
+ -- Raise an exception, indicating an error at character Index in S
+
+ -------------------------------
+ -- Check_Well_Formed_Pattern --
+ -------------------------------
+
+ procedure Check_Well_Formed_Pattern is
+ J : Integer;
+
+ Past_Elmt : Boolean := False;
+ -- Set to True everywhere an elmt has been parsed,
+ -- meaning there can be now an occurrence of '*', '+' and '?'.
+
+ Past_Term : Boolean := False;
+ -- Set to True everywhere a term has been parsed,
+ -- meaning there can be now an occurrence of '|'.
+
+ Parenthesis_Level : Integer := 0;
+
+ Last_Open : Integer := S'First - 1;
+ -- The last occurrence of an opening parenthesis.
+
+ procedure Raise_Exception_If_No_More_Chars (K : Integer := 0);
+ -- If no more characters are raised, call Raise_Exception
+
+ --------------------------------------
+ -- Raise_Exception_If_No_More_Chars --
+ --------------------------------------
+
+ procedure Raise_Exception_If_No_More_Chars (K : Integer := 0) is
+ begin
+ if J + K > S'Last then
+ Raise_Exception ("Ill-formed pattern while parsing", J);
+ end if;
+ end Raise_Exception_If_No_More_Chars;
+
+ -- Start of processing for Check_Well_Formed_Pattern
+
+ begin
+ J := S'First;
+ while J <= S'Last loop
+ case S (J) is
+ when Open_Bracket =>
+ J := J + 1;
+ Raise_Exception_If_No_More_Chars;
+
+ if S (J) = '^' then
+ J := J + 1;
+ Raise_Exception_If_No_More_Chars;
+ end if;
+
+ -- The first character never has a special meaning
+
+ if S (J) = ']' or else S (J) = '-' then
+ J := J + 1;
+ Raise_Exception_If_No_More_Chars;
+ end if;
+
+ -- The set of characters cannot be empty
+
+ if S (J) = ']' then
+ Raise_Exception
+ ("Set of characters cannot be empty in regular "
+ & "expression", J);
+ end if;
+
+ declare
+ Possible_Range_Start : Boolean := True;
+ -- Set True everywhere a range character '-' can occur
+
+ begin
+ loop
+ exit when S (J) = Close_Bracket;
+
+ -- The current character should be followed by a
+ -- closing bracket.
+
+ Raise_Exception_If_No_More_Chars (1);
+
+ if S (J) = '-'
+ and then S (J + 1) /= Close_Bracket
+ then
+ if not Possible_Range_Start then
+ Raise_Exception
+ ("No mix of ranges is allowed in "
+ & "regular expression", J);
+ end if;
+
+ J := J + 1;
+ Raise_Exception_If_No_More_Chars;
+
+ -- Range cannot be followed by '-' character,
+ -- except as last character in the set.
+
+ Possible_Range_Start := False;
+
+ else
+ Possible_Range_Start := True;
+ end if;
+
+ if S (J) = '\' then
+ J := J + 1;
+ Raise_Exception_If_No_More_Chars;
+ end if;
+
+ J := J + 1;
+ end loop;
+ end;
+
+ -- A closing bracket can end an elmt or term
+
+ Past_Elmt := True;
+ Past_Term := True;
+
+ when Close_Bracket =>
+
+ -- A close bracket must follow a open_bracket, and cannot be
+ -- found alone on the line.
+
+ Raise_Exception
+ ("Incorrect character ']' in regular expression", J);
+
+ when '\' =>
+ if J < S'Last then
+ J := J + 1;
+
+ -- Any character can be an elmt or a term
+
+ Past_Elmt := True;
+ Past_Term := True;
+
+ else
+ -- \ not allowed at the end of the regexp
+
+ Raise_Exception
+ ("Incorrect character '\' in regular expression", J);
+ end if;
+
+ when Open_Paren =>
+ Parenthesis_Level := Parenthesis_Level + 1;
+ Last_Open := J;
+
+ -- An open parenthesis does not end an elmt or term
+
+ Past_Elmt := False;
+ Past_Term := False;
+
+ when Close_Paren =>
+ Parenthesis_Level := Parenthesis_Level - 1;
+
+ if Parenthesis_Level < 0 then
+ Raise_Exception
+ ("')' is not associated with '(' in regular "
+ & "expression", J);
+ end if;
+
+ if J = Last_Open + 1 then
+ Raise_Exception
+ ("Empty parentheses not allowed in regular "
+ & "expression", J);
+ end if;
+
+ if not Past_Term then
+ Raise_Exception
+ ("Closing parenthesis not allowed here in regular "
+ & "expression", J);
+ end if;
+
+ -- A closing parenthesis can end an elmt or term
+
+ Past_Elmt := True;
+ Past_Term := True;
+
+ when '{' =>
+ -- Any character can be an elmt or a term
+
+ Past_Elmt := True;
+ Past_Term := True;
+
+ -- No need to check for ',' as the code always accepts them
+
+ when '}' =>
+ -- Any character can be an elmt or a term
+
+ Past_Elmt := True;
+ Past_Term := True;
+
+ when '*' | '?' | '+' =>
+ -- These operators must apply to an elmt sub-expression,
+ -- and cannot be found if one has not just been parsed.
+
+ if not Past_Elmt then
+ Raise_Exception
+ ("'*', '+' and '?' operators must be "
+ & "applied to an element in regular expression", J);
+ end if;
+
+ Past_Elmt := False;
+ Past_Term := True;
+
+ when '|' =>
+ -- This operator must apply to a term sub-expression,
+ -- and cannot be found if one has not just been parsed.
+
+ if not Past_Term then
+ Raise_Exception
+ ("'|' operator must be "
+ & "applied to a term in regular expression", J);
+ end if;
+
+ Past_Elmt := False;
+ Past_Term := False;
+
+ when others =>
+ -- Any character can be an elmt or a term
+
+ Past_Elmt := True;
+ Past_Term := True;
+ end case;
+
+ J := J + 1;
+ end loop;
+
+ -- A closing parenthesis must follow an open parenthesis
+
+ if Parenthesis_Level /= 0 then
+ Raise_Exception
+ ("'(' must always be associated with a ')'", J);
+ end if;
+ end Check_Well_Formed_Pattern;
+
+ --------------------
+ -- Create_Mapping --
+ --------------------
+
+ procedure Create_Mapping is
+
+ procedure Add_In_Map (C : Character);
+ -- Add a character in the mapping, if it is not already defined
+
+ ----------------
+ -- Add_In_Map --
+ ----------------
+
+ procedure Add_In_Map (C : Character) is
+ begin
+ if Map (C) = 0 then
+ Alphabet_Size := Alphabet_Size + 1;
+ Map (C) := Alphabet_Size;
+ end if;
+ end Add_In_Map;
+
+ J : Integer := S'First;
+ Parenthesis_Level : Integer := 0;
+ Last_Open : Integer := S'First - 1;
+
+ -- Start of processing for Create_Mapping
+
+ begin
+ while J <= S'Last loop
+ case S (J) is
+ when Open_Bracket =>
+ J := J + 1;
+
+ if S (J) = '^' then
+ J := J + 1;
+ end if;
+
+ if S (J) = ']' or else S (J) = '-' then
+ J := J + 1;
+ end if;
+
+ -- The first character never has a special meaning
+
+ loop
+ if J > S'Last then
+ Raise_Exception
+ ("Ran out of characters while parsing ", J);
+ end if;
+
+ exit when S (J) = Close_Bracket;
+
+ if S (J) = '-'
+ and then S (J + 1) /= Close_Bracket
+ then
+ declare
+ Start : constant Integer := J - 1;
+
+ begin
+ J := J + 1;
+
+ if S (J) = '\' then
+ J := J + 1;
+ end if;
+
+ for Char in S (Start) .. S (J) loop
+ Add_In_Map (Char);
+ end loop;
+ end;
+ else
+ if S (J) = '\' then
+ J := J + 1;
+ end if;
+
+ Add_In_Map (S (J));
+ end if;
+
+ J := J + 1;
+ end loop;
+
+ -- A close bracket must follow a open_bracket and cannot be
+ -- found alone on the line
+
+ when Close_Bracket =>
+ Raise_Exception
+ ("Incorrect character ']' in regular expression", J);
+
+ when '\' =>
+ if J < S'Last then
+ J := J + 1;
+ Add_In_Map (S (J));
+
+ else
+ -- Back slash \ not allowed at the end of the regexp
+
+ Raise_Exception
+ ("Incorrect character '\' in regular expression", J);
+ end if;
+
+ when Open_Paren =>
+ Parenthesis_Level := Parenthesis_Level + 1;
+ Last_Open := J;
+
+ when Close_Paren =>
+ Parenthesis_Level := Parenthesis_Level - 1;
+
+ if Parenthesis_Level < 0 then
+ Raise_Exception
+ ("')' is not associated with '(' in regular "
+ & "expression", J);
+ end if;
+
+ if J = Last_Open + 1 then
+ Raise_Exception
+ ("Empty parenthesis not allowed in regular "
+ & "expression", J);
+ end if;
+
+ when '*' | '?' =>
+ if J = S'First then
+ Raise_Exception
+ ("'*', '+', '?' and '|' operators cannot be in "
+ & "first position in regular expression", J);
+ end if;
+
+ when '|' | '+' =>
+ if J = S'First then
+
+ -- These operators must apply to a sub-expression,
+ -- and cannot be found at the beginning of the line
+
+ Raise_Exception
+ ("'*', '+', '?' and '|' operators cannot be in "
+ & "first position in regular expression", J);
+ end if;
+
+ when others =>
+ Add_In_Map (S (J));
+ end case;
+
+ J := J + 1;
+ end loop;
+
+ -- A closing parenthesis must follow an open parenthesis
+
+ if Parenthesis_Level /= 0 then
+ Raise_Exception
+ ("'(' must always be associated with a ')'", J);
+ end if;
+
+ end Create_Mapping;
+
+ --------------------------
+ -- Create_Primary_Table --
+ --------------------------
+
+ procedure Create_Primary_Table
+ (Table : out Regexp_Array_Access;
+ Num_States : out State_Index;
+ Start_State : out State_Index;
+ End_State : out State_Index)
+ is
+ Empty_Char : constant Column_Index := Alphabet_Size + 1;
+
+ Current_State : State_Index := 0;
+ -- Index of the last created state
+
+ procedure Add_Empty_Char
+ (State : State_Index;
+ To_State : State_Index);
+ -- Add a empty-character transition from State to To_State
+
+ procedure Create_Repetition
+ (Repetition : Character;
+ Start_Prev : State_Index;
+ End_Prev : State_Index;
+ New_Start : out State_Index;
+ New_End : in out State_Index);
+ -- Create the table in case we have a '*', '+' or '?'.
+ -- Start_Prev .. End_Prev should indicate respectively the start and
+ -- end index of the previous expression, to which '*', '+' or '?' is
+ -- applied.
+
+ procedure Create_Simple
+ (Start_Index : Integer;
+ End_Index : Integer;
+ Start_State : out State_Index;
+ End_State : out State_Index);
+ -- Fill the table for the regexp Simple. This is the recursive
+ -- procedure called to handle () expressions If End_State = 0, then
+ -- the call to Create_Simple creates an independent regexp, not a
+ -- concatenation Start_Index .. End_Index is the starting index in
+ -- the string S.
+ --
+ -- Warning: it may look like we are creating too many empty-string
+ -- transitions, but they are needed to get the correct regexp.
+ -- The table is filled as follow ( s means start-state, e means
+ -- end-state) :
+ --
+ -- regexp state_num | a b * empty_string
+ -- ------- ------------------------------
+ -- a 1 (s) | 2 - - -
+ -- 2 (e) | - - - -
+ --
+ -- ab 1 (s) | 2 - - -
+ -- 2 | - - - 3
+ -- 3 | - 4 - -
+ -- 4 (e) | - - - -
+ --
+ -- a|b 1 | 2 - - -
+ -- 2 | - - - 6
+ -- 3 | - 4 - -
+ -- 4 | - - - 6
+ -- 5 (s) | - - - 1,3
+ -- 6 (e) | - - - -
+ --
+ -- a* 1 | 2 - - -
+ -- 2 | - - - 4
+ -- 3 (s) | - - - 1,4
+ -- 4 (e) | - - - 3
+ --
+ -- (a) 1 (s) | 2 - - -
+ -- 2 (e) | - - - -
+ --
+ -- a+ 1 | 2 - - -
+ -- 2 | - - - 4
+ -- 3 (s) | - - - 1
+ -- 4 (e) | - - - 3
+ --
+ -- a? 1 | 2 - - -
+ -- 2 | - - - 4
+ -- 3 (s) | - - - 1,4
+ -- 4 (e) | - - - -
+ --
+ -- . 1 (s) | 2 2 2 -
+ -- 2 (e) | - - - -
+
+ function Next_Sub_Expression
+ (Start_Index : Integer;
+ End_Index : Integer) return Integer;
+ -- Returns the index of the last character of the next sub-expression
+ -- in Simple. Index cannot be greater than End_Index.
+
+ --------------------
+ -- Add_Empty_Char --
+ --------------------
+
+ procedure Add_Empty_Char
+ (State : State_Index;
+ To_State : State_Index)
+ is
+ J : Column_Index := Empty_Char;
+
+ begin
+ while Get (Table, State, J) /= 0 loop
+ J := J + 1;
+ end loop;
+
+ Set (Table, State, J, To_State);
+ end Add_Empty_Char;
+
+ -----------------------
+ -- Create_Repetition --
+ -----------------------
+
+ procedure Create_Repetition
+ (Repetition : Character;
+ Start_Prev : State_Index;
+ End_Prev : State_Index;
+ New_Start : out State_Index;
+ New_End : in out State_Index)
+ is
+ begin
+ New_Start := Current_State + 1;
+
+ if New_End /= 0 then
+ Add_Empty_Char (New_End, New_Start);
+ end if;
+
+ Current_State := Current_State + 2;
+ New_End := Current_State;
+
+ Add_Empty_Char (End_Prev, New_End);
+ Add_Empty_Char (New_Start, Start_Prev);
+
+ if Repetition /= '+' then
+ Add_Empty_Char (New_Start, New_End);
+ end if;
+
+ if Repetition /= '?' then
+ Add_Empty_Char (New_End, New_Start);
+ end if;
+ end Create_Repetition;
+
+ -------------------
+ -- Create_Simple --
+ -------------------
+
+ procedure Create_Simple
+ (Start_Index : Integer;
+ End_Index : Integer;
+ Start_State : out State_Index;
+ End_State : out State_Index)
+ is
+ J : Integer := Start_Index;
+ Last_Start : State_Index := 0;
+
+ begin
+ Start_State := 0;
+ End_State := 0;
+ while J <= End_Index loop
+ case S (J) is
+ when Open_Paren =>
+ declare
+ J_Start : constant Integer := J + 1;
+ Next_Start : State_Index;
+ Next_End : State_Index;
+
+ begin
+ J := Next_Sub_Expression (J, End_Index);
+ Create_Simple (J_Start, J - 1, Next_Start, Next_End);
+
+ if J < End_Index
+ and then (S (J + 1) = '*' or else
+ S (J + 1) = '+' or else
+ S (J + 1) = '?')
+ then
+ J := J + 1;
+ Create_Repetition
+ (S (J),
+ Next_Start,
+ Next_End,
+ Last_Start,
+ End_State);
+
+ else
+ Last_Start := Next_Start;
+
+ if End_State /= 0 then
+ Add_Empty_Char (End_State, Last_Start);
+ end if;
+
+ End_State := Next_End;
+ end if;
+ end;
+
+ when '|' =>
+ declare
+ Start_Prev : constant State_Index := Start_State;
+ End_Prev : constant State_Index := End_State;
+ Start_J : constant Integer := J + 1;
+ Start_Next : State_Index := 0;
+ End_Next : State_Index := 0;
+
+ begin
+ J := Next_Sub_Expression (J, End_Index);
+
+ -- Create a new state for the start of the alternative
+
+ Current_State := Current_State + 1;
+ Last_Start := Current_State;
+ Start_State := Last_Start;
+
+ -- Create the tree for the second part of alternative
+
+ Create_Simple (Start_J, J, Start_Next, End_Next);
+
+ -- Create the end state
+
+ Add_Empty_Char (Last_Start, Start_Next);
+ Add_Empty_Char (Last_Start, Start_Prev);
+ Current_State := Current_State + 1;
+ End_State := Current_State;
+ Add_Empty_Char (End_Prev, End_State);
+ Add_Empty_Char (End_Next, End_State);
+ end;
+
+ when Open_Bracket =>
+ Current_State := Current_State + 1;
+
+ declare
+ Next_State : State_Index := Current_State + 1;
+
+ begin
+ J := J + 1;
+
+ if S (J) = '^' then
+ J := J + 1;
+
+ Next_State := 0;
+
+ for Column in 0 .. Alphabet_Size loop
+ Set (Table, Current_State, Column,
+ Value => Current_State + 1);
+ end loop;
+ end if;
+
+ -- Automatically add the first character
+
+ if S (J) = '-' or else S (J) = ']' then
+ Set (Table, Current_State, Map (S (J)),
+ Value => Next_State);
+ J := J + 1;
+ end if;
+
+ -- Loop till closing bracket found
+
+ loop
+ exit when S (J) = Close_Bracket;
+
+ if S (J) = '-'
+ and then S (J + 1) /= ']'
+ then
+ declare
+ Start : constant Integer := J - 1;
+
+ begin
+ J := J + 1;
+
+ if S (J) = '\' then
+ J := J + 1;
+ end if;
+
+ for Char in S (Start) .. S (J) loop
+ Set (Table, Current_State, Map (Char),
+ Value => Next_State);
+ end loop;
+ end;
+
+ else
+ if S (J) = '\' then
+ J := J + 1;
+ end if;
+
+ Set (Table, Current_State, Map (S (J)),
+ Value => Next_State);
+ end if;
+ J := J + 1;
+ end loop;
+ end;
+
+ Current_State := Current_State + 1;
+
+ -- If the next symbol is a special symbol
+
+ if J < End_Index
+ and then (S (J + 1) = '*' or else
+ S (J + 1) = '+' or else
+ S (J + 1) = '?')
+ then
+ J := J + 1;
+ Create_Repetition
+ (S (J),
+ Current_State - 1,
+ Current_State,
+ Last_Start,
+ End_State);
+
+ else
+ Last_Start := Current_State - 1;
+
+ if End_State /= 0 then
+ Add_Empty_Char (End_State, Last_Start);
+ end if;
+
+ End_State := Current_State;
+ end if;
+
+ when '*' | '+' | '?' | Close_Paren | Close_Bracket =>
+ Raise_Exception
+ ("Incorrect character in regular expression :", J);
+
+ when others =>
+ Current_State := Current_State + 1;
+
+ -- Create the state for the symbol S (J)
+
+ if S (J) = '.' then
+ for K in 0 .. Alphabet_Size loop
+ Set (Table, Current_State, K,
+ Value => Current_State + 1);
+ end loop;
+
+ else
+ if S (J) = '\' then
+ J := J + 1;
+ end if;
+
+ Set (Table, Current_State, Map (S (J)),
+ Value => Current_State + 1);
+ end if;
+
+ Current_State := Current_State + 1;
+
+ -- If the next symbol is a special symbol
+
+ if J < End_Index
+ and then (S (J + 1) = '*' or else
+ S (J + 1) = '+' or else
+ S (J + 1) = '?')
+ then
+ J := J + 1;
+ Create_Repetition
+ (S (J),
+ Current_State - 1,
+ Current_State,
+ Last_Start,
+ End_State);
+
+ else
+ Last_Start := Current_State - 1;
+
+ if End_State /= 0 then
+ Add_Empty_Char (End_State, Last_Start);
+ end if;
+
+ End_State := Current_State;
+ end if;
+
+ end case;
+
+ if Start_State = 0 then
+ Start_State := Last_Start;
+ end if;
+
+ J := J + 1;
+ end loop;
+ end Create_Simple;
+
+ -------------------------
+ -- Next_Sub_Expression --
+ -------------------------
+
+ function Next_Sub_Expression
+ (Start_Index : Integer;
+ End_Index : Integer) return Integer
+ is
+ J : Integer := Start_Index;
+ Start_On_Alter : Boolean := False;
+
+ begin
+ if S (J) = '|' then
+ Start_On_Alter := True;
+ end if;
+
+ loop
+ exit when J = End_Index;
+ J := J + 1;
+
+ case S (J) is
+ when '\' =>
+ J := J + 1;
+
+ when Open_Bracket =>
+ loop
+ J := J + 1;
+ exit when S (J) = Close_Bracket;
+
+ if S (J) = '\' then
+ J := J + 1;
+ end if;
+ end loop;
+
+ when Open_Paren =>
+ J := Next_Sub_Expression (J, End_Index);
+
+ when Close_Paren =>
+ return J;
+
+ when '|' =>
+ if Start_On_Alter then
+ return J - 1;
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end loop;
+
+ return J;
+ end Next_Sub_Expression;
+
+ -- Start of Create_Primary_Table
+
+ begin
+ Table.all := (others => (others => 0));
+ Create_Simple (S'First, S'Last, Start_State, End_State);
+ Num_States := Current_State;
+ end Create_Primary_Table;
+
+ ----------------------------
+ -- Create_Secondary_Table --
+ ----------------------------
+
+ function Create_Secondary_Table
+ (First_Table : Regexp_Array_Access;
+ Start_State : State_Index;
+ End_State : State_Index) return Regexp
+ is
+ Last_Index : constant State_Index := First_Table'Last (1);
+
+ type Meta_State is array (0 .. Last_Index) of Boolean;
+ pragma Pack (Meta_State);
+ -- Whether a state from first_table belongs to a metastate.
+
+ No_States : constant Meta_State := (others => False);
+
+ type Meta_States_Array is array (State_Index range <>) of Meta_State;
+ type Meta_States_List is access all Meta_States_Array;
+ procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ (Meta_States_Array, Meta_States_List);
+ Meta_States : Meta_States_List;
+ -- Components of meta-states. A given state might belong to
+ -- several meta-states.
+ -- This array grows dynamically.
+
+ type Char_To_State is array (0 .. Alphabet_Size) of State_Index;
+ type Meta_States_Transition_Arr is
+ array (State_Index range <>) of Char_To_State;
+ type Meta_States_Transition is access all Meta_States_Transition_Arr;
+ procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ (Meta_States_Transition_Arr, Meta_States_Transition);
+ Table : Meta_States_Transition;
+ -- Documents the transitions between each meta-state. The
+ -- first index is the meta-state, the second column is the
+ -- character seen in the input, the value is the new meta-state.
+
+ Temp_State_Not_Null : Boolean;
+
+ Current_State : State_Index := 1;
+ -- The current meta-state we are creating
+
+ Nb_State : State_Index := 1;
+ -- The total number of meta-states created so far.
+
+ procedure Closure
+ (Meta_State : State_Index;
+ State : State_Index);
+ -- Compute the closure of the state (that is every other state which
+ -- has a empty-character transition) and add it to the state
+
+ procedure Ensure_Meta_State (Meta : State_Index);
+ -- grows the Meta_States array as needed to make sure that there
+ -- is enough space to store the new meta state.
+
+ -----------------------
+ -- Ensure_Meta_State --
+ -----------------------
+
+ procedure Ensure_Meta_State (Meta : State_Index) is
+ Tmp : Meta_States_List := Meta_States;
+ Tmp2 : Meta_States_Transition := Table;
+
+ begin
+ if Meta_States = null then
+ Meta_States := new Meta_States_Array
+ (1 .. State_Index'Max (Last_Index, Meta) + 1);
+ Meta_States (Meta_States'Range) := (others => No_States);
+
+ Table := new Meta_States_Transition_Arr
+ (1 .. State_Index'Max (Last_Index, Meta) + 1);
+ Table.all := (others => (others => 0));
+
+ elsif Meta > Meta_States'Last then
+ Meta_States := new Meta_States_Array
+ (1 .. State_Index'Max (2 * Tmp'Last, Meta));
+ Meta_States (Tmp'Range) := Tmp.all;
+ Meta_States (Tmp'Last + 1 .. Meta_States'Last) :=
+ (others => No_States);
+ Unchecked_Free (Tmp);
+
+ Table := new Meta_States_Transition_Arr
+ (1 .. State_Index'Max (2 * Tmp2'Last, Meta) + 1);
+ Table (Tmp2'Range) := Tmp2.all;
+ Table (Tmp2'Last + 1 .. Table'Last) :=
+ (others => (others => 0));
+ Unchecked_Free (Tmp2);
+ end if;
+ end Ensure_Meta_State;
+
+ -------------
+ -- Closure --
+ -------------
+
+ procedure Closure
+ (Meta_State : State_Index;
+ State : State_Index)
+ is
+ begin
+ if not Meta_States (Meta_State)(State) then
+ Meta_States (Meta_State)(State) := True;
+
+ -- For each transition on empty-character
+
+ for Column in Alphabet_Size + 1 .. First_Table'Last (2) loop
+ exit when First_Table (State, Column) = 0;
+ Closure (Meta_State, First_Table (State, Column));
+ end loop;
+ end if;
+ end Closure;
+
+ -- Start of processing for Create_Secondary_Table
+
+ begin
+ -- Create a new state
+
+ Ensure_Meta_State (Current_State);
+ Closure (Current_State, Start_State);
+
+ while Current_State <= Nb_State loop
+
+ -- We will be trying, below, to create the next meta-state
+
+ Ensure_Meta_State (Nb_State + 1);
+
+ -- For every character in the regexp, calculate the possible
+ -- transitions from Current_State.
+
+ for Column in 0 .. Alphabet_Size loop
+ Temp_State_Not_Null := False;
+
+ for K in Meta_States (Current_State)'Range loop
+ if Meta_States (Current_State)(K)
+ and then First_Table (K, Column) /= 0
+ then
+ Closure (Nb_State + 1, First_Table (K, Column));
+ Temp_State_Not_Null := True;
+ end if;
+ end loop;
+
+ -- If at least one transition existed
+
+ if Temp_State_Not_Null then
+
+ -- Check if this new state corresponds to an old one
+
+ for K in 1 .. Nb_State loop
+ if Meta_States (K) = Meta_States (Nb_State + 1) then
+ Table (Current_State)(Column) := K;
+
+ -- Reset data, for the next time we try that state
+
+ Meta_States (Nb_State + 1) := No_States;
+ exit;
+ end if;
+ end loop;
+
+ -- If not, create a new state
+
+ if Table (Current_State)(Column) = 0 then
+ Nb_State := Nb_State + 1;
+ Ensure_Meta_State (Nb_State + 1);
+ Table (Current_State)(Column) := Nb_State;
+ end if;
+ end if;
+ end loop;
+
+ Current_State := Current_State + 1;
+ end loop;
+
+ -- Returns the regexp
+
+ declare
+ R : Regexp_Access;
+
+ begin
+ R := new Regexp_Value (Alphabet_Size => Alphabet_Size,
+ Num_States => Nb_State);
+ R.Map := Map;
+ R.Case_Sensitive := Case_Sensitive;
+
+ for S in 1 .. Nb_State loop
+ R.Is_Final (S) := Meta_States (S)(End_State);
+ end loop;
+
+ for State in 1 .. Nb_State loop
+ for K in 0 .. Alphabet_Size loop
+ R.States (State, K) := Table (State)(K);
+ end loop;
+ end loop;
+
+ Unchecked_Free (Meta_States);
+ Unchecked_Free (Table);
+
+ return (Ada.Finalization.Controlled with R => R);
+ end;
+ end Create_Secondary_Table;
+
+ ---------------------
+ -- Raise_Exception --
+ ---------------------
+
+ procedure Raise_Exception (M : String; Index : Integer) is
+ begin
+ raise Error_In_Regexp with M & " at offset" & Index'Img;
+ end Raise_Exception;
+
+ -- Start of processing for Compile
+
+ begin
+ if S = "" then
+ raise Error_In_Regexp with "empty string";
+ end if;
+
+ if not Case_Sensitive then
+ GNAT.Case_Util.To_Lower (S);
+ end if;
+
+ -- Check the pattern is well-formed before any treatment
+
+ Check_Well_Formed_Pattern;
+
+ Create_Mapping;
+
+ -- Creates the primary table
+
+ declare
+ Table : Regexp_Array_Access;
+ Num_States : State_Index;
+ Start_State : State_Index;
+ End_State : State_Index;
+ R : Regexp;
+
+ begin
+ Table := new Regexp_Array (1 .. Initial_Max_States_In_Primary_Table,
+ 0 .. Alphabet_Size + 10);
+
+ Create_Primary_Table (Table, Num_States, Start_State, End_State);
+
+ -- Creates the secondary table
+
+ R := Create_Secondary_Table (Table, Start_State, End_State);
+ Free (Table);
+ return R;
+ end;
+ end Compile;
+
+ overriding procedure Finalize (R : in out Regexp) is
+ procedure Free is new
+ Ada.Unchecked_Deallocation (Regexp_Value, Regexp_Access);
+ begin
+ Free (R.R);
+ end Finalize;
+
+ function Get
+ (Table : Regexp_Array_Access;
+ State : State_Index;
+ Column : Column_Index) return State_Index
+ is
+ begin
+ if State <= Table'Last (1)
+ and then Column <= Table'Last (2)
+ then
+ return Table (State, Column);
+ else
+ return 0;
+ end if;
+ end Get;
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match (R : in out Regexp; S : String; Next : Integer) return
Match_State
+ is begin
+ if R.R = null then
+ raise Constraint_Error;
+ end if;
+
+ if R.R.State = 0 then
+ return Error;
+ end if;
+
+ if R.R.Case_Sensitive then
+ R.R.State := R.R.States (R.R.State, R.R.Map (S (Next)));
+ else
+ R.R.State :=
+ R.R.States (R.R.State,
+ R.R.Map (GNAT.Case_Util.To_Lower (S (Next))));
+ end if;
+
+ if R.R.State = 0 then
+ return Error;
+ elsif R.R.Is_Final (R.R.State) then
+ return Final;
+ else
+ return Matching;
+ end if;
+ end Match;
+
+ procedure Set
+ (Table : in out Regexp_Array_Access;
+ State : State_Index;
+ Column : Column_Index;
+ Value : State_Index)
+ is
+ New_Lines : State_Index;
+ New_Columns : Column_Index;
+ New_Table : Regexp_Array_Access;
+
+ begin
+ if State <= Table'Last (1)
+ and then Column <= Table'Last (2)
+ then
+ Table (State, Column) := Value;
+ else
+ -- Doubles the size of the table until it is big enough that
+ -- (State, Column) is a valid index.
+
+ New_Lines := Table'Last (1) * (State / Table'Last (1) + 1);
+ New_Columns := Table'Last (2) * (Column / Table'Last (2) + 1);
+ New_Table := new Regexp_Array (Table'First (1) .. New_Lines,
+ Table'First (2) .. New_Columns);
+ New_Table.all := (others => (others => 0));
+
+ for J in Table'Range (1) loop
+ for K in Table'Range (2) loop
+ New_Table (J, K) := Table (J, K);
+ end loop;
+ end loop;
+
+ Free (Table);
+ Table := New_Table;
+ Table (State, Column) := Value;
+ end if;
+ end Set;
+
+ function State (R : in Regexp) return Match_State
+ is begin
+ if R.R.State = 0 then
+ return Error;
+ elsif R.R.Is_Final (R.R.State) then
+ return Final;
+ else
+ return Matching;
+ end if;
+ end State;
+
+end WisiToken.Regexp;
+-- Local Variables:
+-- jit-lock-defer-time: 0.5
+-- End:
diff --git a/wisitoken-regexp.ads b/wisitoken-regexp.ads
new file mode 100644
index 0000000..b7cf9ba
--- /dev/null
+++ b/wisitoken-regexp.ads
@@ -0,0 +1,139 @@
+-- Abstract:
+--
+-- Regular expressions, for WisiToken.Lexer.Regexp. It supports a
+-- subset of the syntax of regular expressions copied from familiar
+-- Unix style utilities.
+--
+-- Copied from GNAT System.Regexp, modified to expose the matcher
+-- state machine to allow matching substrings.
+--
+-- Copyright (C) 2015 Stephen Leake
+-- Copyright (C) 1998-2010, AdaCore
+--
+-- 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.
+--
+-- 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.
+--
+-- You should have received a copy of the
+-- GNU General Public License and
+-- a copy of the GCC Runtime Library Exception distributed with the WisiToken
package;
+-- see files GPL.txt and GPL_runtime.txt. If not, see
+-- <http://www.gnu.org/licenses/>.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+package WisiToken.Regexp is
+
+ -- The regular expression must first be compiled, using the Compile
+ -- function, which creates a finite state matching table, allowing
+ -- very fast matching.
+
+ -- The following is the form of a regular expression, expressed in Ada
+ -- reference manual style BNF
+
+ -- regexp ::= term
+
+ -- regexp ::= term | term -- alternation (term or term ...)
+
+ -- term ::= item
+
+ -- term ::= item item ... -- concatenation (item then item)
+
+ -- item ::= elmt -- match elmt
+ -- item ::= elmt * -- zero or more elmt's
+ -- item ::= elmt + -- one or more elmt's
+ -- item ::= elmt ? -- matches elmt or nothing
+
+ -- elmt ::= nchr -- matches given character
+ -- elmt ::= [nchr nchr ...] -- matches any character listed
+ -- elmt ::= [^ nchr nchr ...] -- matches any character not listed
+ -- elmt ::= [char - char] -- matches chars in given range
+ -- elmt ::= . -- matches any single character
+ -- elmt ::= ( regexp ) -- parens used for grouping
+
+ -- char ::= any character, including special characters
+ -- nchr ::= any character except \()[].*+?^ or \char to match char
+ -- ... is used to indication repetition (one or more terms)
+
+ -- See also regexp(1) man page on Unix systems for further details
+
+ type Regexp is private;
+
+ Error_In_Regexp : exception;
+
+ function Compile
+ (Pattern : String;
+ Case_Sensitive : Boolean := True)
+ return Regexp;
+ -- Compile a Pattern. If the syntax of the given
+ -- expression is invalid (does not match above grammar), Error_In_Regexp
+ -- is raised.
+ --
+ -- If Pattern is the empty string it will raise Error_In_Regexp
+ --
+ -- Raises Error_In_Regexp when an error is found in the regular
+ -- expression
+
+ procedure Clear (R : in out Regexp);
+ -- Clear R internal state, to prepare for a new Match.
+
+ type Match_State is (Matching, Final, Error);
+
+ function Match (R : in out Regexp; S : String; Next : Integer) return
Match_State;
+ -- Compute match for S (Next), assuming Next is the next character
+ -- in S after the previous call to Match. If this is the first
+ -- call, Next must be S'First.
+ --
+ -- S'First, S'Last may change between calls to Match.
+ --
+ -- The return values mean:
+ --
+ -- Matching: S (S'First .. Next) matches R, but more characters
+ -- are needed to complete the match.
+ --
+ -- Final: S (S'First .. Next) matches R; more characters may also.
+ --
+ -- Error: S (S'First .. Next) does not match R.
+ --
+ -- Raises Constraint_Error if R is not a compiled regular
+ -- expression.
+
+ function State (R : in Regexp) return Match_State;
+ -- Return the current state of R; if Matching, it is useful to
+ -- call Match again.
+ --
+ -- After Clear (R), State (R) returns Matching.
+
+private
+ type Regexp_Value;
+
+ type Regexp_Access is access Regexp_Value;
+
+ type Regexp is new Ada.Finalization.Controlled with record
+ R : Regexp_Access := null;
+ end record;
+
+ pragma Finalize_Storage_Only (Regexp);
+
+ overriding procedure Finalize (R : in out Regexp);
+ -- Free the memory occupied by R
+
+ overriding procedure Adjust (R : in out Regexp);
+ -- Deep copy R.R.all
+
+end WisiToken.Regexp;
diff --git a/wisitoken-semantic_checks.adb b/wisitoken-semantic_checks.adb
new file mode 100644
index 0000000..af83b7f
--- /dev/null
+++ b/wisitoken-semantic_checks.adb
@@ -0,0 +1,135 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Characters.Handling;
+package body WisiToken.Semantic_Checks is
+
+ function Image (Item : in Check_Status; Descriptor : in
WisiToken.Descriptor) return String
+ is begin
+ case Item.Label is
+ when Ok =>
+ return Check_Status_Label'Image (Item.Label);
+ when Error =>
+ return '(' & Check_Status_Label'Image (Item.Label) & ", " &
+ Image (Item.Begin_Name, Descriptor) & ',' &
+ Image (Item.End_Name, Descriptor) & ')';
+ end case;
+ end Image;
+
+ function Match_Names
+ (Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Descriptor : in WisiToken.Descriptor;
+ Tokens : in Recover_Token_Array;
+ Start_Index : in Positive_Index_Type;
+ End_Index : in Positive_Index_Type;
+ End_Optional : in Boolean)
+ return Check_Status
+ is
+ Start_Name_Region : constant Buffer_Region :=
+ (if Tokens (Start_Index).Name = Null_Buffer_Region
+ then Tokens (Start_Index).Byte_Region
+ else Tokens (Start_Index).Name);
+ End_Name_Region : constant Buffer_Region :=
+ (if Tokens (End_Index).Name = Null_Buffer_Region
+ then Tokens (End_Index).Byte_Region
+ else Tokens (End_Index).Name);
+
+ function Equal return Boolean
+ is
+ use Ada.Characters.Handling;
+ begin
+ if Descriptor.Case_Insensitive then
+ return To_Lower (Lexer.Buffer_Text (Start_Name_Region)) =
+ To_Lower (Lexer.Buffer_Text (End_Name_Region));
+ else
+ return Lexer.Buffer_Text (Start_Name_Region) = Lexer.Buffer_Text
(End_Name_Region);
+ end if;
+ end Equal;
+
+ begin
+ if Tokens (Start_Index).Virtual or Tokens (End_Index).Virtual then
+ return (Label => Ok);
+
+ elsif End_Optional then
+ if End_Name_Region = Null_Buffer_Region then
+ return (Label => Ok);
+ elsif Start_Name_Region = Null_Buffer_Region then
+ return (Extra_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
+ else
+ if Equal then
+ return (Label => Ok);
+ else
+ return (Match_Names_Error, Tokens (Start_Index), Tokens
(End_Index));
+ end if;
+ end if;
+
+ else
+ if Start_Name_Region = Null_Buffer_Region then
+ if End_Name_Region = Null_Buffer_Region then
+ return (Label => Ok);
+ else
+ return (Extra_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
+ end if;
+
+ elsif End_Name_Region = Null_Buffer_Region then
+ return (Missing_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
+
+ else
+ if Equal then
+ return (Label => Ok);
+ else
+ return (Match_Names_Error, Tokens (Start_Index), Tokens
(End_Index));
+ end if;
+ end if;
+ end if;
+ end Match_Names;
+
+ function Propagate_Name
+ (Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ Name_Index : in Positive_Index_Type)
+ return Check_Status
+ is begin
+ if Tokens (Name_Index).Name = Null_Buffer_Region then
+ Nonterm.Name := Tokens (Name_Index).Byte_Region;
+ else
+ Nonterm.Name := Tokens (Name_Index).Name;
+ end if;
+ return (Label => Ok);
+ end Propagate_Name;
+
+ function Merge_Names
+ (Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ First_Index : in Positive_Index_Type;
+ Last_Index : in Positive_Index_Type)
+ return Check_Status
+ is
+ First_Name : Buffer_Region renames Tokens (First_Index).Name;
+ Last_Name : Buffer_Region renames Tokens (Last_Index).Name;
+ begin
+ Nonterm.Name :=
+ First_Name and
+ (if Last_Name = Null_Buffer_Region
+ then Tokens (Last_Index).Byte_Region
+ else Last_Name);
+ return (Label => Ok);
+ end Merge_Names;
+
+end WisiToken.Semantic_Checks;
diff --git a/wisitoken-semantic_checks.ads b/wisitoken-semantic_checks.ads
new file mode 100644
index 0000000..49811d6
--- /dev/null
+++ b/wisitoken-semantic_checks.ads
@@ -0,0 +1,89 @@
+-- Abstract :
+--
+-- Grammar semantic check routines.
+--
+-- Copyright (C) 2017, 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Lexer;
+package WisiToken.Semantic_Checks is
+
+ type Check_Status_Label is
+ (Ok,
+ Missing_Name_Error, -- block start has name, required block end name
missing
+ Extra_Name_Error, -- block start has no name, end has one
+ Match_Names_Error); -- both names present, but don't match
+
+ subtype Error is Check_Status_Label range Check_Status_Label'Succ (Ok) ..
Check_Status_Label'Last;
+
+ type Check_Status (Label : Check_Status_Label := Ok) is record
+ case Label is
+ when Ok =>
+ null;
+
+ when Error =>
+ Begin_Name : Recover_Token;
+ End_Name : Recover_Token;
+ end case;
+ end record;
+
+ subtype Error_Check_Status is Check_Status
+ with Dynamic_Predicate => Error_Check_Status.Label /= Ok;
+
+ function Image (Item : in Check_Status; Descriptor : WisiToken.Descriptor)
return String;
+
+ type Semantic_Check is access function
+ (Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array)
+ return Check_Status;
+ -- Called during parsing and error recovery to implement higher level
+ -- checks, such as block name matching in Ada.
+
+ Null_Check : constant Semantic_Check := null;
+
+ function Match_Names
+ (Lexer : access constant WisiToken.Lexer.Instance'Class;
+ Descriptor : in WisiToken.Descriptor;
+ Tokens : in Recover_Token_Array;
+ Start_Index : in Positive_Index_Type;
+ End_Index : in Positive_Index_Type;
+ End_Optional : in Boolean)
+ return Check_Status;
+ -- Check that buffer text at Tokens (Start_Index).Name matches buffer
+ -- text at Tokens (End_Index).Name. Comparison is controlled by
+ -- Descriptor.Case_Insensitive.
+
+ function Propagate_Name
+ (Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ Name_Index : in Positive_Index_Type)
+ return Check_Status;
+ -- Set Nonterm.Name to Tokens (Name_Index).Name, or .Byte_Region, if
+ -- .Name is Null_Buffer_Region. Return Ok.
+
+ function Merge_Names
+ (Nonterm : in out Recover_Token;
+ Tokens : in Recover_Token_Array;
+ First_Index : in Positive_Index_Type;
+ Last_Index : in Positive_Index_Type)
+ return Check_Status;
+ -- Then set Nonterm.Name to the merger of Tokens (First_Index ..
+ -- Last_Index).Name, return Ok.
+ --
+ -- If Tokens (Last_Index).Name is Null_Buffer_Region, use Tokens
+ -- (Last_Index).Byte_Region instead.
+
+end WisiToken.Semantic_Checks;
diff --git a/wisitoken-syntax_trees.adb b/wisitoken-syntax_trees.adb
new file mode 100644
index 0000000..249065f
--- /dev/null
+++ b/wisitoken-syntax_trees.adb
@@ -0,0 +1,1114 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Containers;
+package body WisiToken.Syntax_Trees is
+
+ -- Body specs, alphabetical, as needed
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ N : in Syntax_Trees.Node;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean)
+ return String;
+
+ function Min (Item : in Valid_Node_Index_Array) return Valid_Node_Index;
+
+ procedure Move_Branch_Point (Tree : in out Syntax_Trees.Tree; Required_Node
: in Valid_Node_Index);
+
+ function Process_Tree
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Process_Node : access function
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Boolean)
+ return Boolean;
+ -- Call Process_Node on nodes in tree rooted at Node. Return when
+ -- Process_Node returns False (Process_Tree returns False), or when
+ -- all nodes have been processed (Process_Tree returns True).
+
+ procedure Set_Children
+ (Nodes : in out Node_Arrays.Vector;
+ Parent : in Valid_Node_Index;
+ Children : in Valid_Node_Index_Array);
+
+ ----------
+ -- Public and body operations, alphabetical
+
+ function Action
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Semantic_Action
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).Action
+ else Tree.Branched_Nodes (Node).Action);
+ end Action;
+
+ function Add_Nonterm
+ (Tree : in out Syntax_Trees.Tree;
+ Production : in Production_ID;
+ Children : in Valid_Node_Index_Array;
+ Action : in Semantic_Action;
+ Default_Virtual : in Boolean)
+ return Valid_Node_Index
+ is
+ Nonterm_Node : Valid_Node_Index;
+ begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Syntax_Trees.Nonterm,
+ ID => Production.LHS,
+ Action => Action,
+ RHS_Index => Production.RHS,
+ Virtual => (if Children'Length = 0 then Default_Virtual else
False),
+ others => <>));
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ Nonterm_Node := Tree.Last_Shared_Node;
+ else
+ Tree.Branched_Nodes.Append
+ ((Label => Syntax_Trees.Nonterm,
+ ID => Production.LHS,
+ Action => Action,
+ RHS_Index => Production.RHS,
+ Virtual => (if Children'Length = 0 then Default_Virtual else
False),
+ others => <>));
+ Nonterm_Node := Tree.Branched_Nodes.Last_Index;
+ end if;
+
+ if Children'Length = 0 then
+ return Nonterm_Node;
+ end if;
+
+ if Tree.Flush then
+ Set_Children (Tree.Shared_Tree.Nodes, Nonterm_Node, Children);
+
+ else
+ declare
+ Min_Child_Node : constant Valid_Node_Index := Min (Children);
+ begin
+ if Min_Child_Node <= Tree.Last_Shared_Node then
+ Move_Branch_Point (Tree, Min_Child_Node);
+ end if;
+ end;
+
+ Set_Children (Tree.Branched_Nodes, Nonterm_Node, Children);
+ end if;
+
+ return Nonterm_Node;
+ end Add_Nonterm;
+
+ function Add_Terminal
+ (Tree : in out Syntax_Trees.Tree;
+ Terminal : in Token_Index;
+ Terminals : in Base_Token_Arrays.Vector)
+ return Valid_Node_Index
+ is begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Shared_Terminal,
+ ID => Terminals (Terminal).ID,
+ Byte_Region => Terminals (Terminal).Byte_Region,
+ Terminal => Terminal,
+ others => <>));
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ return Tree.Last_Shared_Node;
+ else
+ Tree.Branched_Nodes.Append
+ ((Label => Shared_Terminal,
+ ID => Terminals (Terminal).ID,
+ Byte_Region => Terminals (Terminal).Byte_Region,
+ Terminal => Terminal,
+ others => <>));
+ return Tree.Branched_Nodes.Last_Index;
+ end if;
+ end Add_Terminal;
+
+ function Add_Terminal
+ (Tree : in out Syntax_Trees.Tree;
+ Terminal : in Token_ID)
+ return Valid_Node_Index
+ is begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes.Append
+ ((Label => Virtual_Terminal,
+ ID => Terminal,
+ others => <>));
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ return Tree.Last_Shared_Node;
+ else
+ Tree.Branched_Nodes.Append
+ ((Label => Virtual_Terminal,
+ ID => Terminal,
+ others => <>));
+ return Tree.Branched_Nodes.Last_Index;
+ end if;
+ end Add_Terminal;
+
+ overriding procedure Adjust (Tree : in out Base_Tree)
+ is begin
+ if Tree.Augmented_Present then
+ -- Augmented is only set after parsing is complete; trees are never
copied then.
+ raise SAL.Not_Implemented;
+ end if;
+ end Adjust;
+
+ function Augmented
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Base_Token_Class_Access
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Augmented;
+ else
+ return Tree.Branched_Nodes (Node).Augmented;
+ end if;
+ end Augmented;
+
+ function Byte_Region
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Buffer_Region
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).Byte_Region
+ else Tree.Branched_Nodes (Node).Byte_Region);
+ end Byte_Region;
+
+ function Children (N : in Syntax_Trees.Node) return Valid_Node_Index_Array
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if N.Children.Length = 0 then
+ return (1 .. 0 => <>);
+ else
+ return Result : Valid_Node_Index_Array (N.Children.First_Index ..
N.Children.Last_Index) do
+ for I in Result'Range loop
+ Result (I) := N.Children (I);
+ end loop;
+ end return;
+ end if;
+ end Children;
+
+ function Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Valid_Node_Index_Array
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Children (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Children (Tree.Branched_Nodes (Node));
+ end if;
+ end Children;
+
+ procedure Clear (Tree : in out Syntax_Trees.Base_Tree)
+ is begin
+ Tree.Finalize;
+ end Clear;
+
+ procedure Clear (Tree : in out Syntax_Trees.Tree)
+ is begin
+ if Tree.Shared_Tree.Augmented_Present then
+ for Node of Tree.Branched_Nodes loop
+ if Node.Label = Nonterm then
+ Free (Node.Augmented);
+ end if;
+ end loop;
+ end if;
+ Tree.Shared_Tree.Finalize;
+ Tree.Last_Shared_Node := Invalid_Node_Index;
+ Tree.Branched_Nodes.Clear;
+ end Clear;
+
+ function Count_Terminals
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Natural
+ is
+ function Compute (N : in Syntax_Trees.Node) return Natural
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal =>
+ return 1;
+
+ when Nonterm =>
+ return Result : Natural := 0 do
+ for I of N.Children loop
+ Result := Result + Count_Terminals (Tree, I);
+ end loop;
+ end return;
+ end case;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Count_Terminals;
+
+ overriding procedure Finalize (Tree : in out Base_Tree)
+ is begin
+ Tree.Traversing := False;
+ if Tree.Augmented_Present then
+ for Node of Tree.Nodes loop
+ if Node.Label = Nonterm then
+ Free (Node.Augmented);
+ end if;
+ end loop;
+ Tree.Augmented_Present := False;
+ end if;
+ Tree.Nodes.Finalize;
+ end Finalize;
+
+ function Find_Ancestor
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ is
+ N : Node_Index := Node;
+ begin
+ loop
+ N :=
+ (if N <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (N).Parent
+ else Tree.Branched_Nodes (N).Parent);
+
+ exit when N = Invalid_Node_Index;
+ exit when ID =
+ (if N <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (N).ID
+ else Tree.Branched_Nodes (N).ID);
+ end loop;
+ return N;
+ end Find_Ancestor;
+
+ function Find_Child
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ is
+ function Compute (N : in Syntax_Trees.Node) return Node_Index
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal =>
+ return Invalid_Node_Index;
+ when Nonterm =>
+ for C of N.Children loop
+ if ID =
+ (if C <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (C).ID
+ else Tree.Branched_Nodes (C).ID)
+ then
+ return C;
+ end if;
+ end loop;
+ return Invalid_Node_Index;
+ end case;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Find_Child;
+
+ function Find_Descendant
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ is
+ Found : Node_Index := Invalid_Node_Index;
+
+ function Process (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is
+ Node_ID : constant Token_ID :=
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).ID
+ else Tree.Branched_Nodes (Node).ID);
+ begin
+ if Node_ID = ID then
+ Found := Node;
+ return False;
+ else
+ return True;
+ end if;
+ end Process;
+
+ Junk : constant Boolean := Process_Tree (Tree, Node, Process'Access);
+ pragma Unreferenced (Junk);
+ begin
+ return Found;
+ end Find_Descendant;
+
+ function Find_Sibling
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ is
+ function Compute_2 (N : in Syntax_Trees.Node) return Node_Index
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal =>
+ return Invalid_Node_Index;
+
+ when Nonterm =>
+ for C of N.Children loop
+ if ID =
+ (if C <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (C).ID
+ else Tree.Branched_Nodes (C).ID)
+ then
+ return C;
+ end if;
+ end loop;
+ return Invalid_Node_Index;
+ end case;
+ end Compute_2;
+
+ function Compute_1 (Parent : in Node_Index) return Node_Index
+ is begin
+ if Parent = Invalid_Node_Index then
+ return Invalid_Node_Index;
+
+ else
+ return Compute_2
+ ((if Parent <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Parent)
+ else Tree.Branched_Nodes (Parent)));
+ end if;
+ end Compute_1;
+ begin
+ return Compute_1
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).Parent
+ else Tree.Branched_Nodes (Node).Parent));
+ end Find_Sibling;
+
+ procedure Flush (Tree : in out Syntax_Trees.Tree)
+ is begin
+ -- This is the opposite of Move_Branch_Point
+ Tree.Shared_Tree.Nodes.Merge (Tree.Branched_Nodes);
+ Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
+ Tree.Flush := True;
+ end Flush;
+
+ procedure Get_Terminals
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Result : in out Valid_Node_Index_Array;
+ Last : in out SAL.Base_Peek_Type)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ procedure Compute (N : in Syntax_Trees.Node)
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal =>
+ Last := Last + 1;
+ Result (Last) := Node;
+
+ when Nonterm =>
+ for I of N.Children loop
+ Get_Terminals (Tree, I, Result, Last);
+ end loop;
+ end case;
+ end Compute;
+ begin
+ Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Get_Terminals;
+
+ procedure Get_Terminal_IDs
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Result : in out Token_ID_Array;
+ Last : in out Natural)
+ is
+ procedure Compute (N : in Syntax_Trees.Node)
+ is begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal =>
+ Last := Last + 1;
+ Result (Last) := N.ID;
+
+ when Nonterm =>
+ for I of N.Children loop
+ Get_Terminal_IDs (Tree, I, Result, Last);
+ end loop;
+ end case;
+ end Compute;
+ begin
+ Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Get_Terminal_IDs;
+
+ function Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index_Array
+ is
+ Last : SAL.Base_Peek_Type := 0;
+ begin
+ Tree.Shared_Tree.Traversing := True;
+ return Result : Valid_Node_Index_Array (1 .. SAL.Base_Peek_Type
(Count_Terminals (Tree, Node))) do
+ Get_Terminals (Tree, Node, Result, Last);
+ Tree.Shared_Tree.Traversing := False;
+ end return;
+ end Get_Terminals;
+
+ function Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID_Array
+ is
+ Last : Natural := 0;
+ begin
+ Tree.Shared_Tree.Traversing := True;
+ return Result : Token_ID_Array (1 .. Count_Terminals (Tree, Node)) do
+ Get_Terminal_IDs (Tree, Node, Result, Last);
+ Tree.Shared_Tree.Traversing := False;
+ end return;
+ end Get_Terminal_IDs;
+
+ function Has_Branched_Nodes (Tree : in Syntax_Trees.Tree) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ return Tree.Branched_Nodes.Length > 0;
+ end Has_Branched_Nodes;
+
+ function Has_Children (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is
+ use all type Ada.Containers.Count_Type;
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Children.Length > 0;
+ else
+ return Tree.Branched_Nodes (Node).Children.Length > 0;
+ end if;
+ end Has_Children;
+
+ function Has_Parent (Tree : in Syntax_Trees.Tree; Child : in
Valid_Node_Index) return Boolean
+ is begin
+ return
+ (if Child <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Child).Parent /= Invalid_Node_Index
+ else Tree.Branched_Nodes (Child).Parent /= Invalid_Node_Index);
+ end Has_Parent;
+
+ function Has_Parent (Tree : in Syntax_Trees.Tree; Children : in
Valid_Node_Index_Array) return Boolean
+ is begin
+ return
+ (for some Child of Children =>
+ (if Child <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Child).Parent /= Invalid_Node_Index
+ else Tree.Branched_Nodes (Child).Parent /= Invalid_Node_Index));
+ end Has_Parent;
+
+ function ID
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Token_ID
+ is begin
+ return
+ (if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node).ID
+ else Tree.Branched_Nodes (Node).ID);
+ end ID;
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Children : in Valid_Node_Index_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := +"(";
+ Need_Comma : Boolean := False;
+ begin
+ for I of Children loop
+ Result := Result & (if Need_Comma then ", " else "") &
+ Tree.Image (I, Descriptor, Include_Children => False);
+ Need_Comma := True;
+ end loop;
+ Result := Result & ")";
+ return -Result;
+ end Image;
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ N : in Syntax_Trees.Node;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean)
+ return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String;
+ begin
+ if Include_Children and N.Label = Nonterm then
+ Result := +Image (N.ID, Descriptor) & '_' & Trimmed_Image
(N.RHS_Index) & ": ";
+ end if;
+
+ if N.Label = Shared_Terminal then
+ Result := Result & (+Token_Index'Image (N.Terminal)) & ":";
+ end if;
+
+ Result := Result & "(" & Image (N.ID, Descriptor) &
+ (if N.Byte_Region = Null_Buffer_Region then "" else ", " & Image
(N.Byte_Region)) & ")";
+
+ if Include_Children and N.Label = Nonterm then
+ Result := Result & " <= " & Image (Tree, N.Children, Descriptor);
+ end if;
+
+ return -Result;
+ end Image;
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean := False)
+ return String
+ is begin
+ return Tree.Image
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)),
+ Descriptor, Include_Children);
+ end Image;
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Nodes : in Valid_Node_Index_Array;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String := +"(";
+ Need_Comma : Boolean := False;
+ begin
+ for I in Nodes'Range loop
+ Result := Result & (if Need_Comma then ", " else "") &
+ Tree.Image (Nodes (I), Descriptor, Include_Children => False);
+ Need_Comma := True;
+ end loop;
+ Result := Result & ")";
+ return -Result;
+ end Image;
+
+ procedure Initialize
+ (Branched_Tree : in out Syntax_Trees.Tree;
+ Shared_Tree : in Base_Tree_Access;
+ Flush : in Boolean)
+ is begin
+ Branched_Tree :=
+ (Shared_Tree => Shared_Tree,
+ Last_Shared_Node => Shared_Tree.Nodes.Last_Index,
+ Branched_Nodes => <>,
+ Flush => Flush,
+ Root => <>);
+ end Initialize;
+
+ function Is_Empty (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Boolean
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Byte_Region = Null_Buffer_Region;
+ else
+ return Tree.Branched_Nodes (Node).Byte_Region = Null_Buffer_Region;
+ end if;
+ end Is_Empty;
+
+ function Is_Nonterm (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Label = Nonterm;
+ else
+ return Tree.Branched_Nodes (Node).Label = Nonterm;
+ end if;
+ end Is_Nonterm;
+
+ function Is_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Label = Shared_Terminal;
+ else
+ return Tree.Branched_Nodes (Node).Label = Shared_Terminal;
+ end if;
+ end Is_Terminal;
+
+ function Is_Virtual (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is
+ function Compute (N : in Syntax_Trees.Node) return Boolean
+ is begin
+ return N.Label = Virtual_Terminal or (N.Label = Nonterm and then
N.Virtual);
+ end Compute;
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Is_Virtual;
+
+ function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Label
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Label;
+ else
+ return Tree.Branched_Nodes (Node).Label;
+ end if;
+ end Label;
+
+ function Min (Item : in Valid_Node_Index_Array) return Valid_Node_Index
+ is
+ Result : Node_Index := Item (Item'First);
+ begin
+ for I in Item'Range loop
+ if Item (I) < Result then
+ Result := Item (I);
+ end if;
+ end loop;
+ return Result;
+ end Min;
+
+ function Min_Descendant (Nodes : in Node_Arrays.Vector; Node : in
Valid_Node_Index) return Valid_Node_Index
+ is
+ N : Syntax_Trees.Node renames Nodes (Node);
+ begin
+ case N.Label is
+ when Shared_Terminal | Virtual_Terminal =>
+ return Node;
+
+ when Nonterm =>
+ declare
+ Min : Node_Index := Node;
+ begin
+ for C of N.Children loop
+ Min := Node_Index'Min (Min, Min_Descendant (Nodes, C));
+ end loop;
+ return Min;
+ end;
+ end case;
+ end Min_Descendant;
+
+ function Min_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index
+ is
+ function Compute (N : in Syntax_Trees.Node) return Base_Token_Index
+ is begin
+ return
+ (case N.Label is
+ when Shared_Terminal => N.Terminal,
+ when Virtual_Terminal => Invalid_Token_Index,
+ when Nonterm => N.Min_Terminal_Index);
+ end Compute;
+
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Min_Terminal_Index;
+
+ function Max_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index
+ is
+ function Compute (N : in Syntax_Trees.Node) return Base_Token_Index
+ is begin
+ return
+ (case N.Label is
+ when Shared_Terminal => N.Terminal,
+ when Virtual_Terminal => Invalid_Token_Index,
+ when Nonterm => N.Max_Terminal_Index);
+ end Compute;
+
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Max_Terminal_Index;
+
+ procedure Move_Branch_Point (Tree : in out Syntax_Trees.Tree; Required_Node
: in Valid_Node_Index)
+ is begin
+ -- Note that this preserves all stored indices in Branched_Nodes.
+ Tree.Branched_Nodes.Prepend (Tree.Shared_Tree.Nodes, Required_Node,
Tree.Last_Shared_Node);
+ Tree.Last_Shared_Node := Required_Node - 1;
+ end Move_Branch_Point;
+
+ function Parent (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Index
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Parent;
+ else
+ return Tree.Branched_Nodes (Node).Parent;
+ end if;
+ end Parent;
+
+ procedure Print_Tree (Tree : in Syntax_Trees.Tree; Descriptor : in
WisiToken.Descriptor)
+ is
+ use Ada.Text_IO;
+ procedure Print_Node (Node : in Valid_Node_Index; Level : in Integer)
+ is
+ N : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Node);
+ begin
+ for I in 1 .. Level loop
+ Put ("| ");
+ end loop;
+ Put_Line (Image (Tree, N, Descriptor, Include_Children => False));
+
+ if N.Label = Nonterm then
+ for Child of N.Children loop
+ Print_Node (Child, Level + 1);
+ end loop;
+ end if;
+ end Print_Node;
+
+ begin
+ Print_Node (Tree.Root, 0);
+ end Print_Tree;
+
+ function Process_Tree
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Process_Node : access function
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Boolean)
+ return Boolean
+ is
+ function Compute (N : in Syntax_Trees.Node) return Boolean
+ is begin
+ if N.Label = Nonterm then
+ for Child of N.Children loop
+ if not Process_Tree (Tree, Child, Process_Node) then
+ return False;
+ end if;
+ end loop;
+ end if;
+
+ return Process_Node (Tree, Node);
+ end Compute;
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ return Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ return Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Process_Tree;
+
+ procedure Process_Tree
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Process_Node : access procedure
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index))
+ is
+ procedure Compute (N : in Syntax_Trees.Node)
+ is begin
+ if N.Label = Nonterm then
+ for Child of N.Children loop
+ Process_Tree (Tree, Child, Process_Node);
+ end loop;
+ end if;
+
+ Process_Node (Tree, Node);
+ end Compute;
+ begin
+ if Node <= Tree.Last_Shared_Node then
+ Compute (Tree.Shared_Tree.Nodes (Node));
+ else
+ Compute (Tree.Branched_Nodes (Node));
+ end if;
+ end Process_Tree;
+
+ procedure Process_Tree
+ (Tree : in out Syntax_Trees.Tree;
+ Process_Node : access procedure
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index))
+ is begin
+ if Tree.Root = Invalid_Node_Index then
+ raise SAL.Programmer_Error with "Tree.Root not set";
+ end if;
+ Tree.Shared_Tree.Traversing := True;
+ if Tree.Flush then
+ Process_Tree (Tree, Tree.Root, Process_Node);
+ else
+ Process_Tree (Tree, Tree.Root, Process_Node);
+ end if;
+ Tree.Shared_Tree.Traversing := False;
+ exception
+ when others =>
+ Tree.Shared_Tree.Traversing := False;
+ raise;
+ end Process_Tree;
+
+ procedure Set_Root (Tree : in out Syntax_Trees.Tree; Root : in
Valid_Node_Index)
+ is begin
+ Tree.Root := Root;
+ end Set_Root;
+
+ function Root (Tree : in Syntax_Trees.Tree) return Node_Index
+ is begin
+ if Tree.Root /= Invalid_Node_Index then
+ return Tree.Root;
+ else
+ if Tree.Flush then
+ return Tree.Shared_Tree.Nodes.Last_Index;
+ else
+ return Tree.Branched_Nodes.Last_Index;
+ end if;
+ end if;
+ end Root;
+
+ function Same_Token
+ (Tree_1 : in Syntax_Trees.Tree'Class;
+ Index_1 : in Valid_Node_Index;
+ Tree_2 : in Syntax_Trees.Tree'Class;
+ Index_2 : in Valid_Node_Index)
+ return Boolean
+ is
+ function Compute (N_1, N_2 : in Syntax_Trees.Node) return Boolean
+ is begin
+ return N_1.Label = N_2.Label and
+ N_1.ID = N_2.ID and
+ N_1.Byte_Region = N_2.Byte_Region;
+ end Compute;
+ begin
+ return Compute
+ ((if Index_1 <= Tree_1.Last_Shared_Node
+ then Tree_1.Shared_Tree.Nodes (Index_1)
+ else Tree_1.Branched_Nodes (Index_1)),
+ (if Index_2 <= Tree_2.Last_Shared_Node
+ then Tree_2.Shared_Tree.Nodes (Index_2)
+ else Tree_2.Branched_Nodes (Index_2)));
+ end Same_Token;
+
+ procedure Set_Augmented
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Value : in Base_Token_Class_Access)
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ Tree.Shared_Tree.Nodes (Node).Augmented := Value;
+ else
+ Tree.Branched_Nodes (Node).Augmented := Value;
+ end if;
+ end Set_Augmented;
+
+ procedure Set_Children
+ (Nodes : in out Node_Arrays.Vector;
+ Parent : in Valid_Node_Index;
+ Children : in Valid_Node_Index_Array)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ N : Nonterm_Node renames Nodes (Parent);
+ J : Positive_Index_Type := Positive_Index_Type'First;
+
+ Min_Terminal_Index_Set : Boolean := False;
+ begin
+ N.Children.Set_Length (Children'Length);
+ for I in Children'Range loop
+ N.Children (J) := Children (I);
+ declare
+ K : Syntax_Trees.Node renames Nodes (Children (I));
+ begin
+ K.Parent := Parent;
+
+ N.Virtual := N.Virtual or
+ (case K.Label is
+ when Shared_Terminal => False,
+ when Virtual_Terminal => True,
+ when Nonterm => K.Virtual);
+
+ if N.Byte_Region.First > K.Byte_Region.First then
+ N.Byte_Region.First := K.Byte_Region.First;
+ end if;
+
+ if N.Byte_Region.Last < K.Byte_Region.Last then
+ N.Byte_Region.Last := K.Byte_Region.Last;
+ end if;
+
+ if not Min_Terminal_Index_Set then
+ case K.Label is
+ when Shared_Terminal =>
+ Min_Terminal_Index_Set := True;
+ N.Min_Terminal_Index := K.Terminal;
+
+ when Virtual_Terminal =>
+ null;
+
+ when Nonterm =>
+ if K.Min_Terminal_Index /= Invalid_Token_Index then
+ -- not an empty nonterm
+ Min_Terminal_Index_Set := True;
+ N.Min_Terminal_Index := K.Min_Terminal_Index;
+ end if;
+ end case;
+ end if;
+
+ case K.Label is
+ when Shared_Terminal =>
+ if N.Max_Terminal_Index < K.Terminal then
+ N.Max_Terminal_Index := K.Terminal;
+ end if;
+
+ when Virtual_Terminal =>
+ null;
+
+ when Nonterm =>
+ if K.Max_Terminal_Index /= Invalid_Token_Index and then
+ -- not an empty nonterm
+ N.Max_Terminal_Index < K.Max_Terminal_Index
+ then
+ N.Max_Terminal_Index := K.Max_Terminal_Index;
+ end if;
+ end case;
+ end;
+
+ J := J + 1;
+ end loop;
+ end Set_Children;
+
+ procedure Set_State
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ State : in State_Index)
+ is begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes (Node).State := State;
+ else
+ if Node <= Tree.Last_Shared_Node then
+ Tree.Shared_Tree.Nodes (Node).State := State;
+ else
+ Tree.Branched_Nodes (Node).State := State;
+ end if;
+ end if;
+ end Set_State;
+
+ procedure Set_Flush_False (Tree : in out Syntax_Trees.Tree)
+ is begin
+ Tree.Flush := False;
+ Tree.Branched_Nodes.Set_First (Tree.Last_Shared_Node + 1);
+ end Set_Flush_False;
+
+ function Flushed (Tree : in Syntax_Trees.Tree) return Boolean
+ is begin
+ return Tree.Flush;
+ end Flushed;
+
+ procedure Set_Name_Region
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Region : in Buffer_Region)
+ is begin
+ if Tree.Flush then
+ Tree.Shared_Tree.Nodes (Node).Name := Region;
+
+ else
+ if Node <= Tree.Last_Shared_Node then
+ Move_Branch_Point (Tree, Node);
+ end if;
+
+ Tree.Branched_Nodes (Node).Name := Region;
+ end if;
+ end Set_Name_Region;
+
+ function Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Base_Token_Index
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Terminal;
+ else
+ return Tree.Branched_Nodes (Node).Terminal;
+ end if;
+ end Terminal;
+
+ function Traversing (Tree : in Syntax_Trees.Tree) return Boolean
+ is begin
+ return Tree.Shared_Tree.Traversing;
+ end Traversing;
+
+ function Recover_Token
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Recover_Token
+ is
+ function Compute (N : Syntax_Trees.Node) return WisiToken.Recover_Token
+ is begin
+ case N.Label is
+ when Shared_Terminal =>
+ return
+ (ID => N.ID,
+ Byte_Region => N.Byte_Region,
+ Min_Terminal_Index => N.Terminal,
+ Name => Null_Buffer_Region,
+ Virtual => False);
+
+ when Virtual_Terminal =>
+ return
+ (ID => N.ID,
+ Byte_Region => Null_Buffer_Region,
+ Min_Terminal_Index => Invalid_Token_Index,
+ Name => Null_Buffer_Region,
+ Virtual => True);
+
+ when Nonterm =>
+ return
+ (ID => N.ID,
+ Byte_Region => N.Byte_Region,
+ Min_Terminal_Index => N.Min_Terminal_Index,
+ Name => N.Name,
+ Virtual => N.Virtual);
+ end case;
+ end Compute;
+ begin
+ return Compute
+ ((if Node <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (Node)
+ else Tree.Branched_Nodes (Node)));
+ end Recover_Token;
+
+ function Recover_Token_Array
+ (Tree : in Syntax_Trees.Tree;
+ Nodes : in Valid_Node_Index_Array)
+ return WisiToken.Recover_Token_Array
+ is begin
+ return Result : WisiToken.Recover_Token_Array (Nodes'First ..
Nodes'Last) do
+ for I in Result'Range loop
+ Result (I) := Tree.Recover_Token (Nodes (I));
+ end loop;
+ end return;
+ end Recover_Token_Array;
+
+ function State (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Unknown_State_Index
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).State;
+ else
+ return Tree.Branched_Nodes (Node).State;
+ end if;
+ end State;
+
+end WisiToken.Syntax_Trees;
diff --git a/wisitoken-syntax_trees.ads b/wisitoken-syntax_trees.ads
new file mode 100644
index 0000000..dc04946
--- /dev/null
+++ b/wisitoken-syntax_trees.ads
@@ -0,0 +1,411 @@
+-- Abstract :
+--
+-- Syntax tree type and operations.
+--
+-- Rationale :
+--
+-- We provide Base_Tree and Tree in one package, because only Tree
+-- needs an API; the only way Base_Tree is accessed is via Tree.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+
+-- There is one syntax tree for each parser. There is one shared
+-- Terminals array, matching the actual input text.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with SAL.Gen_Unbounded_Definite_Vectors;
+with WisiToken.Lexer;
+package WisiToken.Syntax_Trees is
+
+ type Base_Tree is new Ada.Finalization.Controlled with private;
+
+ type Base_Tree_Access is access all Base_Tree;
+
+ overriding procedure Finalize (Tree : in out Base_Tree);
+ -- Free any allocated storage.
+
+ overriding procedure Adjust (Tree : in out Base_Tree);
+ -- Copy any allocated storage.
+
+ type Tree is tagged private;
+
+ procedure Initialize
+ (Branched_Tree : in out Tree;
+ Shared_Tree : in Base_Tree_Access;
+ Flush : in Boolean);
+ -- Set Branched_Tree to refer to Shared_Tree.
+
+ type Node_Index is range 0 .. Integer'Last;
+ subtype Valid_Node_Index is Node_Index range 1 .. Node_Index'Last;
+
+ Invalid_Node_Index : constant Node_Index := Node_Index'First;
+
+ type Valid_Node_Index_Array is array (Positive_Index_Type range <>) of
Valid_Node_Index;
+ -- Index matches Base_Token_Array, Augmented_Token_Array
+
+ package Valid_Node_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(Positive_Index_Type, Valid_Node_Index);
+ -- Index matches Valid_Node_Index_Array.
+
+ type Node_Label is (Shared_Terminal, Virtual_Terminal, Nonterm);
+
+ type User_Data_Type is tagged limited null record;
+ -- Many test languages don't need this, so we default the procedures
+ -- to null.
+
+ type User_Data_Access is access all User_Data_Type'Class;
+
+ procedure Set_Lexer_Terminals
+ (User_Data : in out User_Data_Type;
+ Lexer : in WisiToken.Lexer.Handle;
+ Terminals : in Base_Token_Array_Access)
+ is null;
+
+ procedure Reset (User_Data : in out User_Data_Type) is null;
+ -- Reset to start a new parse.
+
+ procedure Lexer_To_Augmented
+ (User_Data : in out User_Data_Type;
+ Token : in Base_Token;
+ Lexer : not null access WisiToken.Lexer.Instance'Class)
+ is null;
+ -- Read auxiliary data from Lexer, create an Augmented_Token, store
+ -- it in User_Data. Called before parsing, once for each token in the
+ -- input stream.
+
+ procedure Delete_Token
+ (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.
+
+ procedure Reduce
+ (User_Data : in out User_Data_Type;
+ Tree : in out Syntax_Trees.Tree'Class;
+ Nonterm : in Valid_Node_Index;
+ Tokens : in Valid_Node_Index_Array)
+ is null;
+ -- Reduce Tokens to Nonterm. Nonterm.Byte_Region is computed by
+ -- caller.
+
+ type Semantic_Action is access procedure
+ (User_Data : in out User_Data_Type'Class;
+ Tree : in out Syntax_Trees.Tree;
+ Nonterm : in Valid_Node_Index;
+ Tokens : in Valid_Node_Index_Array);
+ -- Routines of this type are called by
+ -- WisiToken.LR.Parser.Execute_Actions when it processes a Nonterm
+ -- node in the syntax tree. Tokens are the children of Nonterm.
+
+ Null_Action : constant Semantic_Action := null;
+
+ procedure Clear (Tree : in out Syntax_Trees.Base_Tree);
+ procedure Clear (Tree : in out Syntax_Trees.Tree);
+ -- Delete all Elements and free associated memory; keep results of
+ -- Initialize.
+
+ procedure Flush (Tree : in out Syntax_Trees.Tree);
+ -- Move all nodes in branched part to shared tree, set Flush mode
+ -- True.
+
+ procedure Set_Flush_False (Tree : in out Syntax_Trees.Tree);
+ -- Set Flush mode False; use Flush to set True.
+
+ function Flushed (Tree : in Syntax_Trees.Tree) return Boolean;
+
+ function Add_Nonterm
+ (Tree : in out Syntax_Trees.Tree;
+ Production : in Production_ID;
+ Children : in Valid_Node_Index_Array;
+ Action : in Semantic_Action;
+ Default_Virtual : in Boolean)
+ return Valid_Node_Index
+ with
+ Pre => not Tree.Traversing,
+ Post => Tree.Is_Empty (Add_Nonterm'Result) or
+ Tree.Min_Terminal_Index (Add_Nonterm'Result) /=
Invalid_Token_Index;
+ -- Add a new Nonterm node, which can be empty. Result points to the
+ -- added node. If Children'Length = 0, set Nonterm.Virtual :=
+ -- Default_Virtual.
+
+ function Add_Terminal
+ (Tree : in out Syntax_Trees.Tree;
+ Terminal : in Token_Index;
+ Terminals : in Base_Token_Arrays.Vector)
+ return Valid_Node_Index
+ with Pre => not Tree.Traversing;
+ -- Add a new Terminal node. Terminal must be an index into Terminals.
+ -- Result points to the added node.
+
+ function Add_Terminal
+ (Tree : in out Syntax_Trees.Tree;
+ Terminal : in Token_ID)
+ return Valid_Node_Index
+ with Pre => not Tree.Traversing;
+ -- Add a new virtual terminal node with no parent. Result points to
+ -- the added node.
+
+ procedure Set_State
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ State : in State_Index);
+
+ function State (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Unknown_State_Index;
+
+ function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Label;
+
+ function Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Valid_Node_Index_Array
+ with Pre => Tree.Is_Nonterm (Node);
+
+ function Has_Branched_Nodes (Tree : in Syntax_Trees.Tree) return Boolean;
+ function Has_Children (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Has_Parent (Tree : in Syntax_Trees.Tree; Child : in
Valid_Node_Index) return Boolean;
+ function Has_Parent (Tree : in Syntax_Trees.Tree; Children : in
Valid_Node_Index_Array) return Boolean;
+ function Is_Empty (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Boolean;
+ function Is_Nonterm (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Is_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Is_Virtual (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Traversing (Tree : in Syntax_Trees.Tree) return Boolean;
+
+ function Parent (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Index;
+
+ procedure Set_Name_Region
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Region : in Buffer_Region)
+ with Pre => Tree.Is_Nonterm (Node);
+
+ function ID
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Token_ID;
+
+ function Byte_Region
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Buffer_Region;
+
+ function Same_Token
+ (Tree_1 : in Syntax_Trees.Tree'Class;
+ Index_1 : in Valid_Node_Index;
+ Tree_2 : in Syntax_Trees.Tree'Class;
+ Index_2 : in Valid_Node_Index)
+ return Boolean;
+ -- True if the two tokens have the same ID and Byte_Region.
+
+ function Recover_Token
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return WisiToken.Recover_Token;
+
+ function Recover_Token_Array
+ (Tree : in Syntax_Trees.Tree;
+ Nodes : in Valid_Node_Index_Array)
+ return WisiToken.Recover_Token_Array;
+ -- For non-virtual terminals, copied from Tree.Terminals. For others,
+ -- constructed from Tree data.
+
+ procedure Set_Augmented
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Value : in Base_Token_Class_Access)
+ with Pre => Tree.Is_Nonterm (Node);
+ -- Value will be deallocated when Tree is finalized.
+
+ function Augmented
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Base_Token_Class_Access
+ with Pre => Tree.Is_Nonterm (Node);
+ -- Returns result of Set_Augmented.
+
+ function Action
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ return Semantic_Action
+ with Pre => Tree.Is_Nonterm (Node);
+
+ function Find_Ancestor
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index;
+ -- Return the ancestor of Node that contains ID, or Invalid_Node_Index if
+ -- none match.
+
+ function Find_Sibling
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ with Pre => Tree.Has_Parent (Node);
+ -- Return the sibling of Node that contains ID, or Invalid_Node_Index if
+ -- none match.
+
+ function Find_Child
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index
+ with Pre => Tree.Is_Nonterm (Node);
+ -- Return the child of Node that contains ID, or Invalid_Node_Index if
+ -- none match.
+
+ function Find_Descendant
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID)
+ return Node_Index;
+ -- Return the child of Node that contains ID (may be Node), or
+ -- Invalid_Node_Index if none match.
+
+ procedure Set_Root (Tree : in out Syntax_Trees.Tree; Root : in
Valid_Node_Index);
+
+ function Root (Tree : in Syntax_Trees.Tree) return Node_Index;
+ -- Return value set by Set_Root; defaults to the last node added.
+ -- returns Invalid_Node_Index if Tree is empty.
+
+ procedure Process_Tree
+ (Tree : in out Syntax_Trees.Tree;
+ Process_Node : access procedure
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index));
+ -- Traverse Tree in depth-first order, calling Process_Node on each
+ -- node, starting at Tree.Root.
+
+ function Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Base_Token_Index
+ with Pre => Tree.Is_Terminal (Node);
+
+ function Min_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index;
+ function Max_Terminal_Index (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index;
+ -- Returns lowest/highest index of shared terminal in subtree under
+ -- Node. If result is Invalid_Token_Index, all terminals are virtual,
+ -- or a nonterm is empty.
+
+ function Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index_Array;
+
+ function Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID_Array;
+
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean := False)
+ return String;
+ function Image
+ (Tree : in Syntax_Trees.Tree;
+ Nodes : in Valid_Node_Index_Array;
+ Descriptor : in WisiToken.Descriptor)
+ return String;
+ -- For debug and error messages.
+
+ procedure Print_Tree (Tree : in Syntax_Trees.Tree; Descriptor : in
WisiToken.Descriptor)
+ with Pre => Tree.Flushed;
+ -- To Text_IO.Current_Output, for debugging.
+
+private
+
+ type Node (Label : Node_Label := Virtual_Terminal) is
+ -- Label has a default to allow use with Ada.Containers.Vectors; all
+ -- entries are the same size.
+ record
+ ID : WisiToken.Token_ID := Invalid_Token_ID;
+
+ Byte_Region : Buffer_Region := Null_Buffer_Region;
+ -- Computed by Set_Children, used in Semantic_Check actions and debug
+ -- messages.
+
+ Parent : Node_Index := Invalid_Node_Index;
+
+ State : Unknown_State_Index := Unknown_State;
+ -- Parse state that was on stack with this token, to allow undoing a
+ -- reduce.
+
+ case Label is
+ when Shared_Terminal =>
+ Terminal : Token_Index;
+
+ when Virtual_Terminal =>
+ null;
+
+ when Nonterm =>
+ Virtual : Boolean := False;
+ -- True if any child node is Virtual_Terminal or Nonterm with Virtual
+ -- set. Used by Semantic_Check actions.
+
+ RHS_Index : Natural;
+ -- With ID, index into Productions.
+ -- Used for debug output, keep for future use.
+
+ Action : Semantic_Action := null;
+
+ Name : Buffer_Region := Null_Buffer_Region;
+ -- Name is set and checked by Semantic_Check actions.
+
+ Children : Valid_Node_Index_Arrays.Vector;
+
+ Min_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
+ -- Cached for push_back of nonterminals during recovery
+
+ Max_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
+ -- Cached for building a WisiToken tree from a libadalang tree.
+
+ Augmented : Base_Token_Class_Access := null;
+ end case;
+ end record;
+
+ subtype Nonterm_Node is Node (Nonterm);
+
+ package Node_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(Valid_Node_Index, Node);
+
+ type Base_Tree is new Ada.Finalization.Controlled with record
+ Nodes : Node_Arrays.Vector;
+ -- During normal parsing, tokens are added to Nodes by "parallel"
+ -- LALR parsers, but they are all run from one Ada task, so there's
+ -- no need for Nodes to be Protected. Packrat parsing also has a
+ -- single Ada task.
+ --
+ -- During McKenzie_Recover, the syntax tree is not modified.
+
+ Augmented_Present : Boolean := False;
+ -- True if Set_Augmented has been called on any node.
+ -- Declared in Base_Tree because used by Base_Tree.Adjust.
+
+ Traversing : Boolean := False;
+ -- True while traversing tree in Process_Tree.
+ -- Declared in Base_Tree so it is cleared by Finalize.
+
+ end record;
+
+ type Tree is tagged record
+ Shared_Tree : Base_Tree_Access;
+ -- If we need to set anything (ie parent) in Shared_Tree, we move the
+ -- branch point instead, unless Flush = True.
+
+ Last_Shared_Node : Node_Index := Invalid_Node_Index;
+ Branched_Nodes : Node_Arrays.Vector;
+ Flush : Boolean := False;
+ -- We maintain Last_Shared_Node when Flush is True, so subprograms
+ -- that have no reason to check Flush can rely on Last_Shared_Node.
+
+ Root : Node_Index := Invalid_Node_Index;
+ end record with
+ Type_Invariant => (if Tree.Flush then not Tree.Has_Branched_Nodes);
+
+end WisiToken.Syntax_Trees;
diff --git a/wisitoken-text_io_trace.adb b/wisitoken-text_io_trace.adb
new file mode 100644
index 0000000..1329cff
--- /dev/null
+++ b/wisitoken-text_io_trace.adb
@@ -0,0 +1,70 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body WisiToken.Text_IO_Trace is
+
+ overriding
+ procedure Put (Trace : in out Text_IO_Trace.Trace; Item : in String)
+ 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);
+ else
+ Ada.Text_IO.Put (Item);
+ end if;
+ end Put;
+
+ overriding
+ procedure Put_Line (Trace : in out Text_IO_Trace.Trace; Item : in String)
+ is
+ use Ada.Text_IO;
+ 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.Flush (Trace.File.all);
+ else
+ Ada.Text_IO.Put_Line (Item);
+ Ada.Text_IO.Flush;
+ end if;
+ end Put_Line;
+
+ overriding
+ procedure New_Line (Trace : in out Text_IO_Trace.Trace)
+ is
+ use Ada.Text_IO;
+ begin
+ if Trace.File /= null and then Is_Open (Trace.File.all) then
+ Ada.Text_IO.New_Line (Trace.File.all);
+ else
+ Ada.Text_IO.New_Line;
+ end if;
+ end New_Line;
+
+ procedure Set_File (Trace : in out Text_IO_Trace.Trace; File : in
Ada.Text_IO.File_Access)
+ is begin
+ Trace.File := File;
+ end Set_File;
+
+ procedure Clear_File (Trace : in out Text_IO_Trace.Trace)
+ is begin
+ Trace.File := null;
+ end Clear_File;
+
+end WisiToken.Text_IO_Trace;
diff --git a/wisitoken-text_io_trace.ads b/wisitoken-text_io_trace.ads
new file mode 100644
index 0000000..6deaf51
--- /dev/null
+++ b/wisitoken-text_io_trace.ads
@@ -0,0 +1,45 @@
+-- Abstract :
+--
+-- Trace output to Ada.Text_IO
+--
+-- Copyright (C) 2017 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Text_IO;
+package WisiToken.Text_IO_Trace is
+
+ type Trace is limited new WisiToken.Trace with private;
+ -- Defaults to Ada.Text_IO.Standard_Output
+
+ overriding
+ procedure Put (Trace : in out Text_IO_Trace.Trace; Item : in String);
+
+ overriding
+ procedure Put_Line (Trace : in out Text_IO_Trace.Trace; Item : in String);
+
+ overriding
+ procedure New_Line (Trace : in out Text_IO_Trace.Trace);
+
+ 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.
+
+ procedure Clear_File (Trace : in out Text_IO_Trace.Trace);
+ -- Clear internal file; output to Text_IO.Current_Output.
+
+private
+ type Trace is limited new WisiToken.Trace with record
+ File : Ada.Text_IO.File_Access;
+ end record;
+end WisiToken.Text_IO_Trace;
diff --git a/wisitoken-wisi_ada.adb b/wisitoken-wisi_ada.adb
new file mode 100644
index 0000000..ba0285d
--- /dev/null
+++ b/wisitoken-wisi_ada.adb
@@ -0,0 +1,163 @@
+-- Abstract :
+--
+-- see spec
+--
+-- Copyright (C) 2013, 2014, 2015, 2017, 2018 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- 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.Wisi_Ada is
+ use WisiToken.Productions;
+
+ function Only (Item : in Token_ID) return WisiToken.Token_ID_Arrays.Vector
+ is begin
+ return Result : WisiToken.Token_ID_Arrays.Vector do
+ Result.Append (Item);
+ end return;
+ end Only;
+
+ function "&" (Left : in Token_ID; Right : in Token_ID) return
WisiToken.Token_ID_Arrays.Vector
+ is begin
+ return Result : WisiToken.Token_ID_Arrays.Vector do
+ Result.Append (Left);
+ Result.Append (Right);
+ end return;
+ end "&";
+
+ function "+" (Tokens : in Token_ID_Arrays.Vector; Action : in
Syntax_Trees.Semantic_Action) return Right_Hand_Side
+ is begin
+ return (Tokens, Action, null);
+ end "+";
+
+ function "+" (Tokens : in Token_ID; Action : in
Syntax_Trees.Semantic_Action) return Right_Hand_Side
+ is begin
+ return (Only (Tokens), Action, null);
+ end "+";
+
+ function "+" (Action : in Syntax_Trees.Semantic_Action) return
Right_Hand_Side
+ is begin
+ return (Token_ID_Arrays.Empty_Vector, Action, null);
+ end "+";
+
+ function Only (Item : in WisiToken.Productions.Right_Hand_Side) return
WisiToken.Productions.RHS_Arrays.Vector
+ is begin
+ return Result : WisiToken.Productions.RHS_Arrays.Vector do
+ Result.Append (Item);
+ end return;
+ end Only;
+
+ function "or"
+ (Left : in WisiToken.Productions.Instance;
+ Right : in WisiToken.Productions.Right_Hand_Side)
+ return WisiToken.Productions.Instance
+ is begin
+ return Result : WisiToken.Productions.Instance := Left do
+ Result.RHSs.Append (Right);
+ end return;
+ end "or";
+
+ function "<=" (LHS : in Token_ID; RHSs : in
WisiToken.Productions.RHS_Arrays.Vector) return Instance
+ is begin
+ return (LHS, RHSs);
+ end "<=";
+
+ function Only (Subject : in Instance) return Prod_Arrays.Vector
+ is begin
+ return Result : Prod_Arrays.Vector do
+ Result.Set_First (Subject.LHS);
+ Result.Set_Last (Subject.LHS);
+ Result (Subject.LHS) := Subject;
+ end return;
+ end Only;
+
+ function Merge (Left, Right : in Instance) return Instance
+ is
+ Index : Integer := Left.RHSs.Last_Index + 1;
+ begin
+ return Result : Instance := Left do
+ Result.RHSs.Set_Last (Left.RHSs.Last_Index + Integer
(Right.RHSs.Length));
+ for RHS of Right.RHSs loop
+ Result.RHSs (Index) := RHS;
+ Index := Index + 1;
+ end loop;
+ end return;
+ end Merge;
+
+ function "and" (Left : in Instance; Right : in Instance) return
Prod_Arrays.Vector
+ is begin
+ return Result : Prod_Arrays.Vector do
+ Result.Set_First (Token_ID'Min (Left.LHS, Right.LHS));
+ Result.Set_Last (Token_ID'Max (Left.LHS, Right.LHS));
+ if Left.LHS = Right.LHS then
+ Result (Left.LHS) := Merge (Left, Right);
+ else
+ Result (Left.LHS) := Left;
+ Result (Right.LHS) := Right;
+ end if;
+ end return;
+ end "and";
+
+ function "and" (Left : in Prod_Arrays.Vector; Right : in Instance) return
Prod_Arrays.Vector
+ is begin
+ return Result : Prod_Arrays.Vector := Left do
+ if Right.LHS < Result.First_Index then
+ Result.Set_First (Right.LHS);
+ elsif Right.LHS > Result.Last_Index then
+ Result.Set_Last (Right.LHS);
+ end if;
+
+ if Result (Right.LHS).LHS = Invalid_Token_ID then
+ Result (Right.LHS) := Right;
+ else
+ Result (Right.LHS) := Merge (Result (Right.LHS), Right);
+ end if;
+ end return;
+ end "and";
+
+ function "and" (Left : in Prod_Arrays.Vector; Right : in
Prod_Arrays.Vector) return Prod_Arrays.Vector
+ is begin
+ return Result : Prod_Arrays.Vector := Left do
+ if Right.First_Index < Result.First_Index then
+ Result.Set_First (Right.First_Index);
+ elsif Right.First_Index > Result.Last_Index then
+ Result.Set_Last (Right.First_Index);
+ end if;
+ if Right.Last_Index < Result.First_Index then
+ Result.Set_First (Right.Last_Index);
+ elsif Right.Last_Index > Result.Last_Index then
+ Result.Set_Last (Right.Last_Index);
+ end if;
+
+ for P of Right loop
+ if Result (P.LHS).LHS = Invalid_Token_ID then
+ Result (P.LHS) := P;
+ else
+ Result (P.LHS) := Merge (Result (P.LHS), P);
+ end if;
+ end loop;
+ end return;
+ end "and";
+
+end WisiToken.Wisi_Ada;
diff --git a/wisitoken-wisi_ada.ads b/wisitoken-wisi_ada.ads
new file mode 100644
index 0000000..0678d06
--- /dev/null
+++ b/wisitoken-wisi_ada.ads
@@ -0,0 +1,82 @@
+-- Abstract :
+--
+-- Type and operations for building a grammar directly in Ada source.
+--
+-- Copyright (C) 2003, 2013 - 2015, 2017, 2018 Stephe Leake
+-- Copyright (C) 1999 Ted Dennison
+--
+-- This file is part of the WisiToken package.
+--
+-- The WisiToken package is free software; you can redistribute it
+-- and/or modify it under the terms of the GNU General Public License
+-- as published by the Free Software Foundation; either version 3, or
+-- (at your option) any later version. The WisiToken package is
+-- distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+-- License for more details. You should have received a copy of the
+-- GNU General Public License distributed with the WisiToken package;
+-- see file GPL.txt. If not, write to the Free Software Foundation,
+-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from
+-- this unit, or you link this unit with other files to produce an
+-- executable, this unit does not by itself cause the resulting
+-- executable to be covered by the GNU General Public License. This
+-- exception does not however invalidate any other reasons why the
+-- executable file might be covered by the GNU Public License.
+
+pragma License (Modified_GPL);
+
+with WisiToken.Productions;
+with WisiToken.Syntax_Trees;
+package WisiToken.Wisi_Ada is
+
+ function Only (Item : in Token_ID) return WisiToken.Token_ID_Arrays.Vector;
+ function "&" (Left : in Token_ID; Right : in Token_ID) return
WisiToken.Token_ID_Arrays.Vector;
+
+ function "+"
+ (Tokens : in WisiToken.Token_ID_Arrays.Vector;
+ Action : in WisiToken.Syntax_Trees.Semantic_Action)
+ return WisiToken.Productions.Right_Hand_Side;
+ function "+"
+ (Tokens : in Token_ID;
+ Action : in WisiToken.Syntax_Trees.Semantic_Action)
+ return WisiToken.Productions.Right_Hand_Side;
+ function "+" (Action : in WisiToken.Syntax_Trees.Semantic_Action) return
WisiToken.Productions.Right_Hand_Side;
+ -- Create the right hand side of a production.
+
+ function Only (Item : in WisiToken.Productions.Right_Hand_Side) return
WisiToken.Productions.RHS_Arrays.Vector;
+ function "+" (Item : in WisiToken.Productions.Right_Hand_Side) return
WisiToken.Productions.RHS_Arrays.Vector
+ renames Only;
+
+ function "or"
+ (Left : in WisiToken.Productions.Instance;
+ Right : in WisiToken.Productions.Right_Hand_Side)
+ return WisiToken.Productions.Instance;
+
+ function "<="
+ (LHS : in Token_ID;
+ RHSs : in WisiToken.Productions.RHS_Arrays.Vector)
+ return WisiToken.Productions.Instance;
+
+ function Only (Subject : in WisiToken.Productions.Instance) return
WisiToken.Productions.Prod_Arrays.Vector;
+ function "+" (Subject : in WisiToken.Productions.Instance) return
WisiToken.Productions.Prod_Arrays.Vector
+ renames Only;
+ -- First production in a grammar.
+
+ function "and"
+ (Left : in WisiToken.Productions.Instance;
+ Right : in WisiToken.Productions.Instance)
+ return WisiToken.Productions.Prod_Arrays.Vector;
+ function "and"
+ (Left : in WisiToken.Productions.Prod_Arrays.Vector;
+ Right : in WisiToken.Productions.Instance)
+ return WisiToken.Productions.Prod_Arrays.Vector;
+ function "and"
+ (Left : in WisiToken.Productions.Prod_Arrays.Vector;
+ Right : in WisiToken.Productions.Prod_Arrays.Vector)
+ return WisiToken.Productions.Prod_Arrays.Vector;
+ -- Create a grammar
+
+end WisiToken.Wisi_Ada;
diff --git a/wisitoken.adb b/wisitoken.adb
new file mode 100644
index 0000000..3553e4a
--- /dev/null
+++ b/wisitoken.adb
@@ -0,0 +1,351 @@
+-------------------------------------------------------------------------------
+--
+-- Copyright (C) 2009, 2014-2015, 2017, 2018 Stephe Leake
+--
+-- 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.
+-------------------------------------------------------------------------------
+
+with Ada.Strings.Fixed;
+package body WisiToken is
+
+ function Padded_Image (Item : in Token_ID; Desc : in Descriptor) return
String
+ is begin
+ return Ada.Strings.Fixed.Head
+ (Desc.Image (Item).all,
+ (if Item in Desc.First_Terminal .. Desc.Last_Terminal
+ then Desc.Terminal_Image_Width
+ else Desc.Image_Width));
+ end Padded_Image;
+
+ 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);
+ end Image;
+
+ procedure Put_Tokens (Descriptor : in WisiToken.Descriptor)
+ is
+ use Ada.Text_IO;
+ begin
+ for I in Token_ID'First .. Descriptor.Last_Nonterminal loop
+ Put_Line (Token_ID'Image (I) & " => " & Descriptor.Image (I).all);
+ end loop;
+ end Put_Tokens;
+
+ function Find_ID (Descriptor : in WisiToken.Descriptor; Name : in String)
return Token_ID
+ is begin
+ for I in Descriptor.Image'Range loop
+ if Descriptor.Image (I).all = Name then
+ return I;
+ end if;
+ end loop;
+ raise SAL.Programmer_Error with "token name '" & Name & "' not found in
descriptor.image";
+ end Find_ID;
+
+ procedure To_Vector (Item : in Token_ID_Array; Vector : in out
Token_ID_Arrays.Vector)
+ is
+ J : Integer := Vector.First_Index;
+ begin
+ for ID of Item loop
+ Vector.Replace_Element (J, ID);
+ J := J + 1;
+ end loop;
+ end To_Vector;
+
+ function Shared_Prefix (A, B : in Token_ID_Arrays.Vector) return Natural
+ is
+ use all type Ada.Containers.Count_Type;
+ I : Natural := A.First_Index;
+ J : Natural := B.First_Index;
+ begin
+ if A.Length = 0 or B.Length = 0 then
+ return 0;
+ end if;
+
+ loop
+ exit when A (I) /= B (I) or I = A.Last_Index or J = B.Last_Index;
+ I := I + 1;
+ J := J + 1;
+ end loop;
+ return I - 1;
+ end Shared_Prefix;
+
+ function "&" (Left : in Token_ID_Set; Right : in Token_ID) return
Token_ID_Set
+ is begin
+ return Result : Token_ID_Set := Left do
+ Result (Right) := True;
+ end return;
+ end "&";
+
+ function To_Token_ID_Set (First, Last : in Token_ID; Item : in
Token_ID_Array) return Token_ID_Set
+ is begin
+ return Result : Token_ID_Set := (First .. Last => False)
+ do
+ for ID of Item loop
+ Result (ID) := True;
+ end loop;
+ end return;
+ end To_Token_ID_Set;
+
+ procedure To_Set (Item : in Token_ID_Arrays.Vector; Set : out Token_ID_Set)
+ is begin
+ for ID of Item loop
+ Set (ID) := True;
+ end loop;
+ end To_Set;
+
+ function To_Array (Item : in Token_ID_Set) return Token_ID_Arrays.Vector
+ is begin
+ return Result : Token_ID_Arrays.Vector do
+ for ID in Item'Range loop
+ if Item (ID) then
+ Result.Append (ID);
+ end if;
+ end loop;
+ end return;
+ end To_Array;
+
+ function Any (Item : in Token_ID_Set) return Boolean
+ is begin
+ for I in Item'Range loop
+ if Item (I) then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Any;
+
+ function Count (Item : in Token_ID_Set) return Integer
+ is
+ Result : Integer := 0;
+ begin
+ for I in Item'Range loop
+ if Item (I) then
+ Result := Result + 1;
+ end if;
+ end loop;
+ return Result;
+ end Count;
+
+ function Image
+ (Item : in Token_ID_Set;
+ Desc : in Descriptor;
+ Max_Count : in Integer := Integer'Last;
+ Inverted : in Boolean := False)
+ return String
+ is
+ use Ada.Strings.Unbounded;
+ Result : Unbounded_String;
+ Need_Comma : Boolean := False;
+ Count : Integer := 0;
+
+ function Include (Item : in Boolean) return Boolean
+ is begin
+ if not Inverted then
+ return Item;
+
+ else
+ return not Item;
+ end if;
+ end Include;
+
+ begin
+ for I in Item'Range loop
+ if Include (Item (I)) then
+ if Need_Comma then
+ Result := Result & ", ";
+ end if;
+ Result := Result & Image (I, Desc);
+ Need_Comma := True;
+ Count := Count + 1;
+ if Count = Max_Count then
+ return To_String (Result);
+ end if;
+ end if;
+ end loop;
+ return To_String (Result);
+ end Image;
+
+ function Image (Item : in Production_ID) return String
+ is begin
+ return '(' & Trimmed_Image (Item.LHS) & ',' & Natural'Image (Item.RHS) &
')';
+ end Image;
+
+ function Trimmed_Image (Item : in Production_ID) return String
+ is begin
+ return Trimmed_Image (Item.LHS) & '.' & Trimmed_Image (Item.RHS);
+ end Trimmed_Image;
+
+ function Padded_Image (Item : in Production_ID; Width : in Integer) return
String
+ is
+ use Ada.Strings.Fixed;
+ begin
+ return Result : String (1 .. Width) do
+ Move (Trimmed_Image (Item), Result, Justify => Ada.Strings.Right);
+ end return;
+ end Padded_Image;
+
+ function To_Vector (Item : in Production_ID_Array) return
Production_ID_Arrays.Vector
+ is begin
+ return Result : Production_ID_Arrays.Vector do
+ for I of Item loop
+ Result.Append (I);
+ end loop;
+ end return;
+ end To_Vector;
+
+ function Slice (Item : in Token_Array_Token_Set; I : in Token_ID) return
Token_ID_Set
+ is
+ Result : Token_ID_Set := (Item'First (2) .. Item'Last (2) => False);
+ begin
+ for J in Result'Range loop
+ Result (J) := Item (I, J);
+ end loop;
+ return Result;
+ end Slice;
+
+ function Any (Item : in Token_Array_Token_Set; I : in Token_ID) return
Boolean
+ is begin
+ for J in Item'Range (2) loop
+ if Item (I, J) then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Any;
+
+ function Any (Item : in Token_Array_Token_Set) return Boolean
+ is begin
+ for I in Item'Range (1) loop
+ for J in Item'Range (2) loop
+ if Item (I, J) then
+ return True;
+ end if;
+ end loop;
+ end loop;
+ return False;
+ end Any;
+
+ procedure Or_Slice (Item : in out Token_Array_Token_Set; I : in Token_ID;
Value : in Token_ID_Set)
+ is begin
+ for J in Item'Range (2) loop
+ Item (I, J) := Item (I, J) or Value (J);
+ end loop;
+ end Or_Slice;
+
+ procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Token_Array_Token_Set)
+ is
+ use Ada.Text_IO;
+ Paren_Done : Boolean := False;
+ begin
+ if not Any (Item) then
+ Put_Line ("(others => (others => False))");
+ else
+ Put ("(");
+ for I in Item'Range (1) loop
+ if Any (Item, I) then
+ Put_Line (" " & Image (I, Descriptor) & " =>");
+ Put (" (");
+ Paren_Done := False;
+ for J in Item'Range (2) loop
+ if Item (I, J) then
+ if Paren_Done then
+ Put_Line (" |");
+ Put (" " & Image (J, Descriptor));
+ else
+ Paren_Done := True;
+ Put (Image (J, Descriptor));
+ end if;
+ end if;
+ end loop;
+ if Paren_Done then
+ Put_Line (" => True,");
+ Put_Line (" others => False)");
+ else
+ Put_Line (" others => False),");
+ end if;
+ end if;
+ end loop;
+ Put_Line ((if Paren_Done then " " else "") & "others => (others =>
False))");
+ end if;
+ end Put;
+
+ function Error_Message
+ (File_Name : in String;
+ Line : in Line_Number_Type;
+ Column : in Ada.Text_IO.Count;
+ Message : in String)
+ return String
+ is begin
+ return File_Name & ":" &
+ Trimmed_Image (if Line = Invalid_Line_Number then Integer'(0) else
Integer (Line)) & ":" &
+ Trimmed_Image (Integer (Column)) & ": " &
+ Message;
+ end Error_Message;
+
+ function Image (Item : in Buffer_Region) return String
+ is begin
+ return "(" & Trimmed_Image (Integer (Item.First)) & " ." &
Buffer_Pos'Image (Item.Last) & ")";
+ end Image;
+
+ function "and" (Left, Right : in Buffer_Region) return Buffer_Region
+ is begin
+ return (Buffer_Pos'Min (Left.First, Right.First), Buffer_Pos'Max
(Left.Last, Right.Last));
+ end "and";
+
+ function Image
+ (Item : in Base_Token;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is
+ ID_Image : constant String := WisiToken.Image (Item.ID, Descriptor);
+ begin
+ if Item.Char_Region = Null_Buffer_Region then
+ return "(" & ID_Image & ")";
+
+ else
+ return "(" & ID_Image & ", " & Image (Item.Char_Region) & ")";
+ end if;
+ end Image;
+
+ function Image
+ (Token : in Base_Token_Index;
+ Terminals : in Base_Token_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is begin
+ if Token = Invalid_Token_Index then
+ return "<invalid_token_index>";
+ else
+ return Token_Index'Image (Token) & ":" & Image (Terminals (Token),
Descriptor);
+ end if;
+ end Image;
+
+ function Image
+ (Item : in Recover_Token;
+ Descriptor : in WisiToken.Descriptor)
+ return String
+ is begin
+ return "(" & Image (Item.ID, Descriptor) &
+ (if Item.Byte_Region = Null_Buffer_Region then "" else ", " & Image
(Item.Byte_Region)) & ")";
+ end Image;
+
+end WisiToken;
diff --git a/wisitoken.ads b/wisitoken.ads
new file mode 100644
index 0000000..734ff4a
--- /dev/null
+++ b/wisitoken.ads
@@ -0,0 +1,432 @@
+-- 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 Stephe Leake
+-- Copyright (C) 1999 FlightSafety International and Ted Dennison
+--
+-- 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;
diff --git a/wisitoken.gpr b/wisitoken.gpr
new file mode 100644
index 0000000..82b23de
--- /dev/null
+++ b/wisitoken.gpr
@@ -0,0 +1,56 @@
+-- For the wisi ELPA package; provide WisiToken to other ELPA packages
+-- SAL sources are also in the wisi package.
+with "gnatcoll";
+with "standard_common";
+project WisiToken is
+
+ for Source_Dirs use (".");
+
+ for Languages use ("Ada", "C");
+
+ case Standard_Common.Profile is
+ when "On" =>
+ for Object_Dir use "obj_pro";
+ for Exec_Dir use "exec_pro";
+
+ when "Off" =>
+ for Object_Dir use "obj";
+ for Exec_Dir use ".";
+ end case;
+
+ package Compiler is
+ case Standard_Common.Build is
+ when "Debug" =>
+ for Default_Switches ("Ada") use
+ Standard_Common.Compiler.Debug_Switches &
+ Standard_Common.Compiler.Style_Checks;
+
+ when "Normal" =>
+ for Default_Switches ("Ada") use
+ Standard_Common.Compiler.Release_Switches &
+ Standard_Common.Compiler.Style_Checks;
+ end case;
+
+ end Compiler;
+
+ package Builder is
+ for Switches ("Ada") use Standard_Common.Builder'Default_Switches
("Ada");
+
+ -- We use ".exe" extension even on non-Windows, to simplify the
makefiles.
+ for Executable_Suffix use ".exe";
+
+ case Standard_Common.Profile is
+ when "On" =>
+ for Global_Compilation_Switches ("Ada") use ("-pg");
+
+ when "Off" =>
+ null;
+ end case;
+
+ end Builder;
+
+ package Binder is
+ for Default_Switches ("Ada") use Standard_Common.Binder'Default_Switches
("Ada");
+ end Binder;
+
+end WisiToken;
diff --git a/wisitoken_grammar_actions.adb b/wisitoken_grammar_actions.adb
new file mode 100644
index 0000000..c9970d9
--- /dev/null
+++ b/wisitoken_grammar_actions.adb
@@ -0,0 +1,105 @@
+-- generated parser support file.
+-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
+--
+
+-- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+--
+-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
+--
+-- This file is part of GNU Emacs.
+--
+-- GNU Emacs is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- GNU Emacs is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+with WisiToken_Grammar_Runtime; use WisiToken_Grammar_Runtime;
+
+package body Wisitoken_Grammar_Actions is
+
+ procedure declaration_0
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Add_Declaration (User_Data, Tree, Tokens);
+ end declaration_0;
+
+ procedure declaration_1
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Add_Declaration (User_Data, Tree, Tokens);
+ end declaration_1;
+
+ procedure declaration_2
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Add_Declaration (User_Data, Tree, Tokens);
+ end declaration_2;
+
+ procedure declaration_3
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Add_Declaration (User_Data, Tree, Tokens);
+ end declaration_3;
+
+ procedure declaration_4
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Start_If (User_Data, Tree, Tokens);
+ end declaration_4;
+
+ procedure declaration_5
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Tree, Nonterm, Tokens);
+ begin
+ End_If (User_Data);
+ end declaration_5;
+
+ procedure nonterminal_0
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ pragma Unreferenced (Nonterm);
+ begin
+ Add_Nonterminal (User_Data, Tree, Tokens);
+ end nonterminal_0;
+
+end Wisitoken_Grammar_Actions;
diff --git a/wisitoken_grammar_actions.ads b/wisitoken_grammar_actions.ads
new file mode 100644
index 0000000..25b68e8
--- /dev/null
+++ b/wisitoken_grammar_actions.ads
@@ -0,0 +1,168 @@
+-- generated parser support file.
+-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c PROCESS
wisitoken_grammar.wy
+--
+
+-- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+--
+-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
+--
+-- This file is part of GNU Emacs.
+--
+-- GNU Emacs is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- GNU Emacs is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+with WisiToken.Syntax_Trees;
+package Wisitoken_Grammar_Actions is
+
+ Descriptor : aliased WisiToken.Descriptor :=
+ (First_Terminal => 3,
+ Last_Terminal => 25,
+ First_Nonterminal => 26,
+ Last_Nonterminal => 37,
+ EOF_ID => 25,
+ Accept_ID => 26,
+ Case_Insensitive => False,
+ New_Line_ID => 1,
+ Comment_ID => 2,
+ Left_Paren_ID => 2147483647,
+ Right_Paren_ID => 2147483647,
+ String_1_ID => 24,
+ String_2_ID => 23,
+ Embedded_Quote_Escape_Doubled => False,
+ Image =>
+ (new String'("WHITESPACE"),
+ new String'("NEW_LINE"),
+ new String'("COMMENT"),
+ new String'("CODE"),
+ new String'("END"),
+ new String'("IF"),
+ new String'("KEYWORD"),
+ new String'("NON_GRAMMAR"),
+ new String'("TOKEN"),
+ new String'("RAW_CODE"),
+ new String'("REGEXP"),
+ new String'("ACTION"),
+ new String'("BAR"),
+ new String'("COLON"),
+ new String'("COMMA"),
+ new String'("EQUAL"),
+ new String'("GREATER"),
+ new String'("LESS"),
+ new String'("PERCENT"),
+ new String'("SEMICOLON"),
+ new String'("SLASH"),
+ new String'("NUMERIC_LITERAL"),
+ new String'("IDENTIFIER"),
+ new String'("STRING_LITERAL"),
+ new String'("STRING_LITERAL_CASE_INS"),
+ new String'("Wisi_EOI"),
+ new String'("wisitoken_accept"),
+ new String'("declaration"),
+ new String'("token_keyword_non_grammar"),
+ new String'("identifier_list"),
+ new String'("declaration_item_list"),
+ new String'("declaration_item"),
+ new String'("nonterminal"),
+ new String'("rhs_list"),
+ new String'("rhs"),
+ new String'("token_list"),
+ new String'("compilation_unit"),
+ new String'("compilation_unit_list")),
+ Terminal_Image_Width => 23,
+ Image_Width => 25,
+ Last_Lookahead => 26);
+
+ type Token_Enum_ID is
+ (WHITESPACE_ID,
+ NEW_LINE_ID,
+ COMMENT_ID,
+ CODE_ID,
+ END_ID,
+ IF_ID,
+ KEYWORD_ID,
+ NON_GRAMMAR_ID,
+ TOKEN_ID,
+ RAW_CODE_ID,
+ REGEXP_ID,
+ ACTION_ID,
+ BAR_ID,
+ COLON_ID,
+ COMMA_ID,
+ EQUAL_ID,
+ GREATER_ID,
+ LESS_ID,
+ PERCENT_ID,
+ SEMICOLON_ID,
+ SLASH_ID,
+ NUMERIC_LITERAL_ID,
+ IDENTIFIER_ID,
+ STRING_LITERAL_ID,
+ STRING_LITERAL_CASE_INS_ID,
+ Wisi_EOI_ID,
+ wisitoken_accept_ID,
+ declaration_ID,
+ token_keyword_non_grammar_ID,
+ identifier_list_ID,
+ declaration_item_list_ID,
+ declaration_item_ID,
+ nonterminal_ID,
+ rhs_list_ID,
+ rhs_ID,
+ token_list_ID,
+ compilation_unit_ID,
+ compilation_unit_list_ID);
+
+ type Token_Enum_ID_Array is array (Positive range <>) of Token_Enum_ID;
+ use all type WisiToken.Token_ID;
+ function "+" (Item : in Token_Enum_ID) return WisiToken.Token_ID
+ is (WisiToken.Token_ID'First + Token_Enum_ID'Pos (Item));
+ function To_Token_Enum (Item : in WisiToken.Token_ID) return Token_Enum_ID
+ is (Token_Enum_ID'Val (Item - WisiToken.Token_ID'First));
+ function "-" (Item : in WisiToken.Token_ID) return Token_Enum_ID renames
To_Token_Enum;
+
+ procedure declaration_0
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure declaration_1
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure declaration_2
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure declaration_3
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure declaration_4
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure declaration_5
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+ procedure nonterminal_0
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+end Wisitoken_Grammar_Actions;
diff --git a/wisitoken_grammar_main.adb b/wisitoken_grammar_main.adb
new file mode 100644
index 0000000..5470e30
--- /dev/null
+++ b/wisitoken_grammar_main.adb
@@ -0,0 +1,305 @@
+-- generated parser support file.
+-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
+--
+
+-- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+--
+-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
+--
+-- This file is part of GNU Emacs.
+--
+-- GNU Emacs is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- GNU Emacs is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+with Wisitoken_Grammar_Actions; use Wisitoken_Grammar_Actions;
+with WisiToken.Lexer.re2c;
+with wisitoken_grammar_re2c_c;
+package body Wisitoken_Grammar_Main is
+
+ package Lexer is new WisiToken.Lexer.re2c
+ (wisitoken_grammar_re2c_c.New_Lexer,
+ wisitoken_grammar_re2c_c.Free_Lexer,
+ wisitoken_grammar_re2c_c.Reset_Lexer,
+ wisitoken_grammar_re2c_c.Next_Token);
+
+ procedure Create_Parser
+ (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;
+ Trace : not null access WisiToken.Trace'Class;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access)
+ is
+ use WisiToken.Parse.LR;
+ Table : constant Parse_Table_Ptr := new Parse_Table
+ (State_First => 0,
+ State_Last => 61,
+ First_Terminal => 3,
+ Last_Terminal => 25,
+ First_Nonterminal => 26,
+ Last_Nonterminal => 37);
+ begin
+ declare
+ procedure Subr_1
+ is begin
+ Add_Action (Table.States (0), 18, 1);
+ Add_Action (Table.States (0), 22, 2);
+ Add_Error (Table.States (0));
+ Add_Goto (Table.States (0), 27, 3);
+ Add_Goto (Table.States (0), 32, 4);
+ Add_Goto (Table.States (0), 36, 5);
+ Add_Goto (Table.States (0), 37, 6);
+ 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);
+ Add_Action (Table.States (1), 6, 10);
+ Add_Action (Table.States (1), 7, 11);
+ Add_Action (Table.States (1), 8, 12);
+ Add_Action (Table.States (1), 22, 13);
+ Add_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);
+ Add_Error (Table.States (6));
+ Add_Goto (Table.States (6), 27, 3);
+ Add_Goto (Table.States (6), 32, 4);
+ Add_Goto (Table.States (6), 36, 16);
+ Add_Action (Table.States (7), 22, 17);
+ Add_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);
+ Add_Action (Table.States (13), 15, 26);
+ Add_Action (Table.States (13), 18, Reduce, (27, 3), 2,
declaration_3'Access, null);
+ Add_Action (Table.States (13), 20, 27);
+ Add_Action (Table.States (13), 21, 28);
+ Add_Action (Table.States (13), 22, 29, (27, 3), 2,
declaration_3'Access, null);
+ Add_Action (Table.States (13), 23, 30);
+ Add_Action (Table.States (13), 24, 31);
+ Add_Action (Table.States (13), 25, Reduce, (27, 3), 2,
declaration_3'Access, null);
+ Add_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);
+ Add_Action (Table.States (15), 22, 35);
+ Add_Error (Table.States (15));
+ Add_Goto (Table.States (15), 33, 36);
+ Add_Goto (Table.States (15), 34, 37);
+ Add_Goto (Table.States (15), 35, 38);
+ 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);
+ Add_Action (Table.States (32), 15, 26);
+ Add_Action (Table.States (32), 18, Reduce, (27, 2), 3,
declaration_2'Access, null);
+ Add_Action (Table.States (32), 20, 27);
+ Add_Action (Table.States (32), 21, 28);
+ Add_Action (Table.States (32), 22, 29, (27, 2), 3,
declaration_2'Access, null);
+ Add_Action (Table.States (32), 23, 30);
+ Add_Action (Table.States (32), 24, 31);
+ Add_Action (Table.States (32), 25, Reduce, (27, 2), 3,
declaration_2'Access, null);
+ Add_Error (Table.States (32));
+ Add_Goto (Table.States (32), 31, 44);
+ 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);
+ Add_Action (Table.States (34), 15, 26);
+ Add_Action (Table.States (34), 20, 27);
+ Add_Action (Table.States (34), 21, 28);
+ Add_Action (Table.States (34), 22, 29);
+ Add_Action (Table.States (34), 23, 30);
+ Add_Action (Table.States (34), 24, 31);
+ Add_Error (Table.States (34));
+ Add_Goto (Table.States (34), 30, 45);
+ Add_Goto (Table.States (34), 31, 33);
+ 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);
+ Add_Action (Table.States (45), 15, 26);
+ Add_Action (Table.States (45), 18, Reduce, (27, 0), 4,
declaration_0'Access, null);
+ Add_Action (Table.States (45), 20, 27);
+ Add_Action (Table.States (45), 21, 28);
+ Add_Action (Table.States (45), 22, 29, (27, 0), 4,
declaration_0'Access, null);
+ Add_Action (Table.States (45), 23, 30);
+ Add_Action (Table.States (45), 24, 31);
+ Add_Action (Table.States (45), 25, Reduce, (27, 0), 4,
declaration_0'Access, null);
+ Add_Error (Table.States (45));
+ Add_Goto (Table.States (45), 31, 44);
+ 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);
+ Add_Action (Table.States (46), 22, 35);
+ Add_Error (Table.States (46));
+ Add_Goto (Table.States (46), 34, 54);
+ Add_Goto (Table.States (46), 35, 38);
+ 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;
+ end;
+
+ WisiToken.Parse.LR.Parser_No_Recover.New_Parser
+ (Parser,
+ Trace,
+ Lexer.New_Lexer (Trace),
+ Table,
+ User_Data,
+ Max_Parallel => 15,
+ Terminate_Same_State => True);
+ end Create_Parser;
+end Wisitoken_Grammar_Main;
diff --git a/wisitoken_grammar_main.ads b/wisitoken_grammar_main.ads
new file mode 100644
index 0000000..7f28437
--- /dev/null
+++ b/wisitoken_grammar_main.ads
@@ -0,0 +1,33 @@
+-- generated parser support file.
+-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c PROCESS
wisitoken_grammar.wy
+--
+
+-- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+--
+-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
+--
+-- This file is part of GNU Emacs.
+--
+-- GNU Emacs is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- GNU Emacs is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+with WisiToken.Syntax_Trees;
+with WisiToken.Parse.LR.Parser_No_Recover;
+package Wisitoken_Grammar_Main is
+
+ procedure Create_Parser
+ (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;
+ Trace : not null access WisiToken.Trace'Class;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access);
+
+end Wisitoken_Grammar_Main;
diff --git a/wisitoken_grammar_re2c.c b/wisitoken_grammar_re2c.c
new file mode 100644
index 0000000..b45ab3a
--- /dev/null
+++ b/wisitoken_grammar_re2c.c
@@ -0,0 +1,3025 @@
+/* Generated by re2c 1.0.3 */
+#line 1 "../wisitoken_grammar.re2c"
+// generated parser support file. -*- mode: C -*-
+// command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
+//
+
+// Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+//
+// Author: Stephen Leake <stephe-leake@stephe-leake.org>
+//
+// This file is part of GNU Emacs.
+//
+// GNU Emacs is free software: you can redistribute it and/or modify
+// it under the terms of the GNU General Public License as published by
+// the Free Software Foundation, either version 3 of the License, or
+// (at your option) any later version.
+//
+// GNU Emacs is distributed in the hope that it will be useful,
+// but WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU General Public License for more details.
+//
+// You should have received a copy of the GNU General Public License
+// along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+typedef struct wisi_lexer
+{
+ unsigned char* buffer; // input text, in utf-8 encoding
+ unsigned char* buffer_last; // last byte in buffer
+ unsigned char* cursor; // current byte
+ unsigned char* byte_token_start; // byte position at start of current token
+ size_t char_pos; // character position of current character
+ size_t char_token_start; // character position at start of current
token
+ int line; // 1 indexed
+ 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
+ unsigned char* context; // saved cursor
+ size_t context_pos; // saved character position
+ int context_line; // saved line
+ int verbosity;
+
+} wisi_lexer;
+
+#define YYCTYPE unsigned char
+
+#define NO_ERROR 0
+#define ERROR_unrecognized_character 1
+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;
+ return result;
+}
+
+void
+wisitoken_grammar_free_lexer(wisi_lexer** lexer)
+{
+ free(*lexer);
+ *lexer = 0;
+}
+
+void
+wisitoken_grammar_reset_lexer(wisi_lexer* lexer)
+{
+ lexer->cursor = lexer->buffer;
+ lexer->char_pos = 1;
+ lexer->line = (*lexer->cursor == 0x0A) ? 2 : 1;
+}
+
+static void debug(wisi_lexer* lexer, int state, unsigned char ch)
+{
+ if (lexer->verbosity > 0)
+ {
+ if (ch < ' ')
+ printf ("lexer: %d, 0x%x\n", state, ch);
+ else
+ printf ("lexer: %d, '%c' 0x%x\n", state, ch, ch);
+ }
+}
+#define YYDEBUG(state, ch) debug(lexer, state, ch)
+#define YYCURSOR lexer->cursor
+
+#define YYPEEK() (lexer->cursor <= lexer->buffer_last) ? *lexer->cursor : 4
+
+#define DO_COUNT ((*lexer->cursor & 0xC0) != 0xC0) && (*lexer->cursor != 0x0D)
+
+static void skip(wisi_lexer* lexer)
+{
+ if (lexer->cursor <= lexer->buffer_last) ++lexer->cursor;
+ if (lexer->cursor <= lexer->buffer_last)
+ if (DO_COUNT) ++lexer->char_pos;
+ 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
+#define YYRESTORE() lexer->cursor = lexer->marker; lexer->char_pos =
lexer->marker_pos;lexer->line = lexer->marker_line
+#define YYBACKUPCTX() lexer->context = lexer->cursor; lexer->context_pos =
lexer->char_pos;lexer->context_line = lexer->line
+#define YYRESTORECTX() lexer->cursor = lexer->context; lexer->char_pos =
lexer->context_pos;lexer->line = lexer->context_line
+
+static void skip_to(wisi_lexer* lexer, char* target)
+{
+ int i;
+
+ while (lexer->cursor <= lexer->buffer_last)
+ {
+ if (*lexer->cursor == target[0])
+ {
+ i = 0;
+ do
+ i++;
+ while (0 != target[i] &&
+ lexer->cursor + i <= lexer->buffer_last &&
+ *(lexer->cursor + i) == target[i]);
+
+ if (0 == target[i])
+ {
+ for (i = 0; 0 != target[i]; i++)
+ skip(lexer);
+ break;
+ }
+ }
+ skip(lexer);
+ };
+}
+
+int wisitoken_grammar_next_token
+ (wisi_lexer* lexer,
+ int* id,
+ size_t* byte_position,
+ size_t* byte_length,
+ size_t* char_position,
+ size_t* char_length,
+ int* line_start)
+{
+ int status = NO_ERROR;
+ *id = -1;
+ if (lexer->cursor > lexer->buffer_last)
+ {
+ *id = 25;
+ *byte_position = lexer->buffer_last - lexer->buffer + 1;
+ *byte_length = 0;
+ *char_position = lexer->char_token_start;
+ *char_length = 0;
+ *line_start = lexer->line;
+ return status;
+ }
+
+ 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;
+ if (*lexer->cursor == 0x0A)
+ lexer->line_token_start = lexer->line-1;
+ else
+ lexer->line_token_start = lexer->line;
+
+ while (*id == -1 && status == 0)
+ {
+
+#line 174 "../wisitoken_grammar_re2c.c"
+{
+ YYCTYPE yych;
+ unsigned int yyaccept = 0;
+ YYDEBUG(0, *YYCURSOR);
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x04: goto yy4;
+ case '\t':
+ case ' ': goto yy6;
+ case '\n': goto yy8;
+ case '\r': goto yy10;
+ case '"': goto yy11;
+ case '%': goto yy12;
+ case '\'': goto yy14;
+ case ',': goto yy15;
+ case '/': goto yy17;
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9': goto yy19;
+ case ':': goto yy22;
+ case ';': goto yy24;
+ case '<': goto yy26;
+ case '=': goto yy28;
+ case '>': goto yy30;
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case 'a':
+ case 'b':
+ case 'd':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'j':
+ case 'l':
+ case 'm':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z': goto yy32;
+ case 'c': goto yy35;
+ case 'e': goto yy36;
+ case 'i': goto yy37;
+ case 'k': goto yy38;
+ case 'n': goto yy39;
+ case 't': goto yy40;
+ case '|': goto yy41;
+ default: goto yy2;
+ }
+yy2:
+ YYDEBUG(2, YYPEEK ());
+ YYSKIP ();
+yy3:
+ YYDEBUG(3, YYPEEK ());
+#line 230 "../wisitoken_grammar.re2c"
+ {status = ERROR_unrecognized_character; continue;}
+#line 268 "../wisitoken_grammar_re2c.c"
+yy4:
+ YYDEBUG(4, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(5, YYPEEK ());
+#line 228 "../wisitoken_grammar.re2c"
+ {*id = 25; continue;}
+#line 275 "../wisitoken_grammar_re2c.c"
+yy6:
+ YYDEBUG(6, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(7, YYPEEK ());
+#line 197 "../wisitoken_grammar.re2c"
+ { lexer->byte_token_start = lexer->cursor;
+ lexer->char_token_start = lexer->char_pos;
+ if (*lexer->cursor == 0x0A)
+ lexer->line_token_start = lexer->line-1;
+ else
+ lexer->line_token_start = lexer->line;
+ continue; }
+#line 288 "../wisitoken_grammar_re2c.c"
+yy8:
+ YYDEBUG(8, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(9, YYPEEK ());
+#line 204 "../wisitoken_grammar.re2c"
+ {*id = 1; continue;}
+#line 295 "../wisitoken_grammar_re2c.c"
+yy10:
+ YYDEBUG(10, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '\n': goto yy8;
+ default: goto yy3;
+ }
+yy11:
+ YYDEBUG(11, YYPEEK ());
+ yyaccept = 0;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case ' ':
+ case '!':
+ case '"':
+ case '#':
+ case '$':
+ case '%':
+ case '&':
+ case '\'':
+ case '(':
+ case ')':
+ case '*':
+ case '+':
+ case ',':
+ case '-':
+ case '.':
+ case '/':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case ':':
+ case ';':
+ case '<':
+ case '=':
+ case '>':
+ case '?':
+ case '@':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '[':
+ case '\\':
+ case ']':
+ case '^':
+ case '_':
+ case '`':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z':
+ case '{':
+ case '|':
+ case '}':
+ case '~':
+ case 0x7F:
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF:
+ case 0xE0:
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF:
+ case 0xF0:
+ case 0xF1:
+ case 0xF2:
+ case 0xF3:
+ case 0xF4: goto yy44;
+ default: goto yy3;
+ }
+yy12:
+ YYDEBUG(12, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '(': goto yy54;
+ case '[': goto yy56;
+ case '{': goto yy58;
+ default: goto yy13;
+ }
+yy13:
+ YYDEBUG(13, YYPEEK ());
+#line 221 "../wisitoken_grammar.re2c"
+ {*id = 18; continue;}
+#line 474 "../wisitoken_grammar_re2c.c"
+yy14:
+ YYDEBUG(14, YYPEEK ());
+ yyaccept = 0;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case ' ':
+ case '!':
+ case '"':
+ case '#':
+ case '$':
+ case '%':
+ case '&':
+ case '\'':
+ case '(':
+ case ')':
+ case '*':
+ case '+':
+ case ',':
+ case '-':
+ case '.':
+ case '/':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case ':':
+ case ';':
+ case '<':
+ case '=':
+ case '>':
+ case '?':
+ case '@':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '[':
+ case '\\':
+ case ']':
+ case '^':
+ case '_':
+ case '`':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z':
+ case '{':
+ case '|':
+ case '}':
+ case '~':
+ case 0x7F:
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF:
+ case 0xE0:
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF:
+ case 0xF0:
+ case 0xF1:
+ case 0xF2:
+ case 0xF3:
+ case 0xF4: goto yy61;
+ default: goto yy3;
+ }
+yy15:
+ YYDEBUG(15, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(16, YYPEEK ());
+#line 217 "../wisitoken_grammar.re2c"
+ {*id = 14; continue;}
+#line 637 "../wisitoken_grammar_re2c.c"
+yy17:
+ YYDEBUG(17, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(18, YYPEEK ());
+#line 223 "../wisitoken_grammar.re2c"
+ {*id = 20; continue;}
+#line 644 "../wisitoken_grammar_re2c.c"
+yy19:
+ YYDEBUG(19, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ YYDEBUG(20, YYPEEK ());
+ switch (yych) {
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case '_': goto yy19;
+ default: goto yy21;
+ }
+yy21:
+ YYDEBUG(21, YYPEEK ());
+#line 224 "../wisitoken_grammar.re2c"
+ {*id = 21; continue;}
+#line 668 "../wisitoken_grammar_re2c.c"
+yy22:
+ YYDEBUG(22, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(23, YYPEEK ());
+#line 216 "../wisitoken_grammar.re2c"
+ {*id = 13; continue;}
+#line 675 "../wisitoken_grammar_re2c.c"
+yy24:
+ YYDEBUG(24, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case ';': goto yy70;
+ default: goto yy25;
+ }
+yy25:
+ YYDEBUG(25, YYPEEK ());
+#line 222 "../wisitoken_grammar.re2c"
+ {*id = 19; continue;}
+#line 688 "../wisitoken_grammar_re2c.c"
+yy26:
+ YYDEBUG(26, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(27, YYPEEK ());
+#line 220 "../wisitoken_grammar.re2c"
+ {*id = 17; continue;}
+#line 695 "../wisitoken_grammar_re2c.c"
+yy28:
+ YYDEBUG(28, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(29, YYPEEK ());
+#line 218 "../wisitoken_grammar.re2c"
+ {*id = 15; continue;}
+#line 702 "../wisitoken_grammar_re2c.c"
+yy30:
+ YYDEBUG(30, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(31, YYPEEK ());
+#line 219 "../wisitoken_grammar.re2c"
+ {*id = 16; continue;}
+#line 709 "../wisitoken_grammar_re2c.c"
+yy32:
+ YYDEBUG(32, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+yy33:
+ YYDEBUG(33, YYPEEK ());
+ switch (yych) {
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '_':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z': goto yy32;
+ default: goto yy34;
+ }
+yy34:
+ YYDEBUG(34, YYPEEK ());
+#line 225 "../wisitoken_grammar.re2c"
+ {*id = 22; continue;}
+#line 787 "../wisitoken_grammar_re2c.c"
+yy35:
+ YYDEBUG(35, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'o': goto yy73;
+ default: goto yy33;
+ }
+yy36:
+ YYDEBUG(36, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'n': goto yy74;
+ default: goto yy33;
+ }
+yy37:
+ YYDEBUG(37, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'f': goto yy75;
+ default: goto yy33;
+ }
+yy38:
+ YYDEBUG(38, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'e': goto yy77;
+ default: goto yy33;
+ }
+yy39:
+ YYDEBUG(39, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'o': goto yy78;
+ default: goto yy33;
+ }
+yy40:
+ YYDEBUG(40, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'o': goto yy79;
+ default: goto yy33;
+ }
+yy41:
+ YYDEBUG(41, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(42, YYPEEK ());
+#line 215 "../wisitoken_grammar.re2c"
+ {*id = 12; continue;}
+#line 842 "../wisitoken_grammar_re2c.c"
+yy43:
+ YYDEBUG(43, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+yy44:
+ YYDEBUG(44, YYPEEK ());
+ switch (yych) {
+ case ' ':
+ case '!':
+ case '#':
+ case '$':
+ case '%':
+ case '&':
+ case '\'':
+ case '(':
+ case ')':
+ case '*':
+ case '+':
+ case ',':
+ case '-':
+ case '.':
+ case '/':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case ':':
+ case ';':
+ case '<':
+ case '=':
+ case '>':
+ case '?':
+ case '@':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '[':
+ case '\\':
+ case ']':
+ case '^':
+ case '_':
+ case '`':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z':
+ case '{':
+ case '|':
+ case '}':
+ case '~':
+ case 0x7F: goto yy43;
+ case '"': goto yy46;
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF: goto yy48;
+ case 0xE0: goto yy49;
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF: goto yy50;
+ case 0xF0: goto yy51;
+ case 0xF1:
+ case 0xF2:
+ case 0xF3: goto yy52;
+ case 0xF4: goto yy53;
+ default: goto yy45;
+ }
+yy45:
+ YYDEBUG(45, YYPEEK ());
+ YYRESTORE ();
+ switch (yyaccept) {
+ case 0: goto yy3;
+ case 1: goto yy47;
+ case 2: goto yy63;
+ default: goto yy72;
+ }
+yy46:
+ YYDEBUG(46, YYPEEK ());
+ yyaccept = 1;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '"': goto yy43;
+ default: goto yy47;
+ }
+yy47:
+ YYDEBUG(47, YYPEEK ());
+#line 226 "../wisitoken_grammar.re2c"
+ {*id = 23; continue;}
+#line 1022 "../wisitoken_grammar_re2c.c"
+yy48:
+ YYDEBUG(48, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy43;
+ default: goto yy45;
+ }
+yy49:
+ YYDEBUG(49, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy48;
+ default: goto yy45;
+ }
+yy50:
+ YYDEBUG(50, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy48;
+ default: goto yy45;
+ }
+yy51:
+ YYDEBUG(51, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy50;
+ default: goto yy45;
+ }
+yy52:
+ YYDEBUG(52, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy50;
+ default: goto yy45;
+ }
+yy53:
+ YYDEBUG(53, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F: goto yy50;
+ default: goto yy45;
+ }
+yy54:
+ YYDEBUG(54, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(55, YYPEEK ());
+#line 214 "../wisitoken_grammar.re2c"
+ {*id = 11; skip_to(lexer, ")%"); continue;}
+#line 1359 "../wisitoken_grammar_re2c.c"
+yy56:
+ YYDEBUG(56, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(57, YYPEEK ());
+#line 213 "../wisitoken_grammar.re2c"
+ {*id = 10; skip_to(lexer, "]%"); continue;}
+#line 1366 "../wisitoken_grammar_re2c.c"
+yy58:
+ YYDEBUG(58, YYPEEK ());
+ YYSKIP ();
+ YYDEBUG(59, YYPEEK ());
+#line 212 "../wisitoken_grammar.re2c"
+ {*id = 9; skip_to(lexer, "}%"); continue;}
+#line 1373 "../wisitoken_grammar_re2c.c"
+yy60:
+ YYDEBUG(60, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+yy61:
+ YYDEBUG(61, YYPEEK ());
+ switch (yych) {
+ case ' ':
+ case '!':
+ case '"':
+ case '#':
+ case '$':
+ case '%':
+ case '&':
+ case '(':
+ case ')':
+ case '*':
+ case '+':
+ case ',':
+ case '-':
+ case '.':
+ case '/':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case ':':
+ case ';':
+ case '<':
+ case '=':
+ case '>':
+ case '?':
+ case '@':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '[':
+ case '\\':
+ case ']':
+ case '^':
+ case '_':
+ case '`':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z':
+ case '{':
+ case '|':
+ case '}':
+ case '~':
+ case 0x7F: goto yy60;
+ case '\'': goto yy62;
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF: goto yy64;
+ case 0xE0: goto yy65;
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF: goto yy66;
+ case 0xF0: goto yy67;
+ case 0xF1:
+ case 0xF2:
+ case 0xF3: goto yy68;
+ case 0xF4: goto yy69;
+ default: goto yy45;
+ }
+yy62:
+ YYDEBUG(62, YYPEEK ());
+ yyaccept = 2;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '\'': goto yy60;
+ default: goto yy63;
+ }
+yy63:
+ YYDEBUG(63, YYPEEK ());
+#line 227 "../wisitoken_grammar.re2c"
+ {*id = 24; continue;}
+#line 1544 "../wisitoken_grammar_re2c.c"
+yy64:
+ YYDEBUG(64, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy60;
+ default: goto yy45;
+ }
+yy65:
+ YYDEBUG(65, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy64;
+ default: goto yy45;
+ }
+yy66:
+ YYDEBUG(66, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy64;
+ default: goto yy45;
+ }
+yy67:
+ YYDEBUG(67, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy66;
+ default: goto yy45;
+ }
+yy68:
+ YYDEBUG(68, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy66;
+ default: goto yy45;
+ }
+yy69:
+ YYDEBUG(69, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F: goto yy66;
+ default: goto yy45;
+ }
+yy70:
+ YYDEBUG(70, YYPEEK ());
+ yyaccept = 3;
+ YYSKIP ();
+ YYBACKUP ();
+ yych = YYPEEK ();
+ YYDEBUG(71, YYPEEK ());
+ switch (yych) {
+ case 0x00:
+ case 0x01:
+ case 0x02:
+ case 0x03:
+ case 0x05:
+ case 0x06:
+ case 0x07:
+ case 0x08:
+ case '\t':
+ case '\v':
+ case '\f':
+ case '\r':
+ case 0x0E:
+ case 0x0F:
+ case 0x10:
+ case 0x11:
+ case 0x12:
+ case 0x13:
+ case 0x14:
+ case 0x15:
+ case 0x16:
+ case 0x17:
+ case 0x18:
+ case 0x19:
+ case 0x1A:
+ case 0x1B:
+ case 0x1C:
+ case 0x1D:
+ case 0x1E:
+ case 0x1F:
+ case ' ':
+ case '!':
+ case '"':
+ case '#':
+ case '$':
+ case '%':
+ case '&':
+ case '\'':
+ case '(':
+ case ')':
+ case '*':
+ case '+':
+ case ',':
+ case '-':
+ case '.':
+ case '/':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case ':':
+ case ';':
+ case '<':
+ case '=':
+ case '>':
+ case '?':
+ case '@':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '[':
+ case '\\':
+ case ']':
+ case '^':
+ case '_':
+ case '`':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z':
+ case '{':
+ case '|':
+ case '}':
+ case '~':
+ case 0x7F: goto yy70;
+ case 0xC2:
+ case 0xC3:
+ case 0xC4:
+ case 0xC5:
+ case 0xC6:
+ case 0xC7:
+ case 0xC8:
+ case 0xC9:
+ case 0xCA:
+ case 0xCB:
+ case 0xCC:
+ case 0xCD:
+ case 0xCE:
+ case 0xCF:
+ case 0xD0:
+ case 0xD1:
+ case 0xD2:
+ case 0xD3:
+ case 0xD4:
+ case 0xD5:
+ case 0xD6:
+ case 0xD7:
+ case 0xD8:
+ case 0xD9:
+ case 0xDA:
+ case 0xDB:
+ case 0xDC:
+ case 0xDD:
+ case 0xDE:
+ case 0xDF: goto yy80;
+ case 0xE0: goto yy81;
+ case 0xE1:
+ case 0xE2:
+ case 0xE3:
+ case 0xE4:
+ case 0xE5:
+ case 0xE6:
+ case 0xE7:
+ case 0xE8:
+ case 0xE9:
+ case 0xEA:
+ case 0xEB:
+ case 0xEC:
+ case 0xED:
+ case 0xEE:
+ case 0xEF: goto yy82;
+ case 0xF0: goto yy83;
+ case 0xF1:
+ case 0xF2:
+ case 0xF3: goto yy84;
+ case 0xF4: goto yy85;
+ default: goto yy72;
+ }
+yy72:
+ YYDEBUG(72, YYPEEK ());
+#line 205 "../wisitoken_grammar.re2c"
+ {*id = 2; continue;}
+#line 2066 "../wisitoken_grammar_re2c.c"
+yy73:
+ YYDEBUG(73, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'd': goto yy86;
+ default: goto yy33;
+ }
+yy74:
+ YYDEBUG(74, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'd': goto yy87;
+ default: goto yy33;
+ }
+yy75:
+ YYDEBUG(75, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '_':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z': goto yy32;
+ default: goto yy76;
+ }
+yy76:
+ YYDEBUG(76, YYPEEK ());
+#line 208 "../wisitoken_grammar.re2c"
+ {*id = 5; continue;}
+#line 2158 "../wisitoken_grammar_re2c.c"
+yy77:
+ YYDEBUG(77, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'y': goto yy89;
+ default: goto yy33;
+ }
+yy78:
+ YYDEBUG(78, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'n': goto yy90;
+ default: goto yy33;
+ }
+yy79:
+ YYDEBUG(79, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'k': goto yy91;
+ default: goto yy33;
+ }
+yy80:
+ YYDEBUG(80, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy70;
+ default: goto yy45;
+ }
+yy81:
+ YYDEBUG(81, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy80;
+ default: goto yy45;
+ }
+yy82:
+ YYDEBUG(82, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy80;
+ default: goto yy45;
+ }
+yy83:
+ YYDEBUG(83, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy82;
+ default: goto yy45;
+ }
+yy84:
+ YYDEBUG(84, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F:
+ case 0x90:
+ case 0x91:
+ case 0x92:
+ case 0x93:
+ case 0x94:
+ case 0x95:
+ case 0x96:
+ case 0x97:
+ case 0x98:
+ case 0x99:
+ case 0x9A:
+ case 0x9B:
+ case 0x9C:
+ case 0x9D:
+ case 0x9E:
+ case 0x9F:
+ case 0xA0:
+ case 0xA1:
+ case 0xA2:
+ case 0xA3:
+ case 0xA4:
+ case 0xA5:
+ case 0xA6:
+ case 0xA7:
+ case 0xA8:
+ case 0xA9:
+ case 0xAA:
+ case 0xAB:
+ case 0xAC:
+ case 0xAD:
+ case 0xAE:
+ case 0xAF:
+ case 0xB0:
+ case 0xB1:
+ case 0xB2:
+ case 0xB3:
+ case 0xB4:
+ case 0xB5:
+ case 0xB6:
+ case 0xB7:
+ case 0xB8:
+ case 0xB9:
+ case 0xBA:
+ case 0xBB:
+ case 0xBC:
+ case 0xBD:
+ case 0xBE:
+ case 0xBF: goto yy82;
+ default: goto yy45;
+ }
+yy85:
+ YYDEBUG(85, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 0x80:
+ case 0x81:
+ case 0x82:
+ case 0x83:
+ case 0x84:
+ case 0x85:
+ case 0x86:
+ case 0x87:
+ case 0x88:
+ case 0x89:
+ case 0x8A:
+ case 0x8B:
+ case 0x8C:
+ case 0x8D:
+ case 0x8E:
+ case 0x8F: goto yy82;
+ default: goto yy45;
+ }
+yy86:
+ YYDEBUG(86, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'e': goto yy92;
+ default: goto yy33;
+ }
+yy87:
+ YYDEBUG(87, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '_':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z': goto yy32;
+ default: goto yy88;
+ }
+yy88:
+ YYDEBUG(88, YYPEEK ());
+#line 207 "../wisitoken_grammar.re2c"
+ {*id = 4; continue;}
+#line 2596 "../wisitoken_grammar_re2c.c"
+yy89:
+ YYDEBUG(89, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'w': goto yy94;
+ default: goto yy33;
+ }
+yy90:
+ YYDEBUG(90, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '_': goto yy95;
+ default: goto yy33;
+ }
+yy91:
+ YYDEBUG(91, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'e': goto yy96;
+ default: goto yy33;
+ }
+yy92:
+ YYDEBUG(92, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '_':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z': goto yy32;
+ default: goto yy93;
+ }
+yy93:
+ YYDEBUG(93, YYPEEK ());
+#line 206 "../wisitoken_grammar.re2c"
+ {*id = 3; continue;}
+#line 2696 "../wisitoken_grammar_re2c.c"
+yy94:
+ YYDEBUG(94, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'o': goto yy97;
+ default: goto yy33;
+ }
+yy95:
+ YYDEBUG(95, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'g': goto yy98;
+ default: goto yy33;
+ }
+yy96:
+ YYDEBUG(96, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'n': goto yy99;
+ default: goto yy33;
+ }
+yy97:
+ YYDEBUG(97, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'r': goto yy101;
+ default: goto yy33;
+ }
+yy98:
+ YYDEBUG(98, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'r': goto yy102;
+ default: goto yy33;
+ }
+yy99:
+ YYDEBUG(99, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '_':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z': goto yy32;
+ default: goto yy100;
+ }
+yy100:
+ YYDEBUG(100, YYPEEK ());
+#line 211 "../wisitoken_grammar.re2c"
+ {*id = 8; continue;}
+#line 2812 "../wisitoken_grammar_re2c.c"
+yy101:
+ YYDEBUG(101, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'd': goto yy103;
+ default: goto yy33;
+ }
+yy102:
+ YYDEBUG(102, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'a': goto yy105;
+ default: goto yy33;
+ }
+yy103:
+ YYDEBUG(103, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '_':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z': goto yy32;
+ default: goto yy104;
+ }
+yy104:
+ YYDEBUG(104, YYPEEK ());
+#line 209 "../wisitoken_grammar.re2c"
+ {*id = 6; continue;}
+#line 2904 "../wisitoken_grammar_re2c.c"
+yy105:
+ YYDEBUG(105, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'm': goto yy106;
+ default: goto yy33;
+ }
+yy106:
+ YYDEBUG(106, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'm': goto yy107;
+ default: goto yy33;
+ }
+yy107:
+ YYDEBUG(107, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'a': goto yy108;
+ default: goto yy33;
+ }
+yy108:
+ YYDEBUG(108, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case 'r': goto yy109;
+ default: goto yy33;
+ }
+yy109:
+ YYDEBUG(109, YYPEEK ());
+ YYSKIP ();
+ yych = YYPEEK ();
+ switch (yych) {
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ case '_':
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z': goto yy32;
+ default: goto yy110;
+ }
+yy110:
+ YYDEBUG(110, YYPEEK ());
+#line 210 "../wisitoken_grammar.re2c"
+ {*id = 7; continue;}
+#line 3012 "../wisitoken_grammar_re2c.c"
+}
+#line 231 "../wisitoken_grammar.re2c"
+
+ }
+ *byte_position = lexer->byte_token_start - lexer->buffer + 1;
+ *byte_length = lexer->cursor - lexer->byte_token_start;
+ *char_position = lexer->char_token_start;
+ if (DO_COUNT)
+ *char_length = lexer->char_pos - lexer->char_token_start;
+ else
+ *char_length = lexer->char_pos - lexer->char_token_start + 1;
+ *line_start = lexer->line_token_start;
+ return status;
+ }
diff --git a/wisitoken_grammar_re2c_c.ads b/wisitoken_grammar_re2c_c.ads
new file mode 100644
index 0000000..0f96b59
--- /dev/null
+++ b/wisitoken_grammar_re2c_c.ads
@@ -0,0 +1,63 @@
+-- generated parser support file.
+-- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
+--
+
+-- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+--
+-- Author: Stephen Leake <stephe-leake@stephe-leake.org>
+--
+-- This file is part of GNU Emacs.
+--
+-- GNU Emacs is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- GNU Emacs is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+with Interfaces.C;
+with WisiToken;
+with System;
+package wisitoken_grammar_re2c_c is
+
+ function New_Lexer
+ (Buffer : in System.Address;
+ Length : in Interfaces.C.size_t;
+ Verbosity : in Interfaces.C.int)
+ return System.Address
+ with Import => True,
+ Convention => C,
+ External_Name => "wisitoken_grammar_new_lexer";
+ -- Create the lexer object, passing it the full text to process.
+
+ procedure Free_Lexer (Lexer : in out System.Address)
+ with Import => True,
+ Convention => C,
+ External_Name => "wisitoken_grammar_free_lexer";
+ -- Free the lexer object
+
+ procedure Reset_Lexer (Lexer : in System.Address)
+ with Import => True,
+ Convention => C,
+ External_Name => "wisitoken_grammar_reset_lexer";
+
+ function Next_Token
+ (Lexer : in System.Address;
+ ID : out WisiToken.Token_ID;
+ Byte_Position : out Interfaces.C.size_t;
+ Byte_Length : out Interfaces.C.size_t;
+ Char_Position : out Interfaces.C.size_t;
+ Char_Length : out Interfaces.C.size_t;
+ Line_Start : out Interfaces.C.int)
+ return Interfaces.C.int
+ with Import => True,
+ Convention => C,
+ External_Name => "wisitoken_grammar_next_token";
+
+end wisitoken_grammar_re2c_c;
diff --git a/wisitoken_grammar_runtime.adb b/wisitoken_grammar_runtime.adb
new file mode 100644
index 0000000..905b7a5
--- /dev/null
+++ b/wisitoken_grammar_runtime.adb
@@ -0,0 +1,610 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Unbounded;
+with SAL;
+with WisiToken.Generate; use WisiToken.Generate;
+with Wisitoken_Grammar_Actions; use Wisitoken_Grammar_Actions;
+package body WisiToken_Grammar_Runtime is
+
+ use WisiToken;
+
+ function Get_Text
+ (Data : in User_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Tree_Index : in Syntax_Trees.Valid_Node_Index;
+ Strip_Quotes : in Boolean := False)
+ return String
+ is
+ use all type Syntax_Trees.Node_Label;
+
+ function Strip_Delimiters (Tree_Index : in
Syntax_Trees.Valid_Node_Index) return String
+ 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.
+ 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
+ return Data.Grammar_Lexer.Buffer_Text ((Region.First + 1,
Region.Last - 1));
+ else
+ return Data.Grammar_Lexer.Buffer_Text (Region);
+ end if;
+ end Strip_Delimiters;
+
+ begin
+ case Tree.Label (Tree_Index) is
+ when Shared_Terminal =>
+ return Strip_Delimiters (Tree_Index);
+
+ when Virtual_Terminal =>
+ raise SAL.Programmer_Error;
+
+ when Nonterm =>
+ declare
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+ Result : Ada.Strings.Unbounded.Unbounded_String;
+ Tree_Indices : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Get_Terminals (Tree_Index);
+ Need_Space : Boolean :=
False;
+ begin
+ for Tree_Index of Tree_Indices loop
+ Result := Result & (if Need_Space then " " else "") &
Strip_Delimiters (Tree_Index);
+ Need_Space := True;
+ end loop;
+ return -Result;
+ end;
+ end case;
+ end Get_Text;
+
+ function Get_Child_Text
+ (Data : in User_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Parent : in Syntax_Trees.Valid_Node_Index;
+ Child : in SAL.Peek_Type;
+ Strip_Quotes : in Boolean := False)
+ return String
+ is
+ Tree_Indices : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Get_Terminals (Parent);
+ begin
+ return Get_Text (Data, Tree, Tree_Indices (Child), Strip_Quotes);
+ end Get_Child_Text;
+
+ procedure Start_If_1
+ (Data : in out User_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ A_Index : in Syntax_Trees.Valid_Node_Index;
+ B_Index : in Syntax_Trees.Valid_Node_Index)
+ is
+ use all type WisiToken.BNF.Generate_Algorithm;
+ use all type WisiToken.BNF.Lexer_Type;
+ begin
+ if "lexer" = Get_Text (Data, Tree, A_Index) then
+ Data.If_Lexer_Present := True;
+ Data.Ignore_Lines := Data.User_Lexer /= WisiToken.BNF.To_Lexer
(Get_Text (Data, Tree, B_Index));
+
+ elsif "parser" = Get_Text (Data, Tree, A_Index) then
+ Data.If_Parser_Present := True;
+ Data.Ignore_Lines := Data.User_Parser /=
WisiToken.BNF.Generate_Algorithm'Value
+ (Get_Text (Data, Tree, B_Index));
+
+ else
+ raise Grammar_Error with
+ Error_Message
+ (Data.Grammar_Lexer.File_Name, Data.Terminals.all
(Tree.Min_Terminal_Index (A_Index)).Line,
+ "invalid '%if'; must be one of {lexer | parser}");
+ end if;
+ end Start_If_1;
+
+ function Get_RHS
+ (Data : in out User_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Token : in Syntax_Trees.Valid_Node_Index)
+ return WisiToken.BNF.RHS_Type
+ is
+ use all type SAL.Base_Peek_Type;
+ Tokens : constant Syntax_Trees.Valid_Node_Index_Array := Tree.Children
(Token);
+ begin
+ pragma Assert (-Tree.ID (Token) = rhs_ID);
+
+ return RHS : WisiToken.BNF.RHS_Type do
+ if Tokens'Length = 0 then
+ -- Token is an empty rhs; parent is a possibly empty rhs_list;
grandparent is
+ -- a non-empty rhs_list or nonterminal.
+ RHS.Source_Line := Data.Terminals.all (Tree.Min_Terminal_Index
(Tree.Parent (Tree.Parent (Token)))).Line;
+
+ else
+ RHS.Source_Line := Data.Terminals.all (Tree.Min_Terminal_Index
(Token)).Line;
+
+ for I of Tree.Get_Terminals (Tokens (1)) loop
+ RHS.Tokens.Append (Get_Text (Data, Tree, I));
+ end loop;
+
+ if Tokens'Last >= 2 then
+ declare
+ Text : constant String := Get_Text (Data, Tree, Tokens (2));
+ begin
+ if Text'Length > 0 then
+ RHS.Action := +Text;
+ Data.Action_Count := Data.Action_Count + 1;
+ end if;
+ end;
+ end if;
+
+ if Tokens'Last >= 3 then
+ RHS.Check := +Get_Text (Data, Tree, Tokens (3));
+ Data.Check_Count := Data.Check_Count + 1;
+ end if;
+ end if;
+ end return;
+ end Get_RHS;
+
+ procedure Get_Right_Hand_Sides
+ (Data : in out User_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Right_Hand_Sides : in out WisiToken.BNF.RHS_Lists.List;
+ Token : in WisiToken.Syntax_Trees.Valid_Node_Index)
+ is
+ use all type SAL.Base_Peek_Type;
+
+ Tokens : constant Syntax_Trees.Valid_Node_Index_Array := Tree.Children
(Token);
+ begin
+ pragma Assert (-Tree.ID (Token) = rhs_list_ID);
+
+ if Tokens'Last = 1 then
+ -- | rhs
+ if not Data.Ignore_Lines then
+ Right_Hand_Sides.Append (Get_RHS (Data, Tree, Tokens (1)));
+ end if;
+ else
+ -- | rhs_list BAR rhs
+ -- | rhs_list PERCENT IF IDENTIFIER EQUAL IDENTIFIER
+ -- | rhs_list PERCENT END IF
+ Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Tokens (1));
+
+ case Token_Enum_ID'(-Tree.ID (Tokens (3))) is
+ when rhs_ID =>
+ if not Data.Ignore_Lines then
+ Right_Hand_Sides.Append (Get_RHS (Data, Tree, Tokens (3)));
+ end if;
+
+ when IF_ID =>
+ Start_If_1 (Data, Tree, Tokens (4), Tokens (6));
+
+ when END_ID =>
+ Data.Ignore_Lines := False;
+
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+ end if;
+ end Get_Right_Hand_Sides;
+
+ ----------
+ -- Public subprograms, declaration order
+
+ overriding
+ procedure Set_Lexer_Terminals
+ (User_Data : in out User_Data_Type;
+ Lexer : in WisiToken.Lexer.Handle;
+ Terminals : in Base_Token_Array_Access)
+ is begin
+ User_Data.Grammar_Lexer := Lexer;
+ User_Data.Terminals := Terminals;
+ end Set_Lexer_Terminals;
+
+ overriding procedure Reset (Data : in out User_Data_Type)
+ is begin
+ -- Preserve Grammar_Lexer
+ -- Preserve User_Lexer
+ -- Preserve User_Parser
+ -- Perserve Generate_Set
+ -- Preserve Terminals
+ Data.Raw_Code := (others => <>);
+ 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;
+ Data.Action_Count := 0;
+ Data.Check_Count := 0;
+ Data.If_Lexer_Present := False;
+ Data.If_Parser_Present := False;
+ Data.Ignore_Lines := False;
+ end Reset;
+
+ procedure Start_If
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is begin
+ Start_If_1 (User_Data_Type (User_Data), Tree, Tokens (3), Tokens (5));
+ end Start_If;
+
+ procedure End_If (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class)
+ is
+ Data : User_Data_Type renames User_Data_Type (User_Data);
+ begin
+ Data.Ignore_Lines := False;
+ end End_If;
+
+ procedure Add_Declaration
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+
+ Data : User_Data_Type renames User_Data_Type (User_Data);
+
+ function Token (Index : in SAL.Peek_Type) return Base_Token
+ is
+ use all type WisiToken.Syntax_Trees.Node_Label;
+ use all type SAL.Base_Peek_Type;
+ begin
+ if Tokens'Last < Index then
+ raise SAL.Programmer_Error;
+ elsif Tree.Label (Tokens (Index)) /=
WisiToken.Syntax_Trees.Shared_Terminal then
+ raise SAL.Programmer_Error;
+ else
+ return Data.Terminals.all (Tree.Terminal (Tokens (Index)));
+ end if;
+ end Token;
+
+ function Enum_ID (Index : in SAL.Peek_Type) return Token_Enum_ID
+ is (Token_Enum_ID'(-Token (Index).ID));
+
+ begin
+ -- Add declaration to User_Data.Generate_Set, Language_Params,
+ -- Tokens, Conflicts, or McKenzie_Recover.
+
+ if Data.Ignore_Lines then
+ return;
+ end if;
+
+ case Tree.Label (Tokens (2)) is
+ when Syntax_Trees.Nonterm =>
+ -- must be token_keyword_non_grammar
+ declare
+ Children : Syntax_Trees.Valid_Node_Index_Array renames
Tree.Children (Tokens (2));
+ Child_1 : Base_Token renames Data.Terminals.all (Tree.Terminal
(Children (1)));
+ begin
+ case Token_Enum_ID'(-Child_1.ID) is
+ when Wisitoken_Grammar_Actions.TOKEN_ID =>
+
+ WisiToken.BNF.Add_Token
+ (Data.Tokens.Tokens,
+ Kind => Get_Text (Data, Tree, Children (3)),
+ Name => Get_Text (Data, Tree, Tokens (3)),
+ Value => Get_Text (Data, Tree, Tokens (4)));
+
+ when KEYWORD_ID =>
+
+ Data.Tokens.Keywords.Append
+ ((Name => +Get_Text (Data, Tree, Tokens (3)),
+ Value => +Get_Text (Data, Tree, Tokens (4))));
+
+ when NON_GRAMMAR_ID =>
+
+ WisiToken.BNF.Add_Token
+ (Data.Tokens.Non_Grammar,
+ Kind => Get_Text (Data, Tree, Children (3)),
+ Name => Get_Text (Data, Tree, Tokens (3)),
+ Value => Get_Text (Data, Tree, Tokens (4)));
+
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+ end;
+
+ when Syntax_Trees.Shared_Terminal =>
+ case Enum_ID (2) is
+ when CODE_ID =>
+ declare
+ Location : WisiToken.BNF.Raw_Code_Location;
+
+ -- % code identifier_list raw_code
+ -- 1 2 3 4
+ --
+ -- identifier_list = "action spec context"
+ -- identifier_list children = identifier_list IDENTIFIER_ID
+ -- children = identifier_list IDENTIFIER_ID
+ -- children = IDENTIFIER_ID
+ function Get_Loc_List return Base_Token_Array
+ is
+ use all type SAL.Base_Peek_Type;
+ use WisiToken.Syntax_Trees;
+ Node : Valid_Node_Index := Tokens (3);
+ Result : Base_Token_Array (1 .. 3);
+ First : SAL.Peek_Type := Result'Last + 1;
+ begin
+ loop
+ pragma Assert (-Tree.ID (Node) = identifier_list_ID);
+ exit when not Tree.Has_Children (Node);
+ declare
+ Children : constant Valid_Node_Index_Array :=
Tree.Children (Node);
+ begin
+ if Children'Length = 1 then
+ -- identifier_list : IDENTIFIER
+ First := First - 1;
+ Result (First) := Data.Terminals.all (Tree.Terminal
(Children (1)));
+ exit;
+
+ elsif Children'Length = 2 then
+ -- identifier_list : identifier_list IDENTIFIER
+ First := First - 1;
+ Result (First) := Data.Terminals.all (Tree.Terminal
(Children (2)));
+
+ Node := Children (1);
+ else
+ raise SAL.Programmer_Error;
+ end if;
+ end;
+ end loop;
+ return Result (First .. Result'Last);
+ end Get_Loc_List;
+
+ Loc_List : constant Base_Token_Array := Get_Loc_List;
+
+ function Get_Loc (Index : in SAL.Peek_Type) return String
+ is (Data.Grammar_Lexer.Buffer_Text (Loc_List
(Index).Byte_Region));
+
+ begin
+ if Get_Loc (Loc_List'First) = "actions" then
+ Location :=
+ (if Get_Loc (2) = "spec" then
+ (if Get_Loc (3) = "context" then
WisiToken.BNF.Actions_Spec_Context
+ elsif Get_Loc (3) = "pre" then
WisiToken.BNF.Actions_Spec_Pre
+ elsif Get_Loc (3) = "post" then
WisiToken.BNF.Actions_Spec_Post
+ else raise Grammar_Error with
+ Error_Message
+ (Data.Grammar_Lexer.File_Name, Loc_List (2).Line,
+ "expecting {context | pre | post}"))
+
+ elsif Get_Loc (2) = "body" then
+ (if Get_Loc (3) = "context" then
WisiToken.BNF.Actions_Body_Context
+ elsif Get_Loc (3) = "pre" then
WisiToken.BNF.Actions_Body_Pre
+ elsif Get_Loc (3) = "post" then
WisiToken.BNF.Actions_Body_Post
+ else raise Grammar_Error with
+ Error_Message
+ (Data.Grammar_Lexer.File_Name, Loc_List (2).Line,
+ "expecting {context | pre | post}"))
+
+ else raise Grammar_Error);
+
+ elsif Get_Loc (Loc_List'First) = "copyright_license" then
+ Location := WisiToken.BNF.Copyright_License;
+
+ else
+ raise Grammar_Error with
+ Error_Message
+ (Data.Grammar_Lexer.File_Name, Loc_List
(Loc_List'First).Line,
+ "expecting {actions | copyright_license}");
+ end if;
+
+ Data.Raw_Code (Location) := WisiToken.BNF.Split_Lines (Get_Text
(Data, Tree, Tokens (4)));
+ exception
+ when Grammar_Error =>
+ Put_Error
+ (Error_Message
+ (Data.Grammar_Lexer.File_Name, Token (2).Line, Token
(2).Column,
+ "invalid raw code location; actions {spec | body}
{context | pre | post}"));
+ end;
+
+ when IDENTIFIER_ID =>
+ declare
+ Kind : constant String := Data.Grammar_Lexer.Buffer_Text (Token
(2).Byte_Region);
+ begin
+ if Kind = "case_insensitive" then
+ Data.Language_Params.Case_Insensitive := True;
+
+ elsif Kind = "conflict" then
+ declare
+ Tree_Indices : constant
Syntax_Trees.Valid_Node_Index_Array := Tree.Get_Terminals
+ (Tokens (3));
+ -- %conflict <action_a>/<action_b> in state <LHS_A>,
<LHS_B> on token <on>
+ -- 1 2 3 4 5 6 7 8
9 10 11
+ begin
+ Data.Conflicts.Append
+ ((Source_Line => Data.Terminals.all (Tree.Terminal
(Tree_Indices (1))).Line,
+ Action_A => +Get_Text (Data, Tree, Tree_Indices
(1)),
+ LHS_A => +Get_Text (Data, Tree, Tree_Indices
(6)),
+ Action_B => +Get_Text (Data, Tree, Tree_Indices
(3)),
+ LHS_B => +Get_Text (Data, Tree, Tree_Indices
(8)),
+ On => +Get_Text (Data, Tree, Tree_Indices
(11))));
+ end;
+
+ elsif Kind = "end" then
+ -- matching '%if' specified current lexer.
+ null;
+
+ elsif Kind = "elisp_face" then
+ Data.User_Names.Faces.Append (Get_Text (Data, Tree, Tokens
(3), Strip_Quotes => True));
+
+ elsif Kind = "elisp_indent" then
+ Data.User_Names.Indents.Append
+ ((Name => +Get_Child_Text (Data, Tree, Tokens (3), 1,
Strip_Quotes => True),
+ Value => +Get_Child_Text (Data, Tree, Tokens (3), 2)));
+
+ elsif Kind = "regexp_name" then
+ Data.User_Names.Regexps.Append
+ ((Name => +Get_Child_Text (Data, Tree, Tokens (3), 1),
+ Value => +Get_Child_Text (Data, Tree, Tokens (3), 2)));
+
+ elsif Kind = "embedded_quote_escape_doubled" then
+ Data.Language_Params.Embedded_Quote_Escape_Doubled := True;
+
+ elsif Kind = "end_names_optional_option" then
+ Data.Language_Params.End_Names_Optional_Option := +Get_Text
(Data, Tree, Tokens (3));
+
+
+ elsif Kind = "generate" then
+ declare
+ Children : constant Syntax_Trees.Valid_Node_Index_Array
:= Tree.Get_Terminals (Tokens (3));
+ Tuple : WisiToken.BNF.Generate_Tuple;
+ begin
+ Tuple.Gen_Alg := WisiToken.BNF.Generate_Algorithm'Value
(Get_Text (Data, Tree, Children (1)));
+ Tuple.Out_Lang := WisiToken.BNF.To_Output_Language
(Get_Text (Data, Tree, Children (2)));
+ for I in 3 .. SAL.Base_Peek_Type (Children'Length) loop
+ declare
+ Text : constant String := Get_Text (Data, Tree,
Children (I));
+ begin
+ if Text = "text_rep" then
+ Tuple.Text_Rep := True;
+
+ elsif (for some I of WisiToken.BNF.Lexer_Image =>
Text = I.all) then
+ Tuple.Lexer := WisiToken.BNF.To_Lexer (Text);
+
+ elsif (for some I in WisiToken.BNF.Valid_Interface
=>
+ WisiToken.BNF.To_Lower (Text) =
WisiToken.BNF.To_Lower
+ (WisiToken.BNF.Valid_Interface'Image
(I)))
+ then
+ Tuple.Interface_Kind :=
WisiToken.BNF.Valid_Interface'Value (Text);
+ else
+ declare
+ Token : Base_Token renames Data.Terminals.all
(Tree.Terminal (Children (I)));
+ begin
+ raise Grammar_Error with Error_Message
+ (Data.Grammar_Lexer.File_Name, Token.Line,
Token.Column,
+ "invalid generate param '" & Text & "'");
+ end;
+ end if;
+ end;
+ end loop;
+ WisiToken.BNF.Add (Data.Generate_Set, Tuple);
+ end;
+
+ elsif Kind = "mckenzie_check_limit" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Check_Limit := Token_Index'Value
(Get_Text (Data, Tree, Tokens (3)));
+
+ elsif Kind = "mckenzie_check_delta_limit" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Check_Delta_Limit := Integer'Value
(Get_Text (Data, Tree, Tokens (3)));
+
+ elsif Kind = "mckenzie_cost_default" then
+ if Tree.Get_Terminals (Tokens (3))'Length /= 4 then
+ raise Grammar_Error with
+ Error_Message
+ (Data.Grammar_Lexer.File_Name, Data.Terminals.all
(Tree.Min_Terminal_Index (Tokens (3))).Line,
+ "too " & (if Tree.Get_Terminals (Tokens (3))'Length
> 4 then "many" else "few") &
+ " default costs; should be 'insert, delete, push
back, ignore check fail'.");
+ end if;
+
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Source_Line := Data.Terminals.all
(Tree.Min_Terminal_Index (Tokens (1))).Line;
+
+ Data.McKenzie_Recover.Default_Insert :=
Natural'Value
+ (Get_Child_Text (Data, Tree, Tokens (3), 1));
+ Data.McKenzie_Recover.Default_Delete_Terminal :=
Natural'Value
+ (Get_Child_Text (Data, Tree, Tokens (3), 2));
+ Data.McKenzie_Recover.Default_Push_Back :=
Natural'Value
+ (Get_Child_Text (Data, Tree, Tokens (3), 3));
+ Data.McKenzie_Recover.Ignore_Check_Fail :=
Natural'Value
+ (Get_Child_Text (Data, Tree, Tokens (3), 4));
+
+ elsif Kind = "mckenzie_cost_delete" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Delete.Append
+ ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
+ +Get_Child_Text (Data, Tree, Tokens (3), 2)));
+
+ elsif Kind = "mckenzie_cost_insert" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Insert.Append
+ ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
+ +Get_Child_Text (Data, Tree, Tokens (3), 2)));
+
+ elsif Kind = "mckenzie_cost_limit" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Cost_Limit := Natural'Value (Get_Text
(Data, Tree, Tokens (3)));
+
+ elsif Kind = "mckenzie_cost_push_back" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Push_Back.Append
+ ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
+ +Get_Child_Text (Data, Tree, Tokens (3), 2)));
+
+ elsif Kind = "mckenzie_enqueue_limit" then
+ Data.Language_Params.Error_Recover := True;
+ Data.McKenzie_Recover.Enqueue_Limit := Natural'Value
(Get_Text (Data, Tree, Tokens (3)));
+
+ elsif Kind = "no_language_runtime" then
+ Data.Language_Params.Language_Runtime := False;
+
+ elsif Kind = "no_enum" then
+ Data.Language_Params.Declare_Enums := False;
+
+ elsif Kind = "start" then
+ Data.Language_Params.Start_Token := +Get_Text (Data, Tree,
Tokens (3));
+
+ elsif Kind = "re2c_regexp" then
+ Data.Tokens.Regexps.Append
+ ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
+ +Get_Child_Text (Data, Tree, Tokens (3), 2)));
+
+ else
+ raise Grammar_Error with Error_Message
+ (Data.Grammar_Lexer.File_Name, Token (2).Line, Token
(2).Column, "unexpected syntax");
+
+ end if;
+ end;
+
+ when others =>
+ raise Grammar_Error with Error_Message
+ (Data.Grammar_Lexer.File_Name, Token (2).Line, Token (2).Column,
"unexpected syntax");
+ end case;
+
+ when Syntax_Trees.Virtual_Terminal =>
+ raise SAL.Programmer_Error;
+ end case;
+ end Add_Declaration;
+
+ procedure Add_Nonterminal
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array)
+ is
+ Data : User_Data_Type renames User_Data_Type (User_Data);
+
+ LHS : constant String := Get_Text (Data, Tree, Tokens (1));
+
+ Right_Hand_Sides : WisiToken.BNF.RHS_Lists.List;
+ begin
+ Data.Rule_Count := Data.Rule_Count + 1;
+
+ Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Tokens (3));
+
+ if WisiToken.BNF.Is_Present (Data.Tokens.Rules, LHS) then
+ declare
+ LHS_Token : Base_Token renames Data.Terminals.all (Tree.Terminal
(Tokens (1)));
+ begin
+ raise Grammar_Error with Error_Message
+ (Data.Grammar_Lexer.File_Name, LHS_Token.Line, LHS_Token.Column,
"duplicate nonterm");
+ end;
+ else
+ Data.Tokens.Rules.Append
+ ((+LHS, Right_Hand_Sides,
+ Source_Line => Data.Terminals.all (Tree.Min_Terminal_Index
(Tokens (1))).Line));
+ end if;
+ end Add_Nonterminal;
+
+end WisiToken_Grammar_Runtime;
diff --git a/wisitoken_grammar_runtime.ads b/wisitoken_grammar_runtime.ads
new file mode 100644
index 0000000..1e87241
--- /dev/null
+++ b/wisitoken_grammar_runtime.ads
@@ -0,0 +1,85 @@
+-- Abstract :
+--
+-- Runtime utils for wisi_grammar.wy actions.
+--
+-- Copyright (C) 2018 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with WisiToken.BNF;
+with WisiToken.Lexer;
+with WisiToken.Syntax_Trees;
+package WisiToken_Grammar_Runtime is
+
+ type User_Data_Type is new WisiToken.Syntax_Trees.User_Data_Type with
+ record
+ Grammar_Lexer : WisiToken.Lexer.Handle; -- used to read the .wy file now.
+
+ User_Lexer : WisiToken.BNF.Lexer_Type := WisiToken.BNF.None;
+ -- Used to read the user language file, after user parser is generated;
+ -- used now in '%if lexer' statements.
+
+ User_Parser : WisiToken.BNF.Generate_Algorithm := WisiToken.BNF.None;
+ -- Used to generate the user parser; used now in '%if parser'
+ -- statements.
+
+ Generate_Set : WisiToken.BNF.Generate_Set_Access;
+ -- As specified by %generate directives or command line.
+
+ Terminals : WisiToken.Base_Token_Array_Access;
+ 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;
+
+ Rule_Count : Integer := 0;
+ Action_Count : Integer := 0;
+ Check_Count : Integer := 0;
+
+ If_Lexer_Present : Boolean := False;
+ If_Parser_Present : Boolean := False;
+ -- Set True by %if statements in Execute_Actions.
+
+ Ignore_Lines : Boolean := False;
+ -- An '%if' specified a different lexer, during Excute_Actions
+ end record;
+
+ overriding
+ procedure Set_Lexer_Terminals
+ (User_Data : in out User_Data_Type;
+ Lexer : in WisiToken.Lexer.Handle;
+ Terminals : in WisiToken.Base_Token_Array_Access);
+
+ overriding procedure Reset (Data : in out User_Data_Type);
+
+ procedure Start_If
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+
+ procedure End_If (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class);
+
+ procedure Add_Declaration
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+
+ procedure Add_Nonterminal
+ (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array);
+
+end WisiToken_Grammar_Runtime;
- [elpa] branch externals/wisi created (now dd09dcf), Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 931fc16 16/35: * packages/gnome-c-style/gnome-c-tests.el: Add copyright blurb, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 2f33bf8 21/35: Release Ada mode 5.3.1, wisi 1.1.6, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi e91f482 03/35: * wisi: Fix up dependency and sectioning style., Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 60b8ef1 15/35: Update ada-mode, wisi, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi d10db37 22/35: Release ada-mode version 6.0. Release wisi version 2.0,
Stefan Monnier <=
- [elpa] externals/wisi a4e4907 01/35: Add ada-mode, wisi packages, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 922e27f 04/35: * wisi: Fix warnings and a few 80-columns overruns, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 0635f1a 14/35: * packages/wisi: Use lexical binding. Fix dos EOL. Fix EOB markers, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 7cb03cb 10/35: * packages/ada-mode/* : version 5.1.5, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi cb45dd5 07/35: * packages/ada-mode: version 5.1.1: fix wisi packaging bug, add -a in gnat-find, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 8bdcee1 11/35: publish ada-mode 5.1.6, wisi 1.0.6, new package ada-ref-man, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 364da46 20/35: Update ada-mode to version 5.2.2, wisi to version 1.1.5, Stefan Monnier, 2020/11/28
- [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