[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] master 8676dbc: In ada-mode, release 7.1.3; in wisi, release 3.1.
|
From: |
Stephen Leake |
|
Subject: |
[elpa] master 8676dbc: In ada-mode, release 7.1.3; in wisi, release 3.1.2 |
|
Date: |
Thu, 4 Jun 2020 18:40:19 -0400 (EDT) |
branch: master
commit 8676dbc81ffae976fd948f2478e1398d93a9105c
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
---
packages/ada-mode/NEWS | 39 +
packages/ada-mode/README | 3 +-
packages/ada-mode/ada-compiler-gnat.el | 2 +-
packages/ada-mode/ada-core.el | 14 +-
packages/ada-mode/ada-mode.el | 80 +-
packages/ada-mode/ada-mode.info | 87 +-
packages/ada-mode/ada-mode.texi | 24 +-
packages/ada-mode/ada-process.el | 4 +-
packages/ada-mode/ada.wy | 71 +-
packages/ada-mode/ada_lr1_parse_table.txt.gz | Bin 5209667 -> 5209667
bytes
packages/ada-mode/ada_process_actions.adb | 18 +-
packages/ada-mode/ada_process_actions.ads | 12 +-
packages/ada-mode/ada_process_lalr_main.adb | 6 +-
packages/ada-mode/ada_process_lalr_main.ads | 2 +-
packages/ada-mode/ada_process_lr1_main.adb | 6 +-
packages/ada-mode/ada_process_lr1_main.ads | 2 +-
packages/ada-mode/ada_re2c.c | 2 +-
packages/ada-mode/ada_re2c_c.ads | 2 +-
packages/ada-mode/gpr-query.el | 3 +
.../ada-mode/wisi-ada-format_parameter_list.adb | 48 +-
packages/ada-mode/wisi-ada.adb | 4 +-
packages/ada-mode/wisi-ada.ads | 2 +-
packages/wisi/NEWS | 17 +
packages/wisi/README | 6 +-
packages/wisi/wisi-prj.el | 8 +-
packages/wisi/wisi.adb | 50 +-
packages/wisi/wisi.ads | 15 +-
packages/wisi/wisi.el | 13 +-
packages/wisi/wisi.info | 2 +-
packages/wisi/wisi.texi | 4 +-
packages/wisi/wisitoken-bnf-generate.adb | 113 +-
packages/wisi/wisitoken-bnf-generate_packrat.adb | 6 +-
packages/wisi/wisitoken-bnf-generate_utils.adb | 35 +-
packages/wisi/wisitoken-followed_by.adb | 207 ++
packages/wisi/wisitoken-generate.adb | 102 +-
.../wisi/wisitoken-parse-lr-mckenzie_recover.adb | 2 +-
packages/wisi/wisitoken-parse-lr-parser.adb | 21 +-
.../wisi/wisitoken-parse-lr-parser_no_recover.adb | 21 +-
.../wisi/wisitoken-parse-packrat-procedural.adb | 13 +-
packages/wisi/wisitoken-syntax_trees-lr_utils.adb | 887 +++++-
packages/wisi/wisitoken-syntax_trees-lr_utils.ads | 437 ++-
packages/wisi/wisitoken-syntax_trees.adb | 521 +++-
packages/wisi/wisitoken-syntax_trees.ads | 222 +-
packages/wisi/wisitoken-to_tree_sitter.adb | 528 ++++
packages/wisi/wisitoken-user_guide.info | 120 +-
packages/wisi/wisitoken.ads | 23 +-
packages/wisi/wisitoken_grammar_runtime.adb | 3032 ++++++++++++--------
packages/wisi/wisitoken_grammar_runtime.ads | 23 +-
48 files changed, 4987 insertions(+), 1872 deletions(-)
diff --git a/packages/ada-mode/NEWS b/packages/ada-mode/NEWS
index 5b03ceb..217aab3 100644
--- a/packages/ada-mode/NEWS
+++ b/packages/ada-mode/NEWS
@@ -6,6 +6,45 @@ Please send ada-mode bug reports to bug-gnu-emacs@gnu.org, with
'ada-mode' in the subject. If possible, use M-x report-emacs-bug.
+* Ada Mode 7.1.3
+
+** Indentation of 'is' in expression functions is restored to 7.0.1
+ behavior.
+
+** wisi-get-identifier (used by wisi-goto-spec/body and others) sets
+ completion delimiters appropriately. When using gpr-query, for a
+ procedure declared as:
+
+ package Package_Name is
+ procedure Procedure_Name (args);
+
+ the completion string looks like:
+
+ Procedure_Name(args)<Package_Name<line>>
+
+ so for example you can type "iterate<wisitok" to complete on
+ WisiToken iterators, or "add(Data" to complete on all subprograms
+ whose name starts with "add" and whose first argument starts with
+ "Data".
+
+** New constant ada-declaration-nonterms holds the Ada nonterminal
+ identifiers, for use with wisi-cache-nonterm.
+
+** ada-which-function is now a command (can be invoked by M-x); useful
+ when you don't want which-function-mode turned on, but want to know
+ what function point is in.
+
+* Ada Mode 7.1.2
+20 May 2020
+
+** Revert change in indent of 'is' in expression_function_declaration
+ to 7.0.1 behavior.
+
+* Ada Mode 7.1.1
+14 May 2020
+
+** packaging bug fix
+
* Ada Mode 7.1
11 May 2020
diff --git a/packages/ada-mode/README b/packages/ada-mode/README
index 85bb4de..9035cce 100644
--- a/packages/ada-mode/README
+++ b/packages/ada-mode/README
@@ -1,4 +1,4 @@
-Emacs Ada mode version 7.1.0
+Emacs Ada mode version 7.1.3
Ada mode provides auto-casing, fontification, navigation, and
indentation for Ada source code files.
@@ -34,4 +34,3 @@ Ada mode uses project files to define large (multi-directory)
projects, and to define casing exceptions.
See ada-mode.info for help on using and customizing Ada mode.
-
diff --git a/packages/ada-mode/ada-compiler-gnat.el
b/packages/ada-mode/ada-compiler-gnat.el
index beaa9cd..a19fcda 100644
--- a/packages/ada-mode/ada-compiler-gnat.el
+++ b/packages/ada-mode/ada-compiler-gnat.el
@@ -83,7 +83,7 @@ For `compilation-filter-hook'."
;; We don't want 'next-error' to always go to secondary
;; references, so we _don't_ set 'compilation-message text
;; property. Instead, we set 'ada-secondary-error, so
- ;; `ada-goto-secondary-error' will handle it. We also set
+ ;; `ada-show-secondary-error' will handle it. We also set
;; fonts, so the user can see the reference.
;; typical secondary references look like:
diff --git a/packages/ada-mode/ada-core.el b/packages/ada-mode/ada-core.el
index d6ca3d5..85c1787 100644
--- a/packages/ada-mode/ada-core.el
+++ b/packages/ada-mode/ada-core.el
@@ -63,7 +63,11 @@ Called by `syntax-propertize', which is called by font-lock
in
"Goto start of declarative region containing point."
(interactive)
(wisi-validate-cache (point-min) (point-max) t 'navigate)
-
+ (push-mark)
+ (when (looking-back "declare" (line-beginning-position))
+ ;; We just did ada-goto-declarative-region-start to get here; we
+ ;; want the next one up.
+ (backward-word 1))
(let ((done nil)
(start-pos (point))
(outermost nil)
@@ -84,14 +88,16 @@ Called by `syntax-propertize', which is called by font-lock
in
(if (ada-declarative-region-start-p cache)
(if (< (point) start-pos)
+ ;; found it.
(progn
- (forward-word);; past 'is'
+ (forward-word);; past 'is' or 'declare'.
(setq done t))
;; test/ada_mode-nominal.adb function F2
;;
- ;; start-point is in a formal_part or aspect_clause; we
- ;; want the next level up.
+ ;; start-point is in a subprogram_declarator,
+ ;; formal_part, aspect_clause, etc; code that contains a
+ ;; declarative part. We want the next level up.
(if outermost
;; there is no next level up; add the use_clause in the
context_clause.
(progn
diff --git a/packages/ada-mode/ada-mode.el b/packages/ada-mode/ada-mode.el
index bdf74ef..369c1a0 100644
--- a/packages/ada-mode/ada-mode.el
+++ b/packages/ada-mode/ada-mode.el
@@ -6,8 +6,8 @@
;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
;; Keywords: languages
;; ada
-;; Version: 7.1.2
-;; package-requires: ((uniquify-files "1.0.1") (wisi "3.1.1") (emacs "25.0"))
+;; Version: 7.1.3
+;; package-requires: ((uniquify-files "1.0.1") (wisi "3.1.2") (emacs "25.0"))
;; url: http://www.nongnu.org/ada-mode/
;;
;; This file is part of GNU Emacs.
@@ -117,7 +117,7 @@
(defun ada-mode-version ()
"Return Ada mode version."
(interactive)
- (let ((version-string "7.1.2"))
+ (let ((version-string "7.1.3"))
(if (called-interactively-p 'interactive)
(message version-string)
version-string)))
@@ -520,6 +520,37 @@ The extensions should include a `.' if needed.")
"Alist used by `find-file' to find the name of the other package.
See `ff-other-file-alist'.")
+(defconst ada-declaration-nonterms
+ '(
+ abstract_subprogram_declaration
+ entry_body
+ entry_declaration
+ expression_function_declaration
+ full_type_declaration
+ generic_instantiation
+ generic_package_declaration
+ generic_subprogram_declaration
+ null_procedure_declaration
+ object_declaration
+ package_body
+ package_declaration
+ pragma_g
+ private_extension_declaration
+ private_type_declaration
+ protected_body
+ protected_type_declaration
+ single_protected_declaration
+ single_task_declaration
+ subprogram_body
+ subprogram_declaration
+ subprogram_renaming_declaration
+ subtype_declaration
+ task_body
+ task_type_declaration
+ use_clause
+ )
+ "wisi-cache nonterminal symbols that are Ada declarations.")
+
(defconst ada-parent-name-regexp
"\\([[:alnum:]_\\.]+\\)\\.[[:alnum:]_]+"
"Regexp for extracting the parent name from fully-qualified name.")
@@ -585,6 +616,7 @@ See `ff-other-file-alist'.")
(defun ada-which-function (&optional include-type)
"Return name of subprogram/task/package containing point.
Also sets ff-function-name for ff-pre-load-hook."
+ (interactive) ;; because which-function-mode does not provide which-function
to call intermittently!
;; Fail gracefully and silently, since this could be called from
;; which-function-mode.
(let ((parse-begin (max (point-min) (- (point) (/ ada-which-func-parse-size
2))))
@@ -648,6 +680,8 @@ Also sets ff-function-name for ff-pre-load-hook."
(task_body
(setq result (ada-which-function-1 "task" nil)))
))
+ (when (called-interactively-p 'interactive)
+ (message result))
result)))
(error "")))
))
@@ -818,13 +852,19 @@ compiler-specific compilation filters."
;; doesn't change, at least on Windows.
(let ((start-buffer (current-buffer))
pos item file)
- ;; We use `pop-to-buffer', not `set-buffer', so `forward-line'
- ;; works. But that might eat an `other-frame-window-mode' prefix,
- ;; which the user means to apply to ’ada-goto-source’ below;
- ;; disable that temporarily.
+ ;; We use `pop-to-buffer', not `set-buffer', so point is correct
+ ;; for the current window showing compilation-last-buffer, and
+ ;; moving point in that window works. But that might eat an
+ ;; `other-frame-window-mode' prefix, which the user means to apply
+ ;; to ’ada-goto-source’ below; disable that temporarily.
(let ((display-buffer-overriding-action nil))
(pop-to-buffer compilation-last-buffer nil t)
(setq pos (next-single-property-change (point) 'ada-secondary-error))
+ (unless pos
+ ;; probably at end of compilation-buffer, in new compile
+ (goto-char (point-min))
+ (setq pos (next-single-property-change (point) 'ada-secondary-error)))
+
(when pos
(setq item (get-text-property pos 'ada-secondary-error))
;; file-relative-name handles absolute Windows paths from
@@ -834,8 +874,7 @@ compiler-specific compilation filters."
;; Set point in compilation buffer past this secondary error, so
;; user can easily go to the next one.
- (goto-char pos)
- (forward-line 1))
+ (goto-char (next-single-property-change (1+ pos) 'ada-secondary-error)))
(pop-to-buffer start-buffer nil t);; for windowing history
)
@@ -850,10 +889,8 @@ compiler-specific compilation filters."
(defun ada-goto-declaration-start-1 (include-type)
"Subroutine of `ada-goto-declaration-start'."
(let ((start (point))
- (cache (wisi-get-cache (point)))
+ (cache (or (wisi-get-cache (point)) (wisi-backward-cache)))
(done nil))
- (unless cache
- (setq cache (wisi-backward-cache)))
;; cache is null at bob
(while (not done)
(if cache
@@ -888,7 +925,7 @@ compiler-specific compilation filters."
(eq (wisi-cache-token cache) 'TASK))
))
- (unless (< start (wisi-cache-end cache))
+ (unless (<= start (wisi-cache-end cache))
;; found declaration does not include start; find containing one.
(setq done nil))
(unless done
@@ -1120,13 +1157,13 @@ Must match wisi-ada.ads Language_Protocol_Version.")
))
(defconst ada-wisi-named-begin-regexp
- "\\bfunction\\b\\|\\bpackage\\b\\|\\bprocedure\\b\\|\\btask\\b"
+ "\\_<function\\_>\\|\\_<package\\_>\\|\\_<procedure\\_>\\|\\_<task\\_>"
)
(defconst ada-wisi-partial-begin-regexp
- (concat "\\bbegin\\b\\|\\bdeclare\\b\\|"
+ (concat "\\_<begin\\_>\\|\\_<declare\\_>\\|"
ada-wisi-named-begin-regexp
- "\\|\\bend;\\|\\bend " ada-name-regexp ";"))
+ "\\|\\_<end;\\|\\_<end " ada-name-regexp ";"))
(defconst ada-wisi-partial-end-regexp
(concat ada-wisi-partial-begin-regexp
@@ -1149,13 +1186,18 @@ Must match wisi-ada.ads Language_Protocol_Version.")
;; begin
;; Foo;
;;
- ;; Inserting new line after 'Foo;'; if we include 'begin', there
- ;; is no error (begin starts a statement), and the indent is
- ;; computed incorrectly.
+ ;; Inserting new line after 'Foo;'; if we include 'begin' but not
+ ;; 'end;', there is no error (begin starts a statement), and the
+ ;; indent is computed incorrectly, because it is assumed that the
+ ;; line containing 'end;' is indented correctly.
;;
;; This is handled by the set of keywords in
;; ada-wisi-partial-begin-regexp.
(cond
+ ((looking-at "[ \t]*\\_<begin\\_>")
+ ;; indenting 'begin'; best option is to assume it is indented properly
+ (point))
+
((wisi-search-backward-skip
ada-wisi-partial-begin-regexp
(lambda () (or (wisi-in-string-or-comment-p)
diff --git a/packages/ada-mode/ada-mode.info b/packages/ada-mode/ada-mode.info
index 354b664..b5ecdfd 100644
--- a/packages/ada-mode/ada-mode.info
+++ b/packages/ada-mode/ada-mode.info
@@ -25,7 +25,7 @@ File: ada-mode.info, Node: Top, Next: Overview, Prev:
(dir), Up: (dir)
Top
***
-Ada Mode Version 7.1.0
+Ada Mode Version 7.1.3
* Menu:
@@ -221,7 +221,7 @@ below assume that the compiler is installed at '$prefix',
e.g.
If you are running Windows, use mingw64 'bash' to run these commands.
On linux, some versions of the 'GNATCOLL.iconv' package (used by
-'gpr_query', but not the parser) explicity require the 'libiconv.so'
+'gpr_query', but not the parser) explicitly require the 'libiconv.so'
library. GNAT provides the 'libiconv.so' library in
'<gnat>/lib64/libiconv.so'. On Debian, that directory is not in the
standard load path, and iconv is provided by glibc, so 'libiconv.so' is
@@ -1519,7 +1519,18 @@ few letters of an identifier, and then loop through all
the possible
completions.
'complete-symbol' completes on all the symbols defined in the current
-project, as returned by 'gpr_query'.
+project, as returned by 'gpr_query'. For a procedure declared as:
+
+ package Package_Name is
+ procedure Procedure_Name (args);
+
+ the completion string looks like:
+
+ Procedure_Name(args)<Package_Name<line>>
+
+ so for example you can type "iterate<wisitok" to complete on
+WisiToken iterators, or "add(Data" to complete on all subprograms whose
+name starts with "add" and whose first argument starts with "Data".
If you have bound 'hippie-expand', that also uses 'dabbrev-expand'.
@@ -2549,41 +2560,41 @@ Node: Why not LSP?3948
Node: Installation4704
Node: Ada Reference Manual5670
Node: Ada executables5931
-Node: Building GNATCOLL8284
-Node: Building the executables9179
-Node: Customization9997
-Node: Slow response10497
-Node: Non-standard file names12223
-Node: Other compiler14102
-Node: Other cross-reference14677
-Node: Other customization15400
-Node: Compiling Executing19391
-Node: Compile commands20114
-Node: Compiling Examples22806
-Node: No project files23638
-Node: Set compiler options28954
-Node: Set source search path31007
-Node: Use wisi project file33244
-Node: Use multiple GNAT project files36851
-Node: Use a Makefile41696
-Node: Compiler errors43347
-Node: Project files44164
-Node: Project file overview45216
-Node: Project file variables45758
-Node: Moving Through Ada Code49198
-Node: Identifier completion52230
-Node: Indentation54028
-Node: Statement skeletons57557
-Node: Aligning code59200
-Node: Automatic casing60145
-Node: Comment Handling62332
-Node: Key summary62851
-Node: Developer overview65581
-Node: Directory structure65910
-Node: ELPA68597
-Node: Savannah69234
-Node: ada-france69586
-Node: GNU Free Documentation License69825
+Node: Building GNATCOLL8285
+Node: Building the executables9180
+Node: Customization9998
+Node: Slow response10498
+Node: Non-standard file names12224
+Node: Other compiler14103
+Node: Other cross-reference14678
+Node: Other customization15401
+Node: Compiling Executing19392
+Node: Compile commands20115
+Node: Compiling Examples22807
+Node: No project files23639
+Node: Set compiler options28955
+Node: Set source search path31008
+Node: Use wisi project file33245
+Node: Use multiple GNAT project files36852
+Node: Use a Makefile41697
+Node: Compiler errors43348
+Node: Project files44165
+Node: Project file overview45217
+Node: Project file variables45759
+Node: Moving Through Ada Code49199
+Node: Identifier completion52231
+Node: Indentation54420
+Node: Statement skeletons57949
+Node: Aligning code59592
+Node: Automatic casing60537
+Node: Comment Handling62724
+Node: Key summary63243
+Node: Developer overview65973
+Node: Directory structure66302
+Node: ELPA68989
+Node: Savannah69626
+Node: ada-france69978
+Node: GNU Free Documentation License70217
End Tag Table
diff --git a/packages/ada-mode/ada-mode.texi b/packages/ada-mode/ada-mode.texi
index 313e8e4..5c39cb8 100644
--- a/packages/ada-mode/ada-mode.texi
+++ b/packages/ada-mode/ada-mode.texi
@@ -25,7 +25,7 @@ developing GNU and promoting software freedom.''
@titlepage
@sp 10
-@title Ada Mode Version 7.1.0
+@title Ada Mode Version 7.1.3
@page
@vskip 0pt plus 1filll
@insertcopying
@@ -37,7 +37,7 @@ developing GNU and promoting software freedom.''
@node Top, Overview, (dir), (dir)
@top Top
-Ada Mode Version 7.1.0
+Ada Mode Version 7.1.3
@end ifnottex
@menu
@@ -228,7 +228,7 @@ on the @code{PATH}. If you are running Windows, use mingw64
@code{bash} to run these commands.
On linux, some versions of the @code{GNATCOLL.iconv} package (used by
-@code{gpr_query}, but not the parser) explicity
+@code{gpr_query}, but not the parser) explicitly
require the @file{libiconv.so} library. GNAT provides the
@file{libiconv.so} library in @file{<gnat>/lib64/libiconv.so}. On
Debian, that directory is not in the standard load path, and iconv is
@@ -1610,7 +1610,23 @@ few letters of an identifier, and then loop through all
the possible
completions.
@code{complete-symbol} completes on all the symbols defined in the
-current project, as returned by @code{gpr_query}.
+current project, as returned by @code{gpr_query}. For a
+procedure declared as:
+
+@example
+package Package_Name is
+ procedure Procedure_Name (args);
+@end example
+
+the completion string looks like:
+
+@example
+Procedure_Name(args)<Package_Name<line>>
+@end example
+
+so for example you can type "iterate<wisitok" to complete on WisiToken
+iterators, or "add(Data" to complete on all subprograms whose name
+starts with "add" and whose first argument starts with "Data".
If you have bound @code{hippie-expand}, that also uses
@code{dabbrev-expand}.
diff --git a/packages/ada-mode/ada-process.el b/packages/ada-mode/ada-process.el
index e783008..8de15cd 100644
--- a/packages/ada-mode/ada-process.el
+++ b/packages/ada-mode/ada-process.el
@@ -1,7 +1,7 @@
;;; ada-process.el --- Generated parser support file -*- lexical-binding:t -*-
;; command line: wisitoken-bnf-generate.exe --generate LR1 Ada_Emacs re2c
PROCESS text_rep ada.wy
-;; Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@@ -165,7 +165,7 @@
case_statement_alternative
case_statement_alternative_list
compilation_unit
- compilation_unit_list
+ compilation
component_clause
component_clause_list
component_declaration
diff --git a/packages/ada-mode/ada.wy b/packages/ada-mode/ada.wy
index 436d799..dce4b69 100644
--- a/packages/ada-mode/ada.wy
+++ b/packages/ada-mode/ada.wy
@@ -5,8 +5,28 @@
;; Created: Sept 2012
;; Keywords: syntax
;;
+;; Copied from Ada Language Reference Manual Annex P:
+;;
+;; (info "(aarm2012)Annex P" "*info Annex P*")
+;;
file:///C:/Projects/arm_info/org.adaic.arm_form/build/html/aarm2012/AA-P.html
+;; https://www.adaic.org/ada-resources/standards/ Ada 2012 annex P
+;;
+;; but listed in alphabetical order. Repeating and optional constructs
+;; are implemented with extra productions. Most names are simplified
+;; to just "name", many productions are modified to reduce conflicts.
+;;
+;; The EBNF in LRM Annex P is not LALR(1), so we use a generalized
+;; LR parser.
+;;
+;; Annex P overloads several keywords as grammar elements; 'body',
+;; 'pragma', some others. That matters in the generated Ada code. We
+;; resolve this by appending _g to the grammar element name.
+;;
+;; To tolerate some invalid syntax during editing, we relax the
+;; grammar, mainly by allowing many items to be empty.
+
%code copyright_license %{
-;; Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@@ -27,21 +47,11 @@
Partial_Parse_Byte_Goal : WisiToken.Buffer_Pos := WisiToken.Buffer_Pos'Last;
}%
-;;; Commentary:
-;;
-;; This is a wisi grammar file for the Ada language. It is derived
-;; from the 2012 Ada Reference Manual (ARM) with Technical Corrigendum
-;; 1, which is available as (info "(aarm2012)") or at
-;; http://www.ada-auth.org/standards/ada12.html, under the license in
-;; ada_license.text.
-;;
-;; see wisi.el for discussion of using the wisi parser for an
-;; indentation engine.
-
%generate LALR Ada_Emacs re2c Process
%generate LR1 Ada_Emacs text_rep re2c Process
%case_insensitive
+%start compilation
%keyword ABS "abs"
%keyword ACCEPT "accept"
@@ -192,8 +202,6 @@
%[ "'"([\x20-\U0010FFFF]|GNAT_Char_Coding)"'" ]%
"' '"
-%start compilation_unit_list
-
%elisp_face font-lock-constant-face
%elisp_face font-lock-function-name-face
%elisp_face font-lock-type-face
@@ -306,7 +314,7 @@
%conflict SHIFT/REDUCE in state association_opt, name on token EQUAL_GREATER
%conflict SHIFT/REDUCE in state attribute_designator, attribute_designator on
token LEFT_PAREN
%conflict SHIFT/REDUCE in state block_label, identifier_list on token COLON
-%conflict SHIFT/REDUCE in state compilation_unit_list, compilation_unit_list
on token FOR
+%conflict SHIFT/REDUCE in state compilation, compilation on token FOR
%conflict SHIFT/REDUCE in state declaration, declaration on token CONSTANT
%conflict SHIFT/REDUCE in state expression_function_declaration,
subprogram_specification on token IS
%conflict SHIFT/REDUCE in state formal_derived_type_definition,
formal_derived_type_definition on token WITH
@@ -329,30 +337,7 @@
%conflict SHIFT/REDUCE in state task_body, task_body on token IS
%conflict SHIFT/REDUCE in state wisitoken_accept, wisitoken_accept on token
FOR
-;;;; grammar rules
-;;
-;; The actions cache information in keywords that are significant for
-;; indentation and motion.
-;;
-;; BNF copied from:
-;;
-;; (info "(aarm2012)Annex P" "*info Annex P*")
-;;
file:///C:/Projects/arm_info/org.adaic.arm_form/build/html/aarm2012/AA-P.html
-;;
-;; but listed in alphabetical order. Repeating constructs are
-;; implemented with extra productions. Optional constructs are
-;; implemented by repeated productions. Most names are simplified to
-;; just "name".
-;;
-;; The EBNF in LRM Annex P is not LALR(1), so we use a generalized
-;; LALR(1) parser.
-;;
-;; Annex P overloads several keywords as grammar elements; 'body',
-;; 'pragma', some others. That matters in the generated Ada code. We
-;; resolve this by appending _g to the grammar element name.
-;;
-;; To tolerate some invalid syntax during editing, we relax the
-;; grammar, mainly by allowing many items to be empty.
+;;; grammar rules
abstract_limited_synchronized_opt
: ABSTRACT LIMITED
@@ -682,11 +667,11 @@ case_statement_alternative_list
;; Since we allow multiple compilation units in one parse, and don't
;; require a library_item in order to be user friendly, we don't need
;; a context_clause, since a list of context_items is just a
-;; compilation_unit_list. Since context_item includes pragma, this
+;; compilation. Since context_item includes pragma, this
;; also allows a pragma following a compilation_unit.
;;
;; We allow additional items here for partial syntax in mako-ada
-;; templates and grammar actions.
+;; templates and grammar actions, and for partial parsing in large files.
compilation_unit
: with_clause
| subunit
@@ -697,8 +682,8 @@ compilation_unit
;
;; Compute indent for trailing comments.
-compilation_unit_list
- : compilation_unit_list compilation_unit
+compilation
+ : compilation compilation_unit
%((wisi-indent-action [0 [0 0]]))%
| compilation_unit
%((wisi-indent-action [[0 0]]))%
diff --git a/packages/ada-mode/ada_lr1_parse_table.txt.gz
b/packages/ada-mode/ada_lr1_parse_table.txt.gz
index 4184430..a5c7877 100644
Binary files a/packages/ada-mode/ada_lr1_parse_table.txt.gz and
b/packages/ada-mode/ada_lr1_parse_table.txt.gz differ
diff --git a/packages/ada-mode/ada_process_actions.adb
b/packages/ada-mode/ada_process_actions.adb
index 7627acb..e3767c7 100644
--- a/packages/ada-mode/ada_process_actions.adb
+++ b/packages/ada-mode/ada_process_actions.adb
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LR1 Ada_Emacs re2c
PROCESS text_rep ada.wy
--
--- Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+-- Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
@@ -827,7 +827,7 @@ package body Ada_Process_Actions is
end case;
end compilation_unit_2;
- procedure compilation_unit_list_0
+ procedure compilation_0
(User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
Tree : in out WisiToken.Syntax_Trees.Tree;
Nonterm : in WisiToken.Valid_Node_Index;
@@ -844,9 +844,9 @@ package body Ada_Process_Actions is
Indent_Action_0 (Parse_Data, Tree, Nonterm, Tokens, ((False, (Simple,
(Int, 0))), (True, (Simple, (Int, 0)),
(Simple, (Int, 0)))));
end case;
- end compilation_unit_list_0;
+ end compilation_0;
- procedure compilation_unit_list_1
+ procedure compilation_1
(User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
Tree : in out WisiToken.Syntax_Trees.Tree;
Nonterm : in WisiToken.Valid_Node_Index;
@@ -862,9 +862,9 @@ package body Ada_Process_Actions is
when Indent =>
Indent_Action_0 (Parse_Data, Tree, Nonterm, Tokens, (1 => (True,
(Simple, (Int, 0)), (Simple, (Int, 0)))));
end case;
- end compilation_unit_list_1;
+ end compilation_1;
- function compilation_unit_list_1_check
+ function compilation_1_check
(Lexer : access constant WisiToken.Lexer.Instance'Class;
Nonterm : in out WisiToken.Recover_Token;
Tokens : in WisiToken.Recover_Token_Array;
@@ -874,7 +874,7 @@ package body Ada_Process_Actions is
pragma Unreferenced (Lexer, Tokens);
begin
return Terminate_Partial_Parse (Partial_Parse_Active,
Partial_Parse_Byte_Goal, Recover_Active, Nonterm);
- end compilation_unit_list_1_check;
+ end compilation_1_check;
procedure component_clause_0
(User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
@@ -1452,8 +1452,8 @@ package body Ada_Process_Actions is
null;
when Indent =>
Indent_Action_0 (Parse_Data, Tree, Nonterm, Tokens, ((False, (Simple,
(Label => None))), (False, (Simple,
- (Label => None))), (False, (Simple, (Label => None))), (False,
(Simple, (Int, Ada_Indent_Broken))),
- (False, (Simple, (Int, Ada_Indent_Broken))), (False, (Simple, (Int,
Ada_Indent_Broken)))));
+ (Label => None))), (False, (Simple, (Label => None))), (False,
(Simple, (Int, Ada_Indent_Broken))), (False,
+ (Simple, (Int, Ada_Indent_Broken))), (False, (Simple, (Int,
Ada_Indent_Broken)))));
end case;
end expression_function_declaration_0;
diff --git a/packages/ada-mode/ada_process_actions.ads
b/packages/ada-mode/ada_process_actions.ads
index 37b9c5d..3266c0b 100644
--- a/packages/ada-mode/ada_process_actions.ads
+++ b/packages/ada-mode/ada_process_actions.ads
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LR1 Ada_Emacs re2c
PROCESS text_rep ada.wy
--
--- Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+-- Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
@@ -180,7 +180,7 @@ package Ada_Process_Actions is
new String'("case_statement_alternative"),
new String'("case_statement_alternative_list"),
new String'("compilation_unit"),
- new String'("compilation_unit_list"),
+ new String'("compilation"),
new String'("component_clause"),
new String'("component_clause_list"),
new String'("component_declaration"),
@@ -521,7 +521,7 @@ package Ada_Process_Actions is
case_statement_alternative_ID,
case_statement_alternative_list_ID,
compilation_unit_ID,
- compilation_unit_list_ID,
+ compilation_ID,
component_clause_ID,
component_clause_list_ID,
component_declaration_ID,
@@ -905,12 +905,12 @@ package Ada_Process_Actions is
Tree : in out WisiToken.Syntax_Trees.Tree;
Nonterm : in WisiToken.Valid_Node_Index;
Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure compilation_unit_list_0
+ procedure compilation_0
(User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
Tree : in out WisiToken.Syntax_Trees.Tree;
Nonterm : in WisiToken.Valid_Node_Index;
Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure compilation_unit_list_1
+ procedure compilation_1
(User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
Tree : in out WisiToken.Syntax_Trees.Tree;
Nonterm : in WisiToken.Valid_Node_Index;
@@ -1910,7 +1910,7 @@ package Ada_Process_Actions is
Tokens : in WisiToken.Recover_Token_Array;
Recover_Active : in Boolean)
return WisiToken.Semantic_Checks.Check_Status;
- function compilation_unit_list_1_check
+ function compilation_1_check
(Lexer : access constant WisiToken.Lexer.Instance'Class;
Nonterm : in out WisiToken.Recover_Token;
Tokens : in WisiToken.Recover_Token_Array;
diff --git a/packages/ada-mode/ada_process_lalr_main.adb
b/packages/ada-mode/ada_process_lalr_main.adb
index 8cf50f3..6c39695 100644
--- a/packages/ada-mode/ada_process_lalr_main.adb
+++ b/packages/ada-mode/ada_process_lalr_main.adb
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LALR Ada_Emacs re2c
PROCESS ada.wy
--
--- Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+-- Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
@@ -870,7 +870,7 @@ package body Ada_Process_LALR_Main is
Table.States (49).Action_List.Set_Capacity (40);
Add_Action (Table.States (49), (4, 5, 13, 15, 17, 18, 25, 27, 28,
29, 30, 31, 32, 36, 37, 40, 41, 46, 47,
48, 49, 50, 51, 52, 57, 58, 60, 61, 63, 66, 69, 71, 73, 74, 81,
96, 107, 108, 109, 110), (146, 1), 1,
- compilation_unit_list_1'Access,
compilation_unit_list_1_check'Access);
+ compilation_1'Access, compilation_1_check'Access);
Table.States (49).Kernel := To_Vector ((0 => ((146, 1), 145, 0,
(146, 1), 1)));
Table.States (49).Minimal_Complete_Actions := To_Vector ((0 =>
(Reduce, (146, 1), 1)));
Table.States (50).Action_List.Set_Capacity (40);
@@ -3195,7 +3195,7 @@ package body Ada_Process_LALR_Main is
Table.States (231).Action_List.Set_Capacity (40);
Add_Action (Table.States (231), (4, 5, 13, 15, 17, 18, 25, 27, 28,
29, 30, 31, 32, 36, 37, 40, 41, 46, 47,
48, 49, 50, 51, 52, 57, 58, 60, 61, 63, 66, 69, 71, 73, 74, 81,
96, 107, 108, 109, 110), (146, 0), 2,
- compilation_unit_list_0'Access, null);
+ compilation_0'Access, null);
Table.States (231).Kernel := To_Vector ((0 => ((146, 0), 145, 0,
(146, 0), 2)));
Table.States (231).Minimal_Complete_Actions := To_Vector ((0 =>
(Reduce, (146, 0), 2)));
Table.States (232).Action_List.Set_Capacity (4);
diff --git a/packages/ada-mode/ada_process_lalr_main.ads
b/packages/ada-mode/ada_process_lalr_main.ads
index 8ef164a..c32bb9b 100644
--- a/packages/ada-mode/ada_process_lalr_main.ads
+++ b/packages/ada-mode/ada_process_lalr_main.ads
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LALR Ada_Emacs re2c
PROCESS ada.wy
--
--- Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+-- Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
diff --git a/packages/ada-mode/ada_process_lr1_main.adb
b/packages/ada-mode/ada_process_lr1_main.adb
index a4a7f22..b57aa9e 100644
--- a/packages/ada-mode/ada_process_lr1_main.adb
+++ b/packages/ada-mode/ada_process_lr1_main.adb
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LR1 Ada_Emacs re2c
PROCESS text_rep ada.wy
--
--- Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+-- Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
@@ -145,8 +145,8 @@ package body Ada_Process_LR1_Main is
Acts (145).Set_First_Last (0, 4);
Acts (145)(2) := (compilation_unit_2'Access, null);
Acts (146).Set_First_Last (0, 1);
- Acts (146)(0) := (compilation_unit_list_0'Access, null);
- Acts (146)(1) := (compilation_unit_list_1'Access,
compilation_unit_list_1_check'Access);
+ Acts (146)(0) := (compilation_0'Access, null);
+ Acts (146)(1) := (compilation_1'Access,
compilation_1_check'Access);
Acts (147).Set_First_Last (0, 0);
Acts (147)(0) := (component_clause_0'Access, null);
Acts (149).Set_First_Last (0, 1);
diff --git a/packages/ada-mode/ada_process_lr1_main.ads
b/packages/ada-mode/ada_process_lr1_main.ads
index 99d14b2..03331f6 100644
--- a/packages/ada-mode/ada_process_lr1_main.ads
+++ b/packages/ada-mode/ada_process_lr1_main.ads
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LR1 Ada_Emacs re2c
PROCESS text_rep ada.wy
--
--- Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+-- Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
diff --git a/packages/ada-mode/ada_re2c.c b/packages/ada-mode/ada_re2c.c
index 18da94a..684facc 100644
--- a/packages/ada-mode/ada_re2c.c
+++ b/packages/ada-mode/ada_re2c.c
@@ -4,7 +4,7 @@
// command line: wisitoken-bnf-generate.exe --generate LALR Ada_Emacs re2c
PROCESS ada.wy
//
-// Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+// Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
// This program is free software; you can redistribute it and/or
// modify it under the terms of the GNU General Public License as
diff --git a/packages/ada-mode/ada_re2c_c.ads b/packages/ada-mode/ada_re2c_c.ads
index 276e763..4a24ed2 100644
--- a/packages/ada-mode/ada_re2c_c.ads
+++ b/packages/ada-mode/ada_re2c_c.ads
@@ -2,7 +2,7 @@
-- command line: wisitoken-bnf-generate.exe --generate LALR Ada_Emacs re2c
PROCESS ada.wy
--
--- Copyright (C) 2013 - 2019 Free Software Foundation, Inc.
+-- Copyright (C) 2013 - 2020 Free Software Foundation, Inc.
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
diff --git a/packages/ada-mode/gpr-query.el b/packages/ada-mode/gpr-query.el
index 47967bf..4c2570f 100644
--- a/packages/ada-mode/gpr-query.el
+++ b/packages/ada-mode/gpr-query.el
@@ -808,6 +808,9 @@ FILE is from gpr-query."
(gpr-query-session-wait session 'symbols));; ensure symbol-locs is ready
(gpr-query--session-symbol-locs session)))
+(cl-defmethod wisi-xref-completion-delim-regex ((_xref gpr-query-xref))
+ (concat "[_(.<>*]"))
+
(cl-defmethod wisi-xref-completion-regexp ((_xref gpr-query-xref))
gpr-query-completion-regexp)
diff --git a/packages/ada-mode/wisi-ada-format_parameter_list.adb
b/packages/ada-mode/wisi-ada-format_parameter_list.adb
index 51690df..f4957e1 100644
--- a/packages/ada-mode/wisi-ada-format_parameter_list.adb
+++ b/packages/ada-mode/wisi-ada-format_parameter_list.adb
@@ -21,7 +21,7 @@ pragma License (GPL);
with WisiToken.Syntax_Trees.LR_Utils; use WisiToken.Syntax_Trees.LR_Utils;
separate (Wisi.Ada)
procedure Format_Parameter_List
- (Tree : in WisiToken.Syntax_Trees.Tree;
+ (Tree : in out WisiToken.Syntax_Trees.Tree;
Data : in out Parse_Data_Type;
Edit_Begin : in WisiToken.Buffer_Pos)
is
@@ -46,7 +46,15 @@ is
end record;
Formal_Part : constant Node_Index := Find_ID_At (Tree, +formal_part_ID,
Edit_Begin);
- Param_Iter : Iterator;
+ Param_List : constant Constant_List :=
+ (if Formal_Part = Invalid_Node_Index
+ then Creators.Invalid_List (Tree)
+ else Creators.Create_List
+ (Tree,
+ Root => Tree.Child (Formal_Part, 2),
+ List_ID => +parameter_specification_list_ID,
+ Element_ID => +parameter_specification_ID));
+
Edit_End : Buffer_Pos;
Param_Count : Count_Type := 0;
@@ -65,22 +73,20 @@ begin
Put_Line (";; format parameter list node" & Formal_Part'Image);
end if;
- Edit_End := Tree.Byte_Region (Formal_Part).Last;
- Param_Iter := Iterator
- (Iterate (Tree, Data.Base_Terminals, Data.Lexer, Data.Descriptor,
- Tree.Child (Formal_Part, 2), +parameter_specification_ID,
+SEMICOLON_ID));
+ Edit_End := Tree.Byte_Region (Formal_Part).Last;
-- The last parameter might be empty, due to syntax errors.
- for Param_Cur in Param_Iter loop
- if not Tree.Is_Empty (Node (Param_Cur)) then
+ for N of Param_List loop
+ if not Tree.Buffer_Region_Is_Empty (N) then
Param_Count := Param_Count + 1;
end if;
end loop;
declare
Params : array (1 .. Param_Count) of Parameter;
- Param_Cur : Cursor := First (Param_Iter);
- First_Param_Node : constant Node_Index := Node (First (Param_Iter));
+ Param_Cur : Cursor := Param_List.First;
+ Param_Iter : constant Constant_Iterator :=
Param_List.Iterate_Constant;
+ First_Param_Node : constant Node_Index := Node (Param_Cur);
Last_Param_Node : Node_Index;
begin
for Param of Params loop
@@ -89,18 +95,16 @@ begin
declare
Children : constant Valid_Node_Index_Array := Tree.Children (Node
(Param_Cur));
begin
- for Ident_Cur in Iterate
- (Tree, Data.Base_Terminals, Data.Lexer, Data.Descriptor,
Children (1), +IDENTIFIER_ID, +COMMA_ID)
- loop
- Param.Identifiers.Append (Tree.Byte_Region (Node (Ident_Cur)));
+ for Ident of Creators.Create_List (Tree, Children (1),
+identifier_list_ID, +IDENTIFIER_ID) loop
+ Param.Identifiers.Append (Tree.Byte_Region (Ident));
end loop;
- Param.Aliased_P := not Tree.Is_Empty (Children (3));
+ Param.Aliased_P := not Tree.Buffer_Region_Is_Empty (Children (3));
for I in 4 .. Children'Last loop
case To_Token_Enum (Tree.ID (Children (I))) is
when mode_opt_ID =>
- if Tree.Is_Empty (Children (I)) then
+ if Tree.Buffer_Region_Is_Empty (Children (I)) then
Param.In_P := False;
Param.Out_P := False;
else
@@ -110,7 +114,7 @@ begin
end if;
when null_exclusion_opt_ID =>
- Param.Not_Null_P := not Tree.Is_Empty (Children (I));
+ Param.Not_Null_P := not Tree.Buffer_Region_Is_Empty
(Children (I));
when name_ID =>
Param.Type_Region := Tree.Byte_Region (Children (I));
@@ -121,14 +125,14 @@ begin
declare
Access_Children : constant Valid_Node_Index_Array :=
Tree.Children (Children (I));
begin
- Param.Not_Null_P := not Tree.Is_Empty (Access_Children
(1));
+ Param.Not_Null_P := not Tree.Buffer_Region_Is_Empty
(Access_Children (1));
Param.Access_P := True;
if Tree.ID (Access_Children (3)) =
+general_access_modifier_opt_ID then
- Param.Constant_P := not Tree.Is_Empty (Access_Children
(3));
+ Param.Constant_P := not Tree.Buffer_Region_Is_Empty
(Access_Children (3));
Param.Type_Region := Tree.Byte_Region (Access_Children
(4));
else
- Param.Protected_P := not Tree.Is_Empty
(Access_Children (3));
+ Param.Protected_P := not Tree.Buffer_Region_Is_Empty
(Access_Children (3));
Param.Type_Region :=
(Tree.Byte_Region (Access_Children (4)).First,
Tree.Byte_Region (Children (I)).Last);
@@ -139,7 +143,7 @@ begin
null;
when expression_opt_ID =>
- if not Tree.Is_Empty (Children (I)) then
+ if not Tree.Buffer_Region_Is_Empty (Children (I)) then
Param.Default_Exp := Tree.Byte_Region (Children (I));
end if;
@@ -150,7 +154,7 @@ begin
end case;
end loop;
end;
- Param_Cur := Next (Param_Iter, Param_Cur);
+ Param_Cur := Param_Iter.Next (Param_Cur);
end loop;
declare
diff --git a/packages/ada-mode/wisi-ada.adb b/packages/ada-mode/wisi-ada.adb
index 0893716..686df33 100644
--- a/packages/ada-mode/wisi-ada.adb
+++ b/packages/ada-mode/wisi-ada.adb
@@ -423,7 +423,7 @@ package body Wisi.Ada is
end Object_Index_To_Element_Object;
procedure Format_Parameter_List
- (Tree : in WisiToken.Syntax_Trees.Tree;
+ (Tree : in out WisiToken.Syntax_Trees.Tree;
Data : in out Parse_Data_Type;
Edit_Begin : in WisiToken.Buffer_Pos)
is separate;
@@ -705,7 +705,7 @@ package body Wisi.Ada is
overriding
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
diff --git a/packages/ada-mode/wisi-ada.ads b/packages/ada-mode/wisi-ada.ads
index f02d6bf..5e0ba50 100644
--- a/packages/ada-mode/wisi-ada.ads
+++ b/packages/ada-mode/wisi-ada.ads
@@ -93,7 +93,7 @@ package Wisi.Ada is
overriding
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);
diff --git a/packages/wisi/NEWS b/packages/wisi/NEWS
index 38c8057..621c257 100644
--- a/packages/wisi/NEWS
+++ b/packages/wisi/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/packages/wisi/README b/packages/wisi/README
index f189c8d..5898d91 100644
--- a/packages/wisi/README
+++ b/packages/wisi/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/packages/wisi/wisi-prj.el b/packages/wisi/wisi-prj.el
index ba3932d..501c09f 100644
--- a/packages/wisi/wisi-prj.el
+++ b/packages/wisi/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/packages/wisi/wisi.adb b/packages/wisi/wisi.adb
index 66b55fd..91dacab 100644
--- a/packages/wisi/wisi.adb
+++ b/packages/wisi/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/packages/wisi/wisi.ads b/packages/wisi/wisi.ads
index db37e5d..e707ab8 100644
--- a/packages/wisi/wisi.ads
+++ b/packages/wisi/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/packages/wisi/wisi.el b/packages/wisi/wisi.el
index 48e9dc0..2032f93 100644
--- a/packages/wisi/wisi.el
+++ b/packages/wisi/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/packages/wisi/wisi.info b/packages/wisi/wisi.info
index e338347..e24dcee 100644
--- a/packages/wisi/wisi.info
+++ b/packages/wisi/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/packages/wisi/wisi.texi b/packages/wisi/wisi.texi
index 3b9594a..3a7d3b3 100644
--- a/packages/wisi/wisi.texi
+++ b/packages/wisi/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/packages/wisi/wisitoken-bnf-generate.adb
b/packages/wisi/wisitoken-bnf-generate.adb
index 1fe407a..821ef6f 100644
--- a/packages/wisi/wisitoken-bnf-generate.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-bnf-generate_packrat.adb
b/packages/wisi/wisitoken-bnf-generate_packrat.adb
index e76fbee..b4592e5 100644
--- a/packages/wisi/wisitoken-bnf-generate_packrat.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-bnf-generate_utils.adb
b/packages/wisi/wisitoken-bnf-generate_utils.adb
index 0e6eb4d..b5622d0 100644
--- a/packages/wisi/wisitoken-bnf-generate_utils.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-followed_by.adb
b/packages/wisi/wisitoken-followed_by.adb
new file mode 100644
index 0000000..e254bb6
--- /dev/null
+++ b/packages/wisi/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/packages/wisi/wisitoken-generate.adb
b/packages/wisi/wisitoken-generate.adb
index 1d7bb7e..c14077d 100644
--- a/packages/wisi/wisitoken-generate.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-parse-lr-mckenzie_recover.adb
b/packages/wisi/wisitoken-parse-lr-mckenzie_recover.adb
index 24c33d2..3287fb4 100644
--- a/packages/wisi/wisitoken-parse-lr-mckenzie_recover.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-parse-lr-parser.adb
b/packages/wisi/wisitoken-parse-lr-parser.adb
index a3dded3..04b6f6b 100644
--- a/packages/wisi/wisitoken-parse-lr-parser.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-parse-lr-parser_no_recover.adb
b/packages/wisi/wisitoken-parse-lr-parser_no_recover.adb
index 5e23b7c..6fd2b80 100644
--- a/packages/wisi/wisitoken-parse-lr-parser_no_recover.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-parse-packrat-procedural.adb
b/packages/wisi/wisitoken-parse-packrat-procedural.adb
index 44ab122..887794e 100644
--- a/packages/wisi/wisitoken-parse-packrat-procedural.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-syntax_trees-lr_utils.adb
b/packages/wisi/wisitoken-syntax_trees-lr_utils.adb
index c75ccea..cf04a80 100644
--- a/packages/wisi/wisitoken-syntax_trees-lr_utils.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-syntax_trees-lr_utils.ads
b/packages/wisi/wisitoken-syntax_trees-lr_utils.ads
index 84292b4..6f0403c 100644
--- a/packages/wisi/wisitoken-syntax_trees-lr_utils.ads
+++ b/packages/wisi/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/packages/wisi/wisitoken-syntax_trees.adb
b/packages/wisi/wisitoken-syntax_trees.adb
index 7e98947..0a38ae7 100644
--- a/packages/wisi/wisitoken-syntax_trees.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken-syntax_trees.ads
b/packages/wisi/wisitoken-syntax_trees.ads
index 5eff265..db29bac 100644
--- a/packages/wisi/wisitoken-syntax_trees.ads
+++ b/packages/wisi/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/packages/wisi/wisitoken-to_tree_sitter.adb
b/packages/wisi/wisitoken-to_tree_sitter.adb
new file mode 100644
index 0000000..2213414
--- /dev/null
+++ b/packages/wisi/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/packages/wisi/wisitoken-user_guide.info
b/packages/wisi/wisitoken-user_guide.info
index 982869c..7bbdb1b 100644
--- a/packages/wisi/wisitoken-user_guide.info
+++ b/packages/wisi/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/packages/wisi/wisitoken.ads b/packages/wisi/wisitoken.ads
index 0230d55..2c7a11b 100644
--- a/packages/wisi/wisitoken.ads
+++ b/packages/wisi/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/packages/wisi/wisitoken_grammar_runtime.adb
b/packages/wisi/wisitoken_grammar_runtime.adb
index 42d61fe..e40c147 100644
--- a/packages/wisi/wisitoken_grammar_runtime.adb
+++ b/packages/wisi/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/packages/wisi/wisitoken_grammar_runtime.ads
b/packages/wisi/wisitoken_grammar_runtime.ads
index 082e26e..a9de950 100644
--- a/packages/wisi/wisitoken_grammar_runtime.ads
+++ b/packages/wisi/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);
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [elpa] master 8676dbc: In ada-mode, release 7.1.3; in wisi, release 3.1.2,
Stephen Leake <=