[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/wisi 66d7e59 27/35: In ada-mode, wisi: release Ada mode
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] externals/wisi 66d7e59 27/35: In ada-mode, wisi: release Ada mode 6.2.0, wisi 1.2.0. |
|
Date: |
Sat, 28 Nov 2020 14:47:56 -0500 (EST) |
branch: externals/wisi
commit 66d7e59ad20c99dbfbfd17fe9dcd56588c727ce4
Author: Stephen Leake <stephen_leake@stephe-leake.org>
Commit: Stephen Leake <stephen_leake@stephe-leake.org>
In ada-mode, wisi: release Ada mode 6.2.0, wisi 1.2.0.
---
NEWS | 45 +-
README | 2 +-
emacs_wisi_common_parse.adb | 507 ++++++
emacs_wisi_common_parse.ads | 154 ++
gen_emacs_wisi_lr_parse.adb | 39 +
gen_emacs_wisi_lr_parse.ads | 55 +
gen_emacs_wisi_lr_text_rep_parse.adb | 44 +
gen_emacs_wisi_lr_text_rep_parse.ads | 50 +
gen_emacs_wisi_packrat_parse.adb | 180 ++
gen_emacs_wisi_packrat_parse.ads | 42 +
gen_run_wisi_libadalang_parse.adb | 176 ++
gen_run_wisi_libadalang_parse.ads | 30 +
gen_run_wisi_lr_parse.adb | 37 +
gen_run_wisi_lr_parse.ads | 42 +
gen_run_wisi_lr_text_rep_parse.adb | 44 +
gen_run_wisi_lr_text_rep_parse.ads | 44 +
gen_run_wisi_packrat_parse.adb | 241 +++
gen_run_wisi_packrat_parse.ads | 36 +
run_wisi_common_parse.adb | 343 ++++
run_wisi_common_parse.ads | 73 +
sal-gen_bounded_definite_queues.adb | 119 +-
sal-gen_bounded_definite_queues.ads | 106 +-
...l-gen_bounded_definite_stacks-gen_image_aux.adb | 27 +-
sal-gen_bounded_definite_stacks-gen_image_aux.ads | 27 +
sal-gen_bounded_definite_stacks.adb | 82 +
sal-gen_bounded_definite_stacks.ads | 103 ++
sal-gen_bounded_definite_vectors-gen_image.adb | 79 +-
sal-gen_bounded_definite_vectors-gen_refs.adb | 35 +
sal-gen_bounded_definite_vectors-gen_refs.ads | 54 +
sal-gen_bounded_definite_vectors-gen_sorted.ads | 52 -
sal-gen_bounded_definite_vectors.adb | 344 ++--
sal-gen_bounded_definite_vectors.ads | 299 ++--
...unded_definite_vectors_sorted-gen_image_aux.adb | 20 +-
...unded_definite_vectors_sorted-gen_image_aux.ads | 23 +
...en_bounded_definite_vectors_sorted-gen_refs.adb | 29 +
...en_bounded_definite_vectors_sorted-gen_refs.ads | 39 +
... => sal-gen_bounded_definite_vectors_sorted.adb | 172 +-
sal-gen_bounded_definite_vectors_sorted.ads | 85 +
sal-gen_definite_doubly_linked_lists.adb | 55 +-
sal-gen_definite_doubly_linked_lists.ads | 43 +-
sal-gen_definite_doubly_linked_lists_sorted.adb | 1084 ++++++------
sal-gen_definite_doubly_linked_lists_sorted.ads | 372 +++--
sal-gen_graphs.adb | 21 +-
sal-gen_indefinite_doubly_linked_lists.adb | 412 ++---
sal-gen_indefinite_doubly_linked_lists.ads | 40 +-
sal-gen_unbounded_definite_min_heaps_fibonacci.adb | 45 +-
sal-gen_unbounded_definite_min_heaps_fibonacci.ads | 27 +-
sal-gen_unbounded_definite_queues.adb | 4 +-
sal-gen_unbounded_definite_queues.ads | 6 +-
sal-gen_unbounded_definite_red_black_trees.adb | 34 +-
sal-gen_unbounded_definite_red_black_trees.ads | 57 +-
sal-gen_unbounded_definite_stacks.adb | 12 +-
sal-gen_unbounded_definite_stacks.ads | 28 +-
sal-gen_unbounded_definite_vectors.adb | 59 +-
sal-gen_unbounded_definite_vectors.ads | 471 +++---
sal-gen_unbounded_definite_vectors_sorted.adb | 368 +++++
sal-gen_unbounded_definite_vectors_sorted.ads | 170 ++
sal.adb | 2 +-
wisi-compile.el | 225 ---
wisi-elisp-lexer.el | 393 -----
wisi-elisp-parse.el | 1721 --------------------
wisi-parse-common.el | 778 ++++-----
wisi-process-parse.el | 1617 +++++++++---------
wisi-run-indent-test.el | 631 +++----
wisi-tests.el | 30 +-
wisi.adb | 582 +++----
wisi.ads | 115 +-
wisi.el | 151 +-
wisitoken.gpr => wisi.gpr | 47 +-
wisitoken-bnf-generate.adb | 21 +-
wisitoken-bnf-generate_grammar.adb | 14 +-
wisitoken-bnf-generate_utils.adb | 196 +--
wisitoken-bnf-generate_utils.ads | 22 +-
wisitoken-bnf-output_ada_common.adb | 74 +-
wisitoken-bnf-output_ada_emacs.adb | 129 +-
wisitoken-bnf-output_elisp.adb | 293 ----
wisitoken-bnf-output_elisp_common.adb | 58 +-
wisitoken-bnf-output_elisp_common.ads | 7 +-
wisitoken-bnf.adb | 15 +-
wisitoken-bnf.ads | 26 +-
wisitoken-generate-lr-lalr_generate.adb | 9 +-
wisitoken-generate-lr-lr1_generate.adb | 2 +-
wisitoken-generate-lr.adb | 228 +--
wisitoken-generate-lr.ads | 4 +-
wisitoken-generate-lr1_items.adb | 4 +-
wisitoken-generate.adb | 3 +-
wisitoken-parse-lr-mckenzie_recover-base.adb | 31 +-
wisitoken-parse-lr-mckenzie_recover-base.ads | 3 +-
wisitoken-parse-lr-mckenzie_recover-explore.adb | 613 ++++---
wisitoken-parse-lr-mckenzie_recover-parse.adb | 75 +-
wisitoken-parse-lr-mckenzie_recover-parse.ads | 19 +-
wisitoken-parse-lr-mckenzie_recover.adb | 521 +++---
wisitoken-parse-lr-mckenzie_recover.ads | 59 +-
wisitoken-parse-lr-parser.adb | 60 +-
wisitoken-parse-lr-parser.ads | 12 +-
wisitoken-parse-lr-parser_lists.adb | 36 +-
wisitoken-parse-lr-parser_lists.ads | 1 +
wisitoken-parse-lr-parser_no_recover.adb | 13 +-
wisitoken-parse-lr.adb | 408 ++---
wisitoken-parse-lr.ads | 136 +-
wisitoken-parse-packrat-generated.adb | 6 +-
wisitoken-parse-packrat-procedural.adb | 5 +-
wisitoken-parse.adb | 4 +-
wisitoken-syntax_trees-lr_utils.adb | 220 +++
wisitoken-syntax_trees-lr_utils.ads | 88 +
wisitoken-syntax_trees.adb | 56 +-
wisitoken-syntax_trees.ads | 19 +-
wisitoken-wisi_ada.adb | 22 +-
wisitoken.ads | 13 +-
wisitoken_grammar_main.adb | 177 +-
wisitoken_grammar_main.ads | 1 +
wisitoken_grammar_runtime.adb | 152 +-
112 files changed, 9032 insertions(+), 8302 deletions(-)
diff --git a/NEWS b/NEWS
index 28f737c..bb8f8c6 100644
--- a/NEWS
+++ b/NEWS
@@ -1,13 +1,56 @@
GNU Emacs wisi NEWS -- history of user-visible changes.
Copyright (C) 2019 Free Software Foundation, Inc.
-See the end of the file for license conditions.
Please send wisi bug reports to bug-gnu-emacs@gnu.org, with
'wisi' in the subject. If possible, use M-x report-emacs-bug.
* wisi
+13 Aug 2019
+
+** parser process protocol version 3
+
+** Support for the elisp parser and lexer is deleted; only the Ada
+ process parser is supported.
+
+** New user variable `wisi-indent-context-lines' specifies the minimum
+ number of lines before point to include in a parse for indenting a
+ single line. This gives better results when indenting in a nested
+ 'if then else', for example. The default value is 0; you must
+ change it to see an effect.
+
+** Error correction is faster by approximately 30%;
+ %mckenzie_enqueue_limit can be raised accordingly.
+
+** %mckenzie_enqueue_limit is now applied to the total of all parsers
+ in recovery; previously, it was applied to each parser separately.
+ Applying to the total gives a more consistent maximum user wait
+ time for recovery, at the cost of not finding solutions when there
+ are many parsers involved. You may want to increase
+ %mckenzie_enqueue_limit for this as well.
+
+** In the process parser, `wisi-statement-start' now sets 'containing'
+ in all contained caches to the start token, if not set already;
+ previously it only did this if the token was mentioned in the
+ `wisi-statement-start' action. This makes `wisi-containing-action'
+ unnecessary.
+
+** `wisi-containing-action' is deleted.
+
+** An argument of `wisi-motion-action' that is a vector may now
+ provide only one token ID. That token ID is searched for in the
+ containing token region, and the motion token chain starting at the
+ first one found is included in the current right hand side motion
+ token chain.
+
+** The elisp parser and lexer are deleted.
+
+** The process parser supports a new parse command `wisi-refactor',
+ which returns a new message "Edit". It is intended for performing
+ syntax-guided refactoring of code statements.
+
+* wisi 2.1.1
11 Jul 2019
** parser process protocol version 3
diff --git a/README b/README
index f7fc4eb..c7176d2 100644
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-Emacs wisi package 2.1.1
+Emacs wisi package 2.2.0
The wisi package provides utilities for using generalized LALR parsers
(in elisp or external processes) to do indentation, fontification, and
diff --git a/emacs_wisi_common_parse.adb b/emacs_wisi_common_parse.adb
new file mode 100644
index 0000000..f74ce37
--- /dev/null
+++ b/emacs_wisi_common_parse.adb
@@ -0,0 +1,507 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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.Exceptions;
+with Ada.Strings.Fixed;
+with Ada.Text_IO;
+with GNAT.OS_Lib;
+with GNAT.Traceback.Symbolic;
+with SAL;
+with System.Multiprocessors;
+with System.Storage_Elements;
+with WisiToken.Lexer;
+package body Emacs_Wisi_Common_Parse is
+
+ procedure Usage (Name : in String)
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("usage: " & Name & "[--recover-log <file-name>]");
+ Put_Line ("enters a loop waiting for commands:");
+ Put_Line ("Prompt is '" & Prompt & "'");
+ Put_Line ("commands are case sensitive");
+ Put_Line ("See wisi-process-parse.el *--send-parse, *--send-noop for
arguments.");
+ end Usage;
+
+ procedure Read_Input (A : System.Address; N : Integer)
+ is
+ use System.Storage_Elements;
+
+ B : System.Address := A;
+ Remaining : Integer := N;
+ Read : Integer;
+ begin
+ -- We use GNAT.OS_Lib because it does not buffer input, so it runs
+ -- under Emacs nicely; GNAT Text_IO does not return text until
+ -- some fairly large buffer is filled.
+ --
+ -- With GNAT GPL 2016, GNAT.OS_Lib.Read does _not_ wait for all N
+ -- bytes or EOF; it returns as soon as it gets some bytes.
+ loop
+ Read := GNAT.OS_Lib.Read (GNAT.OS_Lib.Standin, B, Remaining);
+ if Read = 0 then
+ -- Pipe closed; probably parent Emacs crashed. Force exit.
+ raise SAL.Programmer_Error with "input pipe closed";
+ end if;
+ Remaining := Remaining - Read;
+ exit when Remaining <= 0;
+ B := B + Storage_Offset (Read);
+ end loop;
+ end Read_Input;
+
+ function Get_Command_Length return Integer
+ is
+ Temp : aliased String (1 .. 3) := (others => ' '); -- initialize for
error message
+ begin
+ Read_Input (Temp'Address, Temp'Length);
+ return Integer'Value (Temp);
+ exception
+ when Constraint_Error =>
+ -- From Integer'Value
+ raise Protocol_Error with "invalid command byte count; '" & Temp & "'";
+ end Get_Command_Length;
+
+ function Get_String
+ (Source : in String;
+ Last : in out Integer)
+ return String
+ is
+ use Ada.Strings.Fixed;
+ First : constant Integer := Index
+ (Source => Source,
+ Pattern => """",
+ From => Last + 1);
+ begin
+ Last := Index
+ (Source => Source,
+ Pattern => """",
+ From => First + 1);
+
+ if First = 0 or Last = 0 then
+ raise Protocol_Error with "no '""' found for string";
+ end if;
+
+ return Source (First + 1 .. Last - 1);
+ end Get_String;
+
+ function Get_Integer
+ (Source : in String;
+ Last : in out Integer)
+ return Integer
+ is
+ use Ada.Strings.Fixed;
+ First : constant Integer := Last + 2; -- final char of previous item,
space
+ begin
+ Last := Index
+ (Source => Source,
+ Pattern => " ",
+ From => First);
+
+ if Last = 0 then
+ Last := Source'Last;
+ else
+ Last := Last - 1;
+ end if;
+
+ return Integer'Value (Source (First .. Last));
+ exception
+ when others =>
+ Ada.Text_IO.Put_Line ("bad integer '" & Source (First .. Source'Last) &
"'");
+ raise;
+ end Get_Integer;
+
+ function Get_Process_Start_Params return Process_Start_Params
+ is
+ use Ada.Command_Line;
+ procedure Put_Usage
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line (Standard_Error, "process start args:");
+ Put_Line (Standard_Error, "--help : put this help");
+ Put_Line (Standard_Error, "--recover-log <file_name> : log recover
actions to file");
+ end Put_Usage;
+
+ Next_Arg : Integer := 1;
+ begin
+ return Result : Process_Start_Params do
+ loop
+ exit when Next_Arg > Argument_Count;
+
+ if Next_Arg <= Argument_Count and then Argument (Next_Arg) =
"--help" then
+ Put_Usage;
+ raise Finish;
+
+ elsif Next_Arg + 1 <= Argument_Count and then Argument (Next_Arg)
= "--recover-log" then
+ Result.Recover_Log_File_Name :=
Ada.Strings.Unbounded.To_Unbounded_String (Argument (Next_Arg + 1));
+ Next_Arg := Next_Arg + 2;
+ end if;
+ end loop;
+ end return;
+ end Get_Process_Start_Params;
+
+ function Get_Parse_Params (Command_Line : in String; Last : in out Integer)
return Parse_Params
+ is
+ use WisiToken;
+ begin
+ return Result : Parse_Params do
+ -- We don't use an aggregate, to enforce execution order.
+ -- Match wisi-process-parse.el wisi-process--send-parse
+
+ Result.Post_Parse_Action := Wisi.Post_Parse_Action_Type'Val
(Get_Integer (Command_Line, Last));
+ Result.Source_File_Name := +Get_String (Command_Line, Last);
+ Result.Begin_Byte_Pos := Get_Integer (Command_Line, Last);
+
+ -- Emacs end is after last char.
+ Result.End_Byte_Pos := Get_Integer (Command_Line, Last) - 1;
+
+ Result.Goal_Byte_Pos := Get_Integer (Command_Line, Last);
+ Result.Begin_Char_Pos := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last));
+ Result.Begin_Line := WisiToken.Line_Number_Type
(Get_Integer (Command_Line, Last));
+ Result.End_Line := WisiToken.Line_Number_Type
(Get_Integer (Command_Line, Last));
+ Result.Begin_Indent := Get_Integer (Command_Line, Last);
+ Result.Partial_Parse_Active := 1 = Get_Integer (Command_Line, Last);
+ Result.Debug_Mode := 1 = Get_Integer (Command_Line, Last);
+ Result.Parse_Verbosity := Get_Integer (Command_Line, Last);
+ Result.McKenzie_Verbosity := Get_Integer (Command_Line, Last);
+ Result.Action_Verbosity := Get_Integer (Command_Line, Last);
+ Result.McKenzie_Disable := Get_Integer (Command_Line, Last);
+ Result.Task_Count := Get_Integer (Command_Line, Last);
+ Result.Check_Limit := Get_Integer (Command_Line, Last);
+ Result.Enqueue_Limit := Get_Integer (Command_Line, Last);
+ Result.Max_Parallel := Get_Integer (Command_Line, Last);
+ Result.Byte_Count := Get_Integer (Command_Line, Last);
+ end return;
+ end Get_Parse_Params;
+
+ function Get_Refactor_Params (Command_Line : in String; Last : in out
Integer) return Refactor_Params
+ is
+ use WisiToken;
+ begin
+ return Result : Refactor_Params do
+ -- We don't use an aggregate, to enforce execution order.
+ -- Match wisi-process-parse.el wisi-process--send-refactor
+
+ Result.Refactor_Action := Get_Integer (Command_Line, Last);
+ Result.Source_File_Name := +Get_String (Command_Line, Last);
+ Result.Parse_Region.First := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last));
+ Result.Parse_Region.Last := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last) - 1);
+
+ Result.Edit_Begin := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last));
+ Result.Parse_Begin_Char_Pos := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last));
+ Result.Parse_Begin_Line := WisiToken.Line_Number_Type
(Get_Integer (Command_Line, Last));
+ Result.Parse_End_Line := WisiToken.Line_Number_Type
(Get_Integer (Command_Line, Last));
+ Result.Debug_Mode := 1 = Get_Integer (Command_Line, Last);
+ Result.Parse_Verbosity := Get_Integer (Command_Line, Last);
+ Result.Action_Verbosity := Get_Integer (Command_Line, Last);
+ Result.Max_Parallel := Get_Integer (Command_Line, Last);
+ Result.Byte_Count := Get_Integer (Command_Line, Last);
+ end return;
+ end Get_Refactor_Params;
+
+ procedure Process_Stream
+ (Name : in String;
+ Language_Protocol_Version : in String;
+ Partial_Parse_Active : in out Boolean;
+ Params : in Process_Start_Params;
+ Parser : in out WisiToken.Parse.LR.Parser.Parser;
+ Parse_Data : in out Wisi.Parse_Data_Type'Class;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ use Ada.Text_IO;
+ use WisiToken; -- "+", "-" Unbounded_string
+
+ procedure Cleanup
+ is begin
+ if Is_Open (Parser.Recover_Log_File) then
+ Close (Parser.Recover_Log_File);
+ end if;
+ end Cleanup;
+
+ begin
+ declare
+ use Ada.Directories;
+ use Ada.Strings.Unbounded;
+ begin
+ if Length (Params.Recover_Log_File_Name) > 0 then
+ Put_Line (";; logging to '" & (-Params.Recover_Log_File_Name) &
"'");
+ -- to Current_Output, visible from Emacs
+
+ if Exists (-Params.Recover_Log_File_Name) then
+ Open (Parser.Recover_Log_File, Append_File,
-Params.Recover_Log_File_Name);
+ else
+ Create (Parser.Recover_Log_File, Out_File,
-Params.Recover_Log_File_Name);
+ end if;
+ end if;
+ end;
+
+ Parser.Trace.Set_Prefix (";; "); -- so debug messages don't confuse
Emacs.
+
+ Put_Line
+ (Name & " protocol: process version " & Protocol_Version & " language
version " & Language_Protocol_Version);
+
+ -- Read commands and tokens from standard_input via GNAT.OS_Lib,
+ -- send results to standard_output.
+ loop
+ Put (Prompt); Flush;
+ declare
+ Command_Length : constant Integer := Get_Command_Length;
+ Command_Line : aliased String (1 .. Command_Length);
+ Last : Integer;
+
+ function Match (Target : in String) return Boolean
+ is begin
+ Last := Command_Line'First + Target'Length - 1;
+ return Last <= Command_Line'Last and then Command_Line
(Command_Line'First .. Last) = Target;
+ end Match;
+ begin
+ Read_Input (Command_Line'Address, Command_Length);
+
+ Put_Line (";; " & Command_Line);
+
+ if Match ("parse") then
+ -- Args: see wisi-process-parse.el
wisi-process-parse--send-parse
+ -- Input: <source text>
+ -- Response:
+ -- [response elisp vector]...
+ -- [elisp error form]...
+ -- prompt
+ declare
+ Params : constant Parse_Params := Get_Parse_Params
(Command_Line, Last);
+ Buffer : Ada.Strings.Unbounded.String_Access;
+
+ procedure Clean_Up
+ is
+ use all type SAL.Base_Peek_Type;
+ begin
+ Parser.Lexer.Discard_Rest_Of_Input;
+ if Parser.Parsers.Count > 0 then
+ Parse_Data.Put
+ (Parser.Lexer.Errors,
+ Parser.Parsers.First.State_Ref.Errors,
+ Parser.Parsers.First.State_Ref.Tree);
+ end if;
+ Ada.Strings.Unbounded.Free (Buffer);
+ end Clean_Up;
+
+ begin
+ Trace_Parse := Params.Parse_Verbosity;
+ Trace_McKenzie := Params.McKenzie_Verbosity;
+ Trace_Action := Params.Action_Verbosity;
+ Debug_Mode := Params.Debug_Mode;
+
+ Partial_Parse_Active := Params.Partial_Parse_Active;
+
+ if WisiToken.Parse.LR.McKenzie_Defaulted (Parser.Table.all)
then
+ -- There is no McKenzie information; don't override that.
+ null;
+ elsif Params.McKenzie_Disable = -1 then
+ -- Use default
+ Parser.Enable_McKenzie_Recover := True;
+ else
+ Parser.Enable_McKenzie_Recover := Params.McKenzie_Disable
= 0;
+ end if;
+
+ Parse_Data.Initialize
+ (Post_Parse_Action => Params.Post_Parse_Action,
+ Lexer => Parser.Lexer,
+ Descriptor => Descriptor'Unrestricted_Access,
+ Base_Terminals => Parser.Terminals'Unrestricted_Access,
+ Begin_Line => Params.Begin_Line,
+ End_Line => Params.End_Line,
+ Begin_Indent => Params.Begin_Indent,
+ Params => Command_Line (Last + 2 ..
Command_Line'Last));
+
+ if Params.Task_Count > 0 then
+ Parser.Table.McKenzie_Param.Task_Count :=
System.Multiprocessors.CPU_Range (Params.Task_Count);
+ end if;
+ if Params.Check_Limit > 0 then
+ Parser.Table.McKenzie_Param.Check_Limit :=
Base_Token_Index (Params.Check_Limit);
+ end if;
+ if Params.Enqueue_Limit > 0 then
+ Parser.Table.McKenzie_Param.Enqueue_Limit :=
Params.Enqueue_Limit;
+ end if;
+
+ if Params.Max_Parallel > 0 then
+ Parser.Max_Parallel := SAL.Base_Peek_Type
(Params.Max_Parallel);
+ end if;
+
+ Buffer := new String (Params.Begin_Byte_Pos ..
Params.End_Byte_Pos);
+
+ Read_Input (Buffer (Params.Begin_Byte_Pos)'Address,
Params.Byte_Count);
+
+ Parser.Lexer.Reset_With_String_Access
+ (Buffer, Params.Source_File_Name, Params.Begin_Char_Pos,
Params.Begin_Line);
+ begin
+ Parser.Parse;
+ exception
+ when WisiToken.Partial_Parse =>
+ null;
+ end;
+ Parser.Execute_Actions;
+ Parse_Data.Put (Parser);
+ Clean_Up;
+
+ exception
+ when Syntax_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error)");
+
+ when E : Parse_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error """ &
Ada.Exceptions.Exception_Message (E) & """)");
+
+ when E : Fatal_Error =>
+ Clean_Up;
+ Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E)
& """)");
+ end;
+
+ elsif Match ("refactor") then
+ -- Args: see wisi-process-parse.el
wisi-process-parse--send-refactor
+ -- Input: <source text>
+ -- Response:
+ -- [edit elisp vector]...
+ -- prompt
+ declare
+ Params : constant Refactor_Params := Get_Refactor_Params
(Command_Line, Last);
+ Buffer : Ada.Strings.Unbounded.String_Access;
+
+ procedure Clean_Up
+ is
+ use all type SAL.Base_Peek_Type;
+ begin
+ Parser.Lexer.Discard_Rest_Of_Input;
+ if Parser.Parsers.Count > 0 then
+ Parse_Data.Put
+ (Parser.Lexer.Errors,
+ Parser.Parsers.First.State_Ref.Errors,
+ Parser.Parsers.First.State_Ref.Tree);
+ end if;
+ Ada.Strings.Unbounded.Free (Buffer);
+ end Clean_Up;
+
+ begin
+ Trace_Parse := Params.Parse_Verbosity;
+ Trace_Action := Params.Action_Verbosity;
+ Debug_Mode := Params.Debug_Mode;
+
+ Partial_Parse_Active := True;
+
+ Parse_Data.Initialize
+ (Post_Parse_Action => Wisi.Navigate, -- mostly ignored
+ Lexer => Parser.Lexer,
+ Descriptor => Descriptor'Unrestricted_Access,
+ Base_Terminals => Parser.Terminals'Unrestricted_Access,
+ Begin_Line => Params.Parse_Begin_Line,
+ End_Line => Params.Parse_End_Line,
+ Begin_Indent => 0,
+ Params => "");
+
+ if Params.Max_Parallel > 0 then
+ Parser.Max_Parallel := SAL.Base_Peek_Type
(Params.Max_Parallel);
+ end if;
+
+ Buffer := new String (Integer (Params.Parse_Region.First) ..
Integer (Params.Parse_Region.Last));
+
+ Read_Input (Buffer (Buffer'First)'Address,
Params.Byte_Count);
+
+ Parser.Lexer.Reset_With_String_Access
+ (Buffer, Params.Source_File_Name,
Params.Parse_Begin_Char_Pos, Params.Parse_Begin_Line);
+ begin
+ Parser.Parse;
+ exception
+ when WisiToken.Partial_Parse =>
+ null;
+ end;
+ Parser.Execute_Actions;
+ Parse_Data.Refactor (Parser.Parsers.First_State_Ref.Tree,
Params.Refactor_Action, Params.Edit_Begin);
+ Clean_Up;
+
+ exception
+ when Syntax_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error ""refactor " &
Params.Parse_Region.First'Image &
+ Params.Parse_Region.Last'Image & ": syntax
error"")");
+
+ when E : Parse_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error ""refactor " &
Params.Parse_Region.First'Image &
+ Params.Parse_Region.Last'Image & ": " &
Ada.Exceptions.Exception_Message (E) & """)");
+
+ when E : others => -- includes Fatal_Error
+ Clean_Up;
+ Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E)
& """)");
+ end;
+
+ elsif Match ("noop") then
+ -- Args: <source byte count>
+ -- Input: <source text>
+ -- Response: prompt
+ declare
+ Byte_Count : constant Integer
:= Get_Integer (Command_Line, Last);
+ Buffer : constant Ada.Strings.Unbounded.String_Access
:= new String (1 .. Byte_Count);
+ Token : Base_Token;
+ Lexer_Error : Boolean;
+ pragma Unreferenced (Lexer_Error);
+ begin
+ Token.ID := Invalid_Token_ID;
+ Read_Input (Buffer (1)'Address, Byte_Count);
+
+ Parser.Lexer.Reset_With_String_Access (Buffer, +"");
+ loop
+ exit when Token.ID = Parser.Trace.Descriptor.EOI_ID;
+ Lexer_Error := Parser.Lexer.Find_Next (Token);
+ end loop;
+ exception
+ when Syntax_Error =>
+ Parser.Lexer.Discard_Rest_Of_Input;
+ end;
+
+ elsif Match ("quit") then
+ exit;
+
+ else
+ Put_Line ("(error ""bad command: '" & Command_Line & "'"")");
+ end if;
+ exception
+ when E : Protocol_Error =>
+ -- don't exit the loop; allow debugging bad elisp
+ Put_Line ("(error ""protocol error "": " &
Ada.Exceptions.Exception_Message (E) & """)");
+ end;
+ end loop;
+ Cleanup;
+ exception
+ when Finish =>
+ null;
+
+ when E : others =>
+ Cleanup;
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ New_Line (2);
+ Put_Line
+ ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E)
& ": " &
+ Ada.Exceptions.Exception_Message (E) & """)");
+ Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
+
+ end Process_Stream;
+
+end Emacs_Wisi_Common_Parse;
diff --git a/emacs_wisi_common_parse.ads b/emacs_wisi_common_parse.ads
new file mode 100644
index 0000000..1d75de6
--- /dev/null
+++ b/emacs_wisi_common_parse.ads
@@ -0,0 +1,154 @@
+-- Abstract :
+--
+-- Common utilities for Gen_Emacs_Wisi_*_Parse
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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.Strings.Unbounded;
+with System;
+with Wisi;
+with WisiToken.Parse.LR.Parser;
+package Emacs_Wisi_Common_Parse is
+
+ Protocol_Version : constant String := "4";
+ -- Protocol_Version defines the data sent between elisp and the
+ -- background process, except for the language-specific parameters,
+ -- which are defined by the Language_Protocol_Version parameter to
+ -- Parse_Stream, below.
+ --
+ -- This value must match wisi-process-parse.el
+ -- wisi-process-parse-protocol-version.
+ --
+ -- See wisi-process-parse.el functions, and this package body, for
+ -- the implementation of the protocol.
+ --
+ -- Only changes once per wisi release. Increment as soon as required,
+ -- record new version in NEWS-wisi.text.
+
+ Prompt : constant String := ";;> ";
+
+ Protocol_Error : exception;
+ Finish : exception;
+
+ procedure Usage (Name : in String);
+
+ procedure Read_Input (A : System.Address; N : Integer);
+
+ function Get_Command_Length return Integer;
+
+ function Get_String
+ (Source : in String;
+ Last : in out Integer)
+ return String;
+
+ function Get_Integer
+ (Source : in String;
+ Last : in out Integer)
+ return Integer;
+
+ type Process_Start_Params is record
+ Recover_Log_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ -- log enabled if non-empty.
+ end record;
+
+ function Get_Process_Start_Params return Process_Start_Params;
+ -- Get from Ada.Command_Line. Handles --help by outputing help,
+ -- raising Finish.
+
+ procedure Process_Stream
+ (Name : in String;
+ Language_Protocol_Version : in String;
+ Partial_Parse_Active : in out Boolean;
+ Params : in Process_Start_Params;
+ Parser : in out WisiToken.Parse.LR.Parser.Parser;
+ Parse_Data : in out Wisi.Parse_Data_Type'Class;
+ Descriptor : in WisiToken.Descriptor);
+
+ ----------
+ -- Parse command
+
+ type Parse_Params is record
+ Post_Parse_Action : Wisi.Post_Parse_Action_Type;
+ Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+
+ Begin_Byte_Pos : Integer;
+ -- Source file byte position of first char sent; start parse here.
+
+ End_Byte_Pos : Integer;
+ -- Byte position of last char sent.
+
+ Goal_Byte_Pos : Integer;
+ -- Byte position of end of desired parse region; terminate parse at
+ -- or after here.
+
+ Begin_Char_Pos : WisiToken.Buffer_Pos;
+ -- Char position of first char sent.
+
+ Begin_Line : WisiToken.Line_Number_Type;
+ End_Line : WisiToken.Line_Number_Type;
+ -- Line number of line containing Begin_Byte_Pos, End_Byte_Pos
+
+ Begin_Indent : Integer;
+ -- Indentation of Line_Begin
+
+ Partial_Parse_Active : Boolean;
+ Debug_Mode : Boolean;
+ Parse_Verbosity : Integer;
+ McKenzie_Verbosity : Integer;
+ Action_Verbosity : Integer;
+ McKenzie_Disable : Integer;
+ Task_Count : Integer;
+ Check_Limit : Integer;
+ Enqueue_Limit : Integer;
+ Max_Parallel : Integer;
+ Byte_Count : Integer;
+ -- Count of bytes of source file sent.
+ end record;
+
+ function Get_Parse_Params (Command_Line : in String; Last : in out Integer)
return Parse_Params;
+
+ ----------
+ -- Refactor command
+
+ type Refactor_Params is record
+ Refactor_Action : Positive; -- Language-specific
+ Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+
+ Parse_Region : WisiToken.Buffer_Region;
+ -- Source file byte region to parse.
+
+ Edit_Begin : WisiToken.Buffer_Pos;
+ -- Source file byte position at start of expression to refactor.
+
+ Parse_Begin_Char_Pos : WisiToken.Buffer_Pos;
+ -- Char position of first char sent.
+
+ Parse_Begin_Line : WisiToken.Line_Number_Type;
+ Parse_End_Line : WisiToken.Line_Number_Type;
+ -- Line numbers of lines containing Parse_Begin_Byte_Pos,
Parse_End_Byte_Pos
+
+ Debug_Mode : Boolean;
+ Parse_Verbosity : Integer;
+ Action_Verbosity : Integer;
+ Max_Parallel : Integer;
+ Byte_Count : Integer;
+ -- Count of bytes of source file sent.
+ end record;
+
+ function Get_Refactor_Params (Command_Line : in String; Last : in out
Integer) return Refactor_Params;
+
+end Emacs_Wisi_Common_Parse;
diff --git a/gen_emacs_wisi_lr_parse.adb b/gen_emacs_wisi_lr_parse.adb
new file mode 100644
index 0000000..951a871
--- /dev/null
+++ b/gen_emacs_wisi_lr_parse.adb
@@ -0,0 +1,39 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2014, 2017 - 2019 All Rights Reserved.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 Emacs_Wisi_Common_Parse; use Emacs_Wisi_Common_Parse;
+with WisiToken.Parse.LR.Parser;
+with WisiToken.Text_IO_Trace;
+procedure Gen_Emacs_Wisi_LR_Parse
+is
+ Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
+ Parser : WisiToken.Parse.LR.Parser.Parser;
+ Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
+
+ Params : constant Process_Start_Params := Get_Process_Start_Params;
+begin
+ Create_Parser
+ (Parser, Language_Fixes, Language_Matching_Begin_Tokens,
Language_String_ID_Set,
+ Trace'Unrestricted_Access,
+ Parse_Data'Unchecked_Access);
+
+ Process_Stream (Name, Language_Protocol_Version, Partial_Parse_Active,
Params, Parser, Parse_Data, Descriptor);
+
+end Gen_Emacs_Wisi_LR_Parse;
diff --git a/gen_emacs_wisi_lr_parse.ads b/gen_emacs_wisi_lr_parse.ads
new file mode 100644
index 0000000..02eac21
--- /dev/null
+++ b/gen_emacs_wisi_lr_parse.ads
@@ -0,0 +1,55 @@
+-- Abstract :
+--
+-- Generic Emacs background process; parse token stream, return
+-- parser actions.
+--
+-- See gen_run_wisi_parse.ads for a standalone version.
+--
+-- References :
+--
+-- [1] On the elisp side, the inter-process protocol is defined in
+-- wisi-process-parse.el, functions wisi-process-parse--send-parse
+-- and wisi-process-parse--execute.
+--
+-- [2] On the Ada side, it is defined here, and in
+-- wisitoken-wisi_runtime.adb
+--
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 WisiToken.Parse.LR.Parser;
+with WisiToken.Syntax_Trees;
+with Wisi;
+generic
+ type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
+
+ Name : in String; -- for Usage, error messages.
+ Language_Protocol_Version : in String; -- Defines language-specific
parse parameters.
+ Descriptor : in WisiToken.Descriptor;
+ Partial_Parse_Active : in out Boolean;
+ Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+
+ with procedure Create_Parser
+ (Parser : out
WisiToken.Parse.LR.Parser.Parser;
+ Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+ Trace : not null access WisiToken.Trace'Class;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access);
+
+procedure Gen_Emacs_Wisi_LR_Parse;
diff --git a/gen_emacs_wisi_lr_text_rep_parse.adb
b/gen_emacs_wisi_lr_text_rep_parse.adb
new file mode 100644
index 0000000..f74144c
--- /dev/null
+++ b/gen_emacs_wisi_lr_text_rep_parse.adb
@@ -0,0 +1,44 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2014, 2017 - 2019 All Rights Reserved.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 Emacs_Wisi_Common_Parse; use Emacs_Wisi_Common_Parse;
+
+with WisiToken.Text_IO_Trace;
+procedure Gen_Emacs_Wisi_LR_Text_Rep_Parse
+is
+ use WisiToken; -- "+", "-" Unbounded_string
+
+ Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
+ Parser : WisiToken.Parse.LR.Parser.Parser;
+ Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
+
+ Params : constant Process_Start_Params := Get_Process_Start_Params;
+begin
+ Create_Parser
+ (Parser, Language_Fixes, Language_Matching_Begin_Tokens,
Language_String_ID_Set,
+ Trace'Unrestricted_Access,
+ Parse_Data'Unchecked_Access,
+ Ada.Directories.Containing_Directory (Ada.Command_Line.Command_Name) &
"/" & Text_Rep_File_Name);
+
+ Process_Stream (Name, Language_Protocol_Version, Partial_Parse_Active,
Params, Parser, Parse_Data, Descriptor);
+
+end Gen_Emacs_Wisi_LR_Text_Rep_Parse;
diff --git a/gen_emacs_wisi_lr_text_rep_parse.ads
b/gen_emacs_wisi_lr_text_rep_parse.ads
new file mode 100644
index 0000000..f9ff468
--- /dev/null
+++ b/gen_emacs_wisi_lr_text_rep_parse.ads
@@ -0,0 +1,50 @@
+-- Abstract :
+--
+-- Generic Emacs background process; parse token stream, return
+-- parser actions.
+--
+-- See gen_run_wisi_parse.ads for a standalone version.
+--
+-- References : see gen_emacs_wisi_lr_parse.ads
+--
+-- Copyright (C) 2017, 2018, 2019 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 WisiToken.Parse.LR.Parser;
+with WisiToken.Syntax_Trees;
+with Wisi;
+generic
+ type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
+
+ Name : in String; -- for Usage, error messages.
"_wisi_parse" will be appended
+ Language_Protocol_Version : in String; -- Defines language-specific
parse parameters.
+ Descriptor : in WisiToken.Descriptor;
+ Partial_Parse_Active : in out Boolean;
+ Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+ Text_Rep_File_Name : in String;
+
+ with procedure Create_Parser
+ (Parser : out
WisiToken.Parse.LR.Parser.Parser;
+ Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+ Trace : not null access WisiToken.Trace'Class;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
+ Text_Rep_File_Name : in String);
+
+procedure Gen_Emacs_Wisi_LR_Text_Rep_Parse;
diff --git a/gen_emacs_wisi_packrat_parse.adb b/gen_emacs_wisi_packrat_parse.adb
new file mode 100644
index 0000000..b4e95f6
--- /dev/null
+++ b/gen_emacs_wisi_packrat_parse.adb
@@ -0,0 +1,180 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 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.Command_Line;
+with Ada.Exceptions;
+with Ada.Strings.Fixed;
+with Ada.Strings.Unbounded;
+with Ada.Text_IO; use Ada.Text_IO;
+with Emacs_Wisi_Common_Parse; use Emacs_Wisi_Common_Parse;
+with GNAT.OS_Lib;
+with GNAT.Traceback.Symbolic;
+with System.Storage_Elements;
+with WisiToken.Lexer;
+with WisiToken.Parse.Packrat;
+with WisiToken.Text_IO_Trace;
+procedure Gen_Emacs_Wisi_Parse_Packrat
+is
+ use WisiToken; -- "+", "-" Unbounded_string
+
+ Trace : aliased WisiToken.Text_IO_Trace.Trace (Descriptor'Access);
+ Parser : WisiToken.Parse.Packrat.Parser;
+ Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
+
+begin
+ Create_Parser (Parser, Trace'Unrestricted_Access,
Parse_Data'Unchecked_Access);
+
+ declare
+ use Ada.Command_Line;
+ begin
+ case Argument_Count is
+ when 0 =>
+ null;
+
+ when others =>
+ Usage (Name);
+ raise Programmer_Error with "invalid option count: " & Integer'Image
(Argument_Count);
+ end case;
+ end;
+
+ Put_Line (Name & " " & Version & ", protocol version " & Protocol_Version);
+
+ -- Read commands and tokens from standard_input via GNAT.OS_Lib,
+ -- send results to standard_output.
+ loop
+ Put (Prompt); Flush;
+ declare
+ Command_Length : constant Integer := Get_Command_Length;
+ Command_Line : aliased String (1 .. Command_Length);
+ Last : Integer;
+
+ function Match (Target : in String) return Boolean
+ is begin
+ Last := Command_Line'First + Target'Length - 1;
+ return Last <= Command_Line'Last and then Command_Line
(Command_Line'First .. Last) = Target;
+ end Match;
+ begin
+ Read_Input (Command_Line'Address, Command_Length);
+
+ Put_Line (";; " & Command_Line);
+
+ if Match ("parse") then
+ -- Args: see Usage
+ -- Input: <source text>
+ -- Response:
+ -- [response elisp vector]...
+ -- [elisp error form]...
+ -- prompt
+ declare
+ use Wisi;
+ Cl_Params : constant Command_Line_Params := Get_Cl_Params
(Command_Line, Last);
+ Buffer : Ada.Strings.Unbounded.String_Access;
+
+ procedure Clean_Up
+ is begin
+ Parser.Lexer.Discard_Rest_Of_Input;
+ Parser.Put_Errors (-Cl_Param.Source_File_Name);
+ Ada.Strings.Unbounded.Free (Buffer);
+ end Clean_Up;
+
+ begin
+ -- Computing Line_Count in elisp allows parsing in parallel
with
+ -- sending source text.
+
+ Trace_Parse := Cl_Params.Parse_Verbosity;
+ Trace_McKenzie := Cl_Params.McKenzie_Verbosity;
+ Trace_Action := Cl_Params.Action_Verbosity;
+ Debug_Mode := Cl_Params.Debug_Mode;
+
+ Parse_Data.Initialize
+ (Post_Parse_Action => Cl_Params.Post_Parse_Action,
+ Descriptor => Descriptor'Access,
+ Source_File_Name => -Cl_Params.Source_File_Name,
+ Line_Count => Cl_Params.Line_Count,
+ Params => Command_Line (Last + 2 ..
Command_Line'Last));
+
+ Buffer := new String (1 .. Cl_Params.Byte_Count);
+ Read_Input (Buffer (1)'Address, Cl_Params.Byte_Count);
+
+ Parser.Lexer.Reset_With_String_Access (Buffer);
+ Parser.Parse;
+ Parser.Execute_Actions;
+ Put (Parse_Data);
+ Clean_Up;
+
+ exception
+ when Syntax_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error)");
+
+ when E : Parse_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error """ & Ada.Exceptions.Exception_Message
(E) & """)");
+
+ when E : Fatal_Error =>
+ Clean_Up;
+ Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E) &
""")");
+ end;
+
+ elsif Match ("noop") then
+ -- Args: <source byte count>
+ -- Input: <source text>
+ -- Response: prompt
+ declare
+ Byte_Count : constant Integer :=
Get_Integer (Command_Line, Last);
+ Buffer : constant Ada.Strings.Unbounded.String_Access :=
new String (1 .. Byte_Count);
+ Token : Base_Token;
+ Lexer_Error : Boolean;
+ pragma Unreferenced (Lexer_Error);
+ begin
+ Token.ID := Invalid_Token_ID;
+ Read_Input (Buffer (1)'Address, Byte_Count);
+
+ Parser.Lexer.Reset_With_String_Access (Buffer);
+ loop
+ exit when Token.ID = Parser.Trace.Descriptor.EOF_ID;
+ Lexer_Error := Parser.Lexer.Find_Next (Token);
+ end loop;
+ exception
+ when Syntax_Error =>
+ Parser.Lexer.Discard_Rest_Of_Input;
+ end;
+
+ elsif Match ("quit") then
+ exit;
+
+ else
+ Put_Line ("(error ""bad command: '" & Command_Line & "'"")");
+ end if;
+ exception
+ when E : Protocol_Error =>
+ -- don't exit the loop; allow debugging bad elisp
+ Put_Line ("(error ""protocol error "": " &
Ada.Exceptions.Exception_Message (E) & """)");
+ end;
+ end loop;
+exception
+when E : others =>
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ New_Line (2);
+ Put_Line
+ ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E) &
": " &
+ Ada.Exceptions.Exception_Message (E) & """)");
+ Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
+end Gen_Emacs_Wisi_Parse_Packrat;
diff --git a/gen_emacs_wisi_packrat_parse.ads b/gen_emacs_wisi_packrat_parse.ads
new file mode 100644
index 0000000..79c69ec
--- /dev/null
+++ b/gen_emacs_wisi_packrat_parse.ads
@@ -0,0 +1,42 @@
+-- Abstract :
+--
+-- Generic Emacs background process; packrat parse token stream,
+-- return parser actions.
+--
+-- See gen_run_wisi_parse_packrat.ads for a standalone version.
+--
+-- References :
+--
+-- See gen_emacs_wisi_parse.ads
+--
+-- Copyright (C) 2018 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 WisiToken.Parse.Packrat;
+with WisiToken.Syntax_Trees;
+with WisiToken.Wisi_Runtime;
+generic
+ type Parse_Data_Type is new WisiToken.Wisi_Runtime.Parse_Data_Type with
private;
+
+ Name : in String; -- for Usage, error messages.
"_wisi_parse_packrat" will be appended
+ Descriptor : in WisiToken.Descriptor;
+
+ with procedure Create_Parser
+ (Parser : out WisiToken.Parse.Packrat.Parser;
+ Trace : not null access WisiToken.Trace'Class;
+ User_Data : in WisiToken.Syntax_Trees.User_Data_Access);
+
+procedure Gen_Emacs_Wisi_Parse_Packrat;
diff --git a/gen_run_wisi_libadalang_parse.adb
b/gen_run_wisi_libadalang_parse.adb
new file mode 100644
index 0000000..c154136
--- /dev/null
+++ b/gen_run_wisi_libadalang_parse.adb
@@ -0,0 +1,176 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 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.Command_Line;
+with Ada.Exceptions;
+with Ada.Real_Time;
+with Ada.Strings.Unbounded;
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.Traceback.Symbolic;
+with Wisi.Libadalang;
+with WisiToken.Text_IO_Trace;
+procedure Gen_Run_Wisi_Libadalang_Parse
+is
+ use WisiToken; -- Token_ID, "+", "-" Unbounded_string
+
+ Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
+ Parser : Wisi.Libadalang.Parser;
+ Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
+
+ procedure Put_Usage
+ is begin
+ Put_Line ("usage: <file_name> <parse_action> [options]");
+ Put_Line ("parse_action: {Navigate | Face | Indent}");
+ Put_Line ("options:");
+ Put_Line ("--verbosity n m : parse, action");
+ Put_Line ("--lang_params <language-specific params>");
+ Put_Line ("--repeat_count n : repeat parse count times, for profiling;
default 1");
+ New_Line;
+ end Put_Usage;
+
+ Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Post_Parse_Action : Wisi.Post_Parse_Action_Type;
+ Lang_Params : Ada.Strings.Unbounded.Unbounded_String;
+
+ Repeat_Count : Integer := 1;
+ Arg : Integer;
+ Start : Ada.Real_Time.Time;
+
+begin
+ declare
+ use Ada.Command_Line;
+ begin
+ if Argument_Count < 1 then
+ Put_Usage;
+ Set_Exit_Status (Failure);
+ return;
+ end if;
+
+ Source_File_Name := +Ada.Command_Line.Argument (1);
+ Post_Parse_Action := Wisi.Post_Parse_Action_Type'Value
(Ada.Command_Line.Argument (2));
+ Arg := 3;
+
+ loop
+ exit when Arg > Argument_Count;
+
+ if Argument (Arg) = "--lang_params" then
+ Lang_Params := +Argument (Arg + 1);
+ Arg := Arg + 2;
+
+ elsif Argument (Arg) = "--repeat_count" then
+ Repeat_Count := Integer'Value (Argument (Arg + 1));
+ Arg := Arg + 2;
+
+ elsif Argument (Arg) = "--verbosity" then
+ WisiToken.Trace_Parse := Integer'Value (Argument (Arg + 1));
+ WisiToken.Trace_Action := Integer'Value (Argument (Arg + 2));
+ Arg := Arg + 3;
+
+ else
+ Put_Line ("unrecognized option: '" & Argument (Arg) & "'");
+ Put_Usage;
+ return;
+ end if;
+ end loop;
+ end;
+
+ Parser.Trace := Trace'Unrestricted_Access;
+ Parser.Lexer := new Wisi.Libadalang.Lexer
(Trace'Unrestricted_Access);
+ Parser.User_Data := Parse_Data'Unrestricted_Access;
+ Parser.Source_File_Name := Source_File_Name;
+
+ Parser.Tree.Initialize (Shared_Tree =>
Parser.Base_Tree'Unrestricted_Access, Flush => True);
+
+ Parse_Data.Initialize
+ (Post_Parse_Action => Post_Parse_Action,
+ Descriptor => Descriptor'Unrestricted_Access,
+ Source_File_Name => -Source_File_Name,
+ Line_Count => 1, -- FIXME: fix wisi_runtime to not need this!
+ Params => -Lang_Params);
+
+ if Repeat_Count > 1 then
+ Start := Ada.Real_Time.Clock;
+ end if;
+
+ for I in 1 .. Repeat_Count loop
+ declare
+ procedure Clean_Up
+ is begin
+ if I = 1 then
+ null;
+ -- FIXME: Errors!
+ -- Parse_Data.Put
+ -- (Parser.Lexer.Errors,
+ -- Parser.Parsers.First.State_Ref.Errors,
+ -- Parser.Parsers.First.State_Ref.Tree);
+ end if;
+ end Clean_Up;
+
+ begin
+ Parse_Data.Reset;
+ Parser.Parse;
+ Parser.Execute_Actions;
+
+ if Repeat_Count = 1 then
+ Parse_Data.Put;
+
+ -- FIXME: put errors via parse_data.put
+ if Parser.Any_Errors then
+ Parser.Put_Errors;
+ end if;
+ -- Parse_Data.Put
+ -- (Parser.Lexer.Errors,
+ -- Parser.Parsers.First.State_Ref.Errors,
+ -- Parser.Parsers.First.State_Ref.Tree);
+ end if;
+ exception
+ when WisiToken.Syntax_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error)");
+
+ when E : WisiToken.Parse_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error """ & Ada.Exceptions.Exception_Message (E) &
""")");
+
+ when E : WisiToken.Fatal_Error =>
+ Clean_Up;
+ Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E) & """)");
+ end;
+ end loop;
+
+ if Repeat_Count > 1 then
+ declare
+ use Ada.Real_Time;
+ Finish : constant Time := Clock;
+ begin
+ Put_Line ("Total time:" & Duration'Image (To_Duration (Finish -
Start)));
+ Put_Line ("per iteration:" & Duration'Image (To_Duration ((Finish -
Start) / Repeat_Count)));
+ end;
+ end if;
+
+exception
+when E : others =>
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ New_Line (2);
+ Put_Line
+ ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E) &
": " &
+ Ada.Exceptions.Exception_Message (E) & """)");
+ Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
+end Gen_Run_Wisi_Libadalang_Parse;
diff --git a/gen_run_wisi_libadalang_parse.ads
b/gen_run_wisi_libadalang_parse.ads
new file mode 100644
index 0000000..356c67d
--- /dev/null
+++ b/gen_run_wisi_libadalang_parse.ads
@@ -0,0 +1,30 @@
+-- Abstract :
+--
+-- Run an Emacs libadalang parser as a standalone executable, for debugging.
+--
+-- See gen_emacs_wisi_libadalang_parse.ads for the Emacs background process.
+--
+-- Copyright (C) 2018 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 Wisi;
+with WisiToken;
+generic
+ type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
+
+ Descriptor : in WisiToken.Descriptor;
+
+procedure Gen_Run_Wisi_Libadalang_Parse;
diff --git a/gen_run_wisi_lr_parse.adb b/gen_run_wisi_lr_parse.adb
new file mode 100644
index 0000000..ee63c77
--- /dev/null
+++ b/gen_run_wisi_lr_parse.adb
@@ -0,0 +1,37 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017 - 2019 All Rights Reserved.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 Run_Wisi_Common_Parse;
+with WisiToken.Text_IO_Trace;
+procedure Gen_Run_Wisi_LR_Parse
+is
+ Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
+ Parser : WisiToken.Parse.LR.Parser.Parser;
+ Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
+begin
+ -- Create parser first so Put_Usage has defaults from Parser.Table,
+ -- and Get_CL_Params can override them.
+ Create_Parser
+ (Parser, Language_Fixes, Language_Matching_Begin_Tokens,
Language_String_ID_Set,
+ Trace'Unrestricted_Access, Parse_Data'Unchecked_Access);
+
+ Run_Wisi_Common_Parse.Parse_File (Parser, Parse_Data, Descriptor);
+
+end Gen_Run_Wisi_LR_Parse;
diff --git a/gen_run_wisi_lr_parse.ads b/gen_run_wisi_lr_parse.ads
new file mode 100644
index 0000000..34fbd3c
--- /dev/null
+++ b/gen_run_wisi_lr_parse.ads
@@ -0,0 +1,42 @@
+-- Abstract :
+--
+-- Run an Emacs LR parser as a standalone executable, for debugging.
+--
+-- See gen_emacs_wisi_lr_parse.ads for the Emacs background process.
+--
+-- Copyright (C) 2017, 2018, 2019 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 WisiToken.Parse.LR.Parser;
+with WisiToken.Syntax_Trees;
+with Wisi;
+generic
+ type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
+
+ Descriptor : in WisiToken.Descriptor;
+ Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+
+ with procedure Create_Parser
+ (Parser : out
WisiToken.Parse.LR.Parser.Parser;
+ Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+ Trace : not null access WisiToken.Trace'Class;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access);
+
+procedure Gen_Run_Wisi_LR_Parse;
diff --git a/gen_run_wisi_lr_text_rep_parse.adb
b/gen_run_wisi_lr_text_rep_parse.adb
new file mode 100644
index 0000000..09efefd
--- /dev/null
+++ b/gen_run_wisi_lr_text_rep_parse.adb
@@ -0,0 +1,44 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017 - 2019 All Rights Reserved.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 Run_Wisi_Common_Parse;
+with WisiToken.Text_IO_Trace;
+procedure Gen_Run_Wisi_LR_Text_Rep_Parse
+is
+ Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
+ Parser : WisiToken.Parse.LR.Parser.Parser;
+ Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
+begin
+ -- Create parser first so Put_Usage has defaults from Parser.Table,
+ -- and Get_CL_Params can override them.
+ declare
+ use Ada.Command_Line;
+ begin
+ -- text_rep file is in same directory as exectuable.
+ Create_Parser
+ (Parser, Language_Fixes, Language_Matching_Begin_Tokens,
Language_String_ID_Set,
+ Trace'Unrestricted_Access, Parse_Data'Unchecked_Access,
+ Ada.Directories.Containing_Directory (Command_Name) & "/" &
Text_Rep_File_Name);
+
+ Run_Wisi_Common_Parse.Parse_File (Parser, Parse_Data, Descriptor);
+ end;
+end Gen_Run_Wisi_LR_Text_Rep_Parse;
diff --git a/gen_run_wisi_lr_text_rep_parse.ads
b/gen_run_wisi_lr_text_rep_parse.ads
new file mode 100644
index 0000000..dd45d16
--- /dev/null
+++ b/gen_run_wisi_lr_text_rep_parse.ads
@@ -0,0 +1,44 @@
+-- Abstract :
+--
+-- Run an Emacs LR text_rep parser as a standalone executable, for debugging.
+--
+-- See gen_emacs_wisi_*_parse.ads for the Emacs background process.
+--
+-- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 WisiToken.Parse.LR.Parser;
+with WisiToken.Syntax_Trees;
+with Wisi;
+generic
+ type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
+
+ Descriptor : in WisiToken.Descriptor;
+ Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+ Text_Rep_File_Name : in String;
+
+ with procedure Create_Parser
+ (Parser : out
WisiToken.Parse.LR.Parser.Parser;
+ Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
+ Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
+ Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
+ Trace : not null access WisiToken.Trace'Class;
+ User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
+ Text_Rep_File_Name : in String);
+
+procedure Gen_Run_Wisi_LR_Text_Rep_Parse;
diff --git a/gen_run_wisi_packrat_parse.adb b/gen_run_wisi_packrat_parse.adb
new file mode 100644
index 0000000..fb3e900
--- /dev/null
+++ b/gen_run_wisi_packrat_parse.adb
@@ -0,0 +1,241 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 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.Command_Line;
+with Ada.Exceptions;
+with Ada.IO_Exceptions;
+with Ada.Real_Time;
+with Ada.Strings.Unbounded;
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.Traceback.Symbolic;
+with WisiToken.Lexer;
+with WisiToken.Text_IO_Trace;
+procedure Gen_Run_Wisi_Parse_Packrat
+is
+ use WisiToken; -- Token_ID, "+", "-" Unbounded_string
+
+ Trace : aliased WisiToken.Text_IO_Trace.Trace (Descriptor'Access);
+ Parser : WisiToken.Parse.Packrat.Parser;
+ Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
+
+ procedure Put_Usage
+ is begin
+ Put_Line ("usage: " & Name & "_wisi_parse <file_name> <parse_action>
[options]");
+ Put_Line ("parse_action: {Navigate | Face | Indent}");
+ Put_Line ("options:");
+ Put_Line ("--verbosity n m l:");
+ Put_Line (" n: parser; m: mckenzie; l: action");
+ Put_Line (" 0 - only report parse errors");
+ Put_Line (" 1 - shows spawn/terminate parallel parsers, error recovery
enter/exit");
+ Put_Line (" 2 - add each parser cycle, error recovery enqueue/check");
+ Put_Line (" 3 - parse stack in each cycle, error recovery parse
actions");
+ Put_Line (" 4 - add lexer debug");
+ Put_Line ("--lang_params <language-specific params>");
+ Put_Line ("--lexer_only : only run lexer, for profiling");
+ Put_Line ("--repeat_count n : repeat parse count times, for profiling;
default 1");
+ Put_Line ("--pause : when repeating, prompt for <enter> after each
parse; allows seeing memory leaks");
+ New_Line;
+ end Put_Usage;
+
+ Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Post_Parse_Action : WisiToken.Wisi_Runtime.Post_Parse_Action_Type;
+
+ Line_Count : WisiToken.Line_Number_Type := 1;
+ Lexer_Only : Boolean := False;
+ Repeat_Count : Integer := 1;
+ Pause : Boolean := False;
+ Arg : Integer;
+ Lang_Params : Ada.Strings.Unbounded.Unbounded_String;
+ Start : Ada.Real_Time.Time;
+begin
+ Create_Parser (Parser, Trace'Unrestricted_Access,
Parse_Data'Unchecked_Access);
+
+ declare
+ use Ada.Command_Line;
+ begin
+ if Argument_Count < 1 then
+ Put_Usage;
+ Set_Exit_Status (Failure);
+ return;
+ end if;
+
+ Source_File_Name := +Ada.Command_Line.Argument (1);
+ Post_Parse_Action := WisiToken.Wisi_Runtime.Post_Parse_Action_Type'Value
(Ada.Command_Line.Argument (2));
+ Arg := 3;
+
+ loop
+ exit when Arg > Argument_Count;
+
+ if Argument (Arg) = "--verbosity" then
+ WisiToken.Trace_Parse := Integer'Value (Argument (Arg + 1));
+ WisiToken.Trace_McKenzie := Integer'Value (Argument (Arg + 2));
+ WisiToken.Trace_Action := Integer'Value (Argument (Arg + 3));
+ Arg := Arg + 4;
+
+ elsif Argument (Arg) = "--lang_params" then
+ Lang_Params := +Argument (Arg + 1);
+ Arg := Arg + 2;
+
+ elsif Argument (Arg) = "--lexer_only" then
+ Lexer_Only := True;
+ Arg := Arg + 1;
+
+ elsif Argument (Arg) = "--pause" then
+ Pause := True;
+ Arg := Arg + 1;
+
+ elsif Argument (Arg) = "--repeat_count" then
+ Repeat_Count := Integer'Value (Argument (Arg + 1));
+ Arg := Arg + 2;
+
+ else
+ Put_Line ("unrecognized option: '" & Argument (Arg) & "'");
+ Put_Usage;
+ return;
+ end if;
+ end loop;
+ end;
+
+ -- Do this after setting Trace_Parse so lexer verbosity is set
+ begin
+ Parser.Lexer.Reset_With_File (-Source_File_Name);
+ exception
+ when Ada.IO_Exceptions.Name_Error =>
+ Put_Line (Standard_Error, "'" & (-Source_File_Name) & "' cannot be
opened");
+ return;
+ end;
+
+ -- See comment in wisi-wisi_runtime.ads for why we still need this.
+ declare
+ Token : Base_Token;
+ Lexer_Error : Boolean;
+ pragma Unreferenced (Lexer_Error);
+ begin
+ loop
+ begin
+ Lexer_Error := Parser.Lexer.Find_Next (Token);
+ exit when Token.ID = Descriptor.EOF_ID;
+ exception
+ when WisiToken.Syntax_Error =>
+ Parser.Lexer.Discard_Rest_Of_Input;
+ Parser.Put_Errors (-Source_File_Name);
+ Put_Line ("(lexer_error)");
+ end;
+ end loop;
+ Line_Count := Token.Line;
+ end;
+
+ if WisiToken.Trace_Action > WisiToken.Outline then
+ Put_Line ("line_count:" & Line_Number_Type'Image (Line_Count));
+ end if;
+
+ Parse_Data.Initialize
+ (Post_Parse_Action => Post_Parse_Action,
+ Descriptor => Descriptor'Access,
+ Source_File_Name => -Source_File_Name,
+ Line_Count => Line_Count,
+ Params => -Lang_Params);
+
+ if Repeat_Count > 1 then
+ Start := Ada.Real_Time.Clock;
+ end if;
+
+ for I in 1 .. Repeat_Count loop
+ declare
+ procedure Clean_Up
+ is begin
+ Parser.Lexer.Discard_Rest_Of_Input;
+ if Repeat_Count = 1 then
+ Parser.Put_Errors (-Source_File_Name);
+ end if;
+ end Clean_Up;
+
+ begin
+ Parse_Data.Reset;
+ Parser.Lexer.Reset;
+
+ if Lexer_Only then
+ declare
+ Token : Base_Token;
+ Lexer_Error : Boolean;
+ pragma Unreferenced (Lexer_Error);
+ begin
+ Parser.Lexer.Reset;
+ loop
+ Lexer_Error := Parser.Lexer.Find_Next (Token);
+ exit when Token.ID = Descriptor.EOF_ID;
+ end loop;
+ -- We don't handle errors here; that was done in the count
lines loop
+ -- above.
+ end;
+ else
+ Parser.Parse;
+ Parser.Execute_Actions;
+
+ if Repeat_Count = 1 then
+ Parse_Data.Put;
+ Parser.Put_Errors (-Source_File_Name);
+ end if;
+ end if;
+ exception
+ when WisiToken.Syntax_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error)");
+
+ when E : WisiToken.Parse_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error """ & Ada.Exceptions.Exception_Message (E) &
""")");
+
+ when E : WisiToken.Fatal_Error =>
+ Clean_Up;
+ Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E) & """)");
+ end;
+
+ if Pause then
+ Put_Line ("Enter to continue:");
+ Flush (Standard_Output);
+ declare
+ Junk : constant String := Get_Line;
+ pragma Unreferenced (Junk);
+ begin
+ null;
+ end;
+ end if;
+ end loop;
+
+ if Repeat_Count > 1 then
+ declare
+ use Ada.Real_Time;
+ Finish : constant Time := Clock;
+ begin
+ Put_Line ("Total time:" & Duration'Image (To_Duration (Finish -
Start)));
+ Put_Line ("per iteration:" & Duration'Image (To_Duration ((Finish -
Start) / Repeat_Count)));
+ end;
+ end if;
+
+exception
+when E : others =>
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ New_Line (2);
+ Put_Line
+ ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E) &
": " &
+ Ada.Exceptions.Exception_Message (E) & """)");
+ Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
+end Gen_Run_Wisi_Parse_Packrat;
diff --git a/gen_run_wisi_packrat_parse.ads b/gen_run_wisi_packrat_parse.ads
new file mode 100644
index 0000000..538da1d
--- /dev/null
+++ b/gen_run_wisi_packrat_parse.ads
@@ -0,0 +1,36 @@
+-- Abstract :
+--
+-- Run an Emacs packrate parser as a standalone executable, for debugging.
+--
+-- See gen_emacs_wisi_parse_packrat.ads for the Emacs background process.
+--
+-- Copyright (C) 2018 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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 WisiToken.Parse.Packrat;
+with WisiToken.Syntax_Trees;
+with WisiToken.Wisi_Runtime;
+generic
+ type Parse_Data_Type is new WisiToken.Wisi_Runtime.Parse_Data_Type with
private;
+
+ Descriptor : in WisiToken.Descriptor;
+
+ with procedure Create_Parser
+ (Parser : out WisiToken.Parse.Packrat.Parser;
+ Trace : not null access WisiToken.Trace'Class;
+ User_Data : in WisiToken.Syntax_Trees.User_Data_Access);
+
+procedure Gen_Run_Wisi_Parse_Packrat;
diff --git a/run_wisi_common_parse.adb b/run_wisi_common_parse.adb
new file mode 100644
index 0000000..e4a45c0
--- /dev/null
+++ b/run_wisi_common_parse.adb
@@ -0,0 +1,343 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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.Exceptions;
+with Ada.IO_Exceptions;
+with Ada.Real_Time;
+with Ada.Text_IO;
+with GNAT.Traceback.Symbolic;
+with SAL;
+with System.Multiprocessors;
+package body Run_Wisi_Common_Parse is
+
+ procedure Usage (Parser : in out WisiToken.Parse.LR.Parser.Parser)
+ is
+ use all type WisiToken.Parse.LR.Parse_Table_Ptr;
+ use Ada.Text_IO;
+ begin
+ Put_Line ("usage: parse <parse_action> <file_name> [partial parse
params] [options]");
+ Put_Line (" or: refactor <refactor_action> <file_name> <edit_begin>
[options]");
+ Put_Line ("parse_action: {Navigate | Face | Indent}");
+ Put_Line ("partial parse params: begin_byte_pos end_byte_pos
goal_byte_pos begin_char_pos begin_line" &
+ " end_line begin_indent");
+ Put_Line ("options:");
+ Put_Line ("--verbosity n m l: (no 'm' for refactor)");
+ Put_Line (" n: parser; m: mckenzie; l: action");
+ Put_Line (" 0 - only report parse errors");
+ Put_Line (" 1 - shows spawn/terminate parallel parsers, error recovery
enter/exit");
+ Put_Line (" 2 - add each parser cycle, error recovery enqueue/check");
+ Put_Line (" 3 - parse stack in each cycle, error recovery parse
actions");
+ Put_Line (" 4 - add lexer debug");
+ Put_Line ("--check_limit n : set error recover token check limit" &
+ (if Parser.Table = null then ""
+ else "; default" &
Parser.Table.McKenzie_Param.Check_Limit'Image));
+ Put_Line ("--check_delta n : set error recover delta check limit" &
+ (if Parser.Table = null then ""
+ else "; default" &
Parser.Table.McKenzie_Param.Check_Delta_Limit'Image));
+ Put_Line ("--enqueue_limit n : set error recover token enqueue limit" &
+ (if Parser.Table = null then ""
+ else "; default" &
Parser.Table.McKenzie_Param.Enqueue_Limit'Image));
+ Put_Line ("--max_parallel n : set maximum count of parallel parsers
(default" &
+ WisiToken.Parse.LR.Parser.Default_Max_Parallel'Image & ")");
+ Put_Line ("--task_count n : worker tasks in error recovery");
+ Put_Line ("--disable_recover : disable error recovery; default enabled");
+ Put_Line ("--debug_mode : tracebacks from unhandled exceptions; default
disabled");
+ Put_Line ("--lang_params <language-specific params>");
+ Put_Line ("--repeat_count n : repeat parse count times, for profiling;
default 1");
+ New_Line;
+ end Usage;
+
+ function Get_CL_Params (Parser : in out WisiToken.Parse.LR.Parser.Parser)
return Command_Line_Params
+ is
+ use Ada.Command_Line;
+ use WisiToken;
+ Arg : Integer := 1;
+ Command : Command_Type;
+ begin
+ if Argument_Count < 1 then
+ Usage (Parser);
+ Set_Exit_Status (Failure);
+ raise Finish;
+
+ elsif Argument (Arg) = "--help" then
+ Usage (Parser);
+ raise Finish;
+
+ elsif Argument_Count < 2 then
+ Usage (Parser);
+ Set_Exit_Status (Failure);
+ raise Finish;
+ end if;
+
+ Command := Command_Type'Value (Ada.Command_Line.Argument (1));
+
+ return Result : Command_Line_Params (Command) do
+ Result.Source_File_Name := +Ada.Command_Line.Argument (3);
+
+ case Command is
+ when Parse =>
+ Result.Post_Parse_Action := Wisi.Post_Parse_Action_Type'Value
(Ada.Command_Line.Argument (2));
+
+ if Argument_Count >= 4 and then Argument (4)(1) /= '-' then
+ Result.Begin_Byte_Pos := WisiToken.Buffer_Pos'Value (Argument
(4));
+ Result.End_Byte_Pos := WisiToken.Buffer_Pos'Value (Argument
(5)) - 1; -- match emacs region
+ Result.Goal_Byte_Pos := WisiToken.Buffer_Pos'Value (Argument
(6));
+ Result.Begin_Char_Pos := WisiToken.Buffer_Pos'Value (Argument
(7));
+ Result.Begin_Line := WisiToken.Line_Number_Type'Value
(Argument (8));
+ Result.End_Line := WisiToken.Line_Number_Type'Value
(Argument (9));
+ Result.Begin_Indent := Integer'Value (Argument (10));
+ Arg := 11;
+ else
+ Result.Begin_Byte_Pos := WisiToken.Invalid_Buffer_Pos;
+ Result.End_Byte_Pos := WisiToken.Invalid_Buffer_Pos;
+ Result.Begin_Char_Pos := WisiToken.Buffer_Pos'First;
+ Result.Begin_Line := WisiToken.Line_Number_Type'First;
+ Arg := 4;
+ end if;
+
+ when Refactor =>
+ Result.Refactor_Action := Integer'Value (Argument (2));
+ Result.Edit_Begin := WisiToken.Buffer_Pos'Value (Argument
(4));
+ Arg := 5;
+ end case;
+
+ loop
+ exit when Arg > Argument_Count;
+
+ if Argument (Arg) = "--verbosity" then
+ WisiToken.Trace_Parse := Integer'Value (Argument (Arg + 1));
+ case Command is
+ when Parse =>
+ WisiToken.Trace_McKenzie := Integer'Value (Argument (Arg +
2));
+ WisiToken.Trace_Action := Integer'Value (Argument (Arg +
3));
+ Arg := Arg + 4;
+ when Refactor =>
+ WisiToken.Trace_Action := Integer'Value (Argument (Arg +
2));
+ Arg := Arg + 3;
+ end case;
+
+ elsif Argument (Arg) = "--check_limit" then
+ Parser.Table.McKenzie_Param.Check_Limit := Token_Index'Value
(Argument (Arg + 1));
+ Arg := Arg + 2;
+
+ elsif Argument (Arg) = "--check_delta" then
+ Parser.Table.McKenzie_Param.Check_Delta_Limit := Integer'Value
(Argument (Arg + 1));
+ Arg := Arg + 2;
+
+ elsif Argument (Arg) = "--debug_mode" then
+ WisiToken.Debug_Mode := True;
+ Arg := Arg + 1;
+
+ elsif Argument (Arg) = "--disable_recover" then
+ Parser.Enable_McKenzie_Recover := False;
+ Arg := Arg + 1;
+
+ elsif Argument (Arg) = "--enqueue_limit" then
+ Parser.Table.McKenzie_Param.Enqueue_Limit := Integer'Value
(Argument (Arg + 1));
+ Arg := Arg + 2;
+
+ elsif Argument (Arg) = "--lang_params" then
+ Result.Lang_Params := +Argument (Arg + 1);
+ Arg := Arg + 2;
+
+ elsif Argument (Arg) = "--max_parallel" then
+ Parser.Max_Parallel := SAL.Base_Peek_Type'Value (Argument (Arg
+ 1));
+ Arg := Arg + 2;
+
+ elsif Argument (Arg) = "--repeat_count" then
+ Result.Repeat_Count := Integer'Value (Argument (Arg + 1));
+ Arg := Arg + 2;
+
+ elsif Argument (Arg) = "--task_count" then
+ Parser.Table.McKenzie_Param.Task_Count :=
System.Multiprocessors.CPU_Range'Value (Argument (Arg + 1));
+ Arg := Arg + 2;
+
+ else
+ Ada.Text_IO.Put_Line ("unrecognized option: '" & Argument (Arg)
& "'");
+ Usage (Parser);
+ Set_Exit_Status (Failure);
+ raise SAL.Parameter_Error;
+ end if;
+ end loop;
+ end return;
+ exception
+ when Finish =>
+ raise;
+
+ when E : others =>
+ Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
+ Usage (Parser);
+ Set_Exit_Status (Failure);
+ raise SAL.Parameter_Error;
+ end Get_CL_Params;
+
+ procedure Parse_File
+ (Parser : in out WisiToken.Parse.LR.Parser.Parser;
+ Parse_Data : in out Wisi.Parse_Data_Type'Class;
+ Descriptor : in WisiToken.Descriptor)
+ is
+ use Ada.Text_IO;
+ use WisiToken;
+
+ Start : Ada.Real_Time.Time;
+ End_Line : WisiToken.Line_Number_Type;
+ begin
+ declare
+ Cl_Params : constant Command_Line_Params := Get_CL_Params (Parser);
+ begin
+ begin
+ case Cl_Params.Command is
+ when Parse =>
+ Parser.Lexer.Reset_With_File
+ (-Cl_Params.Source_File_Name, Cl_Params.Begin_Byte_Pos,
Cl_Params.End_Byte_Pos,
+ Cl_Params.Begin_Char_Pos, Cl_Params.Begin_Line);
+ when Refactor =>
+ Parser.Lexer.Reset_With_File (-Cl_Params.Source_File_Name);
+ end case;
+ exception
+ when Ada.IO_Exceptions.Name_Error =>
+ Put_Line (Standard_Error, "'" & (-Cl_Params.Source_File_Name) & "'
cannot be opened");
+ return;
+ end;
+
+ if Cl_Params.Command = Refactor or else Cl_Params.End_Line =
Invalid_Line_Number then
+ -- User did not provide; run lexer to get end line.
+ declare
+ Token : Base_Token;
+ Lexer_Error : Boolean;
+ pragma Unreferenced (Lexer_Error);
+ begin
+ loop
+ Lexer_Error := Parser.Lexer.Find_Next (Token);
+ exit when Token.ID = Descriptor.EOI_ID;
+ end loop;
+ End_Line := Token.Line;
+ end;
+ else
+ End_Line := Cl_Params.End_Line;
+ end if;
+
+ Parse_Data.Initialize
+ (Post_Parse_Action =>
+ (case Cl_Params.Command is
+ when Parse => Cl_Params.Post_Parse_Action,
+ when Refactor => Wisi.Navigate),
+ Lexer => Parser.Lexer,
+ Descriptor => Descriptor'Unrestricted_Access,
+ Base_Terminals => Parser.Terminals'Unrestricted_Access,
+ Begin_Line =>
+ (case Cl_Params.Command is
+ when Parse => Cl_Params.Begin_Line,
+ when Refactor => WisiToken.Line_Number_Type'First),
+ End_Line => End_Line,
+ Begin_Indent =>
+ (case Cl_Params.Command is
+ when Parse => Cl_Params.Begin_Indent,
+ when Refactor => 0),
+ Params => -Cl_Params.Lang_Params);
+
+ if Cl_Params.Repeat_Count > 1 then
+ Start := Ada.Real_Time.Clock;
+ end if;
+
+ for I in 1 .. Cl_Params.Repeat_Count loop
+ declare
+ procedure Clean_Up
+ is
+ use all type SAL.Base_Peek_Type;
+ begin
+ Parser.Lexer.Discard_Rest_Of_Input;
+ if Cl_Params.Repeat_Count = 1 and Parser.Parsers.Count > 0
then
+ Parse_Data.Put
+ (Parser.Lexer.Errors,
+ Parser.Parsers.First.State_Ref.Errors,
+ Parser.Parsers.First.State_Ref.Tree);
+ end if;
+ end Clean_Up;
+
+ begin
+ Parse_Data.Reset;
+ Parser.Lexer.Reset;
+
+ begin
+ Parser.Parse;
+ exception
+ when WisiToken.Partial_Parse =>
+ null;
+ end;
+
+ Parser.Execute_Actions;
+
+ case Cl_Params.Command is
+ when Parse =>
+ if Cl_Params.Repeat_Count = 1 then
+ Parse_Data.Put (Parser);
+ Parse_Data.Put
+ (Parser.Lexer.Errors,
+ Parser.Parsers.First.State_Ref.Errors,
+ Parser.Parsers.First.State_Ref.Tree);
+ end if;
+
+ when Refactor =>
+ Parse_Data.Refactor
+ (Parser.Parsers.First_State_Ref.Tree,
+ Cl_Params.Refactor_Action, Cl_Params.Edit_Begin);
+ end case;
+ exception
+ when WisiToken.Syntax_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error)");
+
+ when E : WisiToken.Parse_Error =>
+ Clean_Up;
+ Put_Line ("(parse_error """ & Ada.Exceptions.Exception_Message
(E) & """)");
+
+ when E : others => -- includes Fatal_Error
+ Clean_Up;
+ Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E) &
""")");
+ end;
+ end loop;
+
+ if Cl_Params.Repeat_Count > 1 then
+ declare
+ use Ada.Real_Time;
+ Finish : constant Time := Clock;
+ begin
+ Put_Line ("Total time:" & Duration'Image (To_Duration (Finish -
Start)));
+ Put_Line ("per iteration:" & Duration'Image (To_Duration
((Finish - Start) / Cl_Params.Repeat_Count)));
+ end;
+ end if;
+ end;
+ exception
+ when SAL.Parameter_Error | Finish =>
+ -- From Get_CL_Params; already handled.
+ null;
+
+ when E : others =>
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ New_Line (2);
+ Put_Line
+ ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E)
& ": " &
+ Ada.Exceptions.Exception_Message (E) & """)");
+ Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
+ end Parse_File;
+
+end Run_Wisi_Common_Parse;
diff --git a/run_wisi_common_parse.ads b/run_wisi_common_parse.ads
new file mode 100644
index 0000000..c00d007
--- /dev/null
+++ b/run_wisi_common_parse.ads
@@ -0,0 +1,73 @@
+-- Abstract :
+--
+-- Common utilities for Gen_Run_Wisi_*_Parse
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- 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.Strings.Unbounded;
+with Wisi;
+with WisiToken.Parse.LR.Parser;
+package Run_Wisi_Common_Parse is
+
+ Finish : exception;
+
+ procedure Usage (Parser : in out WisiToken.Parse.LR.Parser.Parser);
+ -- Puts parameter description to Current_Output.
+
+ type Command_Type is (Parse, Refactor);
+
+ type Command_Line_Params (Command : Command_Type) is record
+
+ Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Lang_Params : Ada.Strings.Unbounded.Unbounded_String;
+ Repeat_Count : Integer := 1;
+
+ case Command is
+ when Parse =>
+ Post_Parse_Action : Wisi.Post_Parse_Action_Type;
+ Begin_Byte_Pos : WisiToken.Buffer_Pos :=
WisiToken.Invalid_Buffer_Pos;
+ End_Byte_Pos : WisiToken.Buffer_Pos :=
WisiToken.Invalid_Buffer_Pos;
+ Goal_Byte_Pos : WisiToken.Buffer_Pos :=
WisiToken.Invalid_Buffer_Pos;
+ Begin_Char_Pos : WisiToken.Buffer_Pos :=
WisiToken.Buffer_Pos'First;
+ Begin_Line : WisiToken.Line_Number_Type :=
WisiToken.Line_Number_Type'First;
+ End_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
+ Begin_Indent : Integer := 0;
+
+ when Refactor =>
+ -- We assume the file contains only the one statement/declaration
+ -- that needs refactoring.
+
+ Refactor_Action : Positive;
+ -- Language-specific
+
+ Edit_Begin : WisiToken.Buffer_Pos;
+ -- Source file byte position at start of expression to refactor.
+ end case;
+ end record;
+
+ function Get_CL_Params (Parser : in out WisiToken.Parse.LR.Parser.Parser)
return Command_Line_Params;
+ -- For any errors, calls Usage, raises SAL.Parameter_Error.
+ --
+ -- Handles --help by outputing help, raising Finish.
+
+ procedure Parse_File
+ (Parser : in out WisiToken.Parse.LR.Parser.Parser;
+ Parse_Data : in out Wisi.Parse_Data_Type'Class;
+ Descriptor : in WisiToken.Descriptor);
+ -- Calls Get_CL_Params, reads in file, parses, does post-parse actions.
+
+end Run_Wisi_Common_Parse;
diff --git a/sal-gen_bounded_definite_queues.adb
b/sal-gen_bounded_definite_queues.adb
index 61e5c12..71b68c5 100644
--- a/sal-gen_bounded_definite_queues.adb
+++ b/sal-gen_bounded_definite_queues.adb
@@ -17,43 +17,20 @@
pragma License (Modified_GPL);
-package body SAL.Gen_Bounded_Definite_Queues is
-
- -- Local subprograms
-
- function Wrap (Queue : in Queue_Type; I : in Integer) return Integer
- is begin
- if I > Queue.Size then
- return I - Queue.Size;
- elsif I < 1 then
- return Queue.Size + I;
- else
- return I;
- end if;
- end Wrap;
+package body SAL.Gen_Bounded_Definite_Queues
+ with Spark_Mode
+is
+ pragma Suppress (All_Checks);
----------
-- Public subprograms
- function Get_Overflow_Handling (Queue : in Queue_Type) return
Overflow_Action_Type
- is begin
- return Queue.Overflow_Handling;
- end Get_Overflow_Handling;
-
- procedure Set_Overflow_Handling (Queue : in out Queue_Type; Handling : in
Overflow_Action_Type)
- is begin
- Queue.Overflow_Handling := Handling;
- end Set_Overflow_Handling;
-
procedure Clear (Queue : in out Queue_Type) is
begin
Queue.Count := 0;
end Clear;
- function Count (Queue : in Queue_Type) return Natural is
- begin
- return Queue.Count;
- end Count;
+ function Count (Queue : in Queue_Type) return Base_Peek_Type is
(Queue.Count);
function Is_Empty (Queue : in Queue_Type) return Boolean is
begin
@@ -65,90 +42,62 @@ package body SAL.Gen_Bounded_Definite_Queues is
return Queue.Count = Queue.Size;
end Is_Full;
- function Remove (Queue : in out Queue_Type) return Item_Type
+ procedure Remove (Queue : in out Queue_Type; Item : out Item_Type)
is begin
- if Queue.Count = 0 then
- raise Container_Empty;
- end if;
+ Item := Queue.Data (Queue.Head);
- return Item : constant Item_Type := Queue.Data (Queue.Head)
- do
- Queue.Count := Queue.Count - 1;
+ Queue.Count := Queue.Count - 1;
- if Queue.Count > 0 then
- Queue.Head := Wrap (Queue, Queue.Head + 1);
- end if;
+ if Queue.Count > 0 then
+ Queue.Head := Wrap (Queue.Size, Queue.Head + 1);
+ end if;
+ end Remove;
+
+ function Remove (Queue : in out Queue_Type) return Item_Type with
+ Spark_Mode => Off
+ is begin
+ return Item : Item_Type do
+ Remove (Queue, Item);
end return;
end Remove;
procedure Drop (Queue : in out Queue_Type)
is begin
- if Queue.Count = 0 then
- raise Container_Empty;
- end if;
-
Queue.Count := Queue.Count - 1;
if Queue.Count > 0 then
- Queue.Head := Wrap (Queue, Queue.Head + 1);
+ Queue.Head := Wrap (Queue.Size, Queue.Head + 1);
end if;
end Drop;
- function Peek (Queue : in Queue_Type; N : Integer := 0) return Item_Type
- is begin
- if Queue.Count = 0 then
- raise Container_Empty;
- end if;
-
- return Queue.Data (Wrap (Queue, Queue.Head + N));
- end Peek;
+ function Peek (Queue : in Queue_Type; N : Peek_Type := 1) return Item_Type
+ is (Queue.Data (Wrap (Queue.Size, Queue.Head + N - 1)));
+ -- Expression function to allow use in Spark proofs of conditions in spec.
procedure Add (Queue : in out Queue_Type; Item : in Item_Type) is
begin
- if Queue.Count = Queue.Size then
- case Queue.Overflow_Handling is
- when Error =>
- raise Container_Full;
- when Overwrite =>
- Queue.Count := Queue.Count - 1;
- Queue.Head := Wrap (Queue, Queue.Head + 1);
- end case;
- end if;
-
if Queue.Count = 0 then
- Queue.Tail := 1;
- Queue.Head := 1;
- Queue.Count := 1;
- Queue.Data (1) := Item;
+ Queue.Tail := 1;
+ Queue.Head := 1;
+ Queue.Count := 1;
else
- Queue.Tail := Wrap (Queue, Queue.Tail + 1);
- Queue.Data (Queue.Tail) := Item;
- Queue.Count := Queue.Count + 1;
+ Queue.Tail := Wrap (Queue.Size, Queue.Tail + 1);
+ Queue.Count := Queue.Count + 1;
end if;
+ Queue.Data (Queue.Tail) := Item;
end Add;
procedure Add_To_Head (Queue : in out Queue_Type; Item : in Item_Type) is
begin
- if Queue.Count = Queue.Size then
- case Queue.Overflow_Handling is
- when Error =>
- raise Container_Full;
- when Overwrite =>
- Queue.Count := Queue.Count - 1;
- Queue.Tail := Wrap (Queue, Queue.Tail + 1);
- end case;
- end if;
-
if Queue.Count = 0 then
- Queue.Tail := 1;
- Queue.Head := 1;
- Queue.Count := 1;
- Queue.Data (1) := Item;
+ Queue.Tail := 1;
+ Queue.Head := 1;
+ Queue.Count := 1;
else
- Queue.Head := Wrap (Queue, Queue.Head - 1);
- Queue.Data (Queue.Head) := Item;
- Queue.Count := Queue.Count + 1;
+ Queue.Head := Wrap (Queue.Size, Queue.Head - 1);
+ Queue.Count := Queue.Count + 1;
end if;
+ Queue.Data (Queue.Head) := Item;
end Add_To_Head;
end SAL.Gen_Bounded_Definite_Queues;
diff --git a/sal-gen_bounded_definite_queues.ads
b/sal-gen_bounded_definite_queues.ads
index 0b286f8..5614519 100644
--- a/sal-gen_bounded_definite_queues.ads
+++ b/sal-gen_bounded_definite_queues.ads
@@ -2,7 +2,7 @@
--
-- A generic queue, allowing definite non-limited item types.
--
--- Copyright (C) 2004, 2008, 2009, 2011, 2017, 2019 Free Software Foundation
All Rights Reserved.
+-- Copyright (C) 2004, 2008, 2009, 2011, 2017, 2019 Free Software Foundation
All Rights Reserved.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -19,81 +19,99 @@ pragma License (Modified_GPL);
generic
type Item_Type is private;
-package SAL.Gen_Bounded_Definite_Queues is
+package SAL.Gen_Bounded_Definite_Queues
+ with Spark_Mode
+is
pragma Pure;
+ pragma Suppress (All_Checks); -- Users must check Is_Full before Add,
Is_Empty before Remove.
- type Queue_Type (Size : Positive) is tagged private;
- -- Size is maximum number of items in the queue.
- -- Tagged to allow Object.Method syntax.
+ subtype Size_Type is Peek_Type range 1 .. Peek_Type'Last / 2;
+ -- The upper limit is needed to avoid overflow in Peek.
- function Get_Overflow_Handling (Queue : in Queue_Type) return
Overflow_Action_Type;
- procedure Set_Overflow_Handling (Queue : in out Queue_Type; Handling : in
Overflow_Action_Type);
- -- See Add for meaning of Overflow_Handling. Default is Error.
+ type Queue_Type (Size : Size_Type) is private;
+ -- Size is maximum number of items in the queue.
- procedure Clear (Queue : in out Queue_Type);
+ procedure Clear (Queue : in out Queue_Type)
+ with Post => Count (Queue) = 0;
-- Empty Queue of all items.
- function Count (Queue : in Queue_Type) return Natural;
+ function Count (Queue : in Queue_Type) return Base_Peek_Type;
-- Returns count of items in the Queue
- function Is_Empty (Queue : in Queue_Type) return Boolean;
+ function Is_Empty (Queue : in Queue_Type) return Boolean
+ with Post => Is_Empty'Result = (Count (Queue) = 0);
-- Returns true if no items are in Queue.
- function Is_Full (Queue : in Queue_Type) return Boolean;
+ function Is_Full (Queue : in Queue_Type) return Boolean
+ with Post => Is_Full'Result = (Count (Queue) = Queue.Size);
-- Returns true if Queue is full.
- function Remove (Queue : in out Queue_Type) return Item_Type;
+ procedure Remove (Queue : in out Queue_Type; Item : out Item_Type) with
+ Pre => Count (Queue) > 0,
+ Post => Count (Queue) = Count (Queue)'Old - 1 and Item = Peek (Queue'Old)
and
+ (for all I in 1 .. Count (Queue) => Peek (Queue'Old, I + 1) =
Peek (Queue, I));
-- Remove head item from Queue, return it.
- --
- -- Raises Container_Empty if Is_Empty.
+
+ function Remove (Queue : in out Queue_Type) return Item_Type with
+ Spark_Mode => Off;
function Get (Queue : in out Queue_Type) return Item_Type renames Remove;
- procedure Drop (Queue : in out Queue_Type);
+ procedure Drop (Queue : in out Queue_Type) with
+ Pre => Count (Queue) > 0,
+ Post => Count (Queue) = Count (Queue)'Old - 1 and
+ (for all I in 1 .. Count (Queue) => Peek (Queue'Old, I + 1) =
Peek (Queue, I));
-- Remove head item from Queue, discard it.
- --
- -- Raises Container_Empty if Is_Empty.
- function Peek (Queue : in Queue_Type; N : Integer := 0) return Item_Type;
- -- Return a copy of a queue item, without removing it. N = 0 is
+ function Peek (Queue : in Queue_Type; N : Peek_Type := 1) return Item_Type
with
+ Pre => Count (Queue) in 1 .. Queue.Size and N in 1 .. Count (Queue);
+ -- Return a copy of a queue item, without removing it. N = 1 is
-- the queue head.
- procedure Add (Queue : in out Queue_Type; Item : in Item_Type);
+ procedure Add (Queue : in out Queue_Type; Item : in Item_Type) with
+ Pre => Count (Queue) in 0 .. Queue.Size - 1,
+ Post => Count (Queue) = Count (Queue)'Old + 1 and Peek (Queue, Count
(Queue)) = Item and
+ (for all I in 1 .. Count (Queue)'Old => Peek (Queue'Old, I) =
Peek (Queue, I));
-- Add Item to the tail of Queue.
- --
- -- If Queue is full, result depends on Queue.Overflow_Handling:
- --
- -- when Overwrite, an implicit Remove is done (and the data
- -- discarded), then Add is done.
- --
- -- when Error, raises Container_Full.
procedure Put (Queue : in out Queue_Type; Item : in Item_Type) renames Add;
- procedure Add_To_Head (Queue : in out Queue_Type; Item : in Item_Type);
+ procedure Add_To_Head (Queue : in out Queue_Type; Item : in Item_Type) with
+ Pre => Count (Queue) in 0 .. Queue.Size - 1,
+ Post => Count (Queue) = Count (Queue)'Old + 1 and
+ (Peek (Queue) = Item and
+ (for all I in 2 .. Count (Queue) => Peek (Queue'Old, I - 1) =
Peek (Queue, I)));
-- Add Item to the head of Queue.
- --
- -- If Queue is full, result depends on Queue.Overflow_Handling:
- --
- -- when Overwrite, an implicit Remove is done (and the data
- -- discarded), then Add is done.
- --
- -- when Error, raises Container_Full.
private
- type Item_Array_Type is array (Positive range <>) of Item_Type;
-
- type Queue_Type (Size : Positive) is tagged record
- Overflow_Handling : Overflow_Action_Type := Error;
+ type Item_Array_Type is array (Peek_Type range <>) of Item_Type;
- Head : Natural := 0;
- Tail : Natural := 0;
- Count : Natural := 0;
+ type Queue_Type (Size : Size_Type) is
+ record
+ Head : Peek_Type := 1;
+ Tail : Peek_Type := 1;
+ Count : Base_Peek_Type := 0;
Data : Item_Array_Type (1 .. Size);
-- Add at Tail + 1, remove at Head. Count is current count;
-- easier to keep track of that than to compute Is_Empty for
-- each Add and Remove.
- end record;
+ --
+ -- Empty is indicated by Count = 0; head and tail are arbitrary
+ -- in that case.
+ end record with
+ Type_Invariant =>
+ (Head in 1 .. Size and
+ Tail in 1 .. Size and
+ Count in 0 .. Size) and then
+ (Count = 0 or else Wrap (Size, Head + Count - 1) = Tail);
+
+ function Wrap (Size : in Size_Type; I : in Base_Peek_Type) return Peek_Type
+ is (if I > Size then I - Size
+ elsif I = 0 then Size
+ else I)
+ with
+ Pre => I in 0 .. 2 * Size - 1,
+ Post => Wrap'Result in 1 .. Size;
end SAL.Gen_Bounded_Definite_Queues;
diff --git a/sal-gen_bounded_definite_vectors-gen_image.adb
b/sal-gen_bounded_definite_stacks-gen_image_aux.adb
similarity index 59%
copy from sal-gen_bounded_definite_vectors-gen_image.adb
copy to sal-gen_bounded_definite_stacks-gen_image_aux.adb
index e1726d1..7dcd96f 100644
--- a/sal-gen_bounded_definite_vectors-gen_image.adb
+++ b/sal-gen_bounded_definite_stacks-gen_image_aux.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -17,23 +17,26 @@
pragma License (Modified_GPL);
-function SAL.Gen_Bounded_Definite_Vectors.Gen_Image (Item : in Vector) return
String
+with Ada.Strings.Unbounded;
+function SAL.Gen_Bounded_Definite_Stacks.Gen_Image_Aux
+ (Item : in Stack;
+ Aux : in Aux_Data;
+ Depth : in SAL.Base_Peek_Type := 0)
+ 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);
+ 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 Item.Elements (1 .. Last) loop
- Result := Result &
- ((if Trim
- then Fixed.Trim (Element_Image (Item.Elements (I)), Left)
- else Element_Image (Item.Elements (I)));
+ 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_Bounded_Definite_Vectors.Gen_Image;
+end SAL.Gen_Bounded_Definite_Stacks.Gen_Image_Aux;
diff --git a/sal-gen_bounded_definite_stacks-gen_image_aux.ads
b/sal-gen_bounded_definite_stacks-gen_image_aux.ads
new file mode 100644
index 0000000..e960398
--- /dev/null
+++ b/sal-gen_bounded_definite_stacks-gen_image_aux.ads
@@ -0,0 +1,27 @@
+-- Abstract :
+--
+-- Image with auxiliary data for instantiations of parent.
+--
+-- Copyright (C) 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Aux_Data (<>) is private;
+ with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
+function SAL.Gen_Bounded_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_bounded_definite_stacks.adb
b/sal-gen_bounded_definite_stacks.adb
new file mode 100644
index 0000000..fc81daa
--- /dev/null
+++ b/sal-gen_bounded_definite_stacks.adb
@@ -0,0 +1,82 @@
+-- Abstract:
+--
+-- see spec
+--
+-- Copyright (C) 1998, 2003, 2009, 2015, 2017 - 2019 Free Software
Foundation, Inc.
+--
+-- SAL is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the
+-- 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_Bounded_Definite_Stacks
+ with Spark_Mode
+is
+ pragma Suppress (All_Checks);
+
+ procedure Clear (Stack : in out Sgbds.Stack)
+ is begin
+ Stack.Top := 0;
+ end Clear;
+
+ function Depth (Stack : in Sgbds.Stack) return Size_Type
+ is (Stack.Top);
+
+ function Is_Empty (Stack : in Sgbds.Stack) return Boolean
+ is begin
+ return Stack.Top = 0;
+ end Is_Empty;
+
+ function Is_Full (Stack : in Sgbds.Stack) return Boolean
+ is begin
+ return Stack.Top = Stack.Size;
+ end Is_Full;
+
+ function Peek
+ (Stack : in Sgbds.Stack;
+ Index : in Peek_Type := 1)
+ return Element_Type
+ is (Stack.Data (Stack.Top - Index + 1));
+
+ procedure Pop (Stack : in out Sgbds.Stack; Count : in Base_Peek_Type := 1)
+ is begin
+ Stack.Top := Stack.Top - Count;
+ end Pop;
+
+ procedure Pop (Stack : in out Sgbds.Stack; Item : out Element_Type)
+ is begin
+ Item := Stack.Peek (1);
+ Stack.Top := Stack.Top - 1;
+ end Pop;
+
+ function Pop (Stack : in out Sgbds.Stack) return Element_Type with
+ Spark_Mode => Off
+ is begin
+ return Result : Element_Type do
+ Pop (Stack, Result);
+ end return;
+ end Pop;
+
+ procedure Push (Stack : in out Sgbds.Stack; Item : in Element_Type)
+ is begin
+ Stack.Top := Stack.Top + 1;
+ Stack.Data (Stack.Top) := Item;
+ end Push;
+
+end SAL.Gen_Bounded_Definite_Stacks;
diff --git a/sal-gen_bounded_definite_stacks.ads
b/sal-gen_bounded_definite_stacks.ads
new file mode 100644
index 0000000..f743508
--- /dev/null
+++ b/sal-gen_bounded_definite_stacks.ads
@@ -0,0 +1,103 @@
+-- Abstract:
+--
+-- Bounded stack implementation, with full Spark verification,
+-- optimized for speed.
+--
+-- Copyright (C) 1998-2000, 2002-2003, 2009, 2015, 2017 - 2019 Free Software
Foundation, Inc.
+--
+-- SAL is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the
+-- 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);
+
+generic
+ type Element_Type is private;
+package SAL.Gen_Bounded_Definite_Stacks
+ with Spark_Mode
+is
+ pragma Pure;
+ -- pragma Suppress (All_Checks); -- Users must check Is_Full before Push,
Is_Empty before Pop etc.
+
+ package Sgbds renames SAL.Gen_Bounded_Definite_Stacks;
+
+ subtype Size_Type is Base_Peek_Type range 0 .. Base_Peek_Type'Last / 2;
+ -- The upper limit is needed to avoid overflow in Peek.
+ -- Zero included for Depth result.
+
+ type Stack (Size : Size_Type) is tagged private;
+ -- Tagged to allow Object.Method notation.
+
+ -- No Empty_Stack constant, to avoid requiring a Default_Element.
+
+ procedure Clear (Stack : in out Sgbds.Stack)
+ with Post'Class => Depth (Stack) = 0;
+ -- Empty Stack of all items.
+
+ function Depth (Stack : in Sgbds.Stack) return Size_Type;
+ -- Returns current count of items in Stack
+
+ function Is_Empty (Stack : in Sgbds.Stack) return Boolean
+ with Post'Class => Is_Empty'Result = (Depth (Stack) = 0);
+ -- Returns true iff no items are in Stack.
+
+ function Is_Full (Stack : in Sgbds.Stack) return Boolean
+ with Post'Class => Is_Full'Result = (Depth (Stack) = Stack.Size);
+ -- Returns true iff Stack is full.
+
+ function Peek (Stack : in Sgbds.Stack; Index : in Peek_Type := 1) return
Element_Type
+ with Pre'Class => Depth (Stack) in 1 .. Stack.Size and Index in 1 .. Depth
(Stack);
+ -- Return the Index'th item from the top of Stack; the Item is _not_
removed.
+ -- Top item has index 1.
+
+ procedure Pop (Stack : in out Sgbds.Stack; Count : in Base_Peek_Type := 1)
with
+ Pre'Class => Depth (Stack) in 1 .. Stack.Size and Count in 0 .. Depth
(Stack),
+ Post'Class => Depth (Stack) = Depth (Stack)'Old - Count and then
+ (for all I in 1 .. Depth (Stack) => Peek (Stack'Old, I +
Count) = Peek (Stack, I));
+ -- Remove Count Items from the top of Stack, discard them.
+
+ procedure Pop (Stack : in out Sgbds.Stack; Item : out Element_Type) with
+ Pre'Class => Depth (Stack) in 1 .. Stack.Size,
+ Post'Class =>
+ Depth (Stack) = Depth (Stack)'Old - 1 and then
+ (Item = Peek (Stack'Old) and
+ (for all I in 1 .. Depth (Stack) => Peek (Stack'Old, I + 1) = Peek
(Stack, I)));
+ -- Remove one item from the top of Stack, return in Item.
+
+ function Pop (Stack : in out Sgbds.Stack) return Element_Type with
+ Spark_Mode => Off;
+ -- Remove one item from the top of Stack, and return it.
+
+ procedure Push (Stack : in out Sgbds.Stack; Item : in Element_Type) with
+ Pre'Class => Depth (Stack) in 0 .. Stack.Size - 1,
+ Post'Class =>
+ Depth (Stack) = Depth (Stack)'Old + 1 and then
+ (Item = Peek (Stack) and
+ (for all I in 1 .. Depth (Stack'Old) => Peek (Stack'Old, I) = Peek
(Stack, I + 1)));
+ -- Add Item to the top of Stack.
+
+private
+
+ type Element_Array is array (Size_Type range <>) of aliased Element_Type;
+
+ type Stack (Size : Size_Type) is tagged record
+ Top : Base_Peek_Type := Invalid_Peek_Index; -- empty
+ Data : Element_Array (1 .. Size);
+ -- Top of stack is at Data (Top).
+ -- Data (1 .. Top) has been set at some point.
+ end record with
+ Dynamic_Predicate => Top in 0 .. Size;
+
+end SAL.Gen_Bounded_Definite_Stacks;
diff --git a/sal-gen_bounded_definite_vectors-gen_image.adb
b/sal-gen_bounded_definite_vectors-gen_image.adb
index e1726d1..ae901fe 100644
--- a/sal-gen_bounded_definite_vectors-gen_image.adb
+++ b/sal-gen_bounded_definite_vectors-gen_image.adb
@@ -1,39 +1,40 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-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;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Strings.Fixed;
+with Ada.Strings.Unbounded;
+function SAL.Gen_Bounded_Definite_Vectors.Gen_Image (Item : in Vector) return
String
+is
+ use Ada.Strings;
+ 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 &
+ (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_refs.adb
b/sal-gen_bounded_definite_vectors-gen_refs.adb
new file mode 100644
index 0000000..8f9d741
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors-gen_refs.adb
@@ -0,0 +1,35 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Bounded_Definite_Vectors.Gen_Refs is
+
+ function Variable_Ref
+ (Container : aliased in out Vector;
+ Index : in Index_Type)
+ return Variable_Reference_Type
+ is begin
+ return (Element => Container.Elements (To_Peek_Index (Index))'Access,
Dummy => 1);
+ end Variable_Ref;
+
+ function Constant_Ref (Container : aliased in Vector; Index : in
Index_Type) return Constant_Reference_Type
+ is begin
+ return (Element => Container.Elements (To_Peek_Index (Index))'Access,
Dummy => 1);
+ end Constant_Ref;
+
+end SAL.Gen_Bounded_Definite_Vectors.Gen_Refs;
diff --git a/sal-gen_bounded_definite_vectors-gen_refs.ads
b/sal-gen_bounded_definite_vectors-gen_refs.ads
new file mode 100644
index 0000000..c235cbc
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors-gen_refs.ads
@@ -0,0 +1,54 @@
+-- Abstract :
+--
+-- Variable_Reference for parent.
+--
+-- In a child package because it's not Spark, and Spark does not
+-- allow 'Spark_Mode => Off' on type declarations.
+--
+-- Copyright (C) 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+package SAL.Gen_Bounded_Definite_Vectors.Gen_Refs
+ with Spark_Mode => Off
+is
+
+ type Variable_Reference_Type (Element : not null access Element_Type) is
private with
+ Implicit_Dereference => Element;
+
+ function Variable_Ref (Container : aliased in out Vector; Index : in
Index_Type) return Variable_Reference_Type
+ with Inline,
+ Pre => Index in Index_Type'First .. Last_Index (Container);
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
+ Implicit_Dereference => Element;
+
+ function Constant_Ref (Container : aliased in Vector; Index : in
Index_Type) return Constant_Reference_Type
+ with Inline,
+ Pre => Index in Index_Type'First .. Last_Index (Container);
+
+private
+
+ type Variable_Reference_Type (Element : not null access Element_Type) is
+ record
+ Dummy : Integer := raise Program_Error with "uninitialized reference";
+ 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;
+
+end SAL.Gen_Bounded_Definite_Vectors.Gen_Refs;
diff --git a/sal-gen_bounded_definite_vectors-gen_sorted.ads
b/sal-gen_bounded_definite_vectors-gen_sorted.ads
deleted file mode 100644
index e6e101f..0000000
--- a/sal-gen_bounded_definite_vectors-gen_sorted.ads
+++ /dev/null
@@ -1,52 +0,0 @@
--- Abstract :
---
--- Add sorted behavior to parent.
---
--- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-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;
- Ignore_If_Equal : in Boolean := False);
- -- Insert New_Item in sorted position. Items are sorted in increasing
- -- order according to Element_Compare. New_Item is inserted after
- -- Equal items, unless Ignore_If_Equal is true, in which case
- -- New_Item is not inserted.
-
-end SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted;
diff --git a/sal-gen_bounded_definite_vectors.adb
b/sal-gen_bounded_definite_vectors.adb
index 42f5643..17aac08 100644
--- a/sal-gen_bounded_definite_vectors.adb
+++ b/sal-gen_bounded_definite_vectors.adb
@@ -1,224 +1,120 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (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;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Bounded_Definite_Vectors
+ with Spark_Mode
+is
+ pragma Suppress (All_Checks);
+
+ function Length (Container : in Vector) return Ada.Containers.Count_Type
+ is (Ada.Containers.Count_Type (To_Peek_Index (Container.Last)));
+
+ function Is_Full (Container : in Vector) return Boolean
+ is begin
+ return Length (Container) = 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 (Container.Elements (Peek_Type (Index - Index_Type'First + 1)));
+
+ procedure Replace_Element
+ (Container : in out Vector;
+ Index : in Index_Type;
+ New_Item : in Element_Type)
+ is begin
+ Container.Elements (To_Peek_Index (Index)) := New_Item;
+ end Replace_Element;
+
+ function Last_Index (Container : Vector) return Extended_Index
+ is (Container.Last);
+
+ procedure Append (Container : in out Vector; New_Item : in Element_Type)
+ is
+ J : constant Peek_Type := To_Peek_Index (Container.Last + 1);
+ begin
+ 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
+ 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
+ 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
+ Append (Result, Item);
+ end return;
+ end "+";
+
+ function "&" (Left : in Vector; Right : in Element_Type) return Vector
+ is begin
+ -- WORKAROUND: If init Result with ":= Left", GNAT Community 2019
+ -- checks Default_Initial_Condition (which fails when Left is not
+ -- empty)! That is only supposed to be checked when initialized by
+ -- default. Reported to AdaCore as ticket S724-042.
+ return Result : Vector do
+ Result := Left;
+ Append (Result, Right);
+ end return;
+ end "&";
+
+ procedure Delete_First (Container : in out Vector; Count : in
Ada.Containers.Count_Type := 1)
+ is
+ use Ada.Containers;
+ begin
+ if Count = 0 then
+ return;
+ end if;
+
+ declare
+ New_Last : constant Extended_Index := Extended_Index (Integer
(Container.Last) - Integer (Count));
+ J : constant Base_Peek_Type := Base_Peek_Type (Count);
+ K : constant Peek_Type := To_Peek_Index (Container.Last);
+ begin
+ -- Delete items 1 .. J, shift remaining down.
+ Container.Elements (1 .. K - J) := Container.Elements (J + 1 .. K);
+ Container.Last := New_Last;
+ end;
+ end Delete_First;
+
+end SAL.Gen_Bounded_Definite_Vectors;
diff --git a/sal-gen_bounded_definite_vectors.ads
b/sal-gen_bounded_definite_vectors.ads
index 9747704..9e698e2 100644
--- a/sal-gen_bounded_definite_vectors.ads
+++ b/sal-gen_bounded_definite_vectors.ads
@@ -1,154 +1,145 @@
--- Abstract :
---
--- A simple bounded vector of definite items, intended to be faster
--- than Ada.Containers.Bounded_Definite_Vectors.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.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;
- pragma Inline (Constant_Reference);
-
- 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;
- pragma Inline (Variable_Reference);
-
- 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;
- pragma Inline (Constant_Reference);
-
- function Variable_Reference
- (Container : aliased in out Vector;
- Position : in Cursor)
- return Variable_Reference_Type;
- pragma Inline (Variable_Reference);
-
-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;
+-- Abstract :
+--
+-- A simple bounded vector of definite items, in Spark.
+--
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Index_Type is range <>;
+ type Element_Type is private;
+ Capacity : in Ada.Containers.Count_Type;
+package SAL.Gen_Bounded_Definite_Vectors
+ with Spark_Mode
+is
+ use all type Ada.Containers.Count_Type;
+
+ subtype Extended_Index is Index_Type'Base
+ range Index_Type'First - 1 ..
+ Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
+
+ pragma Assert (Capacity <= Ada.Containers.Count_Type (Index_Type'Last -
Index_Type'First + 1));
+
+ No_Index : constant Extended_Index := Extended_Index'First;
+
+ type Vector is private with
+ Default_Initial_Condition => Length (Vector) = 0;
+
+ function Length (Container : in Vector) return Ada.Containers.Count_Type
with
+ Post => Length'Result in 0 .. Capacity;
+
+ function Is_Full (Container : in Vector) return Boolean with
+ Post => Is_Full'Result = (Length (Container) = Capacity);
+
+ function Has_Space (Container : in Vector; Item_Count : in
Ada.Containers.Count_Type) return Boolean
+ is (Length (Container) + Item_Count <= Capacity)
+ with Pre => Item_Count <= Ada.Containers.Count_Type'Last - Length
(Container);
+
+ procedure Clear (Container : in out Vector) with
+ Post => Length (Container) = 0;
+
+ function First_Index (Container : in Vector) return Index_Type is
(Index_Type'First) with
+ Depends => (First_Index'Result => null, null => Container);
+
+ function Last_Index (Container : in Vector) return Extended_Index;
+ -- No_Index when Container is empty.
+
+ function Element (Container : in Vector; Index : in Index_Type) return
Element_Type
+ with Pre => Index <= Last_Index (Container);
+ -- Index of first element in Vector is Index_Type'First.
+
+ procedure Replace_Element
+ (Container : in out Vector;
+ Index : in Index_Type;
+ New_Item : in Element_Type)
+ with
+ Pre => Index <= Last_Index (Container),
+ Post => Element (Container, Index) = New_Item;
+ -- Index of first element in Vector is Index_Type'First.
+
+ procedure Append (Container : in out Vector; New_Item : in Element_Type)
with
+ Pre => Length (Container) < Capacity,
+ Post => Length (Container) = Length (Container'Old) + 1 and
+ Element (Container, Last_Index (Container)) = New_Item and
+ (for all I in Index_Type'First .. Last_Index (Container) - 1 =>
+ Element (Container'Old, I) = Element (Container, I));
+
+ procedure Prepend (Container : in out Vector; New_Item : in Element_Type)
with
+ Pre => Length (Container) < Capacity,
+ Post => Length (Container) = Length (Container'Old) + 1 and then
+ (Element (Container, Index_Type'First) = New_Item and
+ (for all I in Index_Type'First .. Last_Index (Container'Old) =>
+ Element (Container'Old, I) = Element (Container, I + 1)));
+ -- 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) with
+ Pre => Length (Container) < Capacity and Before <= Last_Index
(Container),
+ Contract_Cases =>
+ (Before = No_Index =>
+ Length (Container) = Length (Container'Old) + 1 and
+ Element (Container, Last_Index (Container)) = New_Item and
+ (for all I in Index_Type'First .. Last_Index (Container) - 1 =>
+ Element (Container'Old, I) = Element (Container, I)),
+ Before /= No_Index =>
+ Length (Container) = Length (Container'Old) + 1 and
+ Element (Container, Before) = New_Item and
+ (for all I in Index_Type'First .. Before - 1 =>
+ Element (Container'Old, I) = Element (Container, I)) and
+ (for all I in Before + 1 .. Last_Index (Container) =>
+ Element (Container'Old, I - 1) = Element (Container, I)));
+ -- 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 with
+ Post => Length ("+"'Result) = 1 and
+ Element ("+"'Result, Index_Type'First) = Item;
+
+ function "&" (Left : in Vector; Right : in Element_Type) return Vector with
+ Pre => Length (Left) < Capacity,
+ Post => Length ("&"'Result) = Length (Left) + 1 and
+ (for all I in Index_Type'First .. Last_Index (Left) => Element
(Left, I) = Element ("&"'Result, I)) and
+ Element ("&"'Result, Last_Index ("&"'Result)) = Right;
+
+ procedure Delete_First (Container : in out Vector; Count : in
Ada.Containers.Count_Type := 1) with
+ Pre => Length (Container) >= Count,
+ Post => Length (Container) = Length (Container)'Old - Count and then
+ (for all I in Index_Type'First .. Last_Index (Container) =>
+ Element (Container'Old, Index_Type (Integer (I) + Integer
(Count))) = Element (Container, I));
+ -- Remaining elements slide down.
+
+private
+
+ type Array_Type is array (Peek_Type range 1 .. Peek_Type (Capacity)) of
aliased Element_Type;
+
+ type Vector is
+ record
+ Elements : Array_Type;
+ Last : Extended_Index := No_Index;
+ end record with
+ Type_Invariant => To_Peek_Index (Last) <= Elements'Last;
+ pragma Annotate (GNATprove, Intentional, "type ""Vector"" is not fully
initialized",
+ "Only items in Elements with index < Last are accessed");
+
+ ----------
+ -- For child units
+
+ function To_Peek_Index (Index : in Extended_Index) return Base_Peek_Type is
+ (Base_Peek_Type (Index - Index_Type'First + 1));
+
+end SAL.Gen_Bounded_Definite_Vectors;
diff --git a/sal-gen_bounded_definite_vectors-gen_image.adb
b/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.adb
similarity index 59%
copy from sal-gen_bounded_definite_vectors-gen_image.adb
copy to sal-gen_bounded_definite_vectors_sorted-gen_image_aux.adb
index e1726d1..cee9c74 100644
--- a/sal-gen_bounded_definite_vectors-gen_image.adb
+++ b/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -17,23 +17,19 @@
pragma License (Modified_GPL);
-function SAL.Gen_Bounded_Definite_Vectors.Gen_Image (Item : in Vector) return
String
+with Ada.Strings.Unbounded;
+function SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Image_Aux (Item : in
Vector; Aux : in Aux_Data) 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);
+ Result : Unbounded_String := To_Unbounded_String ("(");
+ Last : constant Base_Peek_Type := 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)));
+ 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;
+end SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Image_Aux;
diff --git a/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.ads
b/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.ads
new file mode 100644
index 0000000..28c56fd
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.ads
@@ -0,0 +1,23 @@
+-- Abstract :
+--
+-- Image with auxiliary data for instantiations of parent.
+--
+-- Copyright (C) 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Aux_Data (<>) is private;
+ with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
+function SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Image_Aux (Item : in
Vector; Aux : in Aux_Data) return String;
diff --git a/sal-gen_bounded_definite_vectors_sorted-gen_refs.adb
b/sal-gen_bounded_definite_vectors_sorted-gen_refs.adb
new file mode 100644
index 0000000..fb5d619
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors_sorted-gen_refs.adb
@@ -0,0 +1,29 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Refs is
+
+ function Constant_Ref (Container : aliased Vector; Index : in Peek_Type)
return Constant_Reference_Type
+ is begin
+ return
+ (Element => Container.Elements (Index)'Access,
+ Dummy => 1);
+ end Constant_Ref;
+
+end SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Refs;
diff --git a/sal-gen_bounded_definite_vectors_sorted-gen_refs.ads
b/sal-gen_bounded_definite_vectors_sorted-gen_refs.ads
new file mode 100644
index 0000000..17e98c4
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors_sorted-gen_refs.ads
@@ -0,0 +1,39 @@
+-- Abstract :
+--
+-- Constant_Reference for parent.
+--
+-- In a child package because it's not Spark, and Spark does not
+-- allow 'Spark_Mode => Off' on type declarations.
+--
+-- Copyright (C) 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+package SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Refs is
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
+ Implicit_Dereference => Element;
+
+ function Constant_Ref (Container : aliased Vector; Index : in Peek_Type)
return Constant_Reference_Type with
+ Inline;
+
+private
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is
+ record
+ Dummy : Integer := raise Program_Error with "uninitialized reference";
+ end record;
+
+end SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Refs;
diff --git a/sal-gen_bounded_definite_vectors-gen_sorted.adb
b/sal-gen_bounded_definite_vectors_sorted.adb
similarity index 56%
rename from sal-gen_bounded_definite_vectors-gen_sorted.adb
rename to sal-gen_bounded_definite_vectors_sorted.adb
index b77f06c..9979f28 100644
--- a/sal-gen_bounded_definite_vectors-gen_sorted.adb
+++ b/sal-gen_bounded_definite_vectors_sorted.adb
@@ -1,90 +1,82 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body 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;
- Ignore_If_Equal : in Boolean := False)
- 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 =>
- if Ignore_If_Equal then
- return;
- else
- -- Insert after J
- exit;
- end if;
- 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;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Bounded_Definite_Vectors_Sorted is
+
+ function Length (Container : in Vector) return Ada.Containers.Count_Type
+ is (Ada.Containers.Count_Type (Container.Last));
+
+ function Is_Full (Container : in Vector) return Boolean
+ is begin
+ return Container.Last = Peek_Type (Capacity);
+ end Is_Full;
+
+ procedure Clear (Container : in out Vector)
+ is begin
+ Container.Last := No_Index;
+ end Clear;
+
+ function Last_Index (Container : in Vector) return Base_Peek_Type
+ is (Container.Last);
+
+ function Element (Container : in Vector; Index : in Peek_Type) return
Element_Type
+ is (Container.Elements (Index));
+
+ procedure Insert
+ (Container : in out Vector;
+ New_Item : in Element_Type;
+ Ignore_If_Equal : in Boolean := False)
+ is
+ K : constant Base_Peek_Type := Container.Last;
+ J : Base_Peek_Type := K;
+ begin
+ if K = 0 then
+ -- Container empty
+ Container.Last := 1;
+ Container.Elements (1) := New_Item;
+ return;
+ end if;
+
+ loop
+ pragma Loop_Invariant (J < Container.Elements'Last);
+ pragma Loop_Variant (Decreases => J);
+ exit when J < 1;
+
+ case Element_Compare (New_Item, Container.Elements (J)) is
+ when Less =>
+ J := J - 1;
+ when Equal =>
+ if Ignore_If_Equal then
+ return;
+ else
+ -- Insert after J
+ exit;
+ end if;
+ when Greater =>
+ -- Insert after J
+ exit;
+ end case;
+ end loop;
+
+ Container.Elements (J + 2 .. K + 1) := Container.Elements (J + 1 .. K);
+ Container.Elements (J + 1) := New_Item;
+ Container.Last := Container.Last + 1;
+ end Insert;
+
+end SAL.Gen_Bounded_Definite_Vectors_Sorted;
diff --git a/sal-gen_bounded_definite_vectors_sorted.ads
b/sal-gen_bounded_definite_vectors_sorted.ads
new file mode 100644
index 0000000..7bc398c
--- /dev/null
+++ b/sal-gen_bounded_definite_vectors_sorted.ads
@@ -0,0 +1,85 @@
+-- Abstract :
+--
+-- A simple bounded sorted vector of definite items, in Spark.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+generic
+ type Element_Type is private;
+ with function Element_Compare (Left, Right : in Element_Type) return
Compare_Result;
+ Capacity : in Ada.Containers.Count_Type;
+package SAL.Gen_Bounded_Definite_Vectors_Sorted
+ with Spark_Mode
+is
+ use all type Ada.Containers.Count_Type;
+
+ type Vector is private with
+ Default_Initial_Condition => Length (Vector) = 0;
+
+ function Length (Container : in Vector) return Ada.Containers.Count_Type
with
+ Post => Length'Result in 0 .. Capacity;
+
+ function Is_Full (Container : in Vector) return Boolean with
+ Post => Is_Full'Result = (Length (Container) = Capacity);
+
+ procedure Clear (Container : in out Vector) with
+ Post => Length (Container) = 0;
+
+ function First_Index (Container : in Vector) return Peek_Type
+ is (Peek_Type'First) with
+ Depends => (First_Index'Result => null, null => Container);
+
+ function Last_Index (Container : in Vector) return Base_Peek_Type with
+ Inline;
+
+ function Element (Container : in Vector; Index : in Peek_Type) return
Element_Type with
+ Pre => Index in First_Index (Container) .. Last_Index (Container);
+
+ function Is_Sorted (Container : in Vector) return Boolean is
+ (for all I in First_Index (Container) .. Last_Index (Container) - 1 =>
+ Element_Compare (Element (Container, I), Element (Container, I + 1))
in Less | Equal);
+
+ procedure Insert
+ (Container : in out Vector;
+ New_Item : in Element_Type;
+ Ignore_If_Equal : in Boolean := False) with
+ Pre => Length (Container) < Capacity,
+ Post => Is_Sorted (Container) and
+ (Length (Container) = Length (Container'Old) or
+ Length (Container) = Length (Container'Old) + 1);
+ -- Insert New_Item in sorted position. Items are sorted in increasing
+ -- order according to Element_Compare. New_Item is inserted after
+ -- Equal items, unless Ignore_If_Equal is true, in which case
+ -- New_Item is not inserted.
+ --
+ -- The presense of Ignore_If_Equal makes it too difficult to prove
+ -- whether the length did or did not increase.
+
+private
+
+ type Array_Type is array (Peek_Type range 1 .. Peek_Type (Capacity)) of
aliased Element_Type;
+
+ No_Index : constant Base_Peek_Type := 0;
+
+ type Vector is record
+ Elements : Array_Type;
+ Last : Base_Peek_Type := No_Index;
+ end record with
+ Type_Invariant => Last <= Elements'Last and Is_Sorted (Vector);
+ pragma Annotate (GNATprove, Intentional, "type ""Vector"" is not fully
initialized",
+ "Only items in Elements with index < Last are accessed");
+
+end SAL.Gen_Bounded_Definite_Vectors_Sorted;
diff --git a/sal-gen_definite_doubly_linked_lists.adb
b/sal-gen_definite_doubly_linked_lists.adb
index e8da73a..f0c5776 100644
--- a/sal-gen_definite_doubly_linked_lists.adb
+++ b/sal-gen_definite_doubly_linked_lists.adb
@@ -2,7 +2,7 @@
--
-- see spec
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or
-- modify it under terms of the GNU General Public License as
@@ -24,6 +24,21 @@ pragma License (Modified_GPL);
package body SAL.Gen_Definite_Doubly_Linked_Lists is
+ procedure Delete_Node (Container : in out List; Node : in out Node_Access)
+ is 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);
+ end Delete_Node;
+
---------
-- Public operations, declaration order.
@@ -186,23 +201,21 @@ package body SAL.Gen_Definite_Doubly_Linked_Lists is
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);
+ Delete_Node (Container, Position.Ptr);
Position := No_Element;
Container.Count := Container.Count - 1;
end Delete;
+ procedure Delete_First (Container : in out List)
+ is
+ use all type Ada.Containers.Count_Type;
+ Node : Node_Access := Container.Head;
+ begin
+ Delete_Node (Container, Node);
+ Container.Count := Container.Count - 1;
+ end Delete_First;
+
procedure Insert
(Container : in out List;
Before : in Cursor;
@@ -252,25 +265,25 @@ package body SAL.Gen_Definite_Doubly_Linked_Lists is
is
pragma Unreferenced (Container);
begin
- return (Element => Position.Ptr.all.Element'Access);
+ return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
end Constant_Reference;
function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
is begin
- return (Element => Position.Ptr.all.Element'Access);
+ return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
end Constant_Ref;
- function Reference (Container : in List; Position : in Cursor) return
Reference_Type
+ function Variable_Reference (Container : in List; Position : in Cursor)
return Variable_Reference_Type
is
pragma Unreferenced (Container);
begin
- return (Element => Position.Ptr.all.Element'Access);
- end Reference;
+ return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
+ end Variable_Reference;
- function Ref (Position : in Cursor) return Reference_Type
+ function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
is begin
- return (Element => Position.Ptr.all.Element'Access);
- end Ref;
+ return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
+ end Variable_Ref;
function Iterate (Container : aliased in List) return
Iterator_Interfaces.Reversible_Iterator'Class
is begin
diff --git a/sal-gen_definite_doubly_linked_lists.ads
b/sal-gen_definite_doubly_linked_lists.ads
index fda94c4..9648320 100644
--- a/sal-gen_definite_doubly_linked_lists.ads
+++ b/sal-gen_definite_doubly_linked_lists.ads
@@ -34,7 +34,7 @@ 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,
+ Variable_Indexing => Variable_Reference,
Default_Iterator => Iterate,
Iterator_Element => Element_Type;
@@ -52,6 +52,8 @@ package SAL.Gen_Definite_Doubly_Linked_Lists is
overriding procedure Finalize (Container : in out List);
-- Free all items in List.
+ procedure Clear (Container : in out List) renames Finalize;
+
function Length (Container : in List) return Ada.Containers.Count_Type;
procedure Append (Container : in out List; Element : in Element_Type);
@@ -83,6 +85,8 @@ package SAL.Gen_Definite_Doubly_Linked_Lists is
procedure Delete (Container : in out List; Position : in out Cursor)
with Pre => Position /= No_Element;
+ procedure Delete_First (Container : in out List);
+
procedure Insert
(Container : in out List;
Before : in Cursor;
@@ -92,25 +96,24 @@ package SAL.Gen_Definite_Doubly_Linked_Lists is
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;
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
+ Implicit_Dereference => Element;
function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type
- with Pre => Position /= No_Element;
- pragma Inline (Constant_Reference);
+ with Inline, Pre => Position /= No_Element;
+ -- Not 'Constant_Ref' because that is taken, and it is wrong for
Constant_Indexing
+
function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
- with Pre => Position /= No_Element;
- pragma Inline (Constant_Ref);
+ with Inline, Pre => Position /= No_Element;
- type Reference_Type (Element : not null access Element_Type) is null record
- with Implicit_Dereference => Element;
+ type Variable_Reference_Type (Element : not null access Element_Type) is
private with
+ Implicit_Dereference => Element;
- function Reference (Container : in List; Position : in Cursor) return
Reference_Type
- with Pre => Position /= No_Element;
- pragma Inline (Reference);
- function Ref (Position : in Cursor) return Reference_Type
- with Pre => Position /= No_Element;
- pragma Inline (Ref);
+ function Variable_Reference (Container : in List; Position : in Cursor)
return Variable_Reference_Type
+ with Inline, Pre => Position /= No_Element;
+
+ function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
+ with Inline, Pre => Position /= No_Element;
package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
@@ -140,6 +143,16 @@ private
Ptr : Node_Access;
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_List : constant List := (Ada.Finalization.Controlled with null, null,
0);
No_Element : constant Cursor := (null, null);
diff --git a/sal-gen_definite_doubly_linked_lists_sorted.adb
b/sal-gen_definite_doubly_linked_lists_sorted.adb
index addac4f..7a4bb11 100644
--- a/sal-gen_definite_doubly_linked_lists_sorted.adb
+++ b/sal-gen_definite_doubly_linked_lists_sorted.adb
@@ -1,542 +1,542 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body 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;
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body 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, Dummy => 1);
+ end Constant_Reference;
+
+ function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
+ end Constant_Ref;
+
+ function Variable_Reference (Container : in List; Position : in Cursor)
return Variable_Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
+ end Variable_Reference;
+
+ function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
+ end Variable_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
index d57748b..bbac90f 100644
--- a/sal-gen_definite_doubly_linked_lists_sorted.ads
+++ b/sal-gen_definite_doubly_linked_lists_sorted.ads
@@ -1,181 +1,191 @@
--- Abstract :
---
--- A generic sorted doubly linked list with definite elements.
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.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.
-
- procedure Clear (Container : in out List) renames Finalize;
-
- 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;
- pragma Inline (Constant_Reference);
- function Constant_Ref (Position : in Cursor) return Constant_Reference_Type;
- pragma Inline (Constant_Ref);
-
- type Reference_Type (Element : not null access Element_Type) is null record
- with Implicit_Dereference => Element;
-
- function Reference (Container : in List; Position : in Cursor) return
Reference_Type
- with Pre => Position /= No_Element;
- pragma Inline (Reference);
- function Ref (Position : in Cursor) return Reference_Type
- with Pre => Position /= No_Element;
- pragma Inline (Ref);
- -- User must not change the element in a way that affects the sort order.
-
- package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
-
- 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;
+-- Abstract :
+--
+-- A generic sorted doubly linked list with definite elements.
+--
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.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 => Variable_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.
+
+ procedure Clear (Container : in out List) renames Finalize;
+
+ 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 private with
+ Implicit_Dereference => Element;
+
+ function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type with
+ Inline, Pre => Position /= No_Element;
+
+ function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
with
+ Inline, Pre => Position /= No_Element;
+
+ type Variable_Reference_Type (Element : not null access Element_Type) is
private with
+ Implicit_Dereference => Element;
+
+ function Variable_Reference (Container : in List; Position : in Cursor)
return Variable_Reference_Type
+ with Inline, Pre => Position /= No_Element;
+
+ function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
+ with Inline, 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;
+
+ 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_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_graphs.adb b/sal-gen_graphs.adb
index 284b26c..ef0fcc3 100644
--- a/sal-gen_graphs.adb
+++ b/sal-gen_graphs.adb
@@ -55,10 +55,9 @@ package body SAL.Gen_Graphs is
Graph.Vertices.Set_First_Last (Vertex, Vertex);
else
if Vertex < Graph.Vertices.First_Index then
- Graph.Vertices.Set_First (Vertex);
- end if;
- if Vertex > Graph.Vertices.Last_Index then
- Graph.Vertices.Set_Last (Vertex);
+ Graph.Vertices.Set_First_Last (Vertex,
Graph.Vertices.Last_Index);
+ elsif Vertex > Graph.Vertices.Last_Index then
+ Graph.Vertices.Set_First_Last (Graph.Vertices.First_Index,
Vertex);
end if;
end if;
end Update_First_Last;
@@ -158,8 +157,10 @@ package body SAL.Gen_Graphs is
To : in Edge_Data)
return Path_Arrays.Vector
is
- Vertex_Queue : Vertex_Queues.Queue_Type
- (Size => Integer (Graph.Vertices.Last_Index -
Graph.Vertices.First_Index + 1));
+ use Vertex_Queues;
+
+ Vertex_Queue : Queue_Type
+ (Size => Peek_Type (Graph.Vertices.Last_Index -
Graph.Vertices.First_Index + 1));
type Colors is (White, Gray, Black);
@@ -227,11 +228,11 @@ package body SAL.Gen_Graphs is
end if;
end loop;
- Vertex_Queue.Put (From);
+ Put (Vertex_Queue, From);
- while not Vertex_Queue.Is_Empty loop
+ while not Is_Empty (Vertex_Queue) loop
declare
- U_Index : constant Vertex_Index := Vertex_Queue.Get;
+ U_Index : constant Vertex_Index := Get (Vertex_Queue);
U : Aux_Node renames Aux (U_Index);
begin
Edges :
@@ -253,7 +254,7 @@ package body SAL.Gen_Graphs is
Result_List.Append (Build_Path (V_Index, Result_Edge));
end if;
- Vertex_Queue.Put (V_Index);
+ Put (Vertex_Queue, V_Index);
end if;
end;
end loop Edges;
diff --git a/sal-gen_indefinite_doubly_linked_lists.adb
b/sal-gen_indefinite_doubly_linked_lists.adb
index 071c319..ced09c2 100644
--- a/sal-gen_indefinite_doubly_linked_lists.adb
+++ b/sal-gen_indefinite_doubly_linked_lists.adb
@@ -1,201 +1,211 @@
--- Abstract :
---
--- see spec
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This library is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of 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;
+-- Abstract :
+--
+-- see spec
+--
+-- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, or (at
+-- your option) any later version. This library is distributed in the
+-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
+-- the implied warranty of 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_Ref (Position : in Cursor) return Constant_Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element, Dummy => 1);
+ end Constant_Ref;
+
+ function Constant_Reference (Container : in List; 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, Dummy => 1);
+ end Constant_Reference;
+
+ function Variable_Reference (Container : in List; Position : in Peek_Type)
return Variable_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, Dummy => 1);
+ end Variable_Reference;
+
+ function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
+ is begin
+ return (Element => Position.Ptr.all.Element, Dummy => 1);
+ end Variable_Ref;
+
+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
index 0ebfc54..609e26c 100644
--- a/sal-gen_indefinite_doubly_linked_lists.ads
+++ b/sal-gen_indefinite_doubly_linked_lists.ads
@@ -29,7 +29,9 @@ generic
type Element_Type (<>) is private;
package SAL.Gen_Indefinite_Doubly_Linked_Lists is
- type List is new Ada.Finalization.Controlled with private;
+ type List is new Ada.Finalization.Controlled with private with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Variable_Reference;
Empty_List : constant List;
@@ -66,23 +68,23 @@ package SAL.Gen_Indefinite_Doubly_Linked_Lists is
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;
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
+ Implicit_Dereference => Element;
- function Constant_Reference (Position : in Cursor) return
Constant_Reference_Type
- with Pre => Has_Element (Position);
- pragma Inline (Constant_Reference);
+ function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
+ with Inline, Pre => Has_Element (Position);
- function Constant_Ref (Container : in List'Class; Position : in Peek_Type)
return Constant_Reference_Type
- with Pre => Position <= Container.Length;
- pragma Inline (Constant_Ref);
+ function Constant_Reference (Container : in List; Position : in Peek_Type)
return Constant_Reference_Type
+ with Inline, Pre => Position <= Container.Length;
- type Reference_Type (Element : not null access Element_Type) is null record
- with Implicit_Dereference => Element;
+ type Variable_Reference_Type (Element : not null access Element_Type) is
private with
+ Implicit_Dereference => Element;
- function Reference (Position : in Cursor) return Reference_Type
- with Pre => Has_Element (Position);
- pragma Inline (Reference);
+ function Variable_Reference (Container : in List; Position : in Peek_Type)
return Variable_Reference_Type
+ with Inline, Pre => Position <= Container.Length;
+
+ function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
+ with Inline, Pre => Has_Element (Position);
private
type Node_Type;
@@ -110,6 +112,16 @@ private
Ptr : Node_Access;
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_List : constant List := (Ada.Finalization.Controlled with null, null,
0);
No_Element : constant Cursor := (null, null);
diff --git a/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
b/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
index c58a9d4..c88a0cb 100644
--- a/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
+++ b/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
@@ -35,27 +35,6 @@ package body SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci
is
----------
-- 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
@@ -319,22 +298,26 @@ package body
SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci is
procedure Add (Heap : in out Heap_Type; Item : in Element_Type)
is
- X : constant Node_Access := Add (Heap, Item);
- pragma Unreferenced (X);
+ X : constant Node_Access := new Node'(Item, null, null, null, null, 0,
False);
begin
- null;
- end Add;
+ -- [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);
- 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;
+ if Key (Item) < Key (Heap.Min.Element) then
+ Heap.Min := X;
+ end if;
+ end if;
+ Heap.Count := Heap.Count + 1;
end Add;
function Peek (Heap : in Heap_Type) return Constant_Reference_Type
is begin
- return (Element => Heap.Min.all.Element'Access);
+ return (Element => Heap.Min.all.Element'Access, Dummy => 1);
end Peek;
procedure Process (Heap : in Heap_Type; Process_Element : access procedure
(Element : in Element_Type))
diff --git a/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
b/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
index 6f978e7..aab9fcf 100644
--- a/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
+++ b/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
@@ -25,7 +25,6 @@ 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);
@@ -68,23 +67,8 @@ package SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci is
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;
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
+ Implicit_Dereference => Element;
function Peek (Heap : in Heap_Type) return Constant_Reference_Type;
-- Return a constant reference to the min element.
@@ -117,8 +101,11 @@ private
Min : Node_Access;
Count : Base_Peek_Type;
end record;
- type Heap_Access_Constant is access constant Heap_Type;
- for Heap_Access_Constant'Storage_Size use 0;
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is
+ record
+ Dummy : Integer := raise Program_Error with "uninitialized reference";
+ end record;
Empty_Heap : constant Heap_Type := (Ada.Finalization.Controlled with Min =>
null, Count => 0);
diff --git a/sal-gen_unbounded_definite_queues.adb
b/sal-gen_unbounded_definite_queues.adb
index f0290fc..af53823 100644
--- a/sal-gen_unbounded_definite_queues.adb
+++ b/sal-gen_unbounded_definite_queues.adb
@@ -2,7 +2,7 @@
--
-- See spec.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -81,7 +81,7 @@ package body SAL.Gen_Unbounded_Definite_Queues is
Next (I);
end loop;
- return (Element => Element_Lists.Reference (Queue.Data, I).Element,
Dummy => 1);
+ return (Element => Element_Lists.Variable_Reference (Queue.Data,
I).Element, Dummy => 1);
end Variable_Peek;
procedure Add (Queue : in out Pkg.Queue; Item : in Element_Type)
diff --git a/sal-gen_unbounded_definite_queues.ads
b/sal-gen_unbounded_definite_queues.ads
index 8e7163b..237800d 100644
--- a/sal-gen_unbounded_definite_queues.ads
+++ b/sal-gen_unbounded_definite_queues.ads
@@ -17,7 +17,7 @@
pragma License (Modified_GPL);
-with Ada.Containers.Doubly_Linked_Lists;
+with SAL.Gen_Definite_Doubly_Linked_Lists;
generic
type Element_Type is private;
package SAL.Gen_Unbounded_Definite_Queues is
@@ -37,7 +37,7 @@ package SAL.Gen_Unbounded_Definite_Queues is
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.
+ -- Return true if no items are in Queue.
function Is_Full (Queue : in Pkg.Queue) return Boolean is (False);
-- Return true if Queue is full.
@@ -85,7 +85,7 @@ package SAL.Gen_Unbounded_Definite_Queues is
private
- package Element_Lists is new Ada.Containers.Doubly_Linked_Lists
(Element_Type);
+ package Element_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists
(Element_Type);
-- We don't provide cursors or write access to queue elements, so we
-- don't need any tampering checks.
diff --git a/sal-gen_unbounded_definite_red_black_trees.adb
b/sal-gen_unbounded_definite_red_black_trees.adb
index 9099f06..adea0d4 100644
--- a/sal-gen_unbounded_definite_red_black_trees.adb
+++ b/sal-gen_unbounded_definite_red_black_trees.adb
@@ -2,7 +2,7 @@
--
-- Generic unbounded red-black tree with definite elements.
--
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -298,53 +298,53 @@ package body SAL.Gen_Unbounded_Definite_Red_Black_Trees is
return Cursor.Node /= null;
end Has_Element;
- function Constant_Ref
+ function Constant_Reference
(Container : aliased in Tree;
Position : in Cursor)
- return Constant_Ref_Type
+ return Constant_Reference_Type
is
pragma Unreferenced (Container);
begin
- return (Element => Position.Node.all.Element'Access);
- end Constant_Ref;
+ return (Element => Position.Node.all.Element'Access, Dummy => 1);
+ end Constant_Reference;
- function Constant_Ref
+ function Constant_Reference
(Container : aliased in Tree;
Key : in Key_Type)
- return Constant_Ref_Type
+ return Constant_Reference_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);
+ return (Element => Node.all.Element'Access, Dummy => 1);
end if;
- end Constant_Ref;
+ end Constant_Reference;
- function Variable_Ref
+ function Variable_Reference
(Container : aliased in Tree;
Position : in Cursor)
- return Variable_Ref_Type
+ return Variable_Reference_Type
is
pragma Unreferenced (Container);
begin
- return (Element => Position.Node.all.Element'Access);
- end Variable_Ref;
+ return (Element => Position.Node.all.Element'Access, Dummy => 1);
+ end Variable_Reference;
- function Variable_Ref
+ function Variable_Reference
(Container : aliased in Tree;
Key : in Key_Type)
- return Variable_Ref_Type
+ return Variable_Reference_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);
+ return (Element => Node.all.Element'Access, Dummy => 1);
end if;
- end Variable_Ref;
+ end Variable_Reference;
function Iterate (Tree : in Pkg.Tree'Class) return Iterator
is begin
diff --git a/sal-gen_unbounded_definite_red_black_trees.ads
b/sal-gen_unbounded_definite_red_black_trees.ads
index 83c9c88..b51e4b9 100644
--- a/sal-gen_unbounded_definite_red_black_trees.ads
+++ b/sal-gen_unbounded_definite_red_black_trees.ads
@@ -37,8 +37,8 @@ package SAL.Gen_Unbounded_Definite_Red_Black_Trees is
type Tree is new Ada.Finalization.Limited_Controlled with private
with
- Constant_Indexing => Constant_Ref,
- Variable_Indexing => Variable_Ref,
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Variable_Reference,
Default_Iterator => Iterate,
Iterator_Element => Element_Type;
@@ -58,34 +58,35 @@ package SAL.Gen_Unbounded_Definite_Red_Black_Trees is
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;
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
+ Implicit_Dereference => Element;
- function Constant_Ref
+ function Constant_Reference
(Container : aliased in Tree;
Position : in Cursor)
- return Constant_Ref_Type;
+ return Constant_Reference_Type with
+ Inline;
- function Constant_Ref
+ function Constant_Reference
(Container : aliased in Tree;
Key : in Key_Type)
- return Constant_Ref_Type;
- pragma Inline (Constant_Ref);
+ return Constant_Reference_Type with
+ Inline;
- type Variable_Ref_Type (Element : not null access Element_Type) is null
record
- with Implicit_Dereference => Element;
+ type Variable_Reference_Type (Element : not null access Element_Type) is
private with
+ Implicit_Dereference => Element;
- function Variable_Ref
+ function Variable_Reference
(Container : aliased in Tree;
Position : in Cursor)
- return Variable_Ref_Type;
- pragma Inline (Variable_Ref);
+ return Variable_Reference_Type with
+ Inline;
- function Variable_Ref
+ function Variable_Reference
(Container : aliased in Tree;
Key : in Key_Type)
- return Variable_Ref_Type;
- pragma Inline (Variable_Ref);
+ return Variable_Reference_Type with
+ Inline;
-- Raises Not_Found if Key not found in Container.
package Iterators is new Ada.Iterator_Interfaces (Cursor, Has_Element);
@@ -116,11 +117,13 @@ package SAL.Gen_Unbounded_Definite_Red_Black_Trees is
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.
+ -- Find first element with key in range First .. Last. If Direction
+ -- is Ascending, start at First, otherwise start at Last.
--
- -- Has_Element is False if there is no such Key.
+ -- Has_Element (result) is False if there is no such element.
+ --
+ -- The Iterator does not remember First, Last; the user must check
+ -- those for any element that Next or Previous returns.
function Count (Tree : in Pkg.Tree) return Ada.Containers.Count_Type;
@@ -131,7 +134,7 @@ package SAL.Gen_Unbounded_Definite_Red_Black_Trees is
-- 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.
+ -- Delete element at Position, set Position to No_Element.
private
type Node;
@@ -169,6 +172,16 @@ private
Right_Done : Boolean := True;
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;
+
No_Element : constant Cursor :=
(Node => null,
Direction => Unknown,
diff --git a/sal-gen_unbounded_definite_stacks.adb
b/sal-gen_unbounded_definite_stacks.adb
index 0a54eab..2ead18f 100644
--- a/sal-gen_unbounded_definite_stacks.adb
+++ b/sal-gen_unbounded_definite_stacks.adb
@@ -165,25 +165,25 @@ package body SAL.Gen_Unbounded_Definite_Stacks is
Stack.Data (Depth - Index + 1) := Element;
end Set;
- function Constant_Ref
+ function Constant_Reference
(Container : aliased in Stack'Class;
Position : in Peek_Type)
- return Constant_Ref_Type
+ return Constant_Reference_Type
is begin
return
(Element => Container.Data (Container.Top - Position + 1)'Access,
Dummy => 1);
- end Constant_Ref;
+ end Constant_Reference;
- function Constant_Ref
+ function Constant_Reference
(Container : aliased in Stack'Class;
Position : in Cursor)
- return Constant_Ref_Type
+ return Constant_Reference_Type
is begin
return
(Element => Container.Data (Container.Top - Position.Ptr + 1)'Access,
Dummy => 1);
- end Constant_Ref;
+ end Constant_Reference;
function Has_Element (Position : in Cursor) return Boolean
is begin
diff --git a/sal-gen_unbounded_definite_stacks.ads
b/sal-gen_unbounded_definite_stacks.ads
index cb54a24..26d0466 100644
--- a/sal-gen_unbounded_definite_stacks.ads
+++ b/sal-gen_unbounded_definite_stacks.ads
@@ -33,7 +33,7 @@ package SAL.Gen_Unbounded_Definite_Stacks is
type Stack is new Ada.Finalization.Controlled with private
with
- Constant_Indexing => Constant_Ref,
+ Constant_Indexing => Constant_Reference,
Default_Iterator => Iterate,
Iterator_Element => Element_Type;
@@ -56,7 +56,7 @@ package SAL.Gen_Unbounded_Definite_Stacks is
function Peek
(Stack : in Sguds.Stack;
Index : in Peek_Type := 1)
- return Element_Type;
+ return Element_Type with Inline;
-- Return the Index'th item from the top of Stack; the Item is _not_
removed.
-- Top item has index 1.
--
@@ -106,25 +106,20 @@ package SAL.Gen_Unbounded_Definite_Stacks is
--
-- 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;
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
+ Implicit_Dereference => Element;
- function Constant_Ref
+ function Constant_Reference
(Container : aliased in Stack'Class;
Position : in Peek_Type)
- return Constant_Ref_Type;
- pragma Inline (Constant_Ref);
+ return Constant_Reference_Type with Inline;
type Cursor is private;
- function Constant_Ref
+ function Constant_Reference
(Container : aliased in Stack'Class;
Position : in Cursor)
- return Constant_Ref_Type;
- pragma Inline (Constant_Ref);
+ return Constant_Reference_Type with Inline;
function Has_Element (Position : in Cursor) return Boolean;
@@ -143,11 +138,16 @@ private
Data : Element_Array_Access;
-- Top of stack is at Data (Top).
- -- Data (1 .. Last_Index) has been set at some point.
+ -- Data (1 .. Top) has been set at some point.
end record;
type Stack_Access is access all Stack;
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is
+ record
+ Dummy : Integer := raise Program_Error with "uninitialized reference";
+ end record;
+
Empty_Stack : constant Stack := (Ada.Finalization.Controlled with
Invalid_Peek_Index, null);
type Cursor is record
diff --git a/sal-gen_unbounded_definite_vectors.adb
b/sal-gen_unbounded_definite_vectors.adb
index b5019bb..be77f9c 100644
--- a/sal-gen_unbounded_definite_vectors.adb
+++ b/sal-gen_unbounded_definite_vectors.adb
@@ -112,6 +112,26 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
end if;
end Capacity;
+ procedure Set_Capacity
+ (Container : in out Vector;
+ First : in Index_Type;
+ Last : in Extended_Index)
+ is
+ First_Peek : constant Peek_Type := To_Peek_Type (First);
+ Last_Peek : constant Peek_Type := To_Peek_Type (Last);
+ begin
+ if Container.Elements = null then
+ Container.Elements := new Array_Type (First_Peek .. Last_Peek);
+ else
+ if First_Peek < Container.Elements'First then
+ Grow (Container.Elements, First_Peek);
+ end if;
+ if Last_Peek < Container.Elements'Last then
+ Grow (Container.Elements, Last_Peek);
+ end if;
+ end if;
+ end Set_Capacity;
+
function Element (Container : Vector; Index : Index_Type) return
Element_Type
is begin
return Container.Elements (To_Peek_Type (Index));
@@ -124,7 +144,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
function First_Index (Container : Vector) return Extended_Index
is begin
- if Container.Elements = null then
+ if Container.First = No_Index then
return No_Index + 1;
else
return Container.First;
@@ -133,11 +153,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
function Last_Index (Container : Vector) return Extended_Index
is begin
- if Container.Elements = null then
- return No_Index;
- else
- return Container.Last;
- end if;
+ return Container.Last;
end Last_Index;
procedure Append (Container : in out Vector; New_Item : in Element_Type)
@@ -388,19 +404,6 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
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 Delete (Container : in out Vector; Index : in Index_Type)
is
J : constant Peek_Type := To_Peek_Type (Index);
@@ -438,10 +441,8 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
end Element;
function First (Container : aliased in Vector) return Cursor
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Container.Length = 0 then
+ is begin
+ if Container.First = No_Index then
return No_Element;
else
return (Container'Access, To_Peek_Type (Container.First));
@@ -517,7 +518,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
is
J : constant Peek_Type := To_Peek_Type (Index);
begin
- return (Element => Container.Elements (J)'Access);
+ return (Element => Container.Elements (J)'Access, Dummy => 1);
end Constant_Ref;
function Variable_Ref
@@ -527,7 +528,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
is
J : constant Peek_Type := To_Peek_Type (Index);
begin
- return (Element => Container.Elements (J)'Access);
+ return (Element => Container.Elements (J)'Access, Dummy => 1);
end Variable_Ref;
overriding function First (Object : Iterator) return Cursor
@@ -535,7 +536,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
if Object.Container.Elements = null then
return (null, Invalid_Peek_Index);
else
- return (Object.Container, To_Peek_Type
(Object.Container.First_Index));
+ return (Object.Container, To_Peek_Type (Object.Container.First));
end if;
end First;
@@ -544,7 +545,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
if Object.Container.Elements = null then
return (null, Invalid_Peek_Index);
else
- return (Object.Container, To_Peek_Type (Object.Container.Last_Index));
+ return (Object.Container, To_Peek_Type (Object.Container.Last));
end if;
end Last;
@@ -573,7 +574,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
function Constant_Ref (Container : aliased Vector; Position : in Cursor)
return Constant_Reference_Type
is begin
- return (Element => Container.Elements (Position.Index)'Access);
+ return (Element => Container.Elements (Position.Index)'Access, Dummy =>
1);
end Constant_Ref;
function Variable_Ref
@@ -581,7 +582,7 @@ package body SAL.Gen_Unbounded_Definite_Vectors is
Position : in Cursor)
return Variable_Reference_Type
is begin
- return (Element => Container.Elements (Position.Index)'Access);
+ return (Element => Container.Elements (Position.Index)'Access, Dummy =>
1);
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
index 8023794..76cca13 100644
--- a/sal-gen_unbounded_definite_vectors.ads
+++ b/sal-gen_unbounded_definite_vectors.ads
@@ -1,230 +1,241 @@
--- 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 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with Ada.Iterator_Interfaces;
-with Ada.Unchecked_Deallocation;
-generic
- type Index_Type is range <>;
- type Element_Type is private;
- Default_Element : in Element_Type;
-package SAL.Gen_Unbounded_Definite_Vectors is
-
- subtype Extended_Index is Index_Type'Base
- 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
- -- Default_Element value.
-
- procedure Set_Length (Container : in out Vector; Length : in
Ada.Containers.Count_Type);
- -- Set Last so Container.Length returns Length. New elements have
- -- Default_Element 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;
- pragma Inline (Constant_Ref);
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
null record
- with Implicit_Dereference => Element;
-
- function Variable_Ref (Container : aliased in Vector; Index : in
Index_Type) return Variable_Reference_Type
- with Pre => Index >= Container.First_Index and Index <=
Container.Last_Index;
- pragma Inline (Variable_Ref);
-
- type Cursor is private;
-
- 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 Prev (Position : in Cursor) return Cursor;
- procedure Prev (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);
- pragma Inline (Constant_Ref);
-
- function Variable_Ref (Container : aliased in Vector; Position : in
Cursor) return Variable_Reference_Type
- with Pre => Has_Element (Position);
- pragma Inline (Variable_Ref);
-
-private
-
- 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;
- function To_Index_Type (Item : in Base_Peek_Type) return Extended_Index;
-
-end SAL.Gen_Unbounded_Definite_Vectors;
+-- 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 - 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with Ada.Iterator_Interfaces;
+with Ada.Unchecked_Deallocation;
+generic
+ type Index_Type is range <>;
+ type Element_Type is private;
+ Default_Element : in Element_Type;
+package SAL.Gen_Unbounded_Definite_Vectors is
+
+ subtype Extended_Index is Index_Type'Base
+ 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 Set_Capacity
+ (Container : in out Vector;
+ First : in Index_Type;
+ Last : in Extended_Index);
+ -- Allocates memory, but does not change Container.First, Container.Last.
+
+ 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_Last
+ (Container : in out Vector;
+ First : in Index_Type;
+ Last : in Extended_Index);
+ -- Elements in First .. Last that have not been set have
+ -- Default_Element 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 private with
+ Implicit_Dereference => Element;
+
+ function Constant_Ref (Container : aliased in Vector; Index : in
Index_Type) return Constant_Reference_Type
+ with Inline, Pre => Index in Container.First_Index .. Container.Last_Index;
+
+ type Variable_Reference_Type (Element : not null access Element_Type) is
private with
+ Implicit_Dereference => Element;
+
+ function Variable_Ref (Container : aliased in Vector; Index : in
Index_Type) return Variable_Reference_Type
+ with Inline, Pre => Index in Container.First_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 Prev (Position : in Cursor) return Cursor;
+ procedure Prev (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 Inline, Pre => Has_Element (Position);
+
+ function Variable_Ref (Container : aliased in Vector; Position : in
Cursor) return Variable_Reference_Type
+ with Pre => Has_Element (Position);
+ pragma Inline (Variable_Ref);
+
+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;
+ -- Elements may be non-null with First = No_Index, after
+ -- Set_Capacity. If First /= No_Index and Last >= First, Elements /=
+ -- null.
+ 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;
+
+ 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_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;
+ function To_Index_Type (Item : in Base_Peek_Type) return Extended_Index;
+
+ procedure Grow (Elements : in out Array_Access; Index : in Base_Peek_Type);
+
+end SAL.Gen_Unbounded_Definite_Vectors;
diff --git a/sal-gen_unbounded_definite_vectors_sorted.adb
b/sal-gen_unbounded_definite_vectors_sorted.adb
new file mode 100644
index 0000000..6d836c5
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors_sorted.adb
@@ -0,0 +1,368 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+package body SAL.Gen_Unbounded_Definite_Vectors_Sorted is
+
+ ----------
+ -- Body subprograms, arbitrary order
+
+ 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;
+
+ procedure Find
+ (Container : in Vector;
+ Key : in Key_Type;
+ Found : out Boolean;
+ At_After : out Base_Peek_Type)
+ with Pre => Container.Last /= No_Index
+ is
+ -- If Found is True, item is at At_After. If False, item should be
+ -- inserted after At_After.
+ Low : Base_Peek_Type := Peek_Type'First - 1;
+ High : Base_Peek_Type := Container.Last + 1;
+ I : Base_Peek_Type := Low + High / 2;
+ begin
+ loop
+ case Key_Compare (Key, To_Key (Container.Elements (I))) is
+ when Less =>
+ High := I;
+ if I = Low then
+ Found := False;
+ At_After := I;
+ return;
+
+ elsif I - 1 = Low then
+ Found := False;
+ At_After := I - 1;
+ return;
+
+ else
+ I := I - (I - Low) / 2;
+ end if;
+
+ when Equal =>
+ Found := True;
+ At_After := I;
+ return;
+
+ when Greater =>
+ Low := I;
+ if I = High then
+ Found := False;
+ At_After := I - 1;
+ return;
+
+ elsif I + 1 = High then
+ Found := False;
+ At_After := I;
+ return;
+
+ else
+ I := I + (High - I) / 2;
+ end if;
+ end case;
+ end loop;
+ end Find;
+
+ ----------
+ -- Public subprograms
+
+ overriding procedure Finalize (Container : in out Vector)
+ is begin
+ Free (Container.Elements);
+ 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 (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;
+
+ procedure Set_Capacity
+ (Container : in out Vector;
+ Length : in Ada.Containers.Count_Type)
+ is
+ use all type Ada.Containers.Count_Type;
+ First_Peek : constant Peek_Type := Peek_Type'First;
+ Last_Peek : constant Base_Peek_Type := Base_Peek_Type (Length);
+ begin
+ if Length = 0 then
+ return;
+ elsif Container.Elements = null then
+ Container.Elements := new Array_Type (First_Peek .. Last_Peek);
+ else
+ if First_Peek < Container.Elements'First then
+ Grow (Container.Elements, First_Peek);
+ end if;
+ if Last_Peek < Container.Elements'Last then
+ Grow (Container.Elements, Last_Peek);
+ end if;
+ end if;
+ end Set_Capacity;
+
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ return Position.Index /= Invalid_Peek_Index;
+ end Has_Element;
+
+ function "&" (Left, Right : in Element_Type) return Vector
+ is begin
+ return Result : Vector do
+ Result.Insert (Left);
+ Result.Insert (Right);
+ end return;
+ end "&";
+
+ function "&" (Left : in Vector; Right : in Element_Type) return Vector
+ is begin
+ return Result : Vector := Left do
+ Result.Insert (Right);
+ end return;
+ end "&";
+
+ function Contains (Container : in Vector; Key : in Key_Type) return Boolean
+ is
+ Found : Boolean;
+ I : Base_Peek_Type;
+ begin
+ if Container.Last = No_Index then
+ return False;
+ end if;
+ Find (Container, Key, Found, I);
+ return Found;
+ end Contains;
+
+ procedure Insert
+ (Container : in out Vector;
+ New_Item : in Element_Type)
+ is
+ New_Key : constant Key_Type := To_Key (New_Item);
+ J : constant Peek_Type := Peek_Type'First;
+ K : constant Base_Peek_Type := Container.Last;
+ I : Base_Peek_Type := K;
+ begin
+ if Container.Last = No_Index then
+ Container.Last := Peek_Type'First;
+ I := Container.Last;
+
+ if Container.Elements = null then
+ Container.Elements := new Array_Type (I .. I);
+ -- else Set_Capacity called.
+ end if;
+ Container.Elements (I) := New_Item;
+ return;
+
+ else
+ Container.Last := Container.Last + 1;
+ end if;
+
+ pragma Assert (Container.Elements /= null);
+
+ if I + 1 > Container.Elements'Last then
+ Grow (Container.Elements, I + 1);
+ end if;
+
+ loop
+ exit when I < J;
+
+ case Key_Compare (New_Key, To_Key (Container.Elements (I))) is
+ when Less =>
+ -- Linear search is simple, we assume insert is used far less
often
+ -- than Find. And this is optimal when inserting in Key order.
+ I := I - 1;
+ when Equal =>
+ -- Insert after I
+ exit;
+ when Greater =>
+ -- Insert after I
+ exit;
+ end case;
+ end loop;
+
+ if I < J then
+ -- Insert before all
+ Container.Elements (J + 1 .. K + 1) := Container.Elements (J .. K);
+ Container.Elements (J) := New_Item;
+ else
+ -- Insert after I
+ Container.Elements (I + 2 .. K + 1) := Container.Elements (I + 1 ..
K);
+ Container.Elements (I + 1) := New_Item;
+ end if;
+ end Insert;
+
+ function Find
+ (Container : aliased in Vector;
+ Key : in Key_Type)
+ return Find_Reference_Type
+ is
+ Found : Boolean;
+ I : Base_Peek_Type;
+ begin
+ if Container.Last = No_Index then
+ return (Element => null, Dummy => 1);
+ end if;
+ Find (Container, Key, Found, I);
+ if Found then
+ return (Element => Container.Elements (I)'Access, Dummy => 1);
+ else
+ return (Element => null, Dummy => 1);
+ end if;
+ end Find;
+
+ function Find_Constant
+ (Container : aliased in Vector;
+ Key : in Key_Type)
+ return Find_Reference_Constant_Type
+ is
+ Found : Boolean;
+ I : Base_Peek_Type;
+ begin
+ if Container.Last = No_Index then
+ return (Element => null, Dummy => 1);
+ end if;
+ Find (Container, Key, Found, I);
+ if Found then
+ return (Element => Container.Elements (I)'Access, Dummy => 1);
+ else
+ return (Element => null, Dummy => 1);
+ end if;
+ end Find_Constant;
+
+ overriding function First (Object : Iterator) return Cursor
+ is begin
+ if Object.Container.Elements = null then
+ return (null, Invalid_Peek_Index);
+ else
+ return (Object.Container, Peek_Type'First);
+ 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, Object.Container.Last);
+ end if;
+ end Last;
+
+ overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
+ is begin
+ if Position.Index = 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 = Peek_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, Dummy =>
1);
+ end Constant_Ref;
+
+ function Last_Index (Container : aliased Vector) return Base_Peek_Type
+ is begin
+ return Container.Last;
+ end Last_Index;
+
+ function Constant_Ref (Container : aliased Vector; Index : in Peek_Type)
return Constant_Reference_Type
+ is begin
+ return (Element => Container.Elements (Index)'Access, Dummy => 1);
+ end Constant_Ref;
+
+end SAL.Gen_Unbounded_Definite_Vectors_Sorted;
diff --git a/sal-gen_unbounded_definite_vectors_sorted.ads
b/sal-gen_unbounded_definite_vectors_sorted.ads
new file mode 100644
index 0000000..c197ec4
--- /dev/null
+++ b/sal-gen_unbounded_definite_vectors_sorted.ads
@@ -0,0 +1,170 @@
+-- Abstract :
+--
+-- A simple unbounded sorted vector of definite items.
+--
+-- Copyright (C) 2019 Free Software Foundation, Inc.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 3, or (at your option) any later
+-- version. This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+-- As a special exception under Section 7 of GPL version 3, you are granted
+-- additional permissions described in the GCC Runtime Library Exception,
+-- version 3.1, as published by the Free Software Foundation.
+
+pragma License (Modified_GPL);
+
+with Ada.Finalization;
+with Ada.Iterator_Interfaces;
+with Ada.Unchecked_Deallocation;
+generic
+ type Element_Type is private;
+ type Key_Type is private;
+ with function To_Key (Item : in Element_Type) return Key_Type;
+ with function Key_Compare (Left, Right : in Key_Type) return Compare_Result;
+package SAL.Gen_Unbounded_Definite_Vectors_Sorted is
+
+ type Vector is new Ada.Finalization.Controlled with private with
+ Constant_Indexing => Constant_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);
+
+ procedure Clear (Container : in out Vector)
+ renames Finalize;
+
+ function Length (Container : in Vector) return Ada.Containers.Count_Type;
+ function Capacity (Container : in Vector) return Ada.Containers.Count_Type;
+
+ procedure Set_Capacity
+ (Container : in out Vector;
+ Length : in Ada.Containers.Count_Type);
+ -- Allocates uninitialized memory; does not change Container.First,
+ -- Container.Last.
+
+ function "&" (Left, Right : in Element_Type) return Vector;
+ function "&" (Left : in Vector; Right : in Element_Type) return Vector;
+
+ function Contains (Container : in Vector; Key : in Key_Type) return Boolean;
+
+ 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.
+ --
+ -- Raises Duplicate_Key if To_Key (New_Item) is already in Container.
+
+ type Find_Reference_Type (Element : access Element_Type) is private with
+ Implicit_Dereference => Element;
+
+ function Find
+ (Container : aliased in Vector;
+ Key : in Key_Type)
+ return Find_Reference_Type;
+ -- Result.Element is null if Key not in Container. User must not modify
Key.
+
+ type Find_Reference_Constant_Type (Element : access constant Element_Type)
is private with
+ Implicit_Dereference => Element;
+
+ function Find_Constant
+ (Container : aliased in Vector;
+ Key : in Key_Type)
+ return Find_Reference_Constant_Type;
+ -- Result.Element is null if Key not in Container.
+
+ type Cursor is private;
+
+ No_Element : constant Cursor;
+
+ function Has_Element (Position : Cursor) return Boolean;
+
+ package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
+
+ function Iterate (Container : aliased in Vector) return
Iterator_Interfaces.Reversible_Iterator'Class;
+
+ type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
+ Implicit_Dereference => Element;
+
+ function Constant_Ref (Container : aliased Vector; Position : in Cursor)
return Constant_Reference_Type
+ with Inline;
+
+ function First_Index (Container : aliased Vector) return Peek_Type is
(Peek_Type'First);
+ function Last_Index (Container : aliased Vector) return Base_Peek_Type
+ with Inline;
+ function Constant_Ref (Container : aliased Vector; Index : in Peek_Type)
return Constant_Reference_Type
+ with Inline;
+
+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);
+
+ No_Index : constant Base_Peek_Type := 0;
+
+ type Vector is new Ada.Finalization.Controlled with
+ record
+ Elements : Array_Access;
+ -- Elements may be non-null with First = No_Index, after
+ -- Set_Capacity. If First /= No_Index and Last >= First, Elements /=
+ -- null.
+ Last : Base_Peek_Type := 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 := No_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;
+
+ type Find_Reference_Type (Element : access Element_Type) is
+ record
+ Dummy : Integer := raise Program_Error with "uninitialized reference";
+ end record;
+
+ type Find_Reference_Constant_Type (Element : access constant Element_Type)
is
+ record
+ Dummy : Integer := raise Program_Error with "uninitialized reference";
+ 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;
+
+ Empty_Vector : constant Vector := (Ada.Finalization.Controlled with others
=> <>);
+
+ No_Element : constant Cursor := (others => <>);
+
+ ----------
+ -- Visible for child package
+
+ procedure Grow (Elements : in out Array_Access; Index : in Base_Peek_Type);
+
+end SAL.Gen_Unbounded_Definite_Vectors_Sorted;
diff --git a/sal.adb b/sal.adb
index ac3b037..e3f5d52 100644
--- a/sal.adb
+++ b/sal.adb
@@ -26,7 +26,7 @@ package body SAL is
function Version return String is
begin
- return "SAL 3.2";
+ return "SAL 3.3";
end Version;
end SAL;
diff --git a/wisi-compile.el b/wisi-compile.el
deleted file mode 100644
index 9788938..0000000
--- a/wisi-compile.el
+++ /dev/null
@@ -1,225 +0,0 @@
-;; wisi-compile.el --- Grammar compiler for the wisi parser, integrating Wisi
OpenToken output. -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2012-2017 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/>.
-;;
-
-;;; Commentary:
-;;
-
-;;;; History: first experimental version Jan 2013
-;;
-;;;; Context
-;;
-;; Semantic (info "(semantic)Top") provides an LALR(1) parser
-;; wisent-parse. The grammar used is defined by the functions
-;; semantic-grammar-create-package, which reads a bison-like source
-;; file and produces corresponding elisp source, and
-;; wisent-compile-grammar, which generates a parser table.
-;;
-;; However, the algorithm used in wisent-compile-grammar cannot cope
-;; with the grammar for the Ada language, because it is not
-;; LALR(1). So we provide a generalized LALR parser, which spawns
-;; parallel LALR parsers at each conflict. Instead of also rewriting
-;; the entire semantic grammar compiler, we use the OpenToken LALR
-;; parser generator, which is easier to modify (it is written in Ada,
-;; not Lisp).
-;;
-;; The Ada function Wisi.Generate reads the bison-like input and
-;; produces corresponding elisp source code, similar to that
-;; produced by semantic-grammar-create-package.
-;;
-;; wisi-compile-grammar (provided here) generates the automaton
-;; structure required by wisi-parse
-;;
-;;;;
-
-(defun wisi-compose-action (value symbol-obarray nonterms)
- (let* ((nonterm (car value))
- (index (cdr value))
- (symbol (intern-soft (format "%s:%d" nonterm index) symbol-obarray))
- (rhs (car (nth index (cdr (assoc nonterm nonterms))))))
- (list nonterm symbol (length rhs))
- ))
-
-(defun wisi-replace-actions (action symbol-obarray nonterms)
- "Replace semantic action symbol names in ACTION with list as defined in
`wisi-compile-grammar'.
-ACTION is the alist for one state from the grammar, with the form:
- ((default . error) ITEM ... )
-ITEM is one of:
-reduction (TOKEN . (NONTERM . INDEX)) where NONTERM . INDEX gives the action
symbol name.
-shift (TOKEN . STATE)
-shift/reduce conflict (STATE (NONTERM . INDEX))
-reduce/shift conflict ((NONTERM . INDEX) (NONTERM . INDEX))
-
-SYMBOL-OBARRAY contains the action symbols.
-NONTERMS is from the grammar.
-Return the new action alist."
- ;; result is list of (nonterm index action-symbol token-count)
- (let (result item)
- (while action
- (setq item (pop action))
- (cond
- ((or
- (memq (cdr item) '(error accept))
- (numberp (cdr item))) ;; shift
- (push item result))
-
- ((listp (cdr item))
- (let ((value (cdr item)))
- (cond
- ((symbolp (car value))
- ;; reduction
- (push (cons (car item)
- (wisi-compose-action value symbol-obarray nonterms))
- result))
-
- ((integerp (car value))
- ;; shift/reduce conflict
- (push (cons (car item)
- (list (car value)
- (wisi-compose-action (cadr value) symbol-obarray
nonterms)))
- result))
-
- (t ;; reduce/reduce conflict
- (push (cons (car item)
- (list (wisi-compose-action (car value) symbol-obarray
nonterms)
- (wisi-compose-action (cadr value) symbol-obarray
nonterms)))
- result))
- )))
-
- (t
- (error "unexpected '%s'; expected 'error, 'accept, numberp, stringp,
listp" (cdr item)))
- ));; while/cond
-
- (reverse result)))
-
-(defun wisi-semantic-action (form nonterm iactn symbol-obarray)
- "Define an Elisp semantic action function for a production, interned in
SYMBOL-OBARRAY.
-FORM is the body of the semantic action.
-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;
-- 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."
- ;; based on comp.el wisent-semantic-action
- (let* ((name (format "%s:%d" nonterm iactn))
- (action-symbol (intern name symbol-obarray)))
-
- (fset action-symbol
- `(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 NONTERMS ACTIONS GOTOS, where:
-
-NONTERMS is a list of productions; each production is a
-list (nonterm (tokens semantic-action) ...) where `semantic-action' is
-any lisp form. The set of (tokens semantic-action) are the right hand
-sides; nonterm is the left hand side.
-
-ACTIONS is an array indexed by parser state, of alists indexed by
-terminal tokens. The value of each item in the alists is one of:
-
-`error'
-
-`accept'
-
-integer - shift; gives new state
-
- (nonterm . index) - reduce by nonterm production index.
-
- (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
-current token.
-
-GOTOS is an array indexed by parser state, of alists giving the
-new state after a reduce for each nonterminal legal in that
-state.
-
-The automaton is an array [parser-actions gotos symbol-obarray]:
-
-- parser-actions is a copy of the input ACTIONS, with semantic
-actions replaced by a list (nonterm action-symbol token-count),
-where:
-
--- nonterm is a symbol from NONTERMS, and is the non-terminal to
-reduce to
-
--- token-count is the number of tokens in the reduction,
-
--- action-symbol is nil if there is no semantic action, or a
-symbol interned in symbol-obarray
-
-- gotos is a copy of GOTOS.
-
-- symbol-obarray is an obarray containing functions that
-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.
-
- (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
- semantic-action index)
-
- (while defs
- (setq def (car defs)
- defs (cdr defs)
- nonterm (car def)
- rhs-list (cdr def)
- index 0)
- (while rhs-list
- (setq rule (car rhs-list)
- rhs-list (cdr rhs-list)
- semantic-action (cadr rule))
-
- (when semantic-action
- (wisi-semantic-action semantic-action nonterm index symbol-obarray))
-
- (setq index (1+ index))
- ))
-
- ;; replace semantic actions in ACTIONS with symbols from symbol-obarray
- (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 0
grammar)))
- (setq i (1+ i)))
- (vector
- actions
- (nth 2 grammar)
- symbol-obarray)
- )))
-
-(provide 'wisi-compile)
-;;; wisi-compile.el ends here
diff --git a/wisi-elisp-lexer.el b/wisi-elisp-lexer.el
deleted file mode 100644
index b0d1e3c..0000000
--- a/wisi-elisp-lexer.el
+++ /dev/null
@@ -1,393 +0,0 @@
-;;; 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
deleted file mode 100644
index 2c93a37..0000000
--- a/wisi-elisp-parse.el
+++ /dev/null
@@ -1,1721 +0,0 @@
-;; wisi-elisp-parse.el --- Wisi parser -*- lexical-binding:t -*-
-
-;; Copyright (C) 2013-2015, 2017 - 2019 Free Software Foundation, Inc.
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-
-;; An extended LALR parser, that handles shift/reduce and
-;; reduce/reduce conflicts by spawning parallel parsers to follow each
-;; path.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'wisi-elisp-lexer)
-(require 'wisi-parse-common)
-
-(defvar wisi-elisp-parse-max-parallel-current (cons 0 0)
- "Cons (count . point); Maximum number of parallel parsers used in most
recent parse,
-point at which that max was spawned.")
-
-(defvar wisi-debug-identical 0
- "Debug terminating identical parsers.
-0 - keep lower-numbered parser.
-1 - keep higher-numbered parser.
-2 - error.")
-
-(cl-defstruct (wisi-elisp-parser-state
- (:copier nil))
- label ;; integer identifying parser for debug
-
- active
- ;; 'shift - need new token
- ;; 'reduce - need reduce
- ;; 'accept - parsing completed
- ;; 'error - failed, error not reported yet
- ;; nil - terminated
- ;;
- ;; 'pending-shift, 'pending-reduce - newly created parser
-
- stack
- ;; Each stack item takes two slots: wisi-tok, state
-
- sp ;; stack pointer
-
- pending
- ;; list of (action-symbol stack-fragment)
- )
-
-(cl-defstruct (wisi-elisp-parser (:include wisi-parser))
- actions
- gotos
- next-token
- )
-
-;;;###autoload
-(defun wisi-make-elisp-parser (automaton next-token)
- "Return ‘wisi-parser’ object.
-
-- AUTOMATON is the parse table generated by `wisi-compile-grammar'.
-
-- NEXT-TOKEN is a function with no argument called by the parser to
- obtain the next token from the current buffer after point, as a
- ’wisi-tok’ object (normally ‘wisi-forward-token’)."
- (make-wisi-elisp-parser
- :actions (aref automaton 0)
- :gotos (aref automaton 1)
- :next-token next-token))
-
-(cl-defmethod wisi-parse-kill ((_parser wisi-elisp-parser))
- nil)
-
-(defvar wisi-elisp-parse--indent nil
- ;; not buffer-local; only let-bound in wisi-parse-current (elisp)
- "A vector of indentation for all lines in buffer.
-Each element can be one of:
-- nil : no indent set yet
-
-- integer : indent
-
-- list ('anchor (start-id ...) indent) :
- indent for current line, base indent for following 'anchored
- lines. Start-id is list of ids anchored at this line. For parens
- and other uses.
-
-- list ('anchored id delta) :
- indent = delta + 'anchor id line indent; for lines indented
- relative to anchor.
-
-- list ('anchor (start-id ...) ('anchored id delta))
- for nested anchors.")
-
-(cl-defmethod wisi-parse-current ((parser wisi-elisp-parser) _begin _send-end
_parse-end)
- "Parse entire current buffer.
-BEGIN, END are ignored"
-
- (let ((actions (wisi-elisp-parser-actions parser))
- (gotos (wisi-elisp-parser-gotos parser))
- (parser-states ;; vector of parallel parser states
- (vector
- (make-wisi-elisp-parser-state
- :label 0
- :active 'shift
- :stack (make-vector wisi-parse-max-stack-size nil)
- :sp 0
- :pending nil)))
- (active-parser-count 1)
- active-parser-count-prev
- (active 'shift)
- (token nil)
- some-pending
- wisi-elisp-parse--indent)
-
- (cl-case wisi--parse-action
- (indent
- (let ((line-count (1+ (count-lines (point-min) (point-max)))))
- (setq wisi-elisp-parse--indent (make-vector line-count nil))
- (wisi-elisp-lexer-reset line-count wisi--lexer)))
-
- (navigate
- (setq wisi-end-caches nil))
-
- (t nil))
-
- (setf (wisi-parser-lexer-errors parser) nil)
- (setf (wisi-parser-parse-errors parser) nil)
-
- ;; We assume the lexer relies on syntax properties
- (when (< emacs-major-version 25) (syntax-propertize (point-max)))
-
- (goto-char (point-min))
- (forward-comment (point-max))
- (aset (wisi-elisp-parser-state-stack (aref parser-states 0)) 0 0)
-
- (setq token (funcall (wisi-elisp-parser-next-token parser)))
- (setq wisi-elisp-parse-max-parallel-current (cons 0 0))
-
- (while (not (eq active 'accept))
- (setq active-parser-count-prev active-parser-count)
- (setq some-pending nil)
- (dotimes (parser-index (length parser-states))
- (when (eq active (wisi-elisp-parser-state-active (aref parser-states
parser-index)))
- (let* ((parser-state (aref parser-states parser-index))
- (result (wisi-elisp-parse-1 token parser-state (>
active-parser-count 1) actions gotos)))
- (when result
- ;; spawn a new parser
- (when (= active-parser-count wisi-parse-max-parallel)
- (let* ((state (aref (wisi-elisp-parser-state-stack parser-state)
- (wisi-elisp-parser-state-sp parser-state)))
- (msg (wisi-error-msg (concat "too many parallel parsers
required in grammar state %d;"
- " simplify grammar, or
increase `wisi-elisp-parse-max-parallel'")
- state)))
- (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error msg)))
-
- (let ((j (wisi-elisp-parse-free-parser parser-states)))
- (cond
- ((= j -1)
- ;; Add to parser-states; the new parser won't be executed
- ;; again in this parser-index loop.
- (setq parser-states (vconcat parser-states (vector nil)))
- (setq j (1- (length parser-states))))
- ((< j parser-index)
- ;; The new parser won't be executed again in this
- ;; parser-index loop; nothing to do.
- )
- (t
- ;; Don't let the new parser execute again in this
- ;; parser-index loop.
- (setq some-pending t)
- (setf (wisi-elisp-parser-state-active result)
- (cl-case (wisi-elisp-parser-state-active result)
- (shift 'pending-shift)
- (reduce 'pending-reduce)
- )))
- )
- (setq active-parser-count (1+ active-parser-count))
- (when (> active-parser-count (car
wisi-elisp-parse-max-parallel-current))
- (setq wisi-elisp-parse-max-parallel-current (cons
active-parser-count (point))))
- (setf (wisi-elisp-parser-state-label result) j)
- (aset parser-states j result))
- (when (> wisi-debug 1)
- (message "spawn parser (%d active)" active-parser-count)))
-
- (when (eq 'error (wisi-elisp-parser-state-active parser-state))
- (setq active-parser-count (1- active-parser-count))
- (when (> wisi-debug 1)
- (message "terminate parser (%d active)" active-parser-count))
- (cl-case active-parser-count
- (0
- (cond
- ((= active-parser-count-prev 1)
- ;; We were not in a parallel parse; abandon parsing, report
the error.
- (let* ((state (aref (wisi-elisp-parser-state-stack
parser-state)
- (wisi-elisp-parser-state-sp
parser-state)))
- (msg (wisi-error-msg "syntax error in grammar state
%d; unexpected %s, expecting one of %s"
- state
- (wisi-token-text token)
- (mapcar 'car (aref actions
state)))))
- (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error msg)))
- (t
- ;; Report errors from all parsers that failed on this token.
- (let ((msg))
- (dotimes (_ (length parser-states))
- (let* ((parser-state (aref parser-states parser-index))
- (state (aref (wisi-elisp-parser-state-stack
parser-state)
- (wisi-elisp-parser-state-sp
parser-state))))
- (when (eq 'error (wisi-elisp-parser-state-active
parser-state))
- (setq msg
- (concat msg
- (when msg "\n")
- (wisi-error-msg
- "syntax error in grammar state %d;
unexpected %s, expecting one of %s"
- state
- (wisi-token-text token)
- (mapcar 'car (aref actions state)))))
- )))
- (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error msg)))
- ))
-
- (1
- (setf (wisi-elisp-parser-state-active parser-state) nil);
Don't save error for later.
- (wisi-elisp-parse-execute-pending (aref parser-states
(wisi-elisp-parse-active-parser parser-states))))
-
- (t
- ;; We were in a parallel parse, and this parser
- ;; failed; mark it inactive, don't save error for
- ;; later.
- (setf (wisi-elisp-parser-state-active parser-state) nil)
- )))
- )));; end dotimes
-
- (when some-pending
- ;; Change pending-* parsers to *.
- (dotimes (parser-index (length parser-states))
- (cond
- ((eq (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'pending-shift)
- (setf (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'shift))
- ((eq (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'pending-reduce)
- (setf (wisi-elisp-parser-state-active (aref parser-states
parser-index)) 'reduce))
- )))
-
- (setq active (wisi-elisp-parsers-active parser-states
active-parser-count))
- (when (eq active 'shift)
- (when (> active-parser-count 1)
- (setq active-parser-count (wisi-elisp-parse-elim-identical parser
parser-states active-parser-count)))
-
- (setq token (funcall (wisi-elisp-parser-next-token parser))))
- )
- (when (> active-parser-count 1)
- (error "ambiguous parse result"))
-
- (cl-case wisi--parse-action
- (indent
- (wisi-elisp-parse--indent-leading-comments)
- (wisi-elisp-parse--resolve-anchors))
-
- (t nil))
-
- ;; Return region parsed.
- (cons (point-min) (point))
- ))
-
-(defun wisi-elisp-parsers-active-index (parser-states)
- ;; only called when active-parser-count = 1
- (let ((result nil)
- (i 0))
- (while (and (not result)
- (< i (length parser-states)))
- (when (wisi-elisp-parser-state-active (aref parser-states i))
- (setq result i))
- (setq i (1+ i)))
- result))
-
-(defun wisi-elisp-parsers-active (parser-states active-count)
- "Return the type of parser cycle to execute.
-PARSER-STATES[*].active is the last action a parser took. If it
-was `shift', that parser used the input token, and should not be
-executed again until another input token is available, after all
-parsers have shifted the current token or terminated.
-
-Returns one of:
-
-`accept' : all PARSER-STATES have active set to nil or `accept' -
-done parsing
-
-`shift' : all PARSER-STATES have active set to nil, `accept', or
-`shift' - get a new token, execute `shift' parsers.
-
-`reduce' : some PARSER-STATES have active set to `reduce' - no new
-token, execute `reduce' parsers."
- (let ((result nil)
- (i 0)
- (shift-count 0)
- (accept-count 0)
- active)
- (while (and (not result)
- (< i (length parser-states)))
- (setq active (wisi-elisp-parser-state-active (aref parser-states i)))
- (cond
- ((eq active 'shift) (setq shift-count (1+ shift-count)))
- ((eq active 'reduce) (setq result 'reduce))
- ((eq active 'accept) (setq accept-count (1+ accept-count)))
- )
- (setq i (1+ i)))
-
- (cond
- (result )
- ((= accept-count active-count)
- 'accept)
- ((= (+ shift-count accept-count) active-count)
- 'shift)
- (t
- ;; all parsers in error state; should not get here
- (error "all parsers in error state; programmer error"))
- )))
-
-(defun wisi-elisp-parse-free-parser (parser-states)
- "Return index to a non-active parser in PARSER-STATES, -1 if there is none."
- (let ((result nil)
- (i 0))
- (while (and (not result)
- (< i (length parser-states)))
- (when (not (wisi-elisp-parser-state-active (aref parser-states i)))
- (setq result i))
- (setq i (1+ i)))
- (if result result -1)))
-
-(defun wisi-elisp-parse-active-parser (parser-states)
- "Return index to the first active parser in PARSER-STATES."
- (let ((result nil)
- (i 0))
- (while (and (not result)
- (< i (length parser-states)))
- (when (wisi-elisp-parser-state-active (aref parser-states i))
- (setq result i))
- (setq i (1+ i)))
- (unless result
- (error "no active parsers"))
- result))
-
-(defun wisi-elisp-parse-elim-identical (parser parser-states
active-parser-count)
- "Check for parsers in PARSER-STATES that have reached identical states
eliminate one.
-Return new ACTIVE-PARSER-COUNT. Assumes all parsers have active
-nil, `shift', or `accept'."
- ;; parser-states passed by reference; active-parser-count by copy
- ;; see test/ada_mode-slices.adb for example
- (dotimes (parser-i (1- (length parser-states)))
- (when (wisi-elisp-parser-state-active (aref parser-states parser-i))
- (dotimes (parser-j (- (length parser-states) parser-i 1))
- (when (wisi-elisp-parser-state-active (aref parser-states (+ parser-i
parser-j 1)))
- (when (eq (wisi-elisp-parser-state-sp (aref parser-states parser-i))
- (wisi-elisp-parser-state-sp (aref parser-states (+
parser-i parser-j 1))))
- (let ((compare t)
- exec)
- (dotimes (stack-i (wisi-elisp-parser-state-sp (aref parser-states
parser-i)))
- (setq
- compare
- (and compare ;; bypass expensive 'arefs' after first stack
item compare fail
- (equal (aref (wisi-elisp-parser-state-stack (aref
parser-states parser-i)) stack-i)
- (aref (wisi-elisp-parser-state-stack (aref
parser-states (+ parser-i parser-j 1)))
- stack-i)))))
- (when compare
- ;; parser stacks are identical
- (setq active-parser-count (1- active-parser-count))
- (when (> wisi-debug 1)
- (message "terminate identical parser %d (%d active)"
- (+ parser-i parser-j 1) active-parser-count)
- (let ((state-i (aref parser-states parser-i))
- (state-j (aref parser-states (+ parser-i parser-j 1))))
- (message "%d actions:" (wisi-elisp-parser-state-label
state-i))
- (mapc #'wisi-elisp-parse-debug-put-action
(wisi-elisp-parser-state-pending state-i))
-
- (message "%d actions:" (wisi-elisp-parser-state-label
state-j))
- (mapc #'wisi-elisp-parse-debug-put-action
(wisi-elisp-parser-state-pending state-j))
- ))
- (cl-ecase wisi-debug-identical
- (0
- (setq exec parser-i)
- (setf (wisi-elisp-parser-state-active (aref parser-states (+
parser-i parser-j 1))) nil))
-
- (1
- (setq exec (+ parser-i parser-j 1))
- (setf (wisi-elisp-parser-state-active (aref parser-states
parser-i)) nil))
-
- (2
- (let ((msg "identical parser stacks"))
- (push (make-wisi--parse-error :pos (point) :message msg)
(wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error msg)))
- )
- (when (= active-parser-count 1)
- ;; The actions for the two parsers are not
- ;; identical, but most of the time either is good
- ;; enough for indentation and navigation, so we just
- ;; do the actions for the one that is not
- ;; terminating. Some times, a significant action is
- ;; lost. In that case, turn on
- ;; ‘wisi-debug-identical’ to investigate fixing it.
- (wisi-elisp-parse-execute-pending (aref parser-states exec)))
- ))))
- )))
- active-parser-count)
-
-(defun wisi-elisp-parse-exec-action (func nonterm tokens)
- "Execute action if TOKENS not null."
- ;; `tokens' is null when all tokens in a grammar statement are
- ;; optional and not present.
- (unless wisi-action-disable
- (if (< 0 (length tokens))
- (when wisi--parse-action
- (funcall func nonterm tokens))
-
- (when (> wisi-debug 1)
- (message "... action skipped; no tokens"))
- )))
-
-(defvar wisi-elisp-parser-state nil
- "Let-bound in `wisi-elisp-parse-reduce', used in `wisi-parse-find-token'.")
-
-(defun wisi-elisp-parse-debug-put-action (action)
- ;; Action is (semantic-function nonterm [tokens])
- (message "%s [%s]"
- (nth 0 action)
- (mapcar #'wisi-tok-debug-image (nth 2 action))))
-
-(defun wisi-elisp-parse-execute-pending (parser-state)
- (let ((wisi-elisp-parser-state parser-state);; reference, for
wisi-parse-find-token
- (pending (wisi-elisp-parser-state-pending parser-state)))
-
- (when (> wisi-debug 1)
- (message "%d: pending actions:" (wisi-elisp-parser-state-label
parser-state)))
-
- (while pending
- (when (> wisi-debug 1) (wisi-elisp-parse-debug-put-action (car pending)))
-
- (let ((func-args (pop pending)))
- (wisi-elisp-parse-exec-action (nth 0 func-args) (nth 1 func-args)
(cl-caddr func-args)))
- )
- (setf (wisi-elisp-parser-state-pending parser-state) nil)
- ))
-
-(defmacro wisi-elisp-parse-action (i al)
- "Return the parser action.
-I is a token item number and AL is the list of (item . action)
-available at current state. The first element of AL contains the
-default action for this state."
- `(cdr (or (assq ,i ,al) (car ,al))))
-
-(defun wisi-elisp-parse-1 (token parser-state pendingp actions gotos)
- "Perform one shift or reduce on PARSER-STATE.
-If PENDINGP, push actions onto PARSER-STATE.pending; otherwise execute them.
-See `wisi-elisp-parse' for full details.
-Return nil or new parser (a wisi-elisp-parser-state struct)."
- (let* ((state (aref (wisi-elisp-parser-state-stack parser-state)
- (wisi-elisp-parser-state-sp parser-state)))
- (parse-action (wisi-elisp-parse-action (wisi-tok-token token) (aref
actions state)))
- new-parser-state)
-
- (when (> wisi-debug 1)
- ;; output trace info
- (if (> wisi-debug 2)
- (progn
- ;; put top 10 stack items
- (let* ((count (min 20 (wisi-elisp-parser-state-sp parser-state)))
- (msg (make-vector (+ 1 count) nil)))
- (dotimes (i count)
- (aset msg (- count i)
- (aref (wisi-elisp-parser-state-stack parser-state)
- (- (wisi-elisp-parser-state-sp parser-state) i)))
- )
- (message "%d: %s: %d: %s"
- (wisi-elisp-parser-state-label parser-state)
- (wisi-elisp-parser-state-active parser-state)
- (wisi-elisp-parser-state-sp parser-state)
- msg))
- (message " %d: %s: %s" state (wisi-tok-debug-image token)
parse-action))
- (message "%d: %d: %s: %s" (wisi-elisp-parser-state-label parser-state)
state token parse-action)))
-
- (when (and (listp parse-action)
- (not (symbolp (car parse-action))))
- ;; Conflict; spawn a new parser.
- (setq new-parser-state
- (make-wisi-elisp-parser-state
- :active nil
- :stack (vconcat (wisi-elisp-parser-state-stack parser-state))
- :sp (wisi-elisp-parser-state-sp parser-state)
- :pending (wisi-elisp-parser-state-pending parser-state)))
-
- (wisi-elisp-parse-2 (cadr parse-action) token new-parser-state t gotos)
- (setq pendingp t)
- (setq parse-action (car parse-action))
- );; when
-
- ;; current parser
- (wisi-elisp-parse-2 parse-action token parser-state pendingp gotos)
-
- new-parser-state))
-
-(defun wisi-elisp-parse-2 (action token parser-state pendingp gotos)
- "Execute parser ACTION (must not be a conflict).
-Return nil."
- (cond
- ((eq action 'accept)
- (setf (wisi-elisp-parser-state-active parser-state) 'accept))
-
- ((eq action 'error)
- (setf (wisi-elisp-parser-state-active parser-state) 'error))
-
- ((natnump action)
- ;; Shift token and new state (= action) onto stack
- (let ((stack (wisi-elisp-parser-state-stack parser-state)); reference
- (sp (wisi-elisp-parser-state-sp parser-state))); copy
- (setq sp (+ sp 2))
- (aset stack (1- sp) token)
- (aset stack sp action)
- (setf (wisi-elisp-parser-state-sp parser-state) sp))
- (setf (wisi-elisp-parser-state-active parser-state) 'shift))
-
- (t
- (wisi-elisp-parse-reduce action parser-state pendingp gotos)
- (setf (wisi-elisp-parser-state-active parser-state) 'reduce))
- ))
-
-(defun wisi-elisp-parse-first-last (stack i j)
- "Return a pair (FIRST . LAST), indices for the first and last
-non-empty tokens for a nonterminal; or nil if all tokens are
-empty. STACK is the parser stack. I and J are the indices in
-STACK of the first and last tokens of the nonterminal."
- (let ((start (car (wisi-tok-region (aref stack i))))
- (end (cdr (wisi-tok-region (aref stack j)))))
- (while (and (or (not start) (not end))
- (/= i j))
- (cond
- ((not start)
- ;; item i is an empty production
- (setq start (car (wisi-tok-region (aref stack (setq i (+ i 2)))))))
-
- ((not end)
- ;; item j is an empty production
- (setq end (cdr (wisi-tok-region (aref stack (setq j (- j 2)))))))
-
- (t (setq i j))))
-
- (when (and start end)
- (cons i j))
- ))
-
-(cl-defmethod wisi-parse-find-token ((_parser wisi-elisp-parser) token-symbol)
- "Find token with TOKEN-SYMBOL on current parser stack, return token struct.
-For use in grammar actions."
- ;; Called from wisi-parse-exec-action in wisi-parse-reduce
- (let* ((stack (wisi-elisp-parser-state-stack wisi-elisp-parser-state))
- (sp (1- (wisi-elisp-parser-state-sp wisi-elisp-parser-state)))
- (tok (aref stack sp)))
- (while (and (> sp 0)
- (not (eq token-symbol (wisi-tok-token tok))))
- (setq sp (- sp 2))
- (setq tok (aref stack sp)))
- (if (= sp 0)
- (error "token %s not found on parse stack" token-symbol)
- tok)
- ))
-
-(cl-defmethod wisi-parse-stack-peek ((_parser wisi-elisp-parser) n)
- ;; IMPROVEME: store stack in parser
- (let* ((stack (wisi-elisp-parser-state-stack wisi-elisp-parser-state))
- (sp (1- (wisi-elisp-parser-state-sp wisi-elisp-parser-state)))
- (i (- sp (* 2 n))))
- (when (> i 0)
- (aref stack i))))
-
-(defun wisi-elisp-parse-reduce (action parser-state pendingp gotos)
- "Reduce PARSER-STATE.stack, and execute or pend ACTION."
- (let* ((wisi-elisp-parser-state parser-state);; reference, for
wisi-parse-find-token
- (stack (wisi-elisp-parser-state-stack parser-state)); reference
- (sp (wisi-elisp-parser-state-sp parser-state)); copy
- (token-count (nth 2 action))
- (nonterm (nth 0 action))
- (first-last (when (> token-count 0)
- (wisi-elisp-parse-first-last stack (- sp (* 2 (1-
token-count)) 1) (1- sp))))
- (nonterm-region (when first-last
- (cons
- (car (wisi-tok-region (aref stack (car
first-last))))
- (cdr (wisi-tok-region (aref stack (cdr
first-last)))))))
- (post-reduce-state (aref stack (- sp (* 2 token-count))))
- (new-state (cdr (assoc nonterm (aref gotos post-reduce-state))))
- (tokens (make-vector token-count nil))
- line first comment-line comment-end)
-
- (when (not new-state)
- (error "no goto for %s %d" nonterm post-reduce-state))
-
- (dotimes (i token-count) ;; i = 0 .. (1- token-count); last token = 0,
first token = (1- token-count)
- (let ((tok (aref stack (- sp (* 2 i) 1))))
- (when (nth 1 action)
- ;; don't need wisi-tokens for a null user action
- (aset tokens (- token-count i 1) tok))
-
- (when (eq wisi--parse-action 'indent)
- (setq line (or (wisi-tok-line tok) line))
- (cond
- ((numberp (wisi-tok-first tok))
- (setq first (wisi-tok-first tok)))
-
- ((wisi-tok-first tok)
- (setq first (wisi-tok-line tok)))
-
- ((and (not (= i 0))
- (wisi-tok-comment-line tok))
- ;; comment lines following last token are not included in nonterm
- ;; test/ada_mode-nominal.ads Object_Access_Type_5a
- ;; test/ada_mode-parens.adb
- (setq first (wisi-tok-comment-line tok)))
- )
- (when (and (= i 0)
- (wisi-tok-comment-line tok))
- (setq comment-line (wisi-tok-comment-line tok))
- (setq comment-end (wisi-tok-comment-end tok)))
- )))
-
- (setq sp (+ 2 (- sp (* 2 token-count))))
- (aset stack (1- sp)
- (make-wisi-tok
- :token nonterm
- :region nonterm-region
- :nonterminal t
- :line line
- :first first
- :comment-line comment-line
- :comment-end comment-end))
- (aset stack sp new-state)
- (setf (wisi-elisp-parser-state-sp parser-state) sp)
-
- (when (nth 1 action)
- ;; nothing to do for a null user action
- (if pendingp
- (if (wisi-elisp-parser-state-pending parser-state)
- (setf (wisi-elisp-parser-state-pending parser-state)
- (append (wisi-elisp-parser-state-pending parser-state)
- (list (list (nth 1 action) nonterm tokens))))
- (setf (wisi-elisp-parser-state-pending parser-state)
- (list (list (nth 1 action) nonterm tokens))))
-
- ;; Not pending.
- (wisi-elisp-parse-exec-action (nth 1 action) nonterm tokens)
- ))
- ))
-
-;;;; navigate grammar actions
-
-(defun wisi-elisp-parse--set-end (start-mark end-mark)
- "Set END-MARK on all caches in `wisi-end-caches' in range START-MARK
END-MARK,
-delete from `wisi-end-caches'."
- (let ((i 0)
- pos cache)
- (while (< i (length wisi-end-caches))
- (setq pos (nth i wisi-end-caches))
- (setq cache (wisi-get-cache pos))
-
- (if (and (>= pos start-mark)
- (< pos end-mark))
- (progn
- (setf (wisi-cache-end cache) end-mark)
- (setq wisi-end-caches (delq pos wisi-end-caches)))
-
- ;; else not in range
- (setq i (1+ i)))
- )))
-
-(defvar wisi-tokens nil
- ;; Not wisi-elisp-parse--tokens for ease in debugging actions, and
- ;; to match lots of doc strings.
- "Array of ‘wisi-tok’ structures for the right hand side of the current
production.
-Let-bound in parser semantic actions.")
-
-(defvar wisi-nterm nil
- ;; Not wisi-elisp-parse--nterm for ease in debugging actions
- "The token id for the left hand side of the current production.
-Let-bound in parser semantic actions.")
-
-(defun wisi-statement-action (pairs)
- ;; Not wisi-elisp-parse--statement-action to match existing grammar files
- "Cache navigation information in text properties of tokens.
-Intended as a grammar non-terminal action.
-
-PAIRS is a vector of the form [TOKEN-NUMBER CLASS TOKEN-NUMBER
-CLASS ...] where TOKEN-NUMBER is the (1 indexed) token number in
-the production, CLASS is the wisi class of that token. Use in a
-grammar action as:
- (wisi-statement-action [1 statement-start 7 statement-end])"
- (when (eq wisi--parse-action 'navigate)
- (save-excursion
- (let ((first-item t)
- first-keyword-mark
- (override-start nil)
- (i 0))
- (while (< i (length pairs))
- (let* ((number (1- (aref pairs i)))
- (region (wisi-tok-region (aref wisi-tokens number)))
- (token (wisi-tok-token (aref wisi-tokens number)))
- (class (aref pairs (setq i (1+ i))))
- (mark (when region (copy-marker (car region) t)))
- cache)
-
- (setq i (1+ i))
-
- (unless
- (cond
- ((fboundp 'seq-contains) ;; emacs < 27
- (seq-contains wisi-class-list class))
- ((fboundp 'seq-contains-p) ;; emacs >= 27
- (seq-contains-p wisi-class-list class)))
- (error "%s not in wisi-class-list" class))
-
- (if region
- (progn
- (if (setq cache (wisi-get-cache (car region)))
- ;; We are processing a previously set non-terminal; ie
simple_statement in
- ;;
- ;; statement : label_opt simple_statement
- ;;
- ;; override nonterm, class, containing
- (progn
- (setf (wisi-cache-class cache) (or override-start
class))
- (setf (wisi-cache-nonterm cache) wisi-nterm)
- (setf (wisi-cache-containing cache) first-keyword-mark)
- (if wisi-end-caches
- (push (car region) wisi-end-caches)
- (setq wisi-end-caches (list (car region)))
- ))
-
- ;; else create new cache
- (with-silent-modifications
- (put-text-property
- (car region)
- (1+ (car region))
- 'wisi-cache
- (wisi-cache-create
- :nonterm wisi-nterm
- :token token
- :last (- (cdr region) (car region))
- :class (or override-start class)
- :containing first-keyword-mark)
- ))
- (if wisi-end-caches
- (push (car region) wisi-end-caches)
- (setq wisi-end-caches (list (car region)))
- ))
-
- (when first-item
- (setq first-item nil)
- (when (or override-start
- (eq class 'statement-start))
- (setq override-start nil)
- (setq first-keyword-mark mark)))
-
- (when (eq class 'statement-end)
- (wisi-elisp-parse--set-end first-keyword-mark (copy-marker
(car region) t)))
- )
-
- ;; region is nil when a production is empty; if the first
- ;; token is a start, override the class on the next token.
- (when (and first-item
- (eq class 'statement-start))
- (setq override-start class)))
- ))
- ))))
-
-(defun wisi-name-action (name)
- ;; Not wisi-elisp-parse--name-action to simplify grammar files
- "NAME is a token number; mark that token with the 'wisi-name text property.
-Intended as a grammar action."
- (when (eq wisi--parse-action 'navigate)
- (let ((region (wisi-tok-region (aref wisi-tokens (1- name)))))
- (when region
- ;; region can be null on an optional or virtual token
- (with-silent-modifications
- (put-text-property (car region) (cdr region) 'wisi-name t))
- ))))
-
-(defun wisi-containing-action (containing-token contained-token)
- ;; Not wisi-elisp-parse--containing-action to match existing grammar files
- "Set containing marks in all tokens in CONTAINED-TOKEN
-with null containing mark to marker pointing to CONTAINING-TOKEN.
-If CONTAINING-TOKEN is empty, the next token number is used."
- (when (eq wisi--parse-action 'navigate)
- (let* ((containing-tok (aref wisi-tokens (1- containing-token)))
- (containing-region (wisi-tok-region containing-tok))
- (contained-tok (aref wisi-tokens (1- contained-token)))
- (contained-region (wisi-tok-region contained-tok)))
-
- (unless containing-region
- (signal 'wisi-parse-error
- (wisi-error-msg
- "wisi-containing-action: containing-region '%s' is empty.
grammar error; bad action"
- (wisi-tok-token containing-tok))))
-
- (unless (or (not contained-region) ;; contained-token is empty
- (wisi-get-cache (car containing-region)))
- (signal 'wisi-parse-error
- (wisi-error-msg
- "wisi-containing-action: containing-token '%s' has no cache.
grammar error; missing action"
- (wisi-token-text (aref wisi-tokens (1- containing-token))))))
-
- (when contained-region
- ;; nil when empty production, may not contain any caches
- (save-excursion
- (goto-char (cdr contained-region))
- (let ((cache (wisi-backward-cache))
- (mark (copy-marker (car containing-region) t)))
- (while cache
-
- ;; skip blocks that are already marked
- (while (and (>= (point) (car contained-region))
- (markerp (wisi-cache-containing cache)))
- (goto-char (wisi-cache-containing cache))
- (setq cache (wisi-get-cache (point))))
-
- (if (or (and (= (car containing-region) (car contained-region))
- (<= (point) (car contained-region)))
- (< (point) (car contained-region)))
- ;; done
- (setq cache nil)
-
- ;; else set mark, loop
- (setf (wisi-cache-containing cache) mark)
- (setq cache (wisi-backward-cache)))
- ))))
- )))
-
-(defun wisi-elisp-parse--match-token (cache tokens start)
- "Return t if CACHE has id from TOKENS and is at START or has containing
equal to START.
-point must be at cache token start.
-TOKENS is a vector [number token_id token_id ...].
-number is ignored."
- (let ((i 1)
- (done nil)
- (result nil)
- token)
- (when (or (= start (point))
- (and (wisi-cache-containing cache)
- (= start (wisi-cache-containing cache))))
- (while (and (not done)
- (< i (length tokens)))
- (setq token (aref tokens i))
- (if (eq token (wisi-cache-token cache))
- (setq result t
- done t)
- (setq i (1+ i)))
- ))
- result))
-
-(defun wisi-motion-action (token-numbers)
- ;; Not wisi-elisp-parse--motion-action to match existing grammar files
- "Set prev/next marks in all tokens given by TOKEN-NUMBERS.
-TOKEN-NUMBERS is a vector with each element one of:
-
-number: the token number; mark that token
-
-vector [number token_id]:
-vector [number token_id token_id ...]:
- mark all tokens in number nonterminal matching token_id with nil prev/next."
- (when (eq wisi--parse-action 'navigate)
- (save-excursion
- (let (prev-keyword-mark
- prev-cache
- token
- start
- cache
- mark
- (i 0))
- (while (< i (length token-numbers))
- (let ((token-number (aref token-numbers i))
- region)
- (setq i (1+ i))
- (cond
- ((numberp token-number)
- (setq token (aref wisi-tokens (1- token-number)))
- (setq region (wisi-tok-region token))
- (when region
- (unless start (setq start (car region)))
- (setq cache (wisi-get-cache (car region)))
- (unless cache (error "no cache on token %d; add to
statement-action" token-number))
- (setq mark (copy-marker (car region) t))
-
- (if prev-keyword-mark
- (progn
- (setf (wisi-cache-prev cache) prev-keyword-mark)
- (setf (wisi-cache-next prev-cache) mark)
- (setq prev-keyword-mark mark)
- (setq prev-cache cache))
-
- ;; else first token; save as prev
- (setq prev-keyword-mark mark)
- (setq prev-cache cache))
- ))
-
- ((vectorp token-number)
- ;; token-number may contain 1 or more token_ids
- ;; the corresponding region may be empty
- ;; there may not have been a prev keyword
- (setq region (wisi-tok-region (aref wisi-tokens (1- (aref
token-number 0)))))
- (when region ;; not an empty token
- ;; We must search for all targets at the same time, to
- ;; get the motion order right.
- (unless start (setq start (car region)))
- (goto-char (car region))
- (setq cache (wisi-get-cache (point)))
- (unless cache (error "no cache at %d; add to statement-action"
(car region)))
- (while (< (point) (cdr region))
- (when (wisi-elisp-parse--match-token cache token-number start)
- (setq mark (copy-marker (point) t))
-
- (if prev-keyword-mark
- ;; Don't include this token if prev/next
- ;; already set by a lower level statement,
- ;; such as a nested if/then/elsif/end if.
- (when (and (null (wisi-cache-prev cache))
- (null (wisi-cache-next prev-cache)))
- (setf (wisi-cache-prev cache) prev-keyword-mark)
- (setf (wisi-cache-next prev-cache) mark)
- (setq prev-keyword-mark mark)
- (setq prev-cache cache))
-
- ;; else first token; save as prev
- (setq prev-keyword-mark mark)
- (setq prev-cache cache)))
-
- (setq cache (wisi-forward-cache))
- )))
-
- (t
- (error "unexpected token-number %s" token-number))
- )
-
- ))
- ))))
-
-;;;; Face grammar actions
-
-(defun wisi-elisp-parse--face-put-cache (region class)
- "Put a ’wisi-face’ cache with class CLASS on REGION."
- (when (> wisi-debug 1)
- (message "face: put cache %s:%s" region class))
- (with-silent-modifications
- (put-text-property
- (car region)
- (1+ (car region))
- 'wisi-face
- (wisi-cache-create
- :last (- (cdr region) (car region))
- :class class)
- )))
-
-(defun wisi-face-mark-action (pairs)
- ;; Not wisi-elisp-parse--face-mark-action to match existing grammar files
- "PAIRS is a vector of TOKEN CLASS pairs; mark TOKEN (token number)
-as having face CLASS (prefix or suffix).
-Intended as a grammar action."
- (when (eq wisi--parse-action 'face)
- (let ((i 0))
- (while (< i (length pairs))
- (let ((region (wisi-tok-region (aref wisi-tokens (1- (aref pairs i)))))
- (class (aref pairs (setq i (1+ i)))))
- (setq i (1+ i))
- (when region
- ;; region can be null on an optional or virtual token
- (let ((cache (get-text-property (car region) 'wisi-face)))
- (if cache
- ;; previously marked; extend this cache, delete any others
- (progn
- (with-silent-modifications
- (remove-text-properties (+ (car region) (wisi-cache-last
cache)) (cdr region) '(wisi-face nil)))
- (setf (wisi-cache-class cache) class)
- (setf (wisi-cache-last cache) (- (cdr region) (car
region))))
-
- ;; else not previously marked
- (wisi-elisp-parse--face-put-cache region class)))
- ))
- ))))
-
-(defun wisi-face-remove-action (tokens)
- ;; Not wisi-elisp-parse--face-remove-action to match existing grammar files
- "Remove face caches and faces in TOKENS.
-Intended as a grammar action.
-
-TOKENS is a vector of token numbers."
- (when (eq wisi--parse-action 'face)
- (let ((i 0))
- (while (< i (length tokens))
- (let* ((number (1- (aref tokens i)))
- (region (wisi-tok-region (aref wisi-tokens number)))
- face-cache)
-
- (setq i (1+ i))
-
- (when region
- (let ((pos (car region)))
- (while (< pos (cdr region))
- (when (setq face-cache (get-text-property pos 'wisi-face))
- (when (> wisi-debug 1)
- (message "face: remove face %s" (cons pos (+ pos
(wisi-cache-last face-cache)))))
- (with-silent-modifications
- (remove-text-properties
- pos (+ pos (wisi-cache-last face-cache))
- (list
- 'wisi-face nil
- 'font-lock-face nil
- 'fontified t))))
- (setq pos (next-single-property-change
- (+ pos (or (and face-cache
- (wisi-cache-last face-cache))
- 0))
- 'wisi-face nil (cdr region)))
- )))
- )))))
-
-(defun wisi-elisp-parse--face-action-1 (face region)
- "Apply FACE to REGION."
- (when region
- (when (> wisi-debug 1)
- (message "face: add face %s:%s" region face))
- (with-silent-modifications
- (add-text-properties
- (car region) (cdr region)
- (list
- 'font-lock-face face
- 'fontified t)))
- ))
-
-(defun wisi-face-apply-action (triples)
- ;; Not wisi-elisp-parse--face-apply-action to match existing grammar files
- "Set face information in `wisi-face' text properties of tokens.
-Intended as a grammar non-terminal action.
-
-TRIPLES is a vector of the form [TOKEN-NUMBER PREFIX-FACE SUFFIX-FACE ...]
-
-In the first ’wisi-face’ cache in each token region, apply
-PREFIX-FACE to class PREFIX, SUFFIX-FACE to class SUFFIX, or
-SUFFIX-FACE to all of the token region if there is no ’wisi-face’
-cache."
- (when (eq wisi--parse-action 'face)
- (let (number prefix-face suffix-face (i 0))
- (while (< i (length triples))
- (setq number (aref triples i))
- (setq prefix-face (aref triples (setq i (1+ i))))
- (setq suffix-face (aref triples (setq i (1+ i))))
- (cond
- ((integerp number)
- (let* ((token-region (wisi-tok-region (aref wisi-tokens (1- number))))
- (pos (car token-region))
- (j 0)
- (some-cache nil)
- cache)
- (when token-region
- ;; region can be null for an optional or virtual token
- (while (< j 2)
- (setq cache (get-text-property pos 'wisi-face))
- (cond
- ((and (not some-cache)
- (null cache))
- ;; cache is null when applying a face to a token
- ;; directly, without first calling
- ;; wisi-face-mark-action. Or when there is a
- ;; previously applied face in a lower level token,
- ;; such as a numeric literal.
- (wisi-elisp-parse--face-action-1 suffix-face token-region))
-
- ((and cache
- (eq 'prefix (wisi-cache-class cache)))
- (setq some-cache t)
- (wisi-elisp-parse--face-action-1 prefix-face
(wisi-cache-region cache pos)))
-
- ((and cache
- (eq 'suffix (wisi-cache-class cache)))
- (setq some-cache t)
- (wisi-elisp-parse--face-action-1 suffix-face
(wisi-cache-region cache pos)))
-
- (t
- ;; don’t apply a face
- nil)
- )
-
- (setq j (1+ j))
- (if suffix-face
- (setq pos (next-single-property-change (+ 2 pos) 'wisi-face
nil (cdr token-region)))
- (setq j 2))
- ))))
-
- (t
- ;; catch conversion errors from previous grammar syntax
- (error "wisi-face-apply-action with non-integer token number"))
- )
- (setq i (1+ i))
- ))))
-
-(defun wisi-face-apply-list-action (triples)
- ;; Not wisi-elisp-parse--face-apply-list-action to match existing grammar
files
- "Similar to ’wisi-face-apply-action’, but applies faces to all
-tokens with a `wisi-face' cache in the wisi-tokens[token-number]
-region, and does not apply a face if there are no such caches."
- (when (eq wisi--parse-action 'face)
- (let (number token-region face-region prefix-face suffix-face cache (i 0)
pos)
- (while (< i (length triples))
- (setq number (aref triples i))
- (setq prefix-face (aref triples (setq i (1+ i))))
- (setq suffix-face (aref triples (setq i (1+ i))))
- (cond
- ((integerp number)
- (setq token-region (wisi-tok-region (aref wisi-tokens (1- number))))
- (when token-region
- ;; region can be null for an optional token
- (setq pos (car token-region))
- (while (and pos
- (< pos (cdr token-region)))
- (setq cache (get-text-property pos 'wisi-face))
- (setq face-region (wisi-cache-region cache pos))
- (cond
- ((or (null (wisi-cache-class cache))
- (eq 'prefix (wisi-cache-class cache)))
- (wisi-elisp-parse--face-action-1 prefix-face face-region))
- ((eq 'suffix (wisi-cache-class cache))
- (wisi-elisp-parse--face-action-1 suffix-face face-region))
-
- (t
- (error "wisi-face-apply-list-action: face cache class is not
prefix or suffix")))
-
- (setq pos (next-single-property-change (1+ pos) 'wisi-face nil
(cdr token-region)))
- )))
- (t
- ;; catch conversion errors from previous grammar syntax
- (error "wisi-face-apply-list-action with non-integer token number"))
- )
- (setq i (1+ i))
- ))))
-
-;;;; indent grammar actions
-
-(defvar wisi-elisp-parse-indent-hanging-function nil
- "Language-specific implementation of `wisi-hanging', `wisi-hanging%'.
-A function taking args TOK DELTA1 DELTA2 OPTION NO-ACCUMULATE,
-and returning an indent.
-TOK is a `wisi-tok' struct for the token being indented.
-DELTA1, DELTA2 are the indents of the first and following lines
-within the nonterminal. OPTION is non-nil if action is `wisi-hanging%'.
-point is at start of TOK, and may be moved.")
-(make-variable-buffer-local 'wisi-elisp-parse-indent-hanging-function)
-
-(defvar wisi-token-index nil
- ;; Not wisi-elisp-parse--token-index for backward compatibility
- "Index of current token in `wisi-tokens'.
-Let-bound in `wisi-indent-action', for grammar actions.")
-
-(defvar wisi-indent-comment nil
- ;; Not wisi-elisp-parse--indent-comment for backward compatibility
- "Non-nil if computing indent for comment.
-Let-bound in `wisi-indent-action', for grammar actions.")
-
-(defun wisi-elisp-parse--apply-int (i delta)
- "Add DELTA (an integer) to the indent at index I."
- (let ((indent (aref wisi-elisp-parse--indent i))) ;; reference if list
-
- (cond
- ((null indent)
- (aset wisi-elisp-parse--indent i delta))
-
- ((integerp indent)
- (aset wisi-elisp-parse--indent i (+ delta indent)))
-
- ((listp indent)
- (cond
- ((eq 'anchor (car indent))
- (cond
- ((null (nth 2 indent))
- (setf (nth 2 indent) delta))
-
- ((integerp (nth 2 indent))
- (setf (nth 2 indent) (+ delta (nth 2 indent))))
-
- ;; else anchored; not affected by this delta
- ))
-
- ((eq 'anchored (car indent))
- ;; not affected by this delta
- )))
-
- (t
- (error "wisi-elisp-parse--apply-int: invalid form : %s" indent))
- )))
-
-(defun wisi-elisp-parse--apply-anchored (delta i)
- "Apply DELTA (an anchored indent) to indent I."
- ;; delta is from wisi-anchored; ('anchored 1 delta no-accumulate)
- (let ((indent (aref wisi-elisp-parse--indent i))
- (accumulate (not (nth 3 delta))))
-
- (when delta
- (cond
- ((null indent)
- (aset wisi-elisp-parse--indent i (seq-take delta 3)))
-
- ((integerp indent)
- (when accumulate
- (let ((temp (seq-take delta 3)))
- (setf (nth 2 temp) (+ indent (nth 2 temp)))
- (aset wisi-elisp-parse--indent i temp))))
-
- ((and (listp indent)
- (eq 'anchor (car indent))
- (or (null (nth 2 indent))
- (integerp (nth 2 indent))))
- (when (or (null (nth 2 indent))
- accumulate)
- (let ((temp (seq-take delta 3)))
- (cond
- ((null (nth 2 indent))
- (setf (nth 2 indent) temp))
-
- (t
- (setf (nth 2 temp) (+ (nth 2 indent) (nth 2 temp)))
- (setf (nth 2 indent) temp))))
- ))
- ))))
-
-(defun wisi-elisp-parse--indent-null-p (indent)
- (or (null indent)
- (and (eq 'anchor (nth 0 indent))
- (null (nth 2 indent)))))
-
-(defun wisi-elisp-parse--indent-token-1 (line end delta)
- "Apply indent DELTA to all lines from LINE (a line number) thru END (a
buffer position)."
- (let ((i (1- line));; index to wisi-elisp-lexer-line-begin,
wisi-elisp-parse--indent
- (paren-first (when (and (listp delta)
- (eq 'hanging (car delta)))
- (nth 2 delta))))
-
- (while (<= (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end)
- (if
- (and ;; no check for called from wisi--indent-comment;
- ;; comments within tokens are indented by
- ;; wisi--indent-token
- wisi-indent-comment-col-0
- (= 11 (syntax-class (syntax-after (aref
(wisi-elisp-lexer-line-begin wisi--lexer) i)))))
- (wisi-elisp-parse--apply-int i 0)
- (cond
- ((integerp delta)
- (wisi-elisp-parse--apply-int i delta))
-
- ((listp delta)
- (cond
- ((eq 'anchored (car delta))
- (wisi-elisp-parse--apply-anchored delta i))
-
- ((eq 'hanging (car delta))
- ;; from wisi-hanging; delta is ('hanging first-line nest delta1
delta2 no-accumulate)
- ;; delta1, delta2 may be anchored
- (when (or (not (nth 5 delta))
- (wisi-elisp-parse--indent-null-p (aref
wisi-elisp-parse--indent i)))
- (if (= i (1- (nth 1 delta)))
- ;; apply delta1
- (let ((delta1 (nth 3 delta)))
- (cond
- ((integerp delta1)
- (wisi-elisp-parse--apply-int i delta1))
-
- (t ;; anchored
- (wisi-elisp-parse--apply-anchored delta1 i))
- ))
-
- ;; don't apply hanging indent in nested parens.
- ;; test/ada_mode-parens.adb
- ;; No_Conditional_Set : constant Ada.Strings.Maps.Character_Set
:=
- ;; Ada.Strings.Maps."or"
- ;; (Ada.Strings.Maps.To_Set (' '),
- (when (= paren-first
- (nth 0 (save-excursion (syntax-ppss (aref
(wisi-elisp-lexer-line-begin wisi--lexer) i)))))
- (let ((delta2 (nth 4 delta)))
- (cond
- ((integerp delta2)
- (wisi-elisp-parse--apply-int i delta2))
-
- (t ;; anchored
- (wisi-elisp-parse--apply-anchored delta2 i))
- )))
- )))
-
- (t
- (error "wisi-elisp-parse--indent-token-1: invalid delta: %s" delta))
- )) ;; listp delta
-
- (t
- (error "wisi-elisp-parse--indent-token-1: invalid delta: %s" delta))
- ))
- (setq i (1+ i))
- )))
-
-(defun wisi-elisp-parse--indent-token (tok token-delta)
- "Add TOKEN-DELTA to all indents in TOK region,"
- (let ((line (if (wisi-tok-nonterminal tok)
- (wisi-tok-first tok)
- (when (wisi-tok-first tok) (wisi-tok-line tok))))
- (end (cdr (wisi-tok-region tok))))
- (when (and line end token-delta)
- (wisi-elisp-parse--indent-token-1 line end token-delta))))
-
-(defun wisi-elisp-parse--indent-comment (tok comment-delta)
- "Add COMMENT-DELTA to all indents in comment region following TOK."
- (let ((line (wisi-tok-comment-line tok))
- (end (wisi-tok-comment-end tok)))
- (when (and line end comment-delta)
- (wisi-elisp-parse--indent-token-1 line end comment-delta))))
-
-(defun wisi-elisp-parse--anchored-1 (tok offset &optional no-accumulate)
- "Return offset of TOK relative to current indentation + OFFSET.
-For use in grammar indent actions."
- (when (wisi-tok-region tok)
- ;; region can be nil when token is inserted by error recovery
- (let ((pos (car (wisi-tok-region tok)))
- delta)
-
- (goto-char pos)
- (setq delta (+ offset (- (current-column) (current-indentation))))
- (wisi-elisp-parse--anchored-2
- (wisi-tok-line tok) ;; anchor-line
- (if wisi-indent-comment
- (wisi-tok-comment-end (aref wisi-tokens wisi-token-index))
- (cdr (wisi-tok-region (aref wisi-tokens wisi-token-index))));; end
- delta
- no-accumulate)
- )))
-
-(defun wisi-elisp-parse--max-anchor (begin-line end)
- (let ((i (1- begin-line))
- (max-i (length (wisi-elisp-lexer-line-begin wisi--lexer)))
- (result 0))
- (while (and (< i max-i)
- (<= (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end))
- (let ((indent (aref wisi-elisp-parse--indent i)))
- (when (and indent (listp indent))
- (cond
- ((eq 'anchor (car indent))
- (setq result (max result (car (nth 1 indent))))
- (when (and (nth 2 indent) (listp (nth 2 indent)))
- (setq result (max result (nth 1 (nth 2 indent))))
- ))
- (t ;; anchored
- (setq result (max result (nth 1 indent))))
- )))
- (setq i (1+ i)))
- result
- ))
-
-(defun wisi-elisp-parse--anchored-2 (anchor-line end delta no-accumulate)
- "Set ANCHOR-LINE as anchor, increment anchors thru END, return anchored
delta."
- ;; Typically, we use anchored to indent relative to a token buried in a line:
- ;;
- ;; test/ada_mode-parens.adb
- ;; Local_2 : Integer := (1 + 2 +
- ;; 3);
- ;; line starting with '3' is anchored to '('
- ;;
- ;; If the anchor is a nonterminal, and the first token in the anchor
- ;; is also first on a line, we don't need anchored to compute the
- ;; delta:
- ;;
- ;; test/ada_mode-parens.adb
- ;; Local_5 : Integer :=
- ;; (1 + 2 +
- ;; 3);
- ;; delta for line starting with '3' can just be '3'.
- ;;
- ;; However, in some places we need anchored to prevent later
- ;; deltas from accumulating:
- ;;
- ;; test/ada_mode-parens.adb
- ;; No_Conditional_Set : constant Ada.Strings.Maps.Character_Set :=
- ;; Ada.Strings.Maps."or"
- ;; (Ada.Strings.Maps.To_Set (' '),
- ;;
- ;; here the function call actual parameter part is indented first
- ;; by 'name' and later by 'expression'; we use anchored to keep the
- ;; 'name' delta and ignore the later delta.
- ;;
- ;; So we apply anchored whether the anchor token is first or not.
-
- (let* ((i (1- anchor-line))
- (indent (aref wisi-elisp-parse--indent i)) ;; reference if list
- (anchor-id (1+ (wisi-elisp-parse--max-anchor anchor-line end))))
-
- ;; Set anchor
- (cond
- ((or
- (null indent)
- (integerp indent))
- (aset wisi-elisp-parse--indent i (list 'anchor (list anchor-id) indent)))
-
- ((and (listp indent)
- (eq 'anchor (car indent)))
- (push anchor-id (nth 1 indent)))
-
- ((and (listp indent)
- (eq 'anchored (car indent)))
- (aset wisi-elisp-parse--indent i (list 'anchor (list anchor-id)
(copy-sequence indent))))
-
- (t
- (error "wisi-anchored-delta: invalid form in indent: %s" indent)))
-
- (list 'anchored anchor-id delta no-accumulate)
- ))
-
-(defun wisi-anchored (token-number offset &optional no-accumulate)
- ;; Not wisi-elisp-parse--anchored to match existing grammar files
- "Return offset of token TOKEN-NUMBER in `wisi-tokens'.relative to current
indentation + OFFSET.
-For use in grammar indent actions."
- (wisi-elisp-parse--anchored-1 (aref wisi-tokens (1- token-number)) offset
no-accumulate))
-
-(defun wisi-anchored* (token-number offset)
- ;; Not wisi-elisp-parse--anchored* to match existing grammar files
- "If TOKEN-NUMBER token in `wisi-tokens' is first on a line,
-call ’wisi-anchored OFFSET’. Otherwise return 0.
-For use in grammar indent actions."
- (if (wisi-tok-first (aref wisi-tokens (1- token-number)))
- (wisi-anchored token-number offset)
- 0))
-
-(defun wisi-anchored*- (token-number offset)
- ;; Not wisi-elisp-parse--anchored*- to match existing grammar files
- "If existing indent is zero, and TOKEN-NUMBER token in `wisi-tokens' is
first on a line,
-call ’wisi-anchored OFFSET’. Otherwise return 0.
-For use in grammar indent actions."
- (if (wisi-tok-first (aref wisi-tokens (1- token-number)))
- (wisi-anchored token-number offset t)
- 0))
-
-(defun wisi-elisp-parse--paren-in-anchor-line (anchor-tok offset)
- "If there is an opening paren containing ANCHOR-TOK in the same line as
ANCHOR-TOK,
-return OFFSET plus the delta from the line indent to the paren
-position. Otherwise return OFFSET."
- (let* ((tok-syntax (syntax-ppss (car (wisi-tok-region anchor-tok))))
- (paren-pos (nth 1 tok-syntax))
- (anchor-line (wisi-tok-line anchor-tok)))
-
- (when (and paren-pos ;; in paren
- (< paren-pos (aref (wisi-elisp-lexer-line-begin wisi--lexer) (1-
anchor-line))))
- ;; paren not in anchor line
- (setq paren-pos nil))
-
- (if paren-pos
- (progn
- (goto-char paren-pos)
- (+ 1 (- (current-column) (current-indentation)) offset))
- offset)
- ))
-
-(defun wisi-anchored% (token-number offset &optional no-accumulate)
- ;; Not wisi-elisp-parse--anchored% to match existing grammar files
- "Return either an anchor for the current token at OFFSET from an enclosing
paren on
-the line containing TOKEN-NUMBER, or OFFSET.
-For use in grammar indent actions."
- (let* ((indent-tok (aref wisi-tokens wisi-token-index))
- ;; indent-tok is a nonterminal; this function makes no sense for
terminals
- (anchor-tok (aref wisi-tokens (1- token-number))))
-
- (wisi-elisp-parse--anchored-2
- (wisi-tok-line anchor-tok)
-
- (if wisi-indent-comment
- (wisi-tok-comment-end indent-tok)
- (cdr (wisi-tok-region indent-tok))) ;; end
-
- (wisi-elisp-parse--paren-in-anchor-line anchor-tok offset)
- no-accumulate)
- ))
-
-(defun wisi-anchored%- (token-number offset)
- ;; Not wisi-elisp-parse--anchored%- to match existing grammar files
- "If existing indent is zero, anchor the current token at OFFSET
-from the first token on the line containing TOKEN-NUMBER in `wisi-tokens'.
-Return the delta.
-For use in grammar indent actions."
- (wisi-anchored% token-number offset t))
-
-(defun wisi-elisp-parse--hanging-1 (delta1 delta2 option no-accumulate)
- "If OPTION is nil, implement `wisi-hanging'; otherwise `wisi-hanging%'."
- (let ((tok (aref wisi-tokens wisi-token-index)))
- ;; tok is a nonterminal; this function makes no sense for terminals
- ;; syntax-ppss moves point to start of tok
-
- (cond
- ((functionp wisi-elisp-parse-indent-hanging-function)
- (funcall wisi-elisp-parse-indent-hanging-function tok delta1 delta2
option no-accumulate))
-
- (t
- (let ((tok-syntax (syntax-ppss (car (wisi-tok-region tok))))
- (first-tok-first-on-line
- ;; first token in tok is first on line
- (and (numberp (wisi-tok-first tok))
- (= (wisi-tok-line tok) (wisi-tok-first tok)))))
- (list 'hanging
- (wisi-tok-line tok) ;; first line of token
- (nth 0 tok-syntax) ;; paren nest level at tok
- delta1
- (if (or (not option) first-tok-first-on-line)
- delta2
- delta1)
- no-accumulate))
- ))
- ))
-
-(defun wisi-hanging (delta1 delta2)
- ;; Not wisi-elisp-parse--hanging to match existing grammar files
- "Use DETLA1 for first line, DELTA2 for following lines.
-For use in grammar indent actions."
- (wisi-elisp-parse--hanging-1 delta1 delta2 nil nil))
-
-(defun wisi-hanging% (delta1 delta2)
- ;; Not wisi-elisp-parse--hanging% to match existing grammar files
- "If first token is first in line, use DETLA1 for first line, DELTA2 for
following lines.
-Otherwise use DELTA1 for all lines.
-For use in grammar indent actions."
- (wisi-elisp-parse--hanging-1 delta1 delta2 t nil))
-
-(defun wisi-hanging%- (delta1 delta2)
- ;; Not wisi-elisp-parse--hanging%- to match existing grammar files
- "If existing indent is non-zero, do nothing.
-Else if first token is first in line, use DETLA1 for first line,
-DELTA2 for following lines. Otherwise use DELTA1 for all lines.
-For use in grammar indent actions."
- (wisi-elisp-parse--hanging-1 delta1 delta2 t t))
-
-(defun wisi-elisp-parse--indent-offset (token offset)
- "Return offset from beginning of first token on line containing TOKEN,
- to beginning of TOKEN, plus OFFSET."
- (save-excursion
- (goto-char (aref (wisi-elisp-lexer-line-begin wisi--lexer) (1-
(wisi-tok-line token))))
- (back-to-indentation)
- (+ offset (- (car (wisi-tok-region token)) (point)))
- ))
-
-(defun wisi-elisp-parse--indent-compute-delta (delta tok)
- "Return evaluation of DELTA."
- (cond
- ((integerp delta)
- delta)
-
- ((symbolp delta)
- (symbol-value delta))
-
- ((vectorp delta)
- ;; [token comment]
- ;; if wisi-indent-comment, we are indenting the comments of the
- ;; previous token; they should align with the 'token' delta.
- (wisi-elisp-parse--indent-compute-delta (aref delta 0) tok))
-
- (t ;; form
- (cond
- ((eq 'anchored (car delta))
- delta)
-
- (t
- (save-excursion
- (goto-char (car (wisi-tok-region tok)))
- (eval delta)))))
- ))
-
-(defun wisi-indent-action (deltas)
- ;; Not wisi-elisp-parse--indent-action to match existing grammar files
- "Accumulate `wisi--indents' from DELTAS.
-DELTAS is a vector; each element can be:
-- an integer
-- a symbol
-- a lisp form
-- a vector.
-
-The first three are evaluated to give an integer delta. A vector must
-have two elements, giving the code and following comment
-deltas. Otherwise the comment delta is the following delta in
-DELTAS."
- (when (eq wisi--parse-action 'indent)
- (dotimes (wisi-token-index (length wisi-tokens))
- (let* ((tok (aref wisi-tokens wisi-token-index))
- (token-delta (aref deltas wisi-token-index))
- (comment-delta
- (cond
- ((vectorp token-delta)
- (aref token-delta 1))
-
- ((< wisi-token-index (1- (length wisi-tokens)))
- (aref deltas (1+ wisi-token-index)))
- )))
- (when (wisi-tok-region tok)
- ;; region is null when optional nonterminal is empty
- (let ((wisi-indent-comment nil))
- (setq token-delta
- (when (and token-delta
- (wisi-tok-first tok))
- (wisi-elisp-parse--indent-compute-delta token-delta tok)))
-
- (when token-delta
- (wisi-elisp-parse--indent-token tok token-delta))
-
- (setq wisi-indent-comment t)
- (setq comment-delta
- (when (and comment-delta
- (wisi-tok-comment-line tok))
- (wisi-elisp-parse--indent-compute-delta comment-delta tok)))
-
- (when comment-delta
- (wisi-elisp-parse--indent-comment tok comment-delta))
- )
- )))))
-
-(defun wisi-indent-action* (n deltas)
- ;; Not wisi-elisp-parse--indent-action* to match existing grammar files
- "If any of the first N tokens in `wisi-tokens' is first on a line,
-call `wisi-indent-action' with DELTAS. Otherwise do nothing."
- (when (eq wisi--parse-action 'indent)
- (let ((done nil)
- (i 0)
- tok)
- (while (and (not done)
- (< i n))
- (setq tok (aref wisi-tokens i))
- (setq i (1+ i))
- (when (and (wisi-tok-region tok)
- (wisi-tok-first tok))
- (setq done t)
- (wisi-indent-action deltas))
- ))))
-
-;;;; non-grammar indent functions
-
-(defconst wisi-elisp-parse--max-anchor-depth 20) ;; IMRPOVEME: can compute in
actions
-
-(defun wisi-elisp-parse--indent-leading-comments ()
- "Set `wisi-elisp-parse--indent to 0 for comment lines before first token in
buffer.
-Leave point at first token (or eob)."
- (save-excursion
- (goto-char (point-min))
- (forward-comment (point-max))
- (let ((end (point))
- (i 0)
- (max-i (length wisi-elisp-parse--indent)))
- (while (and (< i max-i)
- (< (aref (wisi-elisp-lexer-line-begin wisi--lexer) i) end))
- (aset wisi-elisp-parse--indent i 0)
- (setq i (1+ i)))
- )))
-
-(defun wisi-elisp-parse--resolve-anchors ()
- (let ((anchor-indent (make-vector wisi-elisp-parse--max-anchor-depth 0))
- pos)
-
- (dotimes (i (length wisi-elisp-parse--indent))
- (let ((indent (aref wisi-elisp-parse--indent i)))
-
- (cond
- ((or (null indent)
- (integerp indent)))
-
- ((listp indent)
- (let ((anchor-ids (nth 1 indent))
- (indent2 (nth 2 indent)))
- (cond
- ((eq 'anchor (car indent))
- (cond
- ((null indent2))
-
- ((integerp indent2)
- (dotimes (i (length anchor-ids))
- (aset anchor-indent (nth i anchor-ids) indent2))
- (setq indent indent2))
-
- ((listp indent2) ;; 'anchored
- (setq indent (+ (aref anchor-indent (nth 1 indent2)) (nth 2
indent2)))
-
- (dotimes (i (length anchor-ids))
- (aset anchor-indent (nth i anchor-ids) indent)))
-
- (t
- (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
- ));; 'anchor
-
- ((eq 'anchored (car indent))
- (setq indent (+ (aref anchor-indent (nth 1 indent)) indent2)))
-
- (t
- (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
- )));; listp indent
-
- (t
- (error "wisi-indent-region: invalid form in wisi-ind-indent %s"
indent))
- );; cond indent
-
- (when (> i 0)
- (setq pos (aref (wisi-elisp-lexer-line-begin wisi--lexer) i))
- (with-silent-modifications
- (put-text-property (1- pos) pos 'wisi-indent indent)))
- )) ;; dotimes lines
-
- ))
-
-(provide 'wisi-elisp-parse)
-;;; wisi-elisp-parse.el ends here
diff --git a/wisi-parse-common.el b/wisi-parse-common.el
index 895e899..dd9d862 100644
--- a/wisi-parse-common.el
+++ b/wisi-parse-common.el
@@ -1,374 +1,404 @@
-;;; wisi-parse-common.el --- declarations used by wisi-parse.el,
wisi-ada-parse.el, and wisi.el
-;;
-;; Copyright (C) 2014, 2015, 2017 - 2019 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@member.fsf.org>
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Code:
-
-(cl-defstruct (wisi--lexer-error)
- pos ;; position (integer) in buffer where error was detected.
- message ;; string error message
- inserted ;; char inserted after pos.
- )
-
-(cl-defstruct (wisi--parse-error-repair)
- pos ;; position (integer) in buffer where insert/delete is done.
- inserted ;; list of token IDs that were inserted before pos
- deleted ;; list of token IDs that were deleted after pos
- )
-
-(cl-defstruct (wisi--parse-error)
- ;; Includes information derived from compiler error recovery to edit
- ;; text to fix one error. Used by ’wisi-repair-error’ to edit buffer.
- pos ;; position (integer or marker) in buffer where error was detected.
- message ;; string error message
- repair ;; list of wisi--parse-error-repair.
- )
-
-(cl-defstruct wisi-parser
- ;; Separate lists for lexer and parse errors, because lexer errors
- ;; must be repaired first, before parse errors can be repaired. And
- ;; they have different structures.
- lexer-errors
- ;; list of wisi--lexer-errors from last parse. Can be more than one if
- ;; lexer supports error recovery.
- parse-errors
- ;; List of wisi--parse-errors from last parse. Can be more than one if
- ;; parser supports error recovery.
-)
-
-(cl-defgeneric wisi-parse-format-language-options ((parser wisi-parser))
- "Return a string to be sent to the parser, containing settings
-for the language-specific parser options."
- ;; not needed for the elisp parser, which can see the options directly.
- )
-
-(cl-defgeneric wisi-parse-expand-region ((parser wisi-parser) begin end)
- "Return a cons SEND-BEGIN . SEND-END that is an expansion of
-region BEGIN END that starts and ends at points the parser can
-handle gracefully."
- (cons begin end))
-
-(defun wisi-search-backward-skip (regexp skip-p)
- "Search backward for REGEXP. If SKIP-P returns non-nil, search again.
-SKIP-P is a function taking no parameters.
-Return nil if no match found before bob."
- (let ((maybe-found-p (search-backward-regexp regexp nil t)))
- (while (and maybe-found-p
- (funcall skip-p)
- (setq maybe-found-p (search-backward-regexp regexp nil t))))
- maybe-found-p))
-
-(defun wisi-search-forward-skip (regexp skip-p)
- "Search forward for REGEXP. If SKIP-P returns non-nil, search again.
-SKIP-P is a function taking no parameters.
-Return nil if no match found before eob."
- (let ((maybe-found-p (search-forward-regexp regexp nil t)))
- (while (and maybe-found-p
- (funcall skip-p)
- (setq maybe-found-p (search-forward-regexp regexp nil t))))
- maybe-found-p))
-
-(defun wisi-show-expanded-region ()
- "For debugging. Expand currently selected region."
- (interactive)
- (let ((region (wisi-parse-expand-region wisi--parser (region-beginning)
(region-end))))
- (message "pre (%d . %d) post %s" (region-beginning) (region-end) region)
- (set-mark (car region))
- (goto-char (cdr region))
- ))
-
-(cl-defgeneric wisi-parse-adjust-indent ((parser wisi-parser) indent _repair)
- "Adjust INDENT for REPAIR (a wisi--parse-error-repair struct). Return new
indent."
- indent)
-
-(cl-defgeneric wisi-parse-current ((parser wisi-parser) begin send-end
parse-end)
- "Parse current buffer starting at BEGIN, continuing at least thru PARSE-END.
-If using an external parser, send it BEGIN thru SEND-END.")
-
-(cl-defgeneric wisi-parse-kill ((parser wisi-parser))
- "Kill any external process associated with parser.")
-
-(cl-defgeneric wisi-parse-find-token ((parser wisi-parser) token-symbol)
- "Find token with TOKEN-SYMBOL on current parser stack, return token struct.
-For use in grammar actions.")
-
-(cl-defgeneric wisi-parse-stack-peek ((parser wisi-parser) n)
- "Return the Nth token on the parse stack.
-For use in grammar actions.")
-
-(cl-defstruct
- (wisi-cache
- (:constructor wisi-cache-create)
- (:copier nil))
- nonterm;; nonterminal from parse
-
- token
- ;; terminal symbol from wisi-keyword-table or
- ;; wisi-punctuation-table, or lower-level nonterminal from parse
-
- last ;; pos of last char in token, relative to first (0 indexed)
-
- class ;; one of wisi-class-list
-
- containing
- ;; Marker at the start of the containing statement for this token.
- ;; nil for outermost containing.
-
- prev ;; marker at previous motion token in statement; nil if none
- next ;; marker at next motion token in statement; nil if none
- 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-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)
-
-(defcustom wisi-parse-max-parallel 15
- "Maximum number of parallel parsers during regular parsing.
-Parallel parsers are used to resolve redundancy in the grammar.
-If a file needs more than this, it's probably an indication that
-the grammar is excessively redundant."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-
-(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
- statement-end
- statement-override
- statement-start
- misc ;; other stuff
- ]
- "array of valid token classes; checked in wisi-statement-action, used in
wisi-process-parse.")
-
-(defun wisi-error-msg (message &rest args)
- (let ((line (line-number-at-pos))
- (col (- (point) (line-beginning-position))))
- (format
- "%s:%d:%d: %s"
- (buffer-name) ;; buffer-file-name is sometimes nil here!?
- line col
- (apply 'format message args))))
-
-(defvar wisi-parse-error nil)
-(put 'wisi-parse-error
- 'error-conditions
- '(error wisi-parse-error))
-(put 'wisi-parse-error
- 'error-message
- "wisi parse error")
-
-(cl-defstruct wisi-tok
- token ;; symbol from a token table ;; IMPROVEME: rename to ’id’?
- region ;; cons giving buffer region containing token text
-
- nonterminal ;; t if a nonterminal
-
- line ;; Line number at start of token. Nil for empty nonterminals
-
- first
- ;; For terminals, t if token is the first token on a line.
- ;;
- ;; For nonterminals, line number of first contained line (not
- ;; including trailing comments) that needs indenting; it is a
- ;; comment, or begins with a contained token.
- ;;
- ;; Otherwise nil.
-
- ;; The following are non-nil if token (terminal or non-terminal) is
- ;; followed by blank or comment lines
- comment-line ;; first blank or comment line following token
- comment-end ;; position at end of blank or comment lines
- )
-
-(defun wisi-token-text (token)
- "Return buffer text from token range."
- (let ((region (wisi-tok-region token)))
- (and region
- (buffer-substring-no-properties (car region) (cdr region)))))
-
-(defun wisi-and-regions (left right)
- "Return region enclosing both LEFT and RIGHT."
- (if left
- (if right
- (cons (min (car left) (car right))
- (max (cdr left) (cdr right)))
- left)
- right))
-
-(defun wisi--set-line-begin (line-count)
- "Return a vector of line-beginning positions, with length LINE-COUNT."
- (let ((result (make-vector line-count 0)))
- (save-excursion
- (goto-char (point-min))
-
- (dotimes (i line-count)
- (aset result i (point))
- (forward-line 1)))
- result))
-
-;;;; debugging
-(defun wisi-tok-debug-image (tok)
- "Return id and region from TOK, as string."
- (cond
- ((wisi-tok-region tok)
- (format "(%s %d . %d)"
- (wisi-tok-token tok)
- (car (wisi-tok-region tok))
- (cdr (wisi-tok-region tok))))
- (t
- (format "(%s)" (wisi-tok-token tok)))
- ))
-
-(provide 'wisi-parse-common)
+;;; wisi-parse-common.el --- declarations used by wisi-parse.el,
wisi-ada-parse.el, and wisi.el
+;;
+;; Copyright (C) 2014, 2015, 2017 - 2019 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@member.fsf.org>
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(defcustom wisi-partial-parse-threshold 100001
+ "Minimum size that will be parsed by each call to the parser.
+A parse is always requested at a point (or on a region); the
+point is first expanded to a start point before the region and an
+end point after the region, that the parser can gracefully
+handle. If the final region covers the entire buffer, a complete
+parse is done. Indent assumes the start point of the parse region
+is properly indented. Most navigate parses ignore this setting
+and parse the whole buffer."
+ :type 'integer
+ :group 'wisi
+ :safe 'integerp)
+(make-variable-buffer-local 'wisi-partial-parse-threshold)
+
+(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
+ deleted-region ;; buffer (cons FIRST LAST) region deleted
+ )
+
+(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.
+
+ repair-image
+ ;; alist of (TOKEN-ID . STRING); used by repair error
+)
+
+(cl-defgeneric wisi-parse-format-language-options ((parser wisi-parser))
+ "Return a string to be sent to the parser, containing settings
+for the language-specific parser options."
+ ;; not needed for the elisp parser, which can see the options directly.
+ )
+
+(cl-defgeneric wisi-parse-expand-region ((parser wisi-parser) begin end)
+ "Return a cons SEND-BEGIN . SEND-END that is an expansion of
+region BEGIN END that starts and ends at points the parser can
+handle gracefully."
+ (cons begin end))
+
+(defvar-local wisi--parser nil
+ "The current wisi parser; a ‘wisi-parser’ object.")
+
+(defun wisi-read-parse-action ()
+ "Read a parse action symbol from the minibuffer."
+ (intern-soft (completing-read "parse action (indent): " '(face navigate
indent) nil t nil nil 'indent)))
+
+(defun wisi-search-backward-skip (regexp skip-p)
+ "Search backward for REGEXP. If SKIP-P returns non-nil, search again.
+SKIP-P is a function taking no parameters.
+Return nil if no match found before bob."
+ (let ((maybe-found-p (search-backward-regexp regexp nil t)))
+ (while (and maybe-found-p
+ (funcall skip-p)
+ (setq maybe-found-p (search-backward-regexp regexp nil t))))
+ maybe-found-p))
+
+(defun wisi-search-forward-skip (regexp skip-p)
+ "Search forward for REGEXP. If SKIP-P returns non-nil, search again.
+SKIP-P is a function taking no parameters.
+Return nil if no match found before eob."
+ (let ((maybe-found-p (search-forward-regexp regexp nil t)))
+ (while (and maybe-found-p
+ (funcall skip-p)
+ (setq maybe-found-p (search-forward-regexp regexp nil t))))
+ maybe-found-p))
+
+(defun wisi-show-expanded-region ()
+ "For debugging. Expand currently selected region."
+ (interactive)
+ (let ((region (wisi-parse-expand-region wisi--parser (region-beginning)
(region-end))))
+ (message "pre (%d . %d) post %s" (region-beginning) (region-end) region)
+ (set-mark (car region))
+ (goto-char (cdr region))
+ ))
+
+(cl-defgeneric wisi-parse-adjust-indent ((parser wisi-parser) indent _repair)
+ "Adjust INDENT for REPAIR (a wisi--parse-error-repair struct). Return new
indent."
+ indent)
+
+(cl-defgeneric wisi-parse-current ((parser wisi-parser) begin send-end
parse-end)
+ "Parse current buffer starting at BEGIN, continuing at least thru PARSE-END.
+If using an external parser, send it BEGIN thru SEND-END.")
+
+(cl-defgeneric wisi-refactor ((parser wisi-parser) refactor-action parse-begin
parse-end edit-begin)
+ "Send parser command to perform REFACTOR-ACTION on region PARSE-BEGIN
PARSE-END at point EDIT_BEGIN.
+The parse region is not expanded first; it must be the statement
+or declaration containing EDIT_BEGIN.")
+
+(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 for outermost containing.
+
+ prev ;; marker at previous motion token in statement; nil if none
+ next ;; marker at next motion token in statement; nil if none
+ 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-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)
+
+(defcustom wisi-parse-max-parallel 15
+ "Maximum number of parallel parsers during regular parsing.
+Parallel parsers are used to resolve redundancy in the grammar.
+If a file needs more than this, it's probably an indication that
+the grammar is excessively redundant."
+ :type 'integer
+ :group 'wisi
+ :safe 'integerp)
+
+(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
+ statement-end
+ statement-override
+ statement-start
+ misc ;; other stuff
+ ]
+ "array of valid token classes; checked in wisi-statement-action, used in
wisi-process-parse.")
+
+(defun wisi-error-msg (message &rest args)
+ (let ((line (line-number-at-pos))
+ (col (- (point) (line-beginning-position))))
+ (format
+ "%s:%d:%d: %s"
+ (buffer-name) ;; buffer-file-name is sometimes nil here!?
+ line col
+ (apply 'format message args))))
+
+(defvar wisi-parse-error nil)
+(put 'wisi-parse-error
+ 'error-conditions
+ '(error wisi-parse-error))
+(put 'wisi-parse-error
+ 'error-message
+ "wisi parse error")
+
+(cl-defstruct wisi-tok
+ token ;; symbol from a token table ;; IMPROVEME: rename to ’id’?
+ region ;; cons giving buffer region containing token text
+
+ nonterminal ;; t if a nonterminal
+
+ line ;; Line number at start of token. Nil for empty nonterminals
+
+ first
+ ;; For terminals, t if token is the first token on a line.
+ ;;
+ ;; For nonterminals, line number of first contained line (not
+ ;; including trailing comments) that needs indenting; it is a
+ ;; comment, or begins with a contained token.
+ ;;
+ ;; Otherwise nil.
+
+ ;; The following are non-nil if token (terminal or non-terminal) is
+ ;; followed by blank or comment lines
+ comment-line ;; first blank or comment line following token
+ comment-end ;; position at end of blank or comment lines
+ )
+
+(defun wisi-token-text (token)
+ "Return buffer text from token range."
+ (let ((region (wisi-tok-region token)))
+ (and region
+ (buffer-substring-no-properties (car region) (cdr region)))))
+
+(defun wisi-and-regions (left right)
+ "Return region enclosing both LEFT and RIGHT."
+ (if left
+ (if right
+ (cons (min (car left) (car right))
+ (max (cdr left) (cdr right)))
+ left)
+ right))
+
+(defun wisi--set-line-begin (line-count)
+ "Return a vector of line-beginning positions, with length LINE-COUNT."
+ (let ((result (make-vector line-count 0)))
+ (save-excursion
+ (goto-char (point-min))
+
+ (dotimes (i line-count)
+ (aset result i (point))
+ (forward-line 1)))
+ result))
+
+;;;; debugging
+(defun wisi-tok-debug-image (tok)
+ "Return id and region from TOK, as string."
+ (cond
+ ((wisi-tok-region tok)
+ (format "(%s %d . %d)"
+ (wisi-tok-token tok)
+ (car (wisi-tok-region tok))
+ (cdr (wisi-tok-region tok))))
+ (t
+ (format "(%s)" (wisi-tok-token tok)))
+ ))
+
+(provide 'wisi-parse-common)
diff --git a/wisi-process-parse.el b/wisi-process-parse.el
index d941781..5fb025d 100644
--- a/wisi-process-parse.el
+++ b/wisi-process-parse.el
@@ -1,782 +1,835 @@
-;;; wisi-process-parse.el --- interface to external parse program
-;;
-;; Copyright (C) 2014, 2017 - 2019 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@member.fsf.org>
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-(require 'cl-lib)
-(require 'wisi-parse-common)
-
-(defgroup wisi nil
- "Options for Wisi package."
- :group 'programming)
-
-(defcustom wisi-process-time-out 5.0
- "Time out waiting for parser response. An error occurs if there
- is no response from the parser after waiting this amount (in
- seconds)."
- :type 'float
- :safe 'floatp)
-(make-variable-buffer-local 'wisi-process-time-out)
-
-(defconst wisi-process-parse-protocol-version "3"
- "Defines data exchanged between this package and the background process.
-Must match emacs_wisi_common_parse.ads Protocol_Version.")
-
-(defconst wisi-process-parse-prompt "^;;> "
- "Regexp matching executable prompt; indicates previous command is complete.")
-
-(defconst wisi-process-parse-quit-cmd "004quit\n"
- "Command to external process telling it to quit.")
-
-;;;;; 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
- language-protocol-version ;; string identifying language-specific params
- (exec-file nil) ;; absolute file name of executable
- (exec-opts nil) ;; list of process start options for executable
- (token-table nil) ;; vector of token symbols, indexed by integer
- (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.
- end-pos ;; last character position parsed
- language-action-table ;; array of function pointers, each taking an sexp
sent by the process
- )
-
-(defvar wisi-process--alist nil
- "Alist mapping string label to ‘wisi-process--session’ struct")
-
-;;;###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--check-version (parser)
- "Verify protocol version reported by process."
- ;; The process has just started; the first non-comment line in the
- ;; process buffer contains the process and language protocol versions.
- (with-current-buffer (wisi-process--parser-buffer parser)
- (goto-char (point-min))
- (search-forward-regexp "protocol: process version \\([0-9]+\\) language
version \\([0-9]+\\)")
- (unless (and (match-string 1)
- (string-equal (match-string 1)
wisi-process-parse-protocol-version)
- (match-string 2)
- (string-equal (match-string 2)
(wisi-process--parser-language-protocol-version parser)))
- (wisi-parse-kill parser)
- (error "%s parser process protocol version mismatch: elisp %s %s,
process %s %s"
- (wisi-process--parser-label parser)
- wisi-process-parse-protocol-version
(wisi-process--parser-language-protocol-version parser)
- (match-string 1) (match-string 2)))
- ))
-
-(defun wisi-process-parse--require-process (parser)
- "Start the process for PARSER if not already started."
- (unless (process-live-p (wisi-process--parser-process parser))
- (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)
- (make-process
- :name process-name
- :buffer (wisi-process--parser-buffer parser)
- :command (append (list (wisi-process--parser-exec-file parser))
- (wisi-process--parser-exec-opts parser))))
-
- (set-process-query-on-exit-flag (wisi-process--parser-process parser)
nil)
- (setf (wisi-process--parser-busy parser) nil)
-
- (wisi-process-parse--wait parser)
- (wisi-process-parse--check-version 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))
- (accept-process-output process 0.1))
-
- (unless found
- (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 begin send-end parse-end)
- "Send a parse command to PARSER external process, followed by
-the content of the current buffer from BEGIN thru SEND-END. Does
-not wait for command to complete. PARSE-END is end of desired
-parse region."
- ;; Must match "parse" command arguments read by
- ;; emacs_wisi_common_parse,adb Get_Parse_Params.
- (let* ((cmd (format "parse %d \"%s\" %d %d %d %d %d %d %d %d %d %d %d %d %d
%d %d %d %d %d %s"
- (cl-ecase wisi--parse-action
- (navigate 0)
- (face 1)
- (indent 2))
- (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
- (position-bytes begin)
- (position-bytes send-end)
- (position-bytes parse-end)
- begin ;; char_pos
- (line-number-at-pos begin)
- (line-number-at-pos send-end)
- (save-excursion (goto-char begin) (back-to-indentation)
(current-column));; indent-begin
- (if (or (and (= begin (point-min)) (= parse-end
(point-max)))
- (< (point-max) wisi-partial-parse-threshold))
- 0 1) ;; partial parse active
- (if (> wisi-debug 0) 1 0) ;; debug-mode
- (1- wisi-debug) ;; trace_parse
- wisi-trace-mckenzie
- wisi-trace-action
- (if wisi-mckenzie-disable 1 0)
- (or wisi-mckenzie-task-count -1)
- (or wisi-mckenzie-check-limit -1)
- (or wisi-mckenzie-enqueue-limit -1)
- (or wisi-parse-max-parallel -1)
- (- (position-bytes send-end) (position-bytes begin)) ;;
send-end is after last byte
- (wisi-parse-format-language-options parser)
- ))
- (msg (format "%03d%s" (length cmd) cmd))
- (process (wisi-process--parser-process parser)))
- (with-current-buffer (wisi-process--parser-buffer parser)
- (erase-buffer))
-
- (process-send-string process msg)
- (process-send-string process (buffer-substring-no-properties begin
send-end))
-
- ;; We don’t wait for the send to complete; the external process
- ;; may start parsing and send an error message.
- ))
-
-(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)))
- (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--Name_Property (parser sexp)
- ;; sexp is [Name_Property first-pos last-pos]
- ;; see ‘wisi-process-parse--execute’
- ;; implements wisi-name-action
- (with-silent-modifications
- (put-text-property (aref sexp 1) (1+ (aref sexp 2)) 'wisi-name t)))
-
-(defun wisi-process-parse--Face_Property (parser sexp)
- ;; sexp is [Face_Property first-pos last-pos face-index]
- ;; see ‘wisi-process-parse--execute’
- ;; 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
- (when (< (point-min) pos)
- (put-text-property
- (1- pos)
- pos
- 'wisi-indent
- (aref sexp 2)))
- )))
-
-(defun wisi-process-parse--Lexer_Error (parser sexp)
- ;; sexp is [Lexer_Error char-position <message> <repair-char>]
- ;; 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--End (parser sexp)
- ;; sexp is [End pos]
- ;; see ‘wisi-process-parse--execute’
- (setf (wisi-process--parser-end-pos parser) (aref sexp 1)))
-
-(defun wisi-process-parse--Language (parser sexp)
- ;; sexp is [Language language-action ...]
- (funcall (aref (wisi-process--parser-language-action-table parser) (aref
sexp 1)) sexp))
-
-(defun wisi-process-parse--execute (parser sexp)
- "Execute encoded SEXP sent from external process."
- ;; sexp is [action arg ...]; an encoded instruction that we need to execute
- ;;
- ;; 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
- ;;
- ;; [Name_Property first-pos last-pos]
- ;;
- ;; [Face_Property first-pos last-pos face-index]
- ;; Set a font-lock-face text-property
- ;; face-index: integer index into parser-elisp-face-table
- ;;
- ;; [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’.
- ;;
- ;; [Language ...]
- ;; Dispatch to a language-specific action, via
- ;; `wisi-process--parser-language-action-table'.
- ;;
- ;;
- ;; 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))
- (8 (wisi-process-parse--End parser sexp))
- (9 (wisi-process-parse--Name_Property parser sexp))
- (10 (wisi-process-parse--Language parser sexp))
- ))
-
-;;;;; main
-
-(cl-defmethod wisi-parse-kill ((parser wisi-process--parser))
- (when (process-live-p (wisi-process--parser-process parser))
- ;; We used to send a quit command first, to be nice. But there's
- ;; no timeout on that, so it would hang when the process
- ;; executable is not reading command input.
- (when (process-live-p (wisi-process--parser-process parser))
- (kill-process (wisi-process--parser-process parser)))
- )
- (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) begin send-end
parse-end)
- "Run the external parser on the current buffer, from BEGIN to at least
PARSE-END.
-Send BEGIN thru SEND-END to external parser."
- (wisi-process-parse--require-process parser)
-
- ;; font-lock can trigger a face parse while navigate or indent parse
- ;; 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 - use partial parse?"
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))
- (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 ((total-line-count (1+ (count-lines (point-max) (point-min)))))
- (setf (wisi-process--parser-line-begin parser)
(wisi--set-line-begin total-line-count))
- (wisi-process-parse--send-parse parser begin send-end parse-end)
-
- ;; We reset the elisp lexer, because post-parse actions may use it.
- (when wisi--lexer
- (wisi-elisp-lexer-reset total-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
- (cond
- ((listp response)
- ;; error of some sort
- (cond
- ((equal '(parse_error) response)
- ;; Parser detected a syntax error, and recovery failed,
so signal it.
-
- (when (> wisi-debug 0)
- ;; Save a copy of parser output; may be overwritten by
subsequent parse face attempts.
- (set-buffer response-buffer)
- (let ((content (buffer-substring-no-properties
(point-min) (point-max)))
- (buf-name (concat (buffer-name) "-save-error")))
- (set-buffer (get-buffer-create buf-name))
- (insert content)))
-
- (if (wisi-parser-parse-errors parser)
- (signal 'wisi-parse-error
- (wisi--parse-error-message (car
(wisi-parser-parse-errors parser))))
-
- ;; can have no errors when testing a new parser
- (push
- (make-wisi--parse-error :pos 0 :message "parser failed
with no message")
- (wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error "parser failed with no
message")))
-
- ((equal 'parse_error (car response))
- ;; Parser detected some other error non-fatal error, so
signal it.
- (push
- (make-wisi--parse-error :pos 0 :message (cadr
response))
- (wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error (cdr response)))
-
- ((and (eq 'error (car response))
- (string-prefix-p "bad command:" (cadr response)))
- ;; Parser dropped bytes, is treating buffer
- ;; content bytes as commands. Kill the process
- ;; to kill the pipes; there is no other way to
- ;; flush them.
- (kill-process (wisi-process--parser-process parser))
- (signal 'wisi-parse-error "parser lost sync; killed"))
-
- (t
- ;; Some other error
- (condition-case-unless-debug err
- (eval response)
- (error
- (push (make-wisi--parse-error :pos (point) :message
(cadr err)) (wisi-parser-parse-errors parser))
- (signal (car err) (cdr err)))))
- ))
-
- ((arrayp response)
- ;; encoded action
- (condition-case-unless-debug err
- (wisi-process-parse--execute parser response)
- (wisi-parse-error
- (push (make-wisi--parse-error :pos (point) :message
(cadr err)) (wisi-parser-parse-errors parser))
- (signal (car err) (cdr err)))
-
- (error ;; ie from [C:\Windows\system32\KERNEL32.DLL], or
bug in action code above.
- (set-buffer response-buffer)
- (let ((content (buffer-substring-no-properties
(point-min) (point-max)))
- (buf-name (concat (buffer-name) "-save-error")))
- (set-buffer (get-buffer-create buf-name))
- (insert content)
- (insert (format "%s" err))
- (error "parser failed; error messages in %s"
buf-name)))
- ))
- )
-
- (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)
- (set-buffer response-buffer)
- (let ((content (buffer-substring-no-properties (point-min)
(point-max)))
- (buf-name (concat (buffer-name) "-save-error")))
- (set-buffer (get-buffer-create buf-name))
- (insert content)
- (error "parser failed; error messages in %s" buf-name)))
-
- (setq 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)
- (> (wisi-process--parser-total-wait-time parser)
wisi-process-time-out))
- (error "wisi-process-parse not getting more text (or bad syntax
in process output)"))
-
- (setq need-more nil))
- );; 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 parsed region.
- (goto-char (wisi-process--parser-end-pos parser))
- (cons begin (point))
- )
-
- (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))
-
-(defun wisi-process-parse-show-args ()
- "Show the partial parse command-line args for run_ada_[lalr | lr1]_parse for
current region.
-Also add it to the kill ring."
- (interactive)
- (let* ((begin (region-beginning))
- (end (region-end))
- (parse-action (wisi-read-parse-action))
- (msg
- (format "%s %s %d %d %d %d %d %d %d"
- (file-name-nondirectory (buffer-file-name))
- parse-action
- (position-bytes begin)
- (position-bytes end)
- (position-bytes end)
- begin ;; char_pos
- (line-number-at-pos begin)
- (line-number-at-pos end)
- (save-excursion (goto-char begin) (back-to-indentation)
(current-column));; indent-begin
- )))
- (kill-new msg)
- (message msg)))
-
-(provide 'wisi-process-parse)
+;;; wisi-process-parse.el --- interface to external parse program
+;;
+;; Copyright (C) 2014, 2017 - 2019 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@member.fsf.org>
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+(require 'cl-lib)
+(require 'wisi-parse-common)
+
+(defgroup wisi nil
+ "Options for Wisi package."
+ :group 'programming)
+
+(defcustom wisi-process-time-out 5.0
+ "Time out waiting for parser response. An error occurs if there
+ is no response from the parser after waiting this amount (in
+ seconds)."
+ :type 'float
+ :safe 'floatp)
+(make-variable-buffer-local 'wisi-process-time-out)
+
+(defconst wisi-process-parse-protocol-version "4"
+ "Defines data exchanged between this package and the background process.
+Must match emacs_wisi_common_parse.ads Protocol_Version.")
+
+(defconst wisi-process-parse-prompt "^;;> "
+ "Regexp matching executable prompt; indicates previous command is complete.")
+
+(defconst wisi-process-parse-quit-cmd "004quit\n"
+ "Command to external process telling it to quit.")
+
+;;;;; 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
+ language-protocol-version ;; string identifying language-specific params
+ (exec-file nil) ;; absolute file name of executable
+ (exec-opts nil) ;; list of process start options for executable
+ (token-table nil) ;; vector of token symbols, indexed by integer
+ (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.
+ end-pos ;; last character position parsed
+ language-action-table ;; array of function pointers, each taking an sexp
sent by the process
+ )
+
+(defvar wisi-process--alist nil
+ "Alist mapping string label to ‘wisi-process--session’ struct")
+
+;;;###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--check-version (parser)
+ "Verify protocol version reported by process."
+ ;; The process has just started; the first non-comment line in the
+ ;; process buffer contains the process and language protocol versions.
+ (with-current-buffer (wisi-process--parser-buffer parser)
+ (goto-char (point-min))
+ (search-forward-regexp "protocol: process version \\([0-9]+\\) language
version \\([0-9]+\\)")
+ (unless (and (match-string 1)
+ (string-equal (match-string 1)
wisi-process-parse-protocol-version)
+ (match-string 2)
+ (string-equal (match-string 2)
(wisi-process--parser-language-protocol-version parser)))
+ (wisi-parse-kill parser)
+ (error "%s parser process protocol version mismatch: elisp %s %s,
process %s %s"
+ (wisi-process--parser-label parser)
+ wisi-process-parse-protocol-version
(wisi-process--parser-language-protocol-version parser)
+ (match-string 1) (match-string 2)))
+ ))
+
+(defun wisi-process-parse--require-process (parser)
+ "Start the process for PARSER if not already started."
+ (unless (process-live-p (wisi-process--parser-process parser))
+ (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)
+ (make-process
+ :name process-name
+ :buffer (wisi-process--parser-buffer parser)
+ :command (append (list (wisi-process--parser-exec-file parser))
+ (wisi-process--parser-exec-opts parser))))
+
+ (set-process-query-on-exit-flag (wisi-process--parser-process parser)
nil)
+ (setf (wisi-process--parser-busy parser) nil)
+
+ (wisi-process-parse--wait parser)
+ (wisi-process-parse--check-version 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))
+ (accept-process-output process 0.1))
+
+ (unless found
+ (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 begin send-end parse-end)
+ "Send a parse command to PARSER external process, followed by
+the content of the current buffer from BEGIN thru SEND-END. Does
+not wait for command to complete. PARSE-END is end of desired
+parse region."
+ ;; Must match "parse" command arguments read by
+ ;; emacs_wisi_common_parse.adb Get_Parse_Params.
+ (let* ((cmd (format "parse %d \"%s\" %d %d %d %d %d %d %d %d %d %d %d %d %d
%d %d %d %d %d %s"
+ (cl-ecase wisi--parse-action
+ (navigate 0)
+ (face 1)
+ (indent 2))
+ (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
+ (position-bytes begin)
+ (position-bytes send-end)
+ (position-bytes parse-end)
+ begin ;; char_pos
+ (line-number-at-pos begin)
+ (line-number-at-pos send-end)
+ (save-excursion (goto-char begin) (back-to-indentation)
(current-column));; indent-begin
+ (if (or (and (= begin (point-min)) (= parse-end
(point-max)))
+ (< (point-max) wisi-partial-parse-threshold))
+ 0 1) ;; partial parse active
+ (if (> wisi-debug 0) 1 0) ;; debug-mode
+ (1- wisi-debug) ;; trace_parse
+ wisi-trace-mckenzie
+ wisi-trace-action
+ (if wisi-mckenzie-disable 1 0)
+ (or wisi-mckenzie-task-count -1)
+ (or wisi-mckenzie-check-limit -1)
+ (or wisi-mckenzie-enqueue-limit -1)
+ (or wisi-parse-max-parallel -1)
+ (- (position-bytes send-end) (position-bytes begin)) ;;
send-end is after last byte
+ (wisi-parse-format-language-options parser)
+ ))
+ (msg (format "%03d%s" (length cmd) cmd))
+ (process (wisi-process--parser-process parser)))
+ (with-current-buffer (wisi-process--parser-buffer parser)
+ (erase-buffer))
+
+ (process-send-string process msg)
+ (process-send-string process (buffer-substring-no-properties begin
send-end))
+
+ ;; We don’t wait for the send to complete; the external process
+ ;; may start parsing and send an error message.
+ ))
+
+(defun wisi-process-parse--send-refactor (parser refactor-action parse-begin
parse-end edit-begin)
+ "Send a refactor command to PARSER external process, followed
+by the content of the current buffer from PARSE-BEGIN thru
+PARSE-END, wait for command to complete. PARSER will respond with
+one or more Edit messages."
+ ;; Must match "refactor" command arguments read by
+ ;; emacs_wisi_common_parse.adb Get_Refactor_Params.
+ (let* ((cmd (format "refactor %d \"%s\" %d %d %d %d %d %d %d %d %d %d %d"
+ refactor-action
+ (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
+ (position-bytes parse-begin)
+ (position-bytes parse-end)
+ (position-bytes edit-begin)
+ parse-begin ;; char_pos
+ (line-number-at-pos parse-begin)
+ (line-number-at-pos parse-end)
+ (if (> wisi-debug 0) 1 0) ;; debug-mode
+ (1- wisi-debug) ;; trace_parse
+ wisi-trace-action
+ (or wisi-parse-max-parallel -1)
+ (- (position-bytes parse-end) (position-bytes
parse-begin)) ;; parse-end is after last byte
+ ))
+ (msg (format "%03d%s" (length cmd) cmd))
+ (process (wisi-process--parser-process parser)))
+ (with-current-buffer (wisi-process--parser-buffer parser)
+ (erase-buffer))
+
+ (process-send-string process msg)
+ (process-send-string process (buffer-substring-no-properties parse-begin
parse-end))
+ (wisi-process-parse--wait parser)
+ ))
+
+(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)))
+ (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--Name_Property (parser sexp)
+ ;; sexp is [Name_Property first-pos last-pos]
+ ;; see ‘wisi-process-parse--execute’
+ ;; implements wisi-name-action
+ (with-silent-modifications
+ (put-text-property (aref sexp 1) (1+ (aref sexp 2)) 'wisi-name t)))
+
+(defun wisi-process-parse--Face_Property (parser sexp)
+ ;; sexp is [Face_Property first-pos last-pos face-index]
+ ;; see ‘wisi-process-parse--execute’
+ ;; 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
+ (when (< (point-min) pos)
+ (put-text-property
+ (1- pos)
+ pos
+ 'wisi-indent
+ (aref sexp 2)))
+ )))
+
+(defun wisi-process-parse--Lexer_Error (parser sexp)
+ ;; sexp is [Lexer_Error char-position <message> <repair-char>]
+ ;; 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] deleted-region]...]
+ ;; 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))
+ :deleted-region (aref (aref sexp i) 3))
+ (wisi--parse-error-repair last-error)))
+ )))
+
+(defun wisi-process-parse--End (parser sexp)
+ ;; sexp is [End pos]
+ ;; see ‘wisi-process-parse--execute’
+ (setf (wisi-process--parser-end-pos parser) (aref sexp 1)))
+
+(defun wisi-process-parse--Edit (parser sexp)
+ ;; sexp is [Edit begin end text]
+ (delete-region (aref sexp 1) (1+ (aref sexp 2)))
+ (goto-char (aref sexp 1))
+ (insert (aref sexp 3)))
+
+(defun wisi-process-parse--Language (parser sexp)
+ ;; sexp is [Language language-action ...]
+ (funcall (aref (wisi-process--parser-language-action-table parser) (aref
sexp 1)) sexp))
+
+(defun wisi-process-parse--execute (parser sexp)
+ "Execute encoded SEXP sent from external process."
+ ;; sexp is [action arg ...]; an encoded instruction that we need to execute
+ ;;
+ ;; 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
+ ;;
+ ;; [Name_Property first-pos last-pos]
+ ;;
+ ;; [Face_Property first-pos last-pos face-index]
+ ;; Set a font-lock-face text-property
+ ;; face-index: integer index into parser-elisp-face-table
+ ;;
+ ;; [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] deleted-region]...]
+ ;; 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.
+ ;;
+ ;; deleted-region: source buffer region containing deleted tokens
+ ;;
+ ;; Args are token ids; index into parser-token-table. Save the
+ ;; information for later use by ’wisi-repair-error’.
+ ;;
+ ;; [Edit begin end text]
+ ;; Replace region BEGIN . END with TEXT; normally the result of a
+ ;; refactor command.
+ ;;
+ ;; [Language ...]
+ ;; Dispatch to a language-specific action, via
+ ;; `wisi-process--parser-language-action-table'.
+ ;;
+ ;;
+ ;; 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))
+ (8 (wisi-process-parse--End parser sexp))
+ (9 (wisi-process-parse--Name_Property parser sexp))
+ (10 (wisi-process-parse--Edit parser sexp))
+ (11 (wisi-process-parse--Language parser sexp))
+ ))
+
+;;;;; main
+
+(cl-defmethod wisi-parse-kill ((parser wisi-process--parser))
+ (when (process-live-p (wisi-process--parser-process parser))
+ ;; We used to send a quit command first, to be nice. But there's
+ ;; no timeout on that, so it would hang when the process
+ ;; executable is not reading command input.
+ (when (process-live-p (wisi-process--parser-process parser))
+ (kill-process (wisi-process--parser-process parser)))
+ )
+ (setf (wisi-process--parser-busy parser) nil))
+
+(defvar wisi--lexer nil) ;; wisi-elisp-lexer.el
+(declare-function wisi-elisp-lexer-reset "wisi-elisp-lexer")
+
+(defun wisi-process-parse--prepare (parser)
+ (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. Signaling an
+ ;; error tells font-lock to try again later.
+ (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 - use partial parse?"
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)
+
+ (setf (wisi-process--parser-total-wait-time parser) 0.0)
+ (setf (wisi-parser-lexer-errors parser) nil)
+ (setf (wisi-parser-parse-errors parser) nil)
+ ))
+
+(defun wisi-process-parse--handle-messages (parser)
+ (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
+ (need-more nil) ;; point-max if need more, to check for new input
+ (done nil)
+ start-wait-time)
+
+ (set-buffer response-buffer)
+ (setq sexp-start (point-min))
+
+ ;; 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
+ (cond
+ ((listp response)
+ ;; error of some sort
+ (cond
+ ((equal '(parse_error) response)
+ ;; Parser detected a syntax error, and recovery failed, so
signal it.
+
+ (when (> wisi-debug 0)
+ ;; Save a copy of parser output; may be overwritten by
subsequent parse face attempts.
+ (set-buffer response-buffer)
+ (let ((content (buffer-substring-no-properties
(point-min) (point-max)))
+ (buf-name (concat (buffer-name) "-save-error")))
+ (set-buffer (get-buffer-create buf-name))
+ (insert content)))
+
+ (if (wisi-parser-parse-errors parser)
+ (signal 'wisi-parse-error
+ (wisi--parse-error-message (car
(wisi-parser-parse-errors parser))))
+
+ ;; can have no errors when testing a new parser
+ (push
+ (make-wisi--parse-error :pos 0 :message "parser failed
with no message")
+ (wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error "parser failed with no
message")))
+
+ ((equal 'parse_error (car response))
+ ;; Parser detected some other error non-fatal error, so
signal it.
+ (push
+ (make-wisi--parse-error :pos 0 :message (cadr response))
+ (wisi-parser-parse-errors parser))
+ (signal 'wisi-parse-error (cdr response)))
+
+ ((and (eq 'error (car response))
+ (string-prefix-p "bad command:" (cadr response)))
+ ;; Parser dropped bytes, is treating buffer
+ ;; content bytes as commands. Kill the process
+ ;; to kill the pipes; there is no other way to
+ ;; flush them.
+ (kill-process (wisi-process--parser-process parser))
+ (signal 'wisi-parse-error "parser lost sync; killed"))
+
+ (t
+ ;; Some other error
+ (condition-case-unless-debug err
+ (eval response)
+ (error
+ (push (make-wisi--parse-error :pos (point) :message
(cadr err)) (wisi-parser-parse-errors parser))
+ (signal (car err) (cdr err)))))
+ ))
+
+ ((arrayp response)
+ ;; encoded action
+ (condition-case-unless-debug err
+ (wisi-process-parse--execute parser response)
+ (wisi-parse-error
+ (push (make-wisi--parse-error :pos (point) :message (cadr
err)) (wisi-parser-parse-errors parser))
+ (signal (car err) (cdr err)))
+
+ (error ;; ie from [C:\Windows\system32\KERNEL32.DLL], or
bug in action code above.
+ (set-buffer response-buffer)
+ (let ((content (buffer-substring-no-properties (point-min)
(point-max)))
+ (buf-name (concat (buffer-name) "-save-error")))
+ (set-buffer (get-buffer-create buf-name))
+ (insert content)
+ (insert (format "%s" err))
+ (error "parser failed; error messages in %s" buf-name)))
+ ))
+ )
+
+ (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)
+ (set-buffer response-buffer)
+ (let ((content (buffer-substring-no-properties (point-min)
(point-max)))
+ (buf-name (concat (buffer-name) "-save-error")))
+ (set-buffer (get-buffer-create buf-name))
+ (insert content)
+ (error "parser failed; error messages in %s" buf-name)))
+
+ (setq 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)
+ (> (wisi-process--parser-total-wait-time parser)
wisi-process-time-out))
+ (error "wisi-process-parse not getting more text (or bad syntax
in process output)"))
+
+ (setq need-more nil))
+ );; 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 parsed region.
+ (goto-char (wisi-process--parser-end-pos parser))
+ )
+
+ (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))
+ )))
+
+(cl-defmethod wisi-parse-current ((parser wisi-process--parser) begin send-end
parse-end)
+ (wisi-process-parse--prepare parser)
+ (let ((total-line-count (1+ (count-lines (point-max) (point-min)))))
+ (setf (wisi-process--parser-line-begin parser) (wisi--set-line-begin
total-line-count))
+ (wisi-process-parse--send-parse parser begin send-end parse-end)
+
+ ;; We reset the elisp lexer, because post-parse actions may use it.
+ (when wisi--lexer
+ (wisi-elisp-lexer-reset total-line-count wisi--lexer))
+ )
+ (wisi-process-parse--handle-messages parser)
+ (cons begin (point))
+ )
+
+(cl-defmethod wisi-refactor ((parser wisi-process--parser) refactor-action
parse-begin parse-end edit-begin)
+ (save-excursion
+ (wisi-process-parse--prepare parser)
+ (wisi-process-parse--send-refactor parser refactor-action parse-begin
parse-end edit-begin)
+ (wisi-process-parse--handle-messages parser))
+ )
+
+(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))
+
+(defun wisi-process-parse-show-args ()
+ "Show the partial parse command-line args for run_ada_[lalr | lr1]_parse for
current region.
+Also add it to the kill ring."
+ (interactive)
+ (let* ((begin (region-beginning))
+ (end (region-end))
+ (parse-action (wisi-read-parse-action))
+ (msg
+ (format "%s %s %d %d %d %d %d %d %d"
+ (file-name-nondirectory (buffer-file-name))
+ parse-action
+ (position-bytes begin)
+ (position-bytes end)
+ (position-bytes end)
+ begin ;; char_pos
+ (line-number-at-pos begin)
+ (line-number-at-pos end)
+ (save-excursion (goto-char begin) (back-to-indentation)
(current-column));; indent-begin
+ )))
+ (kill-new msg)
+ (message msg)))
+
+(provide 'wisi-process-parse)
diff --git a/wisi-run-indent-test.el b/wisi-run-indent-test.el
index ce5b355..fcf0b33 100644
--- a/wisi-run-indent-test.el
+++ b/wisi-run-indent-test.el
@@ -1,300 +1,331 @@
-;;; wisi-run-indent-test.el --- utils for automating indentation and casing
tests
-;;
-;; Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-(require 'wisi-tests)
-
-;; user can set these to t in an EMACSCMD
-(defvar skip-cmds nil)
-(defvar skip-reindent-test nil)
-(defvar skip-recase-test nil)
-(defvar skip-write nil)
-
-(defun test-in-comment-p ()
- (nth 4 (syntax-ppss)))
-
-(defun test-face (token face)
- "Test if all of TOKEN in next code line has FACE.
-FACE may be a list."
- (save-excursion
- (when (test-in-comment-p)
- (beginning-of-line); forward-comment doesn't move if inside a comment!
- (forward-comment (point-max)))
- (condition-case err
- (search-forward token (line-end-position 5))
- (error
- (error "can't find '%s'" token)))
-
- (save-match-data
- (wisi-validate-cache (line-beginning-position 0) (line-end-position 5)
nil 'face))
-
- ;; We don't use face-at-point, because it doesn't respect
- ;; font-lock-face set by the parser! And we want to check for
- ;; conflicts between font-lock-keywords and the parser.
-
- ;; font-lock-keywords sets 'face property, parser sets 'font-lock-face.
-
- ;; In emacs < 27, if we use (get-text-property (point) 'face), we
- ;; also get 'font-lock-face, but not vice-versa. So we have to use
- ;; text-properties-at to check for both.
- (let* ((token (match-string 0))
- (props (text-properties-at (match-beginning 0)))
- key
- token-face)
-
- (cond
- ((plist-get props 'font-lock-face)
- (setq key 'font-lock-face)
- (setq token-face (plist-get props 'font-lock-face)))
-
- ((plist-get props 'face)
- (setq key 'face)
- (setq token-face (plist-get props 'face)))
- )
-
- (when (and (memq 'font-lock-face props)
- (memq 'face props))
- (describe-text-properties (match-beginning 0))
- (error "mixed font-lock-keyword and parser faces for '%s'" token))
-
- (unless (not (text-property-not-all 0 (length token) key token-face
token))
- (error "mixed faces, expecting %s for '%s'" face token))
-
- (unless (or (and (listp face)
- (memq token-face face))
- (eq token-face face))
- (error "found face %s, expecting %s for '%s'" token-face face token))
- )))
-
-(defun test-face-1 (search token face)
- "Move to end of comment, search for SEARCH, call `test-face'."
- (save-excursion
- (when (test-in-comment-p)
- (beginning-of-line); forward-comment doesn't move if inside a comment!
- (forward-comment (point-max)))
- (search-forward search)
- (test-face token face)
- ))
-
-(defun test-cache-class (token class)
- "Test if TOKEN in next code line has wisi-cache with class CLASS."
- (save-excursion
- (wisi-validate-cache (line-beginning-position 0) (line-end-position 3) nil
'navigate)
- (beginning-of-line); forward-comment doesn't move if inside a comment!
- (forward-comment (point-max))
- (condition-case err
- (search-forward token (line-end-position 5))
- (error
- (error "can't find '%s'" token)))
-
- (let ((cache (get-text-property (match-beginning 0) 'wisi-cache)))
-
- (unless cache (error "no cache"))
- (unless (eq (wisi-cache-class cache) class)
- (error "expecting class %s, found '%s'" class (wisi-cache-class cache)))
- )))
-
-(defun test-cache-containing (containing contained)
- "Test if CONTAINING in next code line has wisi-cache with that contains
CONTAINED."
- (save-excursion
- (wisi-validate-cache (line-beginning-position 0) (line-end-position 3) nil
'navigate)
- (beginning-of-line)
- (forward-comment (point-max))
- (let (containing-pos contained-cache)
- (condition-case err
- (search-forward containing (line-end-position 5))
- (error
- (error "can't find '%s'" containing)))
- (setq containing-pos (match-beginning 0))
-
- (condition-case err
- (search-forward contained (line-end-position 5))
- (error
- (error "can't find '%s'" contained)))
- (setq contained-cache (get-text-property (match-beginning 0)
'wisi-cache))
-
- (unless contained-cache (error "no cache on %s" contained))
- (unless (= containing-pos (wisi-cache-containing contained-cache))
- (error "expecting %d, got %d" containing-pos (wisi-cache-containing
contained-cache)))
- )))
-
-(defun run-test-here ()
- "Run an indentation and casing test on the current buffer."
- (interactive)
- (setq indent-tabs-mode nil)
- (setq jit-lock-context-time 0.0);; for test-face
-
- (let ((error-count 0)
- (test-buffer (current-buffer))
- cmd-line
- last-result last-cmd expected-result)
- ;; Look for EMACS* comments in the file:
- ;;
- ;; EMACSCMD: <form>
- ;; Executes the lisp form inside a save-excursion, saves the result as
a lisp object.
- ;;
- ;; EMACSRESULT: <form>
- ;; point is moved to end of line, <form> is evaluated inside
- ;; save-excursion and compared (using `equal') with the result
- ;; of the previous EMACSCMD, and the test fails if they don't
- ;; match.
- ;;
- ;; EMACS_SKIP_UNLESS: <form>
- ;; skip entire test if form evals nil
- ;;
- ;; EMACSDEBUG: <form>
- ;; Eval form, display result. Also used for setting breakpoint.
-
- (goto-char (point-min))
- (while (and (not skip-cmds)
- (re-search-forward (concat comment-start "EMACS\\([^:]+\\):")
nil t))
- (cond
- ((string= (match-string 1) "CMD")
- (looking-at ".*$")
- (save-excursion
- (setq cmd-line (line-number-at-pos)
- last-cmd (match-string 0)
- last-result
- (condition-case-unless-debug err
- (eval (car (read-from-string last-cmd)))
- (error
- (setq error-count (1+ error-count))
- (message "%s:%d: command: %s"
- (buffer-file-name) cmd-line last-cmd)
- (message "%s:%d: %s: %s"
- (buffer-file-name)
- (line-number-at-pos)
- (car err)
- (cdr err))))
- )
- ;; save-excursion does not preserve mapping of buffer to
- ;; window, but some tests depend on that. For example,
- ;; execute-kbd-macro doesn’t work properly if current buffer
- ;; is not visible..
- (pop-to-buffer test-buffer)))
-
- ((string= (match-string 1) "RESULT")
- (looking-at ".*$")
- (setq expected-result (save-excursion (end-of-line 1) (eval (car
(read-from-string (match-string 0))))))
- (unless (equal expected-result last-result)
- (when debug-on-error (debug))
- (setq error-count (1+ error-count))
- (message
- (concat
- (format "error: %s:%d:\n" (buffer-file-name) (line-number-at-pos))
- (format "Result of '%s' does not match.\nGot '%s',\nexpect '%s'"
- last-cmd
- last-result
- expected-result)
- ))))
-
- ((string= (match-string 1) "_SKIP_UNLESS")
- (looking-at ".*$")
- (unless (eval (car (read-from-string (match-string 0))))
- (setq skip-cmds t)
- (setq skip-reindent-test t)
- (setq skip-recase-test t)
- ;; We don’t set ‘skip-write’ t here, so the *.diff Make target
succeeds.
- ))
-
- ((string= (match-string 1) "DEBUG")
- (looking-at ".*$")
- (message "DEBUG: %s:%d %s"
- (current-buffer)
- (line-number-at-pos)
- (save-excursion
- (eval (car (read-from-string (match-string 0)))))))
-
- (t
- (setq error-count (1+ error-count))
- (error (concat "Unexpected EMACS test command " (match-string 1))))))
-
- (when (> error-count 0)
- (error
- "%s:%d: aborting due to previous errors (%d)"
- (buffer-file-name) (line-number-at-pos (point)) error-count))
- )
-
- (when (not skip-reindent-test)
- ;; Reindent the buffer
- (message "indenting")
-
- ;; first unindent; if the indentation rules do nothing, the test
- ;; would pass, otherwise! Only unindent by 1 column, so comments
- ;; not currently in column 0 are still not in column 0, in case
- ;; the mode supports a special case for comments in column 0.
- (indent-rigidly (point-min) (point-max) -1)
-
- ;; indent-region uses save-excursion, so we can't goto an error location
- (indent-region (point-min) (point-max))
-
- ;; Cleanup the buffer; indenting often leaves trailing whitespace;
- ;; files must be saved without any.
- (delete-trailing-whitespace)
- )
- )
-
-(defun run-test (file-name)
- "Run an indentation and casing test on FILE-NAME."
- (interactive "f")
- ;; we'd like to run emacs from a makefile as:
- ;;
- ;; emacs -Q --batch -l runtest.el -f run-test-here <filename>
- ;;
- ;; However, the function specified with -f is run _before_
- ;; <filename> is visited. So we try this instead:
- ;;
- ;; emacs -Q --batch -l runtest.el --eval '(run-test "<filename>")'
- ;;
- ;; And then we discover that processes spawned with start-process
- ;; don't run when emacs is in --batch mode. So we try this:
- ;;
- ;; emacs -Q -l runtest.el --eval '(progn (run-test
"<filename>")(kill-emacs))'
- ;;
- ;; Then we have problems with font lock defaulting to jit-lock; that
- ;; screws up font-lock tests because the test runs before jit-lock
- ;; does. This forces default font-lock, which fontifies the whole
- ;; buffer when (font-lock-fontify-buffer) is called, which tests
- ;; that rely on font-lock do explicitly.
- (setq font-lock-support-mode nil)
-
- (let ((dir default-directory))
- (find-file file-name) ;; sets default-directory
-
- (when (eq major-mode 'fundamental-mode)
- ;; Running a grammar in test/wisi
- (add-to-list 'load-path (expand-file-name "."))
- (wisi-tests-setup (file-name-sans-extension (file-name-nondirectory
file-name))))
-
- (run-test-here)
-
- (unless skip-write
- ;; Write the result file; makefile will diff.
- (when skip-reindent-test
- ;; user sets skip-reindent-test when testing interactive editing
- ;; commands, so the diff would fail. Revert to the original file,
- ;; save a copy of that.
- (revert-buffer t t))
-
- (delete-trailing-whitespace)
- (write-file (concat dir (file-name-nondirectory file-name) ".tmp")) )
- )
- )
-
-(provide 'wisi-run-indent-test)
-;; end of file
+;;; wisi-run-indent-test.el --- utils for automating indentation and casing
tests
+;;
+;; Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+(require 'wisi-tests)
+
+;; user can set these to t in an EMACSCMD
+(defvar skip-cmds nil)
+(defvar skip-reindent-test nil)
+(defvar skip-recase-test nil)
+(defvar skip-write nil)
+
+(defun test-in-comment-p ()
+ (nth 4 (syntax-ppss)))
+
+(defun test-face (token face)
+ "Test if all of TOKEN in next code line has FACE.
+FACE may be a list."
+ (save-excursion
+ (when (test-in-comment-p)
+ (beginning-of-line); forward-comment doesn't move if inside a comment!
+ (forward-comment (point-max)))
+ (condition-case err
+ (search-forward token (line-end-position 5))
+ (error
+ (error "can't find '%s'" token)))
+
+ (save-match-data
+ (wisi-validate-cache (line-beginning-position 0) (line-end-position 5)
nil 'face))
+
+ ;; We don't use face-at-point, because it doesn't respect
+ ;; font-lock-face set by the parser! And we want to check for
+ ;; conflicts between font-lock-keywords and the parser.
+
+ ;; font-lock-keywords sets 'face property, parser sets 'font-lock-face.
+
+ ;; In emacs < 27, if we use (get-text-property (point) 'face), we
+ ;; also get 'font-lock-face, but not vice-versa. So we have to use
+ ;; text-properties-at to check for both.
+ (let* ((token (match-string 0))
+ (props (text-properties-at (match-beginning 0)))
+ key
+ token-face)
+
+ (cond
+ ((plist-get props 'font-lock-face)
+ (setq key 'font-lock-face)
+ (setq token-face (plist-get props 'font-lock-face)))
+
+ ((plist-get props 'face)
+ (setq key 'face)
+ (setq token-face (plist-get props 'face)))
+ )
+
+ (when (and (memq 'font-lock-face props)
+ (memq 'face props))
+ (describe-text-properties (match-beginning 0))
+ (error "mixed font-lock-keyword and parser faces for '%s'" token))
+
+ (unless (not (text-property-not-all 0 (length token) key token-face
token))
+ (error "mixed faces, expecting %s for '%s'" face token))
+
+ (unless (or (and (listp face)
+ (memq token-face face))
+ (eq token-face face))
+ (error "found face %s, expecting %s for '%s'" token-face face token))
+ )))
+
+(defun test-face-1 (search token face)
+ "Move to end of comment, search for SEARCH, call `test-face'."
+ (save-excursion
+ (when (test-in-comment-p)
+ (beginning-of-line); forward-comment doesn't move if inside a comment!
+ (forward-comment (point-max)))
+ (search-forward search)
+ (test-face token face)
+ ))
+
+(defun test-cache-class (token class)
+ "Test if TOKEN in next code line has wisi-cache with class CLASS."
+ (save-excursion
+ (wisi-validate-cache (line-beginning-position 0) (line-end-position 3) nil
'navigate)
+ (beginning-of-line); forward-comment doesn't move if inside a comment!
+ (forward-comment (point-max))
+ (condition-case err
+ (search-forward token (line-end-position 5))
+ (error
+ (error "can't find '%s'" token)))
+
+ (let ((cache (get-text-property (match-beginning 0) 'wisi-cache)))
+
+ (unless cache (error "no cache"))
+ (unless (eq (wisi-cache-class cache) class)
+ (error "expecting class %s, found '%s'" class (wisi-cache-class cache)))
+ )))
+
+(defun test-cache-containing (containing contained)
+ "Test if CONTAINING in next code line has wisi-cache with that contains
CONTAINED."
+ (save-excursion
+ (wisi-validate-cache (line-beginning-position 0) (line-end-position 3) nil
'navigate)
+ (beginning-of-line)
+ (forward-comment (point-max))
+ (let (containing-pos contained-cache)
+ (search-forward containing (line-end-position 5))
+ (setq containing-pos (match-beginning 0))
+
+ (search-forward contained (line-end-position 5))
+ (setq contained-cache (get-text-property (match-beginning 0)
'wisi-cache))
+
+ (unless contained-cache (error "no cache on %s" contained))
+ (unless (= containing-pos (wisi-cache-containing contained-cache))
+ (error "expecting %d, got %d" containing-pos (wisi-cache-containing
contained-cache)))
+ )))
+
+(defvar test-refactor-markers nil
+ "Stores positions altered by `test-refactor-1' for `test-refactor-2'.
+Each item is a list (ACTION PARSE-BEGIN PARSE-END EDIT-BEGIN)")
+
+(defun test-refactor-1 (action inverse-action search-string refactor-string)
+ (beginning-of-line)
+ (forward-comment (point-max)) ;; forward-comment does not work from inside
comment
+ (search-forward search-string (line-end-position 7))
+ (wisi-validate-cache (line-end-position -7) (line-end-position 7) t
'navigate)
+ (search-forward refactor-string (line-end-position 7))
+ (let* ((edit-begin (match-beginning 0))
+ (cache (wisi-goto-statement-start))
+ (parse-begin (point))
+ (parse-end (wisi-cache-end cache)))
+ (setq parse-end (+ parse-end (wisi-cache-last (wisi-get-cache
(wisi-cache-end cache)))))
+ (push (list
+ inverse-action
+ (copy-marker parse-begin nil)
+ (copy-marker parse-end nil)
+ (copy-marker edit-begin nil))
+ test-refactor-markers)
+ (wisi-refactor wisi--parser action parse-begin parse-end edit-begin)
+ ))
+
+(defun test-refactor-inverse ()
+ "Reverse refactors done by recent set of `test-refactor-1'."
+ (save-excursion
+ (condition-case-unless-debug nil
+ (dolist (item test-refactor-markers)
+ (wisi-refactor wisi--parser
+ (nth 0 item)
+ (marker-position (nth 1 item))
+ (marker-position (nth 2 item))
+ (marker-position (nth 3 item))))
+ (error nil))
+ (setq test-refactor-markers nil)))
+
+(defun run-test-here ()
+ "Run an indentation and casing test on the current buffer."
+ (interactive)
+ (setq indent-tabs-mode nil)
+ (setq jit-lock-context-time 0.0);; for test-face
+
+ (let ((error-count 0)
+ (test-buffer (current-buffer))
+ cmd-line
+ last-result last-cmd expected-result)
+ ;; Look for EMACS* comments in the file:
+ ;;
+ ;; EMACSCMD: <form>
+ ;; Executes the lisp form inside a save-excursion, saves the result as
a lisp object.
+ ;;
+ ;; EMACSRESULT: <form>
+ ;; point is moved to end of line, <form> is evaluated inside
+ ;; save-excursion and compared (using `equal') with the result
+ ;; of the previous EMACSCMD, and the test fails if they don't
+ ;; match.
+ ;;
+ ;; EMACS_SKIP_UNLESS: <form>
+ ;; skip entire test if form evals nil
+ ;;
+ ;; EMACSDEBUG: <form>
+ ;; Eval form, display result. Also used for setting breakpoint.
+
+ (goto-char (point-min))
+ (while (and (not skip-cmds)
+ (re-search-forward (concat comment-start "EMACS\\([^:]+\\):")
nil t))
+ (cond
+ ((string= (match-string 1) "CMD")
+ (looking-at ".*$")
+ (save-excursion
+ (setq cmd-line (line-number-at-pos)
+ last-cmd (match-string 0)
+ last-result
+ (condition-case-unless-debug err
+ (eval (car (read-from-string last-cmd)))
+ (error
+ (setq error-count (1+ error-count))
+ (message "%s:%d: command: %s"
+ (buffer-file-name) cmd-line last-cmd)
+ (message "%s:%d: %s: %s"
+ (buffer-file-name)
+ (line-number-at-pos)
+ (car err)
+ (cdr err))))
+ )
+ ;; save-excursion does not preserve mapping of buffer to
+ ;; window, but some tests depend on that. For example,
+ ;; execute-kbd-macro doesn’t work properly if current buffer
+ ;; is not visible..
+ (pop-to-buffer test-buffer)))
+
+ ((string= (match-string 1) "RESULT")
+ (looking-at ".*$")
+ (setq expected-result (save-excursion (end-of-line 1) (eval (car
(read-from-string (match-string 0))))))
+ (unless (equal expected-result last-result)
+ (when debug-on-error (debug))
+ (setq error-count (1+ error-count))
+ (message
+ (concat
+ (format "error: %s:%d:\n" (buffer-file-name) (line-number-at-pos))
+ (format "Result of '%s' does not match.\nGot '%s',\nexpect '%s'"
+ last-cmd
+ last-result
+ expected-result)
+ ))))
+
+ ((string= (match-string 1) "_SKIP_UNLESS")
+ (looking-at ".*$")
+ (unless (eval (car (read-from-string (match-string 0))))
+ (setq skip-cmds t)
+ (setq skip-reindent-test t)
+ (setq skip-recase-test t)
+ ;; We don’t set ‘skip-write’ t here, so the *.diff Make target
succeeds.
+ ))
+
+ ((string= (match-string 1) "DEBUG")
+ (looking-at ".*$")
+ (message "DEBUG: %s:%d %s"
+ (current-buffer)
+ (line-number-at-pos)
+ (save-excursion
+ (eval (car (read-from-string (match-string 0)))))))
+
+ (t
+ (setq error-count (1+ error-count))
+ (error (concat "Unexpected EMACS test command " (match-string 1))))))
+
+ (when (> error-count 0)
+ (error
+ "%s:%d: aborting due to previous errors (%d)"
+ (buffer-file-name) (line-number-at-pos (point)) error-count))
+ )
+
+ (when (not skip-reindent-test)
+ ;; Reindent the buffer
+ (message "indenting")
+
+ ;; first unindent; if the indentation rules do nothing, the test
+ ;; would pass, otherwise! Only unindent by 1 column, so comments
+ ;; not currently in column 0 are still not in column 0, in case
+ ;; the mode supports a special case for comments in column 0.
+ (indent-rigidly (point-min) (point-max) -1)
+
+ ;; indent-region uses save-excursion, so we can't goto an error location
+ (indent-region (point-min) (point-max))
+
+ ;; Cleanup the buffer; indenting often leaves trailing whitespace;
+ ;; files must be saved without any.
+ (delete-trailing-whitespace)
+ )
+ )
+
+(defun run-test (file-name)
+ "Run an indentation and casing test on FILE-NAME."
+ (interactive "f")
+ ;; we'd like to run emacs from a makefile as:
+ ;;
+ ;; emacs -Q --batch -l runtest.el -f run-test-here <filename>
+ ;;
+ ;; However, the function specified with -f is run _before_
+ ;; <filename> is visited. So we try this instead:
+ ;;
+ ;; emacs -Q --batch -l runtest.el --eval '(run-test "<filename>")'
+ ;;
+ ;; And then we discover that processes spawned with start-process
+ ;; don't run when emacs is in --batch mode. So we try this:
+ ;;
+ ;; emacs -Q -l runtest.el --eval '(progn (run-test
"<filename>")(kill-emacs))'
+ ;;
+ ;; Then we have problems with font lock defaulting to jit-lock; that
+ ;; screws up font-lock tests because the test runs before jit-lock
+ ;; does. This forces default font-lock, which fontifies the whole
+ ;; buffer when (font-lock-fontify-buffer) is called, which tests
+ ;; that rely on font-lock do explicitly.
+ (setq font-lock-support-mode nil)
+
+ (let ((dir default-directory))
+ (find-file file-name) ;; sets default-directory
+
+ (when (eq major-mode 'fundamental-mode)
+ ;; Running a grammar in test/wisi
+ (add-to-list 'load-path (expand-file-name "."))
+ (wisi-tests-setup (file-name-sans-extension (file-name-nondirectory
file-name))))
+
+ (run-test-here)
+
+ (unless skip-write
+ ;; Write the result file; makefile will diff.
+ (when skip-reindent-test
+ ;; user sets skip-reindent-test when testing interactive editing
+ ;; commands, so the diff would fail. Revert to the original file,
+ ;; save a copy of that.
+ (revert-buffer t t))
+
+ (delete-trailing-whitespace)
+ (write-file (concat dir (file-name-nondirectory file-name) ".tmp")) )
+ )
+ )
+
+(provide 'wisi-run-indent-test)
+;; end of file
diff --git a/wisi-tests.el b/wisi-tests.el
index d1468ef..b730cf1 100644
--- a/wisi-tests.el
+++ b/wisi-tests.el
@@ -24,7 +24,7 @@
(require 'cl-lib)
(require 'wisi)
-(defvar wisi-test-parser 'elisp
+(defvar wisi-test-parser 'process
"Set to ’process to test external process parser.")
(defvar test-syntax-table
@@ -81,27 +81,6 @@
(syntax-ppss-flush-cache (point-min));; force re-evaluate with hook.
(cl-ecase wisi-test-parser
- (elisp
- (require 'wisi-elisp-parse)
- (let* ((grammar-file-root (concat grammar-name "-lalr-elisp"))
- (grammar-file-name (concat grammar-file-root ".el"))
- (grammar-file-abs (locate-file grammar-file-name load-path)))
- (unless grammar-file-abs
- (error "can’t find ’%s’ on ’%s’" grammar-file-name load-path))
- (require (intern grammar-file-root)))
-
- (wisi-setup
- :indent-calculate nil
- :post-indent-fail nil
- :parser (wisi-make-elisp-parser
- (symbol-value (intern-soft (concat grammar-name
"-lalr-elisp-parse-table")))
- `wisi-forward-token)
- :lexer (wisi-make-elisp-lexer
- :token-table-raw (symbol-value (intern-soft (concat grammar-name
"-lalr-elisp-token-table-raw")))
- :keyword-table-raw (symbol-value (intern-soft (concat
grammar-name "-lalr-elisp-keyword-table-raw")))
- :string-quote-escape-doubled nil
- :string-quote-escape nil)))
-
(process
(require 'wisi-process-parse)
(require (intern (concat grammar-name "-process"))) ;; generated by
wisi-generate
@@ -118,12 +97,7 @@
:exec-file (concat grammar-name "_wisi_parse.exe")
:face-table (symbol-value (intern-soft (concat grammar-name
"-process-face-table")))
:token-table (symbol-value (intern-soft (concat grammar-name
"-process-token-table")))
- ))
- :lexer (wisi-make-elisp-lexer
- :token-table-raw (symbol-value (intern-soft (concat grammar-name
"-lalr-elisp-token-table-raw")))
- :keyword-table-raw (symbol-value (intern-soft (concat
grammar-name "-lalr-elisp-keyword-table-raw")))
- :string-quote-escape-doubled nil
- :string-quote-escape nil))
+ )))
(setq wisi-mckenzie-disable nil)
)
)
diff --git a/wisi.adb b/wisi.adb
index b65bbee..1ba7a4f 100644
--- a/wisi.adb
+++ b/wisi.adb
@@ -19,23 +19,13 @@ pragma License (Modified_GPL);
with Ada.Exceptions;
with Ada.Strings.Bounded;
+with Ada.Strings.Unbounded;
with Ada.Text_IO;
with SAL;
with WisiToken.Semantic_Checks;
package body Wisi is
use WisiToken;
- Navigate_Cache_Code : constant String := "1";
- Face_Property_Code : constant String := "2";
- Indent_Code : constant String := "3";
- Lexer_Error_Code : constant String := "4";
- Parser_Error_Code : constant String := "5";
- Check_Error_Code : constant String := "6";
- Recover_Code : constant String := "7 ";
- End_Code : constant String := "8";
- Name_Property_Code : constant String := "9";
- Language_Action_Code : constant String := "10 ";
-
Chars_Per_Int : constant Integer := Integer'Width;
----------
@@ -380,114 +370,133 @@ package body Wisi is
Descriptor : in WisiToken.Descriptor;
Embedded_Quote_Escape_Doubled : in Boolean)
is
- use Ada.Containers;
use Ada.Strings.Unbounded;
use Parse.LR;
+ use Parse.LR.Config_Op_Arrays, Parse.LR.Config_Op_Array_Refs;
+
+ -- Output is a sequence of edit regions; each is:
+ -- [edit-pos [inserted token-ids] [deleted token-ids] deleted-region]
+
+ type State_Label is
+ (None, -- not started yet
+ Inserted, -- edit-pos, some insert ids appended
+ Deleted); -- some delete ids appended
+
+ State : State_Label := None;
+ -- State of the current edit region.
+
+ Line : Unbounded_String := To_Unbounded_String ("[");
+ Deleted_Region : Buffer_Region := Null_Buffer_Region;
+ Last_Deleted : Config_Op (Delete) := (Delete, Invalid_Token_ID,
Invalid_Token_Index);
+
+ procedure Start_Edit_Region (Op : in Insert_Delete_Op)
+ is begin
+ Append (Line, "[");
+ Append (Line, Buffer_Pos'Image (Terminals
(WisiToken.Parse.LR.Token_Index (Op)).Char_Region.First));
+ Append (Line, "[");
+ end Start_Edit_Region;
- Line : Unbounded_String := To_Unbounded_String ("[");
- Last_Op : Config_Op := (Fast_Forward, WisiToken.Token_Index'Last);
+ function Deleted_Region_Image return String
+ is begin
+ return "(" & Deleted_Region.First'Image & " . " & Buffer_Pos'Image
(Deleted_Region.Last + 1) & ")";
+ end Deleted_Region_Image;
+ procedure Terminate_Edit_Region
+ is begin
+ case State is
+ when None =>
+ null;
+ when Inserted =>
+ Append (Line, "][]" & Deleted_Region_Image & "]");
+ when Deleted =>
+ Append (Line, "]" & Deleted_Region_Image & "]");
+ end case;
+ Deleted_Region := Null_Buffer_Region;
+ end Terminate_Edit_Region;
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, "]");
+ for I in First_Index (Item.Ops) .. Last_Index (Item.Ops) loop
+ declare
+ Op : Config_Op renames Constant_Ref (Item.Ops, I);
+ begin
+ case Op.Op is
+ when Fast_Forward =>
+ Terminate_Edit_Region;
+ State := None;
- 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;
+ when Undo_Reduce | Push_Back =>
+ null;
- Last_Op := Op;
+ when Insert =>
+ case State is
+ when None =>
+ Start_Edit_Region (Op);
- when Undo_Reduce | Push_Back =>
+ when Inserted =>
null;
- when Insert =>
- if Last_Op.Op = Fast_Forward then
- Append (Line, "[");
- Append (Line, Buffer_Pos'Image (Terminals
(Op.Ins_Token_Index).Char_Region.First));
- Append (Line, "[");
-
- elsif Last_Op.Op = Delete then
- Append (Line, "]][");
- Append (Line, Buffer_Pos'Image (Terminals
(Op.Ins_Token_Index).Char_Region.First));
- Append (Line, "[");
+ when Deleted =>
+ Terminate_Edit_Region;
+ Start_Edit_Region (Op);
- else
- -- Last_Op.Op = Insert
- null;
- end if;
- Append (Line, Token_ID'Image (Op.Ins_ID));
-
- Last_Op := Op;
+ end case;
+ Append (Line, Token_ID'Image (Op.Ins_ID));
+ State := Inserted;
- when Delete =>
- declare
- Skip : Boolean := False;
- begin
- if Last_Op.Op = Fast_Forward then
- Append (Line, "[");
- Append (Line, Buffer_Pos'Image (Terminals
(Op.Del_Token_Index).Char_Region.First));
- Append (Line, "[][");
-
- elsif Last_Op.Op = Insert then
- Append (Line, "][");
-
- elsif Last_Op.Op = Delete then
- if Embedded_Quote_Escape_Doubled and then
- ((Last_Op.Del_ID = Descriptor.String_1_ID and
Op.Del_ID = Descriptor.String_1_ID) or
- (Last_Op.Del_ID = Descriptor.String_2_ID and
Op.Del_ID = Descriptor.String_2_ID))
- then
- declare
- Tok_1 : Augmented_Token renames Terminals
(Last_Op.Del_Token_Index);
- Tok_2 : Augmented_Token renames Terminals
(Op.Del_Token_Index);
- begin
- if Tok_1.Char_Region.Last + 1 =
Tok_2.Char_Region.First then
- -- Buffer text was '"""', lexer repair
changed it to '""""'. The
- -- 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;
+ when Delete =>
+ Deleted_Region := Deleted_Region and Terminals
(Op.Del_Token_Index).Char_Region;
+ declare
+ Skip : Boolean := False;
+ begin
+ case State is
+ when None =>
+ Start_Edit_Region (Op);
+ Append (Line, "][");
- end if;
+ when Inserted =>
+ Append (Line, "][");
- if not Skip then
- Append (Line, Token_ID'Image (Op.Del_ID));
+ when Deleted =>
+ if Embedded_Quote_Escape_Doubled and then
+ ((Last_Deleted.Del_ID = Descriptor.String_1_ID and
Op.Del_ID = Descriptor.String_1_ID) or
+ (Last_Deleted.Del_ID = Descriptor.String_2_ID and
Op.Del_ID = Descriptor.String_2_ID))
+ then
+ declare
+ Tok_1 : Augmented_Token renames Terminals
(Last_Deleted.Del_Token_Index);
+ Tok_2 : Augmented_Token renames Terminals
(Op.Del_Token_Index);
+ begin
+ if Tok_1.Char_Region.Last + 1 =
Tok_2.Char_Region.First then
+ -- Buffer text was '"""', lexer repair changed
it to '""""'. The
+ -- 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;
- Last_Op := Op;
- end case;
- end;
- end loop;
-
- case Last_Op.Op is
- when Fast_Forward =>
- Append (Line, "]");
+ end case;
+ State := Deleted;
- when Undo_Reduce | Push_Back =>
- null;
+ if not Skip then
+ Append (Line, Token_ID'Image (Op.Del_ID));
+ end if;
+ end;
+ Last_Deleted := Op;
+ end case;
+ end;
+ end loop;
- when Insert =>
- Append (Line, "][]]]");
- when Delete =>
- Append (Line, "]]]");
- end case;
- end if;
+ case State is
+ when None =>
+ null;
+ when Inserted | Deleted =>
+ Terminate_Edit_Region;
+ end case;
+ Append (Line, "]");
Ada.Text_IO.Put_Line (To_String (Line));
end Put;
@@ -587,8 +596,9 @@ package body Wisi is
procedure Initialize
(Data : in out Parse_Data_Type;
+ Lexer : in WisiToken.Lexer.Handle;
Descriptor : access constant WisiToken.Descriptor;
- Source_File_Name : in String;
+ Base_Terminals : in Base_Token_Array_Access;
Post_Parse_Action : in Post_Parse_Action_Type;
Begin_Line : in Line_Number_Type;
End_Line : in Line_Number_Type;
@@ -606,8 +616,9 @@ package body Wisi is
(First => Begin_Line,
Last => End_Line + 1);
+ Data.Lexer := Lexer;
Data.Descriptor := Descriptor;
- Data.Source_File_Name := +Source_File_Name;
+ Data.Base_Terminals := Base_Terminals;
Data.Post_Parse_Action := Post_Parse_Action;
case Post_Parse_Action is
@@ -658,7 +669,7 @@ package body Wisi is
function Source_File_Name (Data : in Parse_Data_Type) return String
is begin
- return -Data.Source_File_Name;
+ return Data.Lexer.File_Name;
end Source_File_Name;
function Post_Parse_Action (Data : in Parse_Data_Type) return
Post_Parse_Action_Type
@@ -942,33 +953,30 @@ package body Wisi is
Tokens : in Syntax_Trees.Valid_Node_Index_Array;
Params : in Statement_Param_Array)
is
- First_Item : Boolean := True;
- Start_Set : Boolean := False;
- Override_Start_Set : Boolean := False;
- Containing_Pos : Nil_Buffer_Pos := Nil; -- wisi first-keyword-pos
+ Nonterm_Tok : constant Aug_Token_Ref := Get_Aug_Token (Data,
Tree, Nonterm);
+ First_Item : Boolean := True;
+ Start_Set : Boolean := False;
+ Override_Start_Set : Boolean := False;
+ Containing_Pos : Nil_Buffer_Pos := Nil;
begin
for Pair of Params loop
if not (Pair.Index in Tokens'Range) then
- declare
- Nonterm_Tok : constant Aug_Token_Ref := Get_Aug_Token (Data,
Tree, Nonterm);
- begin
- raise Fatal_Error with Error_Message
- (File_Name => -Data.Source_File_Name,
- Line => Nonterm_Tok.Line,
- Column => Nonterm_Tok.Column,
- Message => "wisi-statement-action: " & Trimmed_Image
(Tree.Production_ID (Nonterm)) &
- " token index" & SAL.Peek_Type'Image (Pair.Index) &
- " not in tokens range (" & SAL.Peek_Type'Image
(Tokens'First) & " .." &
- SAL.Peek_Type'Image (Tokens'Last) & "); bad grammar
action.");
- end;
+ raise Fatal_Error with Error_Message
+ (File_Name => Data.Lexer.File_Name,
+ Line => Nonterm_Tok.Line,
+ Column => Nonterm_Tok.Column,
+ Message => "wisi-statement-action: " & Trimmed_Image
(Tree.Production_ID (Nonterm)) &
+ " token index" & SAL.Peek_Type'Image (Pair.Index) &
+ " not in tokens range (" & SAL.Peek_Type'Image (Tokens'First)
& " .." &
+ SAL.Peek_Type'Image (Tokens'Last) & "); bad grammar action.");
elsif Tree.Byte_Region (Tokens (Pair.Index)) /= Null_Buffer_Region
then
declare
use all type WisiToken.Syntax_Trees.Node_Label;
Token : constant Aug_Token_Ref :=
- (if Pair.Class = Statement_End and then
+ (if Pair.Class = Statement_End and then
Tree.Label (Tokens (Pair.Index)) =
WisiToken.Syntax_Trees.Nonterm
- then Data.Terminals.Variable_Ref (Tree.Max_Terminal_Index
(Tokens (Pair.Index)))
+ then To_Aug_Token_Ref (Data.Terminals
(Tree.Max_Terminal_Index (Tokens (Pair.Index))))
else Get_Aug_Token (Data, Tree, Tokens (Pair.Index)));
Cache_Pos : constant Buffer_Pos :=
Token.Char_Region.First;
@@ -1014,6 +1022,28 @@ package body Wisi is
if Override_Start_Set or Pair.Class = Statement_Start then
Override_Start_Set := False;
Containing_Pos := (True, Token.Char_Region.First);
+
+ -- Set containing on all contained caches
+ declare
+ use Navigate_Cache_Trees;
+ Iterator : constant Navigate_Cache_Trees.Iterator :=
Data.Navigate_Caches.Iterate;
+ Cursor : Navigate_Cache_Trees.Cursor :=
Find_In_Range
+ (Iterator, Ascending, Nonterm_Tok.Char_Region.First
+ 1, -- don't set containing on start
+ Nonterm_Tok.Char_Region.Last);
+ begin
+ loop
+ exit when not Has_Element (Cursor);
+ declare
+ Cache : Navigate_Cache_Type renames
Data.Navigate_Caches (Cursor);
+ begin
+ if not Cache.Containing_Pos.Set then
+ Cache.Containing_Pos := Containing_Pos;
+ end if;
+ exit when Nonterm_Tok.Char_Region.Last <
Cache.Pos + 1;
+ end;
+ Cursor := Iterator.Next (Cursor);
+ end loop;
+ end;
end if;
end if;
@@ -1045,7 +1075,7 @@ package body Wisi is
Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tokens (Tokens'First));
begin
raise Fatal_Error with Error_Message
- (File_Name => -Data.Source_File_Name,
+ (File_Name => Data.Lexer.File_Name,
Line => Token.Line,
Column => Token.Column,
Message => "wisi-name-action: " & Trimmed_Image
(Tree.Production_ID (Nonterm)) & " name (" &
@@ -1069,7 +1099,7 @@ package body Wisi is
return;
elsif Has_Element (Cursor) then
raise Fatal_Error with Error_Message
- (File_Name => -Data.Source_File_Name,
+ (File_Name => Data.Lexer.File_Name,
Line => Name_Token.Line,
Column => Name_Token.Column,
Message => "wisi-name-action: name set twice.");
@@ -1079,112 +1109,6 @@ package body Wisi is
end;
end Name_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 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 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 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 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;
@@ -1194,50 +1118,64 @@ package body Wisi is
is
-- [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;
+ Start : Nil_Buffer_Pos := (Set => False);
+ Iter : constant Iterator := Data.Navigate_Caches.Iterate;
+ Prev_Cache_Cur : Cursor;
+ Cache_Cur : Cursor;
begin
+ if WisiToken.Trace_Action > Outline then
+ Ada.Text_IO.Put_Line
+ ("Motion_Action " & Image (Tree.ID (Nonterm), Data.Descriptor.all)
& " " &
+ Image (Tree.Byte_Region (Nonterm)));
+ end if;
for Param of Params loop
if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then
declare
+ use all type WisiToken.Syntax_Trees.Node_Label;
Token : constant Aug_Token_Ref := Get_Aug_Token (Data, Tree,
Tokens (Param.Index));
Region : constant Buffer_Region := Token.Char_Region;
+ Skip : Boolean := False;
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;
+ case Tree.Label (Tokens (Param.Index)) is
+ when Shared_Terminal =>
+ Cache_Cur := Find (Iter, Region.First);
+ when Virtual_Terminal | Virtual_Identifier =>
+ return;
+
+ when Syntax_Trees.Nonterm =>
+ if Param.ID = Invalid_Token_ID then
+ Cache_Cur := Find (Iter, Region.First);
+
else
+ Skip := True;
+ Cache_Cur := Find_In_Range (Iter, Ascending,
Region.First, Region.Last);
+ loop
+ exit when not Has_Element (Cache_Cur);
+ if Data.Navigate_Caches (Cache_Cur).Pos > Region.Last
then
+ Cache_Cur := No_Element;
+ exit;
+
+ elsif Data.Navigate_Caches (Cache_Cur).ID = Param.ID
and
+ not Data.Navigate_Caches (Cache_Cur).Prev_Pos.Set
+ then
+ Skip := False;
+ exit;
+ end if;
+
+ Cache_Cur := Next (Iter, Cache_Cur);
+ end loop;
+ end if;
+ end case;
+
+ if not Skip then
+ if not Has_Element (Cache_Cur) then
raise Fatal_Error with Error_Message
- (File_Name => -Data.Source_File_Name,
+ (File_Name => Data.Lexer.File_Name,
Line => Token.Line,
Column => Token.Column,
Message => "wisi-motion-action: token " &
@@ -1245,42 +1183,38 @@ package body Wisi is
" has no cache; add to statement-action for " &
Trimmed_Image (Tree.Production_ID (Nonterm)) & ".");
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;
+ if Has_Element (Prev_Cache_Cur) then
+ declare
+ Cache : Navigate_Cache_Type renames
Data.Navigate_Caches (Cache_Cur);
+ Prev_Cache : Navigate_Cache_Type renames
Data.Navigate_Caches (Prev_Cache_Cur);
+ begin
+ if not Cache.Prev_Pos.Set then
+ Cache.Prev_Pos := (True, Prev_Cache.Pos);
+ if WisiToken.Trace_Action > Detail then
+ Ada.Text_IO.Put_Line (" " & Cache.Pos'Image &
" prev to " & Cache.Prev_Pos.Item'Image);
+ end if;
+ end if;
- 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;
+ if not Prev_Cache.Next_Pos.Set then
+ Prev_Cache.Next_Pos := (True, Cache.Pos);
+ if WisiToken.Trace_Action > Detail then
+ Ada.Text_IO.Put_Line
+ (" " & Prev_Cache.Pos'Image & " next to " &
Prev_Cache.Next_Pos.Item'Image);
end if;
- else
- Prev_Keyword_Mark := (True, Point);
- Prev_Cache_Cur := Cache_Cur;
end if;
- end if;
+ end;
+ end if;
+
+ loop
+ -- Set Prev_Cache_Cur to last motion cache in nonterm
chain
+ exit when not Data.Navigate_Caches
(Cache_Cur).Next_Pos.Set;
- Cache_Cur := Next (Iter, Cache_Cur);
- exit when Cache_Cur = No_Element;
+ Cache_Cur := Find (Iter, Data.Navigate_Caches
(Cache_Cur).Next_Pos.Item);
+ pragma Assert (Has_Element (Cache_Cur)); -- otherwise
there's a bug in this subprogram.
- Point := Constant_Ref (Data.Navigate_Caches,
Cache_Cur).Element.Pos;
end loop;
+ Prev_Cache_Cur := Cache_Cur;
end if;
end;
end if;
@@ -1296,7 +1230,6 @@ package body Wisi is
is
pragma Unreferenced (Nonterm);
- -- [2] wisi-face-apply-action
use Face_Cache_Trees;
Iter : constant Iterator := Data.Face_Caches.Iterate;
@@ -1311,7 +1244,7 @@ package body Wisi is
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;
+ Cache : Face_Cache_Type renames Data.Face_Caches
(Cache_Cur);
begin
case Cache.Class is
when Prefix =>
@@ -1321,8 +1254,7 @@ package body Wisi is
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;
+ Suf_Cache : Face_Cache_Type renames
Data.Face_Caches (Suffix_Cur);
begin
if Suffix = Suf_Cache.Class and
Inside (Suf_Cache.Region.First,
Token.Char_Region)
@@ -1367,9 +1299,9 @@ package body Wisi is
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;
+ Data.Face_Caches (Cache_Cur).Region.First >
Token.Char_Region.Last;
declare
- Cache : Face_Cache_Type renames Variable_Ref
(Data.Face_Caches, Cache_Cur).Element.all;
+ Cache : Face_Cache_Type renames Data.Face_Caches
(Cache_Cur);
begin
case Cache.Class is
when Prefix =>
@@ -1395,7 +1327,6 @@ package body Wisi is
is
pragma Unreferenced (Nonterm);
- -- [2] wisi-face-apply-action
use Face_Cache_Trees;
Iter : constant Iterator := Data.Face_Caches.Iterate;
@@ -1409,14 +1340,14 @@ package body Wisi is
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;
+ Cache : Face_Cache_Type renames Data.Face_Caches
(Cache_Cur);
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;
+ Data.Face_Caches (Other_Cur).Region.First >
Token.Char_Region.Last;
Temp := Other_Cur;
Other_Cur := Next (Iter, Other_Cur);
Delete (Data.Face_Caches, Temp);
@@ -1457,7 +1388,7 @@ package body Wisi is
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;
+ Data.Face_Caches (Cache_Cur).Region.First >
Token.Char_Region.Last;
Temp := Cache_Cur;
Cache_Cur := Next (Iter, Cache_Cur);
Delete (Data.Face_Caches, Temp);
@@ -1614,7 +1545,6 @@ package body Wisi is
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);
@@ -1822,7 +1752,6 @@ package body Wisi is
Put (Lexer_Errors);
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
@@ -1857,7 +1786,7 @@ package body Wisi is
is
use Ada.Text_IO;
begin
- Put_Line ("(error """ & Error_Message (-Data.Source_File_Name,
Line_Number, 0, Message) & """)");
+ Put_Line ("(error """ & Error_Message (Data.Lexer.File_Name,
Line_Number, 0, Message) & """)");
end Put_Error;
----------
@@ -1934,12 +1863,46 @@ package body Wisi is
begin
return
(case Tree.Label (Tree_Index) is
- when Shared_Terminal => Data.Terminals.Variable_Ref (Tree.Terminal
(Tree_Index)),
+ when Shared_Terminal => To_Aug_Token_Ref (Data.Terminals
(Tree.Terminal (Tree_Index))),
when Virtual_Terminal => raise SAL.Programmer_Error with
"wisi_runtime.get_aug_token virtual terminal",
when Virtual_Identifier => raise SAL.Programmer_Error with
"wisi_runtime.get_aug_token virtual identifier",
- when Nonterm => (Element => Augmented_Token_Access (Tree.Augmented
(Tree_Index))));
+ when Nonterm => To_Aug_Token_Ref (Tree.Augmented (Tree_Index)));
end Get_Aug_Token;
+ function Get_Text
+ (Data : in Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tree_Index : in WisiToken.Syntax_Trees.Valid_Node_Index)
+ return String
+ is
+ use all type Syntax_Trees.Node_Label;
+ begin
+ case Tree.Label (Tree_Index) is
+ when Shared_Terminal | Nonterm =>
+ return Data.Lexer.Buffer_Text (Tree.Byte_Region (Tree_Index));
+
+ when Virtual_Terminal | Virtual_Identifier =>
+ raise SAL.Programmer_Error;
+
+ end case;
+ end Get_Text;
+
+ function Elisp_Escape_Quotes (Item : in String) return String
+ is
+ Result : String (Item'First .. Item'First + Item'Length * 2);
+ Last : Integer := Item'First - 1;
+ begin
+ for I in Item'Range loop
+ if Item (I) = '"' then
+ Last := Last + 1;
+ Result (Last) := '\';
+ end if;
+ Last := Last + 1;
+ Result (Last) := Item (I);
+ end loop;
+ return Result (Result'First .. Last);
+ end Elisp_Escape_Quotes;
+
overriding
function Image
(Item : in Augmented_Token;
@@ -1960,25 +1923,6 @@ package body Wisi is
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;
diff --git a/wisi.ads b/wisi.ads
index 818a7cc..d240f0a 100644
--- a/wisi.ads
+++ b/wisi.ads
@@ -4,9 +4,9 @@
--
-- References
--
--- [1] wisi.el - defines parse action functions.
+-- [1] wisi-parse-common.el - defines common stuff.
--
--- [2] wisi-elisp-parse.el - defines parse action functions.
+-- [2] wisi.texi - defines parse action functions.
--
-- [3] wisi-process-parse.el - defines elisp/process API
--
@@ -27,8 +27,6 @@ pragma License (Modified_GPL);
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Vectors;
-with Ada.Strings.Unbounded;
-with Ada.Unchecked_Deallocation;
with SAL.Gen_Unbounded_Definite_Red_Black_Trees;
with SAL.Gen_Unbounded_Definite_Vectors;
with WisiToken.Parse.LR;
@@ -45,8 +43,9 @@ package Wisi is
procedure Initialize
(Data : in out Parse_Data_Type;
+ Lexer : in WisiToken.Lexer.Handle;
Descriptor : access constant WisiToken.Descriptor;
- Source_File_Name : in String;
+ Base_Terminals : in WisiToken.Base_Token_Array_Access;
Post_Parse_Action : in Post_Parse_Action_Type;
Begin_Line : in WisiToken.Line_Number_Type;
End_Line : in WisiToken.Line_Number_Type;
@@ -95,6 +94,7 @@ package Wisi is
Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
Params : in Statement_Param_Array);
+ -- Implements [2] wisi-statement-action.
procedure Name_Action
(Data : in out Parse_Data_Type;
@@ -102,31 +102,27 @@ package Wisi is
Nonterm : in WisiToken.Syntax_Trees.Valid_Node_Index;
Tokens : in WisiToken.Syntax_Trees.Valid_Node_Index_Array;
Name : in WisiToken.Positive_Index_Type);
+ -- Implements [2] wisi-name-action.
- 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
+ type Index_ID is record
Index : WisiToken.Positive_Index_Type; -- into Tokens
- IDs : Token_ID_Lists.List;
+ ID : WisiToken.Token_ID;
+ -- If ID is not Invalid_Token_ID, it is the first token in the
+ -- nonterm that Index points to that should have a navigate cache for
+ -- Motion_Action to link to; an error is reported by Motion_Action if
+ -- it does not.
+ --
+ -- If ID is Invalid_Token_ID, and the token at Index is a
+ -- nonterminal, the first token in that nonterminal must have a
+ -- navigate cache; an error is reported by Motion_Action if not.
end record;
- package Index_IDs_Vectors is new Ada.Containers.Vectors
(Ada.Containers.Count_Type, Index_IDs);
+ package Index_ID_Vectors is new Ada.Containers.Vectors
(Ada.Containers.Count_Type, Index_ID);
+
+ subtype Motion_Param_Array is Index_ID_Vectors.Vector;
- subtype Motion_Param_Array is Index_IDs_Vectors.Vector;
+ Invalid_Token_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
+ -- So Create_Parser can just use "Invalid_Token_ID".
procedure Motion_Action
(Data : in out Parse_Data_Type;
@@ -161,7 +157,6 @@ package Wisi is
-- 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
@@ -320,10 +315,19 @@ package Wisi is
Option : in Boolean;
Accumulate : in Boolean)
return Delta_Type;
- -- [2] wisi-elisp-parse--hanging-1
+ -- Implements [2] wisi-hanging, wisi-hanging%, wisi-hanging%-.
--
- -- Language specific child packages override this to implement
- -- wisi-elisp-parse-indent-hanging-function.
+ -- Language specific child packages may override this to implement
+ -- language-specific cases.
+
+ ----------
+ -- Other
+
+ procedure Refactor
+ (Data : in out Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Action : in Positive;
+ Edit_Begin : in WisiToken.Buffer_Pos) is null;
type Arg_Index_Array is array (Positive range <>) of
WisiToken.Positive_Index_Type;
@@ -411,6 +415,13 @@ private
-- nonterminals, empty.
end record;
+ type Augmented_Token_Access is access all Augmented_Token;
+ type Augmented_Token_Access_Constant is access constant Augmented_Token;
+ type Aug_Token_Ref (Element : access constant Augmented_Token) is null
record with
+ Implicit_Dereference => Element;
+
+ function To_Aug_Token_Ref (Item : in WisiToken.Base_Token_Class_Access)
return Aug_Token_Ref
+ is (Element => Augmented_Token_Access_Constant (Item));
overriding
function Image
@@ -429,21 +440,13 @@ private
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, Default_Element => (others =>
<>));
-- Index matches Base_Token_Arrays.
+ function To_Aug_Token_Ref (Item : in
Augmented_Token_Arrays.Constant_Reference_Type) return Aug_Token_Ref
+ is (Element =>
Augmented_Token_Access_Constant'(Item.Element.all'Unchecked_Access));
+
package Line_Paren_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
(WisiToken.Line_Number_Type, Integer, Default_Element => Integer'Last);
package Line_Begin_Pos_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
@@ -498,7 +501,7 @@ private
type Face_Cache_Type is record
Region : WisiToken.Buffer_Region;
- Class : Face_Class_Type; -- wisi-cache-class; one of {'prefix | 'suffix}
+ Class : Face_Class_Type;
Face : Nil_Integer; -- not set, or index into *-process-faces-names
end record;
@@ -579,8 +582,9 @@ private
-- Data for post-parse actions
+ Lexer : WisiToken.Lexer.Handle;
Descriptor : access constant WisiToken.Descriptor;
- Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Base_Terminals : WisiToken.Base_Token_Array_Access;
Post_Parse_Action : Post_Parse_Action_Type;
Navigate_Caches : Navigate_Cache_Trees.Tree; -- Set by Navigate.
Name_Caches : Name_Cache_Trees.Tree; -- Set by Navigate.
@@ -659,8 +663,6 @@ private
----------
-- 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;
@@ -684,6 +686,17 @@ private
Tree_Index : in WisiToken.Syntax_Trees.Valid_Node_Index)
return Aug_Token_Ref;
+ function Get_Text
+ (Data : in Parse_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Tree_Index : in WisiToken.Syntax_Trees.Valid_Node_Index)
+ return String;
+ -- Return text contained by Tree_Index token in source file
+ -- (lexer.buffer).
+
+ function Elisp_Escape_Quotes (Item : in String) return String;
+ -- Prefix any '"' in Item with '\' for elisp.
+
function Indent_Anchored_2
(Data : in out Parse_Data_Type;
Anchor_Line : in WisiToken.Line_Number_Type;
@@ -710,4 +723,18 @@ private
-- [2] wisi-elisp-parse--indent-token-1. Sets Data.Indents, so caller
-- may not be in a renames for a Data.Indents element.
+ -- Visible for language-specific children. Must match list in
+ -- wisi-process-parse.el wisi-process-parse--execute.
+ Navigate_Cache_Code : constant String := "1";
+ Face_Property_Code : constant String := "2";
+ Indent_Code : constant String := "3";
+ Lexer_Error_Code : constant String := "4";
+ Parser_Error_Code : constant String := "5";
+ Check_Error_Code : constant String := "6";
+ Recover_Code : constant String := "7 ";
+ End_Code : constant String := "8";
+ Name_Property_Code : constant String := "9";
+ Edit_Action_Code : constant String := "10";
+ Language_Action_Code : constant String := "11 ";
+
end Wisi;
diff --git a/wisi.el b/wisi.el
index 5ea8d5a..3500f91 100644
--- a/wisi.el
+++ b/wisi.el
@@ -7,8 +7,8 @@
;; Keywords: parser
;; indentation
;; navigation
-;; Version: 2.1.1
-;; package-requires: ((cl-lib "1.0") (emacs "25.0") (seq "2.20"))
+;; Version: 2.2.0
+;; package-requires: ((emacs "25.0") (seq "2.20"))
;; URL: http://stephe-leake.org/ada/wisitoken.html
;;
;; This file is part of GNU Emacs.
@@ -98,22 +98,10 @@
;; than we need. Finally, the semantic parser does not support error
;; correction, and thus fails in most editing situations.
;;
-;; We use wisitoken wisi-generate to compile BNF to Elisp source, and
-;; wisi-compile-grammar to compile that to the parser table. See
-;; ada-mode info for more information on the developer tools used for
-;; ada-mode and wisi.
+;; We use the WisiToken tool wisi-bnf-generate to compile BNF or EBNF
+;; to Ada source, See ada-mode.info and wisi.info for more information
+;; on the developer tools used for ada-mode and wisi.
;;
-;; Alternately, to gain speed and error handling, we use wisi-generate
-;; to generate Ada source, and run that in an external process. That
-;; supports error correction while parsing.
-;;
-;;;; syntax-propertize
-;;
-;; `wisi-forward-token' relies on syntax properties, so
-;; `syntax-propertize' must be called on the text to be lexed before
-;; wisi-forward-token is called. Emacs >= 25 calls syntax-propertize
-;; transparently in the low-level lexer functions.
-
;;; Code:
(require 'cl-lib)
@@ -121,7 +109,6 @@
(require 'seq)
(require 'semantic/lex)
(require 'wisi-parse-common)
-(require 'wisi-elisp-lexer)
(require 'wisi-fringe)
(require 'xref)
@@ -132,19 +119,13 @@
:safe 'integerp)
(make-variable-buffer-local 'wisi-size-threshold)
-(defcustom wisi-partial-parse-threshold 100001
- "Minimum size that will be parsed by each call to the parser.
-A parse is always requested at a point (or on a region); the
-point is first expanded to a start point before the region and an
-end point after the region, that the parser can gracefully
-handle. If the final region covers the entire buffer, a complete
-parse is done. Indent assumes the start point of the parse region
-is properly indented. Most navigate parses ignore this setting
-and parse the whole buffer."
+(defcustom wisi-indent-context-lines 0
+ "Minimum number of lines before point to include in a parse for indent.
+Increasing this will give better results when in the middle of a
+deeply nested statement, but worse in some situations."
:type 'integer
:group 'wisi
:safe 'integerp)
-(make-variable-buffer-local 'wisi-partial-parse-threshold)
(defvar wisi-inhibit-parse nil
"When non-nil, don't run the parser.
@@ -175,14 +156,14 @@ Useful when debugging parser or parser actions."
;;;; token info cache
(defvar-local wisi-parse-failed nil
- "Non-nil when a recent parse has failed - cleared when parse succeeds.")
+ "Non-nil when last parse 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.")
+ "Non-nil when parse is needed because text has changed - cleared when parse
succeeds.")
(defun wisi-parse-try (&optional parse-action)
(cdr (assoc (or parse-action wisi--parse-action) wisi--parse-try)))
@@ -190,6 +171,19 @@ Useful when debugging parser or parser actions."
(defun wisi-set-parse-try (value &optional parse-action)
(setcdr (assoc (or parse-action wisi--parse-action) wisi--parse-try) value))
+(defvar-local wisi--last-parse-region
+ (list
+ (cons 'face nil)
+ (cons 'navigate nil)
+ (cons 'indent nil))
+ "Last region on which parse was requested.")
+
+(defun wisi-last-parse-region (&optional parse-action)
+ (cdr (assoc (or parse-action wisi--parse-action) wisi--last-parse-region)))
+
+(defun wisi-set-last-parse-region (begin end parse-action)
+ (setcdr (assoc parse-action wisi--last-parse-region) (cons begin end)))
+
(defvar-local wisi--cached-regions
(list
(cons 'face nil)
@@ -366,6 +360,9 @@ Truncate any region that overlaps POS."
(wisi-set-parse-try t 'indent)
(wisi-set-parse-try t 'face)
(wisi-set-parse-try t 'navigate)
+ (wisi-set-last-parse-region (point-min) (point-min) 'indent)
+ (wisi-set-last-parse-region (point-min) (point-min) 'face)
+ (wisi-set-last-parse-region (point-min) (point-min) 'navigate)
(wisi-fringe-clean))
;; wisi--change-* keep track of buffer modifications.
@@ -390,11 +387,8 @@ Set by `wisi-before-change', used and reset by
`wisi--post-change'.")
"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.")
+ "Value of `wisi--parse-action' when `wisi-validate-cache' was last run.")
(defun wisi-before-change (begin end)
"For `before-change-functions'."
@@ -707,6 +701,7 @@ Usefull if the parser appears to be hung."
(message msg))
(setq wisi--last-parse-action wisi--parse-action)
+ (wisi-set-last-parse-region begin parse-end wisi--parse-action)
(unless (eq wisi--parse-action 'face)
(when (buffer-live-p wisi-error-buffer)
@@ -792,24 +787,31 @@ Usefull if the parser appears to be hung."
(let ((wisi--parse-action parse-action))
(wisi--check-change)
- ;; Now we can rely on wisi-cache-covers-region
-
- (if (and (or (not wisi-parse-failed)
- (wisi-parse-try))
- (not (wisi-cache-covers-region begin end)))
- (progn
- ;; Don't keep retrying failed parse until text changes again.
- (wisi-set-parse-try nil)
- (wisi--run-parse begin end))
-
+ ;; Now we can rely on wisi-cache-covers-region.
+ ;;
+ ;; If the last parse failed but was partial, and we are trying
+ ;; a different region, it may succeed. Otherwise, don't keep
+ ;; retrying a failed parse until the text changes again.
+ (cond
+ ((and (not wisi-parse-failed)
+ (wisi-cache-covers-region begin end))
(when (> wisi-debug 0)
- (message "parse %s skipped: parse-failed %s parse-try %s
cache-covers-region %s %s.%s"
+ (message "parse %s skipped: cache-covers-region %s %s.%s"
parse-action
- wisi-parse-failed
- (wisi-parse-try)
(wisi-cache-covers-region begin end)
begin end)))
+ ((and wisi-parse-failed
+ (equal (cons begin end) (wisi-last-parse-region parse-action))
+ (not (wisi-parse-try parse-action)))
+ (when (> wisi-debug 0)
+ (message "parse %s skipped: parse-failed" parse-action)))
+
+ (t
+ (progn
+ (wisi-set-parse-try nil)
+ (wisi--run-parse begin end))))
+
;; We want this error even if we did not try to parse; it means
;; the parse results are not valid.
(when (and error-on-fail wisi-parse-failed)
@@ -851,29 +853,6 @@ If LIMIT (a buffer position) is reached, throw an error."
(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."
@@ -1201,7 +1180,6 @@ If INDENT-BLANK-LINES is non-nil, also indent blank lines
(for use as
(wisi-parse-try 'indent)))
(wisi-set-parse-try nil)
-
(wisi--run-parse begin end)
;; If there were errors corrected, the indentation is
@@ -1270,7 +1248,7 @@ If INDENT-BLANK-LINES is non-nil, also indent blank lines
(for use as
(when (>= (point) savep)
(setq to-indent t))
- (wisi-indent-region (line-beginning-position) (line-end-position) t)
+ (wisi-indent-region (line-beginning-position (-
wisi-indent-context-lines)) (1+ (line-end-position)) t)
(goto-char savep)
(when to-indent (back-to-indentation))
@@ -1278,24 +1256,18 @@ If INDENT-BLANK-LINES is non-nil, also indent blank
lines (for use as
(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)
+ (let ((wisi--parse-action 'navigate))
(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))))
-
+ (when (< 0 (length (wisi--parse-error-repair-deleted repair)))
+ (delete-region (car (wisi--parse-error-repair-deleted-region repair))
+ (cdr (wisi--parse-error-repair-deleted-region
repair))))
(dolist (id (wisi--parse-error-repair-inserted repair))
- (insert (cdr (assoc id (wisi-elisp-lexer-id-alist wisi--lexer))))
+ (insert (cdr (assoc id (wisi-parser-repair-image wisi--parser))))
(insert " "))
))
)))
@@ -1467,10 +1439,6 @@ If non-nil, only repair errors in BEG END region."
(define-key global-map "\M-j" 'wisi-show-cache)
)
-(defun wisi-read-parse-action ()
- "Read a parse action symbol from the minibuffer."
- (intern-soft (completing-read "parse action (indent): " '(face navigate
indent) nil t nil nil 'indent)))
-
(defun wisi-parse-buffer (&optional parse-action begin end)
(interactive)
(unless parse-action
@@ -1587,13 +1555,12 @@ If non-nil, only repair errors in BEG END region."
;;;;; setup
-(cl-defun wisi-setup (&key indent-calculate post-indent-fail parser lexer)
+(cl-defun wisi-setup (&key indent-calculate post-indent-fail parser)
"Set up a buffer for parsing files with wisi."
(when wisi--parser
(wisi-kill-parser))
(setq wisi--parser parser)
- (setq wisi--lexer lexer)
(setq wisi--cached-regions
(list
(cons 'face nil)
@@ -1606,6 +1573,12 @@ If non-nil, only repair errors in BEG END region."
(cons 'navigate t)
(cons 'indent t)))
+ (setq wisi--last-parse-region
+ (list
+ (cons 'face nil)
+ (cons 'navigate nil)
+ (cons 'indent nil)))
+
;; 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)
diff --git a/wisitoken.gpr b/wisi.gpr
similarity index 57%
rename from wisitoken.gpr
rename to wisi.gpr
index 2b0064d..8ca2dd2 100644
--- a/wisitoken.gpr
+++ b/wisi.gpr
@@ -1,8 +1,8 @@
-- Abstract :
--
--- Provide SAL and WisiToken to other ELPA packages
+-- Make installed ELPA package wisi Ada code available for other projects.
--
--- Copyright (C) 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2017, 2019 Free Software Foundation, Inc.
--
-- This program is free software; you can redistribute it and/or
-- modify it under terms of the GNU General Public License as
@@ -18,12 +18,10 @@
with "gnatcoll";
with "standard_common";
-project WisiToken is
+project Wisi is
for Source_Dirs use (".");
- for Languages use ("Ada", "C");
-
case Standard_Common.Profile is
when "On" =>
for Object_Dir use "obj_pro";
@@ -34,39 +32,28 @@ project WisiToken is
for Exec_Dir use ".";
end case;
+ for Languages use ("Ada");
+
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;
+ Standard_Common.Compiler.Common_Switches &
+ Standard_Common.Compiler.Style_Checks &
+ Standard_Common.Compiler.Debug_Switches;
+
+ for Default_Switches ("C") use
Standard_Common.Compiler.Debug_Switches_C;
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";
+ Standard_Common.Compiler.Common_Switches &
+ Standard_Common.Compiler.Style_Checks &
+ Standard_Common.Compiler.Release_Switches;
- case Standard_Common.Profile is
- when "On" =>
- for Global_Compilation_Switches ("Ada") use ("-pg");
-
- when "Off" =>
- null;
+ for Default_Switches ("C") use
Standard_Common.Compiler.Release_Switches_C;
end case;
- end Builder;
-
- package Binder is
- for Default_Switches ("Ada") use Standard_Common.Binder'Default_Switches
("Ada");
- end Binder;
+ end Compiler;
-end WisiToken;
+end Wisi;
diff --git a/wisitoken-bnf-generate.adb b/wisitoken-bnf-generate.adb
index ca98c75..72a0221 100644
--- a/wisitoken-bnf-generate.adb
+++ b/wisitoken-bnf-generate.adb
@@ -1,6 +1,6 @@
-- Abstract :
--
--- Parser for Wisi grammar files, producing Ada or Elisp source
+-- Parser for Wisi grammar files, producing Ada source
-- files for a parser.
--
-- Copyright (C) 2012 - 2015, 2017 - 2019 Free Software Foundation, Inc.
@@ -32,7 +32,6 @@ 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.LR.LALR_Generate;
with WisiToken.Generate.LR.LR1_Generate;
@@ -53,8 +52,8 @@ is
begin
-- verbosity meaning is actually determined by output choice;
-- they should be consistent with this description.
- Put_Line (Standard_Error, "version 1.2.0");
- Put_Line (Standard_Error, "wisi-generate [options] {wisi grammar file}");
+ Put_Line (Standard_Error, "version 1.3.0");
+ Put_Line (Standard_Error, "wisitoken-bnf-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:");
@@ -131,7 +130,6 @@ is
Trace : aliased WisiToken.Text_IO_Trace.Trace
(Wisitoken_Grammar_Actions.Descriptor'Access);
Input_Data : aliased WisiToken_Grammar_Runtime.User_Data_Type;
- Elisp_Tokens : WisiToken.BNF.Tokens;
Grammar_Parser : WisiToken.Parse.LR.Parser_No_Recover.Parser;
Do_Time : Boolean := False;
@@ -421,12 +419,6 @@ begin
when re2c_Lexer =>
WisiToken.BNF.Output_Ada_Common.Create_re2c
(Input_Data, Tuple, Generate_Data, -Output_File_Name_Root);
- if Tuple.Out_Lang = Ada_Emacs_Lang and
Elisp_Tokens.Keywords.Is_Empty then
- -- elisp code needs keywords for font-lock.
- Elisp_Tokens.Keywords := Input_Data.Tokens.Keywords;
- end if;
- when Elisp_Lexer =>
- Elisp_Tokens := Input_Data.Tokens;
when others =>
null;
end case;
@@ -474,7 +466,6 @@ begin
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 =>
@@ -502,7 +493,6 @@ begin
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 =>
@@ -558,12 +548,9 @@ begin
when Ada_Emacs_Lang =>
WisiToken.BNF.Output_Ada_Emacs
- (Input_Data, Elisp_Tokens, -Output_File_Name_Root,
Generate_Data, Packrat_Data, Tuple,
+ (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;
if WisiToken.Generate.Error then
raise WisiToken.Grammar_Error with "errors: aborting";
diff --git a/wisitoken-bnf-generate_grammar.adb
b/wisitoken-bnf-generate_grammar.adb
index 165f00f..cd165c4 100644
--- a/wisitoken-bnf-generate_grammar.adb
+++ b/wisitoken-bnf-generate_grammar.adb
@@ -2,7 +2,7 @@
--
-- Output Ada source code to recreate Grammar.
--
--- Copyright (C) 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
@@ -31,8 +31,9 @@ is
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) &
");");
+ Indent_Line
+ ("Grammar.Set_First_Last (" & Trimmed_Image (Grammar.First_Index) & ", " &
+ Trimmed_Image (Grammar.Last_Index) & ");");
for Prod of Grammar loop
Indent_Line ("declare");
@@ -40,8 +41,7 @@ begin
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) & ");");
+ Indent_Line ("Prod.RHSs.Set_First_Last (0, " & 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);
@@ -51,8 +51,8 @@ begin
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) & ");");
+ Indent_Line
+ ("RHS.Tokens.Set_First_Last (1, " & 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);");
diff --git a/wisitoken-bnf-generate_utils.adb b/wisitoken-bnf-generate_utils.adb
index 0f84547..65f64e6 100644
--- a/wisitoken-bnf-generate_utils.adb
+++ b/wisitoken-bnf-generate_utils.adb
@@ -50,34 +50,13 @@ package body WisiToken.BNF.Generate_Utils is
-- This function is used to compute 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;
+ return -Cursor.Data.Tokens.Non_Grammar (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Name;
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;
+ return -Cursor.Data.Tokens.Keywords (Cursor.Keyword).Name;
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;
+ return -Cursor.Data.Tokens.Tokens (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Name;
when EOI =>
return EOI_Name;
@@ -86,12 +65,7 @@ package body WisiToken.BNF.Generate_Utils is
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;
+ return -Cursor.Data.Tokens.Rules (Cursor.Nonterminal).Left_Hand_Side;
when Done =>
raise SAL.Programmer_Error with "token cursor is done";
@@ -106,10 +80,8 @@ package body WisiToken.BNF.Generate_Utils 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.Grammar.Set_First_Last (Descriptor.First_Nonterminal,
Descriptor.Last_Nonterminal);
+ Data.Source_Line_Map.Set_First_Last (Descriptor.First_Nonterminal,
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);
@@ -121,8 +93,7 @@ package body WisiToken.BNF.Generate_Utils is
(Find_Token_ID (Data, Start_Token) & Descriptor.EOI_ID +
WisiToken.Syntax_Trees.Null_Action);
Data.Source_Line_Map (Descriptor.Accept_ID).Line :=
Line_Number_Type'First;
- Data.Source_Line_Map (Descriptor.Accept_ID).RHS_Map.Set_First (0);
- Data.Source_Line_Map (Descriptor.Accept_ID).RHS_Map.Set_Last (0);
+ Data.Source_Line_Map (Descriptor.Accept_ID).RHS_Map.Set_First_Last
(0, 0);
Data.Source_Line_Map (Descriptor.Accept_ID).RHS_Map (0) :=
Line_Number_Type'First;
exception
when Not_Found =>
@@ -144,12 +115,10 @@ package body WisiToken.BNF.Generate_Utils is
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);
+ RHSs.Set_First_Last (RHS_Index, 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);
+ Data.Source_Line_Map (LHS).RHS_Map.Set_First_Last
(RHSs.First_Index, RHSs.Last_Index);
for Right_Hand_Side of Rule.Right_Hand_Sides loop
declare
@@ -159,8 +128,7 @@ package body WisiToken.BNF.Generate_Utils is
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));
+ Tokens.Set_First_Last (I, Integer
(Right_Hand_Side.Tokens.Length));
for Token of Right_Hand_Side.Tokens loop
Tokens (I) := Find_Token_ID (Data, -Token.Identifier);
I := I + 1;
@@ -296,34 +264,14 @@ package body WisiToken.BNF.Generate_Utils is
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;
+ return
+ (Element => Container.Data.Tokens.Non_Grammar
(Cursor.Token_Kind).Tokens (Cursor.Token_Item).Name'Access);
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;
+ return (Element => Container.Data.Tokens.Keywords
(Cursor.Keyword).Name'Access);
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;
+ return (Element => Container.Data.Tokens.Tokens
(Cursor.Token_Kind).Tokens (Cursor.Token_Item).Name'Access);
when EOI =>
return (Element => Aliased_EOI_Name'Access);
@@ -332,12 +280,7 @@ package body WisiToken.BNF.Generate_Utils is
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;
+ return (Element => Container.Data.Tokens.Rules
(Cursor.Nonterminal).Left_Hand_Side'Access);
when Done =>
raise SAL.Programmer_Error with "token cursor is done";
@@ -391,7 +334,7 @@ package body WisiToken.BNF.Generate_Utils is
Kind => Terminals_Keywords,
ID => Cursor.Data.Descriptor.First_Terminal,
Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
- Token_Item => String_Pair_Lists.No_Element,
+ Token_Item => String_Triple_Lists.No_Element,
Keyword => Cursor.Data.Tokens.Keywords.First,
Nonterminal => Rule_Lists.No_Element);
@@ -404,13 +347,13 @@ package body WisiToken.BNF.Generate_Utils is
Kind => Terminals_Others,
ID => Cursor.ID,
Token_Kind => Cursor.Data.Tokens.Tokens.First,
- Token_Item => String_Pair_Lists.No_Element,
+ Token_Item => String_Triple_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);
+ return WisiToken.BNF.String_Triple_Lists.Has_Element
(Cursor.Token_Item);
else
return False;
end if;
@@ -422,7 +365,7 @@ package body WisiToken.BNF.Generate_Utils is
Kind => EOI,
ID => Cursor.ID,
Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
- Token_Item => String_Pair_Lists.No_Element,
+ Token_Item => String_Triple_Lists.No_Element,
Keyword => String_Pair_Lists.No_Element,
Nonterminal => Rule_Lists.No_Element);
@@ -436,7 +379,7 @@ package body WisiToken.BNF.Generate_Utils is
Kind => WisiToken_Accept,
ID => Cursor.ID,
Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
- Token_Item => String_Pair_Lists.No_Element,
+ Token_Item => String_Triple_Lists.No_Element,
Keyword => String_Pair_Lists.No_Element,
Nonterminal => Rule_Lists.No_Element);
else
@@ -455,7 +398,7 @@ package body WisiToken.BNF.Generate_Utils is
Kind => Nonterminal,
ID => Cursor.ID,
Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
- Token_Item => String_Pair_Lists.No_Element,
+ Token_Item => String_Triple_Lists.No_Element,
Keyword => String_Pair_Lists.No_Element,
Nonterminal => Cursor.Data.Tokens.Rules.First);
@@ -482,14 +425,14 @@ package body WisiToken.BNF.Generate_Utils is
Kind => Non_Grammar_Kind,
ID => Token_ID'First,
Token_Kind => Data.Tokens.Non_Grammar.First,
- Token_Item => String_Pair_Lists.No_Element,
+ Token_Item => String_Triple_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
+ if WisiToken.BNF.String_Triple_Lists.Has_Element
(Cursor.Token_Item) then
return Cursor;
end if;
end if;
@@ -508,15 +451,15 @@ package body WisiToken.BNF.Generate_Utils is
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
+ String_Triple_Lists.Next (Cursor.Token_Item);
+ if String_Triple_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
+ if String_Triple_Lists.Has_Element (Cursor.Token_Item) then
return;
end if;
end if;
@@ -541,14 +484,14 @@ package body WisiToken.BNF.Generate_Utils is
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
+ WisiToken.BNF.String_Triple_Lists.Next (Cursor.Token_Item);
+ if WisiToken.BNF.String_Triple_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
+ if WisiToken.BNF.String_Triple_Lists.Has_Element
(Cursor.Token_Item) then
return;
end if;
end if;
@@ -608,13 +551,13 @@ package body WisiToken.BNF.Generate_Utils is
is begin
case Cursor.Kind is
when Non_Grammar_Kind =>
- return -Token_Lists.Constant_Reference
(Cursor.Data.Tokens.Non_Grammar, Cursor.Token_Kind).Kind;
+ return -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;
+ return -Cursor.Data.Tokens.Tokens (Cursor.Token_Kind).Kind;
when EOI =>
return "EOI";
@@ -623,7 +566,7 @@ package body WisiToken.BNF.Generate_Utils is
return "accept";
when Nonterminal =>
- return "nonterminal";
+ return "nonterminal";
when Done =>
raise SAL.Programmer_Error with "token cursor is done";
@@ -634,34 +577,13 @@ package body WisiToken.BNF.Generate_Utils is
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;
+ return -Cursor.Data.Tokens.Non_Grammar (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Value;
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;
+ return -Cursor.Data.Tokens.Keywords (Cursor.Keyword).Value;
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;
+ return -Cursor.Data.Tokens.Tokens (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Value;
when EOI | WisiToken_Accept | Nonterminal =>
return "";
@@ -671,6 +593,26 @@ package body WisiToken.BNF.Generate_Utils is
end case;
end Value;
+ function Repair_Image (Cursor : in Token_Cursor) return String
+ is begin
+ case Cursor.Kind is
+ when Non_Grammar_Kind =>
+ return -Cursor.Data.Tokens.Non_Grammar (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Repair_Image;
+
+ when Terminals_Keywords =>
+ return "";
+
+ when Terminals_Others =>
+ return -Cursor.Data.Tokens.Tokens (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Repair_Image;
+
+ when EOI | WisiToken_Accept | Nonterminal =>
+ return "";
+
+ when Done =>
+ raise SAL.Programmer_Error with "token cursor is done";
+ end case;
+ end Repair_Image;
+
function To_Conflicts
(Data : aliased in out Generate_Data;
Conflicts : in WisiToken.BNF.Conflict_Lists.List;
@@ -760,15 +702,6 @@ package body WisiToken.BNF.Generate_Utils is
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)
@@ -780,24 +713,7 @@ package body WisiToken.BNF.Generate_Utils is
(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");
+ WisiToken.State_Index'Image (Generate_Data.Parser_State_Count) & "
states");
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
index bcf599f..0cd7508 100644
--- a/wisitoken-bnf-generate_utils.ads
+++ b/wisitoken-bnf-generate_utils.ads
@@ -49,11 +49,10 @@ package WisiToken.BNF.Generate_Utils is
-- The following fields are LR specific; so far, it's not worth
-- splitting them out.
- Ignore_Conflicts : Boolean := False;
- Conflicts : WisiToken.Generate.LR.Conflict_Lists.List;
- LR_Parse_Table : WisiToken.Parse.LR.Parse_Table_Ptr;
- Table_Actions_Count : Integer := -1; -- parse, not
user, actions
- Parser_State_Count : WisiToken.Unknown_State_Index := 0;
+ Ignore_Conflicts : Boolean := False;
+ Conflicts : WisiToken.Generate.LR.Conflict_Lists.List;
+ LR_Parse_Table : WisiToken.Parse.LR.Parse_Table_Ptr;
+ Parser_State_Count : WisiToken.Unknown_State_Index := 0;
end record;
function Initialize
@@ -132,6 +131,12 @@ package WisiToken.BNF.Generate_Utils is
-- Tokens : Tokens (i).Tokens (j).Value
-- Rules : empty string (they have no Value)
+ function Repair_Image (Cursor : in Token_Cursor) return String;
+ -- Return the token repair image from the .wy file:
+ -- Keywords: empty string
+ -- Tokens : Tokens (i).Tokens (j).Repair_Image
+ -- Rules : empty string
+
function To_Conflicts
(Data : aliased in out Generate_Data;
Conflicts : in WisiToken.BNF.Conflict_Lists.List;
@@ -149,15 +154,10 @@ package WisiToken.BNF.Generate_Utils is
Item : in McKenzie_Recover_Param_Type)
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
@@ -168,7 +168,7 @@ private
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;
+ Token_Item : String_Triple_Lists.Cursor;
Keyword : String_Pair_Lists.Cursor;
Nonterminal : Rule_Lists.Cursor;
end record;
diff --git a/wisitoken-bnf-output_ada_common.adb
b/wisitoken-bnf-output_ada_common.adb
index b3d7dea..97ec9ed 100644
--- a/wisitoken-bnf-output_ada_common.adb
+++ b/wisitoken-bnf-output_ada_common.adb
@@ -33,13 +33,12 @@ package body WisiToken.BNF.Output_Ada_Common is
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;
+ Action_Node : Parse_Action_Node_Ptr;
First : Boolean := True;
Action : Reduce_Action_Rec;
begin
- loop
- Action_Node := Node.Action;
+ for Node of State.Action_List loop
+ Action_Node := Node.Actions;
if Action_Node.Next /= null then
-- conflict
return False;
@@ -55,32 +54,27 @@ package body WisiToken.BNF.Output_Ada_Common is
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 all type Ada.Containers.Count_Type;
use Ada.Strings.Unbounded;
- use Parse.LR;
Result : Unbounded_String;
- Need_Comma : Boolean := False;
- Node : Action_Node_Ptr := State.Action_List;
+ Need_Comma : Boolean := False;
begin
- if Generate_Utils.Actions_Length (State) = 1 then
- return "(1 => " & Token_ID'Image (Node.Symbol) & ")";
+ if State.Action_List.Length = 1 then
+ return "(1 => " & Token_ID'Image (State.Action_List (1).Symbol) & ")";
else
Result := +"(";
- loop
+ for Node of State.Action_List 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;
@@ -267,6 +261,7 @@ package body WisiToken.BNF.Output_Ada_Common is
"WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;");
else
Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;");
+ Indent_Line (" -- no error recovery");
end if;
Indent_Line (" Trace : not null access
WisiToken.Trace'Class;");
Indent_Start (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access");
@@ -555,11 +550,15 @@ package body WisiToken.BNF.Output_Ada_Common is
declare
use Ada.Containers;
Base_Indent : constant Ada.Text_IO.Count := Indent;
- Node : Action_Node_Ptr := Table.States
(State_Index).Action_List;
begin
+ Indent_Line
+ ("Table.States (" & Trimmed_Image (State_Index) &
").Action_List.Set_Capacity (" &
+ Trimmed_Image (Table.States (State_Index).Action_List.Length)
& ");");
+
if Duplicate_Reduce (Table.States (State_Index)) then
declare
- Action : constant Reduce_Action_Rec := Node.Action.Item;
+ Node : Action_Node renames Table.States
(State_Index).Action_List (1);
+ Action : constant Reduce_Action_Rec := Node.Actions.Item;
begin
Set_Col (Indent);
Line := +"Add_Action (Table.States (" & Trimmed_Image
(State_Index) & "), " &
@@ -587,11 +586,10 @@ package body WisiToken.BNF.Output_Ada_Common is
end;
else
- loop
- exit when Node = null;
+ for Node of Table.States (State_Index).Action_List loop
Set_Col (Indent);
declare
- Action_Node : Parse_Action_Node_Ptr := Node.Action;
+ Action_Node : Parse_Action_Node_Ptr := Node.Actions;
begin
case Action_Node.Item.Verb is
when Shift =>
@@ -632,7 +630,7 @@ package body WisiToken.BNF.Output_Ada_Common is
Append (");");
when Parse.LR.Error =>
- Line := +"Add_Error (Table.States (" & Trimmed_Image
(State_Index) & "));";
+ raise SAL.Programmer_Error;
end case;
Indent_Wrap (-Line);
Line_Count := Line_Count + 1;
@@ -675,24 +673,22 @@ package body WisiToken.BNF.Output_Ada_Common is
end loop;
end;
Indent := Base_Indent;
- Node := Node.Next;
end loop;
end if;
end Actions;
+ if Table.States (State_Index).Goto_List.Length > 0 then
+ Indent_Line
+ ("Table.States (" & Trimmed_Image (State_Index) &
").Goto_List.Set_Capacity (" &
+ Trimmed_Image (Table.States (State_Index).Goto_List.Length) &
");");
+ end if;
Gotos :
- declare
- 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;
+ for Node of Table.States (State_Index).Goto_List loop
+ Set_Col (Indent);
+ Put ("Add_Goto (Table.States (" & Trimmed_Image (State_Index) &
"), ");
+ Put_Line (Trimmed_Image (Node.Symbol) & ", " & Trimmed_Image
(Node.State) & ");");
+ Line_Count := Line_Count + 1;
+ end loop Gotos;
if Input_Data.Language_Params.Error_Recover then
if Table.States (State_Index).Kernel.Length > 0 then
@@ -741,6 +737,7 @@ package body WisiToken.BNF.Output_Ada_Common is
for Subr in 1 .. Subr_Count loop
Indent_Line ("Subr_" & Trimmed_Image (Subr) & ";");
end loop;
+ Indent_Line ("Table.Error_Action := new Parse_Action_Node'((Verb =>
Error), null);");
Indent := Indent - 3;
Indent_Line ("end;");
end Create_LR_Parser_Table;
@@ -1217,14 +1214,9 @@ package body WisiToken.BNF.Output_Ada_Common is
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;
+ Indent_Line
+ (Val & " {*id = " & WisiToken.Token_ID'Image (ID (I)) &
+ "; skip_to(lexer, " & Repair_Image (I) & ");
continue;}");
elsif 0 /= Index (Source => Val, Pattern => "/") then
Indent_Line (Val & " {*id = " & WisiToken.Token_ID'Image (ID
(I)) & "; continue;}");
diff --git a/wisitoken-bnf-output_ada_emacs.adb
b/wisitoken-bnf-output_ada_emacs.adb
index ae109fa..2de6e0c 100644
--- a/wisitoken-bnf-output_ada_emacs.adb
+++ b/wisitoken-bnf-output_ada_emacs.adb
@@ -40,7 +40,6 @@ with WisiToken.Generate.Packrat;
with WisiToken_Grammar_Runtime;
procedure WisiToken.BNF.Output_Ada_Emacs
(Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Elisp_Tokens : in WisiToken.BNF.Tokens;
Output_File_Name_Root : in String;
Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
Packrat_Data : in WisiToken.Generate.Packrat.Data;
@@ -277,28 +276,10 @@ is
when others => "(" & (-Result) & "))");
end Statement_Params;
- function Containing_Params (Params : in String) return String
- is
- -- Input looks like: 1 2)
- First : constant Integer := Index_Non_Blank (Params);
- Second : constant Integer := Index (Params, Blank_Set, First);
- First_Label : constant String := Params (First .. Second - 1);
- Second_Label : constant String := Params (Second + 1 .. Params'Last
- 1);
- begin
- if (0 = Index (First_Label, Numeric, Outside) or else Label_Used
(First_Label)) and
- (0 = Index (Second_Label, Numeric, Outside) or else Label_Used
(Second_Label))
- then
- Nonterm_Needed := True;
- return " (Parse_Data, Tree, Nonterm, Tokens, " & First_Label & ",
" & Second_Label & ")";
- else
- return "";
- end if;
- end Containing_Params;
-
function Motion_Params (Params : in String) return String
is
- -- Input looks like: [1 [2 EXCEPTION WHEN] 3 ...]
- -- Result: (..., Motion_Param_Array'((1, Empty_IDs) & (2, (3 & 8)) &
(3, Empty_IDs))
+ -- Input looks like: [1 [2 EXCEPTION] 3 ...]
+ -- Result: (..., Motion_Param_Array'((1, Invalid_Token_ID) & (2, 3)
& (3, Invalid_Token_ID))
use Generate_Utils;
use Ada.Strings.Maps;
@@ -307,56 +288,61 @@ is
Last : Integer := Index_Non_Blank (Params); -- skip [
First : Integer;
Vector : Boolean;
- Result : Unbounded_String := +" (Parse_Data, Tree, Nonterm, Tokens,
(";
+ Result : Unbounded_String;
Index_First : Integer;
Index_Last : Integer;
- IDs : Unbounded_String;
- IDs_Count : Integer;
- Need_Comma_1 : Boolean := False;
- Need_Comma_2 : Boolean := False;
+ ID : Unbounded_String;
+ Need_Comma : Boolean := False;
+ Count : Integer := 0;
begin
loop
+ if not (Last in Params'First .. Params'Last) then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
+ "Missing ']' or ')'"));
+ exit;
+ end if;
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;
+ Index_First := Last + 1;
+ Last := Index (Params, Delim, Index_First);
+ Index_Last := Last - 1;
+ First := Last + 1;
+ Last := Index (Params, Delim, First);
+ begin
+ ID := +Trimmed_Image (Find_Token_ID (Generate_Data, Params
(First .. Last - 1)));
+ exception
+ when E : Not_Found =>
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
+ Ada.Exceptions.Exception_Message (E)));
+ end;
declare
Label : constant String := Params (Index_First ..
Index_Last);
begin
if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
- Nonterm_Needed := True;
- Result := Result & (if Need_Comma_1 then " & " else "") &
"(" &
- Label & ", " &
- (if IDs_Count = 1 then "+" else "") & IDs & ")";
+ Result := Result & (if Need_Comma then " & " else "") &
"(" &
+ Label & ", " & ID & ")";
+ Need_Comma := True;
+ Count := Count + 1;
end if;
end;
+ if Params (Last) /= ']' then
+ Put_Error
+ (Error_Message
+ (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
+ "too many token IDs in motion action"));
+ return -Result & "))";
+ end if;
+
else
First := Index_Non_Blank (Params, Last);
Last := Index (Params, Delim, First);
@@ -364,14 +350,20 @@ is
Label : constant String := Params (First .. Last - 1);
begin
if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
- Nonterm_Needed := True;
- Result := Result & (if Need_Comma_1 then " & " else "") &
"(" & Label & ", Empty_IDs)";
+ Result := Result & (if Need_Comma then " & " else "") &
"(" & Label & ", Invalid_Token_ID)";
+ Need_Comma := True;
+ Count := Count + 1;
end if;
end;
end if;
- Need_Comma_1 := True;
end loop;
- return -(Result & "))");
+ if Count <= 1 then
+ -- No point in calling Motion_Action with only one param.
+ return "";
+ else
+ Nonterm_Needed := True;
+ return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
+ end if;
end Motion_Params;
function Face_Apply_Params (Params : in String) return String
@@ -1073,15 +1065,6 @@ is
end if;
end;
- elsif Elisp_Name = "wisi-containing-action" then
- declare
- Params : constant String := Containing_Params (Line (Last + 1
.. Line'Last));
- begin
- if Params'Length > 0 then
- Navigate_Lines.Append (Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) & Params & ";");
- end if;
- end;
-
elsif Elisp_Name = "wisi-motion-action" then
declare
Params : constant String := Motion_Params (Line (Last + 1 ..
Line'Last));
@@ -1644,17 +1627,9 @@ is
Output_Elisp_Common.Indent_Name_Table
(Output_File_Name_Root, "process-face-table", Input_Data.Tokens.Faces);
- -- We need the elisp lexer for some operations
- if Elisp_Tokens.Keywords.Length > 0 then
- New_Line;
- Output_Elisp_Common.Indent_Keyword_Table
- (Output_File_Name_Root, "elisp", Elisp_Tokens.Keywords,
Ada.Strings.Unbounded.To_String'Access);
- end if;
- if Elisp_Tokens.Tokens.Length > 0 then
- New_Line;
- Output_Elisp_Common.Indent_Token_Table
- (Output_File_Name_Root, "elisp", Elisp_Tokens.Tokens,
Ada.Strings.Unbounded.To_String'Access);
- end if;
+ -- We need -repair-image for wisi-repair-error
+ New_Line;
+ Output_Elisp_Common.Indent_Repair_Image (Output_File_Name_Root,
"process", Input_Data.Tokens);
New_Line;
Put_Line ("(provide '" & Output_File_Name_Root & "-process)");
diff --git a/wisitoken-bnf-output_elisp.adb b/wisitoken-bnf-output_elisp.adb
deleted file mode 100644
index ff52449..0000000
--- a/wisitoken-bnf-output_elisp.adb
+++ /dev/null
@@ -1,293 +0,0 @@
--- Abstract :
---
--- Output Elisp code implementing the grammar defined by the parameters.
---
--- Copyright (C) 2012 - 2015, 2017 - 2019 Free Software Foundation, Inc.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- 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.Identifier & " ");
- 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
index a0b7158..2260955 100644
--- a/wisitoken-bnf-output_elisp_common.adb
+++ b/wisitoken-bnf-output_elisp_common.adb
@@ -106,8 +106,6 @@ package body WisiToken.BNF.Output_Elisp_Common is
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;
@@ -155,4 +153,60 @@ package body WisiToken.BNF.Output_Elisp_Common is
Indent := Indent - 3;
end Indent_Name_Table;
+ procedure Indent_Repair_Image
+ (Output_File_Root : in String;
+ Label : in String;
+ Tokens : in WisiToken.BNF.Tokens)
+ is
+ use all type Ada.Text_IO.Count;
+ use Ada.Strings.Unbounded;
+ use WisiToken.Generate;
+
+ function re2c_To_Elisp (Item : in String) return String
+ is
+ Result : String (1 .. Item'Length * 2);
+ Last : Integer := Result'First - 1;
+ begin
+ -- Convert re2c case-insensitive string '...' to elisp string "...",
+ -- with '"' escaped.
+ if Item (Item'First) /= ''' then
+ return Item;
+ end if;
+
+ for C of Item loop
+ if C = ''' then
+ Result (Last + 1) := '"';
+ Last := Last + 1;
+ elsif C = '"' then
+ Result (Last + 1) := '\';
+ Result (Last + 2) := '"';
+ Last := Last + 2;
+ else
+ Result (Last + 1) := C;
+ Last := Last + 1;
+ end if;
+ end loop;
+ return Result (1 .. Last);
+ end re2c_To_Elisp;
+
+ begin
+ Indent_Line ("(defconst " & Output_File_Root & "-" & Label &
"-repair-image");
+ Indent_Line (" '(");
+ Indent := Indent + 3;
+ for Pair of Tokens.Keywords loop
+ Indent_Line ("(" & (-Pair.Name) & " . " & (-Pair.Value) & ")");
+ end loop;
+ for Kind of Tokens.Tokens loop
+ for Token of Kind.Tokens loop
+ if Length (Token.Repair_Image) > 0 then
+ Indent_Line ("(" & (-Token.Name) & " . " & re2c_To_Elisp
(-Token.Repair_Image) & ")");
+ else
+ Indent_Line ("(" & (-Token.Name) & " . " & (-Token.Value) &
")");
+ end if;
+ end loop;
+ end loop;
+ Indent_Line ("))");
+ Indent := Indent - 3;
+ end Indent_Repair_Image;
+
end WisiToken.BNF.Output_Elisp_Common;
diff --git a/wisitoken-bnf-output_elisp_common.ads
b/wisitoken-bnf-output_elisp_common.ads
index 040bd5e..03a655e 100644
--- a/wisitoken-bnf-output_elisp_common.ads
+++ b/wisitoken-bnf-output_elisp_common.ads
@@ -2,7 +2,7 @@
--
-- Subprograms common to Output_Elisp and Output_Ada_Emacs
--
--- Copyright (C) 2012, 2013, 2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2012, 2013, 2015, 2017, 2018, 2019 Free Software Foundation,
Inc.
--
-- The WisiToken package is free software; you can redistribute it
-- and/or modify it under terms of the GNU General Public License as
@@ -46,4 +46,9 @@ package WisiToken.BNF.Output_Elisp_Common is
Label : in String;
Names : in String_Lists.List);
+ procedure Indent_Repair_Image
+ (Output_File_Root : in String;
+ Label : in String;
+ Tokens : in WisiToken.BNF.Tokens);
+
end WisiToken.BNF.Output_Elisp_Common;
diff --git a/wisitoken-bnf.adb b/wisitoken-bnf.adb
index dc37d56..29e4f60 100644
--- a/wisitoken-bnf.adb
+++ b/wisitoken-bnf.adb
@@ -204,25 +204,26 @@ package body WisiToken.BNF is
end Count;
procedure Add_Token
- (Tokens : in out Token_Lists.List;
- Kind : in String;
- Name : in String;
- Value : in String)
+ (Tokens : in out Token_Lists.List;
+ Kind : in String;
+ Name : in String;
+ Value : in String;
+ Repair_Image : 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));
+ Token_Kind.Tokens.Append ((+Name, +Value, +Repair_Image));
return;
end if;
end loop;
-- Kind not found; add it
declare
- Temp : String_Pair_Lists.List;
+ Temp : String_Triple_Lists.List;
begin
- Temp.Append ((+Name, +Value));
+ Temp.Append ((+Name, +Value, +Repair_Image));
Tokens.Append ((+Kind, Temp));
end;
end Add_Token;
diff --git a/wisitoken-bnf.ads b/wisitoken-bnf.ads
index 3532de7..d586c4a 100644
--- a/wisitoken-bnf.ads
+++ b/wisitoken-bnf.ads
@@ -64,15 +64,14 @@ package WisiToken.BNF is
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);
+ type Output_Language is (Ada_Lang, Ada_Emacs_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
String_Access_Constant :=
(Ada_Lang => new String'("Ada"),
- Ada_Emacs_Lang => new String'("Ada_Emacs"),
- Elisp_Lang => new String'("elisp"));
+ Ada_Emacs_Lang => new String'("Ada_Emacs"));
function To_Output_Language (Item : in String) return Output_Language;
-- Raises User_Error for invalid Item
@@ -188,6 +187,14 @@ package WisiToken.BNF is
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 String_Triple_Type is record
+ Name : aliased Ada.Strings.Unbounded.Unbounded_String;
+ Value : Ada.Strings.Unbounded.Unbounded_String;
+ Repair_Image : Ada.Strings.Unbounded.Unbounded_String;
+ end record;
+
+ package String_Triple_Lists is new Ada.Containers.Doubly_Linked_Lists
(String_Triple_Type);
+
type Elisp_Action_Type is record
-- Elisp name is the key
Action_Label : Ada.Strings.Unbounded.Unbounded_String;
@@ -229,7 +236,7 @@ package WisiToken.BNF is
type Token_Kind_Type is record
Kind : Ada.Strings.Unbounded.Unbounded_String;
- Tokens : String_Pair_Lists.List;
+ Tokens : String_Triple_Lists.List;
end record;
package Token_Lists is new Ada.Containers.Doubly_Linked_Lists
(Token_Kind_Type);
@@ -238,11 +245,12 @@ package WisiToken.BNF is
-- 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.
+ (Tokens : in out Token_Lists.List;
+ Kind : in String;
+ Name : in String;
+ Value : in String;
+ Repair_Image : in String := "");
+ -- Add Name, Value, Repair_Image to Kind list in Tokens.
function Is_In (Tokens : in Token_Lists.List; Kind : in String) return
Boolean;
function Is_In
diff --git a/wisitoken-generate-lr-lalr_generate.adb
b/wisitoken-generate-lr-lalr_generate.adb
index f55c822..3631f64 100644
--- a/wisitoken-generate-lr-lalr_generate.adb
+++ b/wisitoken-generate-lr-lalr_generate.adb
@@ -176,7 +176,7 @@ package body WisiToken.Generate.LR.LALR_Generate is
Found_State : Unknown_State_Index;
begin
- Kernels.Set_First (First_State_Index);
+ Kernels.Set_First_Last (First_State_Index, First_State_Index - 1);
Add (New_Item_Set, Kernels, Kernel_Tree, Descriptor, Include_Lookaheads
=> False);
@@ -298,7 +298,7 @@ package body WisiToken.Generate.LR.LALR_Generate is
Propagations.Append ((From_Cur, To_List (To_Item)));
elsif not Has_Element (To_Match) then
- Ref (From_Match).To.Append (To_Item);
+ Variable_Ref (From_Match).To.Append (To_Item);
else
raise SAL.Programmer_Error with "Add_Propagation: unexpected case";
@@ -360,7 +360,7 @@ package body WisiToken.Generate.LR.LALR_Generate is
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);
+ LR1_Items.Include (Variable_Ref (To_Item),
Closure_Item.Lookaheads.all, Descriptor);
end if;
end;
end Generate_Lookahead_Info;
@@ -382,7 +382,8 @@ package body WisiToken.Generate.LR.LALR_Generate is
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);
+ LR1_Items.Include
+ (Variable_Ref (Copy), Constant_Ref
(Mapping.From).Lookaheads.all, Added_One, Descriptor);
More_To_Check := More_To_Check or Added_One;
end loop;
diff --git a/wisitoken-generate-lr-lr1_generate.adb
b/wisitoken-generate-lr-lr1_generate.adb
index 0f177d9..d148c67 100644
--- a/wisitoken-generate-lr-lr1_generate.adb
+++ b/wisitoken-generate-lr-lr1_generate.adb
@@ -100,7 +100,7 @@ package body WisiToken.Generate.LR.LR1_Generate is
Found_State : Unknown_State_Index;
begin
- C.Set_First (First_State_Index);
+ C.Set_First_Last (First_State_Index, First_State_Index - 1);
Add (New_Item_Set, C, C_Tree, Descriptor, Include_Lookaheads => True);
diff --git a/wisitoken-generate-lr.adb b/wisitoken-generate-lr.adb
index b814885..54ddfd6 100644
--- a/wisitoken-generate-lr.adb
+++ b/wisitoken-generate-lr.adb
@@ -254,7 +254,7 @@ package body WisiToken.Generate.LR is
procedure Add_Action
(Symbol : in Token_ID;
Action : in Parse_Action_Rec;
- Action_List : in out Action_Node_Ptr;
+ Action_List : in out Action_Arrays.Vector;
Closure : in LR1_Items.Item_Set;
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
@@ -263,7 +263,7 @@ package body WisiToken.Generate.LR is
Conflicts : in out Conflict_Lists.List;
Descriptor : in WisiToken.Descriptor)
is
- Matching_Action : constant Action_Node_Ptr := Find (Symbol, Action_List);
+ Matching_Action : constant Action_Arrays.Find_Reference_Type :=
Action_List.Find (Symbol);
begin
if Trace_Generate > Detail then
Ada.Text_IO.Put (Image (Symbol, Descriptor) & " => ");
@@ -271,8 +271,8 @@ package body WisiToken.Generate.LR is
Ada.Text_IO.New_Line;
end if;
- if Matching_Action /= null then
- if Is_In (Action, Matching_Action.Action) then
+ if Matching_Action.Element /= null then
+ if Is_In (Action, Matching_Action.Actions) then
-- Action is already in the list.
if Trace_Generate > Detail then
Ada.Text_IO.Put_Line (" - already present");
@@ -287,10 +287,10 @@ package body WisiToken.Generate.LR is
-- list of conflicting actions, so we keep it the first item
in the
-- list; no order in the rest of the list.
Action_A : constant Parse_Action_Rec :=
- (if Action.Verb in Shift | Accept_It then Action else
Matching_Action.Action.Item);
+ (if Action.Verb in Shift | Accept_It then Action else
Matching_Action.Actions.Item);
Action_B : constant Parse_Action_Rec :=
- (if Action.Verb in Shift | Accept_It then
Matching_Action.Action.Item else Action);
+ (if Action.Verb in Shift | Accept_It then
Matching_Action.Actions.Item else Action);
New_Conflict : constant Conflict :=
(Action_A => Action_A.Verb,
@@ -362,9 +362,9 @@ package body WisiToken.Generate.LR is
end if;
if Action.Verb = Shift then
- Matching_Action.Action := new Parse_Action_Node'(Action,
Matching_Action.Action);
+ Matching_Action.Actions := new Parse_Action_Node'(Action,
Matching_Action.Actions);
else
- Matching_Action.Action.Next := new
Parse_Action_Node'(Action, Matching_Action.Action.Next);
+ Matching_Action.Actions.Next := new
Parse_Action_Node'(Action, Matching_Action.Actions.Next);
end if;
end;
end if;
@@ -442,51 +442,9 @@ package body WisiToken.Generate.LR is
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;
+ -- We don't place a default error action at the end of every state;
+ -- Parse.LR.Action_For returns Table.Error_Action when Symbol is not
found.
+ Table.Error_Action := new Parse_Action_Node'((Verb =>
WisiToken.Parse.LR.Error), null);
for Item of Closure.Goto_List loop
if Item.Symbol in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal then
@@ -497,7 +455,7 @@ package body WisiToken.Generate.LR is
procedure Add_Lookahead_Actions
(Item : in LR1_Items.Item;
- Action_List : in out Action_Node_Ptr;
+ Action_List : in out Action_Arrays.Vector;
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
@@ -854,25 +812,21 @@ package body WisiToken.Generate.LR is
Working_Set : LR1_Items.Item_Lists.List := Kernel.Set;
Recursive : Boolean := False;
- function Find_Action (List : in Action_Node_Ptr; ID : in Token_ID)
return Minimal_Action
- is
- Node : Action_Node_Ptr := List;
- begin
- loop
+ function Find_Action (List : in Action_Arrays.Vector; ID : in Token_ID)
return Minimal_Action
+ is begin
+ for Node of List loop
if Node.Symbol = ID then
- case Node.Action.Item.Verb is
+ case Node.Actions.Item.Verb is
when Shift =>
- return (Shift, ID, Node.Action.Item.State);
+ return (Shift, ID, Node.Actions.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);
+ return (Reduce, Node.Actions.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;
@@ -1219,6 +1173,7 @@ package body WisiToken.Generate.LR is
Action_Names : in Names_Array_Array;
Check_Names : in Names_Array_Array)
is
+ use all type SAL.Base_Peek_Type;
use Ada.Containers;
use Ada.Text_IO;
File : File_Type;
@@ -1238,75 +1193,67 @@ package body WisiToken.Generate.LR is
New_Line (File);
for State of Table.States loop
- 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));
+ Put (File, Trimmed_Image (State.Action_List.Length) & ' ');
+ for I in State.Action_List.First_Index ..
State.Action_List.Last_Index loop
+ -- Action first, for historical reasons
+ declare
+ Node_I : Action_Node renames State.Action_List (I);
+ Node_J : Parse_Action_Node_Ptr := Node_I.Actions;
+ 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));
+ 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));
+ 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;
+ 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));
+ 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;
+ when Parse.LR.Error =>
+ raise SAL.Programmer_Error;
+ 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;
+ Node_J := Node_J.Next;
+ exit when Node_J = null;
+ Put (File, ' ');
+ end loop;
+ Put (File, ';');
+ Put (File, Token_ID'Image (Node_I.Symbol));
+ end;
+ if I = State.Action_List.Last_Index then
+ Put_Line (File, ";");
+ else
New_Line (File);
+ end if;
+ end loop;
- Node_I := Node_I.Next;
+ if State.Goto_List.Length > 0 then
+ Put (File, Trimmed_Image (State.Goto_List.Length));
+ for Node of State.Goto_List loop
+ Put (File, Node.Symbol'Image & Node.State'Image);
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;
+ end if;
+ Put (File, ';');
+ New_Line (File);
if State.Kernel.Length = 0 then
-- Not set for state 0
@@ -1455,34 +1402,27 @@ package body WisiToken.Generate.LR 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;
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);
+ for Action of State.Action_List loop
+ Put (" " & Image (Action.Symbol, Descriptor) &
+ (Descriptor.Image_Width - Image (Action.Symbol,
Descriptor)'Length) * ' '
+ & " => ");
+ Put (Descriptor, Action.Actions);
New_Line;
- Action_Ptr := Action_Ptr.Next;
end loop;
- if Goto_Ptr /= null then
+ -- The error line is redundant, but we keep it to match existing good
parse tables.
+ Put_Line (" default" & (Descriptor.Image_Width - 7) * ' ' & " =>
ERROR");
+
+ if State.Goto_List.Length > 0 then
New_Line;
end if;
- while Goto_Ptr /= null loop
+ for Item of State.Goto_List 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);
+ (" " & Image (Item.Symbol, Descriptor) &
+ (Descriptor.Image_Width - Image (Item.Symbol,
Descriptor)'Length) * ' ' &
+ " goto state" & Item.State'Image);
end loop;
New_Line;
diff --git a/wisitoken-generate-lr.ads b/wisitoken-generate-lr.ads
index 297689b..1bb9e2b 100644
--- a/wisitoken-generate-lr.ads
+++ b/wisitoken-generate-lr.ads
@@ -63,7 +63,7 @@ package WisiToken.Generate.LR is
procedure Add_Action
(Symbol : in Token_ID;
Action : in Parse_Action_Rec;
- Action_List : in out Action_Node_Ptr;
+ Action_List : in out Action_Arrays.Vector;
Closure : in LR1_Items.Item_Set;
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
@@ -89,7 +89,7 @@ package WisiToken.Generate.LR is
procedure Add_Lookahead_Actions
(Item : in LR1_Items.Item;
- Action_List : in out Action_Node_Ptr;
+ Action_List : in out Action_Arrays.Vector;
Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
Has_Empty_Production : in Token_ID_Set;
First_Nonterm_Set : in Token_Array_Token_Set;
diff --git a/wisitoken-generate-lr1_items.adb b/wisitoken-generate-lr1_items.adb
index 86cd8d9..f394b67 100644
--- a/wisitoken-generate-lr1_items.adb
+++ b/wisitoken-generate-lr1_items.adb
@@ -71,7 +71,7 @@ package body WisiToken.Generate.LR1_Items is
Modified := True;
else
- Include (Ref (Found), Lookaheads, Modified);
+ Include (Variable_Ref (Found), Lookaheads, Modified);
end if;
return Modified;
@@ -306,7 +306,7 @@ package body WisiToken.Generate.LR1_Items is
if Found_Tree = Item_Set_Trees.No_Element then
return Unknown_State;
else
- return Item_Set_Tree.Constant_Ref (Found_Tree).State;
+ return Item_Set_Tree (Found_Tree).State;
end if;
end Find;
diff --git a/wisitoken-generate.adb b/wisitoken-generate.adb
index 769a581..eae0ca3 100644
--- a/wisitoken-generate.adb
+++ b/wisitoken-generate.adb
@@ -268,8 +268,7 @@ package body WisiToken.Generate 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));
+ Result.Set_First_Last (First'First (1), First'Last (1));
for I in First'Range (1) loop
declare
diff --git a/wisitoken-parse-lr-mckenzie_recover-base.adb
b/wisitoken-parse-lr-mckenzie_recover-base.adb
index ae60955..d8b03f3 100644
--- a/wisitoken-parse-lr-mckenzie_recover-base.adb
+++ b/wisitoken-parse-lr-mckenzie_recover-base.adb
@@ -24,11 +24,11 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
(Parsers : not null access Parser_Lists.List;
Parser_Status : in Parser_Status_Array;
Min_Success_Check_Count : in Natural;
+ Total_Enqueue_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
@@ -41,9 +41,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
-- fail; another parser succeeded, this one taking too long.
Done_Count := Done_Count + 1;
- elsif P_Status.Parser_State.Recover.Enqueue_Count +
- P_Status.Parser_State.Recover.Config_Full_Count >=
Enqueue_Limit
- then
+ elsif Total_Enqueue_Count +
P_Status.Parser_State.Recover.Config_Full_Count >= Enqueue_Limit then
-- fail
Done_Count := Done_Count + 1;
end if;
@@ -90,7 +88,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
(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;
@@ -98,6 +95,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
All_Parsers_Done := False;
Success_Counter := 0;
Min_Success_Check_Count := Natural'Last;
+ Total_Enqueue_Count := 0;
Fatal_Called := False;
Result := Recover_Status'First;
Error_ID := Ada.Exceptions.Null_Id;
@@ -133,10 +131,9 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
(Parser_Index : out SAL.Base_Peek_Type;
Config : out Configuration;
Status : out Config_Status)
- when (Fatal_Called or All_Parsers_Done) or else
- Get_Barrier (Parsers, Parser_Status, Min_Success_Check_Count,
Check_Delta_Limit, Enqueue_Limit)
+ when (Fatal_Called or All_Parsers_Done) or else Get_Barrier
+ (Parsers, Parser_Status, Min_Success_Check_Count,
Total_Enqueue_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;
@@ -190,13 +187,11 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
Done_Count := Done_Count + 1;
- elsif P_Status.Parser_State.Recover.Enqueue_Count +
- P_Status.Parser_State.Recover.Config_Full_Count >=
Enqueue_Limit
- then
+ elsif Total_Enqueue_Count +
P_Status.Parser_State.Recover.Config_Full_Count >= Enqueue_Limit then
if Trace_McKenzie > Outline then
Put_Line
(Trace.all,
- P_Status.Parser_State.Label, "fail; enqueue
limit (" &
+ P_Status.Parser_State.Label, "fail; total
enqueue limit (" &
Enqueue_Limit'Image & " cost" &
P_Status.Parser_State.Recover.Config_Heap.Min_Key'Image & ")",
Task_ID => False);
@@ -274,7 +269,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
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.
@@ -331,7 +325,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
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);
@@ -339,13 +332,14 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
begin
P_Status.Active_Workers := P_Status.Active_Workers - 1;
+ Total_Enqueue_Count := Total_Enqueue_Count + Integer (Configs_Count);
+ Data.Enqueue_Count := Data.Enqueue_Count + Integer (Configs_Count);
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
@@ -353,7 +347,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
(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 (Total_Enqueue_Count) &
"/" & Trimmed_Image (Data.Check_Count) &
", min cost:" &
(if Data.Config_Heap.Count > 0
@@ -363,14 +357,15 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Base is
end if;
end Put;
- procedure Config_Full (Parser_Index : in SAL.Peek_Type)
+ procedure Config_Full (Prefix : in String; Parser_Index : in
SAL.Peek_Type)
is
P_Status : Base.Parser_Status renames Parser_Status (Parser_Index);
Data : McKenzie_Data renames P_Status.Parser_State.Recover;
begin
Data.Config_Full_Count := Data.Config_Full_Count + 1;
if Trace_McKenzie > Outline then
- Put_Line (Trace.all, Label (Parser_Index), "config.ops is full; "
& Data.Config_Full_Count'Image);
+ Put_Line (Trace.all, Label (Parser_Index), Prefix & ": config.ops
is full; " &
+ Data.Config_Full_Count'Image);
end if;
end Config_Full;
diff --git a/wisitoken-parse-lr-mckenzie_recover-base.ads
b/wisitoken-parse-lr-mckenzie_recover-base.ads
index cde4bd5..f67df90 100644
--- a/wisitoken-parse-lr-mckenzie_recover-base.ads
+++ b/wisitoken-parse-lr-mckenzie_recover-base.ads
@@ -123,7 +123,7 @@ private package WisiToken.Parse.LR.McKenzie_Recover.Base is
--
-- Decrements active worker count.
- procedure Config_Full (Parser_Index : in SAL.Peek_Type);
+ procedure Config_Full (Prefix : in String; Parser_Index : in
SAL.Peek_Type);
-- Report that a config.ops was full when trying to add another op.
-- This is counted towards the enqueue limit.
@@ -149,6 +149,7 @@ private package WisiToken.Parse.LR.McKenzie_Recover.Base is
All_Parsers_Done : Boolean;
Success_Counter : Natural;
Min_Success_Check_Count : Natural;
+ Total_Enqueue_Count : Natural;
Fatal_Called : Boolean;
Result : Recover_Status;
Error_ID : Ada.Exceptions.Exception_Id;
diff --git a/wisitoken-parse-lr-mckenzie_recover-explore.adb
b/wisitoken-parse-lr-mckenzie_recover-explore.adb
index 272eadf..f749cfb 100644
--- a/wisitoken-parse-lr-mckenzie_recover-explore.adb
+++ b/wisitoken-parse-lr-mckenzie_recover-explore.adb
@@ -18,6 +18,7 @@
pragma License (Modified_GPL);
with Ada.Exceptions;
+with SAL.Gen_Bounded_Definite_Queues;
with WisiToken.Parse.LR.McKenzie_Recover.Parse;
with WisiToken.Parse.LR.Parser;
package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
@@ -34,19 +35,19 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Cost_Delta : in Integer;
Strategy : in Strategies)
is
+ use Config_Op_Arrays;
McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
Op : constant Config_Op := (Insert, ID, Config.Current_Shared_Token,
State, Config.Stack.Depth);
begin
Config.Strategy_Counts (Strategy) := Config.Strategy_Counts (Strategy) +
1;
- begin
- Config.Ops.Append (Op);
- exception
- when SAL.Container_Full =>
- Super.Config_Full (Parser_Index);
+ if Is_Full (Config.Ops) then
+ Super.Config_Full ("do_shift ops", Parser_Index);
raise Bad_Config;
- end;
+ else
+ Append (Config.Ops, Op);
+ end if;
if Cost_Delta = 0 then
Config.Cost := Config.Cost + McKenzie_Param.Insert (ID);
@@ -64,7 +65,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Config.Error_Token.ID := Invalid_Token_ID;
Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
- Config.Stack.Push ((State, Syntax_Trees.Invalid_Node_Index, (ID, Virtual
=> True, others => <>)));
+ if Config.Stack.Is_Full then
+ Super.Config_Full ("do_shift stack", Parser_Index);
+ raise Bad_Config;
+ else
+ Config.Stack.Push ((State, Syntax_Trees.Invalid_Node_Index, (ID,
Virtual => True, others => <>)));
+ end if;
if Trace_McKenzie > Detail then
Base.Put
((if Label'Length > 0 then Label & ": " else "") & "insert " &
Image (ID, Super.Trace.Descriptor.all),
@@ -84,7 +90,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Action : in Reduce_Action_Rec;
Do_Language_Fixes : in Boolean := True)
is
- use all type SAL.Base_Peek_Type;
use all type Semantic_Checks.Check_Status_Label;
use all type WisiToken.Parse.LR.Parser.Language_Fixes_Access;
@@ -114,16 +119,20 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
end if;
-- Finish the reduce; ignore the check fail.
- Config.Stack.Pop (SAL.Base_Peek_Type (Config.Check_Token_Count));
+ if Config.Stack.Depth < SAL.Base_Peek_Type (Config.Check_Token_Count)
then
+ raise SAL.Programmer_Error;
+ else
+ Config.Stack.Pop (SAL.Base_Peek_Type (Config.Check_Token_Count));
+ end if;
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
+ if Config.Stack.Depth = 0 or else Config.Stack.Peek.State =
Unknown_State then
raise Bad_Config;
end if;
- New_State := Goto_For (Table, Config.Stack (1).State,
Action.Production.LHS);
+ New_State := Goto_For (Table, Config.Stack.Peek.State,
Action.Production.LHS);
if New_State = Unknown_State then
if Trace_McKenzie > Extra then
@@ -143,7 +152,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
": state" & State_Index'Image (Prev_State) & " reduce" &
Ada.Containers.Count_Type'Image (Action.Token_Count) & " to " &
Image (Action.Production.LHS, Descriptor) & ", goto" &
- State_Index'Image (New_State) & " via" & State_Index'Image
(Config.Stack (2).State));
+ State_Index'Image (New_State) & " via" & State_Index'Image
(Config.Stack.Peek (2).State));
end if;
end Do_Reduce_1;
@@ -166,7 +175,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
Orig_Config : Configuration;
Table : Parse_Table renames Shared.Table.all;
- Next_Action : Parse_Action_Node_Ptr := Action_For (Table, Config.Stack
(1).State, Inserted_ID);
+ Next_Action : Parse_Action_Node_Ptr := Action_For (Table,
Config.Stack.Peek.State, Inserted_ID);
begin
if Next_Action.Next /= null then
Orig_Config := Config;
@@ -241,10 +250,11 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
-- 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 Parse.Parse_Item_Arrays;
+ use Config_Op_Arrays;
use all type Ada.Containers.Count_Type;
- Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ Parse_Items : aliased Parse.Parse_Item_Arrays.Vector;
Dummy : Boolean := Parse.Parse
(Super, Shared, Parser_Index, Parse_Items, Config,
@@ -254,15 +264,20 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
begin
-- This solution is from Language_Fixes; any cost increase is done
there.
- if Parse_Items.Length = 1 then
+ if Length (Parse_Items) = 1 then
declare
- Item : Parse.Parse_Item renames Parse_Items (1);
+ Item : Parse.Parse_Item renames
Parse.Parse_Item_Array_Refs.Constant_Ref (Parse_Items, 1);
begin
if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
-- Item.Config.Error_Token.ID, Check_Status are correct.
Config := Item.Config;
- Config.Ops.Append ((Fast_Forward, Config.Current_Shared_Token));
+ if Is_Full (Config.Ops) then
+ Super.Config_Full ("fast_forward 1", Parser_Index);
+ return Abandon;
+ else
+ Append (Config.Ops, (Fast_Forward,
Config.Current_Shared_Token));
+ end if;
Config.Minimal_Complete_State := None;
Config.Matching_Begin_Done := False;
return Continue;
@@ -271,26 +286,32 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
end if;
end;
else
- for Item of Parse_Items loop
- if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
- Item.Config.Ops.Append ((Fast_Forward,
Item.Config.Current_Shared_Token));
- Item.Config.Minimal_Complete_State := None;
- Item.Config.Matching_Begin_Done := False;
- Local_Config_Heap.Add (Item.Config);
+ for I in First_Index (Parse_Items) .. Last_Index (Parse_Items) loop
+ declare
+ Item : Parse.Parse_Item renames
Parse.Parse_Item_Array_Refs.Variable_Ref (Parse_Items, I);
+ begin
+ if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
+ if Is_Full (Config.Ops) then
+ Super.Config_Full ("fast_forward 2", Parser_Index);
+ return Abandon;
+ else
+ Append (Item.Config.Ops, (Fast_Forward,
Item.Config.Current_Shared_Token));
+ end if;
+ Item.Config.Minimal_Complete_State := None;
+ Item.Config.Matching_Begin_Done := False;
+ Local_Config_Heap.Add (Item.Config);
- if Trace_McKenzie > Detail then
- Base.Put ("fast forward enqueue", Super, Shared,
Parser_Index, Item.Config);
+ if Trace_McKenzie > Detail then
+ Base.Put ("fast forward enqueue", Super, Shared,
Parser_Index, Item.Config);
+ end if;
end if;
- end if;
+ end;
end loop;
return Abandon;
end if;
exception
when Bad_Config =>
return Abandon;
- when SAL.Container_Full =>
- Super.Config_Full (Parser_Index);
- return Abandon;
end Fast_Forward;
function Check
@@ -301,25 +322,31 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
Local_Config_Heap : in out Config_Heaps.Heap_Type)
return Check_Status
is
+ use Config_Op_Arrays, Config_Op_Array_Refs;
+ use Parse.Parse_Item_Arrays;
use all type Semantic_Checks.Check_Status_Label;
McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
- Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ Parse_Items : aliased Parse.Parse_Item_Arrays.Vector;
Result : Check_Status := Continue;
- function Max_Push_Back_Token_Index (Ops : in Config_Op_Arrays.Vector)
return WisiToken.Base_Token_Index
+ function Max_Push_Back_Token_Index (Ops : aliased in
Config_Op_Arrays.Vector) return WisiToken.Base_Token_Index
is
Result : WisiToken.Base_Token_Index :=
WisiToken.Base_Token_Index'First;
begin
-- For Ops since last Fast_Forward, return maximum Token_Index in a
-- Push_Back. If there are no such ops, return a value that will be
-- less than the current token index.
- for Op of reverse Ops loop
- exit when Op.Op = Fast_Forward;
- if Op.Op = Push_Back and then Op.PB_Token_Index > Result then
- Result := Op.PB_Token_Index;
- end if;
+ for I in reverse First_Index (Ops) .. Last_Index (Ops) loop
+ declare
+ Op : Config_Op renames Constant_Ref (Ops, I);
+ begin
+ exit when Op.Op = Fast_Forward;
+ if Op.Op = Push_Back and then Op.PB_Token_Index > Result then
+ Result := Op.PB_Token_Index;
+ end if;
+ end;
end loop;
return Result;
end Max_Push_Back_Token_Index;
@@ -339,22 +366,22 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
-- Set Config.error to reflect failure, if it is at current token, so
-- Use_Minimal_Complete_Actions can see it.
declare
- Item : Parse.Parse_Item renames Parse_Items
(Parse_Items.First_Index);
- Parsed_Config : Configuration renames Item.Config;
+ Item : Parse.Parse_Item renames
Parse.Parse_Item_Array_Refs.Constant_Ref
+ (Parse_Items, First_Index (Parse_Items));
begin
- if Parsed_Config.Check_Status.Label /= Ok then
- Config.Check_Status := Parsed_Config.Check_Status;
- Config.Error_Token := Parsed_Config.Error_Token;
+ if Item.Config.Check_Status.Label /= Ok then
+ Config.Check_Status := Item.Config.Check_Status;
+ Config.Error_Token := Item.Config.Error_Token;
-- Explore cannot fix a check fail; only Language_Fixes can. The
-- "ignore error" case is handled immediately on return from
-- Language_Fixes in Process_One, below.
Result := Abandon;
- elsif Parsed_Config.Error_Token.ID /= Invalid_Token_ID then
+ elsif Item.Config.Error_Token.ID /= Invalid_Token_ID then
if Item.Shift_Count = 0 then
- Config.Error_Token := Parsed_Config.Error_Token;
+ Config.Error_Token := Item.Config.Error_Token;
Config.Check_Status := (Label => Ok);
else
-- Error is not at current token, but Explore might find
something
@@ -370,39 +397,41 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
-- All Parse_Items either failed or were not parsed; if they failed
-- and made progress, enqueue them so Language_Fixes can try to fix
-- them.
- for Item of Parse_Items loop
- if Item.Config.Error_Token.ID /= Invalid_Token_ID and then
- Item.Shift_Count > 0 and then
- Max_Push_Back_Token_Index (Item.Config.Ops) <
Item.Config.Current_Shared_Token - 1
- then
- -- Some progress was made; explore at the new error point. It is
- -- likely that there is only one actual error point, and this
moves
- -- away from it, so we give it a cost.
- begin
- Item.Config.Minimal_Complete_State := None;
- Item.Config.Matching_Begin_Done := False;
- if Item.Config.Ops (Item.Config.Ops.Last_Index).Op =
Fast_Forward then
-
- Item.Config.Cost := Item.Config.Cost +
McKenzie_Param.Fast_Forward;
-
- Item.Config.Ops (Item.Config.Ops.Last_Index).FF_Token_Index
:=
- Item.Config.Current_Shared_Token;
-
- else
- Item.Config.Cost := Item.Config.Cost +
McKenzie_Param.Fast_Forward;
-
- Item.Config.Ops.Append ((Fast_Forward,
Item.Config.Current_Shared_Token));
+ for I in First_Index (Parse_Items) .. Last_Index (Parse_Items) loop
+ declare
+ Item : Parse.Parse_Item renames
Parse.Parse_Item_Array_Refs.Variable_Ref (Parse_Items, I);
+ begin
+ if Item.Config.Error_Token.ID /= Invalid_Token_ID and then
+ Item.Shift_Count > 0 and then
+ Max_Push_Back_Token_Index (Item.Config.Ops) <
Item.Config.Current_Shared_Token - 1
+ then
+ -- Some progress was made; explore at the new error point. It
is
+ -- likely that there is only one actual error point, and this
moves
+ -- away from it, so we give it a cost.
+ begin
+ Item.Config.Minimal_Complete_State := None;
+ Item.Config.Matching_Begin_Done := False;
+ if Constant_Ref (Item.Config.Ops, Last_Index
(Item.Config.Ops)).Op = Fast_Forward then
+ Item.Config.Cost := Item.Config.Cost +
McKenzie_Param.Fast_Forward;
+ Variable_Ref (Item.Config.Ops, Last_Index
(Item.Config.Ops)).FF_Token_Index :=
+ Item.Config.Current_Shared_Token;
+ else
+ Item.Config.Cost := Item.Config.Cost +
McKenzie_Param.Fast_Forward;
+
+ if Is_Full (Item.Config.Ops) then
+ Super.Config_Full ("check 1", Parser_Index);
+ raise Bad_Config;
+ else
+ Append (Item.Config.Ops, (Fast_Forward,
Item.Config.Current_Shared_Token));
+ end if;
+ end if;
+ end;
+ Local_Config_Heap.Add (Item.Config);
+ if Trace_McKenzie > Detail then
+ Base.Put ("new error point ", Super, Shared, Parser_Index,
Item.Config);
end if;
- exception
- when SAL.Container_Full =>
- Super.Config_Full (Parser_Index);
- raise Bad_Config;
- end;
- Local_Config_Heap.Add (Item.Config);
- if Trace_McKenzie > Detail then
- Base.Put ("new error point ", Super, Shared, Parser_Index,
Item.Config);
end if;
- end if;
+ end;
end loop;
if Trace_McKenzie > Extra then
@@ -465,19 +494,23 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
-- loop only exits via returns above
end loop;
+ exception
+ when Bad_Config =>
+ -- From Do_Reduce_1
+ return False;
end Check_Reduce_To_Start;
procedure Try_Push_Back
(Super : not null access Base.Supervisor;
Shared : not null access Base.Shared;
Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
+ Config : in 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;
+ Token : constant Recover_Token := Config.Stack.Peek.Token;
begin
-- Try pushing back the stack top, to allow insert and other
-- operations at that point.
@@ -491,6 +524,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
-- in trying to redo it.
declare
+ use Config_Op_Arrays;
New_Config : Configuration := Config;
begin
New_Config.Error_Token.ID := Invalid_Token_ID;
@@ -498,14 +532,19 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
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));
+ if Is_Full (New_Config.Ops) then
+ Super.Config_Full ("push_back 1", Parser_Index);
+ raise Bad_Config;
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;
+ if Token.Min_Terminal_Index = Invalid_Token_Index then
+ -- Token is empty; Config.current_shared_token does not
change, no
+ -- cost increase.
+ Append (New_Config.Ops, (Push_Back, Token.ID,
New_Config.Current_Shared_Token));
+ else
+ New_Config.Cost := New_Config.Cost +
McKenzie_Param.Push_Back (Token.ID);
+ Append (New_Config.Ops, (Push_Back, Token.ID,
Token.Min_Terminal_Index));
+ New_Config.Current_Shared_Token := Token.Min_Terminal_Index;
+ end if;
end if;
New_Config.Strategy_Counts (Explore_Table) :=
New_Config.Strategy_Counts (Explore_Table) + 1;
@@ -517,25 +556,22 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
end if;
end;
end if;
- exception
- when SAL.Container_Full =>
- Super.Config_Full (Parser_Index);
end Try_Push_Back;
function Just_Pushed_Back_Or_Deleted (Config : in Configuration; ID : in
Token_ID) return Boolean
is
+ use Config_Op_Arrays, Config_Op_Array_Refs;
use all type Ada.Containers.Count_Type;
begin
- if Config.Ops.Length = 0 then
+ if Length (Config.Ops) = 0 then
return False;
else
declare
- Last_Op : Config_Op renames Config.Ops (Config.Ops.Last_Index);
+ Last_Op : Config_Op renames Constant_Ref (Config.Ops, Last_Index
(Config.Ops));
begin
- return Last_Op = (Push_Back, ID, Config.Current_Shared_Token) or
- Last_Op = (Push_Back, ID, Config.Current_Shared_Token - 1) or
- Last_Op = (Delete, ID, Config.Current_Shared_Token) or
- Last_Op = (Delete, ID, Config.Current_Shared_Token - 1);
+ return
+ (Last_Op.Op = Push_Back and then Last_Op.PB_ID = ID) or
+ (Last_Op.Op = Delete and then Last_Op.Del_ID = ID);
end;
end if;
end Just_Pushed_Back_Or_Deleted;
@@ -544,19 +580,20 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
(Super : not null access Base.Supervisor;
Shared : not null access Base.Shared;
Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
+ Config : in 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;
+ Token : constant Recover_Token := Config.Stack.Peek.Token;
begin
-- Try expanding the nonterm on the stack top, to allow pushing_back
-- its components, or insert and other operations at that point.
if Undo_Reduce_Valid (Config.Stack, Super.Parser_State
(Parser_Index).Tree) then
declare
+ use Config_Op_Arrays;
New_Config : Configuration := Config;
Token_Count : Ada.Containers.Count_Type;
begin
@@ -570,8 +607,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
New_Config.Cost := New_Config.Cost + McKenzie_Param.Undo_Reduce
(Token.ID);
end if;
- New_Config.Ops.Append ((Undo_Reduce, Token.ID, Token_Count));
-
+ if Is_Full (New_Config.Ops) then
+ Super.Config_Full ("undo_reduce 1", Parser_Index);
+ raise Bad_Config;
+ else
+ Append (New_Config.Ops, (Undo_Reduce, Token.ID, Token_Count));
+ end if;
New_Config.Strategy_Counts (Explore_Table) :=
New_Config.Strategy_Counts (Explore_Table) + 1;
Local_Config_Heap.Add (New_Config);
@@ -582,9 +623,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
end if;
end;
end if;
- exception
- when SAL.Container_Full =>
- Super.Config_Full (Parser_Index);
end Try_Undo_Reduce;
procedure Insert_From_Action_List
@@ -606,8 +644,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
-- conflicts or semantic check fails encountered, they create other
-- configs to enqueue.
- I : Action_List_Iterator := First (Table.States
(Config.Stack.Peek.State));
-
Current_Token : constant Token_ID := Current_Token_ID_Peek
(Shared.Terminals.all, Config.Current_Shared_Token,
Config.Insert_Delete, Config.Current_Insert_Delete);
@@ -616,92 +652,93 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
-- Most of the time, all the reductions in a state are the same. So
-- we cache the first result. This includes one reduction; if an
-- associated semantic check failed, this does not include the fixes.
- begin
-
- loop
- exit when I.Is_Done;
- declare
- ID : constant Token_ID := I.Symbol;
- Action : Parse_Action_Rec renames I.Action;
- begin
- if ID /= EOF_ID and then -- can't insert eof
- ID /= Invalid_Token_ID -- invalid when Verb = Error
- then
- if Just_Pushed_Back_Or_Deleted (Config, ID) then
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), "Insert:
abandon " & Image (ID, Descriptor) &
- ": undo push_back");
- end if;
- elsif ID = Current_Token then
- -- This needed because we allow explore when the error is
not at the
- -- explore point; it prevents inserting useless tokens (ie
- -- 'identifier ;' in ada_lite).
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), "Insert:
abandon " & Image (ID, Descriptor) &
- ": current token");
- end if;
+ I : Parse_Action_Node_Ptr;
+ begin
+ for Node of Table.States (Config.Stack.Peek.State).Action_List loop
+ I := Node.Actions;
+ loop
+ exit when I = null;
+ declare
+ ID : constant Token_ID := Node.Symbol;
+ Action : Parse_Action_Rec renames I.Item;
+ begin
+ if ID /= EOF_ID and then -- can't insert eof
+ ID /= Invalid_Token_ID -- invalid when Verb = Error
+ then
+ if Just_Pushed_Back_Or_Deleted (Config, ID) then
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"Insert: abandon " & Image (ID, Descriptor) &
+ ": undo push_back");
+ end if;
+ elsif ID = Current_Token then
+ -- This needed because we allow explore when the error
is not at the
+ -- explore point; it prevents inserting useless tokens
(ie
+ -- 'identifier ;' in ada_lite).
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"Insert: abandon " & Image (ID, Descriptor) &
+ ": current token");
+ end if;
- elsif (for some Minimal of Minimal_Insert => ID = Minimal) then
- -- Was inserted by Insert_Minimal_Complete_Actions
- null;
+ elsif (for some Minimal of Minimal_Insert => ID = Minimal)
then
+ -- Was inserted by Insert_Minimal_Complete_Actions
+ null;
- else
- case Action.Verb is
- when Shift =>
- declare
- New_Config : Configuration := Config;
- begin
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- Do_Shift
- ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action.State, ID,
- Cost_Delta => 0,
- Strategy => Explore_Table);
- end;
-
- when Reduce =>
- if not Equal (Action, Cached_Action) then
+ else
+ case Action.Verb is
+ when Shift =>
declare
New_Config : Configuration := Config;
begin
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- Do_Reduce_1 ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action);
- Cached_Config := New_Config;
- Cached_Action := Action;
-
- Do_Reduce_2
- ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
+ Do_Shift
+ ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action.State, ID,
Cost_Delta => 0,
Strategy => Explore_Table);
end;
- else
- declare
- New_Config : Configuration := Cached_Config;
- begin
- Do_Reduce_2
- ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
- Cost_Delta => 0,
- Strategy => Explore_Table);
- end;
- end if;
+ when Reduce =>
+ if not Equal (Action, Cached_Action) then
+ declare
+ New_Config : Configuration := Config;
+ begin
+ New_Config.Error_Token.ID := Invalid_Token_ID;
+ New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ Do_Reduce_1
+ ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action);
+ Cached_Config := New_Config;
+ Cached_Action := Action;
+
+ Do_Reduce_2
+ ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
+ Cost_Delta => 0,
+ Strategy => Explore_Table);
+ end;
+
+ else
+ declare
+ New_Config : Configuration := Cached_Config;
+ begin
+ Do_Reduce_2
+ ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
+ Cost_Delta => 0,
+ Strategy => Explore_Table);
+ end;
+ end if;
- when Accept_It =>
- raise SAL.Programmer_Error with "found test case for
Process_One Accept_It";
+ when Accept_It =>
+ raise SAL.Programmer_Error with "found test case for
Process_One Accept_It";
- when Error =>
- null;
- end case;
+ when Error =>
+ null;
+ end case;
+ end if;
end if;
- end if;
- end;
- I.Next;
+ end;
+ I := I.Next;
+ end loop;
end loop;
end Insert_From_Action_List;
@@ -714,7 +751,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
return Token_ID_Arrays.Vector
-- Return tokens inserted (empty if none).
is
- use all type SAL.Base_Peek_Type;
use Ada.Containers;
Table : Parse_Table renames Shared.Table.all;
@@ -727,32 +763,42 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
Config : Configuration;
end record;
- package Item_Queues is new SAL.Gen_Unbounded_Definite_Queues (Work_Item);
+ package Item_Queues is new SAL.Gen_Bounded_Definite_Queues (Work_Item);
+ use Item_Queues;
- Work : Item_Queues.Queue;
+ Work : Queue_Type (10);
+ -- The required queue size depends on the number of multiple-item
+ -- Minimal_Complete_Actions encountered. That is limited by compound
+ -- statement nesting, and by the frequency of such actions.
function To_Reduce_Action (Action : in Minimal_Action) return
Reduce_Action_Rec
is (Reduce, (Action.Nonterm, 0), null, null, Action.Token_Count);
procedure Minimal_Do_Shift (Action : in Minimal_Action; Config : in out
Configuration)
- is begin
+ is
+ use Config_Op_Arrays, Config_Op_Array_Refs;
+ begin
-- Check for a cycle. We compare stack depth as well as state, so
-- nested compound statements don't look like a cycle; see
-- test_mckenzie_recover Push_Back_1. We don't check for cycles in
-- Insert_From_Action_List because we assume cost eliminates cycles
-- there; Minimal_Complete_Delta is usually negative, so cost does
-- not necessarily increase here.
- for Op of reverse Config.Ops loop
- if Op.Op = Insert and then
- (Op.Ins_ID = Action.ID and Op.State = Action.State and
Op.Stack_Depth = Config.Stack.Depth)
- then
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: abandon " &
- Image (Action.ID, Descriptor) & Action.State'Image & ":
cycle");
+ for I in reverse First_Index (Config.Ops) .. Last_Index (Config.Ops)
loop
+ declare
+ Op : Config_Op renames Constant_Ref (Config.Ops, I);
+ begin
+ if Op.Op = Insert and then
+ (Op.Ins_ID = Action.ID and Op.State = Action.State and
Op.Stack_Depth = Config.Stack.Depth)
+ then
+ if Trace_McKenzie > Extra then
+ Put_Line
+ (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: abandon " &
+ Image (Action.ID, Descriptor) & Action.State'Image &
": cycle");
+ end if;
+ return;
end if;
- return;
- end if;
+ end;
end loop;
-- We don't check Action.ID = Current_Token; the error is at the
@@ -804,7 +850,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
return;
elsif Actions.Length = 1 then
if (not Reduce_Only) or Actions (Actions.First_Index).Verb =
Reduce then
- Work.Add ((Actions (Actions.First_Index), Config));
+ if Is_Full (Work) then
+ Super.Config_Full ("Minimal_Complete_Actions 1",
Parser_Index);
+ raise Bad_Config;
+ else
+ Add (Work, (Actions (Actions.First_Index), Config));
+ end if;
end if;
return;
end if;
@@ -848,7 +899,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
for I in Length'Range loop
if (Use_Recursive and Item_Not_Recursive (I)) or ((not
Use_Recursive) and Length (I) = Min_Length) then
- Work.Add ((Actions (I), Config));
+ if Is_Full (Work) then
+ Super.Config_Full ("Minimal_Complete_Actions 2",
Parser_Index);
+ raise Bad_Config;
+ else
+ Add (Work, (Actions (I), Config));
+ end if;
elsif Trace_McKenzie > Extra then
Put_Line
(Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: drop " &
@@ -878,10 +934,10 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
Orig_Config, Reduce_Only => False);
loop
- exit when Work.Is_Empty;
+ exit when Is_Empty (Work);
declare
- Item : Work_Item := Work.Get;
+ Item : Work_Item := Get (Work);
begin
if Trace_McKenzie > Extra then
Put_Line
@@ -976,7 +1032,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
return;
end if;
- -- Set up for Parse
declare
New_Config : Configuration := Config;
begin
@@ -985,41 +1040,46 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
end loop;
declare
- use all type SAL.Base_Peek_Type;
- Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ use Parse.Parse_Item_Arrays;
+ Parse_Items : aliased Parse.Parse_Item_Arrays.Vector;
Dummy : constant Boolean := Parse.Parse
(Super, Shared, Parser_Index, Parse_Items, New_Config,
Shared_Token_Goal => Invalid_Token_Index,
All_Conflicts => True,
Trace_Prefix => "parse Matching_Begin");
begin
- for Item of Parse_Items loop
- if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
- Item.Config.Matching_Begin_Done := True;
- Item.Config.Cost := Item.Config.Cost +
Table.McKenzie_Param.Matching_Begin;
- Item.Config.Strategy_Counts (Matching_Begin) :=
Item.Config.Strategy_Counts (Matching_Begin) + 1;
- Item.Config.Error_Token.ID := Invalid_Token_ID;
- Item.Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- if Trace_McKenzie > Detail then
- Base.Put
- ("Matching_Begin: insert " & Image
(Matching_Begin_Tokens, Descriptor),
- Super, Shared, Parser_Index, Item.Config);
- end if;
- Local_Config_Heap.Add (Item.Config);
- else
- if Trace_McKenzie > Detail then
- Base.Put
- ("Matching_Begin: abandon " & Image
(Matching_Begin_Tokens, Descriptor) & ": parse fail",
- Super, Shared, Parser_Index, Item.Config);
+ for I in First_Index (Parse_Items) .. Last_Index (Parse_Items) loop
+ declare
+ Item : Parse.Parse_Item renames
Parse.Parse_Item_Array_Refs.Variable_Ref (Parse_Items, I);
+ begin
+ if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
+ Item.Config.Matching_Begin_Done := True;
+ Item.Config.Cost := Item.Config.Cost +
Table.McKenzie_Param.Matching_Begin;
+ Item.Config.Strategy_Counts (Matching_Begin) :=
Item.Config.Strategy_Counts (Matching_Begin) + 1;
+ Item.Config.Error_Token.ID := Invalid_Token_ID;
+ Item.Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
+
+ if Trace_McKenzie > Detail then
+ Base.Put
+ ("Matching_Begin: insert " & Image
(Matching_Begin_Tokens, Descriptor),
+ Super, Shared, Parser_Index, Item.Config);
+ end if;
+ Local_Config_Heap.Add (Item.Config);
+ else
+ if Trace_McKenzie > Detail then
+ Base.Put
+ ("Matching_Begin: abandon " & Image
(Matching_Begin_Tokens, Descriptor) & ": parse fail",
+ Super, Shared, Parser_Index, Item.Config);
+ end if;
end if;
- end if;
+ end;
end loop;
end;
end;
exception
when SAL.Container_Full =>
- Super.Config_Full (Parser_Index);
+ -- From config_ops_sorted
+ Super.Config_Full ("Minimal_Complete_Actions 3", Parser_Index);
end Insert_Matching_Begin;
procedure Try_Insert_Terminal
@@ -1083,6 +1143,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
Config : in out Configuration;
Local_Config_Heap : in out Config_Heaps.Heap_Type)
is
+ use Config_Op_Arrays;
use all type Parser.Language_String_ID_Set_Access;
Descriptor : WisiToken.Descriptor renames Shared.Trace.Descriptor.all;
@@ -1116,22 +1177,29 @@ package body
WisiToken.Parse.LR.McKenzie_Recover.Explore is
end String_ID_Set;
procedure String_Literal_In_Stack
- (New_Config : in out Configuration;
+ (Label : in String;
+ New_Config : in out Configuration;
Matching : in SAL.Peek_Type;
String_Literal_ID : in Token_ID)
is
+ use Parse.Parse_Item_Arrays;
+
Saved_Shared_Token : constant WisiToken.Token_Index :=
New_Config.Current_Shared_Token;
Tok : Recover_Token;
J : WisiToken.Token_Index;
- Parse_Items : Parse.Parse_Item_Arrays.Vector;
+ Parse_Items : aliased 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.
+ if not Has_Space (New_Config.Ops, Ada.Containers.Count_Type
(Matching)) then
+ Super.Config_Full ("insert quote 1 " & Label, Parser_Index);
+ raise Bad_Config;
+ end if;
for I in 1 .. Matching loop
Tok := New_Config.Stack.Pop.Token;
- New_Config.Ops.Append ((Push_Back, Tok.ID,
Tok.Min_Terminal_Index));
+ Append (New_Config.Ops, (Push_Back, Tok.ID,
Tok.Min_Terminal_Index));
end loop;
New_Config.Current_Shared_Token := Tok.Min_Terminal_Index;
@@ -1148,12 +1216,12 @@ package body
WisiToken.Parse.LR.McKenzie_Recover.Explore is
(Super, Shared, Parser_Index, Parse_Items, New_Config,
Shared_Token_Goal => J,
All_Conflicts => False,
- Trace_Prefix => "insert quote parse pushback")
+ Trace_Prefix => "insert quote parse pushback " & Label)
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));
+ New_Config := Parse.Parse_Item_Array_Refs.Constant_Ref
(Parse_Items, 1).Config;
+ Append (New_Config.Ops, (Fast_Forward,
New_Config.Current_Shared_Token));
else
raise SAL.Programmer_Error;
end if;
@@ -1161,11 +1229,16 @@ package body
WisiToken.Parse.LR.McKenzie_Recover.Explore is
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;
+
+ if not Has_Space
+ (New_Config.Ops, Ada.Containers.Count_Type (Saved_Shared_Token - 1
- New_Config.Current_Shared_Token))
+ then
+ Super.Config_Full ("insert quote 2 " & Label, Parser_Index);
+ raise Bad_Config;
+ end if;
+
+ for J in New_Config.Current_Shared_Token .. Saved_Shared_Token - 1
loop
+ Append (New_Config.Ops, (Delete, Shared.Terminals.all (J).ID, J));
end loop;
New_Config.Current_Shared_Token := Saved_Shared_Token;
@@ -1186,13 +1259,18 @@ package body
WisiToken.Parse.LR.McKenzie_Recover.Explore is
-- This is a guess, so we give it a nominal cost
New_Config.Cost := New_Config.Cost + 1;
+ if not Has_Space (New_Config.Ops, Ada.Containers.Count_Type (Last -
First)) then
+ Super.Config_Full ("insert quote 3 " & Label, Parser_Index);
+ raise Bad_Config;
+ end if;
+
for I in First .. Last loop
- New_Config.Ops.Append ((Delete, Shared.Terminals.all (I).ID, I));
+ Append (New_Config.Ops, (Delete, Shared.Terminals.all (I).ID, I));
end loop;
New_Config.Current_Shared_Token := Last + 1;
-- Let explore do insert after these deletes.
- New_Config.Ops.Append ((Fast_Forward,
New_Config.Current_Shared_Token));
+ Append (New_Config.Ops, (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;
@@ -1206,12 +1284,8 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
New_Config.Strategy_Counts (String_Quote) :=
New_Config.Strategy_Counts (String_Quote) + 1;
if Trace_McKenzie > Detail then
- Base.Put ("insert missing quote " & Label & " ", Super, Shared,
Parser_Index, New_Config);
+ Base.Put ("insert quote " & Label & " ", Super, Shared,
Parser_Index, New_Config);
end if;
- exception
- when SAL.Container_Full =>
- Super.Config_Full (Parser_Index);
- raise Bad_Config;
end Finish;
begin
@@ -1263,7 +1337,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
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));
+ if Is_Full (New_Config.Ops) then
+ Super.Config_Full ("insert quote 4 a", Parser_Index);
+ raise Bad_Config;
+ else
+ Append (New_Config.Ops, (Push_Back, Token.ID,
Token.Min_Terminal_Index));
+ end if;
exit;
end if;
end loop;
@@ -1289,7 +1368,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
-- stack.
declare
- use all type SAL.Base_Peek_Type;
Matching : SAL.Peek_Type := 1;
begin
Find_Descendant_ID
@@ -1301,7 +1379,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
-- 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");
+ (Super.Trace.all, Super.Label (Parser_Index), "insert
quote b abandon; string literal in virtual");
end if;
return;
end if;
@@ -1309,7 +1387,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
declare
New_Config : Configuration := Config;
begin
- String_Literal_In_Stack (New_Config, Matching,
Lexer_Error_Token.ID);
+ String_Literal_In_Stack ("b", New_Config, Matching,
Lexer_Error_Token.ID);
Finish
("b", New_Config, Config.Current_Shared_Token,
Shared.Line_Begin_Token.all (Current_Line + 1) - 1);
@@ -1342,7 +1420,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
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));
+ if Is_Full (New_Config.Ops) then
+ Super.Config_Full ("insert quote 5 d", Parser_Index);
+ raise Bad_Config;
+ else
+ Append (New_Config.Ops, (Push_Back, Token.ID,
Token.Min_Terminal_Index));
+ end if;
exit;
end if;
end loop;
@@ -1362,7 +1445,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
-- 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.
@@ -1377,7 +1459,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
declare
New_Config : Configuration := Config;
begin
- String_Literal_In_Stack (New_Config, Matching,
Lexer_Error_Token.ID);
+ String_Literal_In_Stack ("e", 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);
@@ -1386,9 +1468,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
end;
end if;
exception
- when SAL.Container_Full =>
- Super.Config_Full (Parser_Index);
-
when Bad_Config =>
null;
end Try_Insert_Quote;
@@ -1397,11 +1476,12 @@ package body
WisiToken.Parse.LR.McKenzie_Recover.Explore is
(Super : not null access Base.Supervisor;
Shared : not null access Base.Shared;
Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
+ Config : in Configuration;
Local_Config_Heap : in out Config_Heaps.Heap_Type)
is
-- Try deleting (= skipping) the current shared input token.
+ use Config_Op_Arrays, Config_Op_Array_Refs;
use all type Ada.Containers.Count_Type;
Trace : WisiToken.Trace'Class renames Super.Trace.all;
EOF_ID : Token_ID renames Trace.Descriptor.EOI_ID;
@@ -1413,20 +1493,25 @@ package body
WisiToken.Parse.LR.McKenzie_Recover.Explore is
begin
if ID /= EOF_ID and then
-- can't delete EOF
- (Config.Ops.Length = 0 or else
+ (Length (Config.Ops) = 0 or else
-- Don't delete an ID we just inserted; waste of time
- (not Equal (Config.Ops (Config.Ops.Last_Index), (Insert, ID,
Config.Current_Shared_Token, 1, 0))))
+ (not Equal (Constant_Ref (Config.Ops, Last_Index (Config.Ops)),
+ (Insert, ID, Config.Current_Shared_Token, 1, 0))))
then
declare
New_Config : Configuration := Config;
function Matching_Push_Back return Boolean
is begin
- for Op of reverse New_Config.Ops loop
- exit when not (Op.Op in Undo_Reduce | Push_Back | Delete);
- if Op = (Push_Back, ID, New_Config.Current_Shared_Token) then
- return True;
- end if;
+ for I in reverse First_Index (New_Config.Ops) .. Last_Index
(New_Config.Ops) loop
+ declare
+ Op : Config_Op renames Config_Op_Array_Refs.Variable_Ref
(New_Config.Ops, I).Element.all;
+ begin
+ exit when not (Op.Op in Undo_Reduce | Push_Back | Delete);
+ if Op = (Push_Back, ID, New_Config.Current_Shared_Token)
then
+ return True;
+ end if;
+ end;
end loop;
return False;
end Matching_Push_Back;
@@ -1443,7 +1528,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
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));
+ if Is_Full (New_Config.Ops) then
+ Super.Config_Full ("delete", Parser_Index);
+ raise Bad_Config;
+ else
+ Append (New_Config.Ops, (Delete, ID,
Config.Current_Shared_Token));
+ end if;
New_Config.Current_Shared_Token := New_Config.Current_Shared_Token
+ 1;
loop
exit when not Super.Parser_State
(Parser_Index).Prev_Deleted.Contains (New_Config.Current_Shared_Token);
@@ -1462,9 +1552,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
end if;
end;
end if;
- exception
- when SAL.Container_Full =>
- Super.Config_Full (Parser_Index);
end Try_Delete_Input;
procedure Process_One
@@ -1477,7 +1564,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
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;
@@ -1561,7 +1647,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
-- 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);
+ New_State := Goto_For (Table, Config.Stack.Peek.State,
Config.Error_Token.ID);
if New_State = Unknown_State then
if Config.Stack.Depth = 1 then
@@ -1572,7 +1658,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
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
+ Trimmed_Image (Config.Stack.Peek.State) & " nonterm
" & Image
(Config.Error_Token.ID, Trace.Descriptor.all);
end if;
end if;
@@ -1621,6 +1707,8 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
--
-- All possible permutations will be explored.
+ pragma Assert (Config.Stack.Depth > 0);
+
Try_Insert_Terminal (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
if None_Since_FF (Config.Ops, Delete) and then
@@ -1652,9 +1740,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Explore
is
Super.Put (Parser_Index, Local_Config_Heap);
exception
- when E : others =>
+ when Bad_Config =>
-- Just abandon this config; tell Super we are done.
Super.Put (Parser_Index, Local_Config_Heap);
+
+ when E : others =>
+ Super.Put (Parser_Index, Local_Config_Heap);
if Debug_Mode then
raise;
elsif Trace_McKenzie > Outline then
diff --git a/wisitoken-parse-lr-mckenzie_recover-parse.adb
b/wisitoken-parse-lr-mckenzie_recover-parse.adb
index 963cf1a..5db933e 100644
--- a/wisitoken-parse-lr-mckenzie_recover-parse.adb
+++ b/wisitoken-parse-lr-mckenzie_recover-parse.adb
@@ -26,8 +26,6 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
Nonterm : out Recover_Token;
Default_Virtual : in Boolean)
is
- use all type SAL.Base_Peek_Type;
-
Min_Terminal_Index_Set : Boolean := False;
begin
Nonterm :=
@@ -36,7 +34,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
others => <>);
for I in Tokens'Range loop
- Tokens (I) := Stack (Tokens'Last - I + 1).Token;
+ Tokens (I) := Stack.Peek (Tokens'Last - I + 1).Token;
end loop;
for T of Tokens loop
@@ -67,13 +65,13 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
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
+ pragma Assert (Stack.Depth > Last);
Compute_Nonterm (Action.Production.LHS, Stack, Tokens, Nonterm,
Default_Virtual);
if Action.Check = null then
@@ -92,13 +90,13 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
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)
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Parse_Items : aliased 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
@@ -111,15 +109,16 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
-- If any actions have conflicts, append the conflict configs and
actions to
-- Parse_Items.
+ use Parse_Item_Arrays;
+ use Sorted_Insert_Delete_Arrays;
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);
+ Item : Parse_Item renames Parse_Item_Array_Refs.Variable_Ref
(Parse_Items, Parse_Item_Index).Element.all;
Config : Configuration renames Item.Config;
Action : Parse_Action_Node_Ptr renames Item.Action;
@@ -142,7 +141,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
if Trace_McKenzie > Extra then
if Config.Current_Insert_Delete /= No_Insert_Delete then
Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
Insert_Delete: " &
- Image (Insert_Delete_Arrays.Vector
(Config.Insert_Delete), Trace.Descriptor.all));
+ Image (Config.Insert_Delete, Trace.Descriptor.all));
end if;
end if;
@@ -156,14 +155,14 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
Item.Parsed := True;
if Action = null then
- Action := Action_For (Table, Config.Stack (1).State,
Current_Token.ID);
+ Action := Action_For (Table, Config.Stack.Peek.State,
Current_Token.ID);
end if;
loop
Conflict := Action.Next;
loop
exit when Conflict = null;
- if Parse_Items.Is_Full then
+ if Is_Full (Parse_Items) then
if Trace_McKenzie > Outline then
Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix &
": too many conflicts; abandoning");
end if;
@@ -180,7 +179,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
Image (Conflict.Item, Descriptor));
end if;
- Parse_Items.Append ((New_Config, Conflict, Parsed => False,
Shift_Count => Item.Shift_Count));
+ Append (Parse_Items, (New_Config, Conflict, Parsed => False,
Shift_Count => Item.Shift_Count));
end;
end if;
Conflict := Conflict.Next;
@@ -193,7 +192,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
":" & Image (Current_Token, Descriptor) &
" : " & Image (Action.Item, Descriptor) &
(if Action.Item.Verb = Reduce
- then " via" & Config.Stack (SAL.Peek_Type
(Action.Item.Token_Count + 1)).State'Image
+ then " via" & Config.Stack.Peek (SAL.Peek_Type
(Action.Item.Token_Count + 1)).State'Image
else ""));
end if;
@@ -269,10 +268,10 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
exit when not Success or
Action.Item.Verb = Accept_It or
(if Shared_Token_Goal = Invalid_Token_Index
- then Config.Insert_Delete.Length = 0
+ then Length (Config.Insert_Delete) = 0
else Config.Current_Shared_Token > Shared_Token_Goal);
- Action := Action_For (Table, Config.Stack (1).State,
Current_Token.ID);
+ Action := Action_For (Table, Config.Stack.Peek.State,
Current_Token.ID);
end loop;
Config.Current_Shared_Token := Restore_Terminals_Current;
@@ -281,35 +280,41 @@ package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
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)
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Parse_Items : aliased 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
+ use Parse_Item_Arrays;
Trace : WisiToken.Trace'Class renames Super.Trace.all;
Last_Parsed : Natural;
Success : Boolean;
begin
- Parse_Items.Clear;
- Parse_Items.Append ((Config, Action => null, Parsed => False,
Shift_Count => 0));
+ Clear (Parse_Items);
+ Append (Parse_Items, (Config, Action => null, Parsed => False,
Shift_Count => 0));
-- Clear any errors; so they reflect the parse result.
- Parse_Items (Parse_Items.First_Index).Config.Error_Token.ID :=
Invalid_Token_ID;
- Parse_Items (Parse_Items.First_Index).Config.Check_Status := (Label =>
Semantic_Checks.Ok);
-
- Last_Parsed := Parse_Items.First_Index;
+ declare
+ Config : Configuration renames Parse_Item_Array_Refs.Variable_Ref
+ (Parse_Items, First_Index (Parse_Items)).Config;
+ begin
+ Config.Error_Token.ID := Invalid_Token_ID;
+ Config.Check_Status := (Label => Semantic_Checks.Ok);
+ end;
+
+ Last_Parsed := First_Index (Parse_Items);
loop
-- Loop over initial config and any conflicts.
Success := Parse_One_Item
(Super, Shared, Parser_Index, Parse_Items, Last_Parsed,
Shared_Token_Goal, Trace_Prefix);
- exit when Parse_Items.Last_Index = Last_Parsed;
+ exit when Last_Index (Parse_Items) = Last_Parsed;
exit when Success and not All_Conflicts;
diff --git a/wisitoken-parse-lr-mckenzie_recover-parse.ads
b/wisitoken-parse-lr-mckenzie_recover-parse.ads
index e5e4d36..abd8946 100644
--- a/wisitoken-parse-lr-mckenzie_recover-parse.ads
+++ b/wisitoken-parse-lr-mckenzie_recover-parse.ads
@@ -17,6 +17,7 @@
pragma License (Modified_GPL);
+with SAL.Gen_Bounded_Definite_Vectors.Gen_Refs;
with WisiToken.Parse.LR.McKenzie_Recover.Base;
private package WisiToken.Parse.LR.McKenzie_Recover.Parse is
@@ -53,15 +54,17 @@ private package WisiToken.Parse.LR.McKenzie_Recover.Parse is
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
+ package Parse_Item_Array_Refs is new Parse_Item_Arrays.Gen_Refs;
+
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)
+ (Super : not null access Base.Supervisor;
+ Shared : not null access Base.Shared;
+ Parser_Index : in SAL.Peek_Type;
+ Parse_Items : aliased out Parse_Item_Arrays.Vector;
+ Config : in Configuration;
+ Shared_Token_Goal : in Base_Token_Index;
+ All_Conflicts : in Boolean;
+ Trace_Prefix : in String)
return Boolean;
-- Attempt to parse Config and any conflict configs. If not
-- All_Conflicts, return when Config.Insert_Delete is all processed,
diff --git a/wisitoken-parse-lr-mckenzie_recover.adb
b/wisitoken-parse-lr-mckenzie_recover.adb
index 49c2106..c53f0ef 100644
--- a/wisitoken-parse-lr-mckenzie_recover.adb
+++ b/wisitoken-parse-lr-mckenzie_recover.adb
@@ -91,25 +91,25 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- problem, and would mean a task that terminates due to an exception
-- is never restarted.
- function To_Recover
- (Parser_Stack : in Parser_Lists.Parser_Stacks.Stack;
- Tree : in Syntax_Trees.Tree)
- return Recover_Stacks.Stack
+ procedure To_Recover
+ (Parser_Stack : in Parser_Lists.Parser_Stacks.Stack;
+ Tree : in Syntax_Trees.Tree;
+ Stack : in out Recover_Stacks.Stack)
is
- use all type SAL.Base_Peek_Type;
- Result : Recover_Stacks.Stack;
- Depth : constant SAL.Peek_Type := Parser_Stack.Depth;
+ Depth : constant SAL.Peek_Type := Parser_Stack.Depth;
begin
- Result.Set_Depth (Depth);
- for I in 1 .. Depth loop
+ pragma Assert (Stack.Depth = 0);
+ if Stack.Size < Depth then
+ raise SAL.Programmer_Error with "recover stack needs more space;" &
Depth'Image;
+ end if;
+ for I in reverse 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));
+ Stack.Push ((Item.State, Item.Token, Token));
end;
end loop;
- return Result;
end To_Recover;
procedure Recover_Init
@@ -119,7 +119,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover 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 => <>));
+ Config : Configuration;
Error : Parse_Error renames Parser_State.Errors
(Parser_State.Errors.Last);
begin
Parser_State.Recover.Enqueue_Count := Parser_State.Recover.Enqueue_Count
+ 1;
@@ -148,7 +148,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- Additional initialization of Parser_State.Recover is done in
-- Supervisor.Initialize.
- Config.Stack := To_Recover (Parser_State.Stack, Parser_State.Tree);
+ To_Recover (Parser_State.Stack, Parser_State.Tree, Config.Stack);
-- Parser_State.Recover_Insert_Delete must be empty (else we would not
get
-- here). Therefore Parser_State current token is in
@@ -160,7 +160,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover 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,
+ Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config,
Task_ID => False);
end if;
@@ -168,7 +168,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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,
+ Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config,
Task_ID => False);
end if;
@@ -179,15 +179,15 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- solution; see McKenzie_Recover.Explore Process_One.
Config.Check_Status := Error.Check_Status;
- Config.Error_Token := Config.Stack (1).Token;
+ Config.Error_Token := Config.Stack.Peek.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));
+ Config_Op_Arrays.Append (Config.Ops, (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);
+ Shared_Parser.Terminals, Config, Task_ID => False);
end if;
end if;
@@ -196,12 +196,13 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- recovery.
raise SAL.Programmer_Error;
end case;
+
+ Parser_State.Recover.Config_Heap.Add (Config);
end Recover_Init;
function Recover (Shared_Parser : in out LR.Parser.Parser) return
Recover_Status
is
use all type Parser.Post_Recover_Access;
- use all type SAL.Base_Peek_Type;
Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
Parsers : Parser_Lists.List renames Shared_Parser.Parsers;
@@ -302,6 +303,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- the same check here is premature optimization.
declare
use Parser_Lists;
+
Cur : Cursor := Parsers.First;
Solutions : SAL.Base_Peek_Type := 0;
Spawn_Limit : SAL.Base_Peek_Type := Shared_Parser.Max_Parallel; --
per parser
@@ -357,6 +359,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
Trace.Put_Line
(Integer'Image (Cur.Label) &
": fail, enqueue" & Integer'Image
(Data.Enqueue_Count) &
+ (if Data.Config_Full_Count > 0 then ", config_full"
& Data.Config_Full_Count'Image else "") &
", check " & Integer'Image (Data.Check_Count) &
", max shared_token " & WisiToken.Token_Index'Image
(Shared_Parser.Terminals.Last_Index));
end if;
@@ -381,6 +384,8 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- Can't have active 'renames State_Ref' when terminate a
parser
declare
use Parser_Lists;
+ use Config_Op_Arrays, Config_Op_Array_Refs;
+ use Sorted_Insert_Delete_Arrays;
Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
@@ -396,7 +401,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
Shared_Token_Changed : Boolean := False;
Current_Token_Virtual : Boolean := False;
- Sorted_Insert_Delete : Sorted_Insert_Delete_Arrays.Vector;
+ Sorted_Insert_Delete : aliased
Sorted_Insert_Delete_Arrays.Vector;
procedure Apply_Prev_Token
is begin
@@ -467,163 +472,187 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- 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;
+ for I in First_Index (Result.Ops) .. Last_Index (Result.Ops)
loop
+ declare
+ Op : Config_Op renames Constant_Ref (Result.Ops, I);
+ begin
+ 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 Undo_Reduce =>
+ null;
- when Push_Back =>
- if Op.PB_Token_Index /= Invalid_Token_Index then
- if Op.PB_Token_Index < Min_Op_Token_Index then
- Min_Op_Token_Index := Op.PB_Token_Index;
- end if;
- if Op.PB_Token_Index < Min_Push_Back_Token_Index
then
- Min_Push_Back_Token_Index := Op.PB_Token_Index;
+ when Push_Back =>
+ if Op.PB_Token_Index /= Invalid_Token_Index then
+ if Op.PB_Token_Index < Min_Op_Token_Index then
+ Min_Op_Token_Index := Op.PB_Token_Index;
+ end if;
+ if Op.PB_Token_Index < Min_Push_Back_Token_Index
then
+ Min_Push_Back_Token_Index :=
Op.PB_Token_Index;
+ end if;
end if;
- end if;
- when Insert =>
- if Op.Ins_Token_Index /= Invalid_Token_Index then
- if Op.Ins_Token_Index < Min_Op_Token_Index then
- Min_Op_Token_Index := Op.Ins_Token_Index;
- end if;
- if Op.Ins_Token_Index < Min_Push_Back_Token_Index
then
- Min_Push_Back_Token_Index := Op.Ins_Token_Index;
+ when Insert =>
+ if Op.Ins_Token_Index /= Invalid_Token_Index then
+ if Op.Ins_Token_Index < Min_Op_Token_Index then
+ Min_Op_Token_Index := Op.Ins_Token_Index;
+ end if;
+ if Op.Ins_Token_Index <
Min_Push_Back_Token_Index then
+ Min_Push_Back_Token_Index :=
Op.Ins_Token_Index;
+ end if;
end if;
- end if;
- when Delete =>
- if Op.Del_Token_Index /= Invalid_Token_Index then
- if Op.Del_Token_Index < Min_Op_Token_Index then
- Min_Op_Token_Index := Op.Del_Token_Index;
- end if;
- if Op.Del_Token_Index < Min_Push_Back_Token_Index
then
- Min_Push_Back_Token_Index := Op.Del_Token_Index;
+ when Delete =>
+ if Op.Del_Token_Index /= Invalid_Token_Index then
+ if Op.Del_Token_Index < Min_Op_Token_Index then
+ Min_Op_Token_Index := Op.Del_Token_Index;
+ end if;
+ if Op.Del_Token_Index <
Min_Push_Back_Token_Index then
+ Min_Push_Back_Token_Index :=
Op.Del_Token_Index;
+ end if;
end if;
- end if;
- end case;
+ end case;
+ end;
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;
+ for I in First_Index (Result.Ops) .. Last_Index (Result.Ops)
loop
+ declare
+ Op : Config_Op renames Constant_Ref (Result.Ops, I);
+ begin
+ case Op.Op is
+ when Fast_Forward =>
+ Stack_Matches_Ops := False;
- declare
- Item : constant Parser_Lists.Parser_Stack_Item :=
Parser_State.Stack.Pop;
- begin
- case Tree.Label (Item.Token) is
- when Syntax_Trees.Shared_Terminal |
- Syntax_Trees.Virtual_Identifier |
- Syntax_Trees.Virtual_Terminal =>
+ when Undo_Reduce =>
+ if not Stack_Matches_Ops then
if Trace_McKenzie > Outline then
Put_Line
- (Trace, Parser_State.Label, "expecting
nonterminal, found " &
- Image (Tree.ID (Item.Token),
Trace.Descriptor.all),
+ (Trace, Parser_State.Label, "Undo_Reduce
after insert or fast_forward",
Task_ID => False);
end if;
raise Bad_Config;
-
- when Syntax_Trees.Nonterm =>
- for C of Tree.Children (Item.Token) loop
- Parser_State.Stack.Push ((Tree.State (C), C));
- end loop;
- end case;
- end;
-
- when Push_Back =>
- if Stack_Matches_Ops then
- Parser_State.Stack.Pop;
- if Op.PB_Token_Index /= Invalid_Token_Index then
- Parser_State.Shared_Token := Op.PB_Token_Index;
- Shared_Token_Changed := True;
end if;
- elsif Op.PB_Token_Index = Min_Op_Token_Index then
- loop
- -- Multiple push_backs can have the same
Op.PB_Token_Index, so we may
- -- already be at the target.
- exit when Parser_State.Shared_Token <=
Op.PB_Token_Index and
- (Parser_State.Stack.Depth = 1 or else
- Tree.Min_Terminal_Index (Parser_State.Stack
(1).Token) /= Invalid_Token_Index);
- -- also push back empty tokens.
-
- declare
- Item : constant
Parser_Lists.Parser_Stack_Item := Parser_State.Stack.Pop;
-
- Min_Index : constant Base_Token_Index :=
- Parser_State.Tree.Min_Terminal_Index
(Item.Token);
- begin
- if Min_Index /= Invalid_Token_Index then
- Shared_Token_Changed := True;
- Parser_State.Shared_Token := Min_Index;
+ declare
+ Item : constant Parser_Lists.Parser_Stack_Item
:= Parser_State.Stack.Pop;
+ begin
+ case Tree.Label (Item.Token) is
+ when Syntax_Trees.Shared_Terminal |
+ Syntax_Trees.Virtual_Identifier |
+ Syntax_Trees.Virtual_Terminal =>
+ if Trace_McKenzie > Outline then
+ Put_Line
+ (Trace, Parser_State.Label, "expecting
nonterminal, found " &
+ Image (Tree.ID (Item.Token),
Trace.Descriptor.all),
+ Task_ID => False);
end if;
- end;
- end loop;
- pragma Assert (Parser_State.Shared_Token =
Op.PB_Token_Index);
- end if;
+ raise Bad_Config;
+
+ when Syntax_Trees.Nonterm =>
+ for C of Tree.Children (Item.Token) loop
+ Parser_State.Stack.Push ((Tree.State (C),
C));
+ end loop;
+ end case;
+ end;
+
+ when Push_Back =>
+ if Stack_Matches_Ops then
+ Parser_State.Stack.Pop;
+ if Op.PB_Token_Index /= Invalid_Token_Index then
+ Parser_State.Shared_Token :=
Op.PB_Token_Index;
+ Shared_Token_Changed := True;
+ end if;
- when Insert =>
- if Stack_Matches_Ops and Op.Ins_Token_Index =
Parser_State.Shared_Token then
- -- This is the first Insert. Even if a later
Push_Back supercedes it,
- -- we record Stack_Matches_Ops false here.
- Stack_Matches_Ops := False;
+ elsif Op.PB_Token_Index = Min_Op_Token_Index then
+ loop
+ -- Multiple push_backs can have the same
Op.PB_Token_Index, so we may
+ -- already be at the target.
+ exit when Parser_State.Shared_Token <=
Op.PB_Token_Index and
+ (Parser_State.Stack.Depth = 1 or else
+ Tree.Min_Terminal_Index
(Parser_State.Stack (1).Token) /= Invalid_Token_Index);
+ -- also push back empty tokens.
+
+ declare
+ Item : constant
Parser_Lists.Parser_Stack_Item := Parser_State.Stack.Pop;
+
+ Min_Index : constant Base_Token_Index :=
+ Parser_State.Tree.Min_Terminal_Index
(Item.Token);
+ begin
+ if Min_Index /= Invalid_Token_Index then
+ Shared_Token_Changed := True;
+ Parser_State.Shared_Token := Min_Index;
+ end if;
+ end;
+ end loop;
+ pragma Assert (Parser_State.Shared_Token =
Op.PB_Token_Index);
+ end if;
- if Op.Ins_Token_Index <= Min_Push_Back_Token_Index
then
- Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (Op.Ins_ID);
- Current_Token_Virtual := True;
+ when Insert =>
+ if Stack_Matches_Ops and Op.Ins_Token_Index =
Parser_State.Shared_Token then
+ -- This is the first Insert. Even if a later
Push_Back supercedes it,
+ -- we record Stack_Matches_Ops false here.
+ Stack_Matches_Ops := False;
+
+ if Op.Ins_Token_Index <=
Min_Push_Back_Token_Index then
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (Op.Ins_ID);
+ Current_Token_Virtual := True;
+ else
+ if Is_Full (Sorted_Insert_Delete) then
+ raise Bad_Config;
+ else
+ Insert (Sorted_Insert_Delete, Op);
+ end if;
+ end if;
else
- Sorted_Insert_Delete.Insert (Op);
+ if Is_Full (Sorted_Insert_Delete) then
+ raise Bad_Config;
+ else
+ Insert (Sorted_Insert_Delete, Op);
+ end if;
end if;
- else
- Sorted_Insert_Delete.Insert (Op);
- end if;
- when Delete =>
- if Stack_Matches_Ops and Op.Del_Token_Index =
Parser_State.Shared_Token then
- -- We can apply multiple deletes.
- Parser_State.Shared_Token := Op.Del_Token_Index + 1;
- Apply_Prev_Token;
- Shared_Token_Changed := True;
- else
- Sorted_Insert_Delete.Insert (Op);
- end if;
- end case;
+ when Delete =>
+ if Stack_Matches_Ops and Op.Del_Token_Index =
Parser_State.Shared_Token then
+ -- We can apply multiple deletes.
+ Parser_State.Shared_Token := Op.Del_Token_Index
+ 1;
+ Apply_Prev_Token;
+ Shared_Token_Changed := True;
+ else
+ if Is_Full (Sorted_Insert_Delete) then
+ raise Bad_Config;
+ else
+ Insert (Sorted_Insert_Delete, Op);
+ end if;
+ end if;
+ end case;
+ end;
end loop;
-- We may not have processed the current Insert or Delete
above, if
-- they are after a fast_forward.
- for Op of Sorted_Insert_Delete loop
- if Token_Index (Op) = Parser_State.Shared_Token and not
Current_Token_Virtual then
- case Insert_Delete_Op_Label'(Op.Op) is
- when Insert =>
- Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (ID (Op));
- Current_Token_Virtual := True;
+ for I in First_Index (Sorted_Insert_Delete) .. Last_Index
(Sorted_Insert_Delete) loop
+ declare
+ Op : Insert_Delete_Op renames
Insert_Delete_Array_Refs.Constant_Ref (Sorted_Insert_Delete, I);
+ begin
+ if Token_Index (Op) = Parser_State.Shared_Token and
not Current_Token_Virtual then
+ case Insert_Delete_Op_Label'(Op.Op) is
+ when Insert =>
+ Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal (ID (Op));
+ Current_Token_Virtual := True;
- when Delete =>
- Parser_State.Shared_Token := Op.Del_Token_Index + 1;
- Apply_Prev_Token;
- Shared_Token_Changed := True;
- end case;
- else
- Parser_State.Recover_Insert_Delete.Put (Op);
- end if;
+ when Delete =>
+ Parser_State.Shared_Token := Op.Del_Token_Index
+ 1;
+ Apply_Prev_Token;
+ Shared_Token_Changed := True;
+ end case;
+ else
+ Parser_State.Recover_Insert_Delete.Put (Op);
+ end if;
+ end;
end loop;
-- If not Shared_Token_Changed, Shared_Token is the error
token,
@@ -686,7 +715,10 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
return Super.Recover_Result;
exception
- when others =>
+ when E : others =>
+ if Debug_Mode then
+ Trace.Put (Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
+ end if;
return Fail_Programmer_Error;
end Recover;
@@ -700,22 +732,23 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
end Check;
function Current_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out WisiToken.Base_Token_Index;
- Restore_Terminals_Current : out WisiToken.Base_Token_Index;
- Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out WisiToken.Base_Token_Index;
+ Restore_Terminals_Current : out WisiToken.Base_Token_Index;
+ Insert_Delete : aliased in out
Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type;
+ Prev_Deleted : in
Recover_Token_Index_Arrays.Vector)
return Base_Token
is
- use all type SAL.Base_Peek_Type;
+ use Sorted_Insert_Delete_Arrays;
+ use Insert_Delete_Array_Refs;
procedure Inc_I_D
is begin
Current_Insert_Delete := Current_Insert_Delete + 1;
- if Current_Insert_Delete > Insert_Delete.Last_Index then
+ if Current_Insert_Delete > Last_Index (Insert_Delete) then
Current_Insert_Delete := No_Insert_Delete;
- Insert_Delete.Clear;
+ Clear (Insert_Delete);
end if;
end Inc_I_D;
@@ -730,9 +763,9 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
Restore_Terminals_Current := Terminals_Current;
return Terminals (Terminals_Current);
- elsif Token_Index (Insert_Delete (Current_Insert_Delete)) =
Terminals_Current then
+ elsif Token_Index (Constant_Ref (Insert_Delete,
Current_Insert_Delete)) = Terminals_Current then
declare
- Op : Insert_Delete_Op renames Insert_Delete
(Current_Insert_Delete);
+ Op : Insert_Delete_Op renames Constant_Ref (Insert_Delete,
Current_Insert_Delete);
begin
case Insert_Delete_Op_Label (Op.Op) is
when Insert =>
@@ -759,13 +792,14 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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)
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : aliased 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;
+ use Insert_Delete_Array_Refs;
+
Result : Token_ID;
begin
if Terminals_Current = Base_Token_Index'First then
@@ -780,9 +814,9 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
if Current_Insert_Delete = No_Insert_Delete then
null;
- elsif Token_Index (Insert_Delete (Current_Insert_Delete)) =
Terminals_Current then
+ elsif Token_Index (Constant_Ref (Insert_Delete, Current_Insert_Delete))
= Terminals_Current then
declare
- Op : Insert_Delete_Op renames Insert_Delete
(Current_Insert_Delete);
+ Op : Insert_Delete_Op renames Constant_Ref (Insert_Delete,
Current_Insert_Delete);
begin
case Insert_Delete_Op_Label (Op.Op) is
when Insert =>
@@ -798,14 +832,13 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
end Current_Token_ID_Peek;
procedure Current_Token_ID_Peek_3
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in Base_Token_Index;
- Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector;
- Tokens : out Token_ID_Array_1_3)
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : aliased in
Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in SAL.Base_Peek_Type;
+ Prev_Deleted : in Recover_Token_Index_Arrays.Vector;
+ Tokens : out Token_ID_Array_1_3)
is
- use all type SAL.Base_Peek_Type;
Terminals_Next : WisiToken.Token_Index := Terminals_Current + 1;
begin
if Terminals_Current = Base_Token_Index'First then
@@ -841,13 +874,14 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
else
for I in Tokens'Range loop
declare
+ use Sorted_Insert_Delete_Arrays, Insert_Delete_Array_Refs;
J : constant SAL.Base_Peek_Type := Current_Insert_Delete +
SAL.Peek_Type (I) - 1;
begin
- if (J >= Insert_Delete.First_Index and J <=
Insert_Delete.Last_Index) and then
- Token_Index (Insert_Delete (J)) = Terminals_Current
+ if (J in First_Index (Insert_Delete) .. Last_Index
(Insert_Delete)) and then
+ Token_Index (Constant_Ref (Insert_Delete, J)) =
Terminals_Current
then
declare
- Op : Insert_Delete_Op renames Insert_Delete (J);
+ Op : Insert_Delete_Op renames Constant_Ref
(Insert_Delete, J);
begin
case Insert_Delete_Op_Label (Op.Op) is
when Insert =>
@@ -869,46 +903,48 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
Config : in out Configuration;
ID : in Token_ID)
is
+ use Config_Op_Arrays;
+ use Sorted_Insert_Delete_Arrays;
Op : constant Config_Op := (Delete, ID, Config.Current_Shared_Token);
begin
Check (Terminals (Config.Current_Shared_Token).ID, ID);
- Config.Ops.Append (Op);
- Config.Insert_Delete.Insert (Op);
+ if Is_Full (Config.Ops) or Is_Full (Config.Insert_Delete) then
+ raise Bad_Config;
+ end if;
+ Append (Config.Ops, Op);
+ Insert (Config.Insert_Delete, Op);
Config.Current_Insert_Delete := 1;
- exception
- when SAL.Container_Full =>
- raise Bad_Config;
end Delete_Check;
procedure Delete_Check
(Terminals : in Base_Token_Arrays.Vector;
Config : in out Configuration;
- Index : in out WisiToken.Token_Index;
+ Index : in out WisiToken.Token_Index;
ID : in Token_ID)
is
+ use Config_Op_Arrays;
+ use Sorted_Insert_Delete_Arrays;
Op : constant Config_Op := (Delete, ID, Index);
begin
Check (Terminals (Index).ID, ID);
- Config.Ops.Append (Op);
- Config.Insert_Delete.Insert (Op);
+ if Is_Full (Config.Ops) or Is_Full (Config.Insert_Delete) then
+ raise Bad_Config;
+ end if;
+ Append (Config.Ops, Op);
+ Insert (Config.Insert_Delete, Op);
Config.Current_Insert_Delete := 1;
Index := Index + 1;
- exception
- when SAL.Container_Full =>
- raise Bad_Config;
end Delete_Check;
procedure Find_ID
(Config : in Configuration;
ID : in Token_ID;
Matching_Index : in out SAL.Peek_Type)
- is
- use all type SAL.Peek_Type;
- begin
+ is 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;
+ Stack_ID : Token_ID renames Config.Stack.Peek
(Matching_Index).Token.ID;
begin
exit when Stack_ID = ID;
end;
@@ -920,13 +956,11 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
(Config : in Configuration;
IDs : in Token_ID_Set;
Matching_Index : in out SAL.Peek_Type)
- is
- use all type SAL.Peek_Type;
- begin
+ is begin
loop
- exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ exit when Matching_Index >= Config.Stack.Depth; -- Depth has
Invalid_Token_ID
declare
- ID : Token_ID renames Config.Stack (Matching_Index).Token.ID;
+ ID : Token_ID renames Config.Stack.Peek (Matching_Index).Token.ID;
begin
exit when ID in IDs'First .. IDs'Last and then IDs (ID);
end;
@@ -942,14 +976,13 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
Matching_Index : in out SAL.Peek_Type)
is
use Syntax_Trees;
- use all type SAL.Peek_Type;
begin
loop
- exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- exit when Config.Stack (Matching_Index).Token.ID in ID_Set'Range and
then
- (ID_Set (Config.Stack (Matching_Index).Token.ID) and
- (Config.Stack (Matching_Index).Tree_Index /= Invalid_Node_Index
and then
- Tree.Find_Descendant (Config.Stack
(Matching_Index).Tree_Index, ID) /= Invalid_Node_Index));
+ exit when Matching_Index >= Config.Stack.Depth; -- Depth has
Invalid_Token_ID
+ exit when Config.Stack.Peek (Matching_Index).Token.ID in ID_Set'Range
and then
+ (ID_Set (Config.Stack.Peek (Matching_Index).Token.ID) and
+ (Config.Stack.Peek (Matching_Index).Tree_Index /=
Invalid_Node_Index and then
+ Tree.Find_Descendant (Config.Stack.Peek
(Matching_Index).Tree_Index, ID) /= Invalid_Node_Index));
Matching_Index := Matching_Index + 1;
end loop;
@@ -963,13 +996,12 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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
+ exit when Matching_Name_Index >= Config.Stack.Depth; -- Depth has
Invalid_Token_ID
declare
- Token : Recover_Token renames Config.Stack
(Matching_Name_Index).Token;
+ Token : Recover_Token renames Config.Stack.Peek
(Matching_Name_Index).Token;
Name_Region : constant Buffer_Region :=
(if Token.Name = Null_Buffer_Region
then Token.Byte_Region
@@ -996,18 +1028,17 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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
+ exit when Matching_Name_Index >= Config.Stack.Depth; -- Depth has
Invalid_Token_ID
declare
- Token : Recover_Token renames Config.Stack
(Matching_Name_Index).Token;
+ Token : Recover_Token renames Config.Stack.Peek
(Matching_Name_Index).Token;
Name_Region : constant Buffer_Region :=
(if Token.Name = Null_Buffer_Region
- then Token.Byte_Region -- FIXME: why not only Token.name?
+ then Token.Byte_Region
else Token.Name);
begin
exit when Name_Region /= Null_Buffer_Region and then
@@ -1027,14 +1058,16 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
procedure Insert (Config : in out Configuration; ID : in Token_ID)
is
+ use Config_Op_Arrays;
+ use Sorted_Insert_Delete_Arrays;
Op : constant Config_Op := (Insert, ID, Config.Current_Shared_Token,
Unknown_State, 0);
begin
- Config.Ops.Append (Op);
- Config.Insert_Delete.Insert (Op);
+ if Is_Full (Config.Ops) or Is_Full (Config.Insert_Delete) then
+ raise Bad_Config;
+ end if;
+ Append (Config.Ops, Op);
+ Insert (Config.Insert_Delete, 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)
@@ -1045,15 +1078,15 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
end Insert;
function Next_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out Base_Token_Index;
- Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
- Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out Base_Token_Index;
+ Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
+ Insert_Delete : aliased in out
Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type;
+ Prev_Deleted : in
Recover_Token_Index_Arrays.Vector)
return Base_Token
is
- use all type SAL.Base_Peek_Type;
+ use Sorted_Insert_Delete_Arrays, Insert_Delete_Array_Refs;
function Next_Terminal return Base_Token
is begin
@@ -1069,18 +1102,18 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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;
+ if Last_Index (Insert_Delete) > 0 and then Current_Insert_Delete =
Last_Index (Insert_Delete) then
+ Current_Insert_Delete := No_Insert_Delete;
+ Clear (Insert_Delete);
return Next_Terminal;
elsif Current_Insert_Delete = No_Insert_Delete then
return Next_Terminal;
- elsif Token_Index (Insert_Delete (Current_Insert_Delete + 1)) =
Terminals_Current + 1 then
+ elsif Token_Index (Constant_Ref (Insert_Delete, Current_Insert_Delete
+ 1)) = Terminals_Current + 1 then
Current_Insert_Delete := Current_Insert_Delete + 1;
declare
- Op : constant Insert_Delete_Op := Insert_Delete
(Current_Insert_Delete);
+ Op : Insert_Delete_Op renames Constant_Ref (Insert_Delete,
Current_Insert_Delete);
begin
case Insert_Delete_Op_Label'(Op.Op) is
when Insert =>
@@ -1100,6 +1133,9 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
procedure Push_Back (Config : in out Configuration)
is
+ use Config_Op_Arrays, Config_Op_Array_Refs;
+ use Sorted_Insert_Delete_Arrays;
+
Item : constant Recover_Stack_Item := Config.Stack.Pop;
Token_Index : constant Base_Token_Index :=
Item.Token.Min_Terminal_Index;
@@ -1115,22 +1151,26 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
begin
if Token_Index /= Invalid_Token_Index then
Config.Current_Shared_Token := Token_Index;
- for I in Config.Ops.First_Index .. Config.Ops.Last_Index loop
- if Compare (Token_Index, Config.Ops (I)) then
- Config.Insert_Delete.Insert (Config.Ops (I), Ignore_If_Equal =>
True);
+ for I in First_Index (Config.Ops) .. Last_Index (Config.Ops) loop
+ if Compare (Token_Index, Constant_Ref (Config.Ops, I)) then
+ if Is_Full (Config.Insert_Delete) then
+ raise Bad_Config;
+ end if;
+ Insert (Config.Insert_Delete, Constant_Ref (Config.Ops, I),
Ignore_If_Equal => True);
end if;
end loop;
end if;
- Config.Ops.Append ((Push_Back, Item.Token.ID,
Config.Current_Shared_Token));
- exception
- when SAL.Container_Full =>
- raise Bad_Config;
+ if Is_Full (Config.Ops) then
+ raise Bad_Config;
+ end if;
+ Append (Config.Ops, (Push_Back, Item.Token.ID,
Config.Current_Shared_Token));
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);
+ pragma Assert (Config.Stack.Depth > 1);
+ Check (Config.Stack.Peek (1).Token.ID, Expected_ID);
Push_Back (Config);
end Push_Back_Check;
@@ -1154,8 +1194,8 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
-- Build a string, call trace.put_line once, so output from multiple
-- tasks is not interleaved (mostly).
+ use Insert_Delete_Array_Refs;
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;
@@ -1186,7 +1226,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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) & "/";
+ Image (Constant_Ref (Config.Insert_Delete,
Config.Current_Insert_Delete), Descriptor) & "/";
end if;
Result := Result & Image (Config.Ops, Descriptor);
@@ -1212,7 +1252,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
Tree : in Syntax_Trees.Tree)
return Ada.Containers.Count_Type
is
- Nonterm_Item : constant Recover_Stack_Item := Stack.Pop;
+ Nonterm_Item : constant Recover_Stack_Item := Recover_Stacks.Pop (Stack);
begin
if Nonterm_Item.Token.Byte_Region = Null_Buffer_Region then
return 0;
@@ -1232,8 +1272,9 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
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)));
+ pragma Assert (Config.Stack.Depth > 1);
+ Check (Config.Stack.Peek (1).Token.ID, Expected);
+ Config_Op_Arrays.Append (Config.Ops, (Undo_Reduce, Expected, Undo_Reduce
(Config.Stack, Tree)));
exception
when SAL.Container_Full =>
raise Bad_Config;
diff --git a/wisitoken-parse-lr-mckenzie_recover.ads
b/wisitoken-parse-lr-mckenzie_recover.ads
index b143866..9b84a03 100644
--- a/wisitoken-parse-lr-mckenzie_recover.ads
+++ b/wisitoken-parse-lr-mckenzie_recover.ads
@@ -62,12 +62,12 @@ private
-- Implemented using 'pragma Assert'.
function Current_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out Base_Token_Index;
- Restore_Terminals_Current : out WisiToken.Base_Token_Index;
- Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out Base_Token_Index;
+ Restore_Terminals_Current : out WisiToken.Base_Token_Index;
+ Insert_Delete : aliased in out
Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type;
+ Prev_Deleted : in
Recover_Token_Index_Arrays.Vector)
return Base_Token;
-- Return the current token, from either Terminals or Insert_Delete;
-- set up for Next_Token.
@@ -75,21 +75,21 @@ private
-- 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)
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : aliased in Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in SAL.Base_Peek_Type)
return Token_ID;
-- Return the current token from either Terminals or
-- Insert_Delete, without setting up for Next_Token.
procedure Current_Token_ID_Peek_3
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in Base_Token_Index;
- Insert_Delete : in Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector;
- Tokens : out Token_ID_Array_1_3);
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in Base_Token_Index;
+ Insert_Delete : aliased in
Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in SAL.Base_Peek_Type;
+ Prev_Deleted : in Recover_Token_Index_Arrays.Vector;
+ Tokens : out Token_ID_Array_1_3);
-- Return the current token (in Tokens (1)) from either Terminals or
-- Insert_Delete, without setting up for Next_Token. Return the two
-- following tokens in Tokens (2 .. 3).
@@ -177,12 +177,12 @@ private
-- Call Insert for each item in IDs.
function Next_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out Base_Token_Index;
- Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
- Insert_Delete : in out Sorted_Insert_Delete_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type;
- Prev_Deleted : in Recover_Token_Index_Arrays.Vector)
+ (Terminals : in Base_Token_Arrays.Vector;
+ Terminals_Current : in out Base_Token_Index;
+ Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
+ Insert_Delete : aliased in out
Sorted_Insert_Delete_Arrays.Vector;
+ Current_Insert_Delete : in out SAL.Base_Peek_Type;
+ Prev_Deleted : in
Recover_Token_Index_Arrays.Vector)
return Base_Token;
-- Return the next token, from either Terminals or Insert_Delete;
-- update Terminals_Current or Current_Insert_Delete.
@@ -234,14 +234,15 @@ private
-- Put message to Trace, with parser and task info.
function Undo_Reduce_Valid
- (Stack : in out Recover_Stacks.Stack;
- Tree : in Syntax_Trees.Tree)
+ (Stack : in Recover_Stacks.Stack;
+ Tree : in Syntax_Trees.Tree)
return Boolean
- is ((Stack.Peek.Tree_Index /= WisiToken.Syntax_Trees.Invalid_Node_Index
and then
- Tree.Is_Nonterm (Stack.Peek.Tree_Index)) or
- (Stack.Peek.Tree_Index = WisiToken.Syntax_Trees.Invalid_Node_Index
and
- (not Stack.Peek.Token.Virtual and
- Stack.Peek.Token.Byte_Region = Null_Buffer_Region)));
+ is (Stack.Depth > 1 and then
+ ((Stack.Peek.Tree_Index /=
WisiToken.Syntax_Trees.Invalid_Node_Index and then
+ Tree.Is_Nonterm (Stack.Peek.Tree_Index)) or
+ (Stack.Peek.Tree_Index =
WisiToken.Syntax_Trees.Invalid_Node_Index and
+ (not Stack.Peek.Token.Virtual and
+ Stack.Peek.Token.Byte_Region = Null_Buffer_Region))));
-- Undo_Reduce needs to know what tokens the nonterm contains, to
-- push them on the stack. Thus we need either a valid Tree index, or
-- an empty nonterm. If Token.Virtual, we can't trust
diff --git a/wisitoken-parse-lr-parser.adb b/wisitoken-parse-lr-parser.adb
index 986675d..70fab20 100644
--- a/wisitoken-parse-lr-parser.adb
+++ b/wisitoken-parse-lr-parser.adb
@@ -45,7 +45,6 @@ package body WisiToken.Parse.LR.Parser is
-- 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;
@@ -139,8 +138,6 @@ package body WisiToken.Parse.LR.Parser is
when Reduce =>
declare
- use all type SAL.Base_Peek_Type;
-
New_State : constant Unknown_State_Index := Goto_For
(Table => Shared_Parser.Table.all,
State => Parser_State.Stack (SAL.Base_Peek_Type
(Action.Token_Count) + 1).State,
@@ -226,9 +223,7 @@ package body WisiToken.Parse.LR.Parser is
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
+ is begin
if Trace_Parse > Extra then
Shared_Parser.Trace.Put_Line
(Integer'Image (Parser_State.Label) & ": shared_token:" &
@@ -285,8 +280,6 @@ package body WisiToken.Parse.LR.Parser is
Verb : out All_Parse_Action_Verbs;
Zombie_Count : out SAL.Base_Peek_Type)
is
- use all type SAL.Base_Peek_Type;
-
Shift_Count : SAL.Base_Peek_Type := 0;
Accept_Count : SAL.Base_Peek_Type := 0;
Error_Count : SAL.Base_Peek_Type := 0;
@@ -383,12 +376,7 @@ package body WisiToken.Parse.LR.Parser is
Parser.Language_String_ID_Set := Language_String_ID_Set;
Parser.User_Data := User_Data;
- -- We can't use Table.McKenzie_Param /= Default_McKenzie_Param here,
- -- because the discriminants are different.
- Parser.Enable_McKenzie_Recover :=
- Table.McKenzie_Param.Check_Limit /= Default_McKenzie_Param.Check_Limit
or
- Table.McKenzie_Param.Check_Delta_Limit /=
Default_McKenzie_Param.Check_Delta_Limit or
- Table.McKenzie_Param.Enqueue_Limit /=
Default_McKenzie_Param.Enqueue_Limit;
+ Parser.Enable_McKenzie_Recover := not McKenzie_Defaulted (Table.all);
Parser.Max_Parallel := Max_Parallel;
Parser.Terminate_Same_State := Terminate_Same_State;
@@ -403,7 +391,6 @@ package body WisiToken.Parse.LR.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;
@@ -676,6 +663,7 @@ package body WisiToken.Parse.LR.Parser is
Recover_Result : McKenzie_Recover.Recover_Status :=
McKenzie_Recover.Recover_Status'First;
Pre_Recover_Parser_Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
+ Start : Ada.Calendar.Time;
begin
-- Recover algorithms expect current token at
-- Parsers(*).Current_Token, will set
@@ -686,10 +674,17 @@ package body WisiToken.Parse.LR.Parser is
if Shared_Parser.Enable_McKenzie_Recover then
if Debug_Mode then
Trace.Put_Clock ("pre-recover" &
Shared_Parser.Parsers.Count'Img & " active");
+ Start := Ada.Calendar.Clock;
end if;
Recover_Result := McKenzie_Recover.Recover (Shared_Parser);
if Debug_Mode then
- Trace.Put_Clock ("post-recover" &
Shared_Parser.Parsers.Count'Img & " active");
+ declare
+ use Ada.Calendar;
+ Recover_Duration : constant Duration := Clock - Start;
+ begin
+ Trace.Put_Clock
+ ("post-recover" & Shared_Parser.Parsers.Count'Img &
" active," & Recover_Duration'Image);
+ end;
end if;
if Trace_Parse > Outline then
@@ -732,7 +727,7 @@ package body WisiToken.Parse.LR.Parser is
end;
end if;
else
- if Trace_Parse > Outline then
+ if Trace_Parse > Outline or Trace_McKenzie > Outline then
Trace.Put_Line ("recover disabled");
end if;
end if;
@@ -786,7 +781,10 @@ package body WisiToken.Parse.LR.Parser is
First_Terminal => Trace.Descriptor.First_Terminal,
Last_Terminal => Trace.Descriptor.Last_Terminal,
Recover => <>,
- Msg => +"recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result)));
+ Msg =>
+ (if Shared_Parser.Enable_McKenzie_Recover
+ then +"recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result)
+ else +"recover disabled")));
end loop;
raise WisiToken.Syntax_Error;
end if;
@@ -970,7 +968,7 @@ package body WisiToken.Parse.LR.Parser is
end if;
if Debug_Mode then
- Trace.Put_Clock ("finish");
+ Trace.Put_Clock ("finish parse");
end if;
-- We don't raise Syntax_Error for lexer errors, since they are all
@@ -1007,9 +1005,7 @@ package body WisiToken.Parse.LR.Parser is
end Parse;
overriding function Tree (Shared_Parser : in Parser) return
Syntax_Trees.Tree
- is
- use all type SAL.Base_Peek_Type;
- begin
+ is begin
if Shared_Parser.Parsers.Count > 1 then
raise WisiToken.Parse_Error with "ambigous parse";
else
@@ -1020,7 +1016,6 @@ package body WisiToken.Parse.LR.Parser is
overriding
procedure Execute_Actions (Parser : in out LR.Parser.Parser)
is
- use all type SAL.Base_Peek_Type;
use all type Syntax_Trees.User_Data_Access;
use all type WisiToken.Syntax_Trees.Semantic_Action;
@@ -1065,26 +1060,29 @@ package body WisiToken.Parse.LR.Parser is
end if;
declare
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_State_Ref.Element.all;
+ use Config_Op_Arrays, Config_Op_Array_Refs;
+ Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_State_Ref;
begin
if Trace_Action > Outline then
Parser.Trace.Put_Line
(Integer'Image (Parser_State.Label) & ": root node: " &
Parser_State.Tree.Image
- (Parser_State.Tree.Root, Descriptor));
+ (Parser_State.Tree.Root, Descriptor));
end if;
- if (for some Err of Parser_State.Errors => Any (Err.Recover.Ops,
Delete)) then
- for Err of Parser_State.Errors loop
- for Op of Err.Recover.Ops loop
+ for Err of Parser_State.Errors loop
+ for I in First_Index (Err.Recover.Ops) .. Last_Index
(Err.Recover.Ops) loop
+ declare
+ Op : Config_Op renames Constant_Ref (Err.Recover.Ops, I);
+ begin
case Op.Op is
when Delete =>
Parser.User_Data.Delete_Token (Op.Del_Token_Index);
when others =>
null;
end case;
- end loop;
+ end;
end loop;
- end if;
+ end loop;
Parser.User_Data.Initialize_Actions (Parser_State.Tree);
Parser_State.Tree.Process_Tree (Process_Node'Access);
@@ -1094,7 +1092,6 @@ package body WisiToken.Parse.LR.Parser is
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
@@ -1104,7 +1101,6 @@ package body WisiToken.Parse.LR.Parser is
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;
diff --git a/wisitoken-parse-lr-parser.ads b/wisitoken-parse-lr-parser.ads
index a88e3af..e84d65d 100644
--- a/wisitoken-parse-lr-parser.ads
+++ b/wisitoken-parse-lr-parser.ads
@@ -80,10 +80,10 @@ package WisiToken.Parse.LR.Parser is
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;
+ Table : Parse_Table_Ptr;
+ Language_Fixes : Language_Fixes_Access;
Language_Matching_Begin_Tokens : Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : Language_String_ID_Set_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.
@@ -143,9 +143,9 @@ package WisiToken.Parse.LR.Parser is
-- raise Parse_Error for an ambiguous parse.
overriding procedure Execute_Actions (Parser : in out LR.Parser.Parser);
- -- Call User_Data.Reduce on all nonterms in the syntax tree, then
- -- User_Data.Delete_Token on any tokens deleted by error recovery,
- -- then the grammar semantic actions.
+ -- Call User_Data.Delete_Token on any tokens deleted by error
+ -- recovery, then User_Data.Reduce and the grammar semantic actions
+ -- on all nonterms in the syntax tree.
overriding function Any_Errors (Parser : in LR.Parser.Parser) return
Boolean;
-- Return True if any errors where encountered, recovered or not.
diff --git a/wisitoken-parse-lr-parser_lists.adb
b/wisitoken-parse-lr-parser_lists.adb
index e2a0918..480e86f 100644
--- a/wisitoken-parse-lr-parser_lists.adb
+++ b/wisitoken-parse-lr-parser_lists.adb
@@ -27,7 +27,6 @@ package body WisiToken.Parse.LR.Parser_Lists is
Depth : in SAL.Base_Peek_Type := 0)
return String
is
- use all type SAL.Base_Peek_Type;
use Ada.Strings.Unbounded;
Last : constant SAL.Base_Peek_Type :=
@@ -104,14 +103,14 @@ package body WisiToken.Parse.LR.Parser_Lists is
function Label (Cursor : in Parser_Lists.Cursor) return Natural
is begin
- return Parser_State_Lists.Constant_Reference (Cursor.Ptr).Label;
+ return Parser_State_Lists.Constant_Ref (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
+ for Error of Parser_State_Lists.Constant_Ref (Cursor.Ptr).Errors loop
Result := Error.Recover.Cost;
end loop;
return Result;
@@ -120,12 +119,13 @@ package body WisiToken.Parse.LR.Parser_Lists is
function Max_Recover_Ops_Length (Cursor : in Parser_Lists.Cursor) return
Ada.Containers.Count_Type
is
use Ada.Containers;
+ use Config_Op_Arrays;
Result : Count_Type := 0;
- Errors : Parse_Error_Lists.List renames
Parser_State_Lists.Constant_Reference (Cursor.Ptr).Errors;
+ Errors : Parse_Error_Lists.List renames Parser_State_Lists.Constant_Ref
(Cursor.Ptr).Errors;
begin
for Error of Errors loop
- if Error.Recover.Ops.Length > Result then
- Result := Error.Recover.Ops.Length;
+ if Length (Error.Recover.Ops) > Result then
+ Result := Length (Error.Recover.Ops);
end if;
end loop;
return Result;
@@ -134,7 +134,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
function Min_Recover_Cost (Cursor : in Parser_Lists.Cursor) return Integer
is
Result : Integer := Integer'Last;
- Errors : Parse_Error_Lists.List renames
Parser_State_Lists.Constant_Reference (Cursor.Ptr).Errors;
+ Errors : Parse_Error_Lists.List renames Parser_State_Lists.Constant_Ref
(Cursor.Ptr).Errors;
begin
for Error of Errors loop
if Error.Recover.Cost < Result then
@@ -146,12 +146,12 @@ package body WisiToken.Parse.LR.Parser_Lists is
procedure Set_Verb (Cursor : in Parser_Lists.Cursor; Verb : in
All_Parse_Action_Verbs)
is begin
- Parser_State_Lists.Reference (Cursor.Ptr).Verb := Verb;
+ Parser_State_Lists.Variable_Ref (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;
+ return Parser_State_Lists.Constant_Ref (Cursor.Ptr).Verb;
end Verb;
procedure Terminate_Parser
@@ -161,8 +161,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
Trace : in out WisiToken.Trace'Class;
Terminals : in Base_Token_Arrays.Vector)
is
- use all type SAL.Base_Peek_Type;
- State : Parser_State renames Parser_State_Lists.Constant_Reference
(Current.Ptr).Element.all;
+ State : Parser_State renames Parser_State_Lists.Constant_Ref
(Current.Ptr).Element.all;
begin
if Trace_Parse > Outline then
Trace.Put_Line
@@ -186,7 +185,6 @@ package body WisiToken.Parse.LR.Parser_Lists is
Trace : in out WisiToken.Trace'Class;
Terminals : in Base_Token_Arrays.Vector)
is
- use all type SAL.Base_Peek_Type;
use all type Ada.Containers.Count_Type;
function Compare
@@ -268,22 +266,22 @@ package body WisiToken.Parse.LR.Parser_Lists is
function State_Ref (Position : in Cursor) return State_Reference
is begin
- return (Element => Parser_State_Lists.Constant_Reference
(Position.Ptr).Element);
+ return (Element => Parser_State_Lists.Constant_Ref
(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);
+ return (Element => Parser_State_Lists.Constant_Ref
(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);
+ return (Element => Parser_State_Lists.Constant_Ref
(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);
+ Parser_State : Parser_Lists.Parser_State renames
Parser_State_Lists.Constant_Ref (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));
@@ -297,7 +295,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
begin
List.Parser_Label := List.Parser_Label + 1;
declare
- Item : Parser_State renames Parser_State_Lists.Reference
(Cursor.Ptr).Element.all;
+ Item : Parser_State renames Parser_State_Lists.Variable_Ref
(Cursor.Ptr);
-- We can't do 'Prepend' in the scope of this 'renames';
-- that would be tampering with cursors.
begin
@@ -353,7 +351,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
is
pragma Unreferenced (Container);
begin
- return (Element => Parser_State_Lists.Constant_Reference
(Position.Ptr).Element);
+ return (Element => Parser_State_Lists.Constant_Ref
(Position.Ptr).Element);
end Constant_Reference;
function Reference
@@ -363,7 +361,7 @@ package body WisiToken.Parse.LR.Parser_Lists is
is
pragma Unreferenced (Container);
begin
- return (Element => Parser_State_Lists.Reference (Position.Ptr).Element);
+ return (Element => Parser_State_Lists.Variable_Ref
(Position.Ptr).Element);
end Reference;
function Persistent_State_Ref (Position : in Parser_Node_Access) return
State_Access
diff --git a/wisitoken-parse-lr-parser_lists.ads
b/wisitoken-parse-lr-parser_lists.ads
index a5af546..19aa370 100644
--- a/wisitoken-parse-lr-parser_lists.ads
+++ b/wisitoken-parse-lr-parser_lists.ads
@@ -22,6 +22,7 @@ pragma License (Modified_GPL);
with Ada.Iterator_Interfaces;
with SAL.Gen_Indefinite_Doubly_Linked_Lists;
+with SAL.Gen_Unbounded_Definite_Stacks;
with WisiToken.Syntax_Trees;
package WisiToken.Parse.LR.Parser_Lists is
diff --git a/wisitoken-parse-lr-parser_no_recover.adb
b/wisitoken-parse-lr-parser_no_recover.adb
index 67371f1..7943aab 100644
--- a/wisitoken-parse-lr-parser_no_recover.adb
+++ b/wisitoken-parse-lr-parser_no_recover.adb
@@ -36,8 +36,6 @@ package body WisiToken.Parse.LR.Parser_No_Recover is
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.
@@ -83,8 +81,6 @@ package body WisiToken.Parse.LR.Parser_No_Recover is
Current_Parser.Set_Verb (Reduce);
declare
- use all type SAL.Base_Peek_Type;
-
New_State : constant Unknown_State_Index := Goto_For
(Table => Shared_Parser.Table.all,
State => Parser_State.Stack (SAL.Base_Peek_Type
(Action.Token_Count) + 1).State,
@@ -159,8 +155,6 @@ package body WisiToken.Parse.LR.Parser_No_Recover is
(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;
@@ -236,7 +230,6 @@ package body WisiToken.Parse.LR.Parser_No_Recover is
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;
@@ -436,7 +429,6 @@ package body WisiToken.Parse.LR.Parser_No_Recover is
overriding procedure Execute_Actions (Parser : in out
LR.Parser_No_Recover.Parser)
is
- use all type SAL.Base_Peek_Type;
use all type Syntax_Trees.User_Data_Access;
procedure Process_Node
@@ -489,9 +481,7 @@ package body WisiToken.Parse.LR.Parser_No_Recover is
end Execute_Actions;
overriding function Tree (Parser : in LR.Parser_No_Recover.Parser) return
Syntax_Trees.Tree
- is
- use all type SAL.Base_Peek_Type;
- begin
+ is begin
if Parser.Parsers.Count > 1 then
raise WisiToken.Parse_Error with "ambigous parse";
else
@@ -501,7 +491,6 @@ package body WisiToken.Parse.LR.Parser_No_Recover is
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
diff --git a/wisitoken-parse-lr.adb b/wisitoken-parse-lr.adb
index 8900d4c..0ec3aa9 100644
--- a/wisitoken-parse-lr.adb
+++ b/wisitoken-parse-lr.adb
@@ -109,68 +109,41 @@ package body WisiToken.Parse.LR is
return False;
end Is_In;
- function Find
- (Symbol : in Token_ID;
- Action_List : in Action_Node_Ptr)
- return Action_Node_Ptr
- is
- Action_Node : Action_Node_Ptr := Action_List;
- begin
- while Action_Node /= null loop
- if Action_Node.Symbol = Symbol then
- return Action_Node;
- end if;
- Action_Node := Action_Node.Next;
- end loop;
-
- return null;
- end Find;
+ function Compare (Left, Right : in Token_ID) return SAL.Compare_Result
+ is begin
+ if Left < Right then
+ return SAL.Less;
+ elsif Left = Right then
+ return SAL.Equal;
+ else
+ return SAL.Greater;
+ end if;
+ end Compare;
procedure Add
- (List : in out Action_Node_Ptr;
+ (List : in out Action_Arrays.Vector;
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;
+ is begin
+ declare
+ Node : constant Action_Arrays.Find_Reference_Type := List.Find
(Symbol);
+ begin
+ if Node.Element /= null then
+ declare
+ I : Parse_Action_Node_Ptr := Node.Element.Actions;
+ begin
loop
- exit when I.Next = null or else I.Next.Symbol > Symbol;
+ exit when I.Next = null;
I := I.Next;
end loop;
- New_Item.Next := I.Next;
- I.Next := New_Item;
- end if;
+ I.Next := new Parse_Action_Node'(Action, null);
+ return;
+ end;
end if;
- end if;
+ end;
+ List.Insert ((Symbol, new Parse_Action_Node'(Action, null)));
end Add;
- function Symbol (List : in Goto_Node_Ptr) return Token_ID
- is begin
- return List.Symbol;
- end Symbol;
-
- function State (List : in Goto_Node_Ptr) return State_Index
- is begin
- return List.State;
- end State;
-
- function Next (List : in Goto_Node_Ptr) return Goto_Node_Ptr
- is begin
- return List.Next;
- end Next;
-
function To_Vector (Item : in Kernel_Info_Array) return
Kernel_Info_Arrays.Vector
is begin
return Result : Kernel_Info_Arrays.Vector do
@@ -219,70 +192,12 @@ package body WisiToken.Parse.LR is
end return;
end To_Vector;
- function First (State : in Parse_State) return Action_List_Iterator
- is begin
- return Iter : Action_List_Iterator := (Node => State.Action_List, Item
=> null) do
- loop
- exit when Iter.Node = null;
- Iter.Item := Iter.Node.Action;
- exit when Iter.Item /= null;
- Iter.Node := Iter.Node.Next;
- end loop;
- end return;
- end First;
-
- function Is_Done (Iter : in Action_List_Iterator) return Boolean
- is begin
- return Iter.Node = null;
- end Is_Done;
-
- procedure Next (Iter : in out Action_List_Iterator)
- is begin
- if Iter.Node = null then
- return;
- end if;
-
- if Iter.Item.Next = null then
- loop
- Iter.Node := Iter.Node.Next;
- exit when Iter.Node = null;
- Iter.Item := Iter.Node.Action;
- exit when Iter.Item /= null;
- end loop;
- else
- Iter.Item := Iter.Item.Next; -- a conflict
- end if;
- end Next;
-
- function Symbol (Iter : in Action_List_Iterator) return Token_ID
- is begin
- return Iter.Node.Symbol;
- end Symbol;
-
- function Action (Iter : in Action_List_Iterator) return Parse_Action_Rec
- is begin
- return Iter.Item.Item;
- end Action;
-
procedure Add_Action
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- State_Index : in WisiToken.State_Index)
- is
- Action : constant Parse_Action_Rec := (Shift, State_Index);
- New_Node : constant Action_Node_Ptr := new Action_Node'(Symbol, new
Parse_Action_Node'(Action, null), null);
- Node : Action_Node_Ptr;
- begin
- if State.Action_List = null then
- State.Action_List := New_Node;
- else
- Node := State.Action_List;
- loop
- exit when Node.Next = null;
- Node := Node.Next;
- end loop;
- Node.Next := New_Node;
- end if;
+ (State : in out LR.Parse_State;
+ Symbol : in Token_ID;
+ State_Index : in WisiToken.State_Index)
+ is begin
+ Add (State.Action_List, Symbol, (Shift, State_Index));
end Add_Action;
procedure Add_Action
@@ -294,29 +209,13 @@ package body WisiToken.Parse.LR is
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;
+ Action : constant Parse_Action_Rec :=
+ (case Verb is
+ when Reduce => (Reduce, Production, Semantic_Action,
Semantic_Check, RHS_Token_Count),
+ when Accept_It => (Accept_It, Production, Semantic_Action,
Semantic_Check, RHS_Token_Count),
+ when others => raise SAL.Programmer_Error);
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;
+ Add (State.Action_List, Symbol, Action);
end Add_Action;
procedure Add_Action
@@ -327,14 +226,13 @@ package body WisiToken.Parse.LR is
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.
+ -- We assume WisiToken.BNF.Output_Ada_Common.Duplicate_Reduce is True
+ -- for this state; no conflicts, all the same action.
for Symbol of Symbols loop
Add_Action
(State, Symbol, Reduce, Production, RHS_Token_Count,
Semantic_Action, Semantic_Check);
end loop;
- Add_Error (State);
end Add_Action;
procedure Add_Conflict
@@ -347,7 +245,10 @@ package body WisiToken.Parse.LR is
is
Conflict : constant Parse_Action_Rec :=
(Reduce, Reduce_Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
- Node : Parse_Action_Node_Ptr := Find (Symbol, State.Action_List).Action;
+
+ Ref : constant Action_Arrays.Find_Reference_Constant_Type :=
State.Action_List.Find_Constant (Symbol);
+
+ Node : Parse_Action_Node_Ptr := Ref.Actions;
begin
loop
exit when Node.Next = null;
@@ -356,50 +257,12 @@ package body WisiToken.Parse.LR is
Node.Next := new Parse_Action_Node'(Conflict, null);
end Add_Conflict;
- procedure Add_Error (State : in out LR.Parse_State)
- is
- Action : constant Parse_Action_Rec := (Verb => Error);
- Node : Action_Node_Ptr := State.Action_List;
- begin
- if Node = null then
- raise SAL.Programmer_Error with "adding an error action to a parse
table state before other actions.";
- end if;
- loop
- exit when Node.Next = null;
- Node := Node.Next;
- end loop;
- Node.Next := new Action_Node'(Invalid_Token_ID, new
Parse_Action_Node'(Action, null), null);
- end Add_Error;
-
procedure Add_Goto
(State : in out LR.Parse_State;
Symbol : in Token_ID;
To_State : in State_Index)
- is
- List : Goto_Node_Ptr renames State.Goto_List;
- New_Item : constant Goto_Node_Ptr := new Goto_Node'(Symbol, To_State,
null);
- I : Goto_Node_Ptr := List;
- begin
- if I = null then
- List := New_Item;
- else
- if List.Symbol > Symbol then
- New_Item.Next := List;
- List := New_Item;
- else
- if List.Next = null then
- List.Next := New_Item;
- else
- I := List;
- loop
- exit when I.Next = null or List.Symbol > Symbol;
- I := I.Next;
- end loop;
- New_Item.Next := I.Next;
- I.Next := New_Item;
- end if;
- end if;
- end if;
+ is begin
+ State.Goto_List.Insert ((Symbol, To_State));
end Add_Goto;
function Goto_For
@@ -408,103 +271,60 @@ package body WisiToken.Parse.LR is
ID : in Token_ID)
return Unknown_State_Index
is
- Goto_Node : constant Goto_Node_Ptr := Goto_For (Table, State, ID);
+ Ref : constant Goto_Arrays.Find_Reference_Constant_Type := Table.States
(State).Goto_List.Find_Constant (ID);
begin
- if Goto_Node = null then
+ if Ref.Element = null then
-- We can only get here during error recovery.
return Unknown_State;
else
- return Goto_Node.State;
+ return Ref.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;
+ Ref : constant Action_Arrays.Find_Reference_Constant_Type :=
Table.States (State).Action_List.Find_Constant (ID);
begin
- if Action_Node = null then
- raise SAL.Programmer_Error with "no actions for state" &
Unknown_State_Index'Image (State);
+ if Ref.Element = null then
+ return Table.Error_Action;
end if;
- while Action_Node.Next /= null and Action_Node.Symbol /= ID loop
- Action_Node := Action_Node.Next;
- end loop;
-
- return Action_Node.Action;
+ return Ref.Actions;
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;
+ Result : Token_ID_Set := (Table.First_Terminal .. Table.Last_Terminal =>
False);
begin
- loop
- -- Last action is error; don't include it.
- exit when Action.Next = null;
-
+ for Action of Table.States (State).Action_List loop
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;
+ for Action of State.Action_List loop
+ Parse_Action := Action.Actions;
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;
@@ -650,17 +470,18 @@ package body WisiToken.Parse.LR is
for State of Table.States loop
declare
- Node_I : Action_Node_Ptr := new Action_Node;
- Actions_Done : Boolean := False;
+ Actions_Done : Boolean := False;
begin
- State.Action_List := Node_I;
+ State.Action_List.Set_Capacity (Next_Count_Type);
+
loop
declare
+ Node_I : Action_Node;
Node_J : Parse_Action_Node_Ptr := new
Parse_Action_Node;
- Action_Done : Boolean := False;
+ Action_Done : Boolean := False;
Verb : Parse_Action_Verbs;
begin
- Node_I.Action := Node_J;
+ Node_I.Actions := Node_J;
loop
Verb := Next_Parse_Action_Verbs;
Node_J.Item :=
@@ -692,14 +513,16 @@ package body WisiToken.Parse.LR is
Node_J.Item.Token_Count := Next_Count_Type;
when Error =>
- Actions_Done := True;
+ raise SAL.Programmer_Error;
end case;
if Check_Semicolon then
Action_Done := True;
- if not Actions_Done then
- Node_I.Symbol := Next_Token_ID;
+ Node_I.Symbol := Next_Token_ID;
+
+ if Check_Semicolon then
+ Actions_Done := True;
end if;
end if;
@@ -710,11 +533,10 @@ package body WisiToken.Parse.LR is
end loop;
Check_New_Line;
+ State.Action_List.Insert (Node_I);
end;
exit when Actions_Done;
- Node_I.Next := new Action_Node;
- Node_I := Node_I.Next;
end loop;
end;
@@ -722,36 +544,34 @@ package body WisiToken.Parse.LR is
-- No Gotos
null;
else
+ State.Goto_List.Set_Capacity (Next_Count_Type);
declare
- Node_I : Goto_Node_Ptr := new Goto_Node;
+ Node : Goto_Node;
begin
- State.Goto_List := Node_I;
loop
- Node_I.Symbol := Next_Token_ID;
- Node_I.State := Next_State_Index;
+ Node.Symbol := Next_Token_ID;
+ Node.State := Next_State_Index;
+ State.Goto_List.Insert (Node);
exit when Check_Semicolon;
- Node_I.Next := new Goto_Node;
- Node_I := Node_I.Next;
end loop;
end;
end if;
Check_New_Line;
declare
- First : constant Integer := Next_Integer;
- Last : constant Integer := Next_Integer;
+ First : constant Count_Type := Next_Count_Type;
+ Last : constant Integer := Next_Integer;
begin
if Last = -1 then
-- State.Kernel not set for state 0
null;
else
- State.Kernel.Set_First (Count_Type (First));
- State.Kernel.Set_Last (Count_Type (Last));
+ State.Kernel.Set_First_Last (First, Count_Type (Last));
for I in State.Kernel.First_Index .. State.Kernel.Last_Index
loop
State.Kernel (I).LHS := Next_Token_ID;
State.Kernel (I).Before_Dot := Next_Token_ID;
- State.Kernel (I).Length_After_Dot := Count_Type
(Next_Integer);
+ State.Kernel (I).Length_After_Dot := Next_Count_Type;
end loop;
end if;
end;
@@ -761,8 +581,12 @@ package body WisiToken.Parse.LR is
-- No minimal action
null;
else
- State.Minimal_Complete_Actions.Set_First (Count_Type
(Next_Integer));
- State.Minimal_Complete_Actions.Set_Last (Count_Type
(Next_Integer));
+ declare
+ First : constant Count_Type := Next_Count_Type;
+ Last : constant Count_Type := Next_Count_Type;
+ begin
+ State.Minimal_Complete_Actions.Set_First_Last (First, Last);
+ end;
for I in State.Minimal_Complete_Actions.First_Index ..
State.Minimal_Complete_Actions.Last_Index loop
declare
Verb : constant Minimal_Verbs :=
Next_Parse_Action_Verbs;
@@ -788,6 +612,9 @@ package body WisiToken.Parse.LR is
exit when Check_EOI;
end loop;
+
+ Table.Error_Action := new Parse_Action_Node'((Verb => Error), null);
+
return Table;
end;
exception
@@ -830,40 +657,79 @@ package body WisiToken.Parse.LR is
Left.Ins_Token_Index = Right.Ins_Token_Index;
end Equal;
- function None_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
- is begin
- for O of reverse Ops loop
- exit when O.Op = Fast_Forward;
- if O.Op = Op then
+ function None (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
+ is
+ use Config_Op_Arrays, Config_Op_Array_Refs;
+ begin
+ for I in First_Index (Ops) .. Last_Index (Ops) loop
+ if Constant_Ref (Ops, I).Op /= Op then
return False;
end if;
end loop;
return True;
+ end None;
+
+ function None_Since_FF (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
+ is
+ use Config_Op_Arrays, Config_Op_Array_Refs;
+ begin
+ for I in reverse First_Index (Ops) .. Last_Index (Ops) loop
+ declare
+ O : Config_Op renames Constant_Ref (Ops, I);
+ begin
+ exit when O.Op = Fast_Forward;
+ if O.Op = Op then
+ return False;
+ end if;
+ end;
+ end loop;
+ return True;
end None_Since_FF;
- function Only_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
+ function Only_Since_FF (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
is
+ use Config_Op_Arrays, Config_Op_Array_Refs;
use all type Ada.Containers.Count_Type;
begin
- if Ops.Length = 0 or else Ops (Ops.Last_Index).Op /= Op then
+ if Length (Ops) = 0 or else Constant_Ref (Ops, Last_Index (Ops)).Op /=
Op then
return False;
else
- for O of reverse Ops loop
- exit when O.Op = Fast_Forward;
- if O.Op /= Op then
- return False;
- end if;
+ for I in reverse First_Index (Ops) .. Last_Index (Ops) loop
+ declare
+ O : Config_Op renames Constant_Ref (Ops, I);
+ begin
+ exit when O.Op = Fast_Forward;
+ if O.Op /= Op then
+ return False;
+ end if;
+ end;
end loop;
return True;
end if;
end Only_Since_FF;
+ function Any (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
+ is
+ use Config_Op_Arrays, Config_Op_Array_Refs;
+ begin
+ for I in First_Index (Ops) .. Last_Index (Ops) loop
+ declare
+ O : Config_Op renames Constant_Ref (Ops, I);
+ begin
+ if O.Op = Op then
+ return True;
+ end if;
+ end;
+ end loop;
+ return False;
+ end Any;
+
function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean
is
use all type WisiToken.Syntax_Trees.Node_Index;
begin
for I in 1 .. Depth loop
- if Stack (I).Tree_Index = Syntax_Trees.Invalid_Node_Index then
+ if Stack.Peek (I).Tree_Index = Syntax_Trees.Invalid_Node_Index then
return False;
end if;
end loop;
diff --git a/wisitoken-parse-lr.ads b/wisitoken-parse-lr.ads
index 91b55c8..76a02d5 100644
--- a/wisitoken-parse-lr.ads
+++ b/wisitoken-parse-lr.ads
@@ -37,15 +37,19 @@ pragma License (Modified_GPL);
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Unchecked_Deallocation;
with SAL.Gen_Array_Image;
+with SAL.Gen_Bounded_Definite_Stacks.Gen_Image_Aux;
with SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux;
-with SAL.Gen_Bounded_Definite_Vectors.Gen_Sorted;
+with SAL.Gen_Bounded_Definite_Vectors.Gen_Refs;
+with SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Image_Aux;
+with SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Refs;
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 SAL.Gen_Unbounded_Definite_Vectors_Sorted;
with System.Multiprocessors;
with WisiToken.Semantic_Checks;
with WisiToken.Syntax_Trees;
package WisiToken.Parse.LR is
+ use all type SAL.Base_Peek_Type;
type All_Parse_Action_Verbs is (Pause, Shift, Reduce, Accept_It, Error);
subtype Parse_Action_Verbs is All_Parse_Action_Verbs range Shift .. Error;
@@ -54,7 +58,7 @@ package WisiToken.Parse.LR is
-- to re-sync on the same input terminal.
subtype Token_ID_Array_1_3 is Token_ID_Array (1 .. 3);
- -- For Use_Minimal_Complete_Actions in McDenzie_Recover.
+ -- For Language_Matching_Begin_Tokens.
type Parse_Action_Rec (Verb : Parse_Action_Verbs := Shift) is record
case Verb is
@@ -99,33 +103,33 @@ package WisiToken.Parse.LR is
function Is_In (Item : in Parse_Action_Rec; List : in
Parse_Action_Node_Ptr) return Boolean;
-- True if Item is Equal to any element of List.
- type Action_Node;
- type Action_Node_Ptr is access Action_Node;
-
type Action_Node is record
- Symbol : Token_ID := Invalid_Token_ID; -- ignored if Action is Error
- Action : Parse_Action_Node_Ptr;
- Next : Action_Node_Ptr;
+ Symbol : Token_ID := Invalid_Token_ID; -- ignored if Action is Error
+ Actions : Parse_Action_Node_Ptr;
end record;
- procedure Free is new Ada.Unchecked_Deallocation (Action_Node,
Action_Node_Ptr);
- function Find
- (Symbol : in Token_ID;
- Action_List : in Action_Node_Ptr)
- return Action_Node_Ptr;
+ function To_Key (Item : in Action_Node) return Token_ID is (Item.Symbol);
+
+ function Compare (Left, Right : in Token_ID) return SAL.Compare_Result;
+
+ package Action_Arrays is new SAL.Gen_Unbounded_Definite_Vectors_Sorted
+ (Action_Node, Token_ID, To_Key, Compare);
procedure Add
- (List : in out Action_Node_Ptr;
+ (List : in out Action_Arrays.Vector;
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;
+ type Goto_Node is record
+ Symbol : Token_ID;
+ State : State_Index;
+ end record;
+
+ function To_Key (Item : in Goto_Node) return Token_ID is (Item.Symbol);
- 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;
+ package Goto_Arrays is new SAL.Gen_Unbounded_Definite_Vectors_Sorted
+ (Goto_Node, Token_ID, To_Key, Compare);
type Kernel_Info is record
LHS : Token_ID := Token_ID'First;
@@ -172,8 +176,8 @@ package WisiToken.Parse.LR is
function Strict_Image is new Minimal_Action_Arrays.Gen_Image (Strict_Image);
type Parse_State is record
- Action_List : Action_Node_Ptr;
- Goto_List : Goto_Node_Ptr;
+ Action_List : Action_Arrays.Vector;
+ Goto_List : Goto_Arrays.Vector;
-- The following are used in error recovery.
Kernel : Kernel_Info_Arrays.Vector;
@@ -188,17 +192,6 @@ package WisiToken.Parse.LR is
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;
@@ -234,9 +227,6 @@ package WisiToken.Parse.LR is
Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
-- Add a Reduce conflict to State.
- procedure Add_Error (State : in out Parse_State);
- -- Add an Error action to State, at tail of action list.
-
procedure Add_Goto
(State : in out Parse_State;
Symbol : in Token_ID;
@@ -306,6 +296,7 @@ package WisiToken.Parse.LR is
is tagged
record
States : Parse_State_Array (State_First .. State_Last);
+ Error_Action : Parse_Action_Node_Ptr;
McKenzie_Param : McKenzie_Param_Type (First_Terminal, Last_Terminal,
First_Nonterminal, Last_Nonterminal);
end record;
@@ -314,11 +305,6 @@ package WisiToken.Parse.LR is
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.
@@ -327,11 +313,19 @@ package WisiToken.Parse.LR is
(Table : in Parse_Table;
State : in State_Index;
ID : in Token_ID)
- return Parse_Action_Node_Ptr;
+ return Parse_Action_Node_Ptr
+ with Post => Action_For'Result /= null;
-- Return the action for State, terminal ID.
function Expecting (Table : in Parse_Table; State : in State_Index) return
Token_ID_Set;
+ function McKenzie_Defaulted (Table : in Parse_Table) return Boolean is
+ -- We can't use Table.McKenzie_Param = Default_McKenzie_Param here,
+ -- because the discriminants are different.
+ (Table.McKenzie_Param.Check_Limit = Default_McKenzie_Param.Check_Limit and
+ Table.McKenzie_Param.Check_Delta_Limit =
Default_McKenzie_Param.Check_Delta_Limit and
+ Table.McKenzie_Param.Enqueue_Limit =
Default_McKenzie_Param.Enqueue_Limit);
+
type Parse_Table_Ptr is access Parse_Table;
procedure Free_Table (Table : in out Parse_Table_Ptr);
@@ -372,8 +366,8 @@ package WisiToken.Parse.LR is
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));
+ is (SAL.Peek_Type'Image (Index) & ":" & SAL.Peek_Type'Image
(Fast_Token_ID_Arrays.Last_Index (Tokens)) & ":" &
+ Image (Fast_Token_ID_Arrays.Element (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;
@@ -470,6 +464,8 @@ package WisiToken.Parse.LR is
-- config does hit that limit, it is abandoned; some other config is
-- likely to be cheaper.
+ package Config_Op_Array_Refs is new Config_Op_Arrays.Gen_Refs;
+
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
@@ -495,28 +491,26 @@ package WisiToken.Parse.LR is
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);
+ function None (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
-- True if Ops contains no Op.
- function None_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
+ function None_Since_FF (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
-- True if Ops contains no Op after the last Fast_Forward (or ops.first, if
-- no Fast_Forward).
- function Only_Since_FF (Ops : in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
+ function Only_Since_FF (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
-- True if Ops contains only Op (at least one) after the last Fast_Forward
(or ops.first, if
-- no Fast_Forward).
- function Any (Ops : in Config_Op_Arrays.Vector; Op : in Config_Op_Label)
return Boolean
- is (for some O of Ops => O.Op = Op);
+ function Any (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
-- True if Ops contains at least one Op.
- package Insert_Delete_Arrays is new SAL.Gen_Bounded_Definite_Vectors
- (Positive_Index_Type, Insert_Delete_Op, Capacity => 80);
+ package Sorted_Insert_Delete_Arrays is new
SAL.Gen_Bounded_Definite_Vectors_Sorted
+ (Insert_Delete_Op, Compare, Capacity => 80);
- package Sorted_Insert_Delete_Arrays is new Insert_Delete_Arrays.Gen_Sorted
(Compare);
+ package Insert_Delete_Array_Refs is new
Sorted_Insert_Delete_Arrays.Gen_Refs;
- function Image is new Insert_Delete_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
+ function Image is new Sorted_Insert_Delete_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
type Recover_Stack_Item is record
State : Unknown_State_Index;
@@ -530,7 +524,7 @@ package WisiToken.Parse.LR is
-- during recover.
end record;
- package Recover_Stacks is new SAL.Gen_Unbounded_Definite_Stacks
(Recover_Stack_Item);
+ package Recover_Stacks is new SAL.Gen_Bounded_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)) & " : " &
@@ -546,7 +540,8 @@ package WisiToken.Parse.LR is
return String
renames Recover_Stack_Image;
- function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean;
+ function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean with
+ Pre => Stack.Depth >= Depth;
-- 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.
@@ -559,9 +554,15 @@ package WisiToken.Parse.LR is
type Minimal_Complete_State is (None, Active, Done);
type Configuration is record
- Stack : Recover_Stacks.Stack;
+ Stack : Recover_Stacks.Stack (70);
-- Initially built from the parser stack, then the stack after the
-- Ops below have been performed.
+ --
+ -- Required size is determined by source code structure nesting;
+ -- larger size slows down recover due to memory cache thrashing and
+ -- allocation.
+ --
+ -- Emacs Ada mode wisi.adb needs > 50
Resume_Token_Goal : WisiToken.Token_Index := WisiToken.Token_Index'Last;
-- A successful solution shifts this token. Per-config because it
@@ -575,7 +576,7 @@ package WisiToken.Parse.LR is
String_Quote_Checked : Line_Number_Type := Invalid_Line_Number;
-- Max line checked for missing string quote.
- Insert_Delete : Sorted_Insert_Delete_Arrays.Vector;
+ Insert_Delete : aliased 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.
@@ -599,7 +600,7 @@ package WisiToken.Parse.LR is
-- in explore when adding an op, or in language_fixes when adding a
-- fix).
- Ops : Config_Op_Arrays.Vector;
+ Ops : aliased 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.
@@ -612,8 +613,6 @@ package WisiToken.Parse.LR is
Minimal_Complete_State : LR.Minimal_Complete_State := None;
Matching_Begin_Done : Boolean := False;
end record;
- type Configuration_Access is access all Configuration;
- for Configuration_Access'Storage_Size use 0;
function Key (A : in Configuration) return Integer is (A.Cost);
@@ -621,7 +620,6 @@ package WisiToken.Parse.LR is
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);
@@ -666,18 +664,4 @@ package WisiToken.Parse.LR is
package Parse_Error_Lists is new
Ada.Containers.Indefinite_Doubly_Linked_Lists (Parse_Error);
-private
-
- type Goto_Node is record
- Symbol : Token_ID;
- State : State_Index;
- Next : Goto_Node_Ptr;
- end record;
- procedure Free is new Ada.Unchecked_Deallocation (Goto_Node, Goto_Node_Ptr);
-
- type Action_List_Iterator is tagged record
- Node : Action_Node_Ptr;
- Item : Parse_Action_Node_Ptr;
- end record;
-
end WisiToken.Parse.LR;
diff --git a/wisitoken-parse-packrat-generated.adb
b/wisitoken-parse-packrat-generated.adb
index 0c909e5..f5f4b16 100644
--- a/wisitoken-parse-packrat-generated.adb
+++ b/wisitoken-parse-packrat-generated.adb
@@ -35,13 +35,11 @@ package body WisiToken.Parse.Packrat.Generated is
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);
+ Parser.Derivs.Set_First_Last (Descriptor.First_Nonterminal,
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);
+ Parser.Derivs (Nonterm).Set_First_Last (Parser.Terminals.First_Index,
Parser.Terminals.Last_Index);
end loop;
for Token_Index in Parser.Terminals.First_Index ..
Parser.Terminals.Last_Index loop
diff --git a/wisitoken-parse-packrat-procedural.adb
b/wisitoken-parse-packrat-procedural.adb
index 1f00e48..97f71ff 100644
--- a/wisitoken-parse-packrat-procedural.adb
+++ b/wisitoken-parse-packrat-procedural.adb
@@ -224,15 +224,12 @@ package body WisiToken.Parse.Packrat.Procedural is
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_First_Last (Parser.Terminals.First_Index,
Parser.Terminals.Last_Index + 1);
-- 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);
diff --git a/wisitoken-parse.adb b/wisitoken-parse.adb
index 09280d9..ee7b1e8 100644
--- a/wisitoken-parse.adb
+++ b/wisitoken-parse.adb
@@ -38,12 +38,12 @@ package body WisiToken.Parse is
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.Set_First_Last (Line_Number_Type'First,
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.EOI_ID then
- Parser.Line_Begin_Token.Set_Length (Ada.Containers.Count_Type
(Token.Line + 1));
+ Parser.Line_Begin_Token.Set_First_Last (Line_Number_Type'First,
Token.Line + 1);
Parser.Line_Begin_Token (Token.Line + 1) :=
Parser.Terminals.Last_Index + 1;
end if;
end if;
diff --git a/wisitoken-syntax_trees-lr_utils.adb
b/wisitoken-syntax_trees-lr_utils.adb
new file mode 100644
index 0000000..a456d82
--- /dev/null
+++ b/wisitoken-syntax_trees-lr_utils.adb
@@ -0,0 +1,220 @@
+-- Abstract :
+--
+-- See spec.
+--
+-- Copyright (C) 2019 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- 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.Syntax_Trees.LR_Utils is
+
+ procedure Raise_Programmer_Error
+ (Label : in String;
+ Descriptor : in WisiToken.Descriptor;
+ Lexer : in WisiToken.Lexer.Handle;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Terminals : in WisiToken.Base_Token_Arrays.Vector;
+ Node : in WisiToken.Syntax_Trees.Node_Index)
+ is
+ Terminal_Index : constant Base_Token_Index := Tree.Min_Terminal_Index
(Node);
+ begin
+ raise SAL.Programmer_Error with Error_Message
+ (Lexer.File_Name,
+ (if Terminal_Index = Invalid_Token_Index then 1 else Terminals
(Terminal_Index).Line), 0,
+ Label & Node'Image & ":" & Tree.Image (Node, Descriptor,
Include_Children => True));
+ end Raise_Programmer_Error;
+
+ function Has_Element (Cursor : in LR_Utils.Cursor) return Boolean is
(Cursor.Node /= Invalid_Node_Index);
+
+ function Node (Cursor : in LR_Utils.Cursor) return Node_Index is
(Cursor.Node);
+
+ overriding function First (Iter : Iterator) return Cursor
+ is begin
+ return Result : Cursor do
+ Result.Node := Iter.Root;
+ loop
+ declare
+ Children : constant Valid_Node_Index_Array :=
Iter.Tree.Children (Result.Node);
+ begin
+ if Iter.Tree.ID (Children (1)) = Iter.List_ID then
+ Result.Node := Children (1);
+ elsif Iter.Tree.ID (Children (1)) = Iter.Element_ID then
+ Result.Node := Children (1);
+ exit;
+ else
+ Raise_Programmer_Error
+ ("first_list_element", Iter.Descriptor.all, Iter.Lexer,
Iter.Tree, Iter.Terminals.all, Result.Node);
+ end if;
+ end;
+ end loop;
+ end return;
+ end First;
+
+ overriding function Last (Iter : Iterator) return Cursor
+ is
+ -- Tree is one of:
+ --
+ -- case a: single element list
+ -- element_list : root
+ -- | element: Last
+ --
+ -- case c: no next
+ -- element_list: root
+ -- | element_list
+ -- | | element:
+ -- | element: Last
+ Children : constant Valid_Node_Index_Array := Iter.Tree.Children
(Iter.Root);
+ begin
+ return (Node => Children (Children'Last));
+ end Last;
+
+ overriding function Next (Iter : Iterator; Position : Cursor) return Cursor
+ is begin
+ if Position.Node = Invalid_Node_Index then
+ return Position;
+ else
+ return Result : Cursor do
+ declare
+ use all type SAL.Base_Peek_Type;
+ -- Tree is one of:
+ --
+ -- case a: first element, no next
+ -- rhs
+ -- | rhs_item_list
+ -- | | rhs_item: Element
+ -- | action
+ --
+ -- case b: first element, next
+ -- rhs_item_list
+ -- | rhs_item_list
+ -- | | rhs_item: Element
+ -- | rhs_item: next element
+ --
+ -- case c: non-first element, no next
+ -- rhs
+ -- | rhs_item_list : Grand_Parent
+ -- | | rhs_item_list
+ -- | | | rhs_item:
+ -- | | rhs_item: Element
+ -- | action : Aunt
+ --
+ -- case d: non-first element, next
+ -- rhs_item_list
+ -- | rhs_item_list : Grand_Parent
+ -- | | rhs_item_list
+ -- | | | rhs_item:
+ -- | | rhs_item: Element
+ -- | rhs_item: next element : Aunt
+
+ Grand_Parent : constant Valid_Node_Index :=
Iter.Tree.Parent (Position.Node, 2);
+ Aunts : constant Valid_Node_Index_Array :=
Iter.Tree.Children (Grand_Parent);
+ Last_List_Child : SAL.Base_Peek_Type :=
Aunts'First - 1;
+ begin
+ if Iter.Tree.ID (Grand_Parent) /= Iter.List_ID then
+ -- No next
+ Result.Node := Invalid_Node_Index;
+ else
+ for I in Aunts'Range loop
+ if Iter.Tree.ID (Aunts (I)) in Iter.List_ID |
Iter.Element_ID then
+ Last_List_Child := I;
+ end if;
+ end loop;
+
+ if Last_List_Child = 1 then
+ -- No next
+ Result.Node := Invalid_Node_Index;
+ else
+ Result.Node := Aunts (Last_List_Child);
+ end if;
+ end if;
+ end;
+ end return;
+ end if;
+ end Next;
+
+ overriding function Previous (Iter : Iterator; Position : Cursor) return
Cursor
+ is begin
+ if Position.Node = Invalid_Node_Index then
+ return Position;
+ else
+ return Result : Cursor do
+ -- Tree is one of:
+ --
+ -- case a: first element, no prev
+ -- ?
+ -- | rhs_item_list
+ -- | | rhs_item: Element
+ --
+ -- case b: second element
+ -- ?
+ -- | rhs_item_list
+ -- | | rhs_item: prev item
+ -- | rhs_item: Element
+ --
+ -- case c: nth element
+ -- ?
+ -- | rhs_item_list
+ -- | | rhs_item_list
+ -- | | | rhs_item:
+ -- | | rhs_item: prev element
+ -- | rhs_item: Element
+ declare
+ Parent : constant Valid_Node_Index := Iter.Tree.Parent
(Position.Node);
+ begin
+ if Position.Node = Iter.Tree.Child (Parent, 1) then
+ -- No prev
+ Result.Node := Invalid_Node_Index;
+
+ else
+ declare
+ Prev_Children : constant Valid_Node_Index_Array :=
Iter.Tree.Children
+ (Iter.Tree.Child (Parent, 1));
+ begin
+ Result.Node := Prev_Children (Prev_Children'Last);
+ end;
+ end if;
+ end;
+ end return;
+ end if;
+ end Previous;
+
+ function Iterate
+ (Tree : in WisiToken.Syntax_Trees.Tree;
+ Terminals : in WisiToken.Base_Token_Array_Access;
+ Lexer : in WisiToken.Lexer.Handle;
+ Descriptor : in WisiToken.Descriptor_Access_Constant;
+ Root : in Valid_Node_Index;
+ Element_ID : in WisiToken.Token_ID;
+ Separator_ID : in WisiToken.Token_ID := WisiToken.Invalid_Token_ID)
+ return Iterator_Interfaces.Reversible_Iterator'Class
+ is begin
+ return Iterator'
+ (Iterator_Interfaces.Reversible_Iterator with
+ Tree, Terminals, Lexer, Descriptor, Root,
+ List_ID => Tree.ID (Root),
+ Element_ID => Element_ID,
+ Separator_ID => Separator_ID);
+ end Iterate;
+
+ function Count (Iter : Iterator) return Ada.Containers.Count_Type
+ is
+ use Ada.Containers;
+ Result : Count_Type := 0;
+ begin
+ for Item in Iter loop
+ Result := Result + 1;
+ end loop;
+ return Result;
+ end Count;
+
+end WisiToken.Syntax_Trees.LR_Utils;
diff --git a/wisitoken-syntax_trees-lr_utils.ads
b/wisitoken-syntax_trees-lr_utils.ads
new file mode 100644
index 0000000..9033f49
--- /dev/null
+++ b/wisitoken-syntax_trees-lr_utils.ads
@@ -0,0 +1,88 @@
+-- Abstract :
+--
+-- Utilities for navigating syntax trees produced by an LR parser.
+--
+-- Copyright (C) 2019 Stephen Leake All Rights Reserved.
+--
+-- This library is free software; you can redistribute it and/or modify it
+-- under terms of the GNU General Public License as published by the Free
+-- 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;
+package WisiToken.Syntax_Trees.LR_Utils is
+
+ procedure Raise_Programmer_Error
+ (Label : in String;
+ Descriptor : in WisiToken.Descriptor;
+ Lexer : in WisiToken.Lexer.Handle;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Terminals : in WisiToken.Base_Token_Arrays.Vector;
+ Node : in WisiToken.Syntax_Trees.Node_Index);
+ pragma No_Return (Raise_Programmer_Error);
+
+ ----------
+ -- List functions
+ --
+ -- A list has one of the following grammar forms:
+ --
+ -- list : list element | element ;
+ -- list : element | list element ;
+ --
+ -- list : list separator element | element ;
+ -- list : element | list separator element ;
+
+ type Cursor is private;
+ function Has_Element (Cursor : in LR_Utils.Cursor) return Boolean;
+
+ function Node (Cursor : in LR_Utils.Cursor) return Node_Index;
+
+ package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
+
+ type Iterator is new Iterator_Interfaces.Reversible_Iterator with private;
+
+ overriding function First (Iter : Iterator) return Cursor;
+ overriding function Last (Iter : Iterator) return Cursor;
+
+ overriding function Next (Iter : Iterator; Position : Cursor) return Cursor;
+
+ overriding function Previous (Iter : Iterator; Position : Cursor) return
Cursor;
+
+ function Iterate
+ (Tree : in WisiToken.Syntax_Trees.Tree;
+ Terminals : in WisiToken.Base_Token_Array_Access;
+ Lexer : in WisiToken.Lexer.Handle;
+ Descriptor : in WisiToken.Descriptor_Access_Constant;
+ Root : in Valid_Node_Index;
+ Element_ID : in WisiToken.Token_ID;
+ Separator_ID : in WisiToken.Token_ID := WisiToken.Invalid_Token_ID)
+ return Iterator_Interfaces.Reversible_Iterator'Class;
+
+ function Count (Iter : Iterator) return Ada.Containers.Count_Type;
+
+private
+
+ type Cursor is record
+ Node : Node_Index;
+ end record;
+
+ type Iterator is new Iterator_Interfaces.Reversible_Iterator with record
+ Tree : WisiToken.Syntax_Trees.Tree;
+ Terminals : WisiToken.Base_Token_Array_Access;
+ Lexer : WisiToken.Lexer.Handle;
+ Descriptor : WisiToken.Descriptor_Access_Constant;
+ Root : Valid_Node_Index;
+ List_ID : WisiToken.Token_ID;
+ Element_ID : WisiToken.Token_ID;
+ Separator_ID : WisiToken.Token_ID;
+ end record;
+
+end WisiToken.Syntax_Trees.LR_Utils;
diff --git a/wisitoken-syntax_trees.adb b/wisitoken-syntax_trees.adb
index e8ac152..abcc4d8 100644
--- a/wisitoken-syntax_trees.adb
+++ b/wisitoken-syntax_trees.adb
@@ -229,7 +229,10 @@ package body WisiToken.Syntax_Trees is
is
function Compute (N : in Syntax_Trees.Node) return Node_Index
is begin
- if Child_Index in N.Children.First_Index .. N.Children.Last_Index then
+ if N.Label /= Nonterm then
+ return Invalid_Node_Index;
+
+ elsif Child_Index in N.Children.First_Index .. N.Children.Last_Index
then
return N.Children (Child_Index);
else
return Invalid_Node_Index;
@@ -244,9 +247,7 @@ package body WisiToken.Syntax_Trees is
end Child;
function Children (N : in Syntax_Trees.Node) return Valid_Node_Index_Array
- is
- use all type Ada.Containers.Count_Type;
- begin
+ is begin
if N.Children.Length = 0 then
return (1 .. 0 => <>);
else
@@ -355,7 +356,7 @@ package body WisiToken.Syntax_Trees is
end loop;
if Last_Index = SAL.Base_Peek_Type'Last then
- New_Children.Set_Length (Children'Length);
+ New_Children.Set_First_Last (Children'First,
Children'Last);
for I in Children'Range loop
New_Children (I) := Copy_Node (Tree, Children (I),
Parent);
end loop;
@@ -488,6 +489,7 @@ package body WisiToken.Syntax_Trees is
end if;
Tree.Branched_Nodes.Finalize;
Tree.Last_Shared_Node := Invalid_Node_Index;
+ Tree.Shared_Tree := null;
end if;
end Finalize;
@@ -592,7 +594,31 @@ package body WisiToken.Syntax_Trees is
end if;
end Process;
- Junk : constant Boolean := Process_Tree (Tree, Node, After,
Process'Access);
+ Junk : constant Boolean := Process_Tree (Tree, Node, Before,
Process'Access);
+ pragma Unreferenced (Junk);
+ begin
+ return Found;
+ end Find_Descendant;
+
+ function Find_Descendant
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Predicate : access function (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean)
+ 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 begin
+ if Predicate (Tree, Node) then
+ Found := Node;
+ return False;
+ else
+ return True;
+ end if;
+ end Process;
+
+ Junk : constant Boolean := Process_Tree (Tree, Node, Before,
Process'Access);
pragma Unreferenced (Junk);
begin
return Found;
@@ -871,16 +897,12 @@ package body WisiToken.Syntax_Trees is
end First_Terminal_ID;
function Has_Branched_Nodes (Tree : in Syntax_Trees.Tree) return Boolean
- is
- use all type Ada.Containers.Count_Type;
- begin
+ is 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
+ is begin
if Node <= Tree.Last_Shared_Node then
return Tree.Shared_Tree.Nodes (Node).Children.Length > 0;
else
@@ -1438,7 +1460,7 @@ package body WisiToken.Syntax_Trees is
Min_Terminal_Index_Set : Boolean := False;
begin
- N.Children.Set_Length (Children'Length);
+ N.Children.Set_First_Last (Children'First, Children'Last);
for I in Children'Range loop
N.Children (J) := Children (I);
declare
@@ -1516,7 +1538,7 @@ package body WisiToken.Syntax_Trees is
Parent_Node.RHS_Index := New_ID.RHS;
Parent_Node.Action := null;
- Parent_Node.Children.Set_Length (Children'Length);
+ Parent_Node.Children.Set_First_Last (Children'First, Children'Last);
for I in Children'Range loop
-- We don't update Min/Max_terminal_index; we assume Set_Children is
-- only called after parsing is done, so they are no longer needed.
@@ -1544,8 +1566,10 @@ package body WisiToken.Syntax_Trees is
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);
+ if Tree.Flush then
+ Tree.Flush := False;
+ Tree.Branched_Nodes.Set_First_Last (Tree.Last_Shared_Node + 1,
Tree.Last_Shared_Node);
+ end if;
end Set_Flush_False;
procedure Set_Name_Region
diff --git a/wisitoken-syntax_trees.ads b/wisitoken-syntax_trees.ads
index dcca9b4..85fd2c5 100644
--- a/wisitoken-syntax_trees.ads
+++ b/wisitoken-syntax_trees.ads
@@ -205,7 +205,7 @@ package WisiToken.Syntax_Trees is
procedure Set_Children
(Tree : in out Syntax_Trees.Tree;
Node : in Valid_Node_Index;
- New_ID : in WisiToken.Production_ID;
+ New_ID : in WisiToken.Production_ID;
Children : in Valid_Node_Index_Array)
with
Pre => Tree.Flushed and
@@ -370,6 +370,14 @@ package WisiToken.Syntax_Trees is
-- Return the descendant of Node (may be Node) whose ID is ID, or
-- Invalid_Node_Index if none match.
+ function Find_Descendant
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Predicate : access function (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean)
+ return Node_Index;
+ -- Return the descendant of Node (may be Node) for which Predicate
+ -- returns True, or Invalid_Node_Index if none do.
+
function Find_Min_Terminal_Index
(Tree : in Syntax_Trees.Tree;
Index : in Token_Index)
@@ -467,6 +475,7 @@ package WisiToken.Syntax_Trees is
-- Text_IO.Current_Output, for debugging.
private
+ use all type Ada.Containers.Count_Type;
type Node (Label : Node_Label := Virtual_Terminal) is
-- Label has a default to allow changing the label during tree editing.
@@ -562,6 +571,12 @@ private
Root : Node_Index := Invalid_Node_Index;
end record with
- Type_Invariant => (if Tree.Flush then not Tree.Has_Branched_Nodes);
+ Type_Invariant =>
+ (Shared_Tree = null or else
+ (if Tree.Flush
+ then Last_Shared_Node = Shared_Tree.Nodes.Last_Index and
+ Branched_Nodes.Length = 0
+ else Last_Shared_Node <= Shared_Tree.Nodes.Last_Index and
+ Last_Shared_Node < Branched_Nodes.First_Index));
end WisiToken.Syntax_Trees;
diff --git a/wisitoken-wisi_ada.adb b/wisitoken-wisi_ada.adb
index 4a098c8..34dad7c 100644
--- a/wisitoken-wisi_ada.adb
+++ b/wisitoken-wisi_ada.adb
@@ -2,7 +2,7 @@
--
-- see spec
--
--- Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+-- Copyright (C) 2013, 2014, 2015, 2017 - 2019 Free Software Foundation, Inc.
--
-- This file is part of the WisiToken package.
--
@@ -85,8 +85,7 @@ package body WisiToken.Wisi_Ada is
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.Set_First_Last (Subject.LHS, Subject.LHS);
Result (Subject.LHS) := Subject;
end return;
end Only;
@@ -96,7 +95,7 @@ package body WisiToken.Wisi_Ada 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));
+ Result.RHSs.Set_First_Last (Result.RHSs.First_Index,
Left.RHSs.Last_Index + Integer (Right.RHSs.Length));
for RHS of Right.RHSs loop
Result.RHSs (Index) := RHS;
Index := Index + 1;
@@ -107,8 +106,7 @@ package body WisiToken.Wisi_Ada is
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));
+ Result.Set_First_Last (Token_ID'Min (Left.LHS, Right.LHS),
Token_ID'Max (Left.LHS, Right.LHS));
if Left.LHS = Right.LHS then
Result (Left.LHS) := Merge (Left, Right);
else
@@ -122,9 +120,9 @@ package body WisiToken.Wisi_Ada is
is begin
return Result : Prod_Arrays.Vector := Left do
if Right.LHS < Result.First_Index then
- Result.Set_First (Right.LHS);
+ Result.Set_First_Last (Right.LHS, Result.Last_Index);
elsif Right.LHS > Result.Last_Index then
- Result.Set_Last (Right.LHS);
+ Result.Set_First_Last (Result.First_Index, Right.LHS);
end if;
if Result (Right.LHS).LHS = Invalid_Token_ID then
@@ -139,14 +137,14 @@ package body WisiToken.Wisi_Ada is
is begin
return Result : Prod_Arrays.Vector := Left do
if Right.First_Index < Result.First_Index then
- Result.Set_First (Right.First_Index);
+ Result.Set_First_Last (Right.First_Index, Result.Last_Index);
elsif Right.First_Index > Result.Last_Index then
- Result.Set_Last (Right.First_Index);
+ Result.Set_First_Last (Result.First_Index, Right.First_Index);
end if;
if Right.Last_Index < Result.First_Index then
- Result.Set_First (Right.Last_Index);
+ Result.Set_First_Last (Right.Last_Index, Result.Last_Index);
elsif Right.Last_Index > Result.Last_Index then
- Result.Set_Last (Right.Last_Index);
+ Result.Set_First_Last (Result.First_Index, Right.Last_Index);
end if;
for P of Right loop
diff --git a/wisitoken.ads b/wisitoken.ads
index d4652b8..891fb26 100644
--- a/wisitoken.ads
+++ b/wisitoken.ads
@@ -310,6 +310,7 @@ package WisiToken is
end record;
type Base_Token_Class_Access is access all Base_Token'Class;
+ type Base_Token_Class_Access_Constant is access constant Base_Token'Class;
function Image
(Item : in Base_Token;
@@ -352,10 +353,11 @@ package WisiToken is
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.
+ -- enough information in the recover stack to perform
+ -- Semantic_Checks, Language_Fixes, and Push_Back operations. and to
+ -- apply the solution to the main parser state. We make thousands of
+ -- copies of the parse stack during recover, so minimizing size and
+ -- compute time for this is critical.
ID : Token_ID := Invalid_Token_ID;
Byte_Region : Buffer_Region := Null_Buffer_Region;
@@ -372,8 +374,7 @@ package WisiToken is
Virtual : Boolean := True;
-- For terminals, True if inserted by recover. For nonterminals, True
- -- if any contained token has Virtual = True. Used by Semantic_Checks
- -- and push_back.
+ -- if any contained token has Virtual = True.
end record;
function Image
diff --git a/wisitoken_grammar_main.adb b/wisitoken_grammar_main.adb
index 7a2bb22..981e60c 100644
--- a/wisitoken_grammar_main.adb
+++ b/wisitoken_grammar_main.adb
@@ -49,13 +49,15 @@ package body Wisitoken_Grammar_Main is
declare
procedure Subr_1
is begin
+ Table.States (0).Action_List.Set_Capacity (2);
Add_Action (Table.States (0), 23, 1);
Add_Action (Table.States (0), 33, 2);
- Add_Error (Table.States (0));
+ Table.States (0).Goto_List.Set_Capacity (4);
Add_Goto (Table.States (0), 38, 3);
Add_Goto (Table.States (0), 43, 4);
Add_Goto (Table.States (0), 55, 5);
Add_Goto (Table.States (0), 56, 6);
+ Table.States (1).Action_List.Set_Capacity (7);
Add_Action (Table.States (1), 3, 7);
Add_Action (Table.States (1), 4, 8);
Add_Action (Table.States (1), 5, 9);
@@ -63,33 +65,40 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (1), 7, 11);
Add_Action (Table.States (1), 8, 12);
Add_Action (Table.States (1), 33, 13);
- Add_Error (Table.States (1));
+ Table.States (1).Goto_List.Set_Capacity (1);
Add_Goto (Table.States (1), 39, 14);
+ Table.States (2).Action_List.Set_Capacity (2);
Add_Action (Table.States (2), 13, 15);
Add_Action (Table.States (2), 14, 16);
- Add_Error (Table.States (2));
+ Table.States (3).Action_List.Set_Capacity (3);
Add_Action (Table.States (3), (23, 33, 36), (55, 0), 1, null,
null);
+ Table.States (4).Action_List.Set_Capacity (3);
Add_Action (Table.States (4), (23, 33, 36), (55, 1), 1, null,
null);
+ Table.States (5).Action_List.Set_Capacity (3);
Add_Action (Table.States (5), (23, 33, 36), (56, 0), 1, null,
null);
+ Table.States (6).Action_List.Set_Capacity (3);
Add_Action (Table.States (6), 23, 1);
Add_Action (Table.States (6), 33, 2);
Add_Action (Table.States (6), 36, Accept_It, (37, 0), 1, null,
null);
- Add_Error (Table.States (6));
+ Table.States (6).Goto_List.Set_Capacity (3);
Add_Goto (Table.States (6), 38, 3);
Add_Goto (Table.States (6), 43, 4);
Add_Goto (Table.States (6), 55, 17);
+ Table.States (7).Action_List.Set_Capacity (1);
Add_Action (Table.States (7), 33, 18);
- Add_Error (Table.States (7));
+ Table.States (7).Goto_List.Set_Capacity (1);
Add_Goto (Table.States (7), 40, 19);
+ Table.States (8).Action_List.Set_Capacity (1);
Add_Action (Table.States (8), 5, 20);
- Add_Error (Table.States (8));
+ Table.States (9).Action_List.Set_Capacity (1);
Add_Action (Table.States (9), 33, 21);
- Add_Error (Table.States (9));
+ Table.States (10).Action_List.Set_Capacity (1);
Add_Action (Table.States (10), (1 => 33), (39, 0), 1, null, null);
+ Table.States (11).Action_List.Set_Capacity (1);
Add_Action (Table.States (11), 21, 22);
- Add_Error (Table.States (11));
+ Table.States (12).Action_List.Set_Capacity (1);
Add_Action (Table.States (12), 21, 23);
- Add_Error (Table.States (12));
+ Table.States (13).Action_List.Set_Capacity (13);
Add_Action (Table.States (13), 8, 24);
Add_Action (Table.States (13), 10, 25);
Add_Action (Table.States (13), 15, 26);
@@ -104,11 +113,12 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (13), 34, 33);
Add_Action (Table.States (13), 35, 34);
Add_Action (Table.States (13), 36, Reduce, (38, 3), 2,
declaration_3'Access, null);
- Add_Error (Table.States (13));
+ Table.States (13).Goto_List.Set_Capacity (2);
Add_Goto (Table.States (13), 41, 35);
Add_Goto (Table.States (13), 42, 36);
+ Table.States (14).Action_List.Set_Capacity (1);
Add_Action (Table.States (14), 33, 37);
- Add_Error (Table.States (14));
+ Table.States (15).Action_List.Set_Capacity (10);
Add_Action (Table.States (15), 12, Reduce, (46, 0), 0, null, null);
Add_Action (Table.States (15), 18, 38);
Add_Action (Table.States (15), 19, 39);
@@ -120,7 +130,7 @@ package body Wisitoken_Grammar_Main is
Add_Conflict (Table.States (15), 33, (46, 0), 0, null, null);
Add_Action (Table.States (15), 35, 43);
Add_Action (Table.States (15), 36, Reduce, (46, 0), 0, null, null);
- Add_Error (Table.States (15));
+ Table.States (15).Goto_List.Set_Capacity (9);
Add_Goto (Table.States (15), 45, 44);
Add_Goto (Table.States (15), 46, 45);
Add_Goto (Table.States (15), 47, 46);
@@ -130,6 +140,7 @@ package body Wisitoken_Grammar_Main is
Add_Goto (Table.States (15), 51, 50);
Add_Goto (Table.States (15), 52, 51);
Add_Goto (Table.States (15), 53, 52);
+ Table.States (16).Action_List.Set_Capacity (10);
Add_Action (Table.States (16), 12, Reduce, (46, 0), 0, null, null);
Add_Action (Table.States (16), 18, 38);
Add_Action (Table.States (16), 19, 39);
@@ -141,7 +152,7 @@ package body Wisitoken_Grammar_Main is
Add_Conflict (Table.States (16), 33, (46, 0), 0, null, null);
Add_Action (Table.States (16), 35, 43);
Add_Action (Table.States (16), 36, Reduce, (46, 0), 0, null, null);
- Add_Error (Table.States (16));
+ Table.States (16).Goto_List.Set_Capacity (9);
Add_Goto (Table.States (16), 45, 53);
Add_Goto (Table.States (16), 46, 45);
Add_Goto (Table.States (16), 47, 46);
@@ -151,40 +162,55 @@ package body Wisitoken_Grammar_Main is
Add_Goto (Table.States (16), 51, 50);
Add_Goto (Table.States (16), 52, 51);
Add_Goto (Table.States (16), 53, 52);
+ Table.States (17).Action_List.Set_Capacity (3);
Add_Action (Table.States (17), (23, 33, 36), (56, 1), 2, null,
null);
+ Table.States (18).Action_List.Set_Capacity (2);
Add_Action (Table.States (18), (9, 33), (40, 0), 1, null, null);
+ Table.States (19).Action_List.Set_Capacity (2);
Add_Action (Table.States (19), 9, 54);
Add_Action (Table.States (19), 33, 55);
- Add_Error (Table.States (19));
+ Table.States (20).Action_List.Set_Capacity (3);
Add_Action (Table.States (20), (23, 33, 36), (38, 5), 3,
declaration_5'Access, null);
+ Table.States (21).Action_List.Set_Capacity (1);
Add_Action (Table.States (21), 16, 56);
- Add_Error (Table.States (21));
+ Table.States (22).Action_List.Set_Capacity (1);
Add_Action (Table.States (22), 33, 57);
- Add_Error (Table.States (22));
+ Table.States (23).Action_List.Set_Capacity (1);
Add_Action (Table.States (23), 33, 58);
- Add_Error (Table.States (23));
+ Table.States (24).Action_List.Set_Capacity (13);
Add_Action (Table.States (24), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 10), 1, null,
null);
+ Table.States (25).Action_List.Set_Capacity (13);
Add_Action (Table.States (25), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 5), 1, null,
null);
+ Table.States (26).Action_List.Set_Capacity (13);
Add_Action (Table.States (26), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 0), 1, null,
null);
+ Table.States (27).Action_List.Set_Capacity (13);
Add_Action (Table.States (27), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 2), 1, null,
null);
+ Table.States (28).Action_List.Set_Capacity (13);
Add_Action (Table.States (28), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 3), 1, null,
null);
+ Table.States (29).Action_List.Set_Capacity (13);
Add_Action (Table.States (29), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 6), 1, null,
null);
+ Table.States (30).Action_List.Set_Capacity (13);
Add_Action (Table.States (30), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 7), 1, null,
null);
+ Table.States (31).Action_List.Set_Capacity (13);
Add_Action (Table.States (31), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 4), 1, null,
null);
+ Table.States (32).Action_List.Set_Capacity (13);
Add_Action (Table.States (32), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 1), 1, null,
null);
+ Table.States (33).Action_List.Set_Capacity (13);
Add_Action (Table.States (33), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 8), 1, null,
null);
+ Table.States (34).Action_List.Set_Capacity (13);
Add_Action (Table.States (34), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 9), 1, null,
null);
+ Table.States (35).Action_List.Set_Capacity (13);
Add_Action (Table.States (35), 8, 24);
Add_Action (Table.States (35), 10, 25);
Add_Action (Table.States (35), 15, 26);
@@ -199,10 +225,12 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (35), 34, 33);
Add_Action (Table.States (35), 35, 34);
Add_Action (Table.States (35), 36, Reduce, (38, 2), 3,
declaration_2'Access, null);
- Add_Error (Table.States (35));
+ Table.States (35).Goto_List.Set_Capacity (1);
Add_Goto (Table.States (35), 42, 59);
+ Table.States (36).Action_List.Set_Capacity (13);
Add_Action (Table.States (36), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (41, 0), 1, null,
null);
+ Table.States (37).Action_List.Set_Capacity (11);
Add_Action (Table.States (37), 8, 24);
Add_Action (Table.States (37), 10, 25);
Add_Action (Table.States (37), 15, 26);
@@ -214,16 +242,17 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (37), 33, 32);
Add_Action (Table.States (37), 34, 33);
Add_Action (Table.States (37), 35, 34);
- Add_Error (Table.States (37));
+ Table.States (37).Goto_List.Set_Capacity (2);
Add_Goto (Table.States (37), 41, 60);
Add_Goto (Table.States (37), 42, 36);
+ Table.States (38).Action_List.Set_Capacity (6);
Add_Action (Table.States (38), 18, 38);
Add_Action (Table.States (38), 19, 39);
Add_Action (Table.States (38), 20, 40);
Add_Action (Table.States (38), 21, 41);
Add_Action (Table.States (38), 33, 42);
Add_Action (Table.States (38), 35, 43);
- Add_Error (Table.States (38));
+ Table.States (38).Goto_List.Set_Capacity (8);
Add_Goto (Table.States (38), 47, 46);
Add_Goto (Table.States (38), 48, 47);
Add_Goto (Table.States (38), 49, 61);
@@ -232,13 +261,14 @@ package body Wisitoken_Grammar_Main is
Add_Goto (Table.States (38), 52, 51);
Add_Goto (Table.States (38), 53, 52);
Add_Goto (Table.States (38), 54, 62);
+ Table.States (39).Action_List.Set_Capacity (6);
Add_Action (Table.States (39), 18, 38);
Add_Action (Table.States (39), 19, 39);
Add_Action (Table.States (39), 20, 40);
Add_Action (Table.States (39), 21, 41);
Add_Action (Table.States (39), 33, 42);
Add_Action (Table.States (39), 35, 43);
- Add_Error (Table.States (39));
+ Table.States (39).Goto_List.Set_Capacity (8);
Add_Goto (Table.States (39), 47, 46);
Add_Goto (Table.States (39), 48, 47);
Add_Goto (Table.States (39), 49, 61);
@@ -247,13 +277,14 @@ package body Wisitoken_Grammar_Main is
Add_Goto (Table.States (39), 52, 51);
Add_Goto (Table.States (39), 53, 52);
Add_Goto (Table.States (39), 54, 63);
+ Table.States (40).Action_List.Set_Capacity (6);
Add_Action (Table.States (40), 18, 38);
Add_Action (Table.States (40), 19, 39);
Add_Action (Table.States (40), 20, 40);
Add_Action (Table.States (40), 21, 41);
Add_Action (Table.States (40), 33, 42);
Add_Action (Table.States (40), 35, 43);
- Add_Error (Table.States (40));
+ Table.States (40).Goto_List.Set_Capacity (8);
Add_Goto (Table.States (40), 47, 46);
Add_Goto (Table.States (40), 48, 47);
Add_Goto (Table.States (40), 49, 61);
@@ -262,8 +293,9 @@ package body Wisitoken_Grammar_Main is
Add_Goto (Table.States (40), 52, 51);
Add_Goto (Table.States (40), 53, 52);
Add_Goto (Table.States (40), 54, 64);
+ Table.States (41).Action_List.Set_Capacity (1);
Add_Action (Table.States (41), 33, 65);
- Add_Error (Table.States (41));
+ Table.States (42).Action_List.Set_Capacity (18);
Add_Action (Table.States (42), 11, Reduce, (50, 0), 1, null, null);
Add_Action (Table.States (42), 12, Reduce, (50, 0), 1, null, null);
Add_Action (Table.States (42), 16, 66);
@@ -282,7 +314,7 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (42), 33, Reduce, (50, 0), 1, null, null);
Add_Action (Table.States (42), 35, Reduce, (50, 0), 1, null, null);
Add_Action (Table.States (42), 36, Reduce, (50, 0), 1, null, null);
- Add_Error (Table.States (42));
+ Table.States (43).Action_List.Set_Capacity (15);
Add_Action (Table.States (43), 11, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
Add_Action (Table.States (43), 12, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
Add_Action (Table.States (43), 18, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
@@ -298,20 +330,24 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (43), 33, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
Add_Action (Table.States (43), 35, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
Add_Action (Table.States (43), 36, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Error (Table.States (43));
+ Table.States (44).Action_List.Set_Capacity (5);
Add_Action (Table.States (44), 12, 71);
Add_Action (Table.States (44), 23, 72);
Add_Conflict (Table.States (44), 23, (44, 1), 0, null, null);
Add_Action (Table.States (44), 29, 73);
Add_Action (Table.States (44), 33, Reduce, (44, 1), 0, null, null);
Add_Action (Table.States (44), 36, Reduce, (44, 1), 0, null, null);
- Add_Error (Table.States (44));
+ Table.States (44).Goto_List.Set_Capacity (1);
Add_Goto (Table.States (44), 44, 74);
+ Table.States (45).Action_List.Set_Capacity (5);
Add_Action (Table.States (45), (12, 23, 29, 33, 36), (45, 0), 1,
null, null);
+ Table.States (46).Action_List.Set_Capacity (14);
Add_Action (Table.States (46), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 2), 1,
rhs_item_2'Access, null);
+ Table.States (47).Action_List.Set_Capacity (14);
Add_Action (Table.States (47), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (49, 0), 1, null,
null);
+ Table.States (48).Action_List.Set_Capacity (11);
Add_Action (Table.States (48), 11, 75);
Add_Action (Table.States (48), 12, Reduce, (46, 1), 1, null, null);
Add_Action (Table.States (48), 18, 38);
@@ -324,39 +360,48 @@ package body Wisitoken_Grammar_Main is
Add_Conflict (Table.States (48), 33, (46, 1), 1, null, null);
Add_Action (Table.States (48), 35, 43);
Add_Action (Table.States (48), 36, Reduce, (46, 1), 1, null, null);
- Add_Error (Table.States (48));
+ Table.States (48).Goto_List.Set_Capacity (6);
Add_Goto (Table.States (48), 47, 46);
Add_Goto (Table.States (48), 48, 76);
Add_Goto (Table.States (48), 50, 49);
Add_Goto (Table.States (48), 51, 50);
Add_Goto (Table.States (48), 52, 51);
Add_Goto (Table.States (48), 53, 52);
+ Table.States (49).Action_List.Set_Capacity (14);
Add_Action (Table.States (49), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (48, 0), 1, null,
null);
+ Table.States (50).Action_List.Set_Capacity (14);
Add_Action (Table.States (50), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 5), 1,
rhs_item_5'Access, null);
+ Table.States (51).Action_List.Set_Capacity (14);
Add_Action (Table.States (51), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 3), 1,
rhs_item_3'Access, null);
+ Table.States (52).Action_List.Set_Capacity (14);
Add_Action (Table.States (52), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 4), 1,
rhs_item_4'Access, null);
+ Table.States (53).Action_List.Set_Capacity (5);
Add_Action (Table.States (53), 12, 71);
Add_Action (Table.States (53), 23, 72);
Add_Conflict (Table.States (53), 23, (44, 1), 0, null, null);
Add_Action (Table.States (53), 29, 73);
Add_Action (Table.States (53), 33, Reduce, (44, 1), 0, null, null);
Add_Action (Table.States (53), 36, Reduce, (44, 1), 0, null, null);
- Add_Error (Table.States (53));
+ Table.States (53).Goto_List.Set_Capacity (1);
Add_Goto (Table.States (53), 44, 77);
+ Table.States (54).Action_List.Set_Capacity (3);
Add_Action (Table.States (54), (23, 33, 36), (38, 1), 4,
declaration_1'Access, null);
+ Table.States (55).Action_List.Set_Capacity (2);
Add_Action (Table.States (55), (9, 33), (40, 1), 2, null, null);
+ Table.States (56).Action_List.Set_Capacity (1);
Add_Action (Table.States (56), 33, 78);
- Add_Error (Table.States (56));
+ Table.States (57).Action_List.Set_Capacity (1);
Add_Action (Table.States (57), 17, 79);
- Add_Error (Table.States (57));
+ Table.States (58).Action_List.Set_Capacity (1);
Add_Action (Table.States (58), 17, 80);
- Add_Error (Table.States (58));
+ Table.States (59).Action_List.Set_Capacity (13);
Add_Action (Table.States (59), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (41, 1), 2, null,
null);
+ Table.States (60).Action_List.Set_Capacity (13);
Add_Action (Table.States (60), 8, 24);
Add_Action (Table.States (60), 10, 25);
Add_Action (Table.States (60), 15, 26);
@@ -371,8 +416,9 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (60), 34, 33);
Add_Action (Table.States (60), 35, 34);
Add_Action (Table.States (60), 36, Reduce, (38, 0), 4,
declaration_0'Access, null);
- Add_Error (Table.States (60));
+ Table.States (60).Goto_List.Set_Capacity (1);
Add_Goto (Table.States (60), 42, 59);
+ Table.States (61).Action_List.Set_Capacity (10);
Add_Action (Table.States (61), 12, Reduce, (54, 0), 1, null, null);
Add_Action (Table.States (61), 18, 38);
Add_Action (Table.States (61), 19, 39);
@@ -383,44 +429,50 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (61), 28, Reduce, (54, 0), 1, null, null);
Add_Action (Table.States (61), 33, 42);
Add_Action (Table.States (61), 35, 43);
- Add_Error (Table.States (61));
+ Table.States (61).Goto_List.Set_Capacity (6);
Add_Goto (Table.States (61), 47, 46);
Add_Goto (Table.States (61), 48, 76);
Add_Goto (Table.States (61), 50, 49);
Add_Goto (Table.States (61), 51, 50);
Add_Goto (Table.States (61), 52, 51);
Add_Goto (Table.States (61), 53, 52);
+ Table.States (62).Action_List.Set_Capacity (2);
Add_Action (Table.States (62), 12, 81);
Add_Action (Table.States (62), 26, 82);
- Add_Error (Table.States (62));
+ Table.States (63).Action_List.Set_Capacity (2);
Add_Action (Table.States (63), 12, 81);
Add_Action (Table.States (63), 27, 83);
- Add_Error (Table.States (63));
+ Table.States (64).Action_List.Set_Capacity (2);
Add_Action (Table.States (64), 12, 81);
Add_Action (Table.States (64), 28, 84);
- Add_Error (Table.States (64));
+ Table.States (65).Action_List.Set_Capacity (1);
Add_Action (Table.States (65), 16, 85);
- Add_Error (Table.States (65));
+ Table.States (66).Action_List.Set_Capacity (6);
Add_Action (Table.States (66), 18, 38);
Add_Action (Table.States (66), 19, 39);
Add_Action (Table.States (66), 20, 40);
Add_Action (Table.States (66), 21, 41);
Add_Action (Table.States (66), 33, 86);
Add_Action (Table.States (66), 35, 43);
- Add_Error (Table.States (66));
+ Table.States (66).Goto_List.Set_Capacity (5);
Add_Goto (Table.States (66), 47, 46);
Add_Goto (Table.States (66), 50, 87);
Add_Goto (Table.States (66), 51, 50);
Add_Goto (Table.States (66), 52, 51);
Add_Goto (Table.States (66), 53, 52);
+ Table.States (67).Action_List.Set_Capacity (14);
Add_Action (Table.States (67), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 4), 2, null,
null);
+ Table.States (68).Action_List.Set_Capacity (14);
Add_Action (Table.States (68), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 2), 2, null,
null);
+ Table.States (69).Action_List.Set_Capacity (14);
Add_Action (Table.States (69), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 5), 2, null,
null);
+ Table.States (70).Action_List.Set_Capacity (14);
Add_Action (Table.States (70), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 3), 2,
rhs_optional_item_3'Access, null);
+ Table.States (71).Action_List.Set_Capacity (10);
Add_Action (Table.States (71), 12, Reduce, (46, 0), 0, null, null);
Add_Action (Table.States (71), 18, 38);
Add_Action (Table.States (71), 19, 39);
@@ -432,7 +484,7 @@ package body Wisitoken_Grammar_Main is
Add_Conflict (Table.States (71), 33, (46, 0), 0, null, null);
Add_Action (Table.States (71), 35, 43);
Add_Action (Table.States (71), 36, Reduce, (46, 0), 0, null, null);
- Add_Error (Table.States (71));
+ Table.States (71).Goto_List.Set_Capacity (8);
Add_Goto (Table.States (71), 46, 88);
Add_Goto (Table.States (71), 47, 46);
Add_Goto (Table.States (71), 48, 47);
@@ -441,31 +493,39 @@ package body Wisitoken_Grammar_Main is
Add_Goto (Table.States (71), 51, 50);
Add_Goto (Table.States (71), 52, 51);
Add_Goto (Table.States (71), 53, 52);
+ Table.States (72).Action_List.Set_Capacity (2);
Add_Action (Table.States (72), 4, 89);
Add_Action (Table.States (72), 5, 90);
- Add_Error (Table.States (72));
+ Table.States (73).Action_List.Set_Capacity (3);
Add_Action (Table.States (73), (23, 33, 36), (44, 0), 1, null,
null);
+ Table.States (74).Action_List.Set_Capacity (3);
Add_Action (Table.States (74), (23, 33, 36), (43, 0), 4,
nonterminal_0'Access, null);
+ Table.States (75).Action_List.Set_Capacity (6);
Add_Action (Table.States (75), 11, 91);
Add_Action (Table.States (75), 12, Reduce, (46, 2), 2, null, null);
Add_Action (Table.States (75), 23, Reduce, (46, 2), 2, null, null);
Add_Action (Table.States (75), 29, Reduce, (46, 2), 2, null, null);
Add_Action (Table.States (75), 33, Reduce, (46, 2), 2, null, null);
Add_Action (Table.States (75), 36, Reduce, (46, 2), 2, null, null);
- Add_Error (Table.States (75));
+ Table.States (76).Action_List.Set_Capacity (14);
Add_Action (Table.States (76), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (49, 1), 2, null,
null);
+ Table.States (77).Action_List.Set_Capacity (3);
Add_Action (Table.States (77), (23, 33, 36), (43, 1), 4,
nonterminal_1'Access, null);
+ Table.States (78).Action_List.Set_Capacity (3);
Add_Action (Table.States (78), (23, 33, 36), (38, 4), 5,
declaration_4'Access, null);
+ Table.States (79).Action_List.Set_Capacity (1);
Add_Action (Table.States (79), (1 => 33), (39, 1), 4, null, null);
+ Table.States (80).Action_List.Set_Capacity (1);
Add_Action (Table.States (80), (1 => 33), (39, 2), 4, null, null);
+ Table.States (81).Action_List.Set_Capacity (6);
Add_Action (Table.States (81), 18, 38);
Add_Action (Table.States (81), 19, 39);
Add_Action (Table.States (81), 20, 40);
Add_Action (Table.States (81), 21, 41);
Add_Action (Table.States (81), 33, 42);
Add_Action (Table.States (81), 35, 43);
- Add_Error (Table.States (81));
+ Table.States (81).Goto_List.Set_Capacity (7);
Add_Goto (Table.States (81), 47, 46);
Add_Goto (Table.States (81), 48, 47);
Add_Goto (Table.States (81), 49, 92);
@@ -473,6 +533,7 @@ package body Wisitoken_Grammar_Main is
Add_Goto (Table.States (81), 51, 50);
Add_Goto (Table.States (81), 52, 51);
Add_Goto (Table.States (81), 53, 52);
+ Table.States (82).Action_List.Set_Capacity (15);
Add_Action (Table.States (82), 11, Reduce, (53, 0), 3, null, null);
Add_Action (Table.States (82), 12, Reduce, (53, 0), 3, null, null);
Add_Action (Table.States (82), 18, Reduce, (53, 0), 3, null, null);
@@ -488,9 +549,10 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (82), 33, Reduce, (53, 0), 3, null, null);
Add_Action (Table.States (82), 35, Reduce, (53, 0), 3, null, null);
Add_Action (Table.States (82), 36, Reduce, (53, 0), 3, null, null);
- Add_Error (Table.States (82));
+ Table.States (83).Action_List.Set_Capacity (14);
Add_Action (Table.States (83), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 0), 3, null,
null);
+ Table.States (84).Action_List.Set_Capacity (17);
Add_Action (Table.States (84), 11, Reduce, (51, 0), 3, null, null);
Add_Action (Table.States (84), 12, Reduce, (51, 0), 3, null, null);
Add_Action (Table.States (84), 18, Reduce, (51, 0), 3, null, null);
@@ -508,9 +570,9 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (84), 33, Reduce, (51, 0), 3, null, null);
Add_Action (Table.States (84), 35, Reduce, (51, 0), 3, null, null);
Add_Action (Table.States (84), 36, Reduce, (51, 0), 3, null, null);
- Add_Error (Table.States (84));
+ Table.States (85).Action_List.Set_Capacity (1);
Add_Action (Table.States (85), 33, 97);
- Add_Error (Table.States (85));
+ Table.States (86).Action_List.Set_Capacity (17);
Add_Action (Table.States (86), 11, Reduce, (50, 0), 1, null, null);
Add_Action (Table.States (86), 12, Reduce, (50, 0), 1, null, null);
Add_Action (Table.States (86), 18, Reduce, (50, 0), 1, null, null);
@@ -528,15 +590,18 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (86), 33, Reduce, (50, 0), 1, null, null);
Add_Action (Table.States (86), 35, Reduce, (50, 0), 1, null, null);
Add_Action (Table.States (86), 36, Reduce, (50, 0), 1, null, null);
- Add_Error (Table.States (86));
+ Table.States (87).Action_List.Set_Capacity (14);
Add_Action (Table.States (87), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (48, 1), 3, null,
null);
+ Table.States (88).Action_List.Set_Capacity (5);
Add_Action (Table.States (88), (12, 23, 29, 33, 36), (45, 1), 3,
null, null);
+ Table.States (89).Action_List.Set_Capacity (1);
Add_Action (Table.States (89), 5, 98);
- Add_Error (Table.States (89));
+ Table.States (90).Action_List.Set_Capacity (1);
Add_Action (Table.States (90), 33, 99);
- Add_Error (Table.States (90));
+ Table.States (91).Action_List.Set_Capacity (5);
Add_Action (Table.States (91), (12, 23, 29, 33, 36), (46, 3), 3,
null, null);
+ Table.States (92).Action_List.Set_Capacity (10);
Add_Action (Table.States (92), 12, Reduce, (54, 1), 3, null, null);
Add_Action (Table.States (92), 18, 38);
Add_Action (Table.States (92), 19, 39);
@@ -547,34 +612,42 @@ package body Wisitoken_Grammar_Main is
Add_Action (Table.States (92), 28, Reduce, (54, 1), 3, null, null);
Add_Action (Table.States (92), 33, 42);
Add_Action (Table.States (92), 35, 43);
- Add_Error (Table.States (92));
+ Table.States (92).Goto_List.Set_Capacity (6);
Add_Goto (Table.States (92), 47, 46);
Add_Goto (Table.States (92), 48, 76);
Add_Goto (Table.States (92), 50, 49);
Add_Goto (Table.States (92), 51, 50);
Add_Goto (Table.States (92), 52, 51);
Add_Goto (Table.States (92), 53, 52);
+ Table.States (93).Action_List.Set_Capacity (14);
Add_Action (Table.States (93), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 1), 4, null,
null);
+ Table.States (94).Action_List.Set_Capacity (14);
Add_Action (Table.States (94), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 2), 4, null,
null);
+ Table.States (95).Action_List.Set_Capacity (14);
Add_Action (Table.States (95), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 1), 4, null,
null);
+ Table.States (96).Action_List.Set_Capacity (14);
Add_Action (Table.States (96), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 3), 4, null,
null);
+ Table.States (97).Action_List.Set_Capacity (1);
Add_Action (Table.States (97), 17, 100);
- Add_Error (Table.States (97));
+ Table.States (98).Action_List.Set_Capacity (5);
Add_Action (Table.States (98), (12, 23, 29, 33, 36), (45, 3), 4,
null, null);
+ Table.States (99).Action_List.Set_Capacity (1);
Add_Action (Table.States (99), 16, 101);
- Add_Error (Table.States (99));
+ Table.States (100).Action_List.Set_Capacity (14);
Add_Action (Table.States (100), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (47, 0), 5, null,
null);
+ Table.States (101).Action_List.Set_Capacity (1);
Add_Action (Table.States (101), 33, 102);
- Add_Error (Table.States (101));
+ Table.States (102).Action_List.Set_Capacity (5);
Add_Action (Table.States (102), (12, 23, 29, 33, 36), (45, 2), 6,
null, null);
end Subr_1;
begin
Subr_1;
+ Table.Error_Action := new Parse_Action_Node'((Verb => Error), null);
end;
WisiToken.Parse.LR.Parser_No_Recover.New_Parser
diff --git a/wisitoken_grammar_main.ads b/wisitoken_grammar_main.ads
index e07ed68..35a5e9e 100644
--- a/wisitoken_grammar_main.ads
+++ b/wisitoken_grammar_main.ads
@@ -27,6 +27,7 @@ package Wisitoken_Grammar_Main is
procedure Create_Parser
(Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;
+ -- no error recovery
Trace : not null access WisiToken.Trace'Class;
User_Data : in
WisiToken.Syntax_Trees.User_Data_Access);
diff --git a/wisitoken_grammar_runtime.adb b/wisitoken_grammar_runtime.adb
index 4841ada..346eadb 100644
--- a/wisitoken_grammar_runtime.adb
+++ b/wisitoken_grammar_runtime.adb
@@ -26,6 +26,7 @@ with SAL.Generic_Decimal_Image;
with System.Assertions;
with WisiToken.Generate; use WisiToken.Generate;
with Wisitoken_Grammar_Actions; use Wisitoken_Grammar_Actions;
+with WisiToken.Syntax_Trees.LR_Utils;
package body WisiToken_Grammar_Runtime is
use WisiToken;
@@ -35,17 +36,19 @@ package body WisiToken_Grammar_Runtime is
procedure Raise_Programmer_Error
(Label : in String;
+ Data : in User_Data_Type;
Tree : in WisiToken.Syntax_Trees.Tree;
Node : in WisiToken.Syntax_Trees.Node_Index);
pragma No_Return (Raise_Programmer_Error);
procedure Raise_Programmer_Error
(Label : in String;
+ Data : in User_Data_Type;
Tree : in WisiToken.Syntax_Trees.Tree;
Node : in WisiToken.Syntax_Trees.Node_Index)
is begin
- raise SAL.Programmer_Error with Label &
WisiToken.Syntax_Trees.Node_Index'Image (Node) &
- ":" & Tree.Image (Node, Wisitoken_Grammar_Actions.Descriptor,
Include_Children => True);
+ WisiToken.Syntax_Trees.LR_Utils.Raise_Programmer_Error
+ (Label, Wisitoken_Grammar_Actions.Descriptor, Data.Grammar_Lexer,
Tree, Data.Terminals.all, Node);
end Raise_Programmer_Error;
function Get_Line
@@ -213,7 +216,7 @@ package body WisiToken_Grammar_Runtime is
end;
when others =>
- Raise_Programmer_Error ("Get_RHS; unimplimented token",
Tree, I);
+ Raise_Programmer_Error ("Get_RHS; unimplimented token",
Data, Tree, I);
end case;
end loop;
@@ -241,7 +244,7 @@ package body WisiToken_Grammar_Runtime is
declare
use Ada.Exceptions;
begin
- Raise_Programmer_Error ("Get_RHS: " & Exception_Name (E) & ": " &
Exception_Message (E), Tree, Token);
+ Raise_Programmer_Error ("Get_RHS: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Token);
end;
end Get_RHS;
@@ -282,7 +285,7 @@ package body WisiToken_Grammar_Runtime is
Data.Ignore_Lines := False;
when others =>
- Raise_Programmer_Error ("Get_Right_Hand_Sides", Tree, Token);
+ Raise_Programmer_Error ("Get_Right_Hand_Sides", Data, Tree, Token);
end case;
end Get_Right_Hand_Sides;
@@ -357,7 +360,7 @@ package body WisiToken_Grammar_Runtime is
if Data.Terminals.Length = 0 then
Data.Non_Grammar (0).Append (Token);
else
- Data.Non_Grammar.Set_Last (Data.Terminals.Last_Index);
+ Data.Non_Grammar.Set_First_Last (0, Data.Terminals.Last_Index);
Data.Non_Grammar (Data.Terminals.Last_Index).Append (Token);
end if;
end if;
@@ -495,17 +498,21 @@ package body WisiToken_Grammar_Runtime is
when Syntax_Trees.Nonterm =>
-- must be token_keyword_non_grammar
declare
- Children : Syntax_Trees.Valid_Node_Index_Array renames
Tree.Children (Tokens (2));
- Child_1_ID : constant Token_Enum_ID := To_Token_Enum (Tree.ID
(Children (1)));
+ Children_2 : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Children (Tokens (2));
+ Child_1_ID : constant Token_Enum_ID := To_Token_Enum (Tree.ID
(Children_2 (1)));
begin
case 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)));
+ declare
+ Children_4 : constant Syntax_Trees.Valid_Node_Index_Array :=
Tree.Children (Tokens (4));
+ begin
+ WisiToken.BNF.Add_Token
+ (Data.Tokens.Tokens,
+ Kind => Get_Text (Data, Tree, Children_2 (3)),
+ Name => Get_Text (Data, Tree, Tokens (3)),
+ Value => Get_Text (Data, Tree, Children_4 (1)),
+ Repair_Image => (if Children_4'Length = 1 then "" else
Get_Text (Data, Tree, Children_4 (2))));
+ end;
when KEYWORD_ID =>
@@ -517,7 +524,7 @@ package body WisiToken_Grammar_Runtime is
WisiToken.BNF.Add_Token
(Data.Tokens.Non_Grammar,
- Kind => Get_Text (Data, Tree, Children (3)),
+ Kind => Get_Text (Data, Tree, Children_2 (3)),
Name => Get_Text (Data, Tree, Tokens (3)),
Value => Get_Text (Data, Tree, Tokens (4)));
@@ -825,7 +832,7 @@ package body WisiToken_Grammar_Runtime is
(Data.Grammar_Lexer.File_Name, 1, 1, "duplicate virtual nonterm
'" & LHS_String & "'");
when others =>
- Raise_Programmer_Error ("Add_Nonterminal", Tree, LHS_Node);
+ Raise_Programmer_Error ("Add_Nonterminal", Data, Tree, LHS_Node);
end case;
else
Data.Label_Count := Data.Label_Count + Labels.Length;
@@ -862,7 +869,7 @@ package body WisiToken_Grammar_Runtime is
end;
end if;
when Other =>
- Raise_Programmer_Error ("untranslated EBNF node", Tree, Tree.Parent
(Tokens (Token)));
+ Raise_Programmer_Error ("untranslated EBNF node", Data, Tree,
Tree.Parent (Tokens (Token)));
end case;
end Check_EBNF;
@@ -967,7 +974,7 @@ package body WisiToken_Grammar_Runtime is
Node := Children (1);
exit;
else
- Raise_Programmer_Error ("first_list_element", Tree, Node);
+ Raise_Programmer_Error ("first_list_element", Data, Tree,
Node);
end if;
end;
end loop;
@@ -1151,11 +1158,16 @@ package body WisiToken_Grammar_Runtime is
end Append_Element;
procedure Insert_Optional_RHS (B : in Valid_Node_Index)
+ with Pre => Tree.ID (B) in +rhs_multiple_item_ID | +rhs_optional_item_ID
| +IDENTIFIER_ID
is
-- B is an optional item in an rhs_item_list :
-- | a b? c
+ -- | a b* c
+ --
+ -- or B is a virtual identifier naming the new nonterm replacing the
+ -- original.
--
- -- Insert a second rhs_item_list without B
+ -- where a, c can be empty. Insert a second rhs_item_list without B.
--
-- The containing elment may be rhs or rhs_alternative_list
@@ -1205,7 +1217,7 @@ package body WisiToken_Grammar_Runtime is
when others =>
Raise_Programmer_Error
- ("translate_ebnf_to_bnf insert_optional_rhs unimplemented
RHS", Tree, Container);
+ ("translate_ebnf_to_bnf insert_optional_rhs unimplemented
RHS", Data, Tree, Container);
end case;
end Add_Actions;
begin
@@ -1241,7 +1253,12 @@ package body WisiToken_Grammar_Runtime is
New_RHS_AC :=
(if Tree.ID (Container) = +rhs_ID
then Tree.Add_Nonterm ((+rhs_ID, 0), (1 .. 0 =>
Invalid_Node_Index))
- else Tree.Add_Nonterm ((+rhs_item_list_ID, 0), (1 .. 0 =>
Invalid_Node_Index)));
+ else
+ -- rhs_alternative_list_ID
+ -- The grammar does not allow an empty alternative in an
+ -- rhs_alterntive_list; this will be fixed when it is
converted to an
+ -- rhs_list.
+ Tree.Add_Nonterm ((+rhs_item_list_ID, 0), (1 .. 0 =>
Invalid_Node_Index)));
else
-- c is empty
New_RHS_AC :=
@@ -1308,6 +1325,7 @@ package body WisiToken_Grammar_Runtime is
Compilation_Unit_List_Tail : constant Valid_Node_Index := Tree.Child
(Tree.Root, 1);
procedure Add_Compilation_Unit (Unit : in Valid_Node_Index; Prepend : in
Boolean := False)
+ with Pre => Tree.ID (Unit) in +declaration_ID | +nonterminal_ID
is
Comp_Unit : constant Valid_Node_Index := Tree.Add_Nonterm
((+compilation_unit_ID, (if Tree.ID (Unit) = +declaration_ID then 0
else 1)),
@@ -1337,6 +1355,7 @@ package body WisiToken_Grammar_Runtime is
end To_RHS_List;
function Convert_RHS_Alternative (Content : in Valid_Node_Index) return
Valid_Node_Index
+ with Pre => Tree.ID (Content) = +rhs_alternative_list_ID
is
-- Convert rhs_alternative_list rooted at Content to an rhs_list
Node : Valid_Node_Index := Content;
@@ -1359,14 +1378,29 @@ package body WisiToken_Grammar_Runtime is
-- | rhs: new
-- | | rhs_item_list: keep Node,Child (3)
- Tree.Set_Children
- (Node,
- (+rhs_list_ID, 1),
- (1 => Tree.Child (Node, 1),
- 2 => Tree.Child (Node, 2),
- 3 => Tree.Add_Nonterm
- ((+rhs_ID, 1),
- (1 => Tree.Child (Node, 3)))));
+ if Tree.Is_Empty (Tree.Child (Node, 3)) then
+ -- Convert empty rhs_item_list to empty rhs
+ Tree.Set_Children
+ (Tree.Child (Node, 3),
+ (+rhs_ID, 0),
+ (1 .. 0 => Invalid_Node_Index));
+
+ Tree.Set_Children
+ (Node,
+ (+rhs_list_ID, 1),
+ (1 => Tree.Child (Node, 1),
+ 2 => Tree.Child (Node, 2),
+ 3 => Tree.Child (Node, 3)));
+ else
+ Tree.Set_Children
+ (Node,
+ (+rhs_list_ID, 1),
+ (1 => Tree.Child (Node, 1),
+ 2 => Tree.Child (Node, 2),
+ 3 => Tree.Add_Nonterm
+ ((+rhs_ID, 1),
+ (1 => Tree.Child (Node, 3)))));
+ end if;
Clear_EBNF_Node (Node);
Node := Tree.Child (Node, 1);
@@ -1393,7 +1427,7 @@ package body WisiToken_Grammar_Runtime is
procedure New_Nonterminal
(New_Identifier : in Identifier_Index;
Content : in Valid_Node_Index)
- with Pre => To_Token_Enum (Tree.ID (Content)) in
rhs_alternative_list_ID | rhs_element_ID
+ with Pre => To_Token_Enum (Tree.ID (Content)) in rhs_alternative_list_ID
| rhs_element_ID
is
-- Convert subtree rooted at Content to an rhs_list contained by a
new nonterminal
-- named New_Identifier.
@@ -1404,8 +1438,7 @@ package body WisiToken_Grammar_Runtime is
(case To_Token_Enum (Tree.ID (Content)) is
when rhs_element_ID => To_RHS_List (Content),
when rhs_alternative_list_ID => Convert_RHS_Alternative
(Content),
- when others => raise SAL.Programmer_Error with "new_nonterminal
unimplemented content" &
- Tree.Image (Content, Wisitoken_Grammar_Actions.Descriptor)),
+ when others => raise SAL.Programmer_Error),
Child_4 => Tree.Add_Nonterm
((+semicolon_opt_ID, 0),
(1 => Tree.Add_Terminal (+SEMICOLON_ID))));
@@ -1418,6 +1451,8 @@ package body WisiToken_Grammar_Runtime is
RHS_Element_1 : in Valid_Node_Index;
RHS_Element_3 : in Valid_Node_Index;
Byte_Region : in Buffer_Region)
+ with Pre => Tree.ID (RHS_Element_1) = +rhs_element_ID and
+ Tree.ID (RHS_Element_3) = +rhs_element_ID
is
-- nonterminal: foo_list
-- | IDENTIFIER: "foo_list" List_Nonterm
@@ -1528,7 +1563,7 @@ package body WisiToken_Grammar_Runtime is
when rhs_alternative_list_ID =>
-- All handled by New_Nonterminal*
- raise SAL.Not_Implemented with Tree.Image (Node,
Wisitoken_Grammar_Actions.Descriptor);
+ raise SAL.Programmer_Error;
when rhs_attribute_ID =>
-- Just delete it
@@ -1559,7 +1594,7 @@ package body WisiToken_Grammar_Runtime is
begin
if Tree.RHS_Index (RHS_Item_List) /= 0 then
-- Not first
- Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_attribute_id unimplemented", Tree, Node);
+ Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_attribute_id unimplemented", Data, Tree, Node);
end if;
Tree.Set_Children
@@ -1611,7 +1646,7 @@ package body WisiToken_Grammar_Runtime is
when Virtual_Identifier =>
New_Ident := Tree.Identifier (Name_Node);
when others =>
- Raise_Programmer_Error ("process_node
rhs_group_item", Tree, Name_Node);
+ Raise_Programmer_Error ("process_node
rhs_group_item", Data, Tree, Name_Node);
end case;
exit;
@@ -1643,9 +1678,10 @@ package body WisiToken_Grammar_Runtime is
-- | a b+ c
-- | a b* c
--
- -- Replace it with a new canonical list nonterminal:
+ -- where a and/or c can be empty. Replace it with a new canonical
+ -- list nonterminal:
--
- -- nonterminal_nnn
+ -- nonterminal_nnn_list
-- : b
-- | nonterminal_nnn_list b
--
@@ -1693,7 +1729,7 @@ package body WisiToken_Grammar_Runtime is
--
-- The tokens may have labels.
--
- -- Handling these cases specially this eliminates a
conflict between
+ -- Handling these cases specially eliminates a conflict
between
-- reducing to enumConstants and reducing to the introduced
nonterm
-- list.
--
@@ -1720,6 +1756,7 @@ package body WisiToken_Grammar_Runtime is
then
return;
end if;
+ if Invalid_Node_Index /= Prev_List_Element (Element_1,
+rhs_item_list_ID) then return; end if;
if Invalid_Node_Index /= Next_List_Element (RHS_Element,
+rhs_item_list_ID) then return; end if;
if Invalid_Node_Index /= Next_List_Element (RHS_2,
+rhs_list_ID) or
Invalid_Node_Index /= Prev_List_Element (RHS_2,
+rhs_list_ID)
@@ -1893,7 +1930,7 @@ package body WisiToken_Grammar_Runtime is
when others =>
Raise_Programmer_Error
("unimplemented Find_List_Nonterminal_2 case
'" & Element_Content & "'",
- Tree, Name_Node);
+ Data, Tree, Name_Node);
end case;
-- list nonterm is the next nonterminal
@@ -1969,7 +2006,7 @@ package body WisiToken_Grammar_Runtime is
when others =>
Raise_Programmer_Error
("unimplemented
Find_List_Nonterminal_1 case '" & Element_Content & "'",
- Tree, Name_Node);
+ Data, Tree, Name_Node);
end case;
exit;
@@ -2031,7 +2068,7 @@ package body WisiToken_Grammar_Runtime is
end if;
when others =>
- Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_multiple_item unimplmented", Tree, Node);
+ Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_multiple_item unimplmented", Data, Tree, Node);
end case;
if Allow_Empty then
@@ -2060,7 +2097,8 @@ package body WisiToken_Grammar_Runtime is
exception
when E : System.Assertions.Assert_Failure =>
Raise_Programmer_Error
- ("translate_ebnf_to_bnf multiple_item assert: " &
Ada.Exceptions.Exception_Message (E), Tree, Node);
+ ("translate_ebnf_to_bnf multiple_item assert: " &
Ada.Exceptions.Exception_Message (E),
+ Data, Tree, Node);
end;
when rhs_optional_item_ID =>
@@ -2137,7 +2175,7 @@ package body WisiToken_Grammar_Runtime is
when Shared_Terminal =>
Name_Terminal := Tree.Min_Terminal_Index
(Name_Identifier_Node);
when others =>
- Raise_Programmer_Error ("unhandled rhs_optional
case ", Tree, Name_Identifier_Node);
+ Raise_Programmer_Error ("unhandled rhs_optional
case ", Data, Tree, Name_Identifier_Node);
end case;
end;
end if;
@@ -2161,7 +2199,8 @@ package body WisiToken_Grammar_Runtime is
Name_Ident := Tree.Identifier
(Name_Identifier_Node);
when others =>
Raise_Programmer_Error
- ("unhandled rhs_optional case '" &
New_Text & "'", Tree, Name_Identifier_Node);
+ ("unhandled rhs_optional case '" &
New_Text & "'",
+ Data, Tree, Name_Identifier_Node);
end case;
exit;
end if;
@@ -2295,7 +2334,7 @@ package body WisiToken_Grammar_Runtime is
Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID, 1), (1
=> Tree.Child (Node, 1)));
when others =>
- Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_optional_item unimplmented", Tree, Node);
+ Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_optional_item unimplmented", Data, Tree, Node);
end case;
Clear_EBNF_Node (Node);
@@ -2374,7 +2413,7 @@ package body WisiToken_Grammar_Runtime is
(1 => Tree.Add_Identifier (+IDENTIFIER_ID, Name_Ident,
Tree.Byte_Region (Node))));
when others =>
- Raise_Programmer_Error ("translate_ebnf_to_bnf
string_literal_2 unimplemented", Tree, Node);
+ Raise_Programmer_Error ("translate_ebnf_to_bnf
string_literal_2 unimplemented", Data, Tree, Node);
end case;
end;
@@ -2409,7 +2448,7 @@ package body WisiToken_Grammar_Runtime is
end;
when others =>
- Raise_Programmer_Error ("unimplemented EBNF node", Tree, Node);
+ Raise_Programmer_Error ("unimplemented EBNF node", Data, Tree,
Node);
end case;
exception
when SAL.Programmer_Error =>
@@ -2418,7 +2457,7 @@ package body WisiToken_Grammar_Runtime is
Raise_Programmer_Error
("unhandled exception " & Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E),
- Tree, Node);
+ Data, Tree, Node);
end Process_Node;
begin
@@ -2452,10 +2491,6 @@ package body WisiToken_Grammar_Runtime is
Ada.Text_IO.Put_Line (Base_Identifier_Index'Image (I) & " " &
(-Data.Tokens.Virtual_Identifiers (I)));
end loop;
end if;
- exception
- when E : SAL.Not_Implemented =>
- Ada.Text_IO.Put_Line
- (Ada.Text_IO.Standard_Error, "Translate_EBNF_To_BNF not implemented: "
& Ada.Exceptions.Exception_Message (E));
end Translate_EBNF_To_BNF;
procedure Print_Source
@@ -2562,7 +2597,7 @@ package body WisiToken_Grammar_Runtime is
use Ada.Exceptions;
begin
Raise_Programmer_Error
- ("Put_RHS_Element: " & Exception_Name (E) & ": " &
Exception_Message (E), Tree, Node);
+ ("Put_RHS_Element: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Node);
end;
end Put_RHS_Element;
@@ -2587,7 +2622,7 @@ package body WisiToken_Grammar_Runtime is
use Ada.Exceptions;
begin
Raise_Programmer_Error
- ("Put_RHS_Item_List: " & Exception_Name (E) & ": " &
Exception_Message (E), Tree, Node);
+ ("Put_RHS_Item_List: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Node);
end;
end Put_RHS_Item_List;
@@ -2634,7 +2669,7 @@ package body WisiToken_Grammar_Runtime is
end if;
when others =>
- Raise_Programmer_Error ("Put_RHS", Tree, Node);
+ Raise_Programmer_Error ("Put_RHS", Data, Tree, Node);
end case;
exception
when SAL.Programmer_Error =>
@@ -2644,7 +2679,7 @@ package body WisiToken_Grammar_Runtime is
declare
use Ada.Exceptions;
begin
- Raise_Programmer_Error ("Put_RHS: " & Exception_Name (E) & ": " &
Exception_Message (E), Tree, Node);
+ Raise_Programmer_Error ("Put_RHS: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Node);
end;
end Put_RHS;
@@ -2673,7 +2708,7 @@ package body WisiToken_Grammar_Runtime is
Put_Comments (Node);
when others =>
- Raise_Programmer_Error ("Put_RHS_List", Tree, Node);
+ Raise_Programmer_Error ("Put_RHS_List", Data, Tree, Node);
end case;
exception
when SAL.Programmer_Error =>
@@ -2683,7 +2718,8 @@ package body WisiToken_Grammar_Runtime is
declare
use Ada.Exceptions;
begin
- Raise_Programmer_Error ("Put_RHS_List: " & Exception_Name (E) & ":
" & Exception_Message (E), Tree, Node);
+ Raise_Programmer_Error
+ ("Put_RHS_List: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Node);
end;
end Put_RHS_List;
- [elpa] externals/wisi c282a4b 13/35: update ada-mode, wisi, (continued)
- [elpa] externals/wisi c282a4b 13/35: update ada-mode, wisi, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 27db81d 17/35: Fix some quoting problems in doc strings, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 724a763 31/35: In wisi sal-gen_unbounded_definite_red_black_trees.adb, correct WORKAROUND, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi abbb0c2 19/35: Release wisi 1.1.4, ada-mode 5.2.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 5becb56 29/35: Release ada-mode 7.0.1, wisi 3.0.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 2114f5a 28/35: In ada-mode and wisi, release ada-mode 6.2.1, wisi 2.2.1; fix packaging bugs, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 2636b79 25/35: Release ada-mode 6.1.0, wisi 2.1.0, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi dd09dcf 35/35: * .gitignore: New file, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 232d669 18/35: Release: ada-mode: version 5.2.0. wisi: version 1.1.3, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi c7f61e5 26/35: In ada-mode, wisi; release ada-mode 6.1.1, wisi 2.1.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 66d7e59 27/35: In ada-mode, wisi: release Ada mode 6.2.0, wisi 1.2.0.,
Stefan Monnier <=
- [elpa] externals/wisi 1dc8c19 12/35: release ada-mode 5.1.7, wisi 1.1.0; minor format changes in ada-ref-man (take 2), Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 5934bfc 06/35: release ada-mode 5.1.0, wisi 1.0.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi d9cd208 32/35: In ada-mode, release 7.1.3; in wisi, release 3.1.2, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi c80e75d 30/35: Release ada-mode 7.1.0, wisi 3.1.0, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 4d8af96 05/35: update to Ada mode version 5.0.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 8a5302b 09/35: ada-mode 5.1.3, wisi 1.0.4, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 01c34d0 33/35: In wisi, missed a few files in 3.1.2 release, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 0e04e18 08/35: ada-mode, wisi: bump versions again; forgot to add some files to git, Stefan Monnier, 2020/11/28