[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/wisi d9cd208 32/35: In ada-mode, release 7.1.3; in wisi
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] externals/wisi d9cd208 32/35: In ada-mode, release 7.1.3; in wisi, release 3.1.2 |
|
Date: |
Sat, 28 Nov 2020 14:47:58 -0500 (EST) |
branch: externals/wisi
commit d9cd208e444e42d1c27e1209e15498ab7aba9058
Author: Stephen Leake <stephen_leake@stephe-leake.org>
Commit: Stephen Leake <stephen_leake@stephe-leake.org>
In ada-mode, release 7.1.3; in wisi, release 3.1.2
---
NEWS | 17 +
README | 6 +-
wisi-prj.el | 8 +-
wisi.adb | 50 +-
wisi.ads | 15 +-
wisi.el | 13 +-
wisi.info | 2 +-
wisi.texi | 4 +-
wisitoken-bnf-generate.adb | 113 +-
wisitoken-bnf-generate_packrat.adb | 6 +-
wisitoken-bnf-generate_utils.adb | 35 +-
wisitoken-followed_by.adb | 207 ++
wisitoken-generate.adb | 102 +-
wisitoken-parse-lr-mckenzie_recover.adb | 2 +-
wisitoken-parse-lr-parser.adb | 21 +-
wisitoken-parse-lr-parser_no_recover.adb | 21 +-
wisitoken-parse-packrat-procedural.adb | 13 +-
wisitoken-syntax_trees-lr_utils.adb | 887 ++++++++-
wisitoken-syntax_trees-lr_utils.ads | 437 ++++-
wisitoken-syntax_trees.adb | 521 +++--
wisitoken-syntax_trees.ads | 222 ++-
wisitoken-to_tree_sitter.adb | 528 ++++++
wisitoken-user_guide.info | 120 +-
wisitoken.ads | 23 +-
wisitoken_grammar_runtime.adb | 3032 ++++++++++++++++++------------
wisitoken_grammar_runtime.ads | 23 +-
26 files changed, 4719 insertions(+), 1709 deletions(-)
diff --git a/NEWS b/NEWS
index 38c8057..621c257 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,23 @@ 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 3.1.2
+4 Jun 2020
+
+** New dispatching function wisi-xref-completion-delim-regex for
+ setting completion delimiters; example use in gpr-query.el.
+
+** wisi-get-identifier (used by wisi-goto-spec/body and others) sets
+ completion delimiters using wisi-xref-completion-delim-regex.
+
+** A bug in wisi-before-change is fixed; it was missing many buffer
+ changes, causing the parser not to be run when it should be.
+
+* wisi 3.1.1
+14 May 2020
+
+** packaging bug fix
+
* wisi 3.1.0
11 May 2020
diff --git a/README b/README
index f189c8d..5898d91 100644
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-Emacs wisi package 3.1.0
+Emacs wisi package 3.1.2
The wisi package provides utilities for using generalized
error-correcting LR parsers (in external processes) to do indentation,
@@ -8,3 +8,7 @@ See ada-mode for an example of its use.
It also provides wisitoken-parse_table-mode, for navigating the
diagnostic parse tables output by wisitoken-bnf-generate.
+The generated code is in Ada; it requires the AdaCore gnat compiler
+that you may not have installed. It is available in many packaging
+systems, or as a binary download from
+https://www.adacore.com/download.
diff --git a/wisi-prj.el b/wisi-prj.el
index ba3932d..501c09f 100644
--- a/wisi-prj.el
+++ b/wisi-prj.el
@@ -195,6 +195,9 @@ and line number.
- LOC is the declaration of the name as a list (FILE LINE
COLUMN).")
+(cl-defgeneric wisi-xref-completion-delim-regex (xref)
+ "Return the value for `completion-pcm--delim-wild-regex' to be used with
`wisi-xref-completion-table'.")
+
(cl-defgeneric wisi-xref-completion-regexp (xref)
"Return a regular expression matching the result of completing with
`wisi-xref-completion-table'.
Group 1 must be the simple symbol; the rest of the item may be annotations.")
@@ -277,7 +280,7 @@ LINE, COLUMN are Emacs origin."
result))))
(defun wisi-get-identifier (prompt)
- "Get identifier at point, or if no identifier at point, or with user arg,
prompt for one.
+ "Get identifier at point, or, if no identifier at point or with user arg,
prompt for one.
Single user arg completes on all identifiers in project; double
user arg limits completion to current file."
;; Similar to xref--read-identifier, but uses a different completion
@@ -290,6 +293,7 @@ user arg limits completion to current file."
(not def))
(let* ((table (wisi-filter-table (wisi-xref-completion-table
(wisi-prj-xref prj) prj)
(when (equal '(16) current-prefix-arg)
(buffer-file-name))))
+ (completion-pcm--delim-wild-regex
(wisi-xref-completion-delim-regex (wisi-prj-xref prj)))
(id
;; Since the user decided not to use the identifier at
;; point, don't use it as the default.
@@ -358,7 +362,7 @@ If no symbol at point, or with prefix arg, prompt for
symbol, goto spec."
(t ;; something else
(error "unknown case in wisi-goto-spec/body")))
- (wisi-show-xref desired-loc)
+ (wisi-show-xref desired-loc)
))
(cl-defgeneric wisi-prj-identifier-at-point (_project)
diff --git a/wisi.adb b/wisi.adb
index 66b55fd..91dacab 100644
--- a/wisi.adb
+++ b/wisi.adb
@@ -74,6 +74,13 @@ package body Wisi is
return Image (Augmented_Token_Access (Aug).all, Descriptor);
end Image;
+ function Image (Action : in WisiToken.Syntax_Trees.Semantic_Action) return
String
+ is
+ pragma Unreferenced (Action);
+ begin
+ return "action";
+ end Image;
+
function Image (Anchor_IDs : in Anchor_ID_Vectors.Vector) return String
is
use Ada.Strings.Unbounded;
@@ -1279,9 +1286,7 @@ package body Wisi is
Nonterm : in Valid_Node_Index;
Tokens : in WisiToken.Valid_Node_Index_Array;
Name : in WisiToken.Positive_Index_Type)
- is
- use all type WisiToken.Syntax_Trees.Node_Label;
- begin
+ is begin
if not (Name in Tokens'Range) then
declare
Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1 (Tree,
Tokens (Tokens'First));
@@ -1296,7 +1301,12 @@ package body Wisi is
end;
end if;
- if Tree.Label (Tokens (Name)) = Syntax_Trees.Virtual_Terminal then
+ if Tree.Is_Virtual (Tokens (Name)) then
+ -- Virtual tokens have the same Char_Region as the token they are
+ -- inserted before (for indent purposes), which leads to Name_Action
+ -- appearing to be applied twice. test/ada_mode-fatal_error_1.adb.
+ -- They also don't appear in the actual buffer, so setting a face or
+ -- completing on them is pointless.
return;
end if;
@@ -1311,11 +1321,26 @@ package body Wisi is
return;
elsif Has_Element (Cursor) then
raise Fatal_Error with Error_Message
- (File_Name => Data.Lexer.File_Name,
- Line => Name_Token.Line,
- Column => Name_Token.Column,
- Message => Trimmed_Image (Tree.Production_ID (Nonterm)) & ":
wisi-name-action: name set twice.");
+ (File_Name => Data.Lexer.File_Name,
+ Line => Name_Token.Line,
+ Column => Name_Token.Column,
+ Message => Tree.Image
+ (Tokens (Name), Data.Descriptor.all,
+ Node_Numbers => WisiToken.Trace_Action > Extra,
+ Include_RHS_Index => WisiToken.Trace_Action > Extra)
+ & ": wisi-name-action: name set twice.");
else
+ if Trace_Action > Detail then
+ Ada.Text_IO.Put_Line
+ ("Name_Action " & Tree.Image
+ (Nonterm, Data.Descriptor.all,
+ Node_Numbers => WisiToken.Trace_Action > Extra,
+ Include_RHS_Index => WisiToken.Trace_Action > Extra) & "
" & Tree.Image
+ (Tokens (Name), Data.Descriptor.all,
+ Node_Numbers => WisiToken.Trace_Action > Extra,
+ Include_RHS_Index => WisiToken.Trace_Action > Extra));
+ end if;
+
Data.Name_Caches.Insert (Name_Token.Char_Region);
end if;
end;
@@ -2121,8 +2146,11 @@ package body Wisi is
Line_Number_Type'Image (Item.Line) & ":" & Trimmed_Image (Integer
(Item.Column)) & ")";
elsif Item.Char_Region = Null_Buffer_Region then
- return "(" & ID_Image & ")";
-
+ if Item.Byte_Region = Null_Buffer_Region then
+ return "(" & ID_Image & ")";
+ else
+ return "(" & ID_Image & ", " & Image (Item.Byte_Region) & ")";
+ end if;
else
return "(" & ID_Image & ", " & Image (Item.Char_Region) & ")";
end if;
@@ -2329,7 +2357,7 @@ package body Wisi is
end if;
loop
- exit when Data.Line_Begin_Token.all (I) /=
Augmented_Token_Arrays.No_Index;
+ exit when Data.Line_Begin_Token.all (I) /=
Base_Token_Arrays.No_Index;
-- No_Index means Line is in a multi-line token, which
could be a block comment.
I := I - 1;
end loop;
diff --git a/wisi.ads b/wisi.ads
index db37e5d..e707ab8 100644
--- a/wisi.ads
+++ b/wisi.ads
@@ -36,7 +36,8 @@ package Wisi is
use all type WisiToken.Base_Buffer_Pos;
function Image (Aug : in WisiToken.Base_Token_Class_Access; Descriptor : in
WisiToken.Descriptor) return String;
- -- For Syntax_Trees.Print_Tree
+ function Image (Action : in WisiToken.Syntax_Trees.Semantic_Action) return
String;
+ -- For Syntax_Trees.Print_Tree, Parser.Execute_Action
type Post_Parse_Action_Type is (Navigate, Face, Indent);
@@ -333,7 +334,7 @@ package Wisi is
procedure Refactor
(Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
Action : in Positive;
Edit_Begin : in WisiToken.Buffer_Pos) is null;
@@ -458,16 +459,6 @@ private
return WisiToken.Line_Number_Type;
-- Return first and last line in Token's region.
- 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_Const_Ref (Item : in
Augmented_Token_Arrays.Constant_Reference_Type) return Aug_Token_Const_Ref
- is (Element =>
Augmented_Token_Access_Constant'(Item.Element.all'Unchecked_Access));
-
- function To_Aug_Token_Var_Ref (Item : in
Augmented_Token_Arrays.Variable_Reference_Type) return Aug_Token_Var_Ref
- is (Element =>
Augmented_Token_Access'(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
diff --git a/wisi.el b/wisi.el
index 48e9dc0..2032f93 100644
--- a/wisi.el
+++ b/wisi.el
@@ -7,7 +7,7 @@
;; Keywords: parser
;; indentation
;; navigation
-;; Version: 3.1.1
+;; Version: 3.1.2
;; package-requires: ((emacs "25.0") (seq "2.20"))
;; URL: http://stephe-leake.org/ada/wisitoken.html
;;
@@ -468,14 +468,16 @@ Used to ignore whitespace changes in before/after change
hooks.")
;; don't have to do it again in wisi-after-change.
(setq wisi--change-beg (min wisi--change-beg begin))
+ ;; `buffer-base-buffer' deals with edits in indirect buffers
+ ;; created by ediff-regions-*
+
(cond
((null wisi--change-end)
- (setq wisi--change-end (copy-marker end)))
+ (setq wisi--change-end (make-marker))
+ (set-marker wisi--change-end end (or (buffer-base-buffer)
(current-buffer))))
((> end wisi--change-end)
- ;; `buffer-base-buffer' deals with edits in indirect buffers
- ;; created by ediff-regions-*
- (set-marker wisi--change-end end (buffer-base-buffer)))
+ (set-marker wisi--change-end end (or (buffer-base-buffer)
(current-buffer))))
)
(unless (= begin end)
@@ -1660,6 +1662,7 @@ where the car is a list (FILE LINE COL)."
(defun wisi-show-containing-or-previous-cache ()
(interactive)
(let ((cache (wisi-get-cache (point))))
+ (push-mark)
(if cache
(message "containing %s" (wisi-goto-containing cache t))
(message "previous %s" (wisi-backward-cache)))
diff --git a/wisi.info b/wisi.info
index e338347..e24dcee 100644
--- a/wisi.info
+++ b/wisi.info
@@ -24,7 +24,7 @@ File: wisi.info, Node: Top, Next: Overview, Up: (dir)
Top
***
-Wisi Version 3.1.0
+Wisi Version 3.1.2
* Menu:
diff --git a/wisi.texi b/wisi.texi
index 3b9594a..3a7d3b3 100644
--- a/wisi.texi
+++ b/wisi.texi
@@ -25,7 +25,7 @@ developing GNU and promoting software freedom.''
@titlepage
@sp 10
-@title Wisi Version 3.1.0
+@title Wisi Version 3.1.2
@page
@vskip 0pt plus 1filll
@insertcopying
@@ -37,7 +37,7 @@ developing GNU and promoting software freedom.''
@node Top
@top Top
-Wisi Version 3.1.0
+Wisi Version 3.1.2
@end ifnottex
@menu
diff --git a/wisitoken-bnf-generate.adb b/wisitoken-bnf-generate.adb
index 1fe407a..821ef6f 100644
--- a/wisitoken-bnf-generate.adb
+++ b/wisitoken-bnf-generate.adb
@@ -50,7 +50,7 @@ is
use Ada.Text_IO;
First : Boolean := True;
begin
- Put_Line (Standard_Error, "version 2.0"); -- matches release version in
Docs/wisitoken.html
+ Put_Line (Standard_Error, "version 2.1"); -- matches release version in
Docs/wisitoken.html
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);
@@ -134,8 +134,6 @@ is
Input_Data : aliased WisiToken_Grammar_Runtime.User_Data_Type;
Grammar_Parser : WisiToken.Parse.LR.Parser_No_Recover.Parser;
- Do_Time : Boolean := False;
-
procedure Use_Input_File (File_Name : in String)
is
use Ada.Strings.Unbounded;
@@ -260,7 +258,7 @@ begin
elsif Argument (Arg_Next) = "--time" then
Arg_Next := Arg_Next + 1;
- Do_Time := True;
+ WisiToken.Trace_Time := True;
else
raise User_Error with "invalid argument '" & Argument (Arg_Next) &
"'";
@@ -341,8 +339,9 @@ begin
if Trace_Generate_EBNF > Detail then
Ada.Text_IO.Put_Line ("EBNF tree:");
- Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor);
- Ada.Text_IO.New_Line;
+ Tree.Print_Tree
+ (Wisitoken_Grammar_Actions.Descriptor,
+ Image_Action =>
WisiToken_Grammar_Runtime.Image_Grammar_Action'Access);
end if;
WisiToken_Grammar_Runtime.Translate_EBNF_To_BNF (Tree,
Input_Data);
@@ -350,7 +349,9 @@ begin
if Trace_Generate_EBNF > Detail then
Ada.Text_IO.New_Line;
Ada.Text_IO.Put_Line ("BNF tree:");
- Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor);
+ Tree.Print_Tree
+ (Wisitoken_Grammar_Actions.Descriptor,
+ Image_Action =>
WisiToken_Grammar_Runtime.Image_Grammar_Action'Access);
end if;
if Output_BNF then
@@ -456,55 +457,69 @@ begin
Time_Start := Clock;
- Generate_Data.LR_Parse_Table :=
WisiToken.Generate.LR.LALR_Generate.Generate
- (Generate_Data.Grammar,
- Generate_Data.Descriptor.all,
- Generate_Utils.To_Conflicts
- (Generate_Data, Input_Data.Conflicts,
Input_Data.Grammar_Lexer.File_Name),
- Generate_Utils.To_McKenzie_Param (Generate_Data,
Input_Data.McKenzie_Recover),
- Parse_Table_File_Name,
- Include_Extra => Test_Main,
- Ignore_Conflicts => Ignore_Conflicts,
- Partial_Recursion =>
Input_Data.Language_Params.Partial_Recursion);
-
- if Do_Time then
- Time_End := Clock;
-
- Put_Line
- (Standard_Error,
- "LALR " & Lexer_Image (Tuple.Lexer).all & " generate
time:" &
- Duration'Image (To_Duration (Time_End - Time_Start)));
- end if;
+ if Generate_Data.Grammar
(Generate_Data.Descriptor.Accept_ID).LHS = Invalid_Token_ID then
+ WisiToken.Generate.Put_Error
+ (WisiToken.Generate.Error_Message
+ (Grammar_Parser.Lexer.File_Name, 1,
+ "%start token not specified or not found; no LALR
parse table generated"));
+ else
+ Generate_Data.LR_Parse_Table :=
WisiToken.Generate.LR.LALR_Generate.Generate
+ (Generate_Data.Grammar,
+ Generate_Data.Descriptor.all,
+ Generate_Utils.To_Conflicts
+ (Generate_Data, Input_Data.Conflicts,
Input_Data.Grammar_Lexer.File_Name),
+ Generate_Utils.To_McKenzie_Param (Generate_Data,
Input_Data.McKenzie_Recover),
+ Parse_Table_File_Name,
+ Include_Extra => Test_Main,
+ Ignore_Conflicts => Ignore_Conflicts,
+ Partial_Recursion =>
Input_Data.Language_Params.Partial_Recursion);
+
+ if WisiToken.Trace_Time then
+ Time_End := Clock;
+
+ Put_Line
+ (Standard_Error,
+ "LALR " & Lexer_Image (Tuple.Lexer).all & " generate
time:" &
+ Duration'Image (To_Duration (Time_End -
Time_Start)));
+ end if;
- if Parse_Table_File_Name /= "" then
- Parse_Table_Append_Stats;
+ if Parse_Table_File_Name /= "" then
+ Parse_Table_Append_Stats;
+ end if;
end if;
when LR1 =>
Time_Start := Clock;
- Generate_Data.LR_Parse_Table :=
WisiToken.Generate.LR.LR1_Generate.Generate
- (Generate_Data.Grammar,
- Generate_Data.Descriptor.all,
- Generate_Utils.To_Conflicts
- (Generate_Data, Input_Data.Conflicts,
Input_Data.Grammar_Lexer.File_Name),
- Generate_Utils.To_McKenzie_Param (Generate_Data,
Input_Data.McKenzie_Recover),
- Parse_Table_File_Name,
- Include_Extra => Test_Main,
- Ignore_Conflicts => Ignore_Conflicts,
- Partial_Recursion =>
Input_Data.Language_Params.Partial_Recursion);
-
- if Do_Time then
- Time_End := Clock;
-
- Put_Line
- (Standard_Error,
- "LR1 " & Lexer_Image (Tuple.Lexer).all & " generate
time:" &
- Duration'Image (To_Duration (Time_End - Time_Start)));
- end if;
+ if Generate_Data.Grammar
(Generate_Data.Descriptor.Accept_ID).LHS = Invalid_Token_ID then
+ WisiToken.Generate.Put_Error
+ (WisiToken.Generate.Error_Message
+ (Grammar_Parser.Lexer.File_Name, 1,
+ "%start token not specified or not found; no LALR
parse table generated"));
+ else
+ Generate_Data.LR_Parse_Table :=
WisiToken.Generate.LR.LR1_Generate.Generate
+ (Generate_Data.Grammar,
+ Generate_Data.Descriptor.all,
+ Generate_Utils.To_Conflicts
+ (Generate_Data, Input_Data.Conflicts,
Input_Data.Grammar_Lexer.File_Name),
+ Generate_Utils.To_McKenzie_Param (Generate_Data,
Input_Data.McKenzie_Recover),
+ Parse_Table_File_Name,
+ Include_Extra => Test_Main,
+ Ignore_Conflicts => Ignore_Conflicts,
+ Partial_Recursion =>
Input_Data.Language_Params.Partial_Recursion);
+
+ if Trace_Time then
+ Time_End := Clock;
+
+ Put_Line
+ (Standard_Error,
+ "LR1 " & Lexer_Image (Tuple.Lexer).all & " generate
time:" &
+ Duration'Image (To_Duration (Time_End -
Time_Start)));
+ end if;
- if Parse_Table_File_Name /= "" then
- Parse_Table_Append_Stats;
+ if Parse_Table_File_Name /= "" then
+ Parse_Table_Append_Stats;
+ end if;
end if;
when Packrat_Generate_Algorithm =>
diff --git a/wisitoken-bnf-generate_packrat.adb
b/wisitoken-bnf-generate_packrat.adb
index e76fbee..b4592e5 100644
--- a/wisitoken-bnf-generate_packrat.adb
+++ b/wisitoken-bnf-generate_packrat.adb
@@ -277,10 +277,12 @@ is
Indent_Line ("end if;");
Indent_Line ("goto Recurse_Start;");
Indent := Indent - 3;
- Indent_Line ("elsif Pos = Pos_Recurse_Last and then
Parser.Tree.Is_Empty (Result_Recurse.Result) then");
+ Indent_Line
+ ("elsif Pos = Pos_Recurse_Last and then " &
+ "Parser.Tree.Buffer_Region_Is_Empty (Result_Recurse.Result)
then");
-- Parse succeeded producing an empty nonterm; don't try again. This
-- special case is not in [warth 2008].
- Indent_Line (" Parser.Derivs (8).Replace_Element (Start_Pos,
Result_Recurse);");
+ Indent_Line (" Parser.Derivs (" & Result_ID & ").Replace_Element
(Start_Pos, Result_Recurse);");
Indent_Line ("end if;");
Indent := Indent - 3;
Indent_Line ("end if;");
diff --git a/wisitoken-bnf-generate_utils.adb b/wisitoken-bnf-generate_utils.adb
index 0e6eb4d..b5622d0 100644
--- a/wisitoken-bnf-generate_utils.adb
+++ b/wisitoken-bnf-generate_utils.adb
@@ -87,21 +87,26 @@ package body WisiToken.BNF.Generate_Utils is
Data.Check_Names := new Names_Array_Array (Descriptor.First_Nonterminal
.. Descriptor.Last_Nonterminal);
pragma Assert (Descriptor.Accept_ID = Descriptor.First_Nonterminal);
- begin
- Data.Grammar (Descriptor.Accept_ID) :=
- Descriptor.Accept_ID <= Only
- (Find_Token_ID (Data, Start_Token) & Descriptor.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_Last
(0, 0);
- Data.Source_Line_Map (Descriptor.Accept_ID).RHS_Map (0) :=
Line_Number_Type'First;
- exception
- when Not_Found =>
- Put_Error
- (Error_Message
- (Source_File_Name, 1,
- "start token '" & (Start_Token) & "' not found; need %start?"));
- end;
+
+ Data.Source_Line_Map (Descriptor.Accept_ID).Line :=
Line_Number_Type'First;
+ 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;
+
+ if Start_Token = "" then
+ Put_Error (Error_Message (Source_File_Name, 1, "%start not
specified"));
+ else
+ begin
+ Data.Grammar (Descriptor.Accept_ID) :=
+ Descriptor.Accept_ID <= Only
+ (Find_Token_ID (Data, Start_Token) & Descriptor.EOI_ID +
WisiToken.Syntax_Trees.Null_Action);
+ exception
+ when Not_Found =>
+ Put_Error
+ (Error_Message
+ (Source_File_Name, 1,
+ "start token '" & (Start_Token) & "' not found"));
+ end;
+ end if;
for Rule of Data.Tokens.Rules loop
declare
diff --git a/wisitoken-followed_by.adb b/wisitoken-followed_by.adb
new file mode 100644
index 0000000..e254bb6
--- /dev/null
+++ b/wisitoken-followed_by.adb
@@ -0,0 +1,207 @@
+-- Abstract :
+--
+-- Show productions where a token is followed by another token
+--
+-- Copyright (C) 2020 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.
+
+pragma License (GPL);
+
+with Ada.Command_Line;
+with WisiToken.BNF.Generate_Utils;
+with WisiToken.Generate;
+with WisiToken.Parse.LR.Parser_No_Recover;
+with WisiToken.Productions;
+with WisiToken.Text_IO_Trace;
+with WisiToken_Grammar_Runtime;
+with Wisitoken_Grammar_Actions;
+with Wisitoken_Grammar_Main;
+procedure WisiToken.Followed_By
+is
+ use all type WisiToken_Grammar_Runtime.Meta_Syntax;
+
+ procedure Put_Usage
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("wisitoken-followed_by <grammar file> <token a> <token b>");
+ end Put_Usage;
+
+ function Last
+ (Grammar : in Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal : in Token_ID)
+ return Token_Array_Token_Set
+ is
+ function Last
+ (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
+ Has_Empty_Production : in Token_ID_Set;
+ First_Terminal : in Token_ID;
+ Non_Terminal : in Token_ID)
+ return Token_ID_Set
+ is
+ Search_Tokens : Token_ID_Set := (Grammar.First_Index ..
Grammar.Last_Index => False);
+ begin
+ Search_Tokens (Non_Terminal) := True;
+
+ return Result : Token_ID_Set := (First_Terminal .. Grammar.Last_Index
=> False) do
+ while Any (Search_Tokens) loop
+ declare
+ Added_Tokens : Token_ID_Set := (First_Terminal ..
Grammar.Last_Index => False);
+ Added_Nonterms : Token_ID_Set := (Grammar.First_Index ..
Grammar.Last_Index => False);
+ begin
+ for Prod of Grammar loop
+ if Search_Tokens (Prod.LHS) then
+ for RHS of Prod.RHSs loop
+ for ID of reverse RHS.Tokens loop
+ if not Result (ID) then
+ Added_Tokens (ID) := True;
+ if ID in Added_Nonterms'Range then
+ Added_Nonterms (ID) := True;
+ end if;
+ end if;
+
+ if ID in Has_Empty_Production'Range and then
Has_Empty_Production (ID) then
+ null;
+ else
+ exit;
+ end if;
+ end loop;
+ end loop;
+ end if;
+ end loop;
+
+ Result := Result or Added_Tokens;
+ Search_Tokens := Added_Nonterms;
+ end;
+ end loop;
+ end return;
+ end Last;
+
+ procedure Set_Slice (Result : in out Token_Array_Token_Set; I :
Token_ID; Value : in Token_ID_Set)
+ is begin
+ for J in Result'Range (2) loop
+ Result (I, J) := Value (J);
+ end loop;
+ end Set_Slice;
+
+ begin
+ return Result : Token_Array_Token_Set :=
+ (Grammar.First_Index .. Grammar.Last_Index =>
+ (First_Terminal .. Grammar.Last_Index => False))
+ do
+ for I in Result'Range loop
+ Set_Slice (Result, I, Last (Grammar, Has_Empty_Production,
First_Terminal, I));
+ end loop;
+ end return;
+ end Last;
+
+ Trace : aliased WisiToken.Text_IO_Trace.Trace
(Wisitoken_Grammar_Actions.Descriptor'Access);
+ Input_Data : aliased WisiToken_Grammar_Runtime.User_Data_Type;
+ Grammar_Parser : WisiToken.Parse.LR.Parser_No_Recover.Parser;
+
+ Token_A_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Token_B_Name : Ada.Strings.Unbounded.Unbounded_String;
+begin
+ Wisitoken_Grammar_Main.Create_Parser
+ (Parser => Grammar_Parser,
+ Trace => Trace'Unchecked_Access,
+ User_Data => Input_Data'Unchecked_Access);
+
+ declare
+ use Ada.Command_Line;
+ begin
+ if Argument_Count /= 3 then
+ Put_Usage;
+ end if;
+
+ Grammar_Parser.Lexer.Reset_With_File (Argument (1));
+
+ Token_A_Name := +Argument (2);
+ Token_B_Name := +Argument (3);
+ end;
+
+ Grammar_Parser.Parse;
+ Grammar_Parser.Execute_Actions; -- Meta phase.
+
+ if Input_Data.Meta_Syntax = WisiToken_Grammar_Runtime.EBNF_Syntax then
+ WisiToken_Grammar_Runtime.Translate_EBNF_To_BNF
(Grammar_Parser.Parsers.First_State_Ref.Tree, Input_Data);
+ if WisiToken.Generate.Error then
+ raise WisiToken.Grammar_Error with "errors during translating EBNF to
BNF: aborting";
+ end if;
+ end if;
+
+ Input_Data.Reset;
+ Input_Data.Phase := WisiToken_Grammar_Runtime.Other;
+ Grammar_Parser.Execute_Actions; -- populates Input_Data.Tokens
+
+ declare
+ use Ada.Text_IO;
+
+ Generate_Data : aliased WisiToken.BNF.Generate_Utils.Generate_Data :=
+ WisiToken.BNF.Generate_Utils.Initialize (Input_Data, Ignore_Conflicts
=> True);
+ -- Builds Generate_Data.Descriptor, Generate_Data.Grammar
+
+ Nullable : constant Token_Array_Production_ID :=
WisiToken.Generate.Nullable (Generate_Data.Grammar);
+ Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Nullable);
+
+ First_Nonterm_Set : constant Token_Array_Token_Set :=
WisiToken.Generate.First
+ (Generate_Data.Grammar, Has_Empty_Production,
Generate_Data.Descriptor.First_Terminal);
+
+ Last_Nonterm_Set : constant Token_Array_Token_Set := Last
+ (Generate_Data.Grammar, Has_Empty_Production,
Generate_Data.Descriptor.First_Terminal);
+
+ Token_A : constant Token_ID := BNF.Generate_Utils.Find_Token_ID
(Generate_Data, -Token_A_Name);
+ Token_B : constant Token_ID := BNF.Generate_Utils.Find_Token_ID
(Generate_Data, -Token_B_Name);
+ Need_Comma : Boolean := False;
+
+ procedure Put (LHS : in Token_ID; RHS : in Natural)
+ is
+ begin
+ if Need_Comma then
+ Put (", ");
+ else
+ Need_Comma := True;
+ end if;
+ Put (Trimmed_Image ((LHS, RHS)));
+ end Put;
+
+ begin
+ for LHS in Generate_Data.Grammar.First_Index ..
Generate_Data.Grammar.Last_Index loop
+ declare
+ use WisiToken.Productions;
+ Prod : Instance renames Generate_Data.Grammar (LHS);
+ begin
+ for I in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
+ declare
+ Tokens : Token_ID_Arrays.Vector renames Prod.RHSs (I).Tokens;
+ begin
+ for J in Tokens.First_Index .. Tokens.Last_Index loop
+ if Tokens (J) = Token_A or
+ (Tokens (J) in Last_Nonterm_Set'Range (1) and then
+ Last_Nonterm_Set (Tokens (J), Token_A))
+ then
+ if J < Tokens.Last_Index then
+ if Tokens (J + 1) in First_Nonterm_Set'Range (1)
then
+ if First_Nonterm_Set (Tokens (J + 1), Token_B)
then
+ Put (LHS, I);
+ end if;
+ elsif Tokens (J + 1) = Token_B then
+ Put (LHS, I);
+ end if;
+ end if;
+ end if;
+ end loop;
+ end;
+ end loop;
+ end;
+ end loop;
+ end;
+
+end WisiToken.Followed_By;
diff --git a/wisitoken-generate.adb b/wisitoken-generate.adb
index 1d7bb7e..c14077d 100644
--- a/wisitoken-generate.adb
+++ b/wisitoken-generate.adb
@@ -18,8 +18,9 @@
pragma License (Modified_GPL);
with Ada.Directories;
-with Ada.Text_IO;
+with Ada.Real_Time;
with Ada.Strings.Fixed;
+with Ada.Text_IO;
package body WisiToken.Generate is
function Error_Message
@@ -229,52 +230,43 @@ package body WisiToken.Generate is
Non_Terminal : in Token_ID)
return Token_ID_Set
is
- Derivations : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
- Added_Tokens : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
- Search_Tokens : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
-
- function Compute_Non_Terminals return Token_ID_Set
- is
- Result : Token_ID_Set := (First_Terminal .. Grammar.Last_Index =>
False);
- begin
- -- Can't use a simple aggregate for this; bounds are non-static.
- Result (First_Terminal .. Grammar.First_Index - 1) := (others =>
False);
- Result (Grammar.First_Index .. Grammar.Last_Index) := (others =>
True);
- return Result;
- end Compute_Non_Terminals;
-
- Non_Terminals : constant Token_ID_Set := Compute_Non_Terminals;
-
+ Search_Tokens : Token_ID_Set := (Grammar.First_Index ..
Grammar.Last_Index => False);
begin
Search_Tokens (Non_Terminal) := True;
- while Any (Search_Tokens) loop
-
- Added_Tokens := (others => False);
-
- for Prod of Grammar loop
- if Search_Tokens (Prod.LHS) then
- for RHS of Prod.RHSs loop
- for Derived_Token of RHS.Tokens loop
- if not Derivations (Derived_Token) then
- Added_Tokens (Derived_Token) := True;
- end if;
-
- if Non_Terminals (Derived_Token) and then
Has_Empty_Production (Derived_Token) then
- null;
- else
- exit;
- end if;
- end loop;
+ return Derivations : Token_ID_Set := (First_Terminal ..
Grammar.Last_Index => False) do
+ while Any (Search_Tokens) loop
+ declare
+ Added_Tokens : Token_ID_Set := (First_Terminal ..
Grammar.Last_Index => False);
+ Added_Nonterms : Token_ID_Set := (Grammar.First_Index ..
Grammar.Last_Index => False);
+ begin
+ for Prod of Grammar loop
+ if Search_Tokens (Prod.LHS) then
+ for RHS of Prod.RHSs loop
+ for Derived_Token of RHS.Tokens loop
+ if not Derivations (Derived_Token) then
+ Added_Tokens (Derived_Token) := True;
+ if Derived_Token in Added_Nonterms'Range then
+ Added_Nonterms (Derived_Token) := True;
+ end if;
+ end if;
+
+ if Derived_Token in Has_Empty_Production'Range and
then
+ Has_Empty_Production (Derived_Token)
+ then
+ null;
+ else
+ exit;
+ end if;
+ end loop;
+ end loop;
+ end if;
end loop;
- end if;
+ Derivations := Derivations or Added_Tokens;
+ Search_Tokens := Added_Nonterms;
+ end;
end loop;
-
- Derivations := Derivations or Added_Tokens;
- Search_Tokens := Added_Tokens and Non_Terminals;
- end loop;
-
- return Derivations;
+ end return;
end First;
function First
@@ -496,6 +488,8 @@ package body WisiToken.Generate is
Descriptor : in WisiToken.Descriptor)
return Recursions
is
+ Time_Start : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
+
Graph : constant Grammar_Graphs.Graph := To_Graph (Grammar);
begin
return Result : Recursions :=
@@ -506,6 +500,17 @@ package body WisiToken.Generate is
Set_Grammar_Recursions (Result, Grammar);
+ if Trace_Time then
+ declare
+ use Ada.Real_Time;
+ Time_End : constant Time := Clock;
+ begin
+ Ada.Text_IO.Put_Line
+ (Ada.Text_IO.Standard_Error, "compute partial recursion
time:" &
+ Duration'Image (To_Duration (Time_End - Time_Start)));
+ end;
+ end if;
+
if Trace_Generate_Minimal_Complete > Extra then
Ada.Text_IO.New_Line;
Ada.Text_IO.Put_Line ("Productions:");
@@ -525,6 +530,8 @@ package body WisiToken.Generate is
return Recursions
is
use Grammar_Graphs;
+ Time_Start : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
+
Graph : constant Grammar_Graphs.Graph := To_Graph (Grammar);
Components : constant Component_Lists.List :=
Strongly_Connected_Components
(To_Adjancency (Graph), Non_Trivial_Only => True);
@@ -558,6 +565,17 @@ package body WisiToken.Generate is
Set_Grammar_Recursions (Result, Grammar);
+ if Trace_Time then
+ declare
+ use Ada.Real_Time;
+ Time_End : constant Time := Clock;
+ begin
+ Ada.Text_IO.Put_Line
+ (Ada.Text_IO.Standard_Error, "compute full recursion time:" &
+ Duration'Image (To_Duration (Time_End - Time_Start)));
+ end;
+ end if;
+
if Trace_Generate_Minimal_Complete > Extra then
Ada.Text_IO.New_Line;
Ada.Text_IO.Put_Line ("Productions:");
diff --git a/wisitoken-parse-lr-mckenzie_recover.adb
b/wisitoken-parse-lr-mckenzie_recover.adb
index 24c33d2..3287fb4 100644
--- a/wisitoken-parse-lr-mckenzie_recover.adb
+++ b/wisitoken-parse-lr-mckenzie_recover.adb
@@ -131,7 +131,7 @@ package body WisiToken.Parse.LR.McKenzie_Recover is
Trace.Put_Line
("parser" & Integer'Image (Parser_State.Label) &
": State" & State_Index'Image (Parser_State.Stack (1).State) &
- " Current_Token" & Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) &
+ " Current_Token " & Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) &
" Resume_Token_Goal" & WisiToken.Token_Index'Image
(Config.Resume_Token_Goal));
Trace.Put_Line
((case Error.Label is
diff --git a/wisitoken-parse-lr-parser.adb b/wisitoken-parse-lr-parser.adb
index a3dded3..04b6f6b 100644
--- a/wisitoken-parse-lr-parser.adb
+++ b/wisitoken-parse-lr-parser.adb
@@ -1115,10 +1115,27 @@ package body WisiToken.Parse.LR.Parser is
exception
when E : others =>
declare
- Token : Base_Token renames Parser.Terminals
(Tree.First_Shared_Terminal (Node));
+ Line : Line_Number_Type := Line_Number_Type'First;
+ Column : Ada.Text_IO.Count := Ada.Text_IO.Count'First;
begin
+ if Tree.First_Shared_Terminal (Node) =
Invalid_Token_Index then
+ declare
+ Byte_Region : Buffer_Region renames
Tree.Byte_Region (Node);
+ begin
+ if Byte_Region /= Null_Buffer_Region then
+ Column := Ada.Text_IO.Count (Byte_Region.First);
+ end if;
+ end;
+ else
+ declare
+ Token : Base_Token renames Parser.Terminals
(Tree.First_Shared_Terminal (Node));
+ begin
+ Line := Token.Line;
+ Column := Token.Column;
+ end;
+ end if;
raise WisiToken.Parse_Error with Error_Message
- (Parser.Lexer.File_Name, Token.Line, Token.Column,
+ (Parser.Lexer.File_Name, Line, Column,
"action raised exception " &
Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
end;
diff --git a/wisitoken-parse-lr-parser_no_recover.adb
b/wisitoken-parse-lr-parser_no_recover.adb
index 5e23b7c..6fd2b80 100644
--- a/wisitoken-parse-lr-parser_no_recover.adb
+++ b/wisitoken-parse-lr-parser_no_recover.adb
@@ -459,10 +459,27 @@ package body WisiToken.Parse.LR.Parser_No_Recover is
exception
when E : others =>
declare
- Token : Base_Token renames Parser.Terminals
(Tree.First_Shared_Terminal (Node));
+ Line : Line_Number_Type := Line_Number_Type'First;
+ Column : Ada.Text_IO.Count := Ada.Text_IO.Count'First;
begin
+ if Tree.First_Shared_Terminal (Node) =
Invalid_Token_Index then
+ declare
+ Byte_Region : Buffer_Region renames
Tree.Byte_Region (Node);
+ begin
+ if Byte_Region /= Null_Buffer_Region then
+ Column := Ada.Text_IO.Count (Byte_Region.First);
+ end if;
+ end;
+ else
+ declare
+ Token : Base_Token renames Parser.Terminals
(Tree.First_Shared_Terminal (Node));
+ begin
+ Line := Token.Line;
+ Column := Token.Column;
+ end;
+ end if;
raise WisiToken.Parse_Error with Error_Message
- (Parser.Lexer.File_Name, Token.Line, Token.Column,
+ (Parser.Lexer.File_Name, Line, Column,
"action raised exception " &
Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
end;
diff --git a/wisitoken-parse-packrat-procedural.adb
b/wisitoken-parse-packrat-procedural.adb
index 44ab122..887794e 100644
--- a/wisitoken-parse-packrat-procedural.adb
+++ b/wisitoken-parse-packrat-procedural.adb
@@ -141,8 +141,15 @@ package body WisiToken.Parse.Packrat.Procedural is
Parser.Derivs (R).Replace_Element (Start_Pos, (State => Failure));
else
Memo := Eval (Parser, R, Last_Pos);
- if Trace_Parse > Detail and then Memo.State = Success then
- Parser.Trace.Put_Line (Parser.Tree.Image (Memo.Result,
Descriptor, Include_Children => True));
+ if (Trace_Parse > Detail and Memo.State = Success) or Trace_Parse
> Extra then
+ case Memo.State is
+ when Success =>
+ Parser.Trace.Put_Line (Parser.Tree.Image (Memo.Result,
Descriptor, Include_Children => True));
+ when Failure =>
+ Parser.Trace.Put_Line (Image (R, Descriptor) & " failed at
pos" & Last_Pos'Image);
+ when No_Result =>
+ raise SAL.Programmer_Error;
+ end case;
end if;
Parser.Derivs (R).Replace_Element (Start_Pos, Memo);
return Memo;
@@ -172,7 +179,7 @@ package body WisiToken.Parse.Packrat.Procedural is
-- continue looping
elsif Result_Recurse.Last_Pos = Pos_Recurse_Last then
- if Parser.Tree.Is_Empty (Result_Recurse.Result) then
+ if Parser.Tree.Buffer_Region_Is_Empty (Result_Recurse.Result)
then
Parser.Derivs (R).Replace_Element (Start_Pos,
Result_Recurse);
end if;
exit;
diff --git a/wisitoken-syntax_trees-lr_utils.adb
b/wisitoken-syntax_trees-lr_utils.adb
index c75ccea..cf04a80 100644
--- a/wisitoken-syntax_trees-lr_utils.adb
+++ b/wisitoken-syntax_trees-lr_utils.adb
@@ -30,62 +30,115 @@ package body WisiToken.Syntax_Trees.LR_Utils is
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));
+ -- Not clear why we need Line + 1 here, to match Emacs.
+ (if Terminal_Index = Invalid_Token_Index then 1 else Terminals
(Terminal_Index).Line + 1), 0,
+ Label & ": " &
+ Tree.Image (Node, Descriptor, Include_Children => True,
Include_RHS_Index => True, Node_Numbers => 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);
+ function Count (Container : Constant_List) return Ada.Containers.Count_Type
+ is
+ use Ada.Containers;
+ Result : Count_Type := 0;
+ begin
+ for Item of Container loop
+ Result := Result + 1;
+ end loop;
+ return Result;
+ end Count;
- overriding function First (Iter : Iterator) return Cursor
+ function Contains (Container : in Constant_List; Node : in
Valid_Node_Index) return Boolean
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;
+ return (for some N of Container => N = Node);
+ end Contains;
- overriding function Last (Iter : Iterator) return Cursor
+ function To_Cursor (Container : in Constant_List; Node : in
Valid_Node_Index) 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);
+ pragma Unreferenced (Container);
begin
- return (Node => Children (Children'Last));
+ return (Node => Node);
+ end To_Cursor;
+
+ function Contains (Container : in Constant_List; Item : in Cursor) return
Boolean
+ is begin
+ return (for some N of Container => N = Item.Node);
+ end Contains;
+
+ function First
+ (Tree : in WisiToken.Syntax_Trees.Tree;
+ Root : in WisiToken.Node_Index;
+ List_ID : in WisiToken.Token_ID;
+ Element_ID : in WisiToken.Token_ID)
+ return Node_Index
+ is begin
+ if Root = Invalid_Node_Index then
+ return Invalid_Node_Index;
+ else
+ return Result : Node_Index do
+ Result := Root;
+ loop
+ declare
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Result);
+ begin
+ if Tree.ID (Children (1)) = List_ID then
+ Result := Children (1);
+ elsif Tree.ID (Children (1)) = Element_ID then
+ Result := Children (1);
+ exit;
+ else
+ raise SAL.Programmer_Error;
+ end if;
+ end;
+ end loop;
+ end return;
+ end if;
+ end First;
+
+ function First (Container : in Constant_List) return Cursor
+ is begin
+ return (Node => First (Container.Tree.all, Container.Root,
Container.List_ID, Container.Element_ID));
+ end First;
+
+ function Last
+ (Tree : in WisiToken.Syntax_Trees.Tree;
+ Root : in WisiToken.Node_Index)
+ return Node_Index
+ is begin
+ if Root = Invalid_Node_Index then
+ return Invalid_Node_Index;
+ else
+ -- 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
+ return Tree.Child (Root, SAL.Base_Peek_Type (Tree.Child_Count
(Root)));
+ end if;
end Last;
- overriding function Next (Iter : Iterator; Position : Cursor) return Cursor
+ function Last (Container : in Constant_List) return Cursor
is begin
- if Position.Node = Invalid_Node_Index then
+ return (Node => Last (Container.Tree.all, Container.Root));
+ end Last;
+
+ function Next
+ (Tree : in Syntax_Trees.Tree;
+ List_ID : in Token_ID;
+ Element_ID : in Token_ID;
+ Position : in Node_Index)
+ return Node_Index
+ is begin
+ if Position = Invalid_Node_Index then
return Position;
else
- return Result : Cursor do
+ return Result : Node_Index do
declare
- use all type SAL.Base_Peek_Type;
-- Tree is one of:
--
-- case a: first element, no next
@@ -116,25 +169,30 @@ package body WisiToken.Syntax_Trees.LR_Utils is
-- | | 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;
+ Grand_Parent : constant Node_Index := Tree.Parent (Position, 2);
+
+ Aunts : constant Valid_Node_Index_Array :=
+ (if Grand_Parent = Invalid_Node_Index or else Tree.ID
(Grand_Parent) /= List_ID
+ then (1 .. 0 => Invalid_Node_Index)
+ else 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
+ if Grand_Parent = Invalid_Node_Index or else Tree.ID
(Grand_Parent) /= List_ID then
-- No next
- Result.Node := Invalid_Node_Index;
+ Result := Invalid_Node_Index;
else
for I in Aunts'Range loop
- if Iter.Tree.ID (Aunts (I)) in Iter.List_ID |
Iter.Element_ID then
+ if Tree.ID (Aunts (I)) in List_ID | Element_ID then
Last_List_Child := I;
end if;
end loop;
if Last_List_Child = 1 then
-- No next
- Result.Node := Invalid_Node_Index;
+ Result := Invalid_Node_Index;
else
- Result.Node := Aunts (Last_List_Child);
+ Result := Aunts (Last_List_Child);
end if;
end if;
end;
@@ -142,12 +200,22 @@ package body WisiToken.Syntax_Trees.LR_Utils is
end if;
end Next;
- overriding function Previous (Iter : Iterator; Position : Cursor) return
Cursor
+ overriding function Next (Iter : Iterator; Position : Cursor) return Cursor
+ is begin
+ return
+ (Node => Next
+ (Iter.Container.Tree.all, Iter.Container.List_ID,
Iter.Container.Element_ID, Position.Node));
+ end Next;
+
+ function Previous
+ (Tree : in Syntax_Trees.Tree;
+ Position : in Node_Index)
+ return Node_Index
is begin
- if Position.Node = Invalid_Node_Index then
+ if Position = Invalid_Node_Index then
return Position;
else
- return Result : Cursor do
+ return Result : Node_Index do
-- Tree is one of:
--
-- case a: first element, no prev
@@ -169,18 +237,18 @@ package body WisiToken.Syntax_Trees.LR_Utils is
-- | | rhs_item: prev element
-- | rhs_item: Element
declare
- Parent : constant Valid_Node_Index := Iter.Tree.Parent
(Position.Node);
+ Parent : constant Valid_Node_Index := Tree.Parent (Position);
begin
- if Position.Node = Iter.Tree.Child (Parent, 1) then
+ if Position = Tree.Child (Parent, 1) then
-- No prev
- Result.Node := Invalid_Node_Index;
+ Result := Invalid_Node_Index;
else
declare
- Prev_Children : constant Valid_Node_Index_Array :=
Iter.Tree.Children
- (Iter.Tree.Child (Parent, 1));
+ Prev_Children : constant Valid_Node_Index_Array :=
Tree.Children
+ (Tree.Child (Parent, 1));
begin
- Result.Node := Prev_Children (Prev_Children'Last);
+ Result := Prev_Children (Prev_Children'Last);
end;
end if;
end;
@@ -188,33 +256,684 @@ package body WisiToken.Syntax_Trees.LR_Utils is
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
+ overriding function Previous (Iter : Iterator; Position : Cursor) return
Cursor
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
+ return (Node => Previous (Iter.Container.Tree.all, Position.Node));
+ end Previous;
+
+ function List_Constant_Ref (Container : aliased in Constant_List'Class;
Position : in Cursor) return Valid_Node_Index
is
- use Ada.Containers;
- Result : Count_Type := 0;
+ pragma Unreferenced (Container);
begin
- for Item in Iter loop
- Result := Result + 1;
+ return Position.Node;
+ end List_Constant_Ref;
+
+ overriding function Next (Iter : in Constant_Iterator; Position : Cursor)
return Cursor
+ is begin
+ return (Node => Next (Iter.Container.Tree.all, Iter.Container.List_ID,
Iter.Container.Element_ID, Position.Node));
+ end Next;
+
+ overriding function Previous (Iter : in Constant_Iterator; Position :
Cursor) return Cursor
+ is begin
+ return (Node => Previous (Iter.Container.Tree.all, Position.Node));
+ end Previous;
+
+ function Find
+ (Container : in Constant_List;
+ Target : in Valid_Node_Index)
+ return Cursor
+ is begin
+ for Cur in Container.Iterate_Constant loop
+ if Target = Cur.Node then
+ return Cur;
+ end if;
end loop;
- return Result;
- end Count;
+ return No_Element;
+ end Find;
+
+ function Find
+ (Container : in Constant_List;
+ Target : in String;
+ Equal : in Find_Equal)
+ return Cursor
+ is begin
+ for Cur in Container.Iterate_Constant loop
+ if Equal (Target, Container, Cur.Node) then
+ return Cur;
+ end if;
+ end loop;
+ return No_Element;
+ end Find;
+
+ package body Creators is
+
+ function Create_List
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Root : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID;
+ Element_ID : in WisiToken.Token_ID;
+ Separator_ID : in WisiToken.Token_ID)
+ return List
+ is
+ pragma Unreferenced (List_ID); -- checked in precondition.
+
+ Multi_Element_RHS : constant Natural :=
+ (if Tree.Child_Count (Root) = 1
+ then (if Tree.RHS_Index (Root) = 0 then 1 else 0)
+ elsif Tree.Child_Count (Root) in 2 .. 3 -- 3 if there is a
separator
+ then Tree.RHS_Index (Root)
+ else raise SAL.Programmer_Error);
+ begin
+ return
+ (Tree'Access, Root,
+ List_ID => Tree.ID (Root),
+ One_Element_RHS => (if Multi_Element_RHS = 0 then 1 else 0),
+ Multi_Element_RHS => Multi_Element_RHS,
+ Element_ID => Element_ID,
+ Separator_ID => Separator_ID);
+ end Create_List;
+
+ function Create_List
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Root : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID;
+ Element_ID : in WisiToken.Token_ID)
+ return Constant_List
+ is
+ pragma Unreferenced (List_ID); -- in precondition
+ begin
+ return
+ (Tree'Access, Root,
+ List_ID => Tree.ID (Root),
+ Element_ID => Element_ID);
+ end Create_List;
+
+ function Create_List
+ (Container : in Constant_List;
+ Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Root : in Valid_Node_Index)
+ return Constant_List
+ is begin
+ return Create_List (Tree, Root, Container.List_ID,
Container.Element_ID);
+ end Create_List;
+
+ function Create_List (Container : in out List; Root : in
Valid_Node_Index) return List
+ is begin
+ return Create_List (Container.Tree.all, Root, Container.List_ID,
Container.Element_ID, Container.Separator_ID);
+ end Create_List;
+
+ function Create_From_Element
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Element : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID;
+ Element_ID : in WisiToken.Token_ID;
+ Separator_ID : in WisiToken.Token_ID)
+ return List
+ is
+ Root : Valid_Node_Index := Tree.Parent (Element);
+ begin
+ loop
+ exit when Tree.Parent (Root) = Invalid_Node_Index or else Tree.ID
(Tree.Parent (Root)) /= List_ID;
+ Root := Tree.Parent (Root);
+ end loop;
+ return Create_List (Tree, Root, List_ID, Element_ID, Separator_ID);
+ end Create_From_Element;
+
+ function Create_From_Element (Container : in out List; Element : in
Valid_Node_Index) return List
+ is begin
+ return Create_From_Element
+ (Container.Tree.all, Element, Container.List_ID,
Container.Element_ID, Container.Separator_ID);
+ end Create_From_Element;
+
+ function Create_From_Element
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Element : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID;
+ Element_ID : in WisiToken.Token_ID)
+ return Constant_List
+ is
+ Root : Valid_Node_Index := Tree.Parent (Element);
+ begin
+ loop
+ exit when Tree.Parent (Root) = Invalid_Node_Index or else Tree.ID
(Tree.Parent (Root)) /= List_ID;
+ Root := Tree.Parent (Root);
+ end loop;
+ return Create_List (Tree, Root, List_ID, Element_ID);
+ end Create_From_Element;
+
+ function Invalid_List (Tree : aliased in out
WisiToken.Syntax_Trees.Tree) return List
+ is begin
+ return
+ (Tree => Tree'Access,
+ Root => Invalid_Node_Index,
+ List_ID => Invalid_Token_ID,
+ One_Element_RHS => 0,
+ Multi_Element_RHS => 0,
+ Element_ID => Invalid_Token_ID,
+ Separator_ID => Invalid_Token_ID);
+ end Invalid_List;
+
+ function Invalid_List (Tree : aliased in out
WisiToken.Syntax_Trees.Tree) return Constant_List
+ is begin
+ return
+ (Tree => Tree'Access,
+ Root => Invalid_Node_Index,
+ List_ID => Invalid_Token_ID,
+ Element_ID => Invalid_Token_ID);
+ end Invalid_List;
+
+ function Empty_List
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ List_ID : in WisiToken.Token_ID;
+ Multi_Element_RHS : in Natural;
+ Element_ID : in WisiToken.Token_ID;
+ Separator_ID : in WisiToken.Token_ID)
+ return List
+ is begin
+ return
+ (Tree'Access,
+ Root => Invalid_Node_Index,
+ List_ID => List_ID,
+ One_Element_RHS => (if Multi_Element_RHS = 0 then 1 else 0),
+ Multi_Element_RHS => Multi_Element_RHS,
+ Element_ID => Element_ID,
+ Separator_ID => Separator_ID);
+ end Empty_List;
+
+ function Empty_List (Container : in out List) return List
+ is begin
+ return Empty_List
+ (Container.Tree.all, Container.List_ID,
Container.Multi_Element_RHS, Container.Element_ID,
+ Container.Separator_ID);
+ end Empty_List;
+ end Creators;
+
+ procedure Append
+ (Container : in out List;
+ New_Element : in Valid_Node_Index)
+ is
+ Tree : Syntax_Trees.Tree renames Container.Tree.all;
+ begin
+ if Container.Root = Invalid_Node_Index then
+ Container :=
+ (Container.Tree,
+ List_ID => Container.List_ID,
+ One_Element_RHS => Container.One_Element_RHS,
+ Multi_Element_RHS => Container.Multi_Element_RHS,
+ Element_ID => Container.Element_ID,
+ Separator_ID => Container.Separator_ID,
+ Root => Tree.Add_Nonterm
+ (Production => (Container.List_ID,
Container.One_Element_RHS),
+ Children => (1 => New_Element)));
+
+ else
+ -- Adding element Last in spec example
+ declare
+ List_Parent : constant Node_Index := Tree.Parent
(Container.Root);
+ Old_Root : constant Valid_Node_Index := Container.Root;
+ Child_Index : constant SAL.Base_Peek_Type :=
+ (if List_Parent = Invalid_Node_Index
+ then 0
+ else Tree.Child_Index (List_Parent, Old_Root));
+ begin
+ Container.Root :=
+ Tree.Add_Nonterm
+ (Production => (Container.List_ID,
Container.Multi_Element_RHS),
+ Children =>
+ (if Container.Separator_ID = Invalid_Token_ID
+ then (Old_Root, New_Element)
+ else (Old_Root, Tree.Add_Terminal
(Container.Separator_ID), New_Element)));
+
+ if List_Parent = Invalid_Node_Index then
+ if Tree.Root = Old_Root then
+ Tree.Root := Container.Root;
+ end if;
+
+ else
+ Tree.Replace_Child
+ (List_Parent,
+ Child_Index,
+ Old_Child => Deleted_Child,
+ New_Child => Container.Root);
+ end if;
+ end;
+ end if;
+ end Append;
+
+ procedure Prepend
+ (Container : in out List;
+ New_Element : in Valid_Node_Index)
+ is
+ Tree : Syntax_Trees.Tree renames Container.Tree.all;
+ begin
+ if Container.Root = Invalid_Node_Index then
+ Container :=
+ (Container.Tree,
+ List_ID => Container.List_ID,
+ One_Element_RHS => Container.One_Element_RHS,
+ Multi_Element_RHS => Container.Multi_Element_RHS,
+ Element_ID => Container.Element_ID,
+ Separator_ID => Container.Separator_ID,
+ Root => Tree.Add_Nonterm
+ (Production => (Container.List_ID,
Container.One_Element_RHS),
+ Children => (1 => New_Element)));
+
+ else
+ -- Inserting element First (with list parent node and separator) in
spec example
+ declare
+ Old_First : constant Valid_Node_Index := Container.First.Node;
+ Parent : constant Valid_Node_Index := Tree.Parent (Old_First);
+
+ List_Node : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((Container.List_ID, Container.One_Element_RHS),
+ (1 => New_Element));
+ begin
+ Tree.Set_Children
+ (Node => Parent,
+ New_ID => (Container.List_ID, Container.Multi_Element_RHS),
+ Children =>
+ (if Container.Separator_ID = Invalid_Token_ID
+ then (List_Node, Old_First)
+ else (List_Node, Tree.Add_Terminal (Container.Separator_ID),
Old_First)));
+ end;
+ end if;
+ end Prepend;
+
+ procedure Insert
+ (Container : in out List;
+ New_Element : in Valid_Node_Index;
+ After : in Cursor)
+ is
+ -- Current Tree (see wisitoken_syntax_trees-test.adb Test_Insert_1):
+ --
+ -- list: Tree.Root
+ -- | list = Parent
+ -- | | list
+ -- | | | list
+ -- | | | | element: 1 = First
+ -- | | | separator
+ -- | | | element: 2 = After
+ -- | | separator
+ -- | | element: 3 = Before
+ -- | separator
+ -- | element: 4 = Last
+
+ -- Insert New_Element after 2:
+ --
+ -- list: Tree.Root
+ -- | list
+ -- | | list = Parent
+ -- | | | list: new_list_nonterm
+ -- | | | | list
+ -- | | | | | element: First
+ -- | | | | separator
+ -- | | | | element: After
+ -- | | | separator
+ -- | | | element: new
+ -- | | separator
+ -- | | element: Before
+ -- | separator
+ -- | element: Last
+ Iter : constant Iterator := Container.Iterate;
+ Before : constant Node_Index := Iter.Next (After).Node;
+ begin
+ if After.Node = Invalid_Node_Index then
+ Prepend (Container, New_Element);
+ elsif Before = Invalid_Node_Index then
+ Append (Container, New_Element);
+ else
+ declare
+ Parent : constant Valid_Node_Index := Container.Tree.Parent
(Before);
+ Old_Child : constant Valid_Node_Index := Container.Tree.Parent
(After.Node);
+ Child_Index : constant SAL.Peek_Type :=
Container.Tree.Child_Index (Parent, Old_Child);
+
+ New_List_Nonterm : constant Valid_Node_Index :=
Container.Tree.Add_Nonterm
+ (Production => (Container.List_ID, Container.Multi_Element_RHS),
+ Children =>
+ (if Container.Separator_ID = Invalid_Token_ID
+ then (Old_Child, New_Element)
+ else (Old_Child, Container.Tree.Add_Terminal
(Container.Separator_ID), New_Element)));
+
+ begin
+ -- After = Container.First is not a special case:
+ --
+ -- list: Tree.Root
+ -- | list
+ -- | | list = Parent
+ -- | | | list: new_list_nonterm
+ -- | | | | list
+ -- | | | | | element: First = After
+ -- | | | | separator
+ -- | | | | element: New_Element
+ -- | | | separator
+ -- | | | element: Before
+ --
+ -- Typical case:
+ --
+ -- | | list = Parent
+ -- | | | list: New_list_nonterm
+ -- | | | | | ...
+ -- | | | | separator
+ -- | | | | element: After
+ -- | | | separator
+ -- | | | element: New_Element
+ -- | | separator
+ -- | | element: Before
+
+ Container.Tree.Replace_Child
+ (Parent => Parent,
+ Child_Index => Child_Index,
+ Old_Child => Deleted_Child,
+ New_Child => New_List_Nonterm,
+ Old_Child_New_Parent => New_List_Nonterm);
+ end;
+ end if;
+ end Insert;
+
+ procedure Copy
+ (Source_List : in Constant_List'Class;
+ Source_First : in Cursor := No_Element;
+ Source_Last : in Cursor := No_Element;
+ Dest_List : in out List'Class)
+ is
+ Source_Iter : constant Constant_Iterator := Source_List.Iterate_Constant;
+
+ Item : Cursor := (if Source_First = No_Element then
Source_List.First else Source_First);
+ Last : constant Cursor := (if Source_Last = No_Element then
Source_List.Last else Source_Last);
+ begin
+ for N of Source_List loop
+ exit when not Has_Element (Item);
+
+ Dest_List.Append (Dest_List.Tree.Copy_Subtree (Item.Node));
+
+ exit when Item = Last;
+
+ Item := Source_Iter.Next (Item);
+ end loop;
+ end Copy;
+
+ procedure Delete
+ (Container : in out List;
+ Item : in out Cursor)
+ is
+ Tree : Syntax_Trees.Tree renames Container.Tree.all;
+ begin
+ if Container.First = Container.Last then
+ -- result is empty
+ declare
+ List_Parent : constant Node_Index := Tree.Parent (Container.Root);
+ begin
+ if List_Parent = Invalid_Node_Index then
+ if Tree.Root = Container.Root then
+ Tree.Root := Invalid_Node_Index;
+ end if;
+
+ else
+ Tree.Replace_Child
+ (List_Parent,
+ Child_Index => Tree.Child_Index (List_Parent,
Container.Root),
+ Old_Child => Container.Root,
+ New_Child => Deleted_Child);
+ end if;
+ Container.Root := Invalid_Node_Index;
+ end;
+
+ elsif Item = Container.First then
+ -- Before:
+ --
+ -- 0011: | List_1: Parent_2
+ -- 0009: | | List_0: delete
+ -- 0008: | | | Element_0: old First: Item.Node: delete
+ -- 0001: | | | | ...
+ -- 0002: | | separator?: delete
+ -- 0010: | | Element_0: new First
+ -- 0003: | | | ...
+
+ --
+ -- After:
+ --
+ -- 0011: | List_0: Parent_2
+ -- 0010: | | Element_0: new First
+ -- 0003: | | | ...
+
+ declare
+ Parent_2 : constant Valid_Node_Index := Tree.Parent (Item.Node, 2);
+ begin
+ Tree.Set_Children
+ (Parent_2,
+ (Container.List_ID, Container.One_Element_RHS),
+ (1 => Tree.Child (Parent_2, (if Container.Separator_ID =
Invalid_Token_ID then 2 else 3))));
+ end;
+
+ elsif Item = Container.Last then
+ -- Before:
+ --
+ -- ? ?: List_Parent
+ -- 15: | List_1 : Root, delete
+ -- 11: | | List_*: New_Root
+ -- 10: | | | Element_0
+ -- 03: | | ...
+ -- 06: | | separator?, delete
+ -- 14: | | Element_0 : Last. delete
+ -- 07: | | | ...
+
+ -- ? ?: List_Parent
+ -- 11: | List_*: Root
+ -- 10: | | Element_0
+ -- 03: | ...
+
+ declare
+ List_Parent : constant Node_Index := Tree.Parent
(Container.Root);
+ New_Root : constant Valid_Node_Index := Tree.Child
(Container.Root, 1);
+ begin
+ if List_Parent = Invalid_Node_Index then
+ Tree.Delete_Parent (New_Root);
+ Container.Root := New_Root;
+
+ else
+ declare
+ Parent_Index : constant SAL.Peek_Type := Tree.Child_Index
(List_Parent, Container.Root);
+ begin
+ Tree.Replace_Child
+ (List_Parent, Parent_Index,
+ Old_Child => Container.Root,
+ New_Child => New_Root,
+ Old_Child_New_Parent => Invalid_Node_Index);
+ end;
+ end if;
+
+ Container.Root := New_Root;
+ end;
+
+ else
+ -- Node numbers from test_lr_utils test case 1.
+ --
+ -- before:
+ -- 15: list: Parent_2
+ -- 13: | list: Parent_1, Old_Child
+ -- 11: | | list: Parent_1_Child_1, New_Child
+ -- 09: | | | list:
+ -- 08: | | | | element: 1, First
+ -- 02: | | | separator?
+ -- 10: | | | element: 2
+ -- 04: | | separator?
+ -- 12: | | element: 3, Item.Node, delete
+ -- 06: | separator?
+ -- 14: | element: 4, Last
+ --
+ -- after
+ -- 15: list: Parent_2
+ -- 11: | list: Parent_1_Child_1
+ -- 09: | | list:
+ -- 08: | | | element: 1, First
+ -- 02: | | separator?
+ -- 10: | | element: 2
+ -- 06: | separator?
+ -- 14: | element: 4, Last
+
+ declare
+ Parent_1 : constant Valid_Node_Index := Tree.Parent
(Item.Node);
+ Parent_2 : constant Valid_Node_Index := Tree.Parent
(Parent_1);
+ Parent_1_Child_1 : constant Valid_Node_Index := Tree.Child
(Parent_1, 1);
+ begin
+ Tree.Replace_Child
+ (Parent_2, 1,
+ Old_Child => Parent_1,
+ New_Child => Parent_1_Child_1,
+ Old_Child_New_Parent => Invalid_Node_Index);
+ end;
+ end if;
+
+ Item.Node := Invalid_Node_Index;
+ end Delete;
+
+ function Valid_Skip_List (Tree : aliased in out Syntax_Trees.Tree;
Skip_List : in Skip_Array) return Boolean
+ is begin
+ if Skip_List'Length = 0 then return False; end if;
+
+ if Skip_List (Skip_List'Last).Label /= Skip then return False; end if;
+
+ if (for some I in Skip_List'First .. Skip_List'Last - 1 => Skip_List
(I).Label /= Nested) then
+ return False;
+ end if;
+
+ for I in Skip_List'First + 1 .. Skip_List'Last loop
+ if Tree.ID (Skip_List (I).Element) /= Skip_List (I - 1).Element_ID
then
+ return False;
+ end if;
+ end loop;
+
+ if Skip_List'Length > 2 then
+ declare
+ I : constant Positive_Index_Type := Skip_List'Last - 1;
+ begin
+ if Creators.Create_From_Element
+ (Tree, Skip_List (I - 1).Element, Skip_List (I).List_ID,
Skip_List (I).Element_ID).Count = 1
+ then
+ return False;
+ end if;
+ end;
+ end if;
+
+ return True;
+ end Valid_Skip_List;
+
+ function Copy_Skip_Nested
+ (Source_List : in Constant_List'Class;
+ Skip_List : in Skip_Array;
+ Skip_Found : in out Boolean;
+ Tree : aliased in out Syntax_Trees.Tree;
+ Separator_ID : in Token_ID;
+ Multi_Element_RHS : in Natural)
+ return Node_Index
+ is
+ Dest_List : List := Creators.Empty_List
+ (Tree, Source_List.List_ID, Multi_Element_RHS, Source_List.Element_ID,
Separator_ID);
+
+ function Get_Dest_Child
+ (Node : in Valid_Node_Index;
+ Skip_List : in Skip_Array)
+ return Valid_Node_Index
+ with Pre => Tree.Is_Nonterm (Node) and
+ (Skip_List'Length > 1 and then
+ (Skip_List (Skip_List'First).Label = Nested and Skip_List
(Skip_List'Last).Label = Skip))
+ is
+ Skip_This : Nested_Skip_Item renames Skip_List (Skip_List'First);
+ begin
+ if Node = Skip_This.List_Root then
+ return Copy_Skip_Nested
+ (Creators.Create_List
+ (Tree,
+ Root => Skip_This.List_Root,
+ List_ID => Skip_This.List_ID,
+ Element_ID => Skip_This.Element_ID),
+ Skip_List (Skip_List'First + 1 .. Skip_List'Last),
+ Skip_Found, Tree, Skip_This.Separator_ID,
Skip_This.Multi_Element_RHS);
+ else
+ declare
+ Source_Children : constant Valid_Node_Index_Array :=
Tree.Children (Node);
+ Dest_Children : Valid_Node_Index_Array
(Source_Children'Range);
+ begin
+ for I in Source_Children'Range loop
+ if Source_Children (I) = Skip_This.List_Root then
+ Dest_Children (I) := Copy_Skip_Nested
+ (Creators.Create_List
+ (Tree,
+ Root => Skip_This.List_Root,
+ List_ID => Skip_This.List_ID,
+ Element_ID => Skip_This.Element_ID),
+ Skip_List (Skip_List'First + 1 .. Skip_List'Last),
+ Skip_Found, Tree, Skip_This.Separator_ID,
Skip_This.Multi_Element_RHS);
+ else
+ if Tree.Label (Source_Children (I)) = Nonterm then
+ Dest_Children (I) := Get_Dest_Child (Source_Children
(I), Skip_List);
+ else
+ Dest_Children (I) := Tree.Copy_Subtree
(Source_Children (I));
+ end if;
+ end if;
+ end loop;
+
+ return Tree.Add_Nonterm (Tree.Production_ID (Node),
Dest_Children, Tree.Action (Node));
+ end;
+ end if;
+ end Get_Dest_Child;
+
+ Skip_This : Nested_Skip_Item renames Skip_List (Skip_List'First);
+ begin
+ -- See test_lr_utils.adb Test_Copy_Skip for an example.
+ for N of Source_List loop
+ if Skip_This.Element = N then
+ case Skip_This.Label is
+ when Skip =>
+ -- Done nesting; skip this one
+ Skip_Found := True;
+
+ when Nested =>
+ Dest_List.Append (Get_Dest_Child (N, Skip_List));
+ end case;
+ else
+ Dest_List.Append (Tree.Copy_Subtree (N));
+ end if;
+ end loop;
+ return Dest_List.Root;
+ end Copy_Skip_Nested;
+
+ function Copy_Skip_Nested
+ (Skip_List : in Skip_Info;
+ Tree : aliased in out Syntax_Trees.Tree)
+ return Node_Index
+ is
+ Source_List : constant Constant_List := Creators.Create_List
+ (Tree,
+ Root => Skip_List.Start_List_Root,
+ List_ID => Skip_List.Start_List_ID,
+ Element_ID => Skip_List.Start_Element_ID);
+
+ Skip_Found : Boolean := False;
+ begin
+ return Result : constant Node_Index := Copy_Skip_Nested
+ (Source_List, Skip_List.Skips, Skip_Found, Tree,
Skip_List.Start_Separator_ID,
+ Skip_List.Start_Multi_Element_RHS)
+ do
+ if not Skip_Found then
+ raise SAL.Programmer_Error with "Skip not found";
+ end if;
+ end return;
+ end Copy_Skip_Nested;
+
+ function List_Root
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ List_ID : in Token_ID)
+ return Valid_Node_Index
+ is
+ Root : Node_Index := Node;
+ begin
+ loop
+ exit when Tree.Parent (Root) = Invalid_Node_Index or else Tree.ID
(Tree.Parent (Root)) /= List_ID;
+ Root := Tree.Parent (Root);
+ end loop;
+ return Root;
+ end List_Root;
end WisiToken.Syntax_Trees.LR_Utils;
diff --git a/wisitoken-syntax_trees-lr_utils.ads
b/wisitoken-syntax_trees-lr_utils.ads
index 84292b4..6f0403c 100644
--- a/wisitoken-syntax_trees-lr_utils.ads
+++ b/wisitoken-syntax_trees-lr_utils.ads
@@ -2,6 +2,13 @@
--
-- Utilities for navigating syntax trees produced by an LR parser.
--
+-- Design :
+--
+-- It would be safer if Cursor contained a pointer to Iterator; then
+-- Copy and Splice could just take Cursor arguments. But that
+-- requires mode 'aliased in' for First, Last, which is not
+-- conformant with Ada.Iterator_Interfaces.
+--
-- Copyright (C) 2019, 2020 Stephen Leake All Rights Reserved.
--
-- This library is free software; you can redistribute it and/or modify it
@@ -18,7 +25,9 @@
pragma License (Modified_GPL);
with Ada.Iterator_Interfaces;
+with SAL.Gen_Unconstrained_Array_Image_Aux;
package WisiToken.Syntax_Trees.LR_Utils is
+ use all type SAL.Base_Peek_Type;
procedure Raise_Programmer_Error
(Label : in String;
@@ -39,50 +48,428 @@ package WisiToken.Syntax_Trees.LR_Utils is
--
-- list : list separator element | element ;
-- list : element | list separator element ;
+ --
+ -- In the syntax tree, this looks like:
+ --
+ -- list: Root
+ -- | list
+ -- | | list
+ -- | | | element: First
+ -- | | separator?
+ -- | | element: 2
+ -- | separator?
+ -- | element: 3
+ -- separator?
+ -- element: Last
+
+ type Constant_List (<>) is tagged private with
+ Constant_Indexing => List_Constant_Ref,
+ Default_Iterator => Iterate_Constant,
+ Iterator_Element => Valid_Node_Index;
+
+ function Tree (Container : in Constant_List) return Tree_Constant_Reference
+ with Pre => not Container.Is_Invalid;
+
+ function Is_Invalid (Container : in Constant_List) return Boolean;
+
+ function Is_Empty (Container : in Constant_List) return Boolean;
+ -- Returns True if Container is invalid, or if Container is empty
+
+ function Root (Container : in Constant_List) return Node_Index
+ with Pre => not Container.Is_Invalid;
+
+ function List_ID (Container : in Constant_List) return Token_ID
+ with Pre => not Container.Is_Invalid;
+
+ function Element_ID (Container : in Constant_List) return Token_ID
+ with Pre => not Container.Is_Invalid;
+
+ function Count (Container : in Constant_List) return
Ada.Containers.Count_Type
+ with Pre => not Container.Is_Invalid;
+
+ function Contains (Container : in Constant_List; Node : in
Valid_Node_Index) return Boolean
+ with Pre => not Container.Is_Invalid;
type Cursor is private;
+
+ No_Element : constant Cursor;
+
+ function To_Cursor (Container : in Constant_List; Node : in
Valid_Node_Index) return Cursor
+ with Pre => (not Container.Is_Invalid) and then
+ (Container.Contains (Node) and Container.Tree.ID (Node) =
Container.Element_ID);
+
+ function Contains (Container : in Constant_List; Item : in Cursor) return
Boolean
+ with Pre => not Container.Is_Invalid;
+
function Has_Element (Cursor : in LR_Utils.Cursor) return Boolean;
function Node (Cursor : in LR_Utils.Cursor) return Node_Index;
+ -- Invalid_Node_Index if not Has_Element (Cursor).
+
+ function Get_Node (Cursor : in LR_Utils.Cursor) return Node_Index
+ renames Node;
+ -- Useful when Node is hidden by another declaration.
package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
- type Iterator is new Iterator_Interfaces.Reversible_Iterator with private;
+ type Iterator (Container : not null access constant Constant_List'Class) is
+ new Iterator_Interfaces.Reversible_Iterator
+ with null record;
- overriding function First (Iter : Iterator) return Cursor;
- overriding function Last (Iter : Iterator) return Cursor;
+ function First (Container : in Constant_List) return Cursor;
+ function Last (Container : in Constant_List) return Cursor;
- overriding function Next (Iter : Iterator; Position : Cursor) return Cursor;
+ overriding function First (Iter : in Iterator) return Cursor is
(Iter.Container.First);
+ overriding function Last (Iter : in Iterator) return Cursor is
(Iter.Container.Last);
+ overriding function Next (Iter : in Iterator; Position : Cursor) return
Cursor;
+ overriding function Previous (Iter : in Iterator; Position : Cursor) return
Cursor;
- overriding function Previous (Iter : Iterator; Position : Cursor) return
Cursor;
+ function List_Constant_Ref
+ (Container : aliased in Constant_List'Class;
+ Position : in Cursor)
+ return Valid_Node_Index;
- 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;
+ type Constant_Iterator (Container : not null access constant Constant_List)
is new
+ Iterator_Interfaces.Reversible_Iterator
+ with null record;
- function Count (Iter : Iterator) return Ada.Containers.Count_Type;
+ overriding function First (Iter : in Constant_Iterator) return Cursor is
(Iter.Container.First);
+ overriding function Last (Iter : in Constant_Iterator) return Cursor is
(Iter.Container.Last);
+ overriding function Next (Iter : in Constant_Iterator; Position :
Cursor) return Cursor;
+ overriding function Previous (Iter : in Constant_Iterator; Position :
Cursor) return Cursor;
-private
+ function Iterate_Constant (Container : aliased in Constant_List'Class)
return Constant_Iterator
+ is (Iterator_Interfaces.Reversible_Iterator with Container'Access);
+
+ type Find_Equal is access function
+ (Target : in String;
+ List : in Constant_List'Class;
+ Node : in Valid_Node_Index)
+ return Boolean;
+ -- Function called by Find to compare Target to Node. Target, List
+ -- are the Find arguments; Node is an element of List. Return True if
+ -- Node matches Target.
+ function Find
+ (Container : in Constant_List;
+ Target : in Valid_Node_Index)
+ return Cursor
+ with Pre => not Container.Is_Invalid and Container.Tree.ID (Target) =
Container.Element_ID;
+
+ function Find
+ (Container : in Constant_List;
+ Target : in String;
+ Equal : in Find_Equal)
+ return Cursor
+ with Pre => not Container.Is_Invalid;
+
+ type List (<>) is new Constant_List with private with
+ Default_Iterator => Iterate,
+ Iterator_Element => Valid_Node_Index;
+
+ function Separator_ID (Container : in List) return Token_ID
+ with Pre => not Container.Is_Invalid;
+
+ function Iterate (Container : aliased in List'Class) return Iterator
+ is (Iterator_Interfaces.Reversible_Iterator with Container'Access);
+
+ package Creators is
+ -- Nested package so these are not primitive, and don't have to be
+ -- overridden for List.
+
+ function Create_List
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Root : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID;
+ Element_ID : in WisiToken.Token_ID;
+ Separator_ID : in WisiToken.Token_ID)
+ return List
+ with Pre => (Tree.Is_Nonterm (Root) and then Tree.Has_Children (Root))
and Tree.ID (Root) = List_ID;
+ -- If there is no separator, set Separator_ID =
WisiToken.Invalid_Token_ID
+ -- The list cannot be empty; use Empty_List for an empty list.
+
+ function Create_List
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Root : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID;
+ Element_ID : in WisiToken.Token_ID)
+ return Constant_List
+ with Pre => (Tree.Is_Nonterm (Root) and then Tree.Has_Children (Root))
and Tree.ID (Root) = List_ID;
+ -- The separator is only need when adding new elements.
+
+ function Create_List
+ (Container : in Constant_List;
+ Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Root : in Valid_Node_Index)
+ return Constant_List
+ with Pre => (Container.Tree.Is_Nonterm (Root) and then
+ Container.Tree.Has_Children (Root)) and
+ Container.Tree.ID (Root) = Container.List_ID;
+ -- Same as Create_List, get all other params from Container.
+ -- Need Tree for non-constant view.
+
+ function Create_List (Container : in out List; Root : in
Valid_Node_Index) return List
+ with Pre => (Container.Tree.Is_Nonterm (Root) and then
Container.Tree.Has_Children (Root)) and
+ Container.Tree.ID (Root) = Container.List_ID;
+ -- Same as Create_List, get all other params from Container.
+
+ function Create_From_Element
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Element : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID;
+ Element_ID : in WisiToken.Token_ID;
+ Separator_ID : in WisiToken.Token_ID)
+ return List
+ with Pre => Tree.ID (Tree.Parent (Element)) = List_ID and
+ Tree.ID (Element) = Element_ID and
+ Tree.ID (Tree.Parent (Element)) = List_ID;
+ -- Same as Create_List, but it first finds the root as an ancestor of
+ -- Element.
+
+ function Create_From_Element (Container : in out List; Element : in
Valid_Node_Index) return List
+ with Pre => Container.Tree.ID (Container.Tree.Parent (Element)) =
Container.List_ID and
+ Container.Tree.ID (Element) = Container.Element_ID and
+ Container.Tree.ID (Container.Tree.Parent (Element)) =
Container.List_ID;
+ -- Same as Create_From_Element, get all other params from Container.
+
+ function Create_From_Element
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ Element : in Valid_Node_Index;
+ List_ID : in WisiToken.Token_ID;
+ Element_ID : in WisiToken.Token_ID)
+ return Constant_List
+ with Pre => Tree.ID (Tree.Parent (Element)) = List_ID and
+ Tree.ID (Element) = Element_ID and
+ Tree.ID (Tree.Parent (Element)) = List_ID;
+ -- Same as Create_List, but it first finds the root as an ancestor of
+ -- Element.
+
+ function Invalid_List (Tree : aliased in out
WisiToken.Syntax_Trees.Tree) return List;
+ function Invalid_List (Tree : aliased in out
WisiToken.Syntax_Trees.Tree) return Constant_List;
+ -- First, Last return empty cursor, count returns 0, all other
+ -- operations fail a precondition check.
+ --
+ -- Useful when the result should never be used, but must be present,
+ -- as in a conditional expression.
+
+ function Empty_List
+ (Tree : aliased in out WisiToken.Syntax_Trees.Tree;
+ List_ID : in WisiToken.Token_ID;
+ Multi_Element_RHS : in Natural;
+ Element_ID : in WisiToken.Token_ID;
+ Separator_ID : in WisiToken.Token_ID)
+ return List;
+ -- Result Root returns Invalid_Node_Index; First, Last return empty
+ -- cursor, count returns 0; Append works correctly.
+
+ function Empty_List (Container : in out List) return List;
+ -- Same as Empty_List, get all other params from Container.
+
+ end Creators;
+
+ function Compatible (A, B : in Constant_List'Class) return Boolean;
+ -- True if A and B are not invalid, and all components are the same
+ -- except Root.
+
+ procedure Append
+ (Container : in out List;
+ New_Element : in Valid_Node_Index)
+ with Pre => not Container.Is_Invalid and then Container.Tree.ID
(New_Element) = Container.Element_ID;
+ -- Append New_Item to Container, including Container.Separator_ID if
+ -- it is not Invalid_Token_Index.
+ --
+ -- If Container was Empty, or if Container.Root has no parent in
+ -- Tree, the modified list has no parent. Otherwise, the parent of
+ -- Container.Root is updated to hold the new Container.Root.
+
+ procedure Prepend
+ (Container : in out List;
+ New_Element : in Valid_Node_Index)
+ with Pre => not Container.Is_Invalid and then Container.Tree.ID
(New_Element) = Container.Element_ID;
+ -- Prepend New_Item to Container, including Container.Separator_ID if
+ -- it is not Invalid_Token_Index.
+ --
+ -- Container.Root parent is unchanged.
+
+ procedure Insert
+ (Container : in out List;
+ New_Element : in Valid_Node_Index;
+ After : in Cursor)
+ with Pre => not Container.Is_Invalid and then
+ (Container.Tree.ID (New_Element) = Container.Element_ID and
+ (After = No_Element or else Container.Contains (After)));
+ -- Insert New_Item into Container after Ater, including
+ -- Container.Separator_ID if it is not Invalid_Token_Index.
+ --
+ -- If After is No_Element, calls Prepend.
+ --
+ -- If Container was Empty, or if Container.Root has no parent, the
+ -- modified list has no parent. Otherwise, if After is
+ -- Container.Last, the parent of Container.Root is updated to hold
+ -- the new Container.Root.
+
+ procedure Copy
+ (Source_List : in Constant_List'Class;
+ Source_First : in Cursor := No_Element;
+ Source_Last : in Cursor := No_Element;
+ Dest_List : in out List'Class)
+ with Pre => Compatible (Source_List, Dest_List);
+ -- Deep copy slice of Source_List, appending to Dest_List.
+ --
+ -- If First = No_Element, copy from List.First.
+ -- If Last = No_Element, copy thru List.Last.
+
+ procedure Delete
+ (Container : in out List;
+ Item : in out Cursor)
+ with Pre => Container.Contains (Item);
+ -- Delete Item from Container. Parent of Container.Root is updated
+ -- appropriately. Cursor is set to No_Element.
+
+ type Skip_Label is (Nested, Skip);
+
+ type Skip_Item (Label : Skip_Label := Skip_Label'First) is
+ record
+ Element : Valid_Node_Index;
+ case Label is
+ when Nested =>
+ -- Element is an element in the list currently being copied
+ -- containing a nested list with an element to skip (given by Element
+ -- in the next Skip_Item). The nested list is defined by:
+ List_Root : Valid_Node_Index;
+ List_ID : Token_ID;
+ Element_ID : Token_ID;
+ Separator_ID : Token_ID;
+ Multi_Element_RHS : Natural;
+
+ when Skip =>
+ -- Element is the element in the current list to skip.
+ null;
+ end case;
+ end record;
+ subtype Nested_Skip_Item is Skip_Item (Nested);
+
+ function Image (Item : in Skip_Item; Descriptor : in WisiToken.Descriptor)
return String
+ is ("(" & Item.Label'Image & ", " & Item.Element'Image &
+ (case Item.Label is
+ when Nested => "," & Item.List_Root'Image & ", " & Image
(Item.List_ID, Descriptor),
+ when Skip => "") &
+ ")");
+
+ type Skip_Array is array (Positive_Index_Type range <>) of Skip_Item;
+
+ type Skip_Info (Skip_Last : SAL.Base_Peek_Type) is
+ record
+ -- Skip_Last may be Positive_Index_Type'First - 1 to indicate an
+ -- empty or invalid skip list.
+ Start_List_Root : Valid_Node_Index := Valid_Node_Index'Last;
+ Start_List_ID : Token_ID := Invalid_Token_ID;
+ Start_Element_ID : Token_ID := Invalid_Token_ID;
+ Start_Separator_ID : Token_ID := Invalid_Token_ID;
+ Start_Multi_Element_RHS : Natural := 0;
+ Skips : Skip_Array (Positive_Index_Type'First ..
Skip_Last);
+ end record;
+
+ function Image is new SAL.Gen_Unconstrained_Array_Image_Aux
+ (Positive_Index_Type, Skip_Item, Skip_Array, WisiToken.Descriptor, Image);
+
+ function Image (Item : in Skip_Info; Descriptor : in WisiToken.Descriptor)
return String
+ is ("(" &
+ (if Item.Start_List_ID = Invalid_Token_ID
+ then ""
+ else Item.Start_List_Root'Image & ", " & Image (Item.Start_List_ID,
Descriptor) & ", " &
+ Image (Item.Skips, Descriptor))
+ & ")");
+
+ function Valid_Skip_List (Tree : aliased in out Syntax_Trees.Tree;
Skip_List : in Skip_Array) return Boolean;
+ -- The last element must be Skip, preceding elements must all be
+ -- Nested. The Element in each array element must have ID = preceding
+ -- Element_ID. The net result of all skips must not be empty, unless
+ -- there is only one item (Skip); Start_List_Root may contain only
+ -- that.
+
+ function Copy_Skip_Nested
+ (Skip_List : in Skip_Info;
+ Tree : aliased in out Syntax_Trees.Tree)
+ return Node_Index
+ with Pre => Skip_List.Start_List_ID /= Invalid_Token_ID and then
+ (Valid_Skip_List (Tree, Skip_List.Skips) and
+ Skip_List.Start_List_ID /= Skip_List.Start_Element_ID);
+ -- Copy list rooted at Skip_List.Start_List, skipping one element as
+ -- indicated by Skip_List.Skip. Return root of copied list.
+ --
+ -- Result is Invalid_Node_Index (indicating an empty list) if
+ -- Skip_List has only one item (Skip), and Skip_List.Start_List_Root
+ -- has only that item.
+ --
+ -- Raises SAL.Programmer_Error if skip item described by Skip_List is
+ -- not found.
+
+ function List_Root
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ List_ID : in Token_ID)
+ return Valid_Node_Index
+ with Pre => Tree.ID (Node) = List_ID;
+
+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;
+ No_Element : constant Cursor := (Node => Invalid_Node_Index);
+
+ type Constant_List (Tree : not null access WisiToken.Syntax_Trees.Tree) is
tagged
+ -- We'd prefer to have Tree be 'constant' here, but then it would
+ -- also be constant in List, where we _don't_ want that. An
+ -- alternative design would be to not derive List from Constant_List;
+ -- then we would would have to duplicate all operations.
+ record
+ Root : WisiToken.Node_Index;
+ List_ID : WisiToken.Token_ID;
+ Element_ID : WisiToken.Token_ID;
end record;
+ type List is new Constant_List with
+ record
+ One_Element_RHS : Natural;
+ Multi_Element_RHS : Natural;
+ Separator_ID : WisiToken.Token_ID;
+ end record;
+
+ function Tree (Container : in Constant_List) return Tree_Constant_Reference
+ is (Element => Container.Tree);
+
+ function Is_Invalid (Container : in Constant_List) return Boolean
+ is (Container.List_ID = Invalid_Token_ID);
+
+ function Is_Empty (Container : in Constant_List) return Boolean
+ is (Container.Root = Invalid_Node_Index);
+
+ function Root (Container : in Constant_List) return Node_Index
+ is (Container.Root);
+
+ function List_ID (Container : in Constant_List) return Token_ID
+ is (Container.List_ID);
+
+ function Element_ID (Container : in Constant_List) return Token_ID
+ is (Container.Element_ID);
+
+ 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);
+
+ function Separator_ID (Container : in List) return Token_ID
+ is (Container.Separator_ID);
+
+ function Compatible (A, B : in Constant_List'Class) return Boolean
+ is
+ (A.Tree = B.Tree and
+ A.List_ID /= Invalid_Token_ID and
+ B.List_ID /= Invalid_Token_ID and
+ A.List_ID = B.List_ID and
+ A.Element_ID = B.Element_ID);
+
end WisiToken.Syntax_Trees.LR_Utils;
diff --git a/wisitoken-syntax_trees.adb b/wisitoken-syntax_trees.adb
index 7e98947..0a38ae7 100644
--- a/wisitoken-syntax_trees.adb
+++ b/wisitoken-syntax_trees.adb
@@ -27,9 +27,11 @@ package body WisiToken.Syntax_Trees is
function Image
(Tree : in Syntax_Trees.Tree;
N : in Syntax_Trees.Node;
+ Node_Index : in Valid_Node_Index;
Descriptor : in WisiToken.Descriptor;
Include_Children : in Boolean;
- Include_RHS_Index : in Boolean := False)
+ Include_RHS_Index : in Boolean := False;
+ Node_Numbers : in Boolean := False)
return String;
procedure Move_Branch_Point (Tree : in out Syntax_Trees.Tree; Required_Node
: in Valid_Node_Index);
@@ -76,7 +78,7 @@ package body WisiToken.Syntax_Trees is
Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Parent);
begin
Node.Children.Append (Child);
- -- We don't update Min/Max_terminal_index; they are no longer needed.
+ Tree.Shared_Tree.Nodes (Child).Parent := Parent;
end Add_Child;
function Add_Identifier
@@ -222,6 +224,15 @@ package body WisiToken.Syntax_Trees is
end if;
end Augmented_Const;
+ function Buffer_Region_Is_Empty (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ is begin
+ if Node <= Tree.Last_Shared_Node then
+ return Tree.Shared_Tree.Nodes (Node).Byte_Region = Null_Buffer_Region;
+ else
+ return Tree.Branched_Nodes (Node).Byte_Region = Null_Buffer_Region;
+ end if;
+ end Buffer_Region_Is_Empty;
+
function Byte_Region
(Tree : in Syntax_Trees.Tree;
Node : in Valid_Node_Index)
@@ -258,6 +269,35 @@ package body WisiToken.Syntax_Trees is
end if;
end Child;
+ function Child_Count (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Ada.Containers.Count_Type
+ is begin
+ return Tree.Get_Node_Const_Ref (Node).Children.Length;
+ end Child_Count;
+
+ function Child_Index
+ (N : in Node;
+ Child : in Valid_Node_Index)
+ return SAL.Peek_Type
+ is begin
+ for I in N.Children.First_Index .. N.Children.Last_Index loop
+ if N.Children (I) = Child then
+ return I;
+ end if;
+ end loop;
+ raise SAL.Programmer_Error; -- Should be prevented by precondition
+ end Child_Index;
+
+ function Child_Index
+ (Tree : in out Syntax_Trees.Tree;
+ Parent : in Valid_Node_Index;
+ Child : in Valid_Node_Index)
+ return SAL.Peek_Type
+ is
+ N : Node_Var_Ref renames Get_Node_Var_Ref (Tree, Parent);
+ begin
+ return Child_Index (N, Child);
+ end Child_Index;
+
function Children (N : in Syntax_Trees.Node) return Valid_Node_Index_Array
is begin
if N.Children.Length = 0 then
@@ -301,8 +341,7 @@ package body WisiToken.Syntax_Trees is
function Copy_Subtree
(Tree : in out Syntax_Trees.Tree;
- Root : in Valid_Node_Index;
- Last : in Valid_Node_Index)
+ Root : in Valid_Node_Index)
return Valid_Node_Index
is
function Copy_Node
@@ -361,27 +400,10 @@ package body WisiToken.Syntax_Trees is
New_Children : Valid_Node_Index_Arrays.Vector;
begin
if Children'Length > 0 then
- declare
- use all type SAL.Base_Peek_Type;
- Last_Index : SAL.Base_Peek_Type :=
SAL.Base_Peek_Type'Last;
- begin
- for I in Children'Range loop
- if Children (I) = Last then
- Last_Index := I;
- end if;
- end loop;
-
- if Last_Index = SAL.Base_Peek_Type'Last then
- New_Children.Set_First_Last (Children'First,
Children'Last);
- for I in Children'Range loop
- New_Children (I) := Copy_Node (Tree, Children (I),
Parent);
- end loop;
- else
- for I in Last_Index .. Children'Last loop
- New_Children.Append (Copy_Node (Tree, Children (I),
Parent));
- end loop;
- end if;
- end;
+ 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;
end if;
declare
@@ -438,6 +460,8 @@ package body WisiToken.Syntax_Trees is
null;
when Nonterm =>
for I of N.Children loop
+ -- We don't check for Deleted_Child here; encountering one
indicates
+ -- an error in the user algorithm.
Result := Result + Count_IDs (Tree, I, ID);
end loop;
end case;
@@ -465,8 +489,11 @@ package body WisiToken.Syntax_Trees is
when Nonterm =>
return Result : Integer := 0 do
- for I of N.Children loop
- Result := Result + Count_Terminals (Tree, I);
+ for C of N.Children loop
+ -- This can be called to build a debugging image while
editing the tree
+ if C /= Deleted_Child then
+ Result := Result + Count_Terminals (Tree, C);
+ end if;
end loop;
end return;
end case;
@@ -478,6 +505,53 @@ package body WisiToken.Syntax_Trees is
else Tree.Branched_Nodes (Node)));
end Count_Terminals;
+ procedure Delete_Parent
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ is
+ N : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Node);
+ Parent : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (N.Parent);
+ begin
+ Parent.Children (Child_Index (Parent, Node)) := Deleted_Child;
+
+ if N.Parent = Tree.Root then
+ Tree.Root := Node;
+ end if;
+
+ N.Parent := Invalid_Node_Index;
+ end Delete_Parent;
+
+ function Error_Message
+ (Tree : in Syntax_Trees.Tree;
+ Terminals : in Base_Token_Array_Access_Constant;
+ Node : in Valid_Node_Index;
+ File_Name : in String;
+ Message : in String)
+ return String
+ is
+ First_Terminal : constant Valid_Node_Index := Tree.First_Terminal
(Node);
+ Line : Line_Number_Type := Line_Number_Type'First;
+ Column : Ada.Text_IO.Count := Ada.Text_IO.Count'First;
+ begin
+ case Tree.Label (First_Terminal) is
+ when Shared_Terminal =>
+ declare
+ Token : Base_Token renames Terminals.all
(Tree.First_Shared_Terminal (First_Terminal));
+ begin
+ Line := Token.Line;
+ Column := Token.Column;
+ end;
+
+ when Virtual_Terminal | Virtual_Identifier =>
+ Line := Line_Number_Type'First;
+ Column := Ada.Text_IO.Count (Tree.Byte_Region (First_Terminal).First);
+
+ when others =>
+ null;
+ end case;
+ return WisiToken.Error_Message (File_Name, Line, Column, Message);
+ end Error_Message;
+
overriding procedure Finalize (Tree : in out Base_Tree)
is begin
Tree.Traversing := False;
@@ -518,12 +592,14 @@ package body WisiToken.Syntax_Trees is
end Insert_After;
function Find_Ancestor
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID;
+ Max_Parent : in Boolean := False)
return Node_Index
is
- N : Node_Index := Node;
+ N : Node_Index := Node;
+ Last_Parent : Node_Index := Invalid_Node_Index;
begin
loop
N :=
@@ -532,21 +608,26 @@ package body WisiToken.Syntax_Trees is
else Tree.Branched_Nodes (N).Parent);
exit when N = Invalid_Node_Index;
+ Last_Parent := N;
+
exit when ID =
(if N <= Tree.Last_Shared_Node
then Tree.Shared_Tree.Nodes (N).ID
else Tree.Branched_Nodes (N).ID);
end loop;
- return N;
+
+ return (if Max_Parent then Last_Parent else N);
end Find_Ancestor;
function Find_Ancestor
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- IDs : in Token_ID_Array)
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ IDs : in Token_ID_Array;
+ Max_Parent : in Boolean := False)
return Node_Index
is
- N : Node_Index := Node;
+ N : Node_Index := Node;
+ Last_Parent : Node_Index := Invalid_Node_Index;
begin
loop
N :=
@@ -555,13 +636,15 @@ package body WisiToken.Syntax_Trees is
else Tree.Branched_Nodes (N).Parent);
exit when N = Invalid_Node_Index;
+ Last_Parent := N;
+
exit when
(for some ID of IDs => ID =
(if N <= Tree.Last_Shared_Node
then Tree.Shared_Tree.Nodes (N).ID
else Tree.Branched_Nodes (N).ID));
end loop;
- return N;
+ return (if Max_Parent then Last_Parent else N);
end Find_Ancestor;
function Find_Child
@@ -577,12 +660,14 @@ package body WisiToken.Syntax_Trees is
return Invalid_Node_Index;
when Nonterm =>
for C of N.Children loop
- if ID =
- (if C <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (C).ID
- else Tree.Branched_Nodes (C).ID)
- then
- return C;
+ if C /= Deleted_Child then
+ if ID =
+ (if C <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (C).ID
+ else Tree.Branched_Nodes (C).ID)
+ then
+ return C;
+ end if;
end if;
end loop;
return Invalid_Node_Index;
@@ -662,12 +747,14 @@ package body WisiToken.Syntax_Trees is
when Nonterm =>
for C of N.Children loop
- if ID =
- (if C <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (C).ID
- else Tree.Branched_Nodes (C).ID)
- then
- return C;
+ if C /= Deleted_Child then
+ if ID =
+ (if C <= Tree.Last_Shared_Node
+ then Tree.Shared_Tree.Nodes (C).ID
+ else Tree.Branched_Nodes (C).ID)
+ then
+ return C;
+ end if;
end if;
end loop;
return Invalid_Node_Index;
@@ -731,6 +818,7 @@ package body WisiToken.Syntax_Trees is
null;
when Nonterm =>
for I of N.Children loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
Get_IDs (Tree, I, ID, Result, Last);
end loop;
end case;
@@ -773,8 +861,11 @@ package body WisiToken.Syntax_Trees is
Result (Last) := Node;
when Nonterm =>
- for I of N.Children loop
- Get_Terminals (Tree, I, Result, Last);
+ for C of N.Children loop
+ -- This is called to build an edited source image while
editing the tree
+ if C /= Deleted_Child then
+ Get_Terminals (Tree, C, Result, Last);
+ end if;
end loop;
end case;
end Compute;
@@ -805,6 +896,7 @@ package body WisiToken.Syntax_Trees is
return Index;
when Nonterm =>
for C of N.Children loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
declare
Term : constant Node_Index := First_Terminal (Tree, C);
begin
@@ -841,6 +933,7 @@ package body WisiToken.Syntax_Trees is
when Nonterm =>
for I of N.Children loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
Get_Terminal_IDs (Tree, I, Result, Last);
end loop;
end case;
@@ -893,6 +986,7 @@ package body WisiToken.Syntax_Trees is
when Nonterm =>
for C of N.Children loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
declare
ID : constant Token_ID := First_Terminal_ID (Tree, C);
begin
@@ -916,6 +1010,20 @@ package body WisiToken.Syntax_Trees is
return Tree.Branched_Nodes.Length > 0;
end Has_Branched_Nodes;
+ function Has_Child
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Child : in Valid_Node_Index)
+ return Boolean
+ is begin
+ for C of Tree.Get_Node_Const_Ref (Node).Children loop
+ if C = Child then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Has_Child;
+
function Has_Children (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
is begin
if Node <= Tree.Last_Shared_Node then
@@ -962,9 +1070,10 @@ package body WisiToken.Syntax_Trees is
end Identifier;
function Image
- (Tree : in Syntax_Trees.Tree;
- Children : in Valid_Node_Index_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
+ (Tree : in Syntax_Trees.Tree;
+ Children : in Valid_Node_Index_Arrays.Vector;
+ Descriptor : in WisiToken.Descriptor;
+ Node_Numbers : in Boolean)
return String
is
use Ada.Strings.Unbounded;
@@ -973,7 +1082,9 @@ package body WisiToken.Syntax_Trees is
begin
for I of Children loop
Result := Result & (if Need_Comma then ", " else "") &
- Tree.Image (I, Descriptor, Include_Children => False);
+ (if I = Deleted_Child
+ then "-"
+ else Tree.Image (I, Descriptor, Include_Children => False,
Node_Numbers => Node_Numbers));
Need_Comma := True;
end loop;
Result := Result & ")";
@@ -983,24 +1094,22 @@ package body WisiToken.Syntax_Trees is
function Image
(Tree : in Syntax_Trees.Tree;
N : in Syntax_Trees.Node;
+ Node_Index : in Valid_Node_Index;
Descriptor : in WisiToken.Descriptor;
Include_Children : in Boolean;
- Include_RHS_Index : in Boolean := False)
+ Include_RHS_Index : in Boolean := False;
+ Node_Numbers : in Boolean := False)
return String
is
use Ada.Strings.Unbounded;
- Result : Unbounded_String;
+ Result : Unbounded_String := +(if Node_Numbers then Image (Node_Index) &
":" else "");
begin
- if Include_Children and N.Label = Nonterm then
- Result := +Image (N.ID, Descriptor) & '_' & Trimmed_Image
(N.RHS_Index) & ": ";
- end if;
-
case N.Label is
when Shared_Terminal =>
- Result := Result & (+Token_Index'Image (N.Terminal)) & ":";
+ Result := Result & Trimmed_Image (N.Terminal) & ":";
when Virtual_Identifier =>
- Result := Result & (+Identifier_Index'Image (N.Identifier)) & ";";
+ Result := Result & Trimmed_Image (N.Identifier) & ";";
when others =>
null;
@@ -1011,24 +1120,26 @@ package body WisiToken.Syntax_Trees is
(if N.Byte_Region = Null_Buffer_Region then "" else ", " & Image
(N.Byte_Region)) & ")";
if Include_Children and N.Label = Nonterm then
- Result := Result & " <= " & Image (Tree, N.Children, Descriptor);
+ Result := Result & " <= " & Image (Tree, N.Children, Descriptor,
Node_Numbers);
end if;
return -Result;
end Image;
function Image
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Descriptor : in WisiToken.Descriptor;
- Include_Children : in Boolean := False)
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean := False;
+ Include_RHS_Index : in Boolean := False;
+ Node_Numbers : in Boolean := False)
return String
is begin
return Tree.Image
((if Node <= Tree.Last_Shared_Node
then Tree.Shared_Tree.Nodes (Node)
else Tree.Branched_Nodes (Node)),
- Descriptor, Include_Children);
+ Node, Descriptor, Include_Children, Include_RHS_Index, Node_Numbers);
end Image;
function Image
@@ -1043,7 +1154,7 @@ package body WisiToken.Syntax_Trees is
begin
for I in Nodes'Range loop
Result := Result & (if Need_Comma then ", " else "") &
- Tree.Image (Nodes (I), Descriptor, Include_Children => False);
+ Tree.Image (Nodes (I), Descriptor);
Need_Comma := True;
end loop;
Result := Result & ")";
@@ -1069,7 +1180,8 @@ package body WisiToken.Syntax_Trees is
procedure Initialize
(Branched_Tree : in out Syntax_Trees.Tree;
Shared_Tree : in Base_Tree_Access;
- Flush : in Boolean)
+ Flush : in Boolean;
+ Set_Parents : in Boolean := False)
is begin
Branched_Tree :=
(Ada.Finalization.Controlled with
@@ -1078,16 +1190,28 @@ package body WisiToken.Syntax_Trees is
Branched_Nodes => <>,
Flush => Flush,
Root => <>);
+
+ Branched_Tree.Shared_Tree.Parents_Set := Set_Parents;
end Initialize;
- function Is_Empty (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Boolean
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Byte_Region = Null_Buffer_Region;
- else
- return Tree.Branched_Nodes (Node).Byte_Region = Null_Buffer_Region;
- end if;
- end Is_Empty;
+ function Is_Descendant_Of
+ (Tree : in Syntax_Trees.Tree;
+ Root : in Valid_Node_Index;
+ Descendant : in Valid_Node_Index)
+ return Boolean
+ is
+ Node : Node_Index := Descendant;
+ begin
+ loop
+ exit when Node = Invalid_Node_Index;
+ if Node = Root then
+ return True;
+ end if;
+
+ Node := Tree.Parent (Node);
+ end loop;
+ return False;
+ end Is_Descendant_Of;
function Is_Nonterm (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
is begin
@@ -1170,6 +1294,7 @@ package body WisiToken.Syntax_Trees is
when Nonterm =>
for C of reverse N.Children loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
declare
Last_Term : constant Base_Token_Index :=
Tree.Last_Shared_Terminal (C);
begin
@@ -1199,6 +1324,7 @@ package body WisiToken.Syntax_Trees is
return Node;
when Nonterm =>
for C of reverse N.Children loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
declare
Term : constant Node_Index := Last_Terminal (Tree, C);
begin
@@ -1224,6 +1350,7 @@ package body WisiToken.Syntax_Trees is
Min : Node_Index := Node;
begin
for C of N.Children loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
Min := Node_Index'Min (Min, Min_Descendant (Nodes, C));
end loop;
return Min;
@@ -1253,6 +1380,7 @@ package body WisiToken.Syntax_Trees is
when Nonterm =>
-- Use first non-empty
for J in N.Children.First_Index .. N.Children.Last_Index loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
declare
Result : constant Node_Index := First_Child (N.Children (J));
begin
@@ -1277,6 +1405,7 @@ package body WisiToken.Syntax_Trees is
begin
pragma Assert (N.Label = Nonterm);
for I in N.Children.First_Index .. N.Children.Last_Index loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
if N.Children (I) = Child then
-- Use first non-empty next from I + 1.
for J in I + 1 .. N.Children.Last_Index loop
@@ -1338,6 +1467,7 @@ package body WisiToken.Syntax_Trees is
when Nonterm =>
-- Use first non-empty from end.
for J in reverse N.Children.First_Index .. N.Children.Last_Index
loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
declare
Result : constant Node_Index := Last_Child (N.Children (J));
begin
@@ -1362,6 +1492,7 @@ package body WisiToken.Syntax_Trees is
begin
pragma Assert (N.Label = Nonterm);
for I in reverse N.Children.First_Index ..
N.Children.Last_Index loop
+ -- Encountering Deleted_Child here is an error in the user
algorithm.
if N.Children (I) = Child then
-- Use first non-empty from I - 1.
for J in reverse N.Children.First_Index .. I - 1 loop
@@ -1391,7 +1522,8 @@ package body WisiToken.Syntax_Trees is
(Tree : in Syntax_Trees.Tree;
Descriptor : in WisiToken.Descriptor;
Root : in Node_Index := Invalid_Node_Index;
- Image_Augmented : in Syntax_Trees.Image_Augmented := null)
+ Image_Augmented : in Syntax_Trees.Image_Augmented := null;
+ Image_Action : in Syntax_Trees.Image_Action := null)
is
use Ada.Text_IO;
@@ -1406,7 +1538,7 @@ package body WisiToken.Syntax_Trees is
if Node_Printed (Node) then
-- This does not catch all possible tree edit errors, but it does
-- catch circles.
- raise SAL.Programmer_Error with "Print_Tree: invalid tree" &
Node_Index'Image (Node);
+ raise SAL.Programmer_Error with "Print_Tree: invalid tree; loop:"
& Node_Index'Image (Node);
else
Node_Printed (Node) := True;
end if;
@@ -1415,23 +1547,38 @@ package body WisiToken.Syntax_Trees is
for I in 1 .. Level loop
Put ("| ");
end loop;
- Put (Image (Tree, N, Descriptor, Include_Children => False,
Include_RHS_Index => True));
- if Image_Augmented /= null and N.Augmented /= null then
- Put_Line (" - " & Image_Augmented (N.Augmented));
- else
- New_Line;
+ Put (Image (Tree, N, Node, Descriptor, Include_Children => False,
Include_RHS_Index => True));
+ if Image_Augmented /= null and N.Augmented /= null then
+ Put (" - " & Image_Augmented (N.Augmented));
+ end if;
+ if N.Label = Nonterm and then (Image_Action /= null and N.Action /=
null) then
+ Put (" - " & Image_Action (N.Action));
end if;
+ New_Line;
if N.Label = Nonterm then
for Child of N.Children loop
- Print_Node (Child, Level + 1);
+ if Child = Deleted_Child then
+ Put (" : ");
+ for I in 1 .. Level + 1 loop
+ Put ("| ");
+ end loop;
+ Put_Line (" <deleted>");
+ else
+ Print_Node (Child, Level + 1);
+ end if;
end loop;
end if;
end Print_Node;
+ Print_Root : constant Node_Index := (if Root = Invalid_Node_Index then
Tree.Root else Root);
begin
Node_Printed.Set_First_Last (Tree.First_Index, Tree.Last_Index);
- Print_Node ((if Root = Invalid_Node_Index then Tree.Root else Root), 0);
+ if Print_Root = Invalid_Node_Index then
+ Put_Line ("<empty tree>");
+ else
+ Print_Node (Print_Root, 0);
+ end if;
end Print_Tree;
function Process_Tree
@@ -1454,8 +1601,10 @@ package body WisiToken.Syntax_Trees is
if N.Label = Nonterm then
for Child of N.Children loop
- if not Process_Tree (Tree, Child, Visit_Parent, Process_Node)
then
- return False;
+ if Child /= Deleted_Child then
+ if not Process_Tree (Tree, Child, Visit_Parent,
Process_Node) then
+ return False;
+ end if;
end if;
end loop;
end if;
@@ -1485,7 +1634,9 @@ package body WisiToken.Syntax_Trees is
is begin
if N.Label = Nonterm then
for Child of N.Children loop
- Process_Tree (Tree, Child, Process_Node);
+ if Child /= Deleted_Child then
+ Process_Tree (Tree, Child, Process_Node);
+ end if;
end loop;
end if;
@@ -1506,9 +1657,6 @@ package body WisiToken.Syntax_Trees is
Node : in Valid_Node_Index);
Root : in Node_Index := Invalid_Node_Index)
is begin
- if Root = Invalid_Node_Index and Tree.Root = Invalid_Node_Index then
- raise SAL.Programmer_Error with "Tree.Root not set";
- end if;
Tree.Shared_Tree.Traversing := True;
Process_Tree (Tree, (if Root = Invalid_Node_Index then Tree.Root else
Root), Process_Node);
Tree.Shared_Tree.Traversing := False;
@@ -1529,6 +1677,25 @@ package body WisiToken.Syntax_Trees is
else (Tree.Branched_Nodes (Node).ID, Tree.Branched_Nodes
(Node).RHS_Index));
end Production_ID;
+ procedure Replace_Child
+ (Tree : in out Syntax_Trees.Tree;
+ Parent : in Valid_Node_Index;
+ Child_Index : in SAL.Peek_Type;
+ Old_Child : in Valid_Node_Index;
+ New_Child : in Valid_Node_Index;
+ Old_Child_New_Parent : in Node_Index := Invalid_Node_Index)
+ is
+ N : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Parent);
+ begin
+ N.Children (Child_Index) := New_Child;
+
+ if Old_Child /= Deleted_Child then
+ Tree.Shared_Tree.Nodes (Old_Child).Parent := Old_Child_New_Parent;
+ end if;
+
+ Tree.Shared_Tree.Nodes (New_Child).Parent := Parent;
+ end Replace_Child;
+
function RHS_Index
(Tree : in Syntax_Trees.Tree;
Node : in Valid_Node_Index)
@@ -1540,6 +1707,11 @@ package body WisiToken.Syntax_Trees is
else Tree.Branched_Nodes (Node).RHS_Index);
end RHS_Index;
+ function Root (Tree : in Syntax_Trees.Tree) return Node_Index
+ is begin
+ return Tree.Root;
+ end Root;
+
procedure Set_Node_Identifier
(Tree : in Syntax_Trees.Tree;
Node : in Valid_Node_Index;
@@ -1548,6 +1720,12 @@ package body WisiToken.Syntax_Trees is
is
Current : constant Syntax_Trees.Node := Tree.Shared_Tree.Nodes (Node);
begin
+ for C of Current.Children loop
+ if C /= Deleted_Child then
+ Tree.Shared_Tree.Nodes (C).Parent := Invalid_Node_Index;
+ end if;
+ end loop;
+
Tree.Shared_Tree.Nodes.Replace_Element
(Node,
(Label => Virtual_Identifier,
@@ -1575,6 +1753,11 @@ package body WisiToken.Syntax_Trees is
when Nonterm =>
for C of N.Children loop
+ if C = Deleted_Child then
+ -- This can only happen if someone calls Set_Parents after
parents
+ -- are already set.
+ raise SAL.Programmer_Error with "encountered Deleted_Child";
+ end if;
Set_Parents (Tree, C, Node);
end loop;
end case;
@@ -1589,19 +1772,6 @@ package body WisiToken.Syntax_Trees is
Tree.Root := Root;
end Set_Root;
- function Root (Tree : in Syntax_Trees.Tree) return Node_Index
- is begin
- if Tree.Root /= Invalid_Node_Index then
- return Tree.Root;
- else
- if Tree.Flush then
- return Tree.Shared_Tree.Nodes.Last_Index;
- else
- return Tree.Branched_Nodes.Last_Index;
- end if;
- end if;
- end Root;
-
function Same_Token
(Tree_1 : in Syntax_Trees.Tree'Class;
Index_1 : in Valid_Node_Index;
@@ -1643,27 +1813,44 @@ package body WisiToken.Syntax_Trees is
Parent : in Valid_Node_Index;
Children : in Valid_Node_Index_Array)
is
- use all type SAL.Base_Peek_Type;
-
N : Node_Var_Ref renames Tree.Get_Node_Var_Ref (Parent);
Min_Terminal_Index_Set : Boolean := False;
begin
+ -- See Design note in spec about Parents, Parent_Set.
+
+ if Tree.Parents_Set then
+ -- Clear current Children.Parent first, in case some are also in new
+ -- children.
+ for C of N.Children loop
+ if C /= WisiToken.Deleted_Child then
+ Tree.Shared_Tree.Nodes (C).Parent := Invalid_Node_Index;
+ end if;
+ end loop;
+ end if;
+
N.Children.Set_First_Last (Children'First, Children'Last);
+
for I in Children'Range loop
+
N.Children (I) := Children (I);
if Tree.Parents_Set then
- -- Parsing is done; we are editing the tree.
declare
- K : Node_Var_Ref renames Tree.Get_Node_Var_Ref (Children (I));
+ Child_Node : Node renames Tree.Shared_Tree.Nodes (Children (I));
begin
- K.Parent := Parent;
+ if Child_Node.Parent /= Invalid_Node_Index then
+ declare
+ Other_Parent : Node renames Tree.Shared_Tree.Nodes
(Child_Node.Parent);
+ Child_Index : constant SAL.Base_Peek_Type :=
Syntax_Trees.Child_Index
+ (Other_Parent, Children (I));
+ begin
+ Other_Parent.Children (Child_Index) :=
WisiToken.Deleted_Child;
+ end;
+ end if;
+
+ Child_Node.Parent := Parent;
end;
- else
- -- We do _not_ set K.Parent here; that is only done after parsing
is
- -- complete. See Design note in spec.
- null;
end if;
declare
@@ -1710,23 +1897,16 @@ package body WisiToken.Syntax_Trees is
New_ID : in WisiToken.Production_ID;
Children : in Valid_Node_Index_Array)
is
- use all type SAL.Base_Peek_Type;
- Parent_Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Node);
-
- J : Positive_Index_Type := Positive_Index_Type'First;
+ Parent_Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Node);
begin
+ if New_ID /= (Parent_Node.ID, Parent_Node.RHS_Index) then
+ Parent_Node.Action := null;
+ end if;
+
Parent_Node.ID := New_ID.LHS;
Parent_Node.RHS_Index := New_ID.RHS;
- Parent_Node.Action := null;
- 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.
- Parent_Node.Children (J) := Children (I);
- Tree.Shared_Tree.Nodes (Children (I)).Parent := Node;
- J := J + 1;
- end loop;
+ Set_Children (Tree, Node, Children);
end Set_Children;
procedure Set_State
@@ -1770,6 +1950,17 @@ package body WisiToken.Syntax_Trees is
end if;
end Set_Name_Region;
+ function Sub_Tree_Root (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index
+ is
+ N : Valid_Node_Index := Node;
+ begin
+ loop
+ exit when Tree.Shared_Tree.Nodes (N).Parent = Invalid_Node_Index;
+ N := Tree.Shared_Tree.Nodes (N).Parent;
+ end loop;
+ return N;
+ end Sub_Tree_Root;
+
function Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Base_Token_Index
is begin
if Node <= Tree.Last_Shared_Node then
@@ -1845,4 +2036,76 @@ package body WisiToken.Syntax_Trees is
end if;
end State;
+ procedure Validate_Tree
+ (Tree : in out Syntax_Trees.Tree;
+ Terminals : in Base_Token_Array_Access_Constant;
+ Descriptor : in WisiToken.Descriptor;
+ File_Name : in String;
+ Root : in Node_Index := Invalid_Node_Index;
+ Validate_Node : in Syntax_Trees.Validate_Node := null)
+ is
+ procedure Process_Node
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ is
+ use Ada.Text_IO;
+ N : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Node);
+ Node_Image_Output : Boolean := False;
+ begin
+ if N.Label = Nonterm then
+ for I in N.Children.First_Index .. N.Children.Last_Index loop
+ if N.Children (I) = Deleted_Child then
+ if not Node_Image_Output then
+ Put_Line
+ (Current_Error,
+ Tree.Error_Message
+ (Terminals, Node, File_Name,
+ Image (Tree, N, Node, Descriptor,
+ Include_Children => False,
+ Node_Numbers => True)));
+ Node_Image_Output := True;
+ end if;
+ Put_Line
+ (Current_Error, Tree.Error_Message
+ (Terminals, Node, File_Name, "... child" & I'Image & "
deleted"));
+
+ else
+ declare
+ Child_Parent : constant Node_Index :=
Tree.Shared_Tree.Nodes (N.Children (I)).Parent;
+ begin
+ if Child_Parent /= Node then
+ if not Node_Image_Output then
+ Put_Line
+ (Current_Error,
+ Tree.Error_Message
+ (Terminals, Node, File_Name,
+ Image (Tree, N, Node, Descriptor,
+ Include_Children => False,
+ Node_Numbers => True)));
+ Node_Image_Output := True;
+ end if;
+ if Child_Parent = Invalid_Node_Index then
+ Put_Line
+ (Current_Error, Tree.Error_Message
+ (Terminals, Node, File_Name, "... child.parent
invalid"));
+ else
+ Put_Line
+ (Current_Error, Tree.Error_Message
+ (Terminals, Node, File_Name, "...
child.parent" & Child_Parent'Image & " incorrect"));
+ end if;
+ end if;
+ end;
+ end if;
+ end loop;
+ end if;
+
+ if Validate_Node /= null then
+ Validate_Node (Tree, Node, Node_Image_Output);
+ end if;
+ end Process_Node;
+
+ begin
+ Process_Tree (Tree, (if Root = Invalid_Node_Index then Tree.Root else
Root), Process_Node'Access);
+ end Validate_Tree;
+
end WisiToken.Syntax_Trees;
diff --git a/wisitoken-syntax_trees.ads b/wisitoken-syntax_trees.ads
index 5eff265..db29bac 100644
--- a/wisitoken-syntax_trees.ads
+++ b/wisitoken-syntax_trees.ads
@@ -24,11 +24,20 @@
-- The parent components are set by Set_Parents, which is called by
-- Parser.Execute_Actions before the actions are executed.
-- Fortunately, we don't need the parent components during error
--- recover.
+-- recover. After calling Set_Parents (ie, while editing the syntax
+-- tree after parse), any functions that modify children or parents
+-- update the corresponding links, setting them to Invalid_Node_Index
+-- or Deleted_Child as appropriate.
--
-- We provide Base_Tree and Tree in one package, because only Tree
-- needs an API; the only way Base_Tree is accessed is via Tree.
--
+-- Base_Tree and Tree are not limited to allow
+-- wisitoken-parse-lr-parser_lists.ads Prepend_Copy to copy them. No
+-- Adjust is needed; Shared_Tree is shared between parsers, and
+-- Augmented pointers are also shared, since during parse they are
+-- set only for Shared_Terminals.
+--
-- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
--
-- This library is free software; you can redistribute it and/or modify it
@@ -56,15 +65,24 @@ package WisiToken.Syntax_Trees is
overriding procedure Finalize (Tree : in out Base_Tree);
-- Free any allocated storage.
+ function Is_Empty (Tree : in Base_Tree) return Boolean;
+
type Tree is new Ada.Finalization.Controlled with private;
- type Tree_Variable_Reference (Element : access Tree) is null record with
+ type Tree_Variable_Reference (Element : not null access Tree) is null
record with
+ Implicit_Dereference => Element;
+
+ type Tree_Constant_Reference (Element : not null access constant Tree) is
null record with
Implicit_Dereference => Element;
+ function Is_Empty (Tree : in Syntax_Trees.Tree) return Boolean;
+
procedure Initialize
(Branched_Tree : in out Tree;
Shared_Tree : in Base_Tree_Access;
- Flush : in Boolean);
+ Flush : in Boolean;
+ Set_Parents : in Boolean := False)
+ with Pre => Branched_Tree.Is_Empty and Shared_Tree.Is_Empty;
-- Set Branched_Tree to refer to Shared_Tree.
overriding procedure Finalize (Tree : in out Syntax_Trees.Tree);
@@ -86,7 +104,7 @@ package WisiToken.Syntax_Trees is
procedure Set_Lexer_Terminals
(User_Data : in out User_Data_Type;
Lexer : in WisiToken.Lexer.Handle;
- Terminals : in Base_Token_Array_Access)
+ Terminals : in Base_Token_Array_Access_Constant)
is null;
procedure Reset (User_Data : in out User_Data_Type) is null;
@@ -176,16 +194,15 @@ package WisiToken.Syntax_Trees is
function Copy_Subtree
(Tree : in out Syntax_Trees.Tree;
- Root : in Valid_Node_Index;
- Last : in Valid_Node_Index)
+ Root : in Valid_Node_Index)
return Valid_Node_Index
with Pre => Tree.Flushed and Tree.Parents_Set;
- -- Deep copy (into Tree) subtree of Tree rooted at Root. Stop copying
- -- after children of Last are copied. Return root of new subtree.
+ -- Deep copy (into Tree) subtree of Tree rooted at Root. Return root
+ -- of new subtree; it has no parent.
--
-- Parents of new child nodes are set. Node index order is preserved.
-- References to objects external to tree are shallow copied
- -- (Terminals, Augmented).
+ -- (Terminals, Augmented, Action).
function Add_Nonterm
(Tree : in out Syntax_Trees.Tree;
@@ -194,10 +211,15 @@ package WisiToken.Syntax_Trees is
Action : in Semantic_Action := null;
Default_Virtual : in Boolean := False)
return Valid_Node_Index
- with Pre => not Tree.Traversing;
+ with Pre => not Tree.Traversing and
+ (for all C of Children => C /= Deleted_Child);
-- Add a new Nonterm node, which can be empty. Result points to the
-- added node. If Children'Length = 0, set Nonterm.Virtual :=
-- Default_Virtual.
+ --
+ -- If Tree.Parents_Set, then Children.Parent are set to the new node,
+ -- and in previous parents of those children (if any), the
+ -- corresponding entry in Children is set to Deleted_Child.
function Add_Terminal
(Tree : in out Syntax_Trees.Tree;
@@ -217,8 +239,8 @@ package WisiToken.Syntax_Trees is
-- Add a new Virtual_Terminal node with no parent. Before is the
-- index of the terminal in Terminals that this virtual is inserted
-- before during error correction; if Invalid_Token_Index, it is
- -- inserted during EBNF translation, and there is no such terminal in
- -- Terminals. Result points to the added node.
+ -- inserted during EBNF translation, and there is no such terminal.
+ -- Result points to the added node.
function Before
(Tree : in Syntax_Trees.Tree;
@@ -242,10 +264,37 @@ package WisiToken.Syntax_Trees is
Parent : in Valid_Node_Index;
Child : in Valid_Node_Index)
with
- Pre => Tree.Flushed and
- (not Tree.Traversing) and
+ Pre => Tree.Flushed and Tree.Parents_Set and (not Tree.Traversing) and
Tree.Is_Nonterm (Parent);
- -- Child.Parent must already be set.
+ -- Sets Child.Parent.
+
+ function Child_Index
+ (Tree : in out Syntax_Trees.Tree;
+ Parent : in Valid_Node_Index;
+ Child : in Valid_Node_Index)
+ return SAL.Peek_Type
+ with Pre => Tree.Has_Child (Parent, Child);
+
+ procedure Replace_Child
+ (Tree : in out Syntax_Trees.Tree;
+ Parent : in Valid_Node_Index;
+ Child_Index : in SAL.Peek_Type;
+ Old_Child : in Valid_Node_Index;
+ New_Child : in Valid_Node_Index;
+ Old_Child_New_Parent : in Node_Index := Invalid_Node_Index)
+ with
+ Pre => Tree.Flushed and Tree.Parents_Set and (not Tree.Traversing) and
+ (Tree.Is_Nonterm (Parent) and then
+ (Tree.Child (Parent, Child_Index) = Old_Child and
+ (Old_Child = Deleted_Child or else
+ Tree.Parent (Old_Child) = Parent)));
+ -- In Parent.Children, replace child at Child_Index with New_Child.
+ -- Unless Old_Child is Deleted_Child, set Old_Child.Parent to
+ -- Old_Child_New_Parent (may be Invalid_Node_Index). Unless New_Child
+ -- is Deleted_Child, set New_Child.Parent to Parent.
+ --
+ -- If Old_Child is Deleted_Child, Old_Child_New_Parent should be left
+ -- to default.
procedure Set_Children
(Tree : in out Syntax_Trees.Tree;
@@ -253,24 +302,38 @@ package WisiToken.Syntax_Trees is
New_ID : in WisiToken.Production_ID;
Children : in Valid_Node_Index_Array)
with
- Pre => Tree.Flushed and
- Tree.Parents_Set and
- (not Tree.Traversing) and
- Tree.Is_Nonterm (Node);
- -- Set ID of Node to New_ID, and children to Children; set parent of
- -- Children to Node. Remove any Action.
+ Pre => Tree.Flushed and Tree.Parents_Set and (not Tree.Traversing) and
+ Tree.Is_Nonterm (Node) and
+ (for all C of Children => C /= Deleted_Child);
+ -- If parents of current Node.Children are not Invalid_Node_Index,
+ -- set corresponding entry in those parents to Deleted_Child, then
+ -- set Parent to Invalid_Node_Index.
+ --
+ -- Then set ID of Node to New_ID, and Node.Children to Children; set
+ -- parents of Children to Node.
--
- -- New_ID is required, and Action removed, because this is most
- -- likely a different production.
+ -- If New_ID /= Tree.Production_ID (Node), Node.Action is set
+ -- to null, because the old Action probably no longer applies.
+
+ procedure Delete_Parent
+ (Tree : in out Syntax_Trees.Tree;
+ Node : in Valid_Node_Index)
+ with
+ Pre => Tree.Flushed and Tree.Parents_Set and (not Tree.Traversing) and
+ Tree.Parent (Node) /= Invalid_Node_Index;
+ -- Set child in Node.Parent to Deleted_Child. If Node.Parent =
+ -- Tree.Root, set Tree.Root to Node. Set Node.Parent to
+ -- Invalid_Node_Index.
procedure Set_Node_Identifier
(Tree : in Syntax_Trees.Tree;
Node : in Valid_Node_Index;
ID : in Token_ID;
Identifier : in Identifier_Index)
- with Pre => Tree.Flushed and
+ with Pre => Tree.Flushed and Tree.Parents_Set and (not Tree.Traversing) and
Tree.Is_Nonterm (Node);
- -- Change Node to a Virtual_Identifier.
+ -- Set parents of current Node.Children to Invalid_Node_Index.
+ -- Then change Node to a Virtual_Identifier.
procedure Set_State
(Tree : in out Syntax_Trees.Tree;
@@ -281,8 +344,13 @@ package WisiToken.Syntax_Trees is
function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Label;
+ function Child_Count (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Ada.Containers.Count_Type
+ with Pre => Tree.Is_Nonterm (Node);
+
function Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Valid_Node_Index_Array
with Pre => Tree.Is_Nonterm (Node);
+ -- Any children that were cleared by Add_Nonterm are returned as
+ -- Deleted_Child.
function Child
(Tree : in Syntax_Trees.Tree;
@@ -292,10 +360,22 @@ package WisiToken.Syntax_Trees is
with Pre => Tree.Is_Nonterm (Node);
function Has_Branched_Nodes (Tree : in Syntax_Trees.Tree) return Boolean;
- function Has_Children (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ function Has_Children (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
+ with Pre => Tree.Is_Nonterm (Node);
+ function Has_Child
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Child : in Valid_Node_Index)
+ return Boolean
+ with Pre => Tree.Is_Nonterm (Node);
function Has_Parent (Tree : in Syntax_Trees.Tree; Child : in
Valid_Node_Index) return Boolean;
function Has_Parent (Tree : in Syntax_Trees.Tree; Children : in
Valid_Node_Index_Array) return Boolean;
- function Is_Empty (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Boolean;
+
+ function Buffer_Region_Is_Empty (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
+ -- True if contained buffer region is empty; always the case for
+ -- virtual tokens, and for most copied tokens. Use Has_Children or
+ -- Child_Count to see if Node has children.
+
function Is_Nonterm (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
function Is_Shared_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
function Is_Virtual_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
@@ -308,7 +388,7 @@ package WisiToken.Syntax_Trees is
function Parents_Set (Tree : in Syntax_Trees.Tree) return Boolean;
procedure Set_Parents (Tree : in out Syntax_Trees.Tree)
- with Pre => Tree.Flushed;
+ with Pre => Tree.Flushed and Tree.Root /= Invalid_Node_Index;
function Parent
(Tree : in Syntax_Trees.Tree;
@@ -388,19 +468,24 @@ package WisiToken.Syntax_Trees is
with Pre => Tree.Is_Nonterm (Node);
function Find_Ancestor
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ ID : in Token_ID;
+ Max_Parent : in Boolean := False)
return Node_Index
with Pre => Tree.Parents_Set;
function Find_Ancestor
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- IDs : in Token_ID_Array)
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ IDs : in Token_ID_Array;
+ Max_Parent : in Boolean := False)
return Node_Index
with Pre => Tree.Parents_Set;
- -- Return the ancestor of Node that contains ID, or Invalid_Node_Index if
- -- none match.
+ -- Return the ancestor of Node that contains ID (starting search with
+ -- Node.Parent), or Invalid_Node_Index if none match.
+ --
+ -- If Max_Parent, return max parent found if none match; this will be
+ -- Invalid_Node_Index if Node has no parent.
function Find_Sibling
(Tree : in Syntax_Trees.Tree;
@@ -436,18 +521,30 @@ package WisiToken.Syntax_Trees is
-- Return the descendant of Node (may be Node) for which Predicate
-- returns True, or Invalid_Node_Index if none do.
+ function Is_Descendant_Of
+ (Tree : in Syntax_Trees.Tree;
+ Root : in Valid_Node_Index;
+ Descendant : in Valid_Node_Index)
+ return Boolean
+ with Pre => Tree.Parents_Set and Tree.Is_Nonterm (Root);
+
procedure Set_Root (Tree : in out Syntax_Trees.Tree; Root : in
Valid_Node_Index);
function Root (Tree : in Syntax_Trees.Tree) return Node_Index;
- -- Return value set by Set_Root; defaults to the last node added.
+ -- Return value set by Set_Root.
-- returns Invalid_Node_Index if Tree is empty.
+ function Sub_Tree_Root (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index
+ with Pre => Tree.Parents_Set;
+ -- Return top ancestor of Node.
+
procedure Process_Tree
(Tree : in out Syntax_Trees.Tree;
Process_Node : access procedure
(Tree : in out Syntax_Trees.Tree;
Node : in Valid_Node_Index);
- Root : in Node_Index := Invalid_Node_Index);
+ Root : in Node_Index := Invalid_Node_Index)
+ with Pre => Root /= Invalid_Node_Index or Tree.Root /= Invalid_Node_Index;
-- Traverse subtree of Tree rooted at Root (default Tree.Root) in
-- depth-first order, calling Process_Node on each node.
@@ -503,10 +600,12 @@ package WisiToken.Syntax_Trees is
-- Return all descendants of Node matching ID.
function Image
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Descriptor : in WisiToken.Descriptor;
- Include_Children : in Boolean := False)
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Descriptor : in WisiToken.Descriptor;
+ Include_Children : in Boolean := False;
+ Include_RHS_Index : in Boolean := False;
+ Node_Numbers : in Boolean := False)
return String;
function Image
(Tree : in Syntax_Trees.Tree;
@@ -526,13 +625,44 @@ package WisiToken.Syntax_Trees is
return String;
-- Simple list of numbers, for debugging
+ function Error_Message
+ (Tree : in Syntax_Trees.Tree;
+ Terminals : in Base_Token_Array_Access_Constant;
+ Node : in Valid_Node_Index;
+ File_Name : in String;
+ Message : in String)
+ return String;
+ -- Get Line, column from Node.
+
+ type Validate_Node is access procedure
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Node_Image_Output : in out Boolean);
+ -- Called by Validate_Tree for each node visited; perform other
+ -- checks, output to Text_IO.Current_Error. If Node_Image_Output is
+ -- False, output Image (Tree, Node, Descriptor, Node_Numbers => True) once
+ -- before any error messages.
+
+ procedure Validate_Tree
+ (Tree : in out Syntax_Trees.Tree;
+ Terminals : in Base_Token_Array_Access_Constant;
+ Descriptor : in WisiToken.Descriptor;
+ File_Name : in String;
+ Root : in Node_Index := Invalid_Node_Index;
+ Validate_Node : in Syntax_Trees.Validate_Node := null)
+ with Pre => Tree.Flushed and Tree.Parents_Set;
+ -- Verify child/parent links, and that no children are Deleted_Child.
+ -- Violations output a message to Text_IO.Current_Error.
+
type Image_Augmented is access function (Aug : in Base_Token_Class_Access)
return String;
+ type Image_Action is access function (Action : in Semantic_Action) return
String;
procedure Print_Tree
(Tree : in Syntax_Trees.Tree;
Descriptor : in WisiToken.Descriptor;
Root : in Node_Index := Invalid_Node_Index;
- Image_Augmented : in Syntax_Trees.Image_Augmented := null)
+ Image_Augmented : in Syntax_Trees.Image_Augmented := null;
+ Image_Action : in Syntax_Trees.Image_Action := null)
with Pre => Tree.Flushed;
-- Print tree rooted at Root (default Tree.Root) to
-- Text_IO.Current_Output, for debugging. For each node,
@@ -619,6 +749,9 @@ private
-- note above.
end record;
+ function Is_Empty (Tree : in Base_Tree) return Boolean
+ is (Tree.Nodes.Length = 0);
+
type Tree is new Ada.Finalization.Controlled with record
Shared_Tree : Base_Tree_Access;
-- If we need to set anything (ie parent) in Shared_Tree, we move the
@@ -663,6 +796,9 @@ private
then Tree.Shared_Tree.Nodes.Variable_Ref (Node)
else Tree.Branched_Nodes.Variable_Ref (Node));
+ function Is_Empty (Tree : in Syntax_Trees.Tree) return Boolean
+ is (Tree.Branched_Nodes.Length = 0 and (Tree.Shared_Tree = null or else
Tree.Shared_Tree.Is_Empty));
+
function Parents_Set (Tree : in Syntax_Trees.Tree) return Boolean
is (Tree.Shared_Tree.Parents_Set);
diff --git a/wisitoken-to_tree_sitter.adb b/wisitoken-to_tree_sitter.adb
new file mode 100644
index 0000000..2213414
--- /dev/null
+++ b/wisitoken-to_tree_sitter.adb
@@ -0,0 +1,528 @@
+-- Abstract :
+--
+-- Translate a wisitoken grammar file to a tree-sitter grammar file.
+--
+-- References:
+--
+-- [1] tree-sitter grammar:
https://tree-sitter.github.io/tree-sitter/creating-parsers#the-grammar-dsl
+--
+-- Copyright (C) 2020 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.
+
+pragma License (GPL);
+
+with Ada.Command_Line;
+with Ada.Directories;
+with Ada.Exceptions;
+with Ada.Strings.Fixed;
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.Traceback.Symbolic;
+with WisiToken.Syntax_Trees.LR_Utils;
+with WisiToken.Parse.LR.Parser_No_Recover;
+with WisiToken.Syntax_Trees;
+with WisiToken.Text_IO_Trace;
+with WisiToken_Grammar_Runtime;
+with Wisitoken_Grammar_Actions; use Wisitoken_Grammar_Actions;
+with Wisitoken_Grammar_Main;
+procedure WisiToken.To_Tree_Sitter
+is
+ procedure Put_Usage
+ is begin
+ Put_Line ("wisitoken-to_tree_sitter [--verbosity <level] <wisitoken
grammar file> <language_name>");
+ end Put_Usage;
+
+ procedure Print_Tree_Sitter
+ (Data : in WisiToken_Grammar_Runtime.User_Data_Type;
+ Tree : in Syntax_Trees.Tree;
+ Output_File_Name : in String;
+ Language_Name : in String)
+ is
+ use WisiToken.Syntax_Trees;
+
+ File : File_Type;
+
+ -- Local specs
+
+ procedure Put_RHS_Item_List (Node : in Valid_Node_Index; First : in
Boolean)
+ with Pre => Tree.ID (Node) = +rhs_item_list_ID;
+
+ -- Local bodies
+
+ function Get_Text (Tree_Index : in Valid_Node_Index) return String
+ is
+ function Strip_Delimiters (Tree_Index : in Valid_Node_Index) return
String
+ is
+ Region : Buffer_Region renames Data.Terminals.all (Tree.Terminal
(Tree_Index)).Byte_Region;
+ begin
+ if -Tree.ID (Tree_Index) in RAW_CODE_ID | REGEXP_ID | ACTION_ID
then
+ -- Strip delimiters. We don't strip leading/trailing spaces to
preserve indent.
+ return Data.Grammar_Lexer.Buffer_Text ((Region.First + 2,
Region.Last - 2));
+
+ -- We don't strip string delimiters; tree-setter can use the
same ones.
+ else
+ return Data.Grammar_Lexer.Buffer_Text (Region);
+ end if;
+ end Strip_Delimiters;
+
+ begin
+ case Tree.Label (Tree_Index) is
+ when Shared_Terminal =>
+ return Strip_Delimiters (Tree_Index);
+
+ when Virtual_Terminal =>
+ -- Terminal keyword inserted during tree edit. We could check for
+ -- Identifier, but that will be caught later.
+ return Image (Tree.ID (Tree_Index),
Wisitoken_Grammar_Actions.Descriptor);
+
+ when Virtual_Identifier =>
+ raise SAL.Programmer_Error;
+
+ when Nonterm =>
+ declare
+ use all type Ada.Strings.Unbounded.Unbounded_String;
+ Result : Ada.Strings.Unbounded.Unbounded_String;
+ Tree_Indices : constant Valid_Node_Index_Array :=
Tree.Get_Terminals (Tree_Index);
+ Need_Space : Boolean :=
False;
+ begin
+ for Tree_Index of Tree_Indices loop
+ Result := Result & (if Need_Space then " " else "") &
+ Get_Text (Tree_Index);
+ Need_Space := True;
+ end loop;
+ return -Result;
+ end;
+ end case;
+ end Get_Text;
+
+ procedure Not_Translated (Label : in String; Node : in Valid_Node_Index)
+ is begin
+ New_Line (File);
+ Put (File, "// " & Label & ": not translated: " & Node_Index'Image
(Node) & ":" &
+ Tree.Image (Node, Wisitoken_Grammar_Actions.Descriptor,
Include_Children => True));
+ end Not_Translated;
+
+ procedure Put_RHS_Alternative_List (Node : in Valid_Node_Index; First :
in Boolean)
+ with Pre => Tree.ID (Node) = +rhs_alternative_list_ID
+ is begin
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ -- If only alternative, don't need "choice()".
+ Put_RHS_Item_List (Tree.Child (Node, 1), First => True);
+
+ when 1 =>
+ if First then
+ Put (File, "choice(");
+ end if;
+
+ Put_RHS_Alternative_List (Tree.Child (Node, 1), First => False);
+ Put (File, ", ");
+ Put_RHS_Item_List (Tree.Child (Node, 3), First => True);
+
+ if First then
+ Put (File, ")");
+ end if;
+
+ when others =>
+ Not_Translated ("Put_RHS_Alternative_List", Node);
+ end case;
+ end Put_RHS_Alternative_List;
+
+ procedure Put_RHS_Optional_Item (Node : in Valid_Node_Index)
+ with Pre => Tree.ID (Node) = +rhs_optional_item_ID
+ is begin
+ Put (File, "optional(");
+
+ case Tree.RHS_Index (Node) is
+ when 0 | 1 =>
+ Put_RHS_Alternative_List (Tree.Child (Node, 2), First => True);
+ when 2 =>
+ Put (File, "$." & Get_Text (Tree.Child (Node, 1)));
+ when 3 =>
+ -- STRING_LITERAL_2
+ Put (File, Get_Text (Tree.Child (Node, 1)));
+ when others =>
+ Not_Translated ("Put_RHS_Optional_Item", Node);
+ end case;
+
+ Put (File, ")");
+ end Put_RHS_Optional_Item;
+
+ procedure Put_RHS_Multiple_Item (Node : in Valid_Node_Index)
+ with Pre => Tree.ID (Node) = +rhs_multiple_item_ID
+ is begin
+ case Tree.RHS_Index (Node) is
+ when 0 | 3 =>
+ Put (File, "repeat(");
+ Put_RHS_Alternative_List (Tree.Child (Node, 2), First => True);
+ Put (File, ")");
+
+ when 1 | 2 =>
+ Put (File, "repeat1(");
+ Put_RHS_Alternative_List (Tree.Child (Node, 2), First => True);
+ Put (File, ")");
+
+ when 4 =>
+ Put (File, "repeat1(");
+ Put (File, "$." & Get_Text (Tree.Child (Node, 1)));
+ Put (File, ")");
+
+ when 5 =>
+ Put (File, "repeat(");
+ Put (File, "$." & Get_Text (Tree.Child (Node, 1)));
+ Put (File, ")");
+
+ when others =>
+ Not_Translated ("Put_RHS_Multiple_Item", Node);
+ end case;
+ end Put_RHS_Multiple_Item;
+
+ procedure Put_RHS_Group_Item (Node : in Valid_Node_Index)
+ with Pre => Tree.ID (Node) = +rhs_group_item_ID
+ is begin
+ Not_Translated ("Put_RHS_Group_Item", Node); -- maybe just plain ()?
+ end Put_RHS_Group_Item;
+
+ procedure Put_RHS_Item (Node : in Valid_Node_Index)
+ with Pre => Tree.ID (Node) = +rhs_item_ID
+ is begin
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ declare
+ use WisiToken_Grammar_Runtime;
+
+ Ident : constant String := Get_Text (Node);
+ Decl : constant Node_Index := Find_Declaration (Data, Tree,
Ident);
+ begin
+ if Decl = Invalid_Node_Index then
+ Raise_Programmer_Error ("decl for '" & Ident & "' not
found", Data, Tree, Node);
+
+ elsif Tree.ID (Decl) = +nonterminal_ID then
+ Put (File, "$." & Get_Text (Tree.Child (Decl, 1)));
+
+ else
+ case Tree.RHS_Index (Decl) is
+ when 0 =>
+ case To_Token_Enum (Tree.ID (Tree.Child (Tree.Child
(Decl, 2), 1))) is
+ when KEYWORD_ID =>
+ Put (File, Get_Text (Tree.Child (Decl, 4)));
+
+ when NON_GRAMMAR_ID =>
+ Not_Translated ("put_rhs_item", Node);
+
+ when Wisitoken_Grammar_Actions.TOKEN_ID =>
+ declare
+ use WisiToken.Syntax_Trees.LR_Utils;
+ Iter : constant Syntax_Trees.LR_Utils.Iterator :=
+ Iterate (Data, Tree, Tree.Child (Decl, 4),
+declaration_item_ID);
+ Item : constant Valid_Node_Index :=
+ Tree.Child (Syntax_Trees.LR_Utils.Node (First
(Iter)), 1);
+ begin
+ case To_Token_Enum (Tree.ID (Item)) is
+ when REGEXP_ID =>
+ Put (File, "$." & Ident);
+
+ when STRING_LITERAL_1_ID | STRING_LITERAL_2_ID =>
+ -- FIXME: case insensitive?
+ Put (File, Get_Text (Item));
+
+ when others =>
+ Not_Translated ("put_rhs_item ident token",
Node);
+ end case;
+ end;
+
+ when others =>
+ Not_Translated ("put_rhs_item ident", Node);
+ end case;
+
+ when others =>
+ Not_Translated ("put_rhs_item 0", Node);
+ end case;
+ end if;
+ end;
+
+ when 1 =>
+ -- STRING_LITERAL_2
+ Put (File, Get_Text (Node));
+
+ when 2 =>
+ -- ignore attribute
+ null;
+
+ when 3 =>
+ Put_RHS_Optional_Item (Tree.Child (Node, 1));
+
+ when 4 =>
+ Put_RHS_Multiple_Item (Tree.Child (Node, 1));
+
+ when 5 =>
+ Put_RHS_Group_Item (Tree.Child (Node, 1));
+
+ when others =>
+ Not_Translated ("Put_RHS_Item", Node);
+ end case;
+ end Put_RHS_Item;
+
+ procedure Put_RHS_Element (Node : in Valid_Node_Index)
+ with Pre => Tree.ID (Node) = +rhs_element_ID
+ is begin
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ Put_RHS_Item (Tree.Child (Node, 1));
+
+ when 1 =>
+ -- Ignore the label
+ Put_RHS_Item (Tree.Child (Node, 3));
+
+ when others =>
+ Not_Translated ("Put_RHS_Element", Node);
+ end case;
+ end Put_RHS_Element;
+
+ procedure Put_RHS_Item_List (Node : in Valid_Node_Index; First : in
Boolean)
+ is
+ Children : constant Valid_Node_Index_Array := Tree.Children (Node);
+ begin
+ if Children'Length = 1 then
+ Put_RHS_Element (Children (1));
+ else
+ if First then
+ Put (File, "seq(");
+ end if;
+ Put_RHS_Item_List (Children (1), First => False);
+ Put (File, ", ");
+ Put_RHS_Element (Children (2));
+
+ if First then
+ Put (File, ")");
+ end if;
+ end if;
+ end Put_RHS_Item_List;
+
+ procedure Put_RHS (Node : in Valid_Node_Index)
+ with Pre => Tree.ID (Node) = +rhs_ID
+ is begin
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ Put (File, "/* empty */,");
+
+ when 1 .. 3 =>
+ Put_RHS_Item_List (Tree.Child (Node, 1), First => True);
+ -- ignore actions
+
+ when others =>
+ Not_Translated ("put_rhs", Node);
+ end case;
+ end Put_RHS;
+
+ procedure Put_RHS_List (Node : in Valid_Node_Index; First : in Boolean)
+ with Pre => Tree.ID (Node) = +rhs_list_ID
+ is
+ Children : constant Valid_Node_Index_Array := Tree.Children (Node);
+ begin
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ Put_RHS (Children (1));
+
+ when 1 =>
+ if First then
+ Put (File, "choice(");
+ end if;
+
+ Put_RHS_List (Children (1), First => False);
+ Put (File, ",");
+ Put_RHS (Children (3));
+
+ if First then
+ Put (File, ")");
+ end if;
+
+ when others =>
+ Not_Translated ("Put_RHS_List", Node);
+ end case;
+ end Put_RHS_List;
+
+ procedure Process_Node (Node : in Valid_Node_Index)
+ is begin
+ case To_Token_Enum (Tree.ID (Node)) is
+ -- Enum_Token_ID alphabetical order
+ when compilation_unit_ID =>
+ Process_Node (Tree.Child (Node, 1));
+
+ when compilation_unit_list_ID =>
+ declare
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
+ begin
+ case To_Token_Enum (Tree.ID (Children (1))) is
+ when compilation_unit_list_ID =>
+ Process_Node (Children (1));
+ Process_Node (Children (2));
+ when compilation_unit_ID =>
+ Process_Node (Children (1));
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+ end;
+
+ when declaration_ID =>
+ case Tree.RHS_Index (Node) is
+ when 0 =>
+ if Tree.ID (Tree.Child (Tree.Child (Node, 2), 1)) =
+Wisitoken_Grammar_Actions.TOKEN_ID then
+ declare
+ use Ada.Strings;
+ use Ada.Strings.Fixed;
+ use WisiToken.Syntax_Trees.LR_Utils;
+ Name : constant String := Get_Text (Tree.Child (Node, 3));
+ Iter : constant Syntax_Trees.LR_Utils.Iterator :=
+ WisiToken_Grammar_Runtime.Iterate (Data, Tree,
Tree.Child (Node, 4), +declaration_item_ID);
+ Item : constant Valid_Node_Index :=
+ Tree.Child (Syntax_Trees.LR_Utils.Node (First (Iter)),
1);
+ begin
+ case To_Token_Enum (Tree.ID (Item)) is
+ when REGEXP_ID =>
+ Put_Line (File, Name & ": $ => /" & Trim (Get_Text
(Item), Both) & "/,");
+
+ when others =>
+ null;
+ end case;
+ end;
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ when nonterminal_ID =>
+ declare
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
+ begin
+ Put (File, Get_Text (Children (1)) & ": $ => ");
+
+ Put_RHS_List (Children (3), First => True);
+
+ Put_Line (File, ",");
+ end;
+
+ when wisitoken_accept_ID =>
+ Process_Node (Tree.Child (Node, 1));
+
+ when others =>
+ raise SAL.Not_Implemented with Image (Tree.ID (Node),
Wisitoken_Grammar_Actions.Descriptor);
+ end case;
+ end Process_Node;
+ begin
+ Create (File, Out_File, Output_File_Name);
+ Put_Line (File, "// generated from " & Data.Grammar_Lexer.File_Name & "
-*- buffer-read-only:t -*-");
+
+ -- FIXME: copy copyright, license?
+
+ Put_Line (File, "module.exports = grammar({");
+ Put_Line (File, " name: '" & Language_Name & "',");
+
+ Put_Line (File, " rules: {");
+
+ Process_Node (Tree.Root);
+
+ Put_Line (File, " }");
+ Put_Line (File, "});");
+ Close (File);
+ end Print_Tree_Sitter;
+
+ Trace : aliased WisiToken.Text_IO_Trace.Trace
(Wisitoken_Grammar_Actions.Descriptor'Access);
+ Input_Data : aliased WisiToken_Grammar_Runtime.User_Data_Type;
+ Grammar_Parser : WisiToken.Parse.LR.Parser_No_Recover.Parser;
+
+ Input_File_Name : Ada.Strings.Unbounded.Unbounded_String;
+ Language_Name : Ada.Strings.Unbounded.Unbounded_String;
+begin
+ Wisitoken_Grammar_Main.Create_Parser
+ (Parser => Grammar_Parser,
+ Trace => Trace'Unchecked_Access,
+ User_Data => Input_Data'Unchecked_Access);
+
+ declare
+ use Ada.Command_Line;
+ Arg : Integer := 1;
+ begin
+ if not (Argument_Count in 1 .. 4) then
+ Put_Usage;
+ Set_Exit_Status (Failure);
+ return;
+ end if;
+
+ loop
+ exit when Arg > Argument_Count;
+
+ if Argument (Arg) = "--verbosity" then
+ Arg := Arg + 1;
+ Trace_Generate_EBNF := Integer'Value (Argument (Arg));
+ Arg := Arg + 1;
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- no more options
+ Input_File_Name := +Argument (Arg);
+ Arg := Arg + 1;
+ Language_Name := +Argument (Arg);
+ end;
+
+ begin
+ Grammar_Parser.Lexer.Reset_With_File (-Input_File_Name);
+ exception
+ when Ada.Text_IO.Name_Error | Ada.Text_IO.Use_Error =>
+ raise Ada.Text_IO.Name_Error with "input file '" & (-Input_File_Name) &
"' could not be opened.";
+ end;
+
+ begin
+ Grammar_Parser.Parse;
+ exception
+ when WisiToken.Syntax_Error =>
+ Grammar_Parser.Put_Errors;
+ raise;
+ end;
+
+ Grammar_Parser.Execute_Actions;
+
+ declare
+ use Ada.Directories;
+
+ Output_File_Name : constant String := Base_Name (-Input_File_Name) &
".js";
+
+ Tree : WisiToken.Syntax_Trees.Tree renames
Grammar_Parser.Parsers.First_State_Ref.Tree;
+ begin
+ if Trace_Generate_EBNF > Outline then
+ Put_Line ("'" & (-Input_File_Name) & "' => '" & Output_File_Name &
"'");
+ end if;
+
+ if Trace_Generate_EBNF > Detail then
+ Put_Line ("wisitoken tree:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor);
+ Ada.Text_IO.New_Line;
+ end if;
+
+ Print_Tree_Sitter (Input_Data, Tree, Output_File_Name, -Language_Name);
+ end;
+
+exception
+when WisiToken.Syntax_Error | WisiToken.Parse_Error =>
+ -- error message already output
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+
+when E : others =>
+ declare
+ use Ada.Exceptions;
+ use Ada.Command_Line;
+ begin
+ Put_Line (Standard_Error, Exception_Name (E) & ": " & Exception_Message
(E));
+ Put_Line (Standard_Error, GNAT.Traceback.Symbolic.Symbolic_Traceback
(E));
+ Set_Exit_Status (Failure);
+ end;
+end WisiToken.To_Tree_Sitter;
diff --git a/wisitoken-user_guide.info b/wisitoken-user_guide.info
index 982869c..7bbdb1b 100644
--- a/wisitoken-user_guide.info
+++ b/wisitoken-user_guide.info
@@ -232,7 +232,7 @@ File: wisitoken-user_guide.info, Node: Raw Code, Next:
Keywords, Up: Declarat
3.1.1 Raw code
--------------
-%code { actions | copyright_license } [spec | body | context | pre | post]...
%{ <output language code> }%
+%code { actions | copyright_license } [spec | body | context | pre | post]...
%{ <output language code> }%
Raw code declarations contain arbitrary code, copied verbatim into
the output. The keywords following '%code' determine where the section
@@ -244,10 +244,10 @@ File: wisitoken-user_guide.info, Node: Keywords, Next:
Tokens, Prev: Raw Code
3.1.2 Keywords
--------------
-%keyword <name> <string>
+%keyword <name> <string>
example:
-%keyword SEMICOLON ";"
+%keyword SEMICOLON ";"
"Keywords" are reserved words or symbols in the target language; the
lexers recognize them by the given string.
@@ -258,11 +258,11 @@ File: wisitoken-user_guide.info, Node: Tokens, Next:
Error recovery, Prev: Ke
3.1.3 Tokens
------------
-%token < kind > name regexp
+%token < kind > name regexp
example:
-%token <symbol> IDENTIFIER %[ ... ]%
-%token <punctuation> TICK "'"
+%token <symbol> IDENTIFIER %[ ... ]%
+%token <punctuation> TICK "'"
The syntax of the regular expression is determined by the lexer
generator. The meaning of 'kind' is determined by the lexer ('re2c'
@@ -270,27 +270,27 @@ ignores this), with the following defined by the
WisiToken generator.
Other token kinds have no effect; they may be used for documentation.
'<string-double>'
- %token <string-double> STRING_LITERAL %[ ... ]%
+ %token <string-double> STRING_LITERAL %[ ... ]%
A string of characters that have string syntax, with double quote
delimiters.
'<string-single>'
- %token <string-single> CHARACTER_LITERAL %[ ... ]%
+ %token <string-single> CHARACTER_LITERAL %[ ... ]%
A string of characters that have string syntax, with single quote
delimiters.
'<new-line>'
- %token <new-line> [\n] %[ ... ]%
+ %token <new-line> [\n] %[ ... ]%
Not used by the wisi lexer; required by the Ada lexer. The third
argument is the regular expression to recognize the entire comment.
'<non-reporting>'
- %token <non-reporting> WHITESPACE %[ [ \t] ]%
+ %token <non-reporting> WHITESPACE %[ [ \t] ]%
A token that is recognized by the lexer, but not returned to the
parser.
'<delimited-text>'
- %token <delimited-text> RAW_CODE "%{" "}%"
+ %token <delimited-text> RAW_CODE "%{" "}%"
A token that contains arbitrary text, delimited by the two strings.
@@ -392,7 +392,7 @@ File: wisitoken-user_guide.info, Node: Other declarations,
Prev: Error recover
Declare a known conflict.
Example conflict declaration:
- %conflict REDUCE/REDUCE in state abstract_limited_opt,
abstract_limited_synchronized_opt on token NEW
+ %conflict REDUCE/REDUCE in state abstract_limited_opt,
abstract_limited_synchronized_opt on token NEW
The conflict description is output by 'wisitoken-bnf-generate' when
an undeclared conflict is detected. If the user decides to not fix
@@ -430,10 +430,10 @@ File: wisitoken-user_guide.info, Node: Other
declarations, Prev: Error recover
In the Ada language, block names can be repeated at the end; for
example:
- Get_Inputs :
- loop
- ...
- end loop Get_Inputs;
+ Get_Inputs :
+ loop
+ ...
+ end loop Get_Inputs;
These names are optional in the Ada standard. Making them required
improves error recovery; the recovery algorithm can use matching
@@ -507,18 +507,64 @@ production rules and actions.
The syntax of a nonterminal statement is:
-{nonterminal} : {token} ... [ %( post-parse action )% [ %( in-parse action )%
]] [| {token} ... [ %(
-action code )% ] ... ;
-
- Each nonterminal gives the expansion of a nonterminal token into a
-list of tokens (both terminal and nonterminal); optional productions are
-separated by "|". Each list of tokens is followed by zero to two
-actions, one executed after the parse is complete, one during the parse
-when the production is reduced. in-parse actions can add semantic
-checks that help during error recovery. post-parse actions typically
-build an abstract syntax tree. The actions are written in
-output-language code; for 'Ada_Emacs' output, this is elisp (a hold-over
-from when WisiToken only output elisp code).
+nonterminal : rhs {| rhs} ;
+ A nonterminal is defined by a list of alternate right hand sides.
+
+rhs : {rhs_item} [action [action]] ;
+ Each right hand side is a list of items, followed by zero to two
+actions; the first is the post-parse action, the second the in-parse
+action.
+
+ In-parse actions are exeuted during the parse, when the production is
+reduced; they can add semantic checks that help during error recovery.
+
+ Post-parse actions are executed after the parse is complete, when a
+node produced by this production is visited during the tree traversal;
+they typically build an abstract syntax tree.
+
+ The actions are written in output-language code; for 'Ada_Emacs'
+output, this is elisp (a hold-over from when WisiToken only output elisp
+code).
+
+ If using BNF:
+rhs_item : token ;
+ Where 'token' is defined by a token declaration.
+
+ if using EBNF:
+rhs_item
+ : token
+ | < identifier = identifier >
+ | rhs_optional_item
+ | rhs_multiple_item
+ | '(' rhs {| rhs} ')'
+ ;
+ Here 'token' is either defined by a token declaration, or the token
+value contained in single quotes.
+
+ The second option is an attribute, as defined by ANTLR; these are
+ignored in wisitoken.
+
+ Parentheses are used to group items.
+
+rhs_optional_item
+ : '[' rhs {| rhs} ']'
+ | '(' rhs {| rhs} ')' '?'
+ | token '?'
+ ;
+ These options all mean the same thing; the content is present zero or
+one times.
+
+rhs_multiple_item
+ : '{' rhs {| rhs} '}'
+ | '{' rhs {| rhs} '}-'
+ | '(' rhs {| rhs} ')+'
+ | '(' rhs {| rhs} ')*'
+ | token '+'
+ | token '*'
+ ;
+ "{}", "()*", and "token*" mean the content is present zero or more
+times. "{}-", "()+", and "token+" mean the content is present one or
+more times.
File: wisitoken-user_guide.info, Node: Conditional code, Prev: Nonterminals,
Up: Grammar File Syntax
@@ -530,9 +576,9 @@ It is sometimes necessary to include or exclude some
declarations and
portions of rules based on the choice of lexer or parser.
Therefore WisiToken supports '%if ... %end if' in the grammar file:
-%if {lexer | parser} = {<lexer> | <generate_algorithm>}
-...
-%end if
+%if {lexer | parser} = {<lexer> | <generate_algorithm>}
+...
+%end if
The lines between '%if' and '%end if' are ignored if the current
lexer or parser is not the one specified in the '%if' condition.
@@ -550,12 +596,12 @@ Node: Empty choice in list2930
Node: Grammar File Syntax5912
Node: Declarations6469
Node: Raw Code6775
-Node: Keywords7157
-Node: Tokens7471
-Node: Error recovery8814
-Node: Other declarations12536
-Node: Nonterminals17033
-Node: Conditional code18069
+Node: Keywords7156
+Node: Tokens7468
+Node: Error recovery8803
+Node: Other declarations12525
+Node: Nonterminals17017
+Node: Conditional code19038
End Tag Table
diff --git a/wisitoken.ads b/wisitoken.ads
index 0230d55..2c7a11b 100644
--- a/wisitoken.ads
+++ b/wisitoken.ads
@@ -44,10 +44,12 @@ with Ada.Containers;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
+with SAL.Generic_Decimal_Image;
with SAL.Gen_Trimmed_Image;
with SAL.Gen_Unbounded_Definite_Queues;
with SAL.Gen_Unbounded_Definite_Vectors.Gen_Image;
with SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux;
+with SAL.Gen_Unconstrained_Array_Image;
package WisiToken is
Partial_Parse : exception; -- a partial parse terminated.
@@ -293,18 +295,29 @@ package WisiToken is
-- Syntax tree nodes.
type Node_Index is range 0 .. Integer'Last;
subtype Valid_Node_Index is Node_Index range 1 .. Node_Index'Last;
+ -- Note that Valid_Node_Index includes Deleted_Child.
Invalid_Node_Index : constant Node_Index := Node_Index'First;
+ Deleted_Child : constant Node_Index := Node_Index'Last;
type Valid_Node_Index_Array is array (Positive_Index_Type range <>) of
Valid_Node_Index;
-- Index matches Base_Token_Array, Augmented_Token_Array
+ function Image is new SAL.Generic_Decimal_Image (Valid_Node_Index);
+ -- Has Width parameter
+
+ function Image (Item : in Valid_Node_Index) return String
+ is (Image (Item, 4));
+
+ function Image is new SAL.Gen_Unconstrained_Array_Image
+ (Positive_Index_Type, Valid_Node_Index, Valid_Node_Index_Array, Image);
+
package Valid_Node_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive_Index_Type, Valid_Node_Index, Default_Element =>
Valid_Node_Index'First);
+ (Positive_Index_Type, Valid_Node_Index, Default_Element =>
Valid_Node_Index'Last);
-- Index matches Valid_Node_Index_Array.
type Base_Token is tagged record
- -- Base_Token is used in the core parser. The parser only needs ID and
Tree_Node;
+ -- Base_Token is used in the core parser. The parser only needs ID and
Tree_Index;
-- semantic checks need Byte_Region to compare names. Line, Col, and
-- Char_Region are included for error messages.
@@ -353,6 +366,7 @@ package WisiToken is
package Base_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(Token_Index, Base_Token, Default_Element => (others => <>));
type Base_Token_Array_Access is access all Base_Token_Arrays.Vector;
+ type Base_Token_Array_Access_Constant is access constant
Base_Token_Arrays.Vector;
function Image is new Base_Token_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Trimmed_Image, Image);
@@ -409,6 +423,8 @@ package WisiToken is
Invalid_Identifier_Index : constant Base_Identifier_Index :=
Base_Identifier_Index'First;
+ function Trimmed_Image is new SAL.Gen_Trimmed_Image (Base_Identifier_Index);
+
----------
-- Trace, debug
@@ -438,6 +454,9 @@ package WisiToken is
Trace_Generate_Minimal_Complete : Integer := 0;
-- Output during grammar generation.
+ Trace_Time : Boolean := False;
+ -- Output execution time for various things.
+
Debug_Mode : Boolean := False;
-- If True, Output stack traces, propagate exceptions to top level.
-- Otherwise, be robust to errors, so user does not notice them.
diff --git a/wisitoken_grammar_runtime.adb b/wisitoken_grammar_runtime.adb
index 42d61fe..e40c147 100644
--- a/wisitoken_grammar_runtime.adb
+++ b/wisitoken_grammar_runtime.adb
@@ -23,9 +23,7 @@ with Ada.Strings.Unbounded;
with Ada.Text_IO;
with GNAT.Regexp;
with SAL.Generic_Decimal_Image;
-with System.Assertions;
with WisiToken.Generate; use WisiToken.Generate;
-with WisiToken.Syntax_Trees.LR_Utils;
package body WisiToken_Grammar_Runtime is
use WisiToken;
@@ -34,23 +32,6 @@ package body WisiToken_Grammar_Runtime is
----------
-- Body subprograms, misc order
- procedure Raise_Programmer_Error
- (Label : in String;
- Data : in User_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Node : in WisiToken.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.Node_Index)
- is begin
- 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
(Data : in User_Data_Type;
Tree : in Syntax_Trees.Tree;
@@ -182,12 +163,11 @@ package body WisiToken_Grammar_Runtime is
Labels : in out WisiToken.BNF.String_Arrays.Vector;
Token : in Valid_Node_Index)
return WisiToken.BNF.RHS_Type
+ with Pre => Tree.ID (Token) = +rhs_ID
is
use all type SAL.Base_Peek_Type;
Children : constant Valid_Node_Index_Array := Tree.Children (Token);
begin
- pragma Assert (-Tree.ID (Token) = rhs_ID);
-
return RHS : WisiToken.BNF.RHS_Type do
RHS.Source_Line := Get_Line (Data, Tree, Token);
@@ -253,11 +233,10 @@ package body WisiToken_Grammar_Runtime is
Right_Hand_Sides : in out WisiToken.BNF.RHS_Lists.List;
Labels : in out WisiToken.BNF.String_Arrays.Vector;
Token : in WisiToken.Valid_Node_Index)
+ with Pre => Tree.ID (Token) = +rhs_list_ID
is
Tokens : constant Valid_Node_Index_Array := Tree.Children (Token);
begin
- pragma Assert (-Tree.ID (Token) = rhs_list_ID);
-
case Tree.RHS_Index (Token) is
when 0 =>
-- | rhs
@@ -295,7 +274,7 @@ package body WisiToken_Grammar_Runtime is
procedure Set_Lexer_Terminals
(User_Data : in out User_Data_Type;
Lexer : in WisiToken.Lexer.Handle;
- Terminals : in Base_Token_Array_Access)
+ Terminals : in Base_Token_Array_Access_Constant)
is begin
User_Data.Grammar_Lexer := Lexer;
User_Data.Terminals := Terminals;
@@ -417,7 +396,7 @@ package body WisiToken_Grammar_Runtime is
end Token;
function Enum_ID (Index : in SAL.Peek_Type) return Token_Enum_ID
- is (To_Token_Enum (Token (Index).ID));
+ is (To_Token_Enum (Token (Index).ID));
begin
if Data.Phase = Meta then
@@ -555,6 +534,7 @@ package body WisiToken_Grammar_Runtime is
-- children = identifier_list IDENTIFIER_ID
-- children = IDENTIFIER_ID
function Get_Loc_List return Base_Token_Array
+ with Pre => Tree.ID (Tokens (3)) = +identifier_list_ID
is
use all type SAL.Base_Peek_Type;
use WisiToken.Syntax_Trees;
@@ -563,7 +543,7 @@ package body WisiToken_Grammar_Runtime is
First : SAL.Peek_Type := Result'Last + 1;
begin
loop
- pragma Assert (-Tree.ID (Node) = identifier_list_ID);
+ pragma Assert (Tree.ID (Node) = +identifier_list_ID);
exit when not Tree.Has_Children (Node);
declare
Children : constant Valid_Node_Index_Array :=
Tree.Children (Node);
@@ -603,7 +583,7 @@ package body WisiToken_Grammar_Runtime is
else raise Grammar_Error with
Error_Message
(Data.Grammar_Lexer.File_Name, Loc_List (2).Line,
- "expecting {context | pre | post}"))
+ "expecting {context | pre | post}"))
elsif Get_Loc (2) = "body" then
(if Get_Loc (3) = "context" then
WisiToken.BNF.Actions_Body_Context
@@ -612,7 +592,7 @@ package body WisiToken_Grammar_Runtime is
else raise Grammar_Error with
Error_Message
(Data.Grammar_Lexer.File_Name, Loc_List (2).Line,
- "expecting {context | pre | post}"))
+ "expecting {context | pre | post}"))
else raise Grammar_Error);
@@ -857,6 +837,13 @@ package body WisiToken_Grammar_Runtime is
end if;
end Add_Nonterminal;
+ function Image_Grammar_Action (Action : in
WisiToken.Syntax_Trees.Semantic_Action) return String
+ is
+ pragma Unreferenced (Action);
+ begin
+ return "action";
+ end Image_Grammar_Action;
+
procedure Check_EBNF
(User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
Tree : in WisiToken.Syntax_Trees.Tree;
@@ -883,10 +870,69 @@ package body WisiToken_Grammar_Runtime is
end case;
end Check_EBNF;
+ procedure Raise_Programmer_Error
+ (Label : in String;
+ Data : in User_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Node : in WisiToken.Node_Index)
+ is begin
+ 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 Find_Declaration
+ (Data : in User_Data_Type;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Name : in String)
+ return WisiToken.Node_Index
+ is
+ use WisiToken.Syntax_Trees.LR_Utils;
+ use WisiToken.Syntax_Trees.LR_Utils.Creators;
+
+ function Decl_Name (Decl : in Valid_Node_Index) return String
+ is begin
+ case To_Token_Enum (Tree.ID (Decl)) is
+ when declaration_ID =>
+ case Tree.RHS_Index (Decl) is
+ when 0 =>
+ return Get_Text (Data, Tree, Tree.Child (Decl, 3));
+
+ when 2 | 3 =>
+ return Get_Text (Data, Tree, Tree.Child (Decl, 2));
+
+ when others =>
+ return "";
+ end case;
+
+ when nonterminal_ID =>
+ return Get_Text (Data, Tree, Tree.Child (Decl, 1));
+
+ when others =>
+ return "";
+ end case;
+ end Decl_Name;
+
+ -- Tree.Root is wisitoken_accept
+ List : constant Constant_List := Create_List
+ (Tree, Tree.Child (Tree.Root, 1), +compilation_unit_list_ID,
+compilation_unit_ID);
+ begin
+ for N of List loop
+ declare
+ Decl : constant Valid_Node_Index := Tree.Child (N, 1);
+ begin
+ if Name = Decl_Name (Decl) then
+ return Decl;
+ end if;
+ end;
+ end loop;
+ return Invalid_Node_Index;
+ end Find_Declaration;
+
procedure Translate_EBNF_To_BNF
(Tree : in out WisiToken.Syntax_Trees.Tree;
Data : in out User_Data_Type)
is
+ use all type SAL.Base_Peek_Type;
use WisiToken.Syntax_Trees;
Copied_EBNF_Nodes : WisiToken.Valid_Node_Index_Arrays.Vector;
@@ -897,11 +943,43 @@ package body WisiToken_Grammar_Runtime is
else "[a-zA-Z0-9_]+"),
Case_Sensitive => not Data.Language_Params.Case_Insensitive);
+ procedure Erase_Copied_EBNF_Node (Node : in Valid_Node_Index)
+ is
+ use Ada.Text_IO;
+ Found : Boolean := False;
+ begin
+ if Trace_Generate_EBNF > Outline then
+ Put_Line ("erase copied deleted EBNF node" & Node'Image);
+ end if;
+ -- Vector Delete replaces content with
+ -- Valid_Node_Index_Arrays.Default_Element = Valid_Node_Index'Last =
+ -- Deleted_Child; this is clearer.
+
+ for I in Copied_EBNF_Nodes.First_Index ..
Copied_EBNF_Nodes.Last_Index loop
+ if Copied_EBNF_Nodes (I) = Node then
+ Copied_EBNF_Nodes (I) := Deleted_Child;
+ Found := True;
+ exit;
+ end if;
+ end loop;
+ if not Found then
+ Put_Line (Current_Error, Tree.Image
+ (Node, Wisitoken_Grammar_Actions.Descriptor,
Node_Numbers => True) &
+ " not found in Copied_EBNF_Nodes");
+ raise SAL.Programmer_Error;
+ end if;
+ end Erase_Copied_EBNF_Node;
+
procedure Clear_EBNF_Node (Node : in Valid_Node_Index)
is begin
if Node in Data.EBNF_Nodes.First_Index .. Data.EBNF_Nodes.Last_Index
then
+ if Trace_Generate_EBNF > Outline then
+ Ada.Text_IO.Put_Line ("clear translated EBNF node" &
Node'Image);
+ end if;
+
Data.EBNF_Nodes (Node) := False;
- -- else in Copied_EBNF_Nodes; don't need to delete from there.
+ else
+ Erase_Copied_EBNF_Node (Node);
end if;
end Clear_EBNF_Node;
@@ -932,6 +1010,19 @@ package body WisiToken_Grammar_Runtime is
return ID;
end Next_Nonterm_Name;
+ function Find_Nonterminal
+ (Target : in String;
+ Equal : in WisiToken.Syntax_Trees.LR_Utils.Find_Equal)
+ return Node_Index
+ is
+ use WisiToken.Syntax_Trees.LR_Utils;
+ begin
+ return Get_Node
+ (Creators.Create_List
+ (Tree, Tree.Child (Tree.Root, 1), +compilation_unit_list_ID,
+compilation_unit_ID).Find
+ (Target, Equal));
+ end Find_Nonterminal;
+
function Tree_Add_Nonterminal
(Child_1 : in Valid_Node_Index;
Child_2 : in Valid_Node_Index;
@@ -948,410 +1039,438 @@ package body WisiToken_Grammar_Runtime is
Action => Wisitoken_Grammar_Actions.nonterminal_0'Access);
end Tree_Add_Nonterminal;
- function List_Root (Item : in Valid_Node_Index) return Valid_Node_Index
+ function Duplicate
+ (List : in Syntax_Trees.LR_Utils.List;
+ New_Content : in Node_Index)
+ return Boolean
is
- List_ID : constant WisiToken.Token_ID := Tree.ID (Item);
- Node : Valid_Node_Index := Item;
+ -- We don't require New_Content.ID = List.Element_ID; since we are
+ -- comparing result of Get_Text.
+ New_Content_Str : constant String :=
+ (if New_Content = Invalid_Node_Index
+ then "" -- Empty RHS
+ else Get_Text (Data, Tree, New_Content));
begin
- loop
- exit when Tree.ID (Tree.Parent (Node)) /= List_ID;
- Node := Tree.Parent (Node);
+ for N of List loop
+ if New_Content_Str = Get_Text (Data, Tree, N) then
+ return True;
+ end if;
end loop;
- return Node;
- end List_Root;
-
- function List_Singleton (Root : in Valid_Node_Index) return Boolean
+ return False;
+ end Duplicate;
+
+ procedure Insert_Empty_RHS
+ (RHS_List : in out WisiToken.Syntax_Trees.LR_Utils.List;
+ After : in Valid_Node_Index)
+ with Pre => RHS_List.List_ID = +rhs_list_ID and RHS_List.Element_ID =
+rhs_ID and
+ Tree.ID (After) = +rhs_ID and RHS_List.Contains (After)
is begin
- return Tree.RHS_Index (Root) = 0;
- end List_Singleton;
-
- function First_List_Element (Root : in Valid_Node_Index; Element_ID : in
WisiToken.Token_ID) return Node_Index
+ RHS_List.Insert
+ (New_Element => Tree.Add_Nonterm
+ ((+rhs_ID, 0),
+ (1 .. 0 => Invalid_Node_Index)),
+ After => RHS_List.To_Cursor (After));
+ end Insert_Empty_RHS;
+
+ procedure Insert_RHS
+ (RHS_List : in out WisiToken.Syntax_Trees.LR_Utils.List;
+ New_RHS_Item_List : in Valid_Node_Index;
+ After : in Valid_Node_Index)
+ with Pre => RHS_List.List_ID = +rhs_list_ID and RHS_List.Element_ID =
+rhs_ID and
+ Tree.ID (New_RHS_Item_List) = +rhs_item_list_ID and
+ Tree.ID (After) = +rhs_ID and RHS_List.Contains (After)
+ is begin
+ RHS_List.Insert
+ (New_Element => Tree.Add_Nonterm
+ (Production => (+rhs_ID, Tree.RHS_Index (After)),
+ Children =>
+ (case Tree.RHS_Index (After) is
+ when 1 => (1 => New_RHS_Item_List),
+ when 2 => (New_RHS_Item_List, Tree.Copy_Subtree (Tree.Child
(After, 2))),
+ when 3 => (New_RHS_Item_List,
+ Tree.Copy_Subtree (Tree.Child (After, 2)),
+ Tree.Copy_Subtree (Tree.Child (After, 3))),
+ when others => raise SAL.Programmer_Error)),
+ After => RHS_List.To_Cursor (After));
+ end Insert_RHS;
+
+ procedure Record_Copied_EBNF_Nodes (Node : in Valid_Node_Index)
is
- List_ID : constant WisiToken.Token_ID := Tree.ID (Root);
-
- -- Return the first child with Element_ID in list of List_IDs. This
- -- is not the same as Find_Descendant, because we check the children
- -- first, and only the first child.
- Node : Node_Index := Root;
- begin
- loop
- declare
- Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
- begin
- if Tree.ID (Children (1)) = List_ID then
- Node := Children (1);
- elsif Tree.ID (Children (1)) = Element_ID then
- Node := Children (1);
- exit;
- else
- Raise_Programmer_Error ("first_list_element", Data, Tree,
Node);
+ procedure Record_Copied_Node
+ (Tree : in out WisiToken.Syntax_Trees.Tree;
+ Node : in WisiToken.Valid_Node_Index)
+ is begin
+ if To_Token_Enum (Tree.ID (Node)) in
+ rhs_optional_item_ID |
+ rhs_multiple_item_ID |
+ rhs_group_item_ID |
+ rhs_attribute_ID |
+ STRING_LITERAL_2_ID
+ then
+ if Trace_Generate_EBNF > Outline then
+ Ada.Text_IO.Put_Line
+ ("new EBNF node " & Tree.Image
+ (Node, Wisitoken_Grammar_Actions.Descriptor,
+ Node_Numbers => True));
end if;
- end;
- end loop;
- return Node;
- end First_List_Element;
+ Copied_EBNF_Nodes.Append (Node);
+ end if;
+ end Record_Copied_Node;
+ begin
+ Tree.Process_Tree (Record_Copied_Node'Access, Node);
+ end Record_Copied_EBNF_Nodes;
- function Last_List_Element (Root : in Valid_Node_Index) return Node_Index
+ procedure Erase_Deleted_EBNF_Nodes (Node : in Valid_Node_Index)
is
- -- Tree is one of:
- --
- -- case a: single element list
- -- element_list : root
- -- | element: Last
- --
- -- case c: no next
- -- element_list: root
- -- | element_list
- -- | | element:
- -- | element: Last
- Children : constant Valid_Node_Index_Array := Tree.Children (Root);
+ procedure Erase_Deleted_Node
+ (Tree : in out WisiToken.Syntax_Trees.Tree;
+ Node : in WisiToken.Valid_Node_Index)
+ is begin
+ if To_Token_Enum (Tree.ID (Node)) in
+ rhs_optional_item_ID |
+ rhs_multiple_item_ID |
+ rhs_group_item_ID |
+ rhs_attribute_ID |
+ STRING_LITERAL_2_ID
+ then
+ if Node in Data.EBNF_Nodes.First_Index ..
Data.EBNF_Nodes.Last_Index then
+ -- Node is original, not copied
+ if Trace_Generate_EBNF > Outline then
+ Ada.Text_IO.Put_Line ("erase original deleted EBNF node"
& Node'Image);
+ end if;
+ Data.EBNF_Nodes (Node) := False;
+ else
+ Erase_Copied_EBNF_Node (Node);
+ end if;
+ end if;
+ end Erase_Deleted_Node;
begin
- return Children (Children'Last);
- end Last_List_Element;
+ Tree.Process_Tree (Erase_Deleted_Node'Access, Node);
+ end Erase_Deleted_EBNF_Nodes;
- function Next_List_Element
- (Element : in Valid_Node_Index;
- List_ID : in WisiToken.Token_ID)
- return Node_Index
- with Pre => Tree.Parent (Element, 2) /= Invalid_Node_Index and then
- Tree.ID (Tree.Parent (Element)) = List_ID
+ function Insert_Optional_RHS (B : in Valid_Node_Index) return
Valid_Node_Index
+ with Pre => Tree.ID (B) in +rhs_multiple_item_ID | +rhs_optional_item_ID
| +IDENTIFIER_ID
is
- use all type SAL.Base_Peek_Type;
- -- Tree is one of:
+ -- B is an optional item in an rhs_item_list:
+ -- | A B? C
--
- -- case a: first element, no next
- -- rhs
- -- | rhs_item_list
- -- | | rhs_item: Element
- -- | action
+ -- or B is a rhs_multiple_item that is allowed to be empty:
+ -- | A B* C
--
- -- case b: first element, next
- -- rhs_item_list
- -- | rhs_item_list
- -- | | rhs_item: Element
- -- | rhs_item: next element
+ -- or B is a virtual identifier naming the new nonterm replacing the
+ -- original
--
- -- case c: non-first element, no next
- -- rhs
- -- | rhs_item_list
- -- | | rhs_item_list
- -- | | | rhs_item:
- -- | | rhs_item: Element
- -- | action
+ -- A, C can be empty. The containing element may be rhs or
+ -- rhs_alternative_list.
--
- -- case d: non-first element, next
- -- rhs_item_list
- -- | rhs_item_list
- -- | | rhs_item_list
- -- | | | rhs_item:
- -- | | rhs_item: Element
- -- | rhs_item: next element
-
- Element_ID : constant WisiToken.Token_ID := Tree.ID
(Element);
- Grand_Parent : constant Valid_Node_Index := Tree.Parent
(Element, 2);
- Aunts : constant Valid_Node_Index_Array := Tree.Children
(Grand_Parent);
- Last_List_Child : SAL.Base_Peek_Type := Aunts'First - 1;
- begin
- if Tree.ID (Grand_Parent) /= List_ID then
- -- No next
- return Invalid_Node_Index;
- end if;
+ -- Insert either a second rhs, or a second rhs_item_list, after the
+ -- one containing B, without B.
+ --
+ -- Return the List_Root of the edited list.
- -- Children may be non-list items; ACTION in an rhs_list, for
example.
- for I in Aunts'Range loop
- if Tree.ID (Aunts (I)) in List_ID | Element_ID then
- Last_List_Child := I;
- end if;
- end loop;
+ use Syntax_Trees.LR_Utils;
+ use Syntax_Trees.LR_Utils.Creators;
+ use all type Ada.Containers.Count_Type;
- if Last_List_Child = 1 then
- -- No next
- return Invalid_Node_Index;
- else
- return Aunts (2);
- end if;
- end Next_List_Element;
+ function Find_Skips return Skip_Info
+ is
+ Non_Empty_List : Node_Index := Invalid_Node_Index;
+ -- First (nearest) rhs_item_list ancestor of B that will not be
empty
+ -- when B is skipped.
+
+ Skip_Last : Positive_Index_Type'Base :=
Positive_Index_Type'First;
+ Last_Skip_Node : Valid_Node_Index := Tree.Find_Ancestor
(B, +rhs_element_ID);
+ Reset_Search_For : WisiToken.Token_ID := +rhs_item_list_ID;
+
+ procedure Search (Result : in out Skip_Info)
+ is
+ Skip_Node : Valid_Node_Index := Last_Skip_Node;
+ Search_For : WisiToken.Token_ID := Reset_Search_For;
+ begin
+ loop
+ case To_Token_Enum (Search_For) is
+ when rhs_item_list_ID =>
+ Skip_Node := Tree.Find_Ancestor (Skip_Node,
+rhs_item_list_ID);
- function Prev_List_Element
- (Element : in Valid_Node_Index;
- List_ID : in WisiToken.Token_ID)
- return Node_Index
- with Pre => Tree.Parent (Element) /= Invalid_Node_Index and then
- Tree.ID (Tree.Parent (Element)) = List_ID
- is
- -- Tree is one of:
- --
- -- case a: first element, no prev
- -- ?
- -- | rhs_item_list
- -- | | rhs_item: Element
- --
- -- case b: second element
- -- ?
- -- | rhs_item_list
- -- | | rhs_item: prev item
- -- | rhs_item: Element
- --
- -- case c: nth element
- -- ?
- -- | rhs_item_list
- -- | | rhs_item_list
- -- | | | rhs_item:
- -- | | rhs_item: prev element
- -- | rhs_item: Element
+ Skip_Node := List_Root (Tree, Skip_Node,
+rhs_item_list_ID);
- Parent : constant Valid_Node_Index := Tree.Parent (Element);
- begin
- if Element = Tree.Child (Parent, 1) then
- -- No prev
- return Invalid_Node_Index;
+ Search_For := +rhs_element_ID;
+
+ if Result.Skips'Length = 0 then
+ declare
+ List_Count : constant Ada.Containers.Count_Type :=
Create_List
+ (Tree, Skip_Node, +rhs_item_list_ID,
+rhs_element_ID).Count;
+ begin
+ if List_Count > 1 then
+ Non_Empty_List := List_Root (Tree, Skip_Node,
+rhs_item_list_ID);
+ exit;
+
+ elsif Skip_Last = Positive_Index_Type'First and
List_Count = 1 then
+ -- This list will be empty; no need to descend
into it
+ Last_Skip_Node := Skip_Node;
+ Reset_Search_For := Search_For;
+ else
+ Skip_Last := Skip_Last + 1;
+ end if;
+ end;
+ else
+ Result.Skips (Skip_Last) :=
+ (Label => Nested,
+ Element => Skip_Node,
+ List_Root => Skip_Node,
+ List_ID => +rhs_item_list_ID,
+ Element_ID => +rhs_element_ID,
+ Separator_ID => Invalid_Token_ID,
+ Multi_Element_RHS => 1);
+
+ Skip_Last := Skip_Last - 1;
+ end if;
+
+ when rhs_element_ID =>
+ declare
+ List_Node : Valid_Node_Index := Tree.Find_Ancestor
+ (Skip_Node, (+rhs_ID, +rhs_alternative_list_ID));
+ begin
+
+ if Result.Skips'Length = 0 and then
+ Tree.ID (List_Node) = +rhs_ID
+ then
+ Non_Empty_List := List_Root (Tree, Skip_Node,
+rhs_item_list_ID);
+ Skip_Last := Skip_Last - 1;
+ exit;
+ end if;
+
+ List_Node := List_Root (Tree, List_Node,
+rhs_alternative_list_ID);
+ Skip_Node := Tree.Find_Ancestor (Skip_Node,
+rhs_element_ID);
+
+ Search_For := +rhs_item_list_ID;
+
+ if Result.Skips'Length = 0 then
+ if Skip_Last = Positive_Index_Type'First then
+ -- This list will be empty; no need to descend
into it
+ Last_Skip_Node := Skip_Node;
+ Reset_Search_For := Search_For;
+ else
+ Skip_Last := Skip_Last + 1;
+ end if;
+ else
+ Result.Skips (Skip_Last) :=
+ (Label => Nested,
+ Element => Skip_Node,
+ List_Root => List_Node,
+ List_ID => +rhs_alternative_list_ID,
+ Element_ID => +rhs_item_list_ID,
+ Separator_ID => +BAR_ID,
+ Multi_Element_RHS => 1);
+
+ Skip_Last := Skip_Last - 1;
+ end if;
+ end;
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+
+ end loop;
+ end Search;
+
+ Result_1 : Skip_Info (Skip_Last => Positive_Index_Type'First - 1);
+ begin
+ -- First count the number of Skip_Items we need, and set
+ -- Non_Empty_List.
+ Search (Result_1);
- else
declare
- Prev_Children : constant Valid_Node_Index_Array :=
Tree.Children (Tree.Child (Parent, 1));
+ Result : Skip_Info (Skip_Last);
begin
- return Prev_Children (Prev_Children'Last);
- end;
- end if;
- end Prev_List_Element;
+ if Result.Skips'Length = 0 then
+ return Result;
+ end if;
- procedure Append_Element
- (Tail_List : in Valid_Node_Index;
- New_Element : in Valid_Node_Index;
- Separator_ID : in WisiToken.Token_ID := Invalid_Token_ID)
- is
- -- Tail_List is preserved.
+ Result.Start_List_Root := Non_Empty_List;
+ Result.Start_List_ID := +rhs_item_list_ID;
+ Result.Start_Element_ID := +rhs_element_ID;
- -- Current tree is one of:
- --
- -- case a:
- -- rhs_list: Tail_List
- -- | rhs: Orig_Element_1
- --
- -- case b:
- -- rhs_list: Tail_List
- -- | rhs_list: Orig_List_1
- -- | | rhs: Orig_Element_1
- -- | BAR
- -- | rhs: Orig_Element_2
-
- -- New tree:
- --
- -- case a:
- -- rhs_list: keep Tail_List
- -- | rhs_list: new
- -- | | rhs: keep; Orig_Element_1
- -- | BAR
- -- | rhs: New_Element
- --
- -- case b:
- -- rhs_list: keep Tail_List
- -- | rhs_list: new;
- -- | | rhs_list: keep Orig_List_1
- -- | | | rhs: keep Orig_Element_1
- -- | | BAR: keep
- -- | | rhs: keep Orig_Element_2
- -- | BAR: new
- -- | rhs: New_Element
-
- List_ID : constant WisiToken.Token_ID := Tree.ID
(Tail_List);
- Children : constant Valid_Node_Index_Array := Tree.Children
(Tail_List);
- New_List_Item : constant Valid_Node_Index := Tree.Add_Nonterm
- ((List_ID, (if Children'Length = 1 then 0 else 1)), Children);
- begin
- if Separator_ID = Invalid_Token_ID then
- Tree.Set_Children (Tail_List, (List_ID, 1), (New_List_Item,
New_Element));
- else
- Tree.Set_Children
- (Tail_List, (List_ID, 1), (New_List_Item, Tree.Add_Terminal
(Separator_ID), New_Element));
- end if;
- end Append_Element;
+ Result.Start_Separator_ID := Invalid_Token_ID;
+ Result.Start_Multi_Element_RHS := 1;
- 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.
- --
- -- where a, c can be empty. Insert a second rhs_item_list without B.
- --
- -- The containing elment may be rhs or rhs_alternative_list
-
- Container : constant Valid_Node_Index :=
Tree.Find_Ancestor
- (B, (+rhs_ID, +rhs_alternative_list_ID));
- Orig_RHS_Element_C_Head : constant Node_Index :=
Next_List_Element
- (Tree.Parent (B, 2), +rhs_item_list_ID);
- Orig_RHS_Item_List_C_Root : constant Valid_Node_Index := List_Root
(Tree.Parent (B, 3));
- Orig_RHS_Item_List_A_Root : constant Valid_Node_Index := Tree.Child
(Tree.Parent (B, 3), 1);
- Orig_RHS_Element_A_Head : constant Node_Index :=
- (if Orig_RHS_Item_List_A_Root = Tree.Parent (B, 2)
- then Invalid_Node_Index -- a is empty
- else First_List_Element (Orig_RHS_Item_List_A_Root,
+rhs_element_ID));
- Container_List : constant Valid_Node_Index :=
- (if Tree.ID (Container) = +rhs_ID then Tree.Parent (Container) else
Container);
- New_RHS_Item_List_A : Node_Index :=
Invalid_Node_Index;
- New_RHS_Item_List_C : Node_Index :=
Invalid_Node_Index;
- New_RHS_AC : Valid_Node_Index;
-
- function Add_Actions (RHS_Item_List : Valid_Node_Index) return
Valid_Node_Index
- with Pre => Tree.ID (Container) = +rhs_ID
- is
- Orig_RHS_Children : constant Valid_Node_Index_Array :=
Tree.Children (Container);
- begin
- case Tree.RHS_Index (Container) is
- when 1 =>
- return Tree.Add_Nonterm ((+rhs_ID, 1), (1 => RHS_Item_List));
-
- when 2 =>
- return Tree.Add_Nonterm
- ((+rhs_ID, 2),
- (1 => RHS_Item_List,
- 2 => Tree.Add_Terminal
- (Tree.First_Shared_Terminal (Orig_RHS_Children (2)),
- Data.Terminals.all)));
-
- when 3 =>
- return Tree.Add_Nonterm
- ((+rhs_ID, 3),
- (1 => RHS_Item_List,
- 2 => Tree.Add_Terminal
- (Tree.First_Shared_Terminal (Orig_RHS_Children (2)),
- Data.Terminals.all),
- 3 => Tree.Add_Terminal
- (Tree.First_Shared_Terminal (Orig_RHS_Children (3)),
- Data.Terminals.all)));
+ Result.Skips (Skip_Last) := (Skip, Last_Skip_Node);
- when others =>
- Raise_Programmer_Error
- ("translate_ebnf_to_bnf insert_optional_rhs unimplemented
RHS", Data, Tree, Container);
- end case;
- end Add_Actions;
- begin
- if Orig_RHS_Element_A_Head /= Invalid_Node_Index then
- -- a is not empty
- New_RHS_Item_List_A := Tree.Copy_Subtree
- (Last => Orig_RHS_Element_A_Head,
- Root => Orig_RHS_Item_List_A_Root);
+ if Result.Skips'Length = 1 then
+ return Result;
+ end if;
- if Trace_Generate_EBNF > Extra then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("new a:");
- Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
New_RHS_Item_List_A);
- end if;
+ Search (Result);
+ return Result;
+ end;
+ end Find_Skips;
+
+ Container : Valid_Node_Index := Tree.Find_Ancestor (B, (+rhs_ID,
+rhs_alternative_list_ID));
+ Container_ID : WisiToken.Token_ID := Tree.ID (Container);
+
+ Container_List : Syntax_Trees.LR_Utils.List :=
+ (if Container_ID = +rhs_ID
+ then Create_From_Element
+ (Tree,
+ Element => Container,
+ List_ID => +rhs_list_ID,
+ Element_ID => +rhs_ID,
+ Separator_ID => +BAR_ID)
+ else Create_List
+ (Tree,
+ Root => List_Root (Tree, Container,
+rhs_alternative_list_ID),
+ List_ID => +rhs_alternative_list_ID,
+ Element_ID => +rhs_item_list_ID,
+ Separator_ID => +BAR_ID));
+
+ begin
+ if Trace_Generate_EBNF > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Insert_Optional_RHS start:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor, Container);
end if;
- if Orig_RHS_Element_C_Head /= Invalid_Node_Index then
- -- c is not empty
- New_RHS_Item_List_C := Tree.Copy_Subtree
- (Last => Orig_RHS_Element_C_Head,
- Root => Orig_RHS_Item_List_C_Root);
+ declare
+ Skip_List : constant Skip_Info := Find_Skips;
- if Trace_Generate_EBNF > Extra then
+ New_RHS_AC : Node_Index := Invalid_Node_Index;
+ Is_Duplicate : Boolean := False;
+ begin
+ if WisiToken.Trace_Generate_EBNF > Extra then
Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("new c:");
- Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
New_RHS_Item_List_C);
+ Ada.Text_IO.Put_Line ("skip: " & Image (Skip_List,
Wisitoken_Grammar_Actions.Descriptor));
end if;
- end if;
- if New_RHS_Item_List_C = Invalid_Node_Index then
- if New_RHS_Item_List_A = Invalid_Node_Index then
- -- a c is empty; there cannot be any actions.
- New_RHS_AC :=
- (if Tree.ID (Container) = +rhs_ID
- then Tree.Add_Nonterm ((+rhs_ID, 0), (1 .. 0 =>
Invalid_Node_Index))
+ if Skip_List.Skips'Length = 0 or else
+ +rhs_ID = Tree.ID (Tree.Parent (Skip_List.Start_List_Root))
+ then
+ -- Insert an edited rhs into the rhs_list.
+ --
+ -- We can't insert an empty rhs_item_list into an
+ -- rhs_alterative_list, so we insert an empty rhs.
+
+ if Container_ID = +rhs_alternative_list_ID then
+
+ Container := Tree.Find_Ancestor (B, +rhs_ID);
+
+ Container_ID := +rhs_ID;
+
+ Container_List := Create_From_Element
+ (Tree,
+ Element => Container,
+ List_ID => +rhs_list_ID,
+ Element_ID => +rhs_ID,
+ Separator_ID => +BAR_ID);
+ end if;
+
+ if Skip_List.Skips'Length = 0 then
+ -- New rhs is empty; no rhs_item_list
+ null;
+ else
+ New_RHS_AC := Copy_Skip_Nested (Skip_List, Tree);
+ end if;
+
+ if Duplicate (Container_List, New_RHS_AC) then
+ Is_Duplicate := True;
+ else
+ if Skip_List.Skips'Length = 0 then
+ Insert_Empty_RHS (Container_List, Container);
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 :=
- (if Tree.ID (Container) = +rhs_ID
- then Add_Actions (New_RHS_Item_List_A)
- else New_RHS_Item_List_A);
- end if;
- else
- -- c is not empty
- if New_RHS_Item_List_A = Invalid_Node_Index then
- -- a is empty
- New_RHS_AC :=
- (if Tree.ID (Container) = +rhs_ID
- then Add_Actions (New_RHS_Item_List_C)
- else New_RHS_Item_List_C);
+ Insert_RHS (Container_List, New_RHS_AC, After =>
Container);
+ end if;
+ end if;
+
else
- declare
- Tail_Element_A : constant Valid_Node_Index :=
Last_List_Element (New_RHS_Item_List_A);
- Head_Element_B : constant Valid_Node_Index :=
First_List_Element
- (New_RHS_Item_List_C, +rhs_element_ID);
- begin
- Tree.Set_Children
- (Tree.Parent (Head_Element_B),
- (+rhs_item_list_ID, 1),
- (Tree.Parent (Tail_Element_A), Head_Element_B));
- end;
+ -- Insert an edited rhs_item_list into an rhs_alternative_list
- New_RHS_AC :=
- (if Tree.ID (Container) = +rhs_ID
- then Add_Actions (New_RHS_Item_List_C)
- else New_RHS_Item_List_C);
- end if;
- end if;
+ New_RHS_AC := Copy_Skip_Nested (Skip_List, Tree);
- if Trace_Generate_EBNF > Extra then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("new ac:");
- Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor, New_RHS_AC);
- end if;
+ if Duplicate (Container_List, New_RHS_AC) then
+ -- IMPROVEME: check for duplicate before do copy; requires
version of
+ -- Get_Text that understands Skip_Info
+ Is_Duplicate := True;
+ else
+ declare
+ After : Valid_Node_Index := B;
+ begin
+ loop
+ After := List_Root (Tree, Tree.Find_Ancestor (After,
+rhs_item_list_ID), +rhs_item_list_ID);
+ exit when Container_List.Contains (After);
+ end loop;
+
+ Container_List.Insert
+ (New_Element => New_RHS_AC,
+ After => Container_List.To_Cursor (After));
+ end;
+ end if;
+ end if;
- -- Record copied EBNF nodes
- declare
- procedure Record_Copied_Node
- (Tree : in out WisiToken.Syntax_Trees.Tree;
- Node : in WisiToken.Valid_Node_Index)
- is begin
- if To_Token_Enum (Tree.ID (Node)) in
- rhs_optional_item_ID |
- rhs_multiple_item_ID |
- rhs_group_item_ID |
- rhs_attribute_ID |
- STRING_LITERAL_2_ID
- then
- Copied_EBNF_Nodes.Append (Node);
+ if Trace_Generate_EBNF > Detail then
+ Ada.Text_IO.New_Line;
+ if Is_Duplicate then
+ Ada.Text_IO.Put_Line ("Insert_Optional_RHS duplicate '" &
Get_Text (Data, Tree, New_RHS_AC) & "'");
+ else
+ if Container_ID = +rhs_ID then
+ Ada.Text_IO.Put_Line ("Insert_Optional_RHS old rhs, new
rhs:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
Container_List.Root);
+ else
+ Ada.Text_IO.Put_Line ("Insert_Optional_RHS edited
rhs_alternative_list:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
Tree.Parent (Container_List.Root, 1));
+ end if;
end if;
- end Record_Copied_Node;
- begin
- Tree.Process_Tree (Record_Copied_Node'Access, New_RHS_AC);
- end;
+ end if;
- Append_Element (Container_List, New_RHS_AC, +BAR_ID);
+ if not (Skip_List.Skips'Length = 0 or Is_Duplicate) then
+ Record_Copied_EBNF_Nodes (New_RHS_AC);
+ end if;
+ end;
+ return Container_List.Root;
end Insert_Optional_RHS;
- Compilation_Unit_List_Tail : constant Valid_Node_Index := Tree.Child
(Tree.Root, 1);
-
- procedure Add_Compilation_Unit (Unit : in Valid_Node_Index; Prepend : in
Boolean := False)
+ procedure Add_Compilation_Unit (Label : in String; Unit : in
Valid_Node_Index; Prepend : in Boolean := False)
with Pre => Tree.ID (Unit) in +declaration_ID | +nonterminal_ID
is
+ use WisiToken.Syntax_Trees.LR_Utils;
+
+ List : Syntax_Trees.LR_Utils.List := Creators.Create_List
+ (Tree, Tree.Child (Tree.Root, 1), +compilation_unit_list_ID,
+compilation_unit_ID, Invalid_Token_ID);
+
Comp_Unit : constant Valid_Node_Index := Tree.Add_Nonterm
((+compilation_unit_ID, (if Tree.ID (Unit) = +declaration_ID then 0
else 1)),
(1 => Unit));
+
+ function Equal
+ (Target : in String;
+ List : in LR_Utils.Constant_List'Class;
+ Comp_Unit : in Valid_Node_Index)
+ return Boolean
+ is
+ pragma Unreferenced (List);
+ Decl : constant Valid_Node_Index := Tree.Child (Comp_Unit, 1);
+ begin
+ return Tree.ID (Decl) = +declaration_ID and then Target =
+ (case Tree.RHS_Index (Decl) is
+ when 0 => Get_Text (Data, Tree, Tree.Child (Decl, 3)),
+ when 2 | 3 => Get_Text (Data, Tree, Tree.Child (Decl, 2)),
+ when others => "");
+ end Equal;
+
begin
if Prepend then
- Append_Element
- (Tree.Parent (First_List_Element (Compilation_Unit_List_Tail,
+compilation_unit_ID)), Comp_Unit);
+ -- Prepend is true for keywords, which must be declared before
they
+ -- are used. We put them all after the %meta_syntax declaration,
to
+ -- closer match the likely original EBNF layout.
+ declare
+ Meta_Syntax : constant Cursor := List.Find ("meta_syntax",
Equal'Unrestricted_Access);
+ begin
+ List.Insert (Comp_Unit, After => Meta_Syntax);
+ end;
else
- Append_Element (Compilation_Unit_List_Tail, Comp_Unit);
+ List.Append (Comp_Unit);
end if;
if Trace_Generate_EBNF > Extra then
Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("new comp_unit:");
- Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor, Unit);
+ Ada.Text_IO.Put_Line ("new " & Label & ":" & Comp_Unit'Image & ":
'" & Get_Text (Data, Tree, Unit) & "'");
end if;
end Add_Compilation_Unit;
@@ -1388,7 +1507,7 @@ package body WisiToken_Grammar_Runtime is
-- | rhs: new
-- | | rhs_item_list: keep Node,Child (3)
- if Tree.Is_Empty (Tree.Child (Node, 3)) then
+ if not Tree.Has_Children (Tree.Child (Node, 3)) then
-- Convert empty rhs_item_list to empty rhs
Tree.Set_Children
(Tree.Child (Node, 3),
@@ -1412,7 +1531,6 @@ package body WisiToken_Grammar_Runtime is
(1 => Tree.Child (Node, 3)))));
end if;
- Clear_EBNF_Node (Node);
Node := Tree.Child (Node, 1);
end loop;
@@ -1430,30 +1548,33 @@ package body WisiToken_Grammar_Runtime is
(+rhs_list_ID, 0),
(1 => Tree.Add_Nonterm ((+rhs_ID, 1), (1 => Tree.Child (Node,
1)))));
- Clear_EBNF_Node (Content);
return Content;
end Convert_RHS_Alternative;
procedure New_Nonterminal
- (New_Identifier : in Identifier_Index;
+ (Label : in String;
+ New_Identifier : in Identifier_Index;
Content : in Valid_Node_Index)
with Pre => To_Token_Enum (Tree.ID (Content)) in rhs_alternative_list_ID
| rhs_element_ID
is
-- Convert subtree rooted at Content to an rhs_list contained by a
new nonterminal
-- named New_Identifier.
- New_Nonterm : constant Valid_Node_Index := Tree_Add_Nonterminal
- (Child_1 => Tree.Add_Identifier (+IDENTIFIER_ID, New_Identifier,
Tree.Byte_Region (Content)),
- Child_2 => Tree.Add_Terminal (+COLON_ID),
- Child_3 =>
- (case To_Token_Enum (Tree.ID (Content)) is
- when rhs_element_ID => To_RHS_List (Content),
- when rhs_alternative_list_ID => Convert_RHS_Alternative
(Content),
- when others => raise SAL.Programmer_Error),
- Child_4 => Tree.Add_Nonterm
- ((+semicolon_opt_ID, 0),
- (1 => Tree.Add_Terminal (+SEMICOLON_ID))));
begin
- Add_Compilation_Unit (New_Nonterm);
+ declare
+ New_Nonterm : constant Valid_Node_Index := Tree_Add_Nonterminal
+ (Child_1 => Tree.Add_Identifier (+IDENTIFIER_ID,
New_Identifier, Tree.Byte_Region (Content)),
+ Child_2 => Tree.Add_Terminal (+COLON_ID),
+ Child_3 =>
+ (case To_Token_Enum (Tree.ID (Content)) is
+ when rhs_element_ID => To_RHS_List (Content),
+ when rhs_alternative_list_ID => Convert_RHS_Alternative
(Content),
+ when others => raise SAL.Programmer_Error),
+ Child_4 => Tree.Add_Nonterm
+ ((+semicolon_opt_ID, 0),
+ (1 => Tree.Add_Terminal (+SEMICOLON_ID))));
+ begin
+ Add_Compilation_Unit (Label & New_Identifier'Image, New_Nonterm);
+ end;
end New_Nonterminal;
procedure New_Nonterminal_List_1
@@ -1516,7 +1637,7 @@ package body WisiToken_Grammar_Runtime is
((+semicolon_opt_ID, 0),
(1 => Tree.Add_Terminal (+SEMICOLON_ID))));
begin
- Add_Compilation_Unit (List_Nonterminal);
+ Add_Compilation_Unit ("canonical list" & List_Nonterm'Image,
List_Nonterminal);
end New_Nonterminal_List_1;
procedure New_Nonterminal_List
@@ -1569,953 +1690,1387 @@ package body WisiToken_Grammar_Runtime is
end if;
end Copy_Non_Grammar;
- procedure Process_Node (Node : in Valid_Node_Index)
- is begin
- if Trace_Generate_EBNF > Detail then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("translate node" & Node_Index'Image (Node));
- end if;
+ procedure Translate_RHS_Group_Item (Node : in Valid_Node_Index)
+ is
+ -- Current tree:
+ --
+ -- rhs_element: Parent (Node, 2)
+ -- | rhs_item: Parent (Node, 1)
+ -- | | rhs_group_item: Node
+ -- | | | LEFT_PAREN
+ -- | | | rhs_alternative_list: Child (Node, 2)
+ -- | | | RIGHT_PAREN
+
+ use Syntax_Trees.LR_Utils;
+
+ Element_Content : constant String := Get_Text (Data, Tree,
Tree.Child (Node, 2));
+ Right_Paren_Node : constant Valid_Node_Index := Tree.Child (Node, 3);
+ List : constant Constant_List := Creators.Create_List
+ (Tree, Tree.Child (Tree.Root, 1), +compilation_unit_list_ID,
+compilation_unit_ID);
+ Name_Node : Node_Index;
+ New_Ident : Base_Identifier_Index :=
Invalid_Identifier_Index;
+ begin
+ -- See if there's an existing nonterminal for this content.
+ for N of List loop
- case To_Token_Enum (Tree.ID (Node)) is
- -- Token_Enum_ID alphabetical order
- when declaration_ID =>
- -- Must be "%meta_syntax EBNF"; change to BNF
- declare
- Decl_Item : constant Valid_Node_Index :=
Tree.Find_Descendant
- (Tree.Child (Node, 3), +declaration_item_ID);
- Old_Children : constant Valid_Node_Index_Array := Tree.Children
(Decl_Item);
- New_Children : constant Valid_Node_Index_Array :=
- (1 => Tree.Add_Identifier
- (+IDENTIFIER_ID, New_Identifier ("BNF"), Tree.Byte_Region
(Decl_Item)));
- begin
- Copy_Non_Grammar (Old_Children (1), New_Children (1));
- Tree.Set_Children (Decl_Item, (+declaration_item_ID, 1),
New_Children);
- end;
+ if Tree.Production_ID (Tree.Child (N, 1)) = (+nonterminal_ID, 0)
then
+ -- Target nonterm is:
+ --
+ -- (compilation_unit_1, (111 . 128))
+ -- | (nonterminal_0, (111 . 128))
+ -- | | 7;(IDENTIFIER, (111 . 128))
+ -- | | (COLON)
+ -- | | (rhs_list_1, (111 . 128))
+ -- | | | ...
+ declare
+ RHS_List_1 : constant Node_Index := Tree.Child (Tree.Child
(N, 1), 3);
+ begin
+ if RHS_List_1 /= Invalid_Node_Index and then
+ Element_Content = Get_Text (Data, Tree, RHS_List_1)
+ then
+ Name_Node := Tree.Child (Tree.Child (N, 1), 1);
+ case Tree.Label (Name_Node) is
+ when Shared_Terminal =>
+ New_Ident := New_Identifier (Get_Text (Data, Tree,
Name_Node));
+ when Virtual_Identifier =>
+ New_Ident := Tree.Identifier (Name_Node);
+ when others =>
+ Raise_Programmer_Error ("process_node rhs_group_item",
Data, Tree, Name_Node);
+ end case;
+
+ exit;
+ end if;
+ end;
+ end if;
+ end loop;
- when rhs_alternative_list_ID =>
- -- All handled by New_Nonterminal*
- raise SAL.Programmer_Error;
+ if New_Ident = Invalid_Identifier_Index then
+ New_Ident := Next_Nonterm_Name;
+ New_Nonterminal ("group item", New_Ident, Tree.Child (Node, 2));
+ else
+ Erase_Deleted_EBNF_Nodes (Tree.Child (Node, 2));
+ end if;
- when rhs_attribute_ID =>
- -- Just delete it
+ Tree.Set_Node_Identifier (Node, +IDENTIFIER_ID, New_Ident);
+ Copy_Non_Grammar (Right_Paren_Node, Node);
+ Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID, 0), (1 =>
Node));
+ Clear_EBNF_Node (Node);
+ end Translate_RHS_Group_Item;
+
+ procedure Translate_RHS_Multiple_Item (Node : in Valid_Node_Index)
+ is
+ -- We have one of:
+ --
+ -- | a { b } c
+ -- | a { b } - c
+ -- | a ( b ) + c
+ -- | a ( b ) * c
+ -- | a b+ c
+ -- | a b* c
+ --
+ -- where a and/or c can be empty. Replace it with a new canonical
+ -- list nonterminal:
+ --
+ -- nonterminal_nnn_list
+ -- : b
+ -- | nonterminal_nnn_list b
+ --
+ -- and a second RHS if it can be empty:
+ -- | a c
+
+ -- Current tree:
+ --
+ -- rhs_element : Parent (Node, 2)
+ -- | rhs_item: Parent (Node, 1)
+ -- | | rhs_multiple_item: Node
+ -- | | | LEFT_BRACE | LEFT_PAREN
+ -- | | | rhs_alternative_list
+ -- | | | ...
+ -- | | | RIGHT_BRACE | RIGHT_PAREN
+ -- | | | [MINUS | PLUS | STAR]
+
+ -- or:
+ --
+ -- rhs_element : Parent (Node, 2)
+ -- | rhs_item: Parent (Node, 1)
+ -- | | rhs_multiple_item: Node
+ -- | | | IDENTIFIER
+ -- | | | PLUS | STAR
+
+ Done : Boolean := False;
+ Parent_RHS_Item : constant Valid_Node_Index := Tree.Parent
(Node);
+ List_Nonterm_Virtual_Name : Base_Identifier_Index :=
Invalid_Identifier_Index;
+ List_Nonterm_Terminal_Name : Base_Token_Index :=
Invalid_Token_Index;
+
+ procedure Check_Canonical_List
+ is
+ -- In EBNF, a canonical list with a separator looks like:
+ --
+ -- enumConstants : enumConstant (',' enumConstant)* ;
+ --
+ -- or, with no separator:
--
- -- Current tree (so far, attributes are always the first item in
an rhs):
+ -- SwitchLabels : SwitchLabel {SwitchLabel} ;
--
- -- rhs:
- -- | ...
- -- | rhs_item_list: RHS_Item_List.Parent 2
- -- | | rhs_item_list: RHS_Item_List.Parent 1
- -- | | | rhs_item_list: RHS_Item_List
- -- | | | | rhs_element: Parent (Node, 2)
- -- | | | | | rhs_item: Parent (Node, 1)
- -- | | | | | | rhs_attribute: Node
- -- | | | rhs_element: next_element 1
- -- | | rhs_element: next_element 2
+ -- where Node is the rhs_multiple_item containing "(','
+ -- enumConstant)*" or "{SwitchLabel}".
--
- -- New tree:
+ -- The tokens may have labels.
--
- -- rhs:
- -- | ...
- -- | rhs_item_list: keep RHS_Item_List.Parent
- -- | | rhs_element: keep next_element 1
- -- | rhs_element: kepp next_element 2
+ -- Handling these cases specially eliminates a conflict between
+ -- reducing to enumConstants and reducing to the introduced
nonterm
+ -- list.
+ --
+ -- Alternately, the no separator case can be:
+ --
+ -- enumConstants : enumConstant+ ;
+ --
+ -- Handling this no separator case specially would not eliminate
any conflicts.
+
+ use Syntax_Trees.LR_Utils;
+ use Syntax_Trees.LR_Utils.Creators;
+ use all type Ada.Containers.Count_Type;
+
+ List_Name_Node : constant Valid_Node_Index := Tree.Find_Ancestor
(Node, +nonterminal_ID);
+ RHS_List_Root : constant Valid_Node_Index := Tree.Child
(List_Name_Node, 3);
+
+ RHS_2 : constant Valid_Node_Index := Tree.Find_Ancestor
+ (Node, (+rhs_ID, +rhs_alternative_list_ID));
+ -- If rhs_ID, the RHS containing the canonical list candidate.
+ -- If rhs_alternative_list_ID, not useful (FIXME: actually a
canonical list candidate)
+
+ RHS_2_Item_List_List : constant Constant_List :=
+ (if Tree.ID (RHS_2) = +rhs_ID
+ then Create_List (Tree, Tree.Child (RHS_2, 1),
+rhs_item_list_ID, +rhs_element_ID)
+ else Invalid_List (Tree));
+
+ Alt_List_List : constant Constant_List :=
+ (case Tree.RHS_Index (Node) is
+ when 0 | 3 =>
+ Create_List (Tree, Tree.Child (Node, 2),
+rhs_alternative_list_ID, +rhs_item_list_ID),
+ when others => Invalid_List (Tree));
+ -- Iterator on the rhs_alternative_list of the rhs_multiple_item.
+
+ Alt_List_Item_List : constant Constant_List :=
+ (if Alt_List_List.Is_Invalid
+ then Invalid_List (Tree)
+ else Create_List (Tree, Get_Node (Alt_List_List.First),
+rhs_item_list_ID, +rhs_element_ID));
+ -- Iterator on the content of the rhs_multiple_item. Note that we
+ -- don't support a non-empty multiple_item; a canonical list can
be
+ -- empty.
+
+ RHS_2_Item_List_Iter : constant Constant_Iterator :=
RHS_2_Item_List_List.Iterate_Constant;
+
+ Element_2 : constant Cursor :=
+ (if Is_Invalid (RHS_2_Item_List_List)
+ then No_Element
+ else RHS_2_Item_List_List.To_Cursor (Tree.Parent (Node, 2)));
+ -- The rhs_element containing the rhs_multiple_item
+
+ Element_1 : constant Node_Index :=
+ (if Is_Invalid (RHS_2_Item_List_List)
+ then Invalid_Node_Index
+ else Get_Node (RHS_2_Item_List_Iter.Previous (Element_2)));
+ -- The list element
+ begin
+ if Tree.ID (RHS_2) = +rhs_alternative_list_ID or else
+ Create_List (Tree, RHS_List_Root, +rhs_list_ID, +rhs_ID).Count
/= 1
+ then
+ -- Something else going on
+ return;
+ end if;
+ pragma Assert (Tree.ID (RHS_2) = +rhs_ID);
+
+ if RHS_2_Item_List_List.Count = 2 and then
+ (Tree.RHS_Index (Node) in 4 .. 5 or else
+ Alt_List_Item_List.Count in 1 .. 2)
+ then
+ null;
+ else
+ return;
+ end if;
+
+ if Element_1 = Invalid_Node_Index or else
+ Get_Text (Data, Tree, Tree.Find_Descendant (Element_1,
+rhs_item_ID)) /=
+ Get_Text (Data, Tree, Tree.Find_Descendant (Get_Node
(Alt_List_Item_List.Last), +rhs_item_ID))
+ then
+ return;
+ end if;
+
+ if Trace_Generate_EBNF > Detail then
+ Ada.Text_IO.Put_Line ("canonical list");
+ end if;
+
+ -- We have a canonical list declaration. Rewrite it to:
+ --
+ -- with separator:
+ -- rhs_list: keep
+ -- | rhs_list:
+ -- | | rhs: new, RHS_1
+ -- | | | rhs_item_list: new, RHS_Item_List_1
+ -- | | | | rhs_element: keep, Element_1
+ -- | | | | | rhs_item: keep
+ -- | | | | | | IDENTIFIER: keep; element name
+ -- | BAR: new
+ -- | rhs: keep, RHS_2
+ -- | | rhs_item_list: new, RHS_Item_List_2
+ -- | | | rhs_item_list: keep, rhs_item_list_3
+ -- | | | | rhs_item_list: keep, rhs_item_list_4
+ -- | | | | | rhs_element: new
+ -- | | | | | | rhs_item: new
+ -- | | | | | | | IDENTIFIER: new, list name
+ -- | | | | rhs_element: keep
+ -- | | | | | rhs_item: keep
+ -- | | | | | | IDENTIFIER: keep, separator
+ -- | | | rhs_element: keep, alt_list_elements (last)
+ -- | | | | rhs_item: keep
+ -- | | | | | IDENTIFIER: keep, element name
+ --
+ -- no separator:
+ -- rhs_list: keep
+ -- | rhs_list:
+ -- | | rhs: new, RHS_1
+ -- | | | rhs_item_list: new, RHS_Item_List_1
+ -- | | | | rhs_element: keep, Element_1
+ -- | | | | | rhs_item: keep
+ -- | | | | | | IDENTIFIER: keep; element name
+ -- | BAR: new
+ -- | rhs: keep, RHS_2
+ -- | | rhs_item_list: keep, rhs_item_list_3
+ -- | | | rhs_item_list: new, rhs_item_list_4
+ -- | | | | rhs_element: new
+ -- | | | | | rhs_item: new
+ -- | | | | | | IDENTIFIER: new, list name
+ -- | | | rhs_element: keep, alt_list_elements (last)
+ -- | | | | rhs_item: keep
+ -- | | | | | IDENTIFIER: keep, element name
+
declare
- RHS_Item_List : constant Valid_Node_Index := Tree.Parent
(Node, 3);
- Parent : constant Valid_Node_Index := Tree.Parent
(RHS_Item_List);
+ List_Name_Tok : constant Token_Index :=
Tree.First_Shared_Terminal (List_Name_Node);
+ List_Name_Region : constant Buffer_Region :=
Data.Terminals.all (List_Name_Tok).Byte_Region;
+ List_Name : constant String :=
Data.Grammar_Lexer.Buffer_Text (List_Name_Region);
+
+ RHS_2_Index : constant Integer := Tree.RHS_Index
(RHS_2);
+ RHS_2_Children : Valid_Node_Index_Array := Tree.Children
(RHS_2);
+
+ RHS_1_Item_List : constant Valid_Node_Index :=
Tree.Add_Nonterm
+ ((+rhs_item_list_ID, 0), (1 => Element_1));
+
+ RHS_1_Action : constant Node_Index :=
+ (case RHS_2_Index is
+ when 2 | 3 => Tree.Add_Terminal
+ (Tree.First_Shared_Terminal (RHS_2_Children (2)),
Data.Terminals.all),
+ when others => Invalid_Node_Index);
+
+ RHS_1_Check : constant Node_Index :=
+ (case RHS_2_Index is
+ when 3 => Tree.Add_Terminal
+ (Tree.First_Shared_Terminal (RHS_2_Children (3)),
Data.Terminals.all),
+ when others => Invalid_Node_Index);
+
+ RHS_1 : constant Valid_Node_Index :=
+ (case RHS_2_Index is
+ when 1 => Tree.Add_Nonterm ((+rhs_ID, 1), (1 =>
RHS_1_Item_List)),
+ when 2 => Tree.Add_Nonterm ((+rhs_ID, 2), (1 =>
RHS_1_Item_List, 2 => RHS_1_Action)),
+ when 3 => Tree.Add_Nonterm
+ ((+rhs_ID, 3), (1 => RHS_1_Item_List, 2 => RHS_1_Action, 3
=> RHS_1_Check)),
+ when others => raise SAL.Programmer_Error);
+
+ Bar : constant Valid_Node_Index :=
Tree.Add_Terminal (+BAR_ID);
+ RHS_Item_List_3 : constant Valid_Node_Index := Tree.Child
(RHS_2, 1);
+ RHS_Item_List_4 : constant Valid_Node_Index := Tree.Child
(RHS_Item_List_3, 1);
+ New_List_Name_Term : constant Valid_Node_Index :=
Tree.Add_Terminal
+ (List_Name_Tok, Data.Terminals.all);
+ New_List_Name_Item : constant Valid_Node_Index :=
Tree.Add_Nonterm
+ ((+rhs_item_ID, 0),
+ (1 => New_List_Name_Term));
+
+ New_List_Name_Label : constant Node_Index :=
+ (if Tree.RHS_Index (Element_1) = 1
+ then -- tokens have labels
+ Tree.Add_Identifier (+IDENTIFIER_ID, New_Identifier
(List_Name), List_Name_Region)
+ else Invalid_Node_Index);
+
+ New_List_Name_Element : constant Valid_Node_Index :=
+ (if Tree.RHS_Index (Element_1) = 1
+ then -- tokens have labels
+ Tree.Add_Nonterm
+ ((+rhs_element_ID, 1),
+ (1 => New_List_Name_Label,
+ 2 => Tree.Add_Terminal (+EQUAL_ID),
+ 3 => New_List_Name_Item))
+ else
+ Tree.Add_Nonterm ((+rhs_element_ID, 0), (1 =>
New_List_Name_Item)));
+
+ Alt_List_Elements : constant Valid_Node_Index_Array :=
Tree.Get_IDs (Node, +rhs_element_ID);
+ RHS_Item_List_2 : constant Node_Index :=
+ (if Alt_List_Elements'Last = 1
+ then Invalid_Node_Index -- no separator
+ else Tree.Add_Nonterm
+ ((+rhs_item_list_ID, 1),
+ (1 => RHS_Item_List_3,
+ 2 => Alt_List_Elements (Alt_List_Elements'Last))));
+
begin
- if Tree.RHS_Index (RHS_Item_List) /= 0 then
- -- Not first
- Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_attribute_id unimplemented", Data, Tree, Node);
- end if;
+ Tree.Set_Children (RHS_Item_List_4, (+rhs_item_list_ID, 0), (1
=> New_List_Name_Element));
Tree.Set_Children
- (Parent,
- (+rhs_item_list_ID, 0),
- (1 => Tree.Child (Parent, 2)));
+ (RHS_Item_List_3,
+ (+rhs_item_list_ID, 1),
+ (1 => RHS_Item_List_4,
+ 2 => Alt_List_Elements (1)));
+
+ RHS_2_Children (1) :=
+ (if Alt_List_Elements'Last = 1
+ then RHS_Item_List_3 -- no separator
+ else RHS_Item_List_2);
+ Tree.Set_Children (RHS_2, (+rhs_ID, Tree.RHS_Index (RHS_2)),
RHS_2_Children);
+
+ Tree.Set_Children
+ (Tree.Parent (RHS_2),
+ (+rhs_list_ID, 1),
+ (1 => Tree.Add_Nonterm ((+rhs_list_ID, 0), (1 => RHS_1)),
+ 2 => Bar,
+ 3 => RHS_2));
end;
- when rhs_group_item_ID =>
- -- Current tree:
- --
- -- rhs_element: Parent (Node, 2)
- -- | rhs_item: Parent (Node, 1)
- -- | | rhs_group_item: Node
- -- | | | LEFT_PAREN
- -- | | | rhs_alternative_list: Child (Node, 2)
- -- | | | RIGHT_PAREN
+ Done := True;
+
+ Clear_EBNF_Node (Node);
+
+ if Trace_Generate_EBNF > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Check_Canonical_List edited rhs_list:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
Tree.Parent (RHS_2));
+ end if;
+ end Check_Canonical_List;
+
+ procedure Find_List_Nonterminal_1 (Element_Content : in String)
+ is
+ -- Search for a nonterm (virtual or not) implementing a list for
+ -- Element_Content, which is a single rhs_element; no List_Element
+ -- Nonterminal. If found, set List_Nonterm_Virtual_Name or
+ -- List_Nonterm_Terminal_Name
+ use Syntax_Trees.LR_Utils;
+
+ List : constant Constant_List := Creators.Create_List
+ (Tree, Tree.Child (Tree.Root, 1), +compilation_unit_list_ID,
+compilation_unit_ID);
+ begin
+ for N of List loop
+
+ if Tree.Production_ID (Tree.Child (N, 1)) = (+nonterminal_ID,
0) then
+ -- Target List_Nonterm is:
+ --
+ -- nonterminal_nnn_list
+ -- : element
+ -- | nonterminal_nnn_list element
+ --
+ -- compilation_unit
+ -- | nonterminal
+ -- | | IDENTIFIER : list_nonterm
+ -- | | COLON
+ -- | | rhs_list: rhs_list_1
+ -- | | | rhs_list: rhs_list_2
+ -- | | | | rhs
+ -- | | | | | ... List_element
+ -- | | | BAR
+ -- | | | rhs: ... list_nonterm list_element
+ declare
+ Name_Node : constant Node_Index := Tree.Child
(Tree.Child (N, 1), 1);
+ RHS_List_1 : constant Node_Index := Tree.Child
(Tree.Child (N, 1), 3);
+ RHS_List_2 : constant Node_Index :=
+ (if RHS_List_1 = Invalid_Node_Index
+ then Invalid_Node_Index
+ else Tree.Child (RHS_List_1, 1));
+ begin
+ if RHS_List_2 /= Invalid_Node_Index and
+ Tree.Child (RHS_List_1, 3) /= Invalid_Node_Index and --
second rhs present
+ Tree.Child (RHS_List_2, 3) = Invalid_Node_Index -- no
third rhs
+ then
+ declare
+ RHS_1 : constant String := Get_Text (Data, Tree,
RHS_List_2);
+ RHS_2 : constant String := Get_Text (Data, Tree,
Tree.Child (RHS_List_1, 3));
+ Expected_RHS_2 : constant String := Get_Text (Data,
Tree, Name_Node) & " " &
+ Element_Content;
+ begin
+ if Element_Content = RHS_1 and RHS_2 =
Expected_RHS_2 then
+ case Tree.Label (Name_Node) is
+ when Shared_Terminal =>
+ List_Nonterm_Terminal_Name :=
Tree.First_Shared_Terminal (Name_Node);
+ when Virtual_Identifier =>
+ List_Nonterm_Virtual_Name := Tree.Identifier
(Name_Node);
+ when others =>
+ Raise_Programmer_Error
+ ("unimplemented Find_List_Nonterminal_1
case '" & Element_Content & "'",
+ Data, Tree, Name_Node);
+ end case;
+
+ exit;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end loop;
+ end Find_List_Nonterminal_1;
+
+ procedure Find_List_Nonterminal_2 (Element_Content : in String)
+ is
+ -- Look for a pair of nonterms implementing a list of
Element_Content.
+ -- If found, set List_Nonterm_*_Name
+ use Syntax_Trees.LR_Utils;
+
+ List : constant Constant_List := Creators.Create_List
+ (Tree, Tree.Child (Tree.Root, 1), +compilation_unit_list_ID,
+compilation_unit_ID);
+ begin
+ for Comp_Unit of List loop
+ declare
+ Nonterm : constant Valid_Node_Index := Tree.Child
(Comp_Unit, 1);
+ begin
+ if Tree.Production_ID (Nonterm) = (+nonterminal_ID, 0) and
then
+ Element_Content = Get_Text (Data, Tree, Tree.Child
(Nonterm, 3))
+ then
+ Find_List_Nonterminal_1 (Get_Text (Data, Tree, Tree.Child
(Nonterm, 1)));
+ exit;
+ end if;
+ end;
+ end loop;
+ end Find_List_Nonterminal_2;
+
+ Container_List_Root : Node_Index := Invalid_Node_Index;
+ begin
+ -- Check if this is a recognized pattern
+ Check_Canonical_List;
+ if Done then return; end if;
+
+ -- Check to see if there is an already declared nonterminal
+ -- list with the same content; if not, create one.
+ case Tree.RHS_Index (Node) is
+ when 0 .. 3 =>
+ -- 0: { rhs_alternative_list }
+ -- 1: { rhs_alternative_list } -
+ -- 2: ( rhs_alternative_list ) +
+ -- 3: ( rhs_alternative_list ) *
+
+ if Tree.RHS_Index (Node) in 0 | 3 then
+ Container_List_Root := Insert_Optional_RHS (Node);
+ end if;
+
+ if 0 = Tree.RHS_Index (Tree.Child (Node, 2)) and then
+ 0 = Tree.RHS_Index (Tree.Child (Tree.Child (Node, 2), 1))
+ then
+ -- Only one element in the rhs_alternative_list, and in the
rhs_item_list
+ Find_List_Nonterminal_1 (Get_Text (Data, Tree, Tree.Child
(Node, 2)));
+
+ if List_Nonterm_Virtual_Name = Invalid_Identifier_Index and
+ List_Nonterm_Terminal_Name = Invalid_Token_Index
+ then
+ List_Nonterm_Virtual_Name := Next_Nonterm_Name ("_list");
+ New_Nonterminal_List
+ (List_Nonterm_Virtual_Name, Tree.First_Shared_Terminal
(Tree.Child (Node, 2)),
+ Data.Terminals.all, Tree.Byte_Region (Node));
+ else
+ Erase_Deleted_EBNF_Nodes (Tree.Child (Node, 2));
+ end if;
+ else
+ Find_List_Nonterminal_2 (Get_Text (Data, Tree, Tree.Child
(Node, 2)));
+
+ if List_Nonterm_Virtual_Name = Invalid_Identifier_Index then
+ List_Nonterm_Virtual_Name := Next_Nonterm_Name ("_list");
+ declare
+ List_Element_Virtual_Name : constant Identifier_Index :=
Next_Nonterm_Name;
+ begin
+ New_Nonterminal ("canonical list element",
List_Element_Virtual_Name, Tree.Child (Node, 2));
+ New_Nonterminal_List
+ (List_Nonterm_Virtual_Name, List_Element_Virtual_Name,
Tree.Byte_Region (Node));
+ end;
+ else
+ Erase_Deleted_EBNF_Nodes (Tree.Child (Node, 2));
+ end if;
+ end if;
+
+ when 4 | 5 =>
+ -- IDENTIFIER + | *
+ Find_List_Nonterminal_1 (Get_Text (Data, Tree, Tree.Child (Node,
1)));
+
+ if List_Nonterm_Virtual_Name = Invalid_Identifier_Index then
+ List_Nonterm_Virtual_Name := Next_Nonterm_Name ("_list");
+
+ New_Nonterminal_List
+ (List_Nonterm_Virtual_Name,
+ Tree.First_Shared_Terminal (Tree.Child (Node, 1)),
Data.Terminals.all,
+ Tree.Byte_Region (Node));
+ else
+ -- nothing to erase
+ null;
+ end if;
+
+ if Tree.RHS_Index (Node) = 5 then
+ Container_List_Root := Insert_Optional_RHS (Node);
+ end if;
+
+ when others =>
+ Raise_Programmer_Error ("Translate_RHS_Multiple_Item
unimplemented", Data, Tree, Node);
+ end case;
+
+ -- Edit rhs_item to use list name
+ declare
+ Child : constant Valid_Node_Index :=
+ (if List_Nonterm_Virtual_Name /= Invalid_Identifier_Index
+ then Tree.Add_Identifier
+ (+IDENTIFIER_ID, List_Nonterm_Virtual_Name, Tree.Byte_Region
(Parent_RHS_Item))
+ elsif List_Nonterm_Terminal_Name /= Invalid_Token_Index
+ then Tree.Add_Terminal (List_Nonterm_Terminal_Name,
Data.Terminals.all)
+ else raise SAL.Programmer_Error);
+ begin
+ Tree.Set_Children (Parent_RHS_Item, (+rhs_item_ID, 0), (1 =>
Child));
+ end;
+
+ Clear_EBNF_Node (Node);
+
+ if Trace_Generate_EBNF > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Translate_RHS_Multiple_Item edited:");
+ Tree.Print_Tree
+ (Wisitoken_Grammar_Actions.Descriptor,
+ (if Container_List_Root = Invalid_Node_Index
+ then Parent_RHS_Item
+ else Container_List_Root));
+ end if;
+ end Translate_RHS_Multiple_Item;
+
+ procedure Translate_RHS_Optional_Item (B : in Valid_Node_Index)
+ is
+ -- Source looks like:
+ --
+ -- | A [B] C
+ --
+ -- where A, B, C are token sequences. All are contained in one
+ -- rhs_item_list, which may be contained in an rhs or an
+ -- rhs_alternative_list. B contains an rhs_alternative_list.
+ --
+ -- First add a second rhs_item_list without B:
+ -- | A C
+ --
+ -- then for each alternative in B, splice together rhs_item_lists A,
+ -- B_i, C, copying A, C on all after the first:
+ -- | A B_i C
+ --
+ -- See nested_ebnf_optional.wy for an example of nested optional
+ -- items.
+ --
+ -- We don't create a separate nonterminal for B, so token labels stay
+ -- in the same RHS for actions.
+ --
+ -- current tree:
+ --
+ -- rhs_list:
+ -- | rhs | rhs_alternative_list:
+ -- | | rhs_item_list
+ -- | | | rhs_item_list
+ -- | | ...
+ -- | | | | | rhs_element: a.last
+ -- | | | | | | rhs_item:
+ -- | | | | rhs_element:
+ -- | | | | | rhs_item: contains b
+ -- | | | | | | rhs_optional_item: B
+ -- | | | | | | | LEFT_BRACKET: B.Children (1)
+ -- | | | | | | | rhs_alternative_list: B.Children (2) b
+ -- | | | | | | | RIGHT_BRACKET: B.Children (3)
+ -- | | | rhs_element: c.first
+ -- | | | | rhs_item:
+
+ use Syntax_Trees.LR_Utils;
+ use Syntax_Trees.LR_Utils.Creators;
+
+ Container_List_Root : constant Valid_Node_Index :=
Insert_Optional_RHS (B);
+ begin
+ if Trace_Generate_EBNF > Extra then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Translate_RHS_Optional_Item start");
+ end if;
+
+ case Tree.RHS_Index (B) is
+ when 0 | 1 =>
+ -- : LEFT_BRACKET rhs_alternative_list RIGHT_BRACKET
+ -- | LEFT_PAREN rhs_alternative_list RIGHT_PAREN QUESTION
declare
- Element_Content : constant String := Get_Text (Data,
Tree, Tree.Child (Node, 2));
- Right_Paren_Node : constant Valid_Node_Index := Tree.Child
(Node, 3);
- Temp : Node_Index :=
First_List_Element
- (Tree.Child (Tree.Root, 1), +compilation_unit_ID);
- Name_Node : Node_Index;
- New_Ident : Base_Identifier_Index :=
Invalid_Identifier_Index;
+ Container_List : Syntax_Trees.LR_Utils.List :=
+ (if Tree.ID (Container_List_Root) = +rhs_list_ID
+ then Create_List
+ (Tree,
+ Root => Container_List_Root,
+ List_ID => +rhs_list_ID,
+ Element_ID => +rhs_ID,
+ Separator_ID => +BAR_ID)
+ else Create_List
+ (Tree,
+ Root => Container_List_Root,
+ List_ID => +rhs_alternative_list_ID,
+ Element_ID => +rhs_item_list_ID,
+ Separator_ID => +BAR_ID));
+
+ Container_Cur : Cursor := Container_List.Find
+ (if Container_List.Element_ID = +rhs_ID
+ then Tree.Find_Ancestor (B, +rhs_ID)
+ else List_Root (Tree, Tree.Find_Ancestor (B,
+rhs_item_list_ID), +rhs_item_list_ID));
+
+ ABC_List : List := Create_From_Element
+ (Tree, Tree.Parent (B, 2),
+ List_ID => +rhs_item_list_ID,
+ Element_ID => +rhs_element_ID,
+ Separator_ID => Invalid_Token_ID);
+
+ ABC_Iter : constant Iterator := ABC_List.Iterate;
+
+ ABC_B_Cur : constant Cursor := ABC_List.To_Cursor
(Tree.Parent (B, 2));
+ ABC_A_Last : constant Cursor := ABC_Iter.Previous (ABC_B_Cur);
+ ABC_C_First : constant Cursor := ABC_Iter.Next (ABC_B_Cur);
+
+ B_Alternative_List : constant Constant_List := Create_List
+ (Tree, Tree.Child (B, 2), +rhs_alternative_list_ID,
+rhs_item_list_ID);
+
begin
- -- See if there's an existing nonterminal for this content.
- loop
- pragma Assert (Tree.ID (Temp) = +compilation_unit_ID);
-
- if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+nonterminal_ID, 0) then
- -- Target nonterm is:
- --
- -- (compilation_unit_1, (111 . 128))
- -- | (nonterminal_0, (111 . 128))
- -- | | 7;(IDENTIFIER, (111 . 128))
- -- | | (COLON)
- -- | | (rhs_list_1, (111 . 128))
- -- | | | ...
- declare
- RHS_List_1 : constant Node_Index := Tree.Child
(Tree.Child (Temp, 1), 3);
- begin
- if RHS_List_1 /= Invalid_Node_Index and then
- Element_Content = Get_Text (Data, Tree, RHS_List_1)
- then
- Name_Node := Tree.Child (Tree.Child (Temp, 1), 1);
- case Tree.Label (Name_Node) is
- when Shared_Terminal =>
- New_Ident := New_Identifier (Get_Text (Data,
Tree, Name_Node));
- when Virtual_Identifier =>
- New_Ident := Tree.Identifier (Name_Node);
- when others =>
- Raise_Programmer_Error ("process_node
rhs_group_item", Data, Tree, Name_Node);
- end case;
+ -- An alternate design would be to splice together the
existing A,
+ -- B_i, C; but it's too hard to get all the parent updates
right.
+ for Alt of reverse B_Alternative_List loop
- exit;
- end if;
- end;
- end if;
+ declare
+ B_Item_List : constant Constant_List := Create_List
+ (Tree, Alt, +rhs_item_list_ID, +rhs_element_ID);
+
+ New_ABC : List := Empty_List (ABC_List);
+ begin
+ if Has_Element (ABC_A_Last) then
+ Copy (Source_List => ABC_List,
+ Source_Last => ABC_A_Last,
+ Dest_List => New_ABC);
+ end if;
+
+ Copy (B_Item_List, Dest_List => New_ABC);
+
+ if Has_Element (ABC_C_First) then
+ Copy (ABC_List, Source_First => ABC_C_First, Dest_List
=> New_ABC);
+ end if;
- Temp := Next_List_Element (Temp, +compilation_unit_list_ID);
- exit when Temp = Invalid_Node_Index;
+ if Container_List.Element_ID = +rhs_ID then
+ Insert_RHS (Container_List, New_ABC.Root, After =>
Get_Node (Container_Cur));
+ else
+ Container_List.Insert (New_ABC.Root, After =>
Container_Cur);
+ end if;
+
+ Record_Copied_EBNF_Nodes (New_ABC.Root);
+ end;
end loop;
- if New_Ident = Invalid_Identifier_Index then
- New_Ident := Next_Nonterm_Name;
- New_Nonterminal (New_Ident, Tree.Child (Node, 2));
- end if;
+ Erase_Deleted_EBNF_Nodes (Get_Node (Container_Cur));
+ -- This includes B, so we don't do 'Clear_EBNF_Node (B)'.
- Tree.Set_Node_Identifier (Node, +IDENTIFIER_ID, New_Ident);
- Copy_Non_Grammar (Right_Paren_Node, Node);
- Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID, 0), (1 =>
Node));
- Clear_EBNF_Node (Node);
+ Container_List.Delete (Container_Cur);
end;
- when rhs_multiple_item_ID =>
- -- We have one of:
- --
- -- | a { b } c
- -- | a { b } - c
- -- | a ( b ) + c
- -- | a ( b ) * c
- -- | a b+ c
- -- | a b* c
- --
- -- where a and/or c can be empty. Replace it with a new canonical
- -- list nonterminal:
- --
- -- nonterminal_nnn_list
- -- : b
- -- | nonterminal_nnn_list b
+ when 2 =>
+ -- | IDENTIFIER QUESTION
--
- -- and a second RHS if it can be empty:
- -- | a c
-
-- Current tree:
+ -- rhs_item_3
+ -- | rhs_optional_item_2: B
+ -- | | IDENTIFIER
+ -- | | QUESTION
--
- -- rhs_item: Parent (Node, 1)
- -- | rhs_multiple_item: Node
- -- | | LEFT_BRACE | LEFT_PAREN
- -- | | rhs_alternative_list
- -- | | | ...
- -- | | RIGHT_BRACE | RIGHT_PAREN
- -- | | [MINUS | PLUS | STAR]
-
- -- or:
- --
- -- rhs_item: Parent (Node, 1)
- -- | rhs_multiple_item: Node
- -- | | IDENTIFIER
- -- | | PLUS | STAR
+ -- Change to:
+ -- rhs_item_0
+ -- | IDENTIFIER
- declare
- Done : Boolean := False;
- RHS_Index : constant Integer :=
Tree.RHS_Index (Node);
- Plus_Minus_Star : constant Node_Index :=
Tree.Child
- (Node, (if RHS_Index in 0 .. 3 then 4 else 2));
- Allow_Empty : constant Boolean :=
Plus_Minus_Star = Invalid_Node_Index or else
- Tree.ID (Plus_Minus_Star) in +STAR_ID;
- Parent_RHS_Item : constant Valid_Node_Index :=
Tree.Parent (Node);
- List_Nonterm_Virtual_Name : Base_Identifier_Index :=
Invalid_Identifier_Index;
- List_Nonterm_Terminal_Name : Base_Token_Index :=
Invalid_Token_Index;
- List_Element : Base_Identifier_Index :=
Invalid_Identifier_Index;
-
- procedure Check_Canonical_List
- is
- -- In EBNF, a canonical list with a separator looks like:
- --
- -- enumConstants : enumConstant (',' enumConstant)* ;
- --
- -- or, with no separator:
- --
- -- SwitchLabels : SwitchLabel {SwitchLabel} ;
- --
- -- The tokens may have labels.
- --
- -- Handling these cases specially eliminates a conflict
between
- -- reducing to enumConstants and reducing to the introduced
nonterm
- -- list.
- --
- -- Alternately, the no separator case can be:
- --
- -- enumConstants : enumConstant+ ;
- --
- -- Handling this no separator case specially would not
eliminate any conflicts.
+ Tree.Set_Children (Tree.Parent (B), (+rhs_item_ID, 0), (1 =>
Tree.Child (B, 1)));
+ Clear_EBNF_Node (B);
- use all type SAL.Base_Peek_Type;
+ when 3 =>
+ -- | STRING_LITERAL_2 QUESTION
+ Tree.Set_Children (Tree.Parent (B), (+rhs_item_ID, 1), (1 =>
Tree.Child (B, 1)));
+ Clear_EBNF_Node (B);
+
+ when others =>
+ Raise_Programmer_Error ("translate_ebnf_to_bnf rhs_optional_item
unimplemented", Data, Tree, B);
+ end case;
+
+ if WisiToken.Trace_Generate_EBNF > Detail then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line ("Translate_RHS_Optional_Item edited:");
+ Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
Container_List_Root);
+ end if;
+ end Translate_RHS_Optional_Item;
+
+ procedure Translate_Token_Literal (Node : in Valid_Node_Index)
+ is
+ use Syntax_Trees.LR_Utils;
+
+ Name_Ident : Identifier_Index;
- Alt_List_Items : constant Valid_Node_Index_Array :=
Tree.Get_IDs (Node, +rhs_item_ID);
- RHS_Element : constant Valid_Node_Index :=
Tree.Parent (Node, 2);
- Element_1 : constant Node_Index :=
Prev_List_Element
- (RHS_Element, +rhs_item_list_ID);
- RHS_2 : constant Valid_Node_Index :=
Tree.Find_Ancestor
- (Node, (+rhs_ID, +rhs_alternative_list_ID));
+ function Equal
+ (Target : in String;
+ List : in Constant_List'Class;
+ N : in Valid_Node_Index)
+ return Boolean
+ is
+ pragma Unreferenced (List);
+ begin
+ if Tree.Production_ID (Tree.Child (N, 1)) = (+declaration_ID, 0)
then
+ declare
+ Decl : constant Node_Index := Tree.Child (N, 1);
+ Value_Node : constant Valid_Node_Index := Tree.Child
(Tree.Child (Decl, 4), 1);
begin
- if Tree.ID (RHS_2) = +rhs_alternative_list_ID then return;
end if;
- if not (Alt_List_Items'Last in 1 .. 2) then return; end if;
- if Element_1 = Invalid_Node_Index or else
- Get_Text (Data, Tree, Tree.Get_IDs (Element_1,
+rhs_item_ID)(1)) /=
- Get_Text (Data, Tree, Alt_List_Items (Alt_List_Items'Last))
- then
- return;
- end if;
- if Invalid_Node_Index /= 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)
+ if Tree.ID (Value_Node) = +declaration_item_ID and then
+ Tree.ID (Tree.Child (Value_Node, 1)) in
+ +IDENTIFIER_ID | +STRING_LITERAL_1_ID |
+STRING_LITERAL_2_ID and then
+ Target = Get_Text (Data, Tree, Tree.Child (Value_Node, 1),
Strip_Quotes => True)
then
- return;
+ case Tree.Label (Tree.Child (Decl, 3)) is
+ when Shared_Terminal =>
+ Name_Ident := New_Identifier (Get_Text (Data, Tree,
Tree.Child (Decl, 3)));
+ when Virtual_Identifier =>
+ Name_Ident := Tree.Identifier (Tree.Child (Decl, 3));
+ when others =>
+ raise SAL.Programmer_Error;
+ end case;
+ return True;
+ else
+ return False;
end if;
+ end;
+ else
+ return False;
+ end if;
+ end Equal;
- -- We have a canonical list declaration. Rewrite it to:
- --
- -- with separator:
- -- rhs_list: keep
- -- | rhs_list:
- -- | | rhs: new, RHS_1
- -- | | | rhs_item_list: new, RHS_Item_List_1
- -- | | | | rhs_element: keep, Element_1
- -- | | | | | rhs_item: keep
- -- | | | | | | IDENTIFIER: keep; element name
- -- | BAR: new
- -- | rhs: keep, RHS_2
- -- | | rhs_item_list: new, RHS_Item_List_2
- -- | | | rhs_item_list: keep, rhs_item_list_3
- -- | | | | rhs_item_list: keep, rhs_item_list_4
- -- | | | | | rhs_element: new
- -- | | | | | | rhs_item: new
- -- | | | | | | | IDENTIFIER: new, list name
- -- | | | | rhs_element: keep
- -- | | | | | rhs_item: keep
- -- | | | | | | IDENTIFIER: keep, separator
- -- | | | rhs_element: keep, alt_list_elements (last)
- -- | | | | rhs_item: keep
- -- | | | | | IDENTIFIER: keep, element name
- --
- -- no separator:
- -- rhs_list: keep
- -- | rhs_list:
- -- | | rhs: new, RHS_1
- -- | | | rhs_item_list: new, RHS_Item_List_1
- -- | | | | rhs_element: keep, Element_1
- -- | | | | | rhs_item: keep
- -- | | | | | | IDENTIFIER: keep; element name
- -- | BAR: new
- -- | rhs: keep, RHS_2
- -- | | rhs_item_list: keep, rhs_item_list_3
- -- | | | rhs_item_list: new, rhs_item_list_4
- -- | | | | rhs_element: new
- -- | | | | | rhs_item: new
- -- | | | | | | IDENTIFIER: new, list name
- -- | | | rhs_element: keep, alt_list_elements (last)
- -- | | | | rhs_item: keep
- -- | | | | | IDENTIFIER: keep, element name
+ Value : constant String := Get_Text (Data, Tree, Node,
Strip_Quotes => True);
+ Found : constant Node_Index := Find_Nonterminal (Value,
Equal'Unrestricted_Access);
+ begin
+ if Found = Invalid_Node_Index then
+ if GNAT.Regexp.Match (Value, Symbol_Regexp) then
+ Name_Ident := New_Identifier (Ada.Characters.Handling.To_Upper
(Value));
+ else
+ Put_Error
+ (Error_Message
+ (Data.Grammar_Lexer.File_Name, Get_Line (Data, Tree, Node),
+ "punctuation token '" & Value & "' not declared"));
+ return;
+ end if;
+ end if;
+
+ -- Replace string literal in rhs_item
+ declare
+ Parent : constant Valid_Node_Index := Tree.Parent (Node);
+ begin
+ case To_Token_Enum (Tree.ID (Parent)) is
+ when rhs_item_ID =>
+ Tree.Set_Children
+ (Tree.Parent (Node),
+ (+rhs_item_ID, 0),
+ (1 => Tree.Add_Identifier (+IDENTIFIER_ID, Name_Ident,
Tree.Byte_Region (Node))));
+
+ when rhs_optional_item_ID =>
+ Tree.Set_Children
+ (Tree.Parent (Node),
+ (+rhs_optional_item_ID, 2),
+ (Tree.Add_Identifier (+IDENTIFIER_ID, Name_Ident,
Tree.Byte_Region (Node)),
+ Tree.Child (Tree.Parent (Node), 2)));
+
+ when others =>
+ Raise_Programmer_Error ("translate_ebnf_to_bnf string_literal_2
unimplemented", Data, Tree, Node);
+ end case;
+ end;
+
+ Clear_EBNF_Node (Node);
+ if Found /= Invalid_Node_Index then
+ return;
+ end if;
+
+ -- Declare token for keyword string literal
+ declare
+ Keyword : constant Valid_Node_Index := Tree.Add_Identifier
+ (+KEYWORD_ID, Keyword_Ident, Tree.Byte_Region (Node));
+ Kind : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+token_keyword_non_grammar_ID, 0),
+ (1 => Keyword));
+ Value_Literal : constant Valid_Node_Index := Tree.Add_Identifier
+ (+STRING_LITERAL_1_ID, New_Identifier ('"' & Value & '"'),
Tree.Byte_Region (Node));
+ Decl_Item : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+declaration_item_ID, 1),
+ (1 => Value_Literal));
+ Decl_Item_List : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+declaration_item_list_ID, 0),
+ (1 => Decl_Item));
+
+ Percent : constant Valid_Node_Index := Tree.Add_Identifier
+ (+PERCENT_ID, Percent_Ident, Tree.Byte_Region (Node));
+ Name : constant Valid_Node_Index := Tree.Add_Identifier
+ (+IDENTIFIER_ID, Name_Ident, Tree.Byte_Region (Node));
+ Decl : constant Valid_Node_Index := Tree.Add_Nonterm
+ ((+declaration_ID, 0), (Percent, Kind, Name, Decl_Item_List),
Action => declaration_0'Access);
+ begin
+ Add_Compilation_Unit ("literal token", Decl, Prepend => True);
+ end;
+
+ end Translate_Token_Literal;
+
+ procedure Process_Node (Node : in Valid_Node_Index)
+ is begin
+ case To_Token_Enum (Tree.ID (Node)) is
+ -- Token_Enum_ID alphabetical order
+ when declaration_ID =>
+ -- Must be "%meta_syntax EBNF"; change to BNF
+ declare
+ Decl_Item : constant Valid_Node_Index :=
Tree.Find_Descendant
+ (Tree.Child (Node, 3), +declaration_item_ID);
+ Old_Children : constant Valid_Node_Index_Array := Tree.Children
(Decl_Item);
+ New_Children : constant Valid_Node_Index_Array :=
+ (1 => Tree.Add_Identifier
+ (+IDENTIFIER_ID, New_Identifier ("BNF"), Tree.Byte_Region
(Decl_Item)));
+ begin
+ Copy_Non_Grammar (Old_Children (1), New_Children (1));
+ Tree.Set_Children (Decl_Item, (+declaration_item_ID, 1),
New_Children);
+ end;
+ Clear_EBNF_Node (Node);
+
+ when rhs_alternative_list_ID =>
+ -- All handled by New_Nonterminal*
+ raise SAL.Programmer_Error;
+
+ when rhs_attribute_ID =>
+ -- Just delete it
+ declare
+ use WisiToken.Syntax_Trees.LR_Utils;
+ RHS_Item_List : List := Creators.Create_From_Element
+ (Tree, Tree.Parent (Node, 2), +rhs_item_list_ID,
+rhs_element_ID, Invalid_Token_ID);
+ Element : Cursor := RHS_Item_List.To_Cursor (Tree.Parent (Node,
2));
+ begin
+ RHS_Item_List.Delete (Element);
+ end;
+ Clear_EBNF_Node (Node);
+
+ when rhs_group_item_ID =>
+ Translate_RHS_Group_Item (Node);
+
+ when rhs_multiple_item_ID =>
+ Translate_RHS_Multiple_Item (Node);
+
+ when rhs_optional_item_ID =>
+ Translate_RHS_Optional_Item (Node);
+
+ when STRING_LITERAL_2_ID =>
+ Translate_Token_Literal (Node);
+
+ when others =>
+ Raise_Programmer_Error ("unimplemented EBNF node", Data, Tree,
Node);
+ end case;
+ exception
+ when SAL.Programmer_Error =>
+ raise;
+ when E : others =>
+ Raise_Programmer_Error
+ ("unhandled exception " & Ada.Exceptions.Exception_Name (E) & ": " &
+ Ada.Exceptions.Exception_Message (E),
+ Data, Tree, Node);
+ end Process_Node;
+
+ EBNF_Allowed : Boolean := True;
+
+ procedure Validate_Node
+ (Tree : in Syntax_Trees.Tree;
+ Node : in Valid_Node_Index;
+ Node_Image_Output : in out Boolean)
+ is
+ use Ada.Text_IO;
+
+ procedure Put_Error (Msg : in String)
+ is begin
+ if not Node_Image_Output then
+ Node_Image_Output := True;
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Tree, Data.Terminals, Node, Data.Grammar_Lexer.File_Name,
+ Tree.Image
+ (Node, Wisitoken_Grammar_Actions.Descriptor,
+ Include_RHS_Index => True,
+ Include_Children => Trace_Generate_EBNF > Detail,
+ Node_Numbers => True)));
+ end if;
+ Put_Line (Current_Error, "... " & Msg);
+ WisiToken.Generate.Error := True;
+ end Put_Error;
+
+ procedure Check_EBNF_Allowed
+ is begin
+ if not EBNF_Allowed then
+ Put_Error ("no EBNF allowed");
+ end if;
+ end Check_EBNF_Allowed;
+
+ begin
+ if Tree.Label (Node) /= Nonterm then
+ return;
+ end if;
- declare
- List_Name_Node : constant Valid_Node_Index :=
Tree.Find_Ancestor (RHS_2, +nonterminal_ID);
- List_Name_Tok : constant Token_Index :=
Tree.First_Shared_Terminal (List_Name_Node);
- List_Name_Region : constant Buffer_Region :=
Data.Terminals.all (List_Name_Tok).Byte_Region;
- List_Name : constant String :=
Data.Grammar_Lexer.Buffer_Text (List_Name_Region);
-
- RHS_2_Index : constant Integer := Tree.RHS_Index
(RHS_2);
- RHS_2_Children : Valid_Node_Index_Array := Tree.Children
(RHS_2);
-
- RHS_Item_List_1 : constant Valid_Node_Index :=
Tree.Add_Nonterm
- ((+rhs_item_list_ID, 0), (1 => Element_1));
-
- RHS_1_Action : constant Node_Index :=
- (case RHS_2_Index is
- when 2 | 3 => Tree.Add_Terminal
- (Tree.First_Shared_Terminal (RHS_2_Children (2)),
Data.Terminals.all),
- when others => Invalid_Node_Index);
-
- RHS_1_Check : constant Node_Index :=
- (case RHS_2_Index is
- when 3 => Tree.Add_Terminal
- (Tree.First_Shared_Terminal (RHS_2_Children (3)),
Data.Terminals.all),
- when others => Invalid_Node_Index);
-
- RHS_1 : constant Valid_Node_Index :=
- (case RHS_2_Index is
- when 1 => Tree.Add_Nonterm ((+rhs_ID, 1), (1 =>
RHS_Item_List_1)),
- when 2 => Tree.Add_Nonterm ((+rhs_ID, 2), (1 =>
RHS_Item_List_1, 2 => RHS_1_Action)),
- when 3 => Tree.Add_Nonterm
- ((+rhs_ID, 3), (1 => RHS_Item_List_1, 2 =>
RHS_1_Action, 3 => RHS_1_Check)),
- when others => raise SAL.Programmer_Error);
-
- Bar : constant Valid_Node_Index :=
Tree.Add_Terminal (+BAR_ID);
- RHS_Item_List_3 : constant Valid_Node_Index :=
Tree.Child (RHS_2, 1);
- RHS_Item_List_4 : constant Valid_Node_Index :=
Tree.Child (RHS_Item_List_3, 1);
- New_List_Name_Term : constant Valid_Node_Index :=
Tree.Add_Terminal
- (List_Name_Tok, Data.Terminals.all);
- New_List_Name_Item : constant Valid_Node_Index :=
Tree.Add_Nonterm
- ((+rhs_item_ID, 0),
- (1 => New_List_Name_Term));
-
- New_List_Name_Label : constant Node_Index :=
- (if Tree.RHS_Index (Element_1) = 1
- then -- tokens have labels
- Tree.Add_Identifier (+IDENTIFIER_ID, New_Identifier
(List_Name), List_Name_Region)
- else Invalid_Node_Index);
-
- New_List_Name_Element : constant Valid_Node_Index :=
- (if Tree.RHS_Index (Element_1) = 1
- then -- tokens have labels
- Tree.Add_Nonterm
- ((+rhs_element_ID, 1),
- (1 => New_List_Name_Label,
- 2 => Tree.Add_Terminal (+EQUAL_ID),
- 3 => New_List_Name_Item))
- else
- Tree.Add_Nonterm ((+rhs_element_ID, 0), (1 =>
New_List_Name_Item)));
+ declare
+ use all type Ada.Containers.Count_Type;
+ Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
+ RHS_Index : constant Natural := Tree.RHS_Index
(Node);
+ begin
+ case To_Token_Enum (Tree.ID (Node)) is
+ when nonterminal_ID =>
+ null;
- Alt_List_Elements : constant Valid_Node_Index_Array :=
Tree.Get_IDs (Node, +rhs_element_ID);
- RHS_Item_List_2 : constant Node_Index :=
- (if Alt_List_Elements'Last = 1
- then Invalid_Node_Index -- no separator
- else Tree.Add_Nonterm
- ((+rhs_item_list_ID, 1),
- (1 => RHS_Item_List_3,
- 2 => Alt_List_Elements (Alt_List_Elements'Last))));
+ when rhs_list_ID =>
+ case RHS_Index is
+ when 0 =>
+ if Children'Length /= 1 then
+ Put_Error ("expected child_count 1");
+ elsif Tree.ID (Children (1)) /= +rhs_ID then
+ Put_Error ("child 1 not rhs");
+ end if;
- begin
- Tree.Set_Children (RHS_Item_List_4, (+rhs_item_list_ID,
0), (1 => New_List_Name_Element));
-
- Tree.Set_Children
- (RHS_Item_List_3,
- (+rhs_item_list_ID, 1),
- (1 => RHS_Item_List_4,
- 2 => Alt_List_Elements (1)));
-
- RHS_2_Children (1) :=
- (if Alt_List_Elements'Last = 1
- then RHS_Item_List_3 -- no separator
- else RHS_Item_List_2);
- Tree.Set_Children (RHS_2, (+rhs_ID, Tree.RHS_Index
(RHS_2)), RHS_2_Children);
-
- Tree.Set_Children
- (Tree.Parent (RHS_2),
- (+rhs_list_ID, 1),
- (1 => Tree.Add_Nonterm ((+rhs_list_ID, 0), (1 =>
RHS_1)),
- 2 => Bar,
- 3 => RHS_2));
- end;
+ when 1 =>
+ if Tree.Child_Count (Node) /= 3 then
+ Put_Error ("expected child_count 3");
+ elsif Tree.ID (Children (1)) /= +rhs_list_ID or
+ Tree.ID (Children (2)) /= +BAR_ID or
+ Tree.ID (Children (3)) /= +rhs_ID
+ then
+ Put_Error ("expecting rhs_list BAR rhs");
+ end if;
- Done := True;
+ when others =>
+ Put_Error ("unexpected RHS_Index");
+ end case;
- Clear_EBNF_Node (Node);
+ when rhs_ID =>
+ case RHS_Index is
+ when 0 =>
+ if Children'Length /= 0 then
+ Put_Error ("expected child_count 0");
+ end if;
- if Trace_Generate_EBNF > Extra then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("edited rhs_list:");
- Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
Tree.Parent (RHS_2));
+ when 1 =>
+ if Tree.Child_Count (Node) /= 1 then
+ Put_Error ("expected child_count 1");
+ elsif Tree.ID (Children (1)) /= +rhs_item_list_ID then
+ Put_Error ("expecting rhs_item_list");
end if;
- end Check_Canonical_List;
- procedure Find_List_Nonterminal_2 (Element_Content : in String)
- is
- -- Look for a virtual pair of nonterms implementing a list
of Element_Content.
- -- If found, set List_Nonterm_Virtual_Name, List_Element
- Temp : Node_Index := First_List_Element (Tree.Child
(Tree.Root, 1), +compilation_unit_ID);
- Name_Node : Node_Index;
- begin
- loop
- pragma Assert (Tree.ID (Temp) = +compilation_unit_ID);
+ when 2 =>
+ if Tree.Child_Count (Node) /= 2 then
+ Put_Error ("expected child_count 2");
+ elsif Tree.ID (Children (1)) /= +rhs_item_list_ID or
+ Tree.ID (Children (2)) /= +ACTION_ID
+ then
+ Put_Error ("expecting rhs_item_list ACTION");
+ end if;
- if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+nonterminal_ID, 0) and
- Tree.Is_Virtual (Tree.Child (Temp, 1))
- then
- if Element_Content = Get_Text (Data, Tree, Tree.Child
(Tree.Child (Temp, 1), 3)) then
- Name_Node := Tree.Child (Tree.Child (Temp, 1), 1);
- case Tree.Label (Name_Node) is
- when Virtual_Identifier =>
- List_Element := Tree.Identifier (Name_Node);
- when others =>
- Raise_Programmer_Error
- ("unimplemented Find_List_Nonterminal_2 case
'" & Element_Content & "'",
- Data, Tree, Name_Node);
- end case;
-
- -- list nonterm is the next nonterminal
- Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
- Name_Node := Tree.Child (Tree.Child (Temp, 1), 1);
- case Tree.Label (Name_Node) is
- when Virtual_Identifier =>
- List_Nonterm_Virtual_Name := Tree.Identifier
(Name_Node);
- when others =>
- raise SAL.Programmer_Error;
- end case;
- exit;
- end if;
- end if;
+ when 3 =>
+ if Tree.Child_Count (Node) /= 3 then
+ Put_Error ("expected child_count 3");
+ elsif Tree.ID (Children (1)) /= +rhs_item_list_ID or
+ Tree.ID (Children (2)) /= +ACTION_ID or
+ Tree.ID (Children (3)) /= +ACTION_ID
+ then
+ Put_Error ("expecting rhs_item_list ACTION ACTION");
+ end if;
- Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
- exit when Temp = Invalid_Node_Index;
- end loop;
- end Find_List_Nonterminal_2;
+ when others =>
+ Put_Error ("unexpected RHS_Index");
+ end case;
- procedure Find_List_Nonterminal_1 (Element_Content : in String)
- is
- -- Search for a nonterm (virtual or not) implementing a
list for
- -- Element_Content, which is a single rhs_element; no
List_Element
- -- Nonterminal. If found, set List_Nonterm_Virtual_Name or
- -- List_Nonterm_Terminal_Name
- Temp : Node_Index := First_List_Element (Tree.Child
(Tree.Root, 1), +compilation_unit_ID);
- begin
- loop
- pragma Assert (Tree.ID (Temp) = +compilation_unit_ID);
-
- if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+nonterminal_ID, 0) then
- -- Target List_Nonterm is:
- --
- -- nonterminal_nnn_list
- -- : element
- -- | nonterminal_nnn_list element
- --
- -- compilation_unit
- -- | nonterminal
- -- | | IDENTIFIER : list_nonterm
- -- | | COLON
- -- | | rhs_list: rhs_list_1
- -- | | | rhs_list: rhs_list_2
- -- | | | | rhs
- -- | | | | | ... List_element
- -- | | | BAR
- -- | | | rhs: ... list_nonterm list_element
- declare
- Name_Node : constant Node_Index := Tree.Child
(Tree.Child (Temp, 1), 1);
- RHS_List_1 : constant Node_Index := Tree.Child
(Tree.Child (Temp, 1), 3);
- RHS_List_2 : constant Node_Index :=
- (if RHS_List_1 = Invalid_Node_Index
- then Invalid_Node_Index
- else Tree.Child (RHS_List_1, 1));
- begin
- if RHS_List_2 /= Invalid_Node_Index and
- Tree.Child (RHS_List_1, 3) /= Invalid_Node_Index
and -- second rhs present
- Tree.Child (RHS_List_2, 3) = Invalid_Node_Index
-- no third rhs
- then
- declare
- RHS_1 : constant String := Get_Text (Data,
Tree, RHS_List_2);
- RHS_2 : constant String := Get_Text (Data,
Tree, Tree.Child (RHS_List_1, 3));
- Expected_RHS_2 : constant String := Get_Text
(Data, Tree, Name_Node) & " " &
- Element_Content;
- begin
- if Element_Content = RHS_1 and RHS_2 =
Expected_RHS_2 then
- case Tree.Label (Name_Node) is
- when Shared_Terminal =>
- List_Nonterm_Terminal_Name :=
Tree.First_Shared_Terminal (Name_Node);
- when Virtual_Identifier =>
- List_Nonterm_Virtual_Name :=
Tree.Identifier (Name_Node);
- when others =>
- Raise_Programmer_Error
- ("unimplemented
Find_List_Nonterminal_1 case '" & Element_Content & "'",
- Data, Tree, Name_Node);
- end case;
-
- exit;
- end if;
- end;
- end if;
- end;
- end if;
+ when rhs_attribute_ID =>
+ Check_EBNF_Allowed;
- Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
- exit when Temp = Invalid_Node_Index;
- end loop;
- end Find_List_Nonterminal_1;
- begin
- -- Check if this is a recognized pattern
- Check_Canonical_List;
- if Done then return; end if;
+ when rhs_element_ID =>
+ case RHS_Index is
+ when 0 =>
+ if Tree.Child_Count (Node) /= 1 then
+ Put_Error ("expected child_count 1");
+ elsif Tree.ID (Children (1)) /= +rhs_item_ID then
+ Put_Error ("expecting rhs_item");
+ end if;
- -- Check to see if there is an already declared nonterminal
- -- list with the same content; if not, create one.
- case Tree.RHS_Index (Node) is
- when 0 .. 3 =>
- -- { rhs_alternative_list } -?
- -- ( rhs_alternative_list ) [+*]
- if 0 = Tree.RHS_Index (Tree.Child (Node, 2)) and then
- 0 = Tree.RHS_Index (Tree.Child (Tree.Child (Node, 2), 1))
+ when 1 =>
+ if Tree.Child_Count (Node) /= 3 then
+ Put_Error ("expected child_count 3");
+ elsif Tree.ID (Children (1)) /= +IDENTIFIER_ID or
+ Tree.ID (Children (2)) /= +EQUAL_ID or
+ Tree.ID (Children (3)) /= +rhs_item_ID
then
- -- Only one element in the rhs_alternative_list, and in
the rhs_item_list
- Find_List_Nonterminal_1 (Get_Text (Data, Tree, Tree.Child
(Node, 2)));
+ Put_Error ("expecting IDENTIFIER EQUAL rhs_item");
+ end if;
- if List_Nonterm_Virtual_Name = Invalid_Identifier_Index
and
- List_Nonterm_Terminal_Name = Invalid_Token_Index
- then
- List_Nonterm_Virtual_Name := Next_Nonterm_Name
("_list");
- New_Nonterminal_List
- (List_Nonterm_Virtual_Name,
Tree.First_Shared_Terminal (Tree.Child (Node, 2)),
- Data.Terminals.all, Tree.Byte_Region (Node));
- end if;
- else
- Find_List_Nonterminal_2 (Get_Text (Data, Tree, Tree.Child
(Node, 2)));
+ when others =>
+ Put_Error ("unexpected RHS_Index");
+ end case;
- if List_Nonterm_Virtual_Name = Invalid_Identifier_Index
then
- List_Nonterm_Virtual_Name := Next_Nonterm_Name
("_list");
- List_Element := Next_Nonterm_Name;
- New_Nonterminal (List_Element, Tree.Child (Node, 2));
- New_Nonterminal_List (List_Nonterm_Virtual_Name,
List_Element, Tree.Byte_Region (Node));
- end if;
+ when rhs_item_list_ID =>
+ case RHS_Index is
+ when 0 =>
+ if Tree.Child_Count (Node) /= 1 then
+ Put_Error ("expected child_count 1");
+ elsif Tree.ID (Children (1)) /= +rhs_element_ID then
+ Put_Error ("expecting rhs_element");
end if;
- when 4 | 5 =>
- -- IDENTIFIER + | *
- Find_List_Nonterminal_1 (Get_Text (Data, Tree, Tree.Child
(Node, 1)));
-
- if List_Nonterm_Virtual_Name = Invalid_Identifier_Index then
- List_Nonterm_Virtual_Name := Next_Nonterm_Name ("_list");
- New_Nonterminal_List
- (List_Nonterm_Virtual_Name,
- Tree.First_Shared_Terminal (Tree.Child (Node, 1)),
Data.Terminals.all,
- Tree.Byte_Region (Node));
+ when 1 =>
+ if Tree.Child_Count (Node) /= 2 then
+ Put_Error ("expected child_count 2");
+ elsif Tree.ID (Children (1)) /= +rhs_item_list_ID or
+ Tree.ID (Children (2)) /= +rhs_element_ID
+ then
+ Put_Error ("expecting rhs_item_list ELEMENT");
end if;
when others =>
- Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_multiple_item unimplmented", Data, Tree, Node);
+ Put_Error ("unexpected RHS_Index");
end case;
- if Allow_Empty then
- Insert_Optional_RHS (Node);
+ when rhs_item_ID =>
+ if Tree.Child_Count (Node) /= 1 then
+ Put_Error ("expected child_count 1");
end if;
- declare
- Child : constant Valid_Node_Index :=
- (if List_Nonterm_Virtual_Name /= Invalid_Identifier_Index
- then Tree.Add_Identifier
- (+IDENTIFIER_ID, List_Nonterm_Virtual_Name,
Tree.Byte_Region (Parent_RHS_Item))
- elsif List_Nonterm_Terminal_Name /= Invalid_Token_Index
- then Tree.Add_Terminal (List_Nonterm_Terminal_Name,
Data.Terminals.all)
- else raise SAL.Programmer_Error);
- begin
- Tree.Set_Children (Parent_RHS_Item, (+rhs_item_ID, 0), (1 =>
Child));
- end;
-
- Clear_EBNF_Node (Node);
+ case RHS_Index is
+ when 0 =>
+ if Tree.ID (Children (1)) /= +IDENTIFIER_ID then
+ Put_Error ("expecting IDENTIFIER");
+ end if;
- if Trace_Generate_EBNF > Extra then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("edited rhs_item:");
- Tree.Print_Tree (Wisitoken_Grammar_Actions.Descriptor,
Parent_RHS_Item);
- end if;
- exception
- when E : System.Assertions.Assert_Failure =>
- Raise_Programmer_Error
- ("translate_ebnf_to_bnf multiple_item assert: " &
Ada.Exceptions.Exception_Message (E),
- Data, Tree, Node);
- end;
+ when 1 =>
+ if Tree.ID (Children (1)) /= +STRING_LITERAL_2_ID then
+ Put_Error ("expecting STRING_LITERAL_2");
+ end if;
- when rhs_optional_item_ID =>
- -- Source looks like:
- --
- -- | a [b] c
- --
- -- where 'a', 'b', 'c' are token sequences. Translate to:
- --
- -- | a nonterm_b c
- -- | a c
- --
- -- where 'nonterm_b' is a new nonterminal containing b, unless b
is
- -- simple enough to inline.
- --
- -- See nested_ebnf_optional.wy for an example of nested optional
- -- items.
- --
- -- current tree:
- --
- -- | rhs_list:
- -- | | rhs | rhs_alternative_list:
- -- | | | rhs_item_list
- -- | | | | rhs_item_list
- -- | | | ...
- -- | | | | | | rhs_element:
- -- | | | | | | | rhs_item: contains a tail
- -- | | | | | rhs_element:
- -- | | | | | | rhs_item: contains b
- -- | | | | | | | rhs_optional_item: Node
- -- | | | | | | | | LEFT_BRACKET: Node.Children (1)
- -- | | | | | | | | rhs_alternative_item_list: Node.Children (2) b
- -- | | | | | | | | RIGHT_BRACKET: Node.Children (3)
- -- | | | | rhs_element: head of c
- -- | | | | | rhs_item: head of c
+ when 2 =>
+ if Tree.ID (Children (1)) /= +rhs_attribute_ID then
+ Put_Error ("expecting rhs_attribute");
+ end if;
- declare
- Name_Ident : Base_Identifier_Index :=
Invalid_Identifier_Index;
- Name_Terminal : Base_Token_Index := Invalid_Token_Index;
- Name_Label : Base_Token_Index := Invalid_Token_Index;
- Found : Boolean := False;
- begin
- case Tree.RHS_Index (Node) is
- when 0 | 1 =>
- -- : LEFT_BRACKET rhs_alternative_list RIGHT_BRACKET
- -- | LEFT_PAREN rhs_alternative_list RIGHT_PAREN QUESTION
+ when 3 =>
+ if Tree.ID (Children (1)) /= +rhs_optional_item_ID then
+ Put_Error ("expecting rhs_optional_item");
+ end if;
- -- Check for special cases
+ when 4 =>
+ if Tree.ID (Children (1)) /= +rhs_multiple_item_ID then
+ Put_Error ("expecting rhs_multiple_item");
+ end if;
- if List_Singleton (Tree.Child (Node, 2)) then
- if List_Singleton (Tree.Child (Tree.Child (Node, 2), 1))
then
- -- Single item in rhs_alternative_list and
rhs_item_list; just use it.
- --
- -- Single alternative, multiple rhs_items handled
below
- declare
- Name_Element_Node : Valid_Node_Index;
- Name_Identifier_Node : Node_Index;
- begin
- Found := True;
- Name_Element_Node := First_List_Element
- (Tree.Child (Tree.Child (Node, 2), 1),
+rhs_element_ID);
+ when 5 =>
+ if Tree.ID (Children (1)) /= +rhs_group_item_ID then
+ Put_Error ("expecting rhs_group_item");
+ end if;
- if Tree.RHS_Index (Name_Element_Node) = 0 then
- Name_Identifier_Node := Tree.Child (Tree.Child
(Name_Element_Node, 1), 1);
- else
- -- Name has a label
- Name_Label :=
Tree.First_Shared_Terminal (Tree.Child (Name_Element_Node, 1));
- Name_Identifier_Node := Tree.Child (Tree.Child
(Name_Element_Node, 3), 1);
- end if;
+ when others =>
+ Put_Error ("unexpected RHS_Index");
+ end case;
- case Tree.Label (Name_Identifier_Node) is
- when Virtual_Identifier =>
- Name_Ident := Tree.Identifier
(Name_Identifier_Node);
- when Shared_Terminal =>
- Name_Terminal := Tree.First_Shared_Terminal
(Name_Identifier_Node);
- when others =>
- Raise_Programmer_Error ("unhandled rhs_optional
case ", Data, Tree, Name_Identifier_Node);
- end case;
- end;
- end if;
- else
- -- See if we've already created a nonterminal for this.
- declare
- New_Text : constant String := Get_Text
(Data, Tree, Tree.Child (Node, 2));
- Temp : Node_Index :=
First_List_Element
- (Tree.Child (Tree.Root, 1), +compilation_unit_ID);
- Name_Identifier_Node : Node_Index;
- begin
- loop
- pragma Assert (Tree.ID (Temp) =
+compilation_unit_ID);
-
- if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+nonterminal_ID, 0) then
- if New_Text = Get_Text (Data, Tree, Tree.Child
(Tree.Child (Temp, 1), 3)) then
- Found := True;
- Name_Identifier_Node := Tree.Child
(Tree.Child (Temp, 1), 1);
- case Tree.Label (Name_Identifier_Node) is
- when Virtual_Identifier =>
- Name_Ident := Tree.Identifier
(Name_Identifier_Node);
- when others =>
- Raise_Programmer_Error
- ("unhandled rhs_optional case '" &
New_Text & "'",
- Data, Tree, Name_Identifier_Node);
- end case;
- exit;
- end if;
- end if;
+ when rhs_group_item_ID =>
+ Check_EBNF_Allowed;
+ if RHS_Index /= 0 or
+ (Children'Length /= 3 or else
+ (Tree.ID (Children (1)) /= +LEFT_PAREN_ID or
+ Tree.ID (Children (2)) /= +rhs_alternative_list_ID or
+ Tree.ID (Children (3)) /= +RIGHT_PAREN_ID))
+ then
+ Put_Error ("expecting RHS_Index 0, LEFT_PAREN
rhs_alternative_list RIGHT_PAREN");
+ end if;
- Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
- exit when Found or Temp = Invalid_Node_Index;
- end loop;
- end;
+ when rhs_optional_item_ID =>
+ Check_EBNF_Allowed;
+ case RHS_Index is
+ when 0 =>
+ if Children'Length /= 3 or else
+ (Tree.ID (Children (1)) /= +LEFT_BRACKET_ID or
+ Tree.ID (Children (2)) /= +rhs_alternative_list_ID or
+ Tree.ID (Children (3)) /= +RIGHT_BRACKET_ID)
+ then
+ Put_Error ("expecting LEFT_BRACKET rhs_alternative_list
RIGHT_BRACKET");
end if;
- if Found then
- -- Use previously created nonterminal
- if Name_Ident /= Invalid_Identifier_Index then
- Tree.Set_Node_Identifier (Node, +IDENTIFIER_ID,
Name_Ident);
-
- -- Change RHS_Index, delete Check_EBNF action
- Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID,
0), (1 => Node));
-
- elsif Name_Terminal /= Invalid_Token_Index then
- Tree.Set_Children
- (Tree.Parent (Node),
- (+rhs_item_ID, 0),
- (1 => Tree.Add_Terminal (Name_Terminal,
Data.Terminals.all)));
+ when 1 =>
+ if Children'Length /= 4 or else
+ (Tree.ID (Children (1)) /= +LEFT_PAREN_ID or
+ Tree.ID (Children (2)) /= +rhs_alternative_list_ID or
+ Tree.ID (Children (3)) /= +RIGHT_PAREN_ID or
+ Tree.ID (Children (4)) /= +QUESTION_ID)
+ then
+ Put_Error ("expecting LEFT_PAREN rhs_alternative_list
RIGHT_PAREN QUESTION");
+ end if;
- else
- raise SAL.Programmer_Error;
- end if;
+ when 2 =>
+ if Children'Length /= 2 or else
+ (Tree.ID (Children (1)) /= +IDENTIFIER_ID or
+ Tree.ID (Children (2)) /= +QUESTION_ID)
+ then
+ Put_Error ("expecting IDENTIFIER QUESTION");
+ end if;
- if Name_Label /= Invalid_Token_Index then
- declare
- Label_Node : constant Valid_Node_Index :=
Tree.Add_Terminal
- (Name_Label, Data.Terminals.all);
- Equal_Node : constant Valid_Node_Index :=
Tree.Add_Terminal (+EQUAL_ID);
- begin
- Tree.Set_Children
- (Tree.Parent (Tree.Parent (Node)),
- (+rhs_element_ID, 1),
- (1 => Label_Node,
- 2 => Equal_Node,
- 3 => Tree.Parent (Node)));
- end;
- end if;
+ when 3 =>
+ if Children'Length /= 2 or else
+ (Tree.ID (Children (1)) /= +STRING_LITERAL_2_ID or
+ Tree.ID (Children (2)) /= +QUESTION_ID)
+ then
+ Put_Error ("expecting STRING_LITERAL_2 QUESTION");
+ end if;
- else
- -- Create a new nonterm, or handle more special cases
+ when others =>
+ Put_Error ("unexpected RHS_Index");
+ end case;
- if List_Singleton (Tree.Child (Node, 2)) then
- -- Single alternative, multiple rhs_items
- --
- -- No separate nonterminal, so token labels stay in
the same RHS for
- -- actions. Splice together rhs_item_lists a, b, c
- declare
- Root_List_A : constant Valid_Node_Index :=
Tree.Child (Tree.Parent (Node, 3), 1);
- Tail_Element_A : constant Node_Index :=
- (if Root_List_A = Tree.Parent (Node, 2)
- then Invalid_Node_Index -- a is empty
- else Last_List_Element (Root_List_A));
- Root_List_B : constant Valid_Node_Index :=
Tree.Child (Tree.Child (Node, 2), 1);
- Head_Element_B : constant Valid_Node_Index :=
First_List_Element
- (Root_List_B, +rhs_element_ID);
- Tail_Element_B : constant Valid_Node_Index :=
Last_List_Element (Root_List_B);
- Root_List_C : constant Valid_Node_Index :=
List_Root (Tree.Parent (Node, 3));
- Head_Element_C : constant Node_Index :=
Next_List_Element
- (Tree.Parent (Node, 2), +rhs_item_list_ID);
- RHS : constant Valid_Node_Index :=
Tree.Parent (Root_List_C);
- RHS_Children : Valid_Node_Index_Array :=
Tree.Children (RHS);
- begin
- if Tail_Element_A = Invalid_Node_Index and
Head_Element_C = Invalid_Node_Index then
- -- A, C both empty
- RHS_Children (1) := Tree.Child (Root_List_B, 1);
- Tree.Set_Children (RHS, Tree.Production_ID
(RHS), RHS_Children);
-
- elsif Tail_Element_A = Invalid_Node_Index then
- -- A empty, C not empty
- declare
- Parent_B2 : constant Valid_Node_Index :=
Tree.Parent (Tail_Element_B);
- Parent_C : constant Valid_Node_Index :=
Tree.Parent (Head_Element_C);
- begin
- Tree.Set_Children (Parent_C,
(+rhs_item_list_ID, 1), (Parent_B2, Head_Element_C));
- -- Head_Element_C remains the list root.
- end;
-
- elsif Head_Element_C = Invalid_Node_Index then
- -- A not empty, C empty.
- declare
- Parent_A : constant Valid_Node_Index :=
Tree.Parent (Tail_Element_A);
- Parent_B : constant Valid_Node_Index :=
Tree.Parent (Head_Element_B);
- begin
- Tree.Set_Children (Parent_B,
(+rhs_item_list_ID, 1), (Parent_A, Head_Element_B));
- RHS_Children (1) := Root_List_B;
- Tree.Set_Children (RHS, Tree.Production_ID
(RHS), RHS_Children);
- end;
- else
- -- A, C both not empty
- declare
- Parent_A : constant Valid_Node_Index :=
Tree.Parent (Tail_Element_A);
- Parent_B1 : constant Valid_Node_Index :=
Tree.Parent (Head_Element_B);
- Parent_B2 : constant Valid_Node_Index :=
Tree.Parent (Tail_Element_B);
- Parent_C : constant Valid_Node_Index :=
Tree.Parent (Head_Element_C);
- begin
- Tree.Set_Children (Parent_B1,
(+rhs_item_list_ID, 1), (Parent_A, Head_Element_B));
- Tree.Set_Children (Parent_C,
(+rhs_item_list_ID, 1), (Parent_B2, Head_Element_C));
- -- Head_Element_C remains the list root.
- end;
- end if;
+ when rhs_multiple_item_ID =>
+ Check_EBNF_Allowed;
+ case RHS_Index is
+ when 0 =>
+ if Children'Length /= 3 or else
+ (Tree.ID (Children (1)) /= +LEFT_BRACE_ID or
+ Tree.ID (Children (2)) /= +rhs_alternative_list_ID or
+ Tree.ID (Children (3)) /= +RIGHT_BRACE_ID)
+ then
+ Put_Error ("expecting LEFT_BRACE rhs_alternative_list
RIGHT_BRACE");
+ end if;
- if Trace_Generate_EBNF > Extra then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("edited rhs:");
- Tree.Print_Tree
(Wisitoken_Grammar_Actions.Descriptor, RHS);
- end if;
- end;
- else
- declare
- Nonterm_B : constant Identifier_Index :=
Next_Nonterm_Name ("");
- begin
- New_Nonterminal (Nonterm_B, Tree.Child (Node, 2));
- Tree.Set_Node_Identifier (Node, +IDENTIFIER_ID,
Nonterm_B);
- end;
- Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID,
0), (1 => Node));
- end if;
+ when 1 =>
+ if Children'Length /= 4 or else
+ (Tree.ID (Children (1)) /= +LEFT_BRACE_ID or
+ Tree.ID (Children (2)) /= +rhs_alternative_list_ID or
+ Tree.ID (Children (3)) /= +RIGHT_BRACE_ID or
+ Tree.ID (Children (4)) /= +MINUS_ID)
+ then
+ Put_Error ("expecting LEFT_BRACE rhs_alternative_list
RIGHT_BRACE MINUS");
end if;
when 2 =>
- -- | IDENTIFIER QUESTION
- Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID, 0), (1
=> Tree.Child (Node, 1)));
+ if Children'Length /= 4 or else
+ (Tree.ID (Children (1)) /= +LEFT_PAREN_ID or
+ Tree.ID (Children (2)) /= +rhs_alternative_list_ID or
+ Tree.ID (Children (3)) /= +RIGHT_PAREN_ID or
+ Tree.ID (Children (4)) /= +PLUS_ID)
+ then
+ Put_Error ("expecting LEFT_PAREN rhs_alternative_list
RIGHT_PAREN PLUS");
+ end if;
when 3 =>
- -- | STRING_LITERAL_2 QUESTION
- Tree.Set_Children (Tree.Parent (Node), (+rhs_item_ID, 1), (1
=> Tree.Child (Node, 1)));
-
- when others =>
- Raise_Programmer_Error ("translate_ebnf_to_bnf
rhs_optional_item unimplmented", Data, Tree, Node);
- end case;
-
- Clear_EBNF_Node (Node);
+ if Children'Length /= 4 or else
+ (Tree.ID (Children (1)) /= +LEFT_PAREN_ID or
+ Tree.ID (Children (2)) /= +rhs_alternative_list_ID or
+ Tree.ID (Children (3)) /= +RIGHT_PAREN_ID or
+ Tree.ID (Children (4)) /= +STAR_ID)
+ then
+ Put_Error ("expecting LEFT_PAREN rhs_alternative_list
RIGHT_PAREN STAR");
+ end if;
- Insert_Optional_RHS (Node);
- end;
+ when 4 =>
+ if Children'Length /= 2 or else
+ (Tree.ID (Children (1)) /= +IDENTIFIER_ID or
+ Tree.ID (Children (2)) /= +PLUS_ID)
+ then
+ Put_Error ("expecting IDENTIFIER PLUS");
+ end if;
- when STRING_LITERAL_2_ID =>
- declare
- Value : constant String := Get_Text (Data, Tree, Node,
Strip_Quotes => True);
- Name_Ident : Identifier_Index;
- Found : Boolean := False;
- begin
- -- See if Value is already declared
- declare
- Temp : Node_Index := First_List_Element (Tree.Child
(Tree.Root, 1), +compilation_unit_ID);
- Decl : Node_Index;
- begin
- loop
- pragma Assert (Tree.ID (Temp) = +compilation_unit_ID);
+ when 5 =>
+ if Children'Length /= 2 or else
+ (Tree.ID (Children (1)) /= +IDENTIFIER_ID or
+ Tree.ID (Children (2)) /= +STAR_ID)
+ then
+ Put_Error ("expecting IDENTIFIER STAR");
+ end if;
- if Tree.Production_ID (Tree.Child (Temp, 1)) =
(+declaration_ID, 0) then
- Decl := Tree.Child (Temp, 1);
- declare
- Value_Node : constant Valid_Node_Index :=
Tree.Child (Tree.Child (Decl, 4), 1);
- begin
- if Tree.ID (Value_Node) = +declaration_item_ID and
then
- Tree.ID (Tree.Child (Value_Node, 1)) in
- +IDENTIFIER_ID | +STRING_LITERAL_1_ID |
+STRING_LITERAL_2_ID and then
- Value = Get_Text (Data, Tree, Tree.Child
(Value_Node, 1), Strip_Quotes => True)
- then
- Found := True;
- case Tree.Label (Tree.Child (Decl, 3)) is
- when Shared_Terminal =>
- Name_Ident := New_Identifier (Get_Text (Data,
Tree, Tree.Child (Decl, 3)));
- when Virtual_Identifier =>
- Name_Ident := Tree.Identifier (Tree.Child
(Decl, 3));
- when others =>
- raise SAL.Programmer_Error;
- end case;
- end if;
- end;
- end if;
+ when others =>
+ Put_Error ("unexpected RHS_Index");
+ end case;
- Temp := Next_List_Element (Temp,
+compilation_unit_list_ID);
- exit when Temp = Invalid_Node_Index;
- end loop;
- end;
+ when rhs_alternative_list_ID =>
+ Check_EBNF_Allowed;
+ case RHS_Index is
+ when 0 =>
+ if Children'Length /= 1 or else
+ (Tree.ID (Children (1)) /= +rhs_item_list_ID)
+ then
+ Put_Error ("expecting rhs_item_list");
+ end if;
- if not Found then
- if GNAT.Regexp.Match (Value, Symbol_Regexp) then
- Name_Ident := New_Identifier
(Ada.Characters.Handling.To_Upper (Value));
- else
- Put_Error
- (Error_Message
- (Data.Grammar_Lexer.File_Name, Get_Line (Data, Tree,
Node),
- "punctuation token '" & Value & "' not declared"));
- return;
+ when 1 =>
+ if Children'Length /= 3 or else
+ (Tree.ID (Children (1)) /= +rhs_alternative_list_ID or
+ Tree.ID (Children (2)) /= +BAR_ID or
+ Tree.ID (Children (3)) /= +rhs_item_list_ID)
+ then
+ Put_Error ("expecting rhs_alternative_list BAR
rhs_item_list");
end if;
- end if;
+ when others =>
+ Put_Error ("unexpected RHS_Index");
+ end case;
- declare
- Parent : constant Valid_Node_Index := Tree.Parent (Node);
- begin
- case To_Token_Enum (Tree.ID (Parent)) is
- when rhs_item_ID =>
- Tree.Set_Children
- (Tree.Parent (Node),
- (+rhs_item_ID, 0),
- (1 => Tree.Add_Identifier (+IDENTIFIER_ID, Name_Ident,
Tree.Byte_Region (Node))));
-
- when rhs_optional_item_ID =>
- Tree.Set_Children
- (Tree.Parent (Node),
- (+rhs_optional_item_ID, 2),
- (1 => Tree.Add_Identifier (+IDENTIFIER_ID, Name_Ident,
Tree.Byte_Region (Node))));
+ when compilation_unit_ID =>
+ null;
- when others =>
- Raise_Programmer_Error ("translate_ebnf_to_bnf
string_literal_2 unimplemented", Data, Tree, Node);
- end case;
- end;
+ when compilation_unit_list_ID =>
+ null;
- Clear_EBNF_Node (Node);
- if Found then return; end if;
+ when others =>
+ null;
+ end case;
+ end;
+ end Validate_Node;
- -- Declare token for keyword string literal
- declare
- Keyword : constant Valid_Node_Index :=
Tree.Add_Identifier
- (+KEYWORD_ID, Keyword_Ident, Tree.Byte_Region (Node));
- Kind : constant Valid_Node_Index :=
Tree.Add_Nonterm
- ((+token_keyword_non_grammar_ID, 0),
- (1 => Keyword));
- Value_Literal : constant Valid_Node_Index :=
Tree.Add_Identifier
- (+STRING_LITERAL_1_ID, New_Identifier ('"' & Value & '"'),
Tree.Byte_Region (Node));
- Decl_Item : constant Valid_Node_Index :=
Tree.Add_Nonterm
- ((+declaration_item_ID, 1),
- (1 => Value_Literal));
- Decl_Item_List : constant Valid_Node_Index :=
Tree.Add_Nonterm
- ((+declaration_item_list_ID, 0),
- (1 => Decl_Item));
-
- Percent : constant Valid_Node_Index := Tree.Add_Identifier
- (+PERCENT_ID, Percent_Ident, Tree.Byte_Region (Node));
- Name : constant Valid_Node_Index := Tree.Add_Identifier
- (+IDENTIFIER_ID, Name_Ident, Tree.Byte_Region (Node));
- Decl : constant Valid_Node_Index := Tree.Add_Nonterm
- ((+declaration_ID, 0), (Percent, Kind, Name,
Decl_Item_List), Action => declaration_0'Access);
- begin
- Add_Compilation_Unit (Decl, Prepend => True);
- end;
- end;
+ procedure Check_Original_EBNF
+ is
+ use Ada.Text_IO;
+ Sub_Tree_Root : Node_Index;
+ begin
+ for N in Data.EBNF_Nodes.First_Index .. Data.EBNF_Nodes.Last_Index
loop
+ if Data.EBNF_Nodes (N) then
+ Sub_Tree_Root := Tree.Sub_Tree_Root (N);
+ if Sub_Tree_Root /= Tree.Root then
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Tree, Data.Terminals, N, Data.Grammar_Lexer.File_Name,
+ Tree.Image
+ (N, Wisitoken_Grammar_Actions.Descriptor,
+ Node_Numbers => True)));
+ Put_Line (Current_Error, "... not in tree; in root" &
Sub_Tree_Root'Image);
+ WisiToken.Generate.Error := True;
+ end if;
+ end if;
+ end loop;
+ end Check_Original_EBNF;
- when others =>
- Raise_Programmer_Error ("unimplemented EBNF node", Data, Tree,
Node);
- end case;
- exception
- when SAL.Programmer_Error =>
- raise;
- when E : others =>
- Raise_Programmer_Error
- ("unhandled exception " & Ada.Exceptions.Exception_Name (E) & ": " &
- Ada.Exceptions.Exception_Message (E),
- Data, Tree, Node);
- end Process_Node;
+ procedure Check_Copied_EBNF
+ is
+ use Ada.Text_IO;
+ Sub_Tree_Root : Node_Index;
+ begin
+ for N of Copied_EBNF_Nodes loop
+ if N /= Deleted_Child then
+ Sub_Tree_Root := Tree.Sub_Tree_Root (N);
+ if Sub_Tree_Root /= Tree.Root then
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Tree, Data.Terminals, N, Data.Grammar_Lexer.File_Name,
+ Tree.Image
+ (N, Wisitoken_Grammar_Actions.Descriptor,
+ Node_Numbers => True)));
+ Put_Line (Current_Error, "... not in tree; in root" &
Sub_Tree_Root'Image);
+ WisiToken.Generate.Error := True;
+ end if;
+ end if;
+ end loop;
+ end Check_Copied_EBNF;
begin
-- Process nodes in node increasing order, so contained items are
-- translated first, so duplicates of the containing item can be found
for I in Data.EBNF_Nodes.First_Index .. Data.EBNF_Nodes.Last_Index loop
if Data.EBNF_Nodes (I) then
+ if Trace_Generate_EBNF > Outline then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line
+ ("translate original node " & Tree.Image
+ (I, Wisitoken_Grammar_Actions.Descriptor,
+ Include_RHS_Index => True,
+ Node_Numbers => True));
+ end if;
+
Process_Node (I);
+
+ Tree.Validate_Tree
+ (Data.Terminals, Wisitoken_Grammar_Actions.Descriptor,
Data.Grammar_Lexer.File_Name, Tree.Root,
+ Validate_Node'Unrestricted_Access);
+ Check_Original_EBNF;
+ Check_Copied_EBNF;
end if;
end loop;
- -- Processing copied nodes may produce more copied nodes, so we can't
- -- use a 'for' loop.
declare
- use all type SAL.Base_Peek_Type;
+ use Ada.Text_IO;
+ begin
+ for Node in Data.EBNF_Nodes.First_Index .. Data.EBNF_Nodes.Last_Index
loop
+ if Data.EBNF_Nodes (Node) then
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Tree, Data.Terminals, Node, Data.Grammar_Lexer.File_Name,
+ Tree.Image
+ (Node, Wisitoken_Grammar_Actions.Descriptor,
+ Include_RHS_Index => True,
+ Include_Children => Trace_Generate_EBNF > Detail,
+ Node_Numbers => True)));
+ Put_Line (Current_Error, "... original EBNF node not
translated");
+ end if;
+ end loop;
+ end;
+
+ declare
I : SAL.Base_Peek_Type := Copied_EBNF_Nodes.First_Index;
begin
+ -- Processing copied nodes may produce more copied nodes, so we can't
+ -- use a 'for' loop.
loop
exit when I > Copied_EBNF_Nodes.Last_Index;
- Process_Node (Copied_EBNF_Nodes (I));
+ if Copied_EBNF_Nodes (I) = Deleted_Child then
+ -- Deleted
+ if Trace_Generate_EBNF > Outline then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line
+ ("skipping deleted copied node " & Tree.Image
+ (Copied_EBNF_Nodes (I),
Wisitoken_Grammar_Actions.Descriptor,
+ Include_RHS_Index => True,
+ Node_Numbers => True));
+ end if;
+ else
+ if Trace_Generate_EBNF > Outline then
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line
+ ("translate copied node " & Tree.Image
+ (Copied_EBNF_Nodes (I),
Wisitoken_Grammar_Actions.Descriptor,
+ Include_RHS_Index => True,
+ Node_Numbers => True));
+ end if;
+
+ Process_Node (Copied_EBNF_Nodes (I));
+
+ Tree.Validate_Tree
+ (Data.Terminals, Wisitoken_Grammar_Actions.Descriptor,
Data.Grammar_Lexer.File_Name, Tree.Root,
+ Validate_Node'Unrestricted_Access);
+ Check_Copied_EBNF;
+ end if;
I := I + 1;
end loop;
end;
+ declare
+ use Ada.Text_IO;
+ begin
+ for Node of Copied_EBNF_Nodes loop
+ if Node /= Deleted_Child then
+ Put_Line
+ (Current_Error,
+ Error_Message
+ (Tree, Data.Terminals, Node, Data.Grammar_Lexer.File_Name,
+ Tree.Image
+ (Node, Wisitoken_Grammar_Actions.Descriptor,
+ Include_RHS_Index => True,
+ Include_Children => Trace_Generate_EBNF > Detail,
+ Node_Numbers => True)));
+ Put_Line (Current_Error, "... copied EBNF node not translated");
+ end if;
+ end loop;
+ end;
+
+ EBNF_Allowed := False;
+ Tree.Validate_Tree
+ (Data.Terminals, Wisitoken_Grammar_Actions.Descriptor,
Data.Grammar_Lexer.File_Name, Tree.Root,
+ Validate_Node'Unrestricted_Access);
+
Data.Meta_Syntax := BNF_Syntax;
if Trace_Generate_EBNF > Detail then
@@ -2630,7 +3185,10 @@ package body WisiToken_Grammar_Runtime is
when others =>
New_Line (File);
Put (File, " ;; not translated: " & Node_Index'Image (Node) & ":" &
- Tree.Image (Node, Wisitoken_Grammar_Actions.Descriptor,
Include_Children => True));
+ Tree.Image (Node, Wisitoken_Grammar_Actions.Descriptor,
+ Include_Children => True,
+ Include_RHS_Index => True,
+ Node_Numbers => True));
end case;
exception
when SAL.Programmer_Error =>
@@ -2880,5 +3438,5 @@ package body WisiToken_Grammar_Runtime is
end WisiToken_Grammar_Runtime;
-- Local Variables:
--- ada-which-func-parse-size: 30000
+-- ada-which-func-parse-size: 50000
-- End:
diff --git a/wisitoken_grammar_runtime.ads b/wisitoken_grammar_runtime.ads
index 082e26e..a9de950 100644
--- a/wisitoken_grammar_runtime.ads
+++ b/wisitoken_grammar_runtime.ads
@@ -22,6 +22,7 @@ with WisiToken.BNF;
with WisiToken.Lexer;
with WisiToken.Syntax_Trees;
with Wisitoken_Grammar_Actions;
+with WisiToken.Syntax_Trees.LR_Utils;
package WisiToken_Grammar_Runtime is
type Meta_Syntax is (Unknown, BNF_Syntax, EBNF_Syntax);
@@ -50,7 +51,7 @@ package WisiToken_Grammar_Runtime is
-- Other - everything else
Meta_Syntax : WisiToken_Grammar_Runtime.Meta_Syntax := Unknown;
- Terminals : WisiToken.Base_Token_Array_Access;
+ Terminals : WisiToken.Base_Token_Array_Access_Constant;
Raw_Code : WisiToken.BNF.Raw_Code;
Language_Params : WisiToken.BNF.Language_Param_Type;
Tokens : aliased WisiToken.BNF.Tokens;
@@ -90,7 +91,7 @@ package WisiToken_Grammar_Runtime is
procedure Set_Lexer_Terminals
(User_Data : in out User_Data_Type;
Lexer : in WisiToken.Lexer.Handle;
- Terminals : in WisiToken.Base_Token_Array_Access);
+ Terminals : in WisiToken.Base_Token_Array_Access_Constant);
overriding procedure Reset (Data : in out User_Data_Type);
@@ -123,12 +124,30 @@ package WisiToken_Grammar_Runtime is
Tree : in WisiToken.Syntax_Trees.Tree;
Tokens : in WisiToken.Valid_Node_Index_Array);
+ function Image_Grammar_Action (Action : in
WisiToken.Syntax_Trees.Semantic_Action) return String;
+ -- For Syntax_Trees.Print_Tree.
+
procedure Check_EBNF
(User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
Tree : in WisiToken.Syntax_Trees.Tree;
Tokens : in WisiToken.Valid_Node_Index_Array;
Token : in WisiToken.Positive_Index_Type);
+ procedure Raise_Programmer_Error
+ (Label : in String;
+ Data : in User_Data_Type;
+ Tree : in WisiToken.Syntax_Trees.Tree;
+ Node : in WisiToken.Node_Index);
+ pragma No_Return (Raise_Programmer_Error);
+
+ function Find_Declaration
+ (Data : in User_Data_Type;
+ Tree : in out WisiToken.Syntax_Trees.Tree;
+ Name : in String)
+ return WisiToken.Node_Index;
+ -- Return the node that declares Name, Invalid_Node_Index if none.
+ -- The node is either a declaration or a nonterminal.
+
procedure Translate_EBNF_To_BNF
(Tree : in out WisiToken.Syntax_Trees.Tree;
Data : in out User_Data_Type);
- [elpa] externals/wisi abbb0c2 19/35: Release wisi 1.1.4, ada-mode 5.2.1, (continued)
- [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, 2020/11/28
- [elpa] externals/wisi 1dc8c19 12/35: release ada-mode 5.1.7, wisi 1.1.0; minor format changes in ada-ref-man (take 2), Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 5934bfc 06/35: release ada-mode 5.1.0, wisi 1.0.1, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi d9cd208 32/35: In ada-mode, release 7.1.3; in wisi, release 3.1.2,
Stefan Monnier <=
- [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