[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] master ab6f759: * externals-list: Convert wisi to :external
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] master ab6f759: * externals-list: Convert wisi to :external |
|
Date: |
Sat, 28 Nov 2020 14:48:03 -0500 (EST) |
branch: master
commit ab6f7599ecd637a08b59b247807a40d1ed6f5dc1
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
* externals-list: Convert wisi to :external
---
externals-list | 1 +
packages/wisi/NEWS | 303 --
packages/wisi/README | 14 -
packages/wisi/build-wisitoken-bnf-generate.sh | 7 -
packages/wisi/dir | 19 -
packages/wisi/emacs_wisi_common_parse.adb | 508 ---
packages/wisi/emacs_wisi_common_parse.ads | 157 -
packages/wisi/gen_emacs_wisi_lr_parse.adb | 39 -
packages/wisi/gen_emacs_wisi_lr_parse.ads | 55 -
packages/wisi/gen_emacs_wisi_lr_text_rep_parse.adb | 44 -
packages/wisi/gen_emacs_wisi_lr_text_rep_parse.ads | 50 -
packages/wisi/gen_emacs_wisi_packrat_parse.adb | 180 -
packages/wisi/gen_emacs_wisi_packrat_parse.ads | 42 -
packages/wisi/gen_run_wisi_libadalang_parse.adb | 176 -
packages/wisi/gen_run_wisi_libadalang_parse.ads | 30 -
packages/wisi/gen_run_wisi_lr_parse.adb | 37 -
packages/wisi/gen_run_wisi_lr_parse.ads | 42 -
packages/wisi/gen_run_wisi_lr_text_rep_parse.adb | 44 -
packages/wisi/gen_run_wisi_lr_text_rep_parse.ads | 44 -
packages/wisi/gen_run_wisi_packrat_parse.adb | 241 --
packages/wisi/gen_run_wisi_packrat_parse.ads | 36 -
packages/wisi/long_float_elementary_functions.ads | 21 -
packages/wisi/recover_stats.adb | 271 --
packages/wisi/run_wisi_common_parse.adb | 356 --
packages/wisi/run_wisi_common_parse.ads | 73 -
...da_containers-gen_doubly_linked_lists_image.adb | 50 -
...da_containers-gen_doubly_linked_lists_image.ads | 28 -
packages/wisi/sal-ada_containers.ads | 21 -
packages/wisi/sal-gen_array_image.adb | 34 -
packages/wisi/sal-gen_array_image.ads | 24 -
packages/wisi/sal-gen_bounded_definite_queues.adb | 103 -
packages/wisi/sal-gen_bounded_definite_queues.ads | 117 -
...l-gen_bounded_definite_stacks-gen_image_aux.adb | 42 -
...l-gen_bounded_definite_stacks-gen_image_aux.ads | 27 -
packages/wisi/sal-gen_bounded_definite_stacks.adb | 82 -
packages/wisi/sal-gen_bounded_definite_stacks.ads | 103 -
.../sal-gen_bounded_definite_vectors-gen_image.adb | 40 -
.../sal-gen_bounded_definite_vectors-gen_image.ads | 23 -
...-gen_bounded_definite_vectors-gen_image_aux.adb | 35 -
...-gen_bounded_definite_vectors-gen_image_aux.ads | 23 -
.../sal-gen_bounded_definite_vectors-gen_refs.adb | 35 -
.../sal-gen_bounded_definite_vectors-gen_refs.ads | 54 -
packages/wisi/sal-gen_bounded_definite_vectors.adb | 120 -
packages/wisi/sal-gen_bounded_definite_vectors.ads | 145 -
...unded_definite_vectors_sorted-gen_image_aux.adb | 35 -
...unded_definite_vectors_sorted-gen_image_aux.ads | 23 -
...en_bounded_definite_vectors_sorted-gen_refs.adb | 29 -
...en_bounded_definite_vectors_sorted-gen_refs.ads | 39 -
.../sal-gen_bounded_definite_vectors_sorted.adb | 96 -
.../sal-gen_bounded_definite_vectors_sorted.ads | 100 -
.../wisi/sal-gen_definite_doubly_linked_lists.adb | 317 --
.../wisi/sal-gen_definite_doubly_linked_lists.ads | 172 -
...finite_doubly_linked_lists_sorted-gen_image.adb | 47 -
...finite_doubly_linked_lists_sorted-gen_image.ads | 25 -
...sal-gen_definite_doubly_linked_lists_sorted.adb | 542 ---
...sal-gen_definite_doubly_linked_lists_sorted.ads | 190 -
packages/wisi/sal-gen_graphs.adb | 719 ----
packages/wisi/sal-gen_graphs.ads | 190 -
.../sal-gen_indefinite_doubly_linked_lists.adb | 211 -
.../sal-gen_indefinite_doubly_linked_lists.ads | 128 -
packages/wisi/sal-gen_trimmed_image.adb | 28 -
packages/wisi/sal-gen_trimmed_image.ads | 23 -
...-gen_unbounded_definite_min_heaps_fibonacci.adb | 354 --
...-gen_unbounded_definite_min_heaps_fibonacci.ads | 112 -
...gen_unbounded_definite_queues-gen_image_aux.adb | 35 -
...gen_unbounded_definite_queues-gen_image_aux.ads | 23 -
.../wisi/sal-gen_unbounded_definite_queues.adb | 97 -
.../wisi/sal-gen_unbounded_definite_queues.ads | 110 -
.../sal-gen_unbounded_definite_red_black_trees.adb | 870 ----
.../sal-gen_unbounded_definite_red_black_trees.ads | 198 -
...gen_unbounded_definite_stacks-gen_image_aux.adb | 42 -
...gen_unbounded_definite_stacks-gen_image_aux.ads | 27 -
.../wisi/sal-gen_unbounded_definite_stacks.adb | 219 -
.../wisi/sal-gen_unbounded_definite_stacks.ads | 158 -
...n_unbounded_definite_vectors-gen_comparable.adb | 73 -
...n_unbounded_definite_vectors-gen_comparable.ads | 30 -
...al-gen_unbounded_definite_vectors-gen_image.adb | 50 -
...al-gen_unbounded_definite_vectors-gen_image.ads | 24 -
...en_unbounded_definite_vectors-gen_image_aux.adb | 43 -
...en_unbounded_definite_vectors-gen_image_aux.ads | 28 -
.../wisi/sal-gen_unbounded_definite_vectors.adb | 585 ---
.../wisi/sal-gen_unbounded_definite_vectors.ads | 252 --
.../sal-gen_unbounded_definite_vectors_sorted.adb | 374 --
.../sal-gen_unbounded_definite_vectors_sorted.ads | 172 -
.../wisi/sal-gen_unconstrained_array_image.adb | 34 -
.../wisi/sal-gen_unconstrained_array_image.ads | 24 -
.../wisi/sal-gen_unconstrained_array_image_aux.adb | 33 -
.../wisi/sal-gen_unconstrained_array_image_aux.ads | 25 -
packages/wisi/sal-generic_decimal_image.adb | 48 -
packages/wisi/sal-generic_decimal_image.ads | 37 -
packages/wisi/sal.adb | 32 -
packages/wisi/sal.ads | 75 -
packages/wisi/standard_common.gpr | 152 -
packages/wisi/wisi-fringe.el | 152 -
packages/wisi/wisi-parse-common.el | 403 --
packages/wisi/wisi-prj.el | 1614 --------
packages/wisi/wisi-process-parse.el | 844 ----
packages/wisi/wisi-run-indent-test.el | 399 --
packages/wisi/wisi-skel.el | 187 -
packages/wisi/wisi-tests.el | 120 -
packages/wisi/wisi.adb | 2434 -----------
packages/wisi/wisi.ads | 769 ----
packages/wisi/wisi.el | 1725 --------
packages/wisi/wisi.gpr.gp | 64 -
packages/wisi/wisi.info | 1294 ------
packages/wisi/wisi.texi | 812 ----
packages/wisi/wisitoken-bnf-generate.adb | 634 ---
packages/wisi/wisitoken-bnf-generate_grammar.adb | 86 -
packages/wisi/wisitoken-bnf-generate_packrat.adb | 333 --
packages/wisi/wisitoken-bnf-generate_utils.adb | 724 ----
packages/wisi/wisitoken-bnf-generate_utils.ads | 174 -
packages/wisi/wisitoken-bnf-output_ada.adb | 512 ---
packages/wisi/wisitoken-bnf-output_ada_common.adb | 1392 -------
packages/wisi/wisitoken-bnf-output_ada_common.ads | 90 -
packages/wisi/wisitoken-bnf-output_ada_emacs.adb | 1916 ---------
.../wisi/wisitoken-bnf-output_elisp_common.adb | 212 -
.../wisi/wisitoken-bnf-output_elisp_common.ads | 54 -
packages/wisi/wisitoken-bnf-utils.adb | 45 -
packages/wisi/wisitoken-bnf-utils.ads | 29 -
packages/wisi/wisitoken-bnf.adb | 355 --
packages/wisi/wisitoken-bnf.ads | 358 --
packages/wisi/wisitoken-followed_by.adb | 207 -
packages/wisi/wisitoken-gen_token_enum.adb | 133 -
packages/wisi/wisitoken-gen_token_enum.ads | 122 -
.../wisi/wisitoken-generate-lr-lalr_generate.adb | 611 ---
.../wisi/wisitoken-generate-lr-lalr_generate.ads | 87 -
.../wisi/wisitoken-generate-lr-lr1_generate.adb | 343 --
.../wisi/wisitoken-generate-lr-lr1_generate.ads | 91 -
packages/wisi/wisitoken-generate-lr.adb | 1510 -------
packages/wisi/wisitoken-generate-lr.ads | 214 -
packages/wisi/wisitoken-generate-lr1_items.adb | 553 ---
packages/wisi/wisitoken-generate-lr1_items.ads | 335 --
packages/wisi/wisitoken-generate-packrat.adb | 247 --
packages/wisi/wisitoken-generate-packrat.ads | 75 -
packages/wisi/wisitoken-generate.adb | 665 ---
packages/wisi/wisitoken-generate.ads | 200 -
packages/wisi/wisitoken-lexer-re2c.adb | 307 --
packages/wisi/wisitoken-lexer-re2c.ads | 144 -
packages/wisi/wisitoken-lexer-regexp.adb | 259 --
packages/wisi/wisitoken-lexer-regexp.ads | 114 -
packages/wisi/wisitoken-lexer.adb | 61 -
packages/wisi/wisitoken-lexer.ads | 187 -
.../wisitoken-parse-lr-mckenzie_recover-base.adb | 451 --
.../wisitoken-parse-lr-mckenzie_recover-base.ads | 185 -
...wisitoken-parse-lr-mckenzie_recover-explore.adb | 1875 ---------
...wisitoken-parse-lr-mckenzie_recover-explore.ads | 28 -
.../wisitoken-parse-lr-mckenzie_recover-parse.adb | 327 --
.../wisitoken-parse-lr-mckenzie_recover-parse.ads | 83 -
.../wisi/wisitoken-parse-lr-mckenzie_recover.adb | 1306 ------
.../wisi/wisitoken-parse-lr-mckenzie_recover.ads | 310 --
packages/wisi/wisitoken-parse-lr-parser.adb | 1256 ------
packages/wisi/wisitoken-parse-lr-parser.ads | 162 -
packages/wisi/wisitoken-parse-lr-parser_lists.adb | 416 --
packages/wisi/wisitoken-parse-lr-parser_lists.ads | 274 --
.../wisi/wisitoken-parse-lr-parser_no_recover.adb | 574 ---
.../wisi/wisitoken-parse-lr-parser_no_recover.ads | 92 -
packages/wisi/wisitoken-parse-lr.adb | 767 ----
packages/wisi/wisitoken-parse-lr.ads | 698 ----
.../wisi/wisitoken-parse-packrat-generated.adb | 96 -
.../wisi/wisitoken-parse-packrat-generated.ads | 76 -
.../wisi/wisitoken-parse-packrat-procedural.adb | 267 --
.../wisi/wisitoken-parse-packrat-procedural.ads | 86 -
packages/wisi/wisitoken-parse-packrat.adb | 63 -
packages/wisi/wisitoken-parse-packrat.ads | 75 -
packages/wisi/wisitoken-parse.adb | 108 -
packages/wisi/wisitoken-parse.ads | 84 -
packages/wisi/wisitoken-parse_table-mode.el | 95 -
packages/wisi/wisitoken-productions.adb | 83 -
packages/wisi/wisitoken-productions.ads | 88 -
packages/wisi/wisitoken-semantic_checks.adb | 152 -
packages/wisi/wisitoken-semantic_checks.ads | 106 -
packages/wisi/wisitoken-syntax_trees-lr_utils.adb | 939 -----
packages/wisi/wisitoken-syntax_trees-lr_utils.ads | 475 ---
packages/wisi/wisitoken-syntax_trees.adb | 2111 ----------
packages/wisi/wisitoken-syntax_trees.ads | 805 ----
packages/wisi/wisitoken-text_io_trace.adb | 113 -
packages/wisi/wisitoken-text_io_trace.ads | 53 -
packages/wisi/wisitoken-to_tree_sitter.adb | 528 ---
packages/wisi/wisitoken-user_guide.info | 611 ---
packages/wisi/wisitoken-wisi_ada.adb | 160 -
packages/wisi/wisitoken-wisi_ada.ads | 81 -
packages/wisi/wisitoken.adb | 367 --
packages/wisi/wisitoken.ads | 508 ---
packages/wisi/wisitoken_grammar_actions.adb | 182 -
packages/wisi/wisitoken_grammar_actions.ads | 237 --
packages/wisi/wisitoken_grammar_main.adb | 662 ---
packages/wisi/wisitoken_grammar_main.ads | 34 -
packages/wisi/wisitoken_grammar_re2c.c | 4303 --------------------
packages/wisi/wisitoken_grammar_re2c_c.ads | 63 -
packages/wisi/wisitoken_grammar_runtime.adb | 3442 ----------------
packages/wisi/wisitoken_grammar_runtime.ads | 166 -
191 files changed, 1 insertion(+), 61364 deletions(-)
diff --git a/externals-list b/externals-list
index 4fbb1b9..1e25d68 100644
--- a/externals-list
+++ b/externals-list
@@ -179,6 +179,7 @@
("webfeeder" :external
"https://gitlab.com/ambrevar/emacs-webfeeder.git";)
("websocket" :external
"https://github.com/ahyatt/emacs-websocket.git";)
("windower" :external "https://gitlab.com/ambrevar/emacs-windower";)
+ ("wisi" :external nil)
("wisitoken-grammar-mode" :external nil)
("which-key" :external "https://github.com/justbur/emacs-which-key";)
("wpuzzle" :external nil)
diff --git a/packages/wisi/NEWS b/packages/wisi/NEWS
deleted file mode 100644
index 621c257..0000000
--- a/packages/wisi/NEWS
+++ /dev/null
@@ -1,303 +0,0 @@
-GNU Emacs wisi NEWS -- history of user-visible changes.
-
-Copyright (C) 2014 - 2020 Free Software Foundation, Inc.
-
-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
-
-** Add Wisitoken.Syntax_Trees.Insert_Token, to allow using inserted
- virtual terminals tokens in indent. Several related changes to
- allow treating virtual terminals on par with actual terminals.
-
-** New elisp generic functions: wisi-xref-completion-table,
wisi-xref-completion-regexp, wisi-xref-completion-at-point-table
-
-** New elisp functions: wisi-filter-table, wisi-completion-at-point,
wisi-skel-add-token-after
-
-** wisi-get-identifier uses wisi-xref-completion-table.
-
-** wisi-prj-identifier-at-point returns (IDENT START END)
-
-** In wisi.ads: augmented tokens are no stored only in the syntax
- tree; new functions Get_Aug_Token_Const_1, Get_Aug_Token_Const,
- Get_Aug_Token_Var provide access to them. Parse_Data_Type contains
- a reference to the shared Terminals.
-
-* wisi 3.0.1
-30 Jan 2020
-
-** fix packaging bugs
-
-** improve xref integration
-
-* wisi 3.0.0
-19 Dec 2019
-
-** parser process protocol version 5
-
-** Add project.el integration. See wisi.info for more information.
-
-** Move autocase functions from ada-mode to wisi.
-
-** Replace most ada-mode function variables with dispatching on wisi-prj.
-
-** New commands `wisi-goto-containing-statement-start',
`wisi-indent-containing-statement'.
-
-** Displayed parser errors are sorted in increasing error position.
-
-* wisi 2.2.1
-17 Aug 2019
-
-** parser process protocol version 4
-
-** fix packaging bugs
-
-* wisi 2.2.0
-13 Aug 2019
-
-** parser process protocol version 3
-
-** Support for the elisp parser and lexer is deleted; only the Ada
- process parser is supported.
-
-** New user variable `wisi-indent-context-lines' specifies the minimum
- number of lines before point to include in a parse for indenting a
- single line. This gives better results when indenting in a nested
- 'if then else', for example. The default value is 0; you must
- change it to see an effect.
-
-** Error correction is faster by approximately 30%;
- %mckenzie_enqueue_limit can be raised accordingly.
-
-** %mckenzie_enqueue_limit is now applied to the total of all parsers
- in recovery; previously, it was applied to each parser separately.
- Applying to the total gives a more consistent maximum user wait
- time for recovery, at the cost of not finding solutions when there
- are many parsers involved. You may want to increase
- %mckenzie_enqueue_limit for this as well.
-
-** In the process parser, `wisi-statement-start' now sets 'containing'
- in all contained caches to the start token, if not set already;
- previously it only did this if the token was mentioned in the
- `wisi-statement-start' action. This makes `wisi-containing-action'
- unnecessary.
-
-** `wisi-containing-action' is deleted.
-
-** An argument of `wisi-motion-action' that is a vector may now
- provide only one token ID. That token ID is searched for in the
- containing token region, and the motion token chain starting at the
- first one found is included in the current right hand side motion
- token chain.
-
-** The process parser supports a new parse command `wisi-refactor',
- which returns a new message "Edit". It is intended for performing
- syntax-guided refactoring of code statements.
-
-* wisi 2.1.1
-11 Jul 2019
-
-** parser process protocol version 3
-
-** User variable wisi-mckenzie-cost-limit is deleted; set
- wisi-mckenzie-enqueue-limit instead, it gives better results.
-
-** `wisi-show-parse-errors' now shows errors in a dedicated window, so
- it will not be resized or reused.
-
-** New grammar action `wisi-name-action'; sets a name that will be
- fontified. This replaces the previous 'name' navigate class.
-
-** Support 'nil' as an indent argument; useful for the first token,
- whose indent is typically unknown. Indent functions that do not
- accumulate now only check for "nil", not "zero or nil".
-
-** New file wisi-xref.el provides a completion table built from tokens
- marked by the new grammar action `wisi-name-action'.
-
-** The process parser checks the parser process protocol version, to
- ensure the elisp code matches the process code.
-
-** The process parser supports passing data to a language-specific
- elisp function, via the `language-action-table' field of the
- `wisi-process--parser' struct.
-
-** New user option `wisi-parse-max-parallel' to set the number of
- parallel parsers used; Java needs more than Ada.
-
-* wisi 2.1.0
-21 Mar 2019
-
-** parser process protocol version 2
-
-** Add support for partial parsing; useful in very large files. Files
- larger than wisi-partial-parse-threshold (default 100_001) will be
- parsed partially.
-
-** Miscellaneous speed-ups in the Ada code; 'pragma Inline', better use of Ada
tasks.
-
-** Better error correction in the Ada process parser; insert minimimal
- tokens to complete a statement/declaration before or after the error
- point.
-
-* wisi 2.0.1
-8 Dec 2018
-
-** parser process protocol version 1
-
-** Assign copyright in Ada files to FSF
-
-** Update user guide, include it in elpa package
-
-* wisi 2.0.0
-17 Nov 2018
-
-** Change indentation engine to compute indent directly in parser actions.
-
-** Add error correcting external process parser.
-
-** Factor out wisi-elisp-lexer.el from wisi.el, and
- ada-wisi-elisp-parse.el from ada-wisi.el. Move elisp grammar
- actions from wisi.el to wisi-elisp-parse.el; they are not used with
- the process parser.
-
-** Add support for error corrections in parser; 'wisi-repair-error'
- can apply the corrections to the buffer text.
-
-** Display marks in fringe at location of errors detected by
- background parser.
-
-** include sources for wisitoken parser runtime, parser generator.
-
-* wisi 1.1.6
-3 Oct 2017
-
-** wisi-forward-find-cache-token - new function.
-
-** New minor-mode parse_table-mode helps navigating parse table
- listings output by 'wisi-generate -v 1'; useful when debugging
- grammars.
-
-* wisi 1.1.5
-9 Jul 2017
-
-** wisi-indent-fallback allows setting the indent engine to use when
- the wisi engine fails.
-
-** wisi-comment-indent now uses comment-column for comments following
- code on the same line.
-
-** wisi-forward-statement-keyword tolerates end of buffer, and uses
- either cache-next or cache-end.
-
-** forward-sexp-function is set to wisi-forward-sexp, which handles
- parens, strings, and statements.
-
-* wisi 1.1.4
-31 Oct 2016
-
-** wisi-validate-cache takes optional error-on-fail arg.
-
-* wisi 1.1.3
-26 Jul 2016
-
-** improve use of quotes in doc strings.
-
-* wisi 1.1.2
-20 Jan 2016
-
-** wisi-compile no longer requires semantic.
-
-** wisi-parse slightly faster
-
-** minor bug fixes
-
-** wisi-extend-action now takes two args (first last)
-
-** wisi-face-action-1 optional arg no-override is replaced by
override-no-error.
-
-* wisi 1.1.1
-10 Apr 2015
-
-** rename wisi-font-lock-size-threshold to wisi-size-threshold, use
- for more things in ada-mode
-
-* wisi 1.1.0
-18 Nov 2014
-
-** change wisi-forward-token to not return text; simpler, faster
-
-** remove face from wisi-cache; set font-lock-face property directly.
-
-** add support for numeric literal tokens.
-
-** change wisi-*-action to take a vector of arguments; faster for
- external parser, catches more errors.
-
-** add wisi-font-lock-size-threshold
-
-* wisi 1.0.6
-28 Sep 2014
-
-** add face to wisi-cache
-
-** wisi-before/after-change : improve checks for invalidate-cache
-
-** wisi-motion-action takes class with each token-id
-
-** new parse actions: wisi-extend-action, wisi-face-action
-
-** new functions: wisi-goto-statement-start, -end.
-
-** fix misc bugs
-
-* wisi 1.0.5
-12 Jul 2014
-
-** wisi-parse-max-parallel-current - new variable for debugging slow parsing
issues
-
-** wisi-set-end - new algorithm giving significant speedup
-
-* wisi 1.0.4
-19 Apr 2014
-
-** add support for GNAT Ada bracket hex character notation
-
-* wisi 1.0.3
-16 Mar 2014
-
-** fix another packaging bug; forgot to add files to ELPA git!
-
-* wisi 1.0.2
-14 Mar 2014
-
-** Emacs 24.2 supported, via cl-lib in Gnu ELPA
-
-* wisi 1.0.1
-
-** minor fixes for byte compiler warnings
-
-* wisi 1.0
-Feb 2 2014
-
-** first release in ELPA
diff --git a/packages/wisi/README b/packages/wisi/README
deleted file mode 100644
index 5898d91..0000000
--- a/packages/wisi/README
+++ /dev/null
@@ -1,14 +0,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,
-fontification, and navigation; and integration with Emacs package.el.
-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/build-wisitoken-bnf-generate.sh
b/packages/wisi/build-wisitoken-bnf-generate.sh
deleted file mode 100755
index faa4094..0000000
--- a/packages/wisi/build-wisitoken-bnf-generate.sh
+++ /dev/null
@@ -1,7 +0,0 @@
-# Build wisitoken-bnf-generate.exe, for generating code from grammar files.
-#
-# Instead of using this, you should consider using the complete
-# wisitoken development tree; see
-# http://stephe-leake.org/ada/wisitoken.html
-
-gprbuild -p -j8 -P wisi.gpr wisitoken-bnf-generate
diff --git a/packages/wisi/dir b/packages/wisi/dir
deleted file mode 100644
index fbc9cbb..0000000
--- a/packages/wisi/dir
+++ /dev/null
@@ -1,19 +0,0 @@
-This is the file .../info/dir, which contains the
-topmost node of the Info hierarchy, called (dir)Top.
-The first time you invoke Info you start off looking at this node.
-
-File: dir, Node: Top This is the top of the INFO tree
-
- This (the Directory node) gives a menu of major topics.
- Typing "q" exits, "H" lists all Info commands, "d" returns here,
- "h" gives a primer for first-timers,
- "mEmacs<Return>" visits the Emacs manual, etc.
-
- In Emacs, you can click mouse button 2 on a menu item or cross reference
- to select it.
-
-* Menu:
-
-Parser generators
-* wisitoken-bnf-generate: (wisitoken-bnf-generate).
- Ada and Elisp parser generator
diff --git a/packages/wisi/emacs_wisi_common_parse.adb
b/packages/wisi/emacs_wisi_common_parse.adb
deleted file mode 100644
index 59d20e5..0000000
--- a/packages/wisi/emacs_wisi_common_parse.adb
+++ /dev/null
@@ -1,508 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Command_Line;
-with Ada.Directories;
-with Ada.Exceptions;
-with Ada.Strings.Fixed;
-with Ada.Text_IO;
-with GNAT.OS_Lib;
-with SAL;
-with System.Multiprocessors;
-with System.Storage_Elements;
-with WisiToken.Lexer;
-package body Emacs_Wisi_Common_Parse is
-
- procedure Usage (Name : in String)
- is
- use Ada.Text_IO;
- begin
- Put_Line ("usage: " & Name & "[--recover-log <file-name>]");
- Put_Line ("enters a loop waiting for commands:");
- Put_Line ("Prompt is '" & Prompt & "'");
- Put_Line ("commands are case sensitive");
- Put_Line ("See wisi-process-parse.el *--send-parse, *--send-noop for
arguments.");
- end Usage;
-
- procedure Read_Input (A : System.Address; N : Integer)
- is
- use System.Storage_Elements;
-
- B : System.Address := A;
- Remaining : Integer := N;
- Read : Integer;
- begin
- -- We use GNAT.OS_Lib because it does not buffer input, so it runs
- -- under Emacs nicely; GNAT Text_IO does not return text until
- -- some fairly large buffer is filled.
- --
- -- With GNAT GPL 2016, GNAT.OS_Lib.Read does _not_ wait for all N
- -- bytes or EOF; it returns as soon as it gets some bytes.
- loop
- Read := GNAT.OS_Lib.Read (GNAT.OS_Lib.Standin, B, Remaining);
- if Read = 0 then
- -- Pipe closed; probably parent Emacs crashed. Force exit.
- raise SAL.Programmer_Error with "input pipe closed";
- end if;
- Remaining := Remaining - Read;
- exit when Remaining <= 0;
- B := B + Storage_Offset (Read);
- end loop;
- end Read_Input;
-
- function Get_Command_Length return Integer
- is
- Temp : aliased String (1 .. 3) := (others => ' '); -- initialize for
error message
- begin
- Read_Input (Temp'Address, Temp'Length);
- return Integer'Value (Temp);
- exception
- when Constraint_Error =>
- -- From Integer'Value
- raise Protocol_Error with "invalid command byte count; '" & Temp & "'";
- end Get_Command_Length;
-
- function Get_String
- (Source : in String;
- Last : in out Integer)
- return String
- is
- use Ada.Strings.Fixed;
- First : constant Integer := Index
- (Source => Source,
- Pattern => """",
- From => Last + 1);
- begin
- Last := Index
- (Source => Source,
- Pattern => """",
- From => First + 1);
-
- if First = 0 or Last = 0 then
- raise Protocol_Error with "no '""' found for string";
- end if;
-
- return Source (First + 1 .. Last - 1);
- end Get_String;
-
- function Get_Integer
- (Source : in String;
- Last : in out Integer)
- return Integer
- is
- use Ada.Strings.Fixed;
- First : constant Integer := Last + 2; -- final char of previous item,
space
- begin
- Last := Index
- (Source => Source,
- Pattern => " ",
- From => First);
-
- if Last = 0 then
- Last := Source'Last;
- else
- Last := Last - 1;
- end if;
-
- return Integer'Value (Source (First .. Last));
- exception
- when others =>
- Ada.Text_IO.Put_Line ("bad integer '" & Source (First .. Source'Last) &
"'");
- raise;
- end Get_Integer;
-
- function Get_Process_Start_Params return Process_Start_Params
- is
- use Ada.Command_Line;
- procedure Put_Usage
- is
- use Ada.Text_IO;
- begin
- Put_Line (Standard_Error, "process start args:");
- Put_Line (Standard_Error, "--help : put this help");
- Put_Line (Standard_Error, "--recover-log <file_name> : log recover
actions to file");
- end Put_Usage;
-
- Next_Arg : Integer := 1;
- begin
- return Result : Process_Start_Params do
- loop
- exit when Next_Arg > Argument_Count;
-
- if Next_Arg <= Argument_Count and then Argument (Next_Arg) =
"--help" then
- Put_Usage;
- raise Finish;
-
- elsif Next_Arg + 1 <= Argument_Count and then Argument (Next_Arg)
= "--recover-log" then
- Result.Recover_Log_File_Name :=
Ada.Strings.Unbounded.To_Unbounded_String (Argument (Next_Arg + 1));
- Next_Arg := Next_Arg + 2;
- end if;
- end loop;
- end return;
- end Get_Process_Start_Params;
-
- function Get_Parse_Params (Command_Line : in String; Last : in out Integer)
return Parse_Params
- is
- use WisiToken;
- begin
- return Result : Parse_Params do
- -- We don't use an aggregate, to enforce execution order.
- -- Match wisi-process-parse.el wisi-process--send-parse
-
- Result.Post_Parse_Action := Wisi.Post_Parse_Action_Type'Val
(Get_Integer (Command_Line, Last));
- Result.Source_File_Name := +Get_String (Command_Line, Last);
- Result.Begin_Byte_Pos := Get_Integer (Command_Line, Last);
-
- -- Emacs end is after last char.
- Result.End_Byte_Pos := Get_Integer (Command_Line, Last) - 1;
-
- Result.Goal_Byte_Pos := Get_Integer (Command_Line, Last);
- Result.Begin_Char_Pos := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last));
- Result.Begin_Line := WisiToken.Line_Number_Type
(Get_Integer (Command_Line, Last));
- Result.End_Line := WisiToken.Line_Number_Type
(Get_Integer (Command_Line, Last));
- Result.Begin_Indent := Get_Integer (Command_Line, Last);
- Result.Partial_Parse_Active := 1 = Get_Integer (Command_Line, Last);
- Result.Debug_Mode := 1 = Get_Integer (Command_Line, Last);
- Result.Parse_Verbosity := Get_Integer (Command_Line, Last);
- Result.McKenzie_Verbosity := Get_Integer (Command_Line, Last);
- Result.Action_Verbosity := Get_Integer (Command_Line, Last);
- Result.McKenzie_Disable := Get_Integer (Command_Line, Last);
- Result.Task_Count := Get_Integer (Command_Line, Last);
- Result.Check_Limit := Get_Integer (Command_Line, Last);
- Result.Enqueue_Limit := Get_Integer (Command_Line, Last);
- Result.Max_Parallel := Get_Integer (Command_Line, Last);
- Result.Byte_Count := Get_Integer (Command_Line, Last);
- end return;
- end Get_Parse_Params;
-
- function Get_Refactor_Params (Command_Line : in String; Last : in out
Integer) return Refactor_Params
- is
- use WisiToken;
- begin
- return Result : Refactor_Params do
- -- We don't use an aggregate, to enforce execution order.
- -- Match wisi-process-parse.el wisi-process--send-refactor
-
- Result.Refactor_Action := Get_Integer (Command_Line, Last);
- Result.Source_File_Name := +Get_String (Command_Line, Last);
- Result.Parse_Region.First := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last));
- Result.Parse_Region.Last := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last) - 1);
-
- Result.Edit_Begin := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last));
- Result.Parse_Begin_Char_Pos := WisiToken.Buffer_Pos (Get_Integer
(Command_Line, Last));
- Result.Parse_Begin_Line := WisiToken.Line_Number_Type
(Get_Integer (Command_Line, Last));
- Result.Parse_End_Line := WisiToken.Line_Number_Type
(Get_Integer (Command_Line, Last));
- Result.Parse_Begin_Indent := Get_Integer (Command_Line, Last);
- Result.Debug_Mode := 1 = Get_Integer (Command_Line, Last);
- Result.Parse_Verbosity := Get_Integer (Command_Line, Last);
- Result.Action_Verbosity := Get_Integer (Command_Line, Last);
- Result.Max_Parallel := Get_Integer (Command_Line, Last);
- Result.Byte_Count := Get_Integer (Command_Line, Last);
- end return;
- end Get_Refactor_Params;
-
- procedure Process_Stream
- (Name : in String;
- Language_Protocol_Version : in String;
- Partial_Parse_Active : in out Boolean;
- Params : in Process_Start_Params;
- Parser : in out WisiToken.Parse.LR.Parser.Parser;
- Parse_Data : in out Wisi.Parse_Data_Type'Class;
- Descriptor : in WisiToken.Descriptor)
- is
- use Ada.Text_IO;
- use WisiToken; -- "+", "-" Unbounded_string
-
- procedure Cleanup
- is begin
- if Is_Open (Parser.Recover_Log_File) then
- Close (Parser.Recover_Log_File);
- end if;
- end Cleanup;
-
- begin
- declare
- use Ada.Directories;
- use Ada.Strings.Unbounded;
- begin
- if Length (Params.Recover_Log_File_Name) > 0 then
- Put_Line (";; logging to '" & (-Params.Recover_Log_File_Name) &
"'");
- -- to Current_Output, visible from Emacs
-
- if Exists (-Params.Recover_Log_File_Name) then
- Open (Parser.Recover_Log_File, Append_File,
-Params.Recover_Log_File_Name);
- else
- Create (Parser.Recover_Log_File, Out_File,
-Params.Recover_Log_File_Name);
- end if;
- end if;
- end;
-
- Parser.Trace.Set_Prefix (";; "); -- so debug messages don't confuse
Emacs.
-
- Put_Line
- (Name & " protocol: process version " & Protocol_Version & " language
version " & Language_Protocol_Version);
-
- -- Read commands and tokens from standard_input via GNAT.OS_Lib,
- -- send results to standard_output.
- loop
- Put (Prompt); Flush;
- declare
- Command_Length : constant Integer := Get_Command_Length;
- Command_Line : aliased String (1 .. Command_Length);
- Last : Integer;
-
- function Match (Target : in String) return Boolean
- is begin
- Last := Command_Line'First + Target'Length - 1;
- return Last <= Command_Line'Last and then Command_Line
(Command_Line'First .. Last) = Target;
- end Match;
- begin
- Read_Input (Command_Line'Address, Command_Length);
-
- Put_Line (";; " & Command_Line);
-
- if Match ("parse") then
- -- Args: see wisi-process-parse.el
wisi-process-parse--send-parse
- -- Input: <source text>
- -- Response:
- -- [response elisp vector]...
- -- [elisp error form]...
- -- prompt
- declare
- Params : constant Parse_Params := Get_Parse_Params
(Command_Line, Last);
- Buffer : Ada.Strings.Unbounded.String_Access;
-
- procedure Clean_Up
- is
- use all type SAL.Base_Peek_Type;
- begin
- Parser.Lexer.Discard_Rest_Of_Input;
- if Parser.Parsers.Count > 0 then
- Parse_Data.Put
- (Parser.Lexer.Errors,
- Parser.Parsers.First.State_Ref.Errors,
- Parser.Parsers.First.State_Ref.Tree);
- end if;
- Ada.Strings.Unbounded.Free (Buffer);
- end Clean_Up;
-
- begin
- Trace_Parse := Params.Parse_Verbosity;
- Trace_McKenzie := Params.McKenzie_Verbosity;
- Trace_Action := Params.Action_Verbosity;
- Debug_Mode := Params.Debug_Mode;
-
- Partial_Parse_Active := Params.Partial_Parse_Active;
- Parser.Partial_Parse_Active := Params.Partial_Parse_Active;
-
- if WisiToken.Parse.LR.McKenzie_Defaulted (Parser.Table.all)
then
- -- There is no McKenzie information; don't override that.
- null;
- elsif Params.McKenzie_Disable = -1 then
- -- Use default
- Parser.Enable_McKenzie_Recover := True;
- else
- Parser.Enable_McKenzie_Recover := Params.McKenzie_Disable
= 0;
- end if;
-
- Parse_Data.Initialize
- (Post_Parse_Action => Params.Post_Parse_Action,
- Lexer => Parser.Lexer,
- Descriptor => Descriptor'Unrestricted_Access,
- Base_Terminals => Parser.Terminals'Unrestricted_Access,
- Begin_Line => Params.Begin_Line,
- End_Line => Params.End_Line,
- Begin_Indent => Params.Begin_Indent,
- Params => Command_Line (Last + 2 ..
Command_Line'Last));
-
- if Params.Task_Count > 0 then
- Parser.Table.McKenzie_Param.Task_Count :=
System.Multiprocessors.CPU_Range (Params.Task_Count);
- end if;
- if Params.Check_Limit > 0 then
- Parser.Table.McKenzie_Param.Check_Limit :=
Base_Token_Index (Params.Check_Limit);
- end if;
- if Params.Enqueue_Limit > 0 then
- Parser.Table.McKenzie_Param.Enqueue_Limit :=
Params.Enqueue_Limit;
- end if;
-
- if Params.Max_Parallel > 0 then
- Parser.Max_Parallel := SAL.Base_Peek_Type
(Params.Max_Parallel);
- end if;
-
- Buffer := new String (Params.Begin_Byte_Pos ..
Params.End_Byte_Pos);
-
- Read_Input (Buffer (Params.Begin_Byte_Pos)'Address,
Params.Byte_Count);
-
- Parser.Lexer.Reset_With_String_Access
- (Buffer, Params.Source_File_Name, Params.Begin_Char_Pos,
Params.Begin_Line);
-
- -- Parser.Line_Begin_Token First, Last set by Lex_All
- begin
- Parser.Parse;
- exception
- when WisiToken.Partial_Parse =>
- null;
- end;
- Parser.Execute_Actions;
- Parse_Data.Put (Parser);
- Clean_Up;
-
- exception
- when Syntax_Error =>
- Clean_Up;
- Put_Line ("(parse_error)");
-
- when E : Parse_Error =>
- Clean_Up;
- Put_Line ("(parse_error """ &
Ada.Exceptions.Exception_Message (E) & """)");
-
- when E : Fatal_Error =>
- Clean_Up;
- Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E)
& """)");
- end;
-
- elsif Match ("refactor") then
- -- Args: see wisi-process-parse.el
wisi-process-parse--send-refactor
- -- Input: <source text>
- -- Response:
- -- [edit elisp vector]...
- -- prompt
- declare
- Params : constant Refactor_Params := Get_Refactor_Params
(Command_Line, Last);
- Buffer : Ada.Strings.Unbounded.String_Access;
-
- procedure Clean_Up
- is
- use all type SAL.Base_Peek_Type;
- begin
- Parser.Lexer.Discard_Rest_Of_Input;
- if Parser.Parsers.Count > 0 then
- Parse_Data.Put
- (Parser.Lexer.Errors,
- Parser.Parsers.First.State_Ref.Errors,
- Parser.Parsers.First.State_Ref.Tree);
- end if;
- Ada.Strings.Unbounded.Free (Buffer);
- end Clean_Up;
-
- begin
- Trace_Parse := Params.Parse_Verbosity;
- Trace_Action := Params.Action_Verbosity;
- Debug_Mode := Params.Debug_Mode;
-
- Partial_Parse_Active := True;
-
- Parse_Data.Initialize
- (Post_Parse_Action => Wisi.Navigate, -- mostly ignored
- Lexer => Parser.Lexer,
- Descriptor => Descriptor'Unrestricted_Access,
- Base_Terminals => Parser.Terminals'Unrestricted_Access,
- Begin_Line => Params.Parse_Begin_Line,
- End_Line => Params.Parse_End_Line,
- Begin_Indent => Params.Parse_Begin_Indent,
- Params => "");
-
- if Params.Max_Parallel > 0 then
- Parser.Max_Parallel := SAL.Base_Peek_Type
(Params.Max_Parallel);
- end if;
-
- Buffer := new String (Integer (Params.Parse_Region.First) ..
Integer (Params.Parse_Region.Last));
-
- Read_Input (Buffer (Buffer'First)'Address,
Params.Byte_Count);
-
- Parser.Lexer.Reset_With_String_Access
- (Buffer, Params.Source_File_Name,
Params.Parse_Begin_Char_Pos, Params.Parse_Begin_Line);
- begin
- Parser.Parse;
- exception
- when WisiToken.Partial_Parse =>
- null;
- end;
- Parser.Execute_Actions;
- Parse_Data.Refactor (Parser.Parsers.First_State_Ref.Tree,
Params.Refactor_Action, Params.Edit_Begin);
- Clean_Up;
-
- exception
- when Syntax_Error =>
- Clean_Up;
- Put_Line ("(parse_error ""refactor " &
Params.Parse_Region.First'Image &
- Params.Parse_Region.Last'Image & ": syntax
error"")");
-
- when E : Parse_Error =>
- Clean_Up;
- Put_Line ("(parse_error ""refactor " &
Params.Parse_Region.First'Image &
- Params.Parse_Region.Last'Image & ": " &
Ada.Exceptions.Exception_Message (E) & """)");
-
- when E : others => -- includes Fatal_Error
- Clean_Up;
- Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E)
& """)");
- end;
-
- elsif Match ("noop") then
- -- Args: <source byte count>
- -- Input: <source text>
- -- Response: prompt
- declare
- Byte_Count : constant Integer
:= Get_Integer (Command_Line, Last);
- Buffer : constant Ada.Strings.Unbounded.String_Access
:= new String (1 .. Byte_Count);
- Token : Base_Token;
- Lexer_Error : Boolean;
- pragma Unreferenced (Lexer_Error);
- begin
- Token.ID := Invalid_Token_ID;
- Read_Input (Buffer (1)'Address, Byte_Count);
-
- Parser.Lexer.Reset_With_String_Access (Buffer, +"");
- loop
- exit when Token.ID = Parser.Trace.Descriptor.EOI_ID;
- Lexer_Error := Parser.Lexer.Find_Next (Token);
- end loop;
- exception
- when Syntax_Error =>
- Parser.Lexer.Discard_Rest_Of_Input;
- end;
-
- elsif Match ("quit") then
- exit;
-
- else
- Put_Line ("(error ""bad command: '" & Command_Line & "'"")");
- end if;
- exception
- when E : Protocol_Error =>
- -- don't exit the loop; allow debugging bad elisp
- Put_Line ("(error ""protocol error "": " &
Ada.Exceptions.Exception_Message (E) & """)");
- end;
- end loop;
- Cleanup;
- exception
- when Finish =>
- null;
-
- when E : others =>
- Cleanup;
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
- New_Line (2);
- Put_Line
- ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E)
& ": " &
- Ada.Exceptions.Exception_Message (E) & """)");
- end Process_Stream;
-
-end Emacs_Wisi_Common_Parse;
diff --git a/packages/wisi/emacs_wisi_common_parse.ads
b/packages/wisi/emacs_wisi_common_parse.ads
deleted file mode 100644
index e646eba..0000000
--- a/packages/wisi/emacs_wisi_common_parse.ads
+++ /dev/null
@@ -1,157 +0,0 @@
--- Abstract :
---
--- Common utilities for Gen_Emacs_Wisi_*_Parse
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Strings.Unbounded;
-with System;
-with Wisi;
-with WisiToken.Parse.LR.Parser;
-package Emacs_Wisi_Common_Parse is
-
- Protocol_Version : constant String := "5";
- -- Protocol_Version defines the data sent between elisp and the
- -- background process, except for the language-specific parameters,
- -- which are defined by the Language_Protocol_Version parameter to
- -- Parse_Stream, below.
- --
- -- This value must match wisi-process-parse.el
- -- wisi-process-parse-protocol-version.
- --
- -- See wisi-process-parse.el functions, and this package body, for
- -- the implementation of the protocol.
- --
- -- Only changes once per wisi release. Increment as soon as required,
- -- record new version in NEWS-wisi.text.
-
- Prompt : constant String := ";;> ";
-
- Protocol_Error : exception;
- Finish : exception;
-
- procedure Usage (Name : in String);
-
- procedure Read_Input (A : System.Address; N : Integer);
-
- function Get_Command_Length return Integer;
-
- function Get_String
- (Source : in String;
- Last : in out Integer)
- return String;
-
- function Get_Integer
- (Source : in String;
- Last : in out Integer)
- return Integer;
-
- type Process_Start_Params is record
- Recover_Log_File_Name : Ada.Strings.Unbounded.Unbounded_String;
- -- log enabled if non-empty.
- end record;
-
- function Get_Process_Start_Params return Process_Start_Params;
- -- Get from Ada.Command_Line. Handles --help by outputing help,
- -- raising Finish.
-
- procedure Process_Stream
- (Name : in String;
- Language_Protocol_Version : in String;
- Partial_Parse_Active : in out Boolean;
- Params : in Process_Start_Params;
- Parser : in out WisiToken.Parse.LR.Parser.Parser;
- Parse_Data : in out Wisi.Parse_Data_Type'Class;
- Descriptor : in WisiToken.Descriptor);
-
- ----------
- -- Parse command
-
- type Parse_Params is record
- Post_Parse_Action : Wisi.Post_Parse_Action_Type;
- Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
-
- Begin_Byte_Pos : Integer;
- -- Source file byte position of first char sent; start parse here.
-
- End_Byte_Pos : Integer;
- -- Byte position of last char sent.
-
- Goal_Byte_Pos : Integer;
- -- Byte position of end of desired parse region; terminate parse at
- -- or after here.
-
- Begin_Char_Pos : WisiToken.Buffer_Pos;
- -- Char position of first char sent.
-
- Begin_Line : WisiToken.Line_Number_Type;
- End_Line : WisiToken.Line_Number_Type;
- -- Line number of line containing Begin_Byte_Pos, End_Byte_Pos
-
- Begin_Indent : Integer;
- -- Indentation of Line_Begin
-
- Partial_Parse_Active : Boolean;
- Debug_Mode : Boolean;
- Parse_Verbosity : Integer;
- McKenzie_Verbosity : Integer;
- Action_Verbosity : Integer;
- McKenzie_Disable : Integer;
- Task_Count : Integer;
- Check_Limit : Integer;
- Enqueue_Limit : Integer;
- Max_Parallel : Integer;
- Byte_Count : Integer;
- -- Count of bytes of source file sent.
- end record;
-
- function Get_Parse_Params (Command_Line : in String; Last : in out Integer)
return Parse_Params;
-
- ----------
- -- Refactor command
-
- type Refactor_Params is record
- Refactor_Action : Positive; -- Language-specific
- Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
-
- Parse_Region : WisiToken.Buffer_Region;
- -- Source file byte region to parse.
-
- Edit_Begin : WisiToken.Buffer_Pos;
- -- Source file byte position at start of expression to refactor.
-
- Parse_Begin_Char_Pos : WisiToken.Buffer_Pos;
- -- Char position of first char sent.
-
- Parse_Begin_Line : WisiToken.Line_Number_Type;
- Parse_End_Line : WisiToken.Line_Number_Type;
- -- Line numbers of lines containing Parse_Begin_Byte_Pos,
Parse_End_Byte_Pos
-
- Parse_Begin_Indent : Integer;
- -- Indentation of Parse_Begin_Line
-
- Debug_Mode : Boolean;
- Parse_Verbosity : Integer;
- Action_Verbosity : Integer;
- Max_Parallel : Integer;
- Byte_Count : Integer;
- -- Count of bytes of source file sent.
- end record;
-
- function Get_Refactor_Params (Command_Line : in String; Last : in out
Integer) return Refactor_Params;
-
-end Emacs_Wisi_Common_Parse;
diff --git a/packages/wisi/gen_emacs_wisi_lr_parse.adb
b/packages/wisi/gen_emacs_wisi_lr_parse.adb
deleted file mode 100644
index 0f81868..0000000
--- a/packages/wisi/gen_emacs_wisi_lr_parse.adb
+++ /dev/null
@@ -1,39 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2014, 2017 - 2020 All Rights Reserved.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Emacs_Wisi_Common_Parse; use Emacs_Wisi_Common_Parse;
-with WisiToken.Parse.LR.Parser;
-with WisiToken.Text_IO_Trace;
-procedure Gen_Emacs_Wisi_LR_Parse
-is
- Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
- Parser : WisiToken.Parse.LR.Parser.Parser;
- Parse_Data : aliased Parse_Data_Type (Parser.Terminals'Access,
Parser.Line_Begin_Token'Access);
-
- Params : constant Process_Start_Params := Get_Process_Start_Params;
-begin
- Create_Parser
- (Parser, Language_Fixes, Language_Matching_Begin_Tokens,
Language_String_ID_Set,
- Trace'Unrestricted_Access,
- Parse_Data'Unchecked_Access);
-
- Process_Stream (Name, Language_Protocol_Version, Partial_Parse_Active,
Params, Parser, Parse_Data, Descriptor);
-
-end Gen_Emacs_Wisi_LR_Parse;
diff --git a/packages/wisi/gen_emacs_wisi_lr_parse.ads
b/packages/wisi/gen_emacs_wisi_lr_parse.ads
deleted file mode 100644
index 02eac21..0000000
--- a/packages/wisi/gen_emacs_wisi_lr_parse.ads
+++ /dev/null
@@ -1,55 +0,0 @@
--- Abstract :
---
--- Generic Emacs background process; parse token stream, return
--- parser actions.
---
--- See gen_run_wisi_parse.ads for a standalone version.
---
--- References :
---
--- [1] On the elisp side, the inter-process protocol is defined in
--- wisi-process-parse.el, functions wisi-process-parse--send-parse
--- and wisi-process-parse--execute.
---
--- [2] On the Ada side, it is defined here, and in
--- wisitoken-wisi_runtime.adb
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with WisiToken.Parse.LR.Parser;
-with WisiToken.Syntax_Trees;
-with Wisi;
-generic
- type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
-
- Name : in String; -- for Usage, error messages.
- Language_Protocol_Version : in String; -- Defines language-specific
parse parameters.
- Descriptor : in WisiToken.Descriptor;
- Partial_Parse_Active : in out Boolean;
- Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
-
- with procedure Create_Parser
- (Parser : out
WisiToken.Parse.LR.Parser.Parser;
- Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
- Trace : not null access WisiToken.Trace'Class;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access);
-
-procedure Gen_Emacs_Wisi_LR_Parse;
diff --git a/packages/wisi/gen_emacs_wisi_lr_text_rep_parse.adb
b/packages/wisi/gen_emacs_wisi_lr_text_rep_parse.adb
deleted file mode 100644
index 31f1052..0000000
--- a/packages/wisi/gen_emacs_wisi_lr_text_rep_parse.adb
+++ /dev/null
@@ -1,44 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2014, 2017 - 2020 All Rights Reserved.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Command_Line;
-with Ada.Directories;
-with Emacs_Wisi_Common_Parse; use Emacs_Wisi_Common_Parse;
-
-with WisiToken.Text_IO_Trace;
-procedure Gen_Emacs_Wisi_LR_Text_Rep_Parse
-is
- use WisiToken; -- "+", "-" Unbounded_string
-
- Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
- Parser : WisiToken.Parse.LR.Parser.Parser;
- Parse_Data : aliased Parse_Data_Type (Parser.Terminals'Access,
Parser.Line_Begin_Token'Access);
-
- Params : constant Process_Start_Params := Get_Process_Start_Params;
-begin
- Create_Parser
- (Parser, Language_Fixes, Language_Matching_Begin_Tokens,
Language_String_ID_Set,
- Trace'Unrestricted_Access,
- Parse_Data'Unchecked_Access,
- Ada.Directories.Containing_Directory (Ada.Command_Line.Command_Name) &
"/" & Text_Rep_File_Name);
-
- Process_Stream (Name, Language_Protocol_Version, Partial_Parse_Active,
Params, Parser, Parse_Data, Descriptor);
-
-end Gen_Emacs_Wisi_LR_Text_Rep_Parse;
diff --git a/packages/wisi/gen_emacs_wisi_lr_text_rep_parse.ads
b/packages/wisi/gen_emacs_wisi_lr_text_rep_parse.ads
deleted file mode 100644
index f9ff468..0000000
--- a/packages/wisi/gen_emacs_wisi_lr_text_rep_parse.ads
+++ /dev/null
@@ -1,50 +0,0 @@
--- Abstract :
---
--- Generic Emacs background process; parse token stream, return
--- parser actions.
---
--- See gen_run_wisi_parse.ads for a standalone version.
---
--- References : see gen_emacs_wisi_lr_parse.ads
---
--- Copyright (C) 2017, 2018, 2019 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with WisiToken.Parse.LR.Parser;
-with WisiToken.Syntax_Trees;
-with Wisi;
-generic
- type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
-
- Name : in String; -- for Usage, error messages.
"_wisi_parse" will be appended
- Language_Protocol_Version : in String; -- Defines language-specific
parse parameters.
- Descriptor : in WisiToken.Descriptor;
- Partial_Parse_Active : in out Boolean;
- Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
- Text_Rep_File_Name : in String;
-
- with procedure Create_Parser
- (Parser : out
WisiToken.Parse.LR.Parser.Parser;
- Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
- Trace : not null access WisiToken.Trace'Class;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
- Text_Rep_File_Name : in String);
-
-procedure Gen_Emacs_Wisi_LR_Text_Rep_Parse;
diff --git a/packages/wisi/gen_emacs_wisi_packrat_parse.adb
b/packages/wisi/gen_emacs_wisi_packrat_parse.adb
deleted file mode 100644
index b4e95f6..0000000
--- a/packages/wisi/gen_emacs_wisi_packrat_parse.adb
+++ /dev/null
@@ -1,180 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 All Rights Reserved.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Command_Line;
-with Ada.Exceptions;
-with Ada.Strings.Fixed;
-with Ada.Strings.Unbounded;
-with Ada.Text_IO; use Ada.Text_IO;
-with Emacs_Wisi_Common_Parse; use Emacs_Wisi_Common_Parse;
-with GNAT.OS_Lib;
-with GNAT.Traceback.Symbolic;
-with System.Storage_Elements;
-with WisiToken.Lexer;
-with WisiToken.Parse.Packrat;
-with WisiToken.Text_IO_Trace;
-procedure Gen_Emacs_Wisi_Parse_Packrat
-is
- use WisiToken; -- "+", "-" Unbounded_string
-
- Trace : aliased WisiToken.Text_IO_Trace.Trace (Descriptor'Access);
- Parser : WisiToken.Parse.Packrat.Parser;
- Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
-
-begin
- Create_Parser (Parser, Trace'Unrestricted_Access,
Parse_Data'Unchecked_Access);
-
- declare
- use Ada.Command_Line;
- begin
- case Argument_Count is
- when 0 =>
- null;
-
- when others =>
- Usage (Name);
- raise Programmer_Error with "invalid option count: " & Integer'Image
(Argument_Count);
- end case;
- end;
-
- Put_Line (Name & " " & Version & ", protocol version " & Protocol_Version);
-
- -- Read commands and tokens from standard_input via GNAT.OS_Lib,
- -- send results to standard_output.
- loop
- Put (Prompt); Flush;
- declare
- Command_Length : constant Integer := Get_Command_Length;
- Command_Line : aliased String (1 .. Command_Length);
- Last : Integer;
-
- function Match (Target : in String) return Boolean
- is begin
- Last := Command_Line'First + Target'Length - 1;
- return Last <= Command_Line'Last and then Command_Line
(Command_Line'First .. Last) = Target;
- end Match;
- begin
- Read_Input (Command_Line'Address, Command_Length);
-
- Put_Line (";; " & Command_Line);
-
- if Match ("parse") then
- -- Args: see Usage
- -- Input: <source text>
- -- Response:
- -- [response elisp vector]...
- -- [elisp error form]...
- -- prompt
- declare
- use Wisi;
- Cl_Params : constant Command_Line_Params := Get_Cl_Params
(Command_Line, Last);
- Buffer : Ada.Strings.Unbounded.String_Access;
-
- procedure Clean_Up
- is begin
- Parser.Lexer.Discard_Rest_Of_Input;
- Parser.Put_Errors (-Cl_Param.Source_File_Name);
- Ada.Strings.Unbounded.Free (Buffer);
- end Clean_Up;
-
- begin
- -- Computing Line_Count in elisp allows parsing in parallel
with
- -- sending source text.
-
- Trace_Parse := Cl_Params.Parse_Verbosity;
- Trace_McKenzie := Cl_Params.McKenzie_Verbosity;
- Trace_Action := Cl_Params.Action_Verbosity;
- Debug_Mode := Cl_Params.Debug_Mode;
-
- Parse_Data.Initialize
- (Post_Parse_Action => Cl_Params.Post_Parse_Action,
- Descriptor => Descriptor'Access,
- Source_File_Name => -Cl_Params.Source_File_Name,
- Line_Count => Cl_Params.Line_Count,
- Params => Command_Line (Last + 2 ..
Command_Line'Last));
-
- Buffer := new String (1 .. Cl_Params.Byte_Count);
- Read_Input (Buffer (1)'Address, Cl_Params.Byte_Count);
-
- Parser.Lexer.Reset_With_String_Access (Buffer);
- Parser.Parse;
- Parser.Execute_Actions;
- Put (Parse_Data);
- Clean_Up;
-
- exception
- when Syntax_Error =>
- Clean_Up;
- Put_Line ("(parse_error)");
-
- when E : Parse_Error =>
- Clean_Up;
- Put_Line ("(parse_error """ & Ada.Exceptions.Exception_Message
(E) & """)");
-
- when E : Fatal_Error =>
- Clean_Up;
- Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E) &
""")");
- end;
-
- elsif Match ("noop") then
- -- Args: <source byte count>
- -- Input: <source text>
- -- Response: prompt
- declare
- Byte_Count : constant Integer :=
Get_Integer (Command_Line, Last);
- Buffer : constant Ada.Strings.Unbounded.String_Access :=
new String (1 .. Byte_Count);
- Token : Base_Token;
- Lexer_Error : Boolean;
- pragma Unreferenced (Lexer_Error);
- begin
- Token.ID := Invalid_Token_ID;
- Read_Input (Buffer (1)'Address, Byte_Count);
-
- Parser.Lexer.Reset_With_String_Access (Buffer);
- loop
- exit when Token.ID = Parser.Trace.Descriptor.EOF_ID;
- Lexer_Error := Parser.Lexer.Find_Next (Token);
- end loop;
- exception
- when Syntax_Error =>
- Parser.Lexer.Discard_Rest_Of_Input;
- end;
-
- elsif Match ("quit") then
- exit;
-
- else
- Put_Line ("(error ""bad command: '" & Command_Line & "'"")");
- end if;
- exception
- when E : Protocol_Error =>
- -- don't exit the loop; allow debugging bad elisp
- Put_Line ("(error ""protocol error "": " &
Ada.Exceptions.Exception_Message (E) & """)");
- end;
- end loop;
-exception
-when E : others =>
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
- New_Line (2);
- Put_Line
- ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E) &
": " &
- Ada.Exceptions.Exception_Message (E) & """)");
- Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
-end Gen_Emacs_Wisi_Parse_Packrat;
diff --git a/packages/wisi/gen_emacs_wisi_packrat_parse.ads
b/packages/wisi/gen_emacs_wisi_packrat_parse.ads
deleted file mode 100644
index 79c69ec..0000000
--- a/packages/wisi/gen_emacs_wisi_packrat_parse.ads
+++ /dev/null
@@ -1,42 +0,0 @@
--- Abstract :
---
--- Generic Emacs background process; packrat parse token stream,
--- return parser actions.
---
--- See gen_run_wisi_parse_packrat.ads for a standalone version.
---
--- References :
---
--- See gen_emacs_wisi_parse.ads
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with WisiToken.Parse.Packrat;
-with WisiToken.Syntax_Trees;
-with WisiToken.Wisi_Runtime;
-generic
- type Parse_Data_Type is new WisiToken.Wisi_Runtime.Parse_Data_Type with
private;
-
- Name : in String; -- for Usage, error messages.
"_wisi_parse_packrat" will be appended
- Descriptor : in WisiToken.Descriptor;
-
- with procedure Create_Parser
- (Parser : out WisiToken.Parse.Packrat.Parser;
- Trace : not null access WisiToken.Trace'Class;
- User_Data : in WisiToken.Syntax_Trees.User_Data_Access);
-
-procedure Gen_Emacs_Wisi_Parse_Packrat;
diff --git a/packages/wisi/gen_run_wisi_libadalang_parse.adb
b/packages/wisi/gen_run_wisi_libadalang_parse.adb
deleted file mode 100644
index c154136..0000000
--- a/packages/wisi/gen_run_wisi_libadalang_parse.adb
+++ /dev/null
@@ -1,176 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 All Rights Reserved.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Command_Line;
-with Ada.Exceptions;
-with Ada.Real_Time;
-with Ada.Strings.Unbounded;
-with Ada.Text_IO; use Ada.Text_IO;
-with GNAT.Traceback.Symbolic;
-with Wisi.Libadalang;
-with WisiToken.Text_IO_Trace;
-procedure Gen_Run_Wisi_Libadalang_Parse
-is
- use WisiToken; -- Token_ID, "+", "-" Unbounded_string
-
- Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
- Parser : Wisi.Libadalang.Parser;
- Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
-
- procedure Put_Usage
- is begin
- Put_Line ("usage: <file_name> <parse_action> [options]");
- Put_Line ("parse_action: {Navigate | Face | Indent}");
- Put_Line ("options:");
- Put_Line ("--verbosity n m : parse, action");
- Put_Line ("--lang_params <language-specific params>");
- Put_Line ("--repeat_count n : repeat parse count times, for profiling;
default 1");
- New_Line;
- end Put_Usage;
-
- Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
- Post_Parse_Action : Wisi.Post_Parse_Action_Type;
- Lang_Params : Ada.Strings.Unbounded.Unbounded_String;
-
- Repeat_Count : Integer := 1;
- Arg : Integer;
- Start : Ada.Real_Time.Time;
-
-begin
- declare
- use Ada.Command_Line;
- begin
- if Argument_Count < 1 then
- Put_Usage;
- Set_Exit_Status (Failure);
- return;
- end if;
-
- Source_File_Name := +Ada.Command_Line.Argument (1);
- Post_Parse_Action := Wisi.Post_Parse_Action_Type'Value
(Ada.Command_Line.Argument (2));
- Arg := 3;
-
- loop
- exit when Arg > Argument_Count;
-
- if Argument (Arg) = "--lang_params" then
- Lang_Params := +Argument (Arg + 1);
- Arg := Arg + 2;
-
- elsif Argument (Arg) = "--repeat_count" then
- Repeat_Count := Integer'Value (Argument (Arg + 1));
- Arg := Arg + 2;
-
- elsif Argument (Arg) = "--verbosity" then
- WisiToken.Trace_Parse := Integer'Value (Argument (Arg + 1));
- WisiToken.Trace_Action := Integer'Value (Argument (Arg + 2));
- Arg := Arg + 3;
-
- else
- Put_Line ("unrecognized option: '" & Argument (Arg) & "'");
- Put_Usage;
- return;
- end if;
- end loop;
- end;
-
- Parser.Trace := Trace'Unrestricted_Access;
- Parser.Lexer := new Wisi.Libadalang.Lexer
(Trace'Unrestricted_Access);
- Parser.User_Data := Parse_Data'Unrestricted_Access;
- Parser.Source_File_Name := Source_File_Name;
-
- Parser.Tree.Initialize (Shared_Tree =>
Parser.Base_Tree'Unrestricted_Access, Flush => True);
-
- Parse_Data.Initialize
- (Post_Parse_Action => Post_Parse_Action,
- Descriptor => Descriptor'Unrestricted_Access,
- Source_File_Name => -Source_File_Name,
- Line_Count => 1, -- FIXME: fix wisi_runtime to not need this!
- Params => -Lang_Params);
-
- if Repeat_Count > 1 then
- Start := Ada.Real_Time.Clock;
- end if;
-
- for I in 1 .. Repeat_Count loop
- declare
- procedure Clean_Up
- is begin
- if I = 1 then
- null;
- -- FIXME: Errors!
- -- Parse_Data.Put
- -- (Parser.Lexer.Errors,
- -- Parser.Parsers.First.State_Ref.Errors,
- -- Parser.Parsers.First.State_Ref.Tree);
- end if;
- end Clean_Up;
-
- begin
- Parse_Data.Reset;
- Parser.Parse;
- Parser.Execute_Actions;
-
- if Repeat_Count = 1 then
- Parse_Data.Put;
-
- -- FIXME: put errors via parse_data.put
- if Parser.Any_Errors then
- Parser.Put_Errors;
- end if;
- -- Parse_Data.Put
- -- (Parser.Lexer.Errors,
- -- Parser.Parsers.First.State_Ref.Errors,
- -- Parser.Parsers.First.State_Ref.Tree);
- end if;
- exception
- when WisiToken.Syntax_Error =>
- Clean_Up;
- Put_Line ("(parse_error)");
-
- when E : WisiToken.Parse_Error =>
- Clean_Up;
- Put_Line ("(parse_error """ & Ada.Exceptions.Exception_Message (E) &
""")");
-
- when E : WisiToken.Fatal_Error =>
- Clean_Up;
- Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E) & """)");
- end;
- end loop;
-
- if Repeat_Count > 1 then
- declare
- use Ada.Real_Time;
- Finish : constant Time := Clock;
- begin
- Put_Line ("Total time:" & Duration'Image (To_Duration (Finish -
Start)));
- Put_Line ("per iteration:" & Duration'Image (To_Duration ((Finish -
Start) / Repeat_Count)));
- end;
- end if;
-
-exception
-when E : others =>
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
- New_Line (2);
- Put_Line
- ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E) &
": " &
- Ada.Exceptions.Exception_Message (E) & """)");
- Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
-end Gen_Run_Wisi_Libadalang_Parse;
diff --git a/packages/wisi/gen_run_wisi_libadalang_parse.ads
b/packages/wisi/gen_run_wisi_libadalang_parse.ads
deleted file mode 100644
index 356c67d..0000000
--- a/packages/wisi/gen_run_wisi_libadalang_parse.ads
+++ /dev/null
@@ -1,30 +0,0 @@
--- Abstract :
---
--- Run an Emacs libadalang parser as a standalone executable, for debugging.
---
--- See gen_emacs_wisi_libadalang_parse.ads for the Emacs background process.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Wisi;
-with WisiToken;
-generic
- type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
-
- Descriptor : in WisiToken.Descriptor;
-
-procedure Gen_Run_Wisi_Libadalang_Parse;
diff --git a/packages/wisi/gen_run_wisi_lr_parse.adb
b/packages/wisi/gen_run_wisi_lr_parse.adb
deleted file mode 100644
index 84498de..0000000
--- a/packages/wisi/gen_run_wisi_lr_parse.adb
+++ /dev/null
@@ -1,37 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2020 All Rights Reserved.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Run_Wisi_Common_Parse;
-with WisiToken.Text_IO_Trace;
-procedure Gen_Run_Wisi_LR_Parse
-is
- Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
- Parser : WisiToken.Parse.LR.Parser.Parser;
- Parse_Data : aliased Parse_Data_Type (Parser.Terminals'Access,
Parser.Line_Begin_Token'Access);
-begin
- -- Create parser first so Put_Usage has defaults from Parser.Table,
- -- and Get_CL_Params can override them.
- Create_Parser
- (Parser, Language_Fixes, Language_Matching_Begin_Tokens,
Language_String_ID_Set,
- Trace'Unrestricted_Access, Parse_Data'Unchecked_Access);
-
- Run_Wisi_Common_Parse.Parse_File (Parser, Parse_Data, Descriptor);
-
-end Gen_Run_Wisi_LR_Parse;
diff --git a/packages/wisi/gen_run_wisi_lr_parse.ads
b/packages/wisi/gen_run_wisi_lr_parse.ads
deleted file mode 100644
index 34fbd3c..0000000
--- a/packages/wisi/gen_run_wisi_lr_parse.ads
+++ /dev/null
@@ -1,42 +0,0 @@
--- Abstract :
---
--- Run an Emacs LR parser as a standalone executable, for debugging.
---
--- See gen_emacs_wisi_lr_parse.ads for the Emacs background process.
---
--- Copyright (C) 2017, 2018, 2019 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with WisiToken.Parse.LR.Parser;
-with WisiToken.Syntax_Trees;
-with Wisi;
-generic
- type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
-
- Descriptor : in WisiToken.Descriptor;
- Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
-
- with procedure Create_Parser
- (Parser : out
WisiToken.Parse.LR.Parser.Parser;
- Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
- Trace : not null access WisiToken.Trace'Class;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access);
-
-procedure Gen_Run_Wisi_LR_Parse;
diff --git a/packages/wisi/gen_run_wisi_lr_text_rep_parse.adb
b/packages/wisi/gen_run_wisi_lr_text_rep_parse.adb
deleted file mode 100644
index 45bc5e1..0000000
--- a/packages/wisi/gen_run_wisi_lr_text_rep_parse.adb
+++ /dev/null
@@ -1,44 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2020 All Rights Reserved.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Command_Line;
-with Ada.Directories;
-with Run_Wisi_Common_Parse;
-with WisiToken.Text_IO_Trace;
-procedure Gen_Run_Wisi_LR_Text_Rep_Parse
-is
- Trace : aliased WisiToken.Text_IO_Trace.Trace
(Descriptor'Unrestricted_Access);
- Parser : WisiToken.Parse.LR.Parser.Parser;
- Parse_Data : aliased Parse_Data_Type (Parser.Terminals'Access,
Parser.Line_Begin_Token'Access);
-begin
- -- Create parser first so Put_Usage has defaults from Parser.Table,
- -- and Get_CL_Params can override them.
- declare
- use Ada.Command_Line;
- begin
- -- text_rep file is in same directory as exectuable.
- Create_Parser
- (Parser, Language_Fixes, Language_Matching_Begin_Tokens,
Language_String_ID_Set,
- Trace'Unrestricted_Access, Parse_Data'Unchecked_Access,
- Ada.Directories.Containing_Directory (Command_Name) & "/" &
Text_Rep_File_Name);
-
- Run_Wisi_Common_Parse.Parse_File (Parser, Parse_Data, Descriptor);
- end;
-end Gen_Run_Wisi_LR_Text_Rep_Parse;
diff --git a/packages/wisi/gen_run_wisi_lr_text_rep_parse.ads
b/packages/wisi/gen_run_wisi_lr_text_rep_parse.ads
deleted file mode 100644
index dd45d16..0000000
--- a/packages/wisi/gen_run_wisi_lr_text_rep_parse.ads
+++ /dev/null
@@ -1,44 +0,0 @@
--- Abstract :
---
--- Run an Emacs LR text_rep parser as a standalone executable, for debugging.
---
--- See gen_emacs_wisi_*_parse.ads for the Emacs background process.
---
--- Copyright (C) 2018, 2019 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with WisiToken.Parse.LR.Parser;
-with WisiToken.Syntax_Trees;
-with Wisi;
-generic
- type Parse_Data_Type is new Wisi.Parse_Data_Type with private;
-
- Descriptor : in WisiToken.Descriptor;
- Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
- Text_Rep_File_Name : in String;
-
- with procedure Create_Parser
- (Parser : out
WisiToken.Parse.LR.Parser.Parser;
- Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
- Trace : not null access WisiToken.Trace'Class;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
- Text_Rep_File_Name : in String);
-
-procedure Gen_Run_Wisi_LR_Text_Rep_Parse;
diff --git a/packages/wisi/gen_run_wisi_packrat_parse.adb
b/packages/wisi/gen_run_wisi_packrat_parse.adb
deleted file mode 100644
index fb3e900..0000000
--- a/packages/wisi/gen_run_wisi_packrat_parse.adb
+++ /dev/null
@@ -1,241 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 All Rights Reserved.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Command_Line;
-with Ada.Exceptions;
-with Ada.IO_Exceptions;
-with Ada.Real_Time;
-with Ada.Strings.Unbounded;
-with Ada.Text_IO; use Ada.Text_IO;
-with GNAT.Traceback.Symbolic;
-with WisiToken.Lexer;
-with WisiToken.Text_IO_Trace;
-procedure Gen_Run_Wisi_Parse_Packrat
-is
- use WisiToken; -- Token_ID, "+", "-" Unbounded_string
-
- Trace : aliased WisiToken.Text_IO_Trace.Trace (Descriptor'Access);
- Parser : WisiToken.Parse.Packrat.Parser;
- Parse_Data : aliased Parse_Data_Type (Parser.Line_Begin_Token'Access);
-
- procedure Put_Usage
- is begin
- Put_Line ("usage: " & Name & "_wisi_parse <file_name> <parse_action>
[options]");
- Put_Line ("parse_action: {Navigate | Face | Indent}");
- Put_Line ("options:");
- Put_Line ("--verbosity n m l:");
- Put_Line (" n: parser; m: mckenzie; l: action");
- Put_Line (" 0 - only report parse errors");
- Put_Line (" 1 - shows spawn/terminate parallel parsers, error recovery
enter/exit");
- Put_Line (" 2 - add each parser cycle, error recovery enqueue/check");
- Put_Line (" 3 - parse stack in each cycle, error recovery parse
actions");
- Put_Line (" 4 - add lexer debug");
- Put_Line ("--lang_params <language-specific params>");
- Put_Line ("--lexer_only : only run lexer, for profiling");
- Put_Line ("--repeat_count n : repeat parse count times, for profiling;
default 1");
- Put_Line ("--pause : when repeating, prompt for <enter> after each
parse; allows seeing memory leaks");
- New_Line;
- end Put_Usage;
-
- Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
- Post_Parse_Action : WisiToken.Wisi_Runtime.Post_Parse_Action_Type;
-
- Line_Count : WisiToken.Line_Number_Type := 1;
- Lexer_Only : Boolean := False;
- Repeat_Count : Integer := 1;
- Pause : Boolean := False;
- Arg : Integer;
- Lang_Params : Ada.Strings.Unbounded.Unbounded_String;
- Start : Ada.Real_Time.Time;
-begin
- Create_Parser (Parser, Trace'Unrestricted_Access,
Parse_Data'Unchecked_Access);
-
- declare
- use Ada.Command_Line;
- begin
- if Argument_Count < 1 then
- Put_Usage;
- Set_Exit_Status (Failure);
- return;
- end if;
-
- Source_File_Name := +Ada.Command_Line.Argument (1);
- Post_Parse_Action := WisiToken.Wisi_Runtime.Post_Parse_Action_Type'Value
(Ada.Command_Line.Argument (2));
- Arg := 3;
-
- loop
- exit when Arg > Argument_Count;
-
- if Argument (Arg) = "--verbosity" then
- WisiToken.Trace_Parse := Integer'Value (Argument (Arg + 1));
- WisiToken.Trace_McKenzie := Integer'Value (Argument (Arg + 2));
- WisiToken.Trace_Action := Integer'Value (Argument (Arg + 3));
- Arg := Arg + 4;
-
- elsif Argument (Arg) = "--lang_params" then
- Lang_Params := +Argument (Arg + 1);
- Arg := Arg + 2;
-
- elsif Argument (Arg) = "--lexer_only" then
- Lexer_Only := True;
- Arg := Arg + 1;
-
- elsif Argument (Arg) = "--pause" then
- Pause := True;
- Arg := Arg + 1;
-
- elsif Argument (Arg) = "--repeat_count" then
- Repeat_Count := Integer'Value (Argument (Arg + 1));
- Arg := Arg + 2;
-
- else
- Put_Line ("unrecognized option: '" & Argument (Arg) & "'");
- Put_Usage;
- return;
- end if;
- end loop;
- end;
-
- -- Do this after setting Trace_Parse so lexer verbosity is set
- begin
- Parser.Lexer.Reset_With_File (-Source_File_Name);
- exception
- when Ada.IO_Exceptions.Name_Error =>
- Put_Line (Standard_Error, "'" & (-Source_File_Name) & "' cannot be
opened");
- return;
- end;
-
- -- See comment in wisi-wisi_runtime.ads for why we still need this.
- declare
- Token : Base_Token;
- Lexer_Error : Boolean;
- pragma Unreferenced (Lexer_Error);
- begin
- loop
- begin
- Lexer_Error := Parser.Lexer.Find_Next (Token);
- exit when Token.ID = Descriptor.EOF_ID;
- exception
- when WisiToken.Syntax_Error =>
- Parser.Lexer.Discard_Rest_Of_Input;
- Parser.Put_Errors (-Source_File_Name);
- Put_Line ("(lexer_error)");
- end;
- end loop;
- Line_Count := Token.Line;
- end;
-
- if WisiToken.Trace_Action > WisiToken.Outline then
- Put_Line ("line_count:" & Line_Number_Type'Image (Line_Count));
- end if;
-
- Parse_Data.Initialize
- (Post_Parse_Action => Post_Parse_Action,
- Descriptor => Descriptor'Access,
- Source_File_Name => -Source_File_Name,
- Line_Count => Line_Count,
- Params => -Lang_Params);
-
- if Repeat_Count > 1 then
- Start := Ada.Real_Time.Clock;
- end if;
-
- for I in 1 .. Repeat_Count loop
- declare
- procedure Clean_Up
- is begin
- Parser.Lexer.Discard_Rest_Of_Input;
- if Repeat_Count = 1 then
- Parser.Put_Errors (-Source_File_Name);
- end if;
- end Clean_Up;
-
- begin
- Parse_Data.Reset;
- Parser.Lexer.Reset;
-
- if Lexer_Only then
- declare
- Token : Base_Token;
- Lexer_Error : Boolean;
- pragma Unreferenced (Lexer_Error);
- begin
- Parser.Lexer.Reset;
- loop
- Lexer_Error := Parser.Lexer.Find_Next (Token);
- exit when Token.ID = Descriptor.EOF_ID;
- end loop;
- -- We don't handle errors here; that was done in the count
lines loop
- -- above.
- end;
- else
- Parser.Parse;
- Parser.Execute_Actions;
-
- if Repeat_Count = 1 then
- Parse_Data.Put;
- Parser.Put_Errors (-Source_File_Name);
- end if;
- end if;
- exception
- when WisiToken.Syntax_Error =>
- Clean_Up;
- Put_Line ("(parse_error)");
-
- when E : WisiToken.Parse_Error =>
- Clean_Up;
- Put_Line ("(parse_error """ & Ada.Exceptions.Exception_Message (E) &
""")");
-
- when E : WisiToken.Fatal_Error =>
- Clean_Up;
- Put_Line ("(error """ & Ada.Exceptions.Exception_Message (E) & """)");
- end;
-
- if Pause then
- Put_Line ("Enter to continue:");
- Flush (Standard_Output);
- declare
- Junk : constant String := Get_Line;
- pragma Unreferenced (Junk);
- begin
- null;
- end;
- end if;
- end loop;
-
- if Repeat_Count > 1 then
- declare
- use Ada.Real_Time;
- Finish : constant Time := Clock;
- begin
- Put_Line ("Total time:" & Duration'Image (To_Duration (Finish -
Start)));
- Put_Line ("per iteration:" & Duration'Image (To_Duration ((Finish -
Start) / Repeat_Count)));
- end;
- end if;
-
-exception
-when E : others =>
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
- New_Line (2);
- Put_Line
- ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E) &
": " &
- Ada.Exceptions.Exception_Message (E) & """)");
- Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
-end Gen_Run_Wisi_Parse_Packrat;
diff --git a/packages/wisi/gen_run_wisi_packrat_parse.ads
b/packages/wisi/gen_run_wisi_packrat_parse.ads
deleted file mode 100644
index 538da1d..0000000
--- a/packages/wisi/gen_run_wisi_packrat_parse.ads
+++ /dev/null
@@ -1,36 +0,0 @@
--- Abstract :
---
--- Run an Emacs packrate parser as a standalone executable, for debugging.
---
--- See gen_emacs_wisi_parse_packrat.ads for the Emacs background process.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with WisiToken.Parse.Packrat;
-with WisiToken.Syntax_Trees;
-with WisiToken.Wisi_Runtime;
-generic
- type Parse_Data_Type is new WisiToken.Wisi_Runtime.Parse_Data_Type with
private;
-
- Descriptor : in WisiToken.Descriptor;
-
- with procedure Create_Parser
- (Parser : out WisiToken.Parse.Packrat.Parser;
- Trace : not null access WisiToken.Trace'Class;
- User_Data : in WisiToken.Syntax_Trees.User_Data_Access);
-
-procedure Gen_Run_Wisi_Parse_Packrat;
diff --git a/packages/wisi/long_float_elementary_functions.ads
b/packages/wisi/long_float_elementary_functions.ads
deleted file mode 100644
index d5664b7..0000000
--- a/packages/wisi/long_float_elementary_functions.ads
+++ /dev/null
@@ -1,21 +0,0 @@
--- Abstract :
---
--- instantiation
---
--- Copyright (C) 2017 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Numerics.Generic_Elementary_Functions;
-package Long_Float_Elementary_Functions is new
Ada.Numerics.Generic_Elementary_Functions (Long_Float);
diff --git a/packages/wisi/recover_stats.adb b/packages/wisi/recover_stats.adb
deleted file mode 100644
index e1fed7b..0000000
--- a/packages/wisi/recover_stats.adb
+++ /dev/null
@@ -1,271 +0,0 @@
--- Abstract :
---
--- Summarize error recover log.
---
--- Copyright (C) 2019 - 2020 Stephen Leake All Rights Reserved.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Command_Line;
-with Ada.Exceptions;
-with Ada.Long_Float_Text_IO;
-with Ada.Strings.Fixed; use Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Ada.Text_IO; use Ada.Text_IO;
-with GNAT.Traceback.Symbolic;
-with SAL.Gen_Stats.Gen_Image;
-with SAL.Long_Float_Stats;
-with WisiToken.Parse.LR;
-procedure Recover_Stats
-is
- subtype Strategies is WisiToken.Parse.LR.Strategies;
-
- File : File_Type;
-
- Delimiters : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set (",() ");
- Number : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set ("0123456789");
-
- type Strategy_Counts is array (Strategies) of Natural;
-
- type Recover_Label is (Full, Partial);
-
- type Recover_Summary is record
- Event_Count : Integer := 0;
- -- 1 per recover event (1 line in log file)
-
- Enqueue_Stats : SAL.Long_Float_Stats.Stats_Type;
- Check_Stats : SAL.Long_Float_Stats.Stats_Type;
-
- Strat_Counts_Total : Strategy_Counts := (others => 0);
- Strat_Counts_Present : Strategy_Counts := (others => 0);
- -- 1 per recover event if used
-
- Recover_Count_Present : Integer := 0;
- -- 1 per parser in recover result
-
- Recover_Count_Total : Integer := 0;
- -- Sum of all strategy counts
-
- Fail_Event_Count : Integer := 0; -- for all reasons
- Fail_Enqueue_Limit : Integer := 0;
- Fail_No_Configs_Left : Integer := 0;
- Fail_Programmer_Error : Integer := 0;
- Fail_Other : Integer := 0;
- end record;
-
- Summary : array (Recover_Label) of Recover_Summary;
-begin
- Open (File, In_File, Ada.Command_Line.Argument (1));
-
- loop
- exit when End_Of_File (File);
- declare
- -- The recover log is written by code in
- -- wisitoken-parse-lr-parser.adb Parse (search for Recover_Log).
- --
- -- A line has the syntax:
- -- yyyy-mm-dd hh:mm:ss <partial> <success> pre_parser_count
'<file_name>' (<parser_data>)...
- --
- -- where there is one (<parser_data) for each parser active after
recover. <parser_data> is:
- --
- -- (<strategy_counts>) <enqueue_count> <check_count> <success>
- --
- -- Note that the per-parser success is always TRUE; it would not be
- -- active if recover had failed.
-
- Line : constant String := Get_Line (File);
- First : Integer := Index (Line, " "); -- after date
- Last : Integer;
-
- Label : Recover_Label := Full;
-
- function Line_Eq (Item : in String) return Boolean
- is begin
- return Line (First .. First + Item'Length - 1) = Item;
- end Line_Eq;
-
- function Next_Integer return Integer
- is begin
- Find_Token
- (Line, Number,
- From => Last + 1,
- Test => Ada.Strings.Inside,
- First => First,
- Last => Last);
- return Integer'Value (Line (First .. Last));
- exception
- when Constraint_Error =>
- raise Constraint_Error with "bad integer '" & Line (First .. Last
- 1) & "' " &
- Ada.Text_IO.Count'Image (Ada.Text_IO.Line (File) - 1) &
First'Image & Last'Image;
- end Next_Integer;
-
- function Next_Boolean return Boolean
- is begin
- First := Last + 2;
- Last := -1 + Index (Line, Delimiters, First);
- return Boolean'Value (Line (First .. Last));
- end Next_Boolean;
-
- function Read_Strat_Counts (Strategy_Found : out Boolean) return
Strategy_Counts
- is begin
- Strategy_Found := False;
- Last := Index (Line, "(", Last + 1);
- return Result : Strategy_Counts do
- for I in Strategies loop
- Result (I) := Next_Integer;
- if Result (I) > 0 then
- Strategy_Found := True;
- end if;
- end loop;
- Last := 1 + Index (Line, ")", Last + 1);
- end return;
- end Read_Strat_Counts;
-
- begin
- First := Index (Line, " ", First + 1); -- after time
- Last := Index (Line, " ", First + 1); -- after Partial_Parse_Active
- if Boolean'Value (Line (First + 1 .. Last - 1)) then
- Label := Partial;
- end if;
-
- Summary (Label).Event_Count := Summary (Label).Event_Count + 1;
-
- First := Last + 1;
- if Line (First .. First + 3) = "FAIL" then
- Summary (Label).Fail_Event_Count := Summary
(Label).Fail_Event_Count + 1;
- First := First + 4;
-
- if Line_Eq ("NO_CONFIGS_LEFT") then
- Summary (Label).Fail_No_Configs_Left := Summary
(Label).Fail_No_Configs_Left + 1;
- elsif Line_Eq ("ENQUEUE_LIMIT") then
- Summary (Label).Fail_Enqueue_Limit := Summary
(Label).Fail_Enqueue_Limit + 1;
- elsif Line_Eq ("PROGRAMMER_ERROR") then
- Summary (Label).Fail_Programmer_Error := Summary
(Label).Fail_Programmer_Error + 1;
- else
- Summary (Label).Fail_Other := Summary (Label).Fail_Other + 1;
- end if;
-
- else
- -- Process per-parser data
- Last := Index (Line, "(", Last + 1);
- loop
- exit when Line (Last + 1) = ')';
- declare
- Strategy_Found : Boolean;
- Strat_Counts : constant Strategy_Counts :=
Read_Strat_Counts (Strategy_Found);
- Enqueue_Count : constant Integer := Next_Integer;
- Check_Count : constant Integer := Next_Integer;
- Success : constant Boolean := Next_Boolean;
- pragma Unreferenced (Success);
- begin
- Summary (Label).Recover_Count_Present := Summary
(Label).Recover_Count_Present + 1;
-
- if not Strategy_Found then
- raise SAL.Programmer_Error;
- else
- Summary (Label).Enqueue_Stats.Accumulate (Long_Float
(Enqueue_Count));
- Summary (Label).Check_Stats.Accumulate (Long_Float
(Check_Count));
- for I in Strategies loop
- Summary (Label).Recover_Count_Total :=
- Summary (Label).Recover_Count_Total + Strat_Counts
(I);
- Summary (Label).Strat_Counts_Total (I) :=
- Summary (Label).Strat_Counts_Total (I) +
Strat_Counts (I);
- if Strat_Counts (I) > 0 then
- Summary (Label).Strat_Counts_Present (I) := Summary
(Label).Strat_Counts_Present (I) + 1;
- end if;
- end loop;
- end if;
- end;
- end loop;
- end if;
- end;
- end loop;
-
- declare
- use Ada.Strings;
-
- Label_Field : String (1 .. 23); -- fits strategy and fail labels
- Count_Field : String (1 .. 8);
- Percent_Field : String (1 .. 4);
- -- Shared by Put_If, Put_Percent
-
- procedure Put_If
- (Summary_Label : in Recover_Label;
- Name : in String;
- Count : in Integer;
- Always : in Boolean := False)
- is
- Percent_Present : constant Integer :=
- Integer (100.0 * Float (Count) / Float (Summary
(Summary_Label).Event_Count));
- begin
- if Count > 0 or Always then
- Move (Name, Label_Field); Put (Label_Field & " => ");
- Move (Count'Image, Count_Field, Justify => Right); Put
(Count_Field);
- Move (Percent_Present'Image & "%", Percent_Field, Justify =>
Right); Put_Line (Percent_Field);
- end if;
- end Put_If;
-
- package Stats_Image is new SAL.Long_Float_Stats.Gen_Image
- (Real_IO => Ada.Long_Float_Text_IO,
- Default_Mean_Fore => 7,
- Default_Mean_Aft => 0,
- Default_Mean_Exp => 0,
- Default_Sd_Fore => 7,
- Default_Sd_Aft => 1,
- Default_Sd_Exp => 0);
-
- procedure Put_Percent (Summary_Label : in Recover_Label; Present, Total
: in Integer; Name : in String)
- is
- Percent_Present : constant Integer :=
- Integer (100.0 * Float (Present) / Float (Summary
(Summary_Label).Recover_Count_Present));
- Percent_Total : constant Integer :=
- Integer (100.0 * Float (Total) / Float (Summary
(Summary_Label).Recover_Count_Total));
- begin
- Move (Name, Label_Field); Put (Label_Field);
- Move (Present'Image, Count_Field, Justify => Right); Put
(Count_Field);
- Move (Percent_Present'Image & "%", Percent_Field, Justify => Right);
Put (Percent_Field & " /");
- Move (Total'Image, Count_Field, Justify => Right); Put (Count_Field);
- Move (Percent_Total'Image & "%", Percent_Field, Justify => Right);
Put_Line (Percent_Field);
- end Put_Percent;
-
- begin
- for I in Recover_Label loop
- Put_Line (I'Image);
- Put_Line ("present/total:" & Summary (I).Event_Count'Image & " /" &
Summary (I).Recover_Count_Total'Image);
- if Summary (I).Event_Count > 0 then
- Put_Line (" mean std. dev. min max");
- Put_Line ("Enqueue: " & Stats_Image.Image (Summary
(I).Enqueue_Stats.Display));
- Put_Line ("Check: " & Stats_Image.Image (Summary
(I).Check_Stats.Display));
- Put_If (I, "FAIL", Summary (I).Fail_Event_Count, Always => True);
- Put_If (I, "FAIL_ENQUEUE_LIMIT", Summary (I).Fail_Enqueue_Limit);
- Put_If (I, "FAIL_NO_CONFIGS_LEFT", Summary
(I).Fail_No_Configs_Left);
- Put_If (I, "FAIL_PROGRAMMER_ERROR", Summary
(I).Fail_Programmer_Error);
- Put_If (I, "FAIL_OTHER", Summary (I).Fail_Other);
- for J in Strategies loop
- Put_Percent
- (I,
- Summary (I).Strat_Counts_Present (J),
- Summary (I).Strat_Counts_Total (J),
- J'Image);
- end loop;
- end if;
- New_Line;
- end loop;
- end;
-exception
-when E : others =>
- Put_Line (Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
- Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
-end Recover_Stats;
diff --git a/packages/wisi/run_wisi_common_parse.adb
b/packages/wisi/run_wisi_common_parse.adb
deleted file mode 100644
index c79f2e7..0000000
--- a/packages/wisi/run_wisi_common_parse.adb
+++ /dev/null
@@ -1,356 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Command_Line;
-with Ada.Exceptions;
-with Ada.IO_Exceptions;
-with Ada.Real_Time;
-with Ada.Text_IO;
-with SAL;
-with System.Multiprocessors;
-package body Run_Wisi_Common_Parse is
-
- procedure Usage (Parser : in out WisiToken.Parse.LR.Parser.Parser)
- is
- use all type WisiToken.Parse.LR.Parse_Table_Ptr;
- use Ada.Text_IO;
- begin
- Put_Line ("usage: parse <parse_action> <file_name> [partial parse
params] [options]");
- Put_Line (" or: refactor <refactor_action> <file_name> <edit_begin>
[options]");
- Put_Line ("parse_action: {Navigate | Face | Indent}");
- Put_Line ("partial parse params: begin_byte_pos end_byte_pos
goal_byte_pos begin_char_pos begin_line" &
- " end_line begin_indent");
- Put_Line ("options:");
- Put_Line ("--verbosity n m l: (no 'm' for refactor)");
- Put_Line (" n: parser; m: mckenzie; l: action");
- Put_Line (" 0 - only report parse errors");
- Put_Line (" 1 - shows spawn/terminate parallel parsers, error recovery
enter/exit");
- Put_Line (" 2 - add each parser cycle, error recovery enqueue/check");
- Put_Line (" 3 - parse stack in each cycle, error recovery parse
actions");
- Put_Line (" 4 - add lexer debug, dump syntax tree");
- Put_Line ("--check_limit n : set error recover token check limit" &
- (if Parser.Table = null then ""
- else "; default" &
Parser.Table.McKenzie_Param.Check_Limit'Image));
- Put_Line ("--check_delta n : set error recover delta check limit" &
- (if Parser.Table = null then ""
- else "; default" &
Parser.Table.McKenzie_Param.Check_Delta_Limit'Image));
- Put_Line ("--enqueue_limit n : set error recover token enqueue limit" &
- (if Parser.Table = null then ""
- else "; default" &
Parser.Table.McKenzie_Param.Enqueue_Limit'Image));
- Put_Line ("--max_parallel n : set maximum count of parallel parsers
(default" &
- WisiToken.Parse.LR.Parser.Default_Max_Parallel'Image & ")");
- Put_Line ("--task_count n : worker tasks in error recovery");
- Put_Line ("--disable_recover : disable error recovery; default enabled");
- Put_Line ("--debug_mode : tracebacks from unhandled exceptions; default
disabled");
- Put_Line ("--lang_params <language-specific params>");
- Put_Line ("--repeat_count n : repeat parse count times, for profiling;
default 1");
- New_Line;
- end Usage;
-
- function Get_CL_Params (Parser : in out WisiToken.Parse.LR.Parser.Parser)
return Command_Line_Params
- is
- use Ada.Command_Line;
- use WisiToken;
- Arg : Integer := 1;
- Command : Command_Type;
- begin
- if Argument_Count < 1 then
- Usage (Parser);
- Set_Exit_Status (Failure);
- raise Finish;
-
- elsif Argument (Arg) = "--help" then
- Usage (Parser);
- raise Finish;
-
- elsif Argument_Count < 2 then
- Usage (Parser);
- Set_Exit_Status (Failure);
- raise Finish;
- end if;
-
- Command := Command_Type'Value (Ada.Command_Line.Argument (1));
-
- return Result : Command_Line_Params (Command) do
- Result.Source_File_Name := +Ada.Command_Line.Argument (3);
-
- case Command is
- when Parse =>
- Result.Post_Parse_Action := Wisi.Post_Parse_Action_Type'Value
(Ada.Command_Line.Argument (2));
-
- if Argument_Count >= 4 and then Argument (4)(1) /= '-' then
- Result.Begin_Byte_Pos := WisiToken.Buffer_Pos'Value (Argument
(4));
- Result.End_Byte_Pos := WisiToken.Buffer_Pos'Value (Argument
(5)) - 1; -- match emacs region
- Result.Goal_Byte_Pos := WisiToken.Buffer_Pos'Value (Argument
(6));
- Result.Begin_Char_Pos := WisiToken.Buffer_Pos'Value (Argument
(7));
- Result.Begin_Line := WisiToken.Line_Number_Type'Value
(Argument (8));
- Result.End_Line := WisiToken.Line_Number_Type'Value
(Argument (9));
- Result.Begin_Indent := Integer'Value (Argument (10));
- Arg := 11;
- else
- Result.Begin_Byte_Pos := WisiToken.Invalid_Buffer_Pos;
- Result.End_Byte_Pos := WisiToken.Invalid_Buffer_Pos;
- Result.Begin_Char_Pos := WisiToken.Buffer_Pos'First;
- Result.Begin_Line := WisiToken.Line_Number_Type'First;
- Arg := 4;
- end if;
-
- when Refactor =>
- Result.Refactor_Action := Integer'Value (Argument (2));
- Result.Edit_Begin := WisiToken.Buffer_Pos'Value (Argument
(4));
- Arg := 5;
- end case;
-
- loop
- exit when Arg > Argument_Count;
-
- if Argument (Arg) = "--verbosity" then
- WisiToken.Trace_Parse := Integer'Value (Argument (Arg + 1));
- case Command is
- when Parse =>
- WisiToken.Trace_McKenzie := Integer'Value (Argument (Arg +
2));
- WisiToken.Trace_Action := Integer'Value (Argument (Arg +
3));
- Arg := Arg + 4;
- when Refactor =>
- WisiToken.Trace_Action := Integer'Value (Argument (Arg +
2));
- Arg := Arg + 3;
- end case;
-
- WisiToken.Debug_Mode := WisiToken.Trace_Parse > Outline or
WisiToken.Trace_McKenzie > Outline;
-
- elsif Argument (Arg) = "--check_limit" then
- Parser.Table.McKenzie_Param.Check_Limit := Token_Index'Value
(Argument (Arg + 1));
- Arg := Arg + 2;
-
- elsif Argument (Arg) = "--check_delta" then
- Parser.Table.McKenzie_Param.Check_Delta_Limit := Integer'Value
(Argument (Arg + 1));
- Arg := Arg + 2;
-
- elsif Argument (Arg) = "--debug_mode" then
- WisiToken.Debug_Mode := True;
- Arg := Arg + 1;
-
- elsif Argument (Arg) = "--disable_recover" then
- Parser.Enable_McKenzie_Recover := False;
- Arg := Arg + 1;
-
- elsif Argument (Arg) = "--enqueue_limit" then
- Parser.Table.McKenzie_Param.Enqueue_Limit := Integer'Value
(Argument (Arg + 1));
- Arg := Arg + 2;
-
- elsif Argument (Arg) = "--lang_params" then
- Result.Lang_Params := +Argument (Arg + 1);
- Arg := Arg + 2;
-
- elsif Argument (Arg) = "--max_parallel" then
- Parser.Max_Parallel := SAL.Base_Peek_Type'Value (Argument (Arg
+ 1));
- Arg := Arg + 2;
-
- elsif Argument (Arg) = "--repeat_count" then
- Result.Repeat_Count := Integer'Value (Argument (Arg + 1));
- Arg := Arg + 2;
-
- elsif Argument (Arg) = "--task_count" then
- Parser.Table.McKenzie_Param.Task_Count :=
System.Multiprocessors.CPU_Range'Value (Argument (Arg + 1));
- Arg := Arg + 2;
-
- else
- Ada.Text_IO.Put_Line ("unrecognized option: '" & Argument (Arg)
& "'");
- Usage (Parser);
- Set_Exit_Status (Failure);
- raise SAL.Parameter_Error;
- end if;
- end loop;
- end return;
- exception
- when Finish =>
- raise;
-
- when E : others =>
- Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
- Usage (Parser);
- Set_Exit_Status (Failure);
- raise SAL.Parameter_Error;
- end Get_CL_Params;
-
- procedure Parse_File
- (Parser : in out WisiToken.Parse.LR.Parser.Parser;
- Parse_Data : in out Wisi.Parse_Data_Type'Class;
- Descriptor : in WisiToken.Descriptor)
- is
- use Ada.Text_IO;
- use WisiToken;
-
- Start : Ada.Real_Time.Time;
- End_Line : WisiToken.Line_Number_Type;
-
- function Image_Augmented (Aug : in Base_Token_Class_Access) return String
- is begin
- -- For Syntax_Trees.Print_Tree
- return Wisi.Image (Aug, Descriptor);
- end Image_Augmented;
-
- begin
- Parser.Trace.Set_Prefix (";; "); -- so we get the same debug messages as
Emacs_Wisi_Common_Parse
-
- declare
- Cl_Params : constant Command_Line_Params := Get_CL_Params (Parser);
- begin
- begin
- case Cl_Params.Command is
- when Parse =>
- Parser.Lexer.Reset_With_File
- (-Cl_Params.Source_File_Name, Cl_Params.Begin_Byte_Pos,
Cl_Params.End_Byte_Pos,
- Cl_Params.Begin_Char_Pos, Cl_Params.Begin_Line);
- when Refactor =>
- Parser.Lexer.Reset_With_File (-Cl_Params.Source_File_Name);
- end case;
- exception
- when Ada.IO_Exceptions.Name_Error =>
- Put_Line (Standard_Error, "'" & (-Cl_Params.Source_File_Name) & "'
cannot be opened");
- return;
- end;
-
- -- Parser.Line_Begin_Token First, Last set by Lex_All
-
- if Cl_Params.Command = Refactor or else Cl_Params.End_Line =
Invalid_Line_Number then
- -- User did not provide; run lexer to get end line.
- declare
- Token : Base_Token;
- Lexer_Error : Boolean;
- pragma Unreferenced (Lexer_Error);
- begin
- loop
- Lexer_Error := Parser.Lexer.Find_Next (Token);
- exit when Token.ID = Descriptor.EOI_ID;
- end loop;
- End_Line := Token.Line;
- end;
- else
- End_Line := Cl_Params.End_Line;
- end if;
-
- Parse_Data.Initialize
- (Post_Parse_Action =>
- (case Cl_Params.Command is
- when Parse => Cl_Params.Post_Parse_Action,
- when Refactor => Wisi.Navigate),
- Lexer => Parser.Lexer,
- Descriptor => Descriptor'Unrestricted_Access,
- Base_Terminals => Parser.Terminals'Unrestricted_Access,
- Begin_Line =>
- (case Cl_Params.Command is
- when Parse => Cl_Params.Begin_Line,
- when Refactor => WisiToken.Line_Number_Type'First),
- End_Line => End_Line,
- Begin_Indent =>
- (case Cl_Params.Command is
- when Parse => Cl_Params.Begin_Indent,
- when Refactor => 0),
- Params => -Cl_Params.Lang_Params);
-
- if Cl_Params.Repeat_Count > 1 then
- Start := Ada.Real_Time.Clock;
- end if;
-
- for I in 1 .. Cl_Params.Repeat_Count loop
- declare
- procedure Clean_Up
- is
- use all type SAL.Base_Peek_Type;
- begin
- Parser.Lexer.Discard_Rest_Of_Input;
- if Cl_Params.Repeat_Count = 1 and Parser.Parsers.Count > 0
then
- Parse_Data.Put
- (Parser.Lexer.Errors,
- Parser.Parsers.First.State_Ref.Errors,
- Parser.Parsers.First.State_Ref.Tree);
- end if;
- end Clean_Up;
-
- begin
- Parse_Data.Reset;
- Parser.Lexer.Reset;
-
- begin
- Parser.Parse;
- exception
- when WisiToken.Partial_Parse =>
- null;
- end;
-
- Parser.Execute_Actions (Image_Augmented'Unrestricted_Access);
-
- case Cl_Params.Command is
- when Parse =>
- if Cl_Params.Repeat_Count = 1 then
- Parse_Data.Put (Parser);
- Parse_Data.Put
- (Parser.Lexer.Errors,
- Parser.Parsers.First.State_Ref.Errors,
- Parser.Parsers.First.State_Ref.Tree);
- end if;
-
- when Refactor =>
- Parse_Data.Refactor
- (Parser.Parsers.First_State_Ref.Tree,
- Cl_Params.Refactor_Action, Cl_Params.Edit_Begin);
- end case;
- exception
- when WisiToken.Syntax_Error =>
- Clean_Up;
- Put_Line ("(parse_error)");
-
- when E : WisiToken.Parse_Error =>
- Clean_Up;
- Put_Line ("(parse_error """ & Ada.Exceptions.Exception_Name (E)
& " " &
- Ada.Exceptions.Exception_Message (E) & """)");
-
- when E : others => -- includes Fatal_Error
- Clean_Up;
- Put_Line ("(error """ & Ada.Exceptions.Exception_Name (E) & " "
&
- Ada.Exceptions.Exception_Message (E) & """)");
- end;
- end loop;
-
- if Cl_Params.Repeat_Count > 1 then
- declare
- use Ada.Real_Time;
- Finish : constant Time := Clock;
- begin
- Put_Line ("Total time:" & Duration'Image (To_Duration (Finish -
Start)));
- Put_Line ("per iteration:" & Duration'Image (To_Duration
((Finish - Start) / Cl_Params.Repeat_Count)));
- end;
- end if;
- end;
- exception
- when SAL.Parameter_Error | Finish =>
- -- From Get_CL_Params; already handled.
- null;
-
- when E : others =>
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
- New_Line (2);
- Put_Line
- ("(error ""unhandled exception: " & Ada.Exceptions.Exception_Name (E)
& ": " &
- Ada.Exceptions.Exception_Message (E) & """)");
- end Parse_File;
-
-end Run_Wisi_Common_Parse;
diff --git a/packages/wisi/run_wisi_common_parse.ads
b/packages/wisi/run_wisi_common_parse.ads
deleted file mode 100644
index c00d007..0000000
--- a/packages/wisi/run_wisi_common_parse.ads
+++ /dev/null
@@ -1,73 +0,0 @@
--- Abstract :
---
--- Common utilities for Gen_Run_Wisi_*_Parse
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Strings.Unbounded;
-with Wisi;
-with WisiToken.Parse.LR.Parser;
-package Run_Wisi_Common_Parse is
-
- Finish : exception;
-
- procedure Usage (Parser : in out WisiToken.Parse.LR.Parser.Parser);
- -- Puts parameter description to Current_Output.
-
- type Command_Type is (Parse, Refactor);
-
- type Command_Line_Params (Command : Command_Type) is record
-
- Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
- Lang_Params : Ada.Strings.Unbounded.Unbounded_String;
- Repeat_Count : Integer := 1;
-
- case Command is
- when Parse =>
- Post_Parse_Action : Wisi.Post_Parse_Action_Type;
- Begin_Byte_Pos : WisiToken.Buffer_Pos :=
WisiToken.Invalid_Buffer_Pos;
- End_Byte_Pos : WisiToken.Buffer_Pos :=
WisiToken.Invalid_Buffer_Pos;
- Goal_Byte_Pos : WisiToken.Buffer_Pos :=
WisiToken.Invalid_Buffer_Pos;
- Begin_Char_Pos : WisiToken.Buffer_Pos :=
WisiToken.Buffer_Pos'First;
- Begin_Line : WisiToken.Line_Number_Type :=
WisiToken.Line_Number_Type'First;
- End_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
- Begin_Indent : Integer := 0;
-
- when Refactor =>
- -- We assume the file contains only the one statement/declaration
- -- that needs refactoring.
-
- Refactor_Action : Positive;
- -- Language-specific
-
- Edit_Begin : WisiToken.Buffer_Pos;
- -- Source file byte position at start of expression to refactor.
- end case;
- end record;
-
- function Get_CL_Params (Parser : in out WisiToken.Parse.LR.Parser.Parser)
return Command_Line_Params;
- -- For any errors, calls Usage, raises SAL.Parameter_Error.
- --
- -- Handles --help by outputing help, raising Finish.
-
- procedure Parse_File
- (Parser : in out WisiToken.Parse.LR.Parser.Parser;
- Parse_Data : in out Wisi.Parse_Data_Type'Class;
- Descriptor : in WisiToken.Descriptor);
- -- Calls Get_CL_Params, reads in file, parses, does post-parse actions.
-
-end Run_Wisi_Common_Parse;
diff --git a/packages/wisi/sal-ada_containers-gen_doubly_linked_lists_image.adb
b/packages/wisi/sal-ada_containers-gen_doubly_linked_lists_image.adb
deleted file mode 100644
index a5dd042..0000000
--- a/packages/wisi/sal-ada_containers-gen_doubly_linked_lists_image.adb
+++ /dev/null
@@ -1,50 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded;
-function SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
- (Item : in Lists.List;
- Strict : in Boolean := False)
- return String
-is
- use all type Ada.Containers.Count_Type;
- use Ada.Strings;
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- Need_Comma : Boolean := False;
-begin
- if Strict and Item.Length = 0 then
- return "(1 .. 0 => <>)";
-
- elsif Strict and Item.Length = 1 then
- return "(1 => " & Element_Image (Lists.Element (Item.First)) & ")";
-
- else
- for El of Item loop
- if Need_Comma then
- Result := Result & ", ";
- else
- Need_Comma := True;
- end if;
- Result := Result & Element_Image (El);
- end loop;
- Result := Result & ")";
- return To_String (Result);
- end if;
-end SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image;
diff --git a/packages/wisi/sal-ada_containers-gen_doubly_linked_lists_image.ads
b/packages/wisi/sal-ada_containers-gen_doubly_linked_lists_image.ads
deleted file mode 100644
index 39e9b9e..0000000
--- a/packages/wisi/sal-ada_containers-gen_doubly_linked_lists_image.ads
+++ /dev/null
@@ -1,28 +0,0 @@
--- Abstract :
---
--- Image for normal Ada array types
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-with Ada.Containers.Doubly_Linked_Lists;
-generic
- type Element_Type is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
- with package Lists is new Ada.Containers.Doubly_Linked_Lists (Element_Type,
"=");
- with function Element_Image (Item : in Element_Type) return String;
-function SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
- (Item : in Lists.List;
- Strict : in Boolean := False)
- return String;
diff --git a/packages/wisi/sal-ada_containers.ads
b/packages/wisi/sal-ada_containers.ads
deleted file mode 100644
index 4afad1e..0000000
--- a/packages/wisi/sal-ada_containers.ads
+++ /dev/null
@@ -1,21 +0,0 @@
--- Abstract :
---
--- Root of extensions to Ada.Containers.
---
--- Copyright (C) 2019 Free Software Foundation All Rights Reserved.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-package SAL.Ada_Containers is
-
-end SAL.Ada_Containers;
diff --git a/packages/wisi/sal-gen_array_image.adb
b/packages/wisi/sal-gen_array_image.adb
deleted file mode 100644
index 7f9097d..0000000
--- a/packages/wisi/sal-gen_array_image.adb
+++ /dev/null
@@ -1,34 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-function SAL.Gen_Array_Image (Item : in Array_Type) return String
-is
- Result : Unbounded_String := To_Unbounded_String ("(");
-begin
- for I in Item'Range loop
- Result := Result & Element_Image (Item (I));
- if I = Item'Last then
- Result := Result & ")";
- else
- Result := Result & ", ";
- end if;
- end loop;
- return To_String (Result);
-end SAL.Gen_Array_Image;
diff --git a/packages/wisi/sal-gen_array_image.ads
b/packages/wisi/sal-gen_array_image.ads
deleted file mode 100644
index 53bd25f..0000000
--- a/packages/wisi/sal-gen_array_image.ads
+++ /dev/null
@@ -1,24 +0,0 @@
--- Abstract :
---
--- Image for normal Ada array types
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-generic
- type Index_Type is (<>);
- type Element_Type is private;
- type Array_Type is array (Index_Type) of Element_Type;
- with function Element_Image (Item : in Element_Type) return String;
-function SAL.Gen_Array_Image (Item : in Array_Type) return String;
diff --git a/packages/wisi/sal-gen_bounded_definite_queues.adb
b/packages/wisi/sal-gen_bounded_definite_queues.adb
deleted file mode 100644
index 71b68c5..0000000
--- a/packages/wisi/sal-gen_bounded_definite_queues.adb
+++ /dev/null
@@ -1,103 +0,0 @@
--- Abstract:
---
--- See spec.
---
--- Copyright (C) 2004, 2008, 2009, 2011, 2017, 2019 Free Software Foundation
All Rights Reserved.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Bounded_Definite_Queues
- with Spark_Mode
-is
- pragma Suppress (All_Checks);
-
- ----------
- -- Public subprograms
-
- procedure Clear (Queue : in out Queue_Type) is
- begin
- Queue.Count := 0;
- end Clear;
-
- function Count (Queue : in Queue_Type) return Base_Peek_Type is
(Queue.Count);
-
- function Is_Empty (Queue : in Queue_Type) return Boolean is
- begin
- return Queue.Count = 0;
- end Is_Empty;
-
- function Is_Full (Queue : in Queue_Type) return Boolean is
- begin
- return Queue.Count = Queue.Size;
- end Is_Full;
-
- procedure Remove (Queue : in out Queue_Type; Item : out Item_Type)
- is begin
- Item := Queue.Data (Queue.Head);
-
- Queue.Count := Queue.Count - 1;
-
- if Queue.Count > 0 then
- Queue.Head := Wrap (Queue.Size, Queue.Head + 1);
- end if;
- end Remove;
-
- function Remove (Queue : in out Queue_Type) return Item_Type with
- Spark_Mode => Off
- is begin
- return Item : Item_Type do
- Remove (Queue, Item);
- end return;
- end Remove;
-
- procedure Drop (Queue : in out Queue_Type)
- is begin
- Queue.Count := Queue.Count - 1;
-
- if Queue.Count > 0 then
- Queue.Head := Wrap (Queue.Size, Queue.Head + 1);
- end if;
- end Drop;
-
- function Peek (Queue : in Queue_Type; N : Peek_Type := 1) return Item_Type
- is (Queue.Data (Wrap (Queue.Size, Queue.Head + N - 1)));
- -- Expression function to allow use in Spark proofs of conditions in spec.
-
- procedure Add (Queue : in out Queue_Type; Item : in Item_Type) is
- begin
- if Queue.Count = 0 then
- Queue.Tail := 1;
- Queue.Head := 1;
- Queue.Count := 1;
- else
- Queue.Tail := Wrap (Queue.Size, Queue.Tail + 1);
- Queue.Count := Queue.Count + 1;
- end if;
- Queue.Data (Queue.Tail) := Item;
- end Add;
-
- procedure Add_To_Head (Queue : in out Queue_Type; Item : in Item_Type) is
- begin
- if Queue.Count = 0 then
- Queue.Tail := 1;
- Queue.Head := 1;
- Queue.Count := 1;
- else
- Queue.Head := Wrap (Queue.Size, Queue.Head - 1);
- Queue.Count := Queue.Count + 1;
- end if;
- Queue.Data (Queue.Head) := Item;
- end Add_To_Head;
-
-end SAL.Gen_Bounded_Definite_Queues;
diff --git a/packages/wisi/sal-gen_bounded_definite_queues.ads
b/packages/wisi/sal-gen_bounded_definite_queues.ads
deleted file mode 100644
index 5614519..0000000
--- a/packages/wisi/sal-gen_bounded_definite_queues.ads
+++ /dev/null
@@ -1,117 +0,0 @@
--- Abstract:
---
--- A generic queue, allowing definite non-limited item types.
---
--- Copyright (C) 2004, 2008, 2009, 2011, 2017, 2019 Free Software Foundation
All Rights Reserved.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Item_Type is private;
-package SAL.Gen_Bounded_Definite_Queues
- with Spark_Mode
-is
- pragma Pure;
- pragma Suppress (All_Checks); -- Users must check Is_Full before Add,
Is_Empty before Remove.
-
- subtype Size_Type is Peek_Type range 1 .. Peek_Type'Last / 2;
- -- The upper limit is needed to avoid overflow in Peek.
-
- type Queue_Type (Size : Size_Type) is private;
- -- Size is maximum number of items in the queue.
-
- procedure Clear (Queue : in out Queue_Type)
- with Post => Count (Queue) = 0;
- -- Empty Queue of all items.
-
- function Count (Queue : in Queue_Type) return Base_Peek_Type;
- -- Returns count of items in the Queue
-
- function Is_Empty (Queue : in Queue_Type) return Boolean
- with Post => Is_Empty'Result = (Count (Queue) = 0);
- -- Returns true if no items are in Queue.
-
- function Is_Full (Queue : in Queue_Type) return Boolean
- with Post => Is_Full'Result = (Count (Queue) = Queue.Size);
- -- Returns true if Queue is full.
-
- procedure Remove (Queue : in out Queue_Type; Item : out Item_Type) with
- Pre => Count (Queue) > 0,
- Post => Count (Queue) = Count (Queue)'Old - 1 and Item = Peek (Queue'Old)
and
- (for all I in 1 .. Count (Queue) => Peek (Queue'Old, I + 1) =
Peek (Queue, I));
- -- Remove head item from Queue, return it.
-
- function Remove (Queue : in out Queue_Type) return Item_Type with
- Spark_Mode => Off;
-
- function Get (Queue : in out Queue_Type) return Item_Type renames Remove;
-
- procedure Drop (Queue : in out Queue_Type) with
- Pre => Count (Queue) > 0,
- Post => Count (Queue) = Count (Queue)'Old - 1 and
- (for all I in 1 .. Count (Queue) => Peek (Queue'Old, I + 1) =
Peek (Queue, I));
- -- Remove head item from Queue, discard it.
-
- function Peek (Queue : in Queue_Type; N : Peek_Type := 1) return Item_Type
with
- Pre => Count (Queue) in 1 .. Queue.Size and N in 1 .. Count (Queue);
- -- Return a copy of a queue item, without removing it. N = 1 is
- -- the queue head.
-
- procedure Add (Queue : in out Queue_Type; Item : in Item_Type) with
- Pre => Count (Queue) in 0 .. Queue.Size - 1,
- Post => Count (Queue) = Count (Queue)'Old + 1 and Peek (Queue, Count
(Queue)) = Item and
- (for all I in 1 .. Count (Queue)'Old => Peek (Queue'Old, I) =
Peek (Queue, I));
- -- Add Item to the tail of Queue.
-
- procedure Put (Queue : in out Queue_Type; Item : in Item_Type) renames Add;
-
- procedure Add_To_Head (Queue : in out Queue_Type; Item : in Item_Type) with
- Pre => Count (Queue) in 0 .. Queue.Size - 1,
- Post => Count (Queue) = Count (Queue)'Old + 1 and
- (Peek (Queue) = Item and
- (for all I in 2 .. Count (Queue) => Peek (Queue'Old, I - 1) =
Peek (Queue, I)));
- -- Add Item to the head of Queue.
-
-private
-
- type Item_Array_Type is array (Peek_Type range <>) of Item_Type;
-
- type Queue_Type (Size : Size_Type) is
- record
- Head : Peek_Type := 1;
- Tail : Peek_Type := 1;
- Count : Base_Peek_Type := 0;
- Data : Item_Array_Type (1 .. Size);
- -- Add at Tail + 1, remove at Head. Count is current count;
- -- easier to keep track of that than to compute Is_Empty for
- -- each Add and Remove.
- --
- -- Empty is indicated by Count = 0; head and tail are arbitrary
- -- in that case.
- end record with
- Type_Invariant =>
- (Head in 1 .. Size and
- Tail in 1 .. Size and
- Count in 0 .. Size) and then
- (Count = 0 or else Wrap (Size, Head + Count - 1) = Tail);
-
- function Wrap (Size : in Size_Type; I : in Base_Peek_Type) return Peek_Type
- is (if I > Size then I - Size
- elsif I = 0 then Size
- else I)
- with
- Pre => I in 0 .. 2 * Size - 1,
- Post => Wrap'Result in 1 .. Size;
-
-end SAL.Gen_Bounded_Definite_Queues;
diff --git a/packages/wisi/sal-gen_bounded_definite_stacks-gen_image_aux.adb
b/packages/wisi/sal-gen_bounded_definite_stacks-gen_image_aux.adb
deleted file mode 100644
index 7dcd96f..0000000
--- a/packages/wisi/sal-gen_bounded_definite_stacks-gen_image_aux.adb
+++ /dev/null
@@ -1,42 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded;
-function SAL.Gen_Bounded_Definite_Stacks.Gen_Image_Aux
- (Item : in Stack;
- Aux : in Aux_Data;
- Depth : in SAL.Base_Peek_Type := 0)
- return String
-is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- Last : constant Base_Peek_Type :=
- (if Depth = 0
- then Item.Top
- else Base_Peek_Type'Min (Depth, Item.Top));
-begin
- for I in 1 .. Last loop
- Result := Result & Element_Image (Item.Peek (I), Aux);
- if I /= Last then
- Result := Result & ", ";
- end if;
- end loop;
- Result := Result & ")";
- return To_String (Result);
-end SAL.Gen_Bounded_Definite_Stacks.Gen_Image_Aux;
diff --git a/packages/wisi/sal-gen_bounded_definite_stacks-gen_image_aux.ads
b/packages/wisi/sal-gen_bounded_definite_stacks-gen_image_aux.ads
deleted file mode 100644
index e960398..0000000
--- a/packages/wisi/sal-gen_bounded_definite_stacks-gen_image_aux.ads
+++ /dev/null
@@ -1,27 +0,0 @@
--- Abstract :
---
--- Image with auxiliary data for instantiations of parent.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Aux_Data (<>) is private;
- with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Bounded_Definite_Stacks.Gen_Image_Aux
- (Item : in Stack;
- Aux : in Aux_Data;
- Depth : in SAL.Base_Peek_Type := 0)
- return String;
diff --git a/packages/wisi/sal-gen_bounded_definite_stacks.adb
b/packages/wisi/sal-gen_bounded_definite_stacks.adb
deleted file mode 100644
index fc81daa..0000000
--- a/packages/wisi/sal-gen_bounded_definite_stacks.adb
+++ /dev/null
@@ -1,82 +0,0 @@
--- Abstract:
---
--- see spec
---
--- Copyright (C) 1998, 2003, 2009, 2015, 2017 - 2019 Free Software
Foundation, Inc.
---
--- SAL is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the
--- Free Software Foundation; either version 3, or (at your option)
--- any later version. SAL is distributed in the hope that it will be
--- useful, but WITHOUT ANY WARRANTY; without even the implied
--- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
--- See the GNU General Public License for more details. You should
--- have received a copy of the GNU General Public License distributed
--- with SAL; see file COPYING. If not, write to the Free Software
--- Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--- USA.
---
--- As a special exception, if other files instantiate generics from
--- SAL, or you link SAL object files with other files to produce an
--- executable, that does not by itself cause the resulting executable
--- to be covered by the GNU General Public License. This exception
--- does not however invalidate any other reasons why the executable
--- file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Bounded_Definite_Stacks
- with Spark_Mode
-is
- pragma Suppress (All_Checks);
-
- procedure Clear (Stack : in out Sgbds.Stack)
- is begin
- Stack.Top := 0;
- end Clear;
-
- function Depth (Stack : in Sgbds.Stack) return Size_Type
- is (Stack.Top);
-
- function Is_Empty (Stack : in Sgbds.Stack) return Boolean
- is begin
- return Stack.Top = 0;
- end Is_Empty;
-
- function Is_Full (Stack : in Sgbds.Stack) return Boolean
- is begin
- return Stack.Top = Stack.Size;
- end Is_Full;
-
- function Peek
- (Stack : in Sgbds.Stack;
- Index : in Peek_Type := 1)
- return Element_Type
- is (Stack.Data (Stack.Top - Index + 1));
-
- procedure Pop (Stack : in out Sgbds.Stack; Count : in Base_Peek_Type := 1)
- is begin
- Stack.Top := Stack.Top - Count;
- end Pop;
-
- procedure Pop (Stack : in out Sgbds.Stack; Item : out Element_Type)
- is begin
- Item := Stack.Peek (1);
- Stack.Top := Stack.Top - 1;
- end Pop;
-
- function Pop (Stack : in out Sgbds.Stack) return Element_Type with
- Spark_Mode => Off
- is begin
- return Result : Element_Type do
- Pop (Stack, Result);
- end return;
- end Pop;
-
- procedure Push (Stack : in out Sgbds.Stack; Item : in Element_Type)
- is begin
- Stack.Top := Stack.Top + 1;
- Stack.Data (Stack.Top) := Item;
- end Push;
-
-end SAL.Gen_Bounded_Definite_Stacks;
diff --git a/packages/wisi/sal-gen_bounded_definite_stacks.ads
b/packages/wisi/sal-gen_bounded_definite_stacks.ads
deleted file mode 100644
index e2ba7ab..0000000
--- a/packages/wisi/sal-gen_bounded_definite_stacks.ads
+++ /dev/null
@@ -1,103 +0,0 @@
--- Abstract:
---
--- Bounded stack implementation, with full Spark verification,
--- optimized for speed.
---
--- Copyright (C) 1998-2000, 2002-2003, 2009, 2015, 2017 - 2020 Free Software
Foundation, Inc.
---
--- SAL is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the
--- Free Software Foundation; either version 3, or (at your option)
--- any later version. SAL is distributed in the hope that it will be
--- useful, but WITHOUT ANY WARRANTY; without even the implied
--- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
--- See the GNU General Public License for more details. You should
--- have received a copy of the GNU General Public License distributed
--- with SAL; see file COPYING. If not, write to the Free Software
--- Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--- USA.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Element_Type is private;
-package SAL.Gen_Bounded_Definite_Stacks
- with Spark_Mode
-is
- pragma Pure;
- -- pragma Suppress (All_Checks); -- Users must check Is_Full before Push,
Is_Empty before Pop etc.
-
- package Sgbds renames SAL.Gen_Bounded_Definite_Stacks;
-
- subtype Size_Type is Base_Peek_Type range 0 .. Base_Peek_Type'Last / 2;
- -- The upper limit is needed to avoid overflow in Peek.
- -- Zero included for Depth result.
-
- type Stack (Size : Size_Type) is tagged private;
- -- Tagged to allow Object.Method notation.
-
- -- No Empty_Stack constant, to avoid requiring a Default_Element.
-
- procedure Clear (Stack : in out Sgbds.Stack)
- with Post'Class => Depth (Stack) = 0;
- -- Empty Stack of all items.
-
- function Depth (Stack : in Sgbds.Stack) return Size_Type;
- -- Returns current count of items in Stack
-
- function Is_Empty (Stack : in Sgbds.Stack) return Boolean
- with Post'Class => Is_Empty'Result = (Depth (Stack) = 0);
- -- Returns true iff no items are in Stack.
-
- function Is_Full (Stack : in Sgbds.Stack) return Boolean
- with Post'Class => Is_Full'Result = (Depth (Stack) = Stack.Size);
- -- Returns true iff Stack is full.
-
- function Peek (Stack : in Sgbds.Stack; Index : in Peek_Type := 1) return
Element_Type
- with Pre'Class => Depth (Stack) in 1 .. Stack.Size and Index in 1 .. Depth
(Stack);
- -- Return the Index'th item from the top of Stack; the Item is _not_
removed.
- -- Top item has index 1.
-
- procedure Pop (Stack : in out Sgbds.Stack; Count : in Base_Peek_Type := 1)
with
- Pre'Class => Depth (Stack) in 1 .. Stack.Size and Count in 0 .. Depth
(Stack),
- Post'Class => Depth (Stack) = Depth (Stack)'Old - Count and then
- (for all I in 1 .. Depth (Stack) => Peek (Stack'Old, I +
Count) = Peek (Stack, I));
- -- Remove Count Items from the top of Stack, discard them.
-
- procedure Pop (Stack : in out Sgbds.Stack; Item : out Element_Type) with
- Pre'Class => Depth (Stack) in 1 .. Stack.Size,
- Post'Class =>
- Depth (Stack) = Depth (Stack)'Old - 1 and then
- (Item = Peek (Stack'Old) and
- (for all I in 1 .. Depth (Stack) => Peek (Stack'Old, I + 1) = Peek
(Stack, I)));
- -- Remove one item from the top of Stack, return in Item.
-
- function Pop (Stack : in out Sgbds.Stack) return Element_Type with
- Spark_Mode => Off;
- -- Remove one item from the top of Stack, and return it.
-
- procedure Push (Stack : in out Sgbds.Stack; Item : in Element_Type) with
- Pre'Class => Depth (Stack) in 0 .. Stack.Size - 1,
- Post'Class =>
- Depth (Stack) = Depth (Stack)'Old + 1 and then
- (Item = Peek (Stack) and
- (for all I in 1 .. Depth (Stack'Old) => Peek (Stack'Old, I) = Peek
(Stack, I + 1)));
- -- Add Item to the top of Stack.
-
-private
-
- type Element_Array is array (Size_Type range <>) of aliased Element_Type;
-
- type Stack (Size : Size_Type) is tagged record
- Top : Base_Peek_Type := Invalid_Peek_Index; -- empty
- Data : Element_Array (1 .. Size);
- -- Top of stack is at Data (Top).
- -- Data (1 .. Top) has been set at some point.
- end record with
- Dynamic_Predicate => Stack.Top in 0 .. Stack.Size;
-
-end SAL.Gen_Bounded_Definite_Stacks;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors-gen_image.adb
b/packages/wisi/sal-gen_bounded_definite_vectors-gen_image.adb
deleted file mode 100644
index ae901fe..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors-gen_image.adb
+++ /dev/null
@@ -1,40 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Fixed;
-with Ada.Strings.Unbounded;
-function SAL.Gen_Bounded_Definite_Vectors.Gen_Image (Item : in Vector) return
String
-is
- use Ada.Strings;
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- Last : constant Base_Peek_Type := To_Peek_Index (Item.Last);
-begin
- for I in 1 .. Last loop
- Result := Result &
- (if Trim
- then Fixed.Trim (Element_Image (Item.Elements (I)), Left)
- else Element_Image (Item.Elements (I)));
- if I /= Last then
- Result := Result & ", ";
- end if;
- end loop;
- Result := Result & ")";
- return To_String (Result);
-end SAL.Gen_Bounded_Definite_Vectors.Gen_Image;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors-gen_image.ads
b/packages/wisi/sal-gen_bounded_definite_vectors-gen_image.ads
deleted file mode 100644
index 950b9d0..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors-gen_image.ads
+++ /dev/null
@@ -1,23 +0,0 @@
--- Abstract :
---
--- Image for instantiations of parent.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- with function Element_Image (Item : in Element_Type) return String;
- Trim : in Boolean;
-function SAL.Gen_Bounded_Definite_Vectors.Gen_Image (Item : in Vector) return
String;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors-gen_image_aux.adb
b/packages/wisi/sal-gen_bounded_definite_vectors-gen_image_aux.adb
deleted file mode 100644
index 685ef13..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors-gen_image_aux.adb
+++ /dev/null
@@ -1,35 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded;
-function SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector; Aux
: in Aux_Data) return String
-is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- Last : constant Base_Peek_Type := To_Peek_Index (Item.Last);
-begin
- for I in 1 .. Last loop
- Result := Result & Element_Image (Item.Elements (I), Aux);
- if I /= Last then
- Result := Result & ", ";
- end if;
- end loop;
- Result := Result & ")";
- return To_String (Result);
-end SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors-gen_image_aux.ads
b/packages/wisi/sal-gen_bounded_definite_vectors-gen_image_aux.ads
deleted file mode 100644
index 241e67b..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors-gen_image_aux.ads
+++ /dev/null
@@ -1,23 +0,0 @@
--- Abstract :
---
--- Image with auxiliary data for instantiations of parent.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Aux_Data (<>) is private;
- with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux (Item : in Vector; Aux
: in Aux_Data) return String;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors-gen_refs.adb
b/packages/wisi/sal-gen_bounded_definite_vectors-gen_refs.adb
deleted file mode 100644
index 8f9d741..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors-gen_refs.adb
+++ /dev/null
@@ -1,35 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Bounded_Definite_Vectors.Gen_Refs is
-
- function Variable_Ref
- (Container : aliased in out Vector;
- Index : in Index_Type)
- return Variable_Reference_Type
- is begin
- return (Element => Container.Elements (To_Peek_Index (Index))'Access,
Dummy => 1);
- end Variable_Ref;
-
- function Constant_Ref (Container : aliased in Vector; Index : in
Index_Type) return Constant_Reference_Type
- is begin
- return (Element => Container.Elements (To_Peek_Index (Index))'Access,
Dummy => 1);
- end Constant_Ref;
-
-end SAL.Gen_Bounded_Definite_Vectors.Gen_Refs;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors-gen_refs.ads
b/packages/wisi/sal-gen_bounded_definite_vectors-gen_refs.ads
deleted file mode 100644
index c235cbc..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors-gen_refs.ads
+++ /dev/null
@@ -1,54 +0,0 @@
--- Abstract :
---
--- Variable_Reference for parent.
---
--- In a child package because it's not Spark, and Spark does not
--- allow 'Spark_Mode => Off' on type declarations.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
-package SAL.Gen_Bounded_Definite_Vectors.Gen_Refs
- with Spark_Mode => Off
-is
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
private with
- Implicit_Dereference => Element;
-
- function Variable_Ref (Container : aliased in out Vector; Index : in
Index_Type) return Variable_Reference_Type
- with Inline,
- Pre => Index in Index_Type'First .. Last_Index (Container);
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Constant_Ref (Container : aliased in Vector; Index : in
Index_Type) return Constant_Reference_Type
- with Inline,
- Pre => Index in Index_Type'First .. Last_Index (Container);
-
-private
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
-end SAL.Gen_Bounded_Definite_Vectors.Gen_Refs;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors.adb
b/packages/wisi/sal-gen_bounded_definite_vectors.adb
deleted file mode 100644
index 17aac08..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors.adb
+++ /dev/null
@@ -1,120 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Bounded_Definite_Vectors
- with Spark_Mode
-is
- pragma Suppress (All_Checks);
-
- function Length (Container : in Vector) return Ada.Containers.Count_Type
- is (Ada.Containers.Count_Type (To_Peek_Index (Container.Last)));
-
- function Is_Full (Container : in Vector) return Boolean
- is begin
- return Length (Container) = Capacity;
- end Is_Full;
-
- procedure Clear (Container : in out Vector)
- is begin
- Container.Last := No_Index;
- end Clear;
-
- function Element (Container : Vector; Index : Index_Type) return
Element_Type
- is (Container.Elements (Peek_Type (Index - Index_Type'First + 1)));
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : in Index_Type;
- New_Item : in Element_Type)
- is begin
- Container.Elements (To_Peek_Index (Index)) := New_Item;
- end Replace_Element;
-
- function Last_Index (Container : Vector) return Extended_Index
- is (Container.Last);
-
- procedure Append (Container : in out Vector; New_Item : in Element_Type)
- is
- J : constant Peek_Type := To_Peek_Index (Container.Last + 1);
- begin
- Container.Elements (J) := New_Item;
- Container.Last := Container.Last + 1;
- end Append;
-
- procedure Prepend (Container : in out Vector; New_Item : in Element_Type)
- is
- J : constant Peek_Type := Peek_Type (Container.Last + 1 -
Index_Type'First + 1);
- begin
- Container.Elements (2 .. J) := Container.Elements (1 .. J - 1);
- Container.Elements (1) := New_Item;
- Container.Last := Container.Last + 1;
- end Prepend;
-
- procedure Insert
- (Container : in out Vector;
- New_Item : in Element_Type;
- Before : in Extended_Index)
- is
- J : constant Peek_Type := To_Peek_Index ((if Before = No_Index then
Container.Last + 1 else Before));
- K : constant Base_Peek_Type := To_Peek_Index (Container.Last);
- begin
- Container.Elements (J + 1 .. K + 1) := Container.Elements (J .. K);
- Container.Elements (J) := New_Item;
- Container.Last := Container.Last + 1;
- end Insert;
-
- function "+" (Item : in Element_Type) return Vector
- is begin
- return Result : Vector do
- Append (Result, Item);
- end return;
- end "+";
-
- function "&" (Left : in Vector; Right : in Element_Type) return Vector
- is begin
- -- WORKAROUND: If init Result with ":= Left", GNAT Community 2019
- -- checks Default_Initial_Condition (which fails when Left is not
- -- empty)! That is only supposed to be checked when initialized by
- -- default. Reported to AdaCore as ticket S724-042.
- return Result : Vector do
- Result := Left;
- Append (Result, Right);
- end return;
- end "&";
-
- procedure Delete_First (Container : in out Vector; Count : in
Ada.Containers.Count_Type := 1)
- is
- use Ada.Containers;
- begin
- if Count = 0 then
- return;
- end if;
-
- declare
- New_Last : constant Extended_Index := Extended_Index (Integer
(Container.Last) - Integer (Count));
- J : constant Base_Peek_Type := Base_Peek_Type (Count);
- K : constant Peek_Type := To_Peek_Index (Container.Last);
- begin
- -- Delete items 1 .. J, shift remaining down.
- Container.Elements (1 .. K - J) := Container.Elements (J + 1 .. K);
- Container.Last := New_Last;
- end;
- end Delete_First;
-
-end SAL.Gen_Bounded_Definite_Vectors;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors.ads
b/packages/wisi/sal-gen_bounded_definite_vectors.ads
deleted file mode 100644
index 9e698e2..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors.ads
+++ /dev/null
@@ -1,145 +0,0 @@
--- Abstract :
---
--- A simple bounded vector of definite items, in Spark.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Index_Type is range <>;
- type Element_Type is private;
- Capacity : in Ada.Containers.Count_Type;
-package SAL.Gen_Bounded_Definite_Vectors
- with Spark_Mode
-is
- use all type Ada.Containers.Count_Type;
-
- subtype Extended_Index is Index_Type'Base
- range Index_Type'First - 1 ..
- Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
-
- pragma Assert (Capacity <= Ada.Containers.Count_Type (Index_Type'Last -
Index_Type'First + 1));
-
- No_Index : constant Extended_Index := Extended_Index'First;
-
- type Vector is private with
- Default_Initial_Condition => Length (Vector) = 0;
-
- function Length (Container : in Vector) return Ada.Containers.Count_Type
with
- Post => Length'Result in 0 .. Capacity;
-
- function Is_Full (Container : in Vector) return Boolean with
- Post => Is_Full'Result = (Length (Container) = Capacity);
-
- function Has_Space (Container : in Vector; Item_Count : in
Ada.Containers.Count_Type) return Boolean
- is (Length (Container) + Item_Count <= Capacity)
- with Pre => Item_Count <= Ada.Containers.Count_Type'Last - Length
(Container);
-
- procedure Clear (Container : in out Vector) with
- Post => Length (Container) = 0;
-
- function First_Index (Container : in Vector) return Index_Type is
(Index_Type'First) with
- Depends => (First_Index'Result => null, null => Container);
-
- function Last_Index (Container : in Vector) return Extended_Index;
- -- No_Index when Container is empty.
-
- function Element (Container : in Vector; Index : in Index_Type) return
Element_Type
- with Pre => Index <= Last_Index (Container);
- -- Index of first element in Vector is Index_Type'First.
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : in Index_Type;
- New_Item : in Element_Type)
- with
- Pre => Index <= Last_Index (Container),
- Post => Element (Container, Index) = New_Item;
- -- Index of first element in Vector is Index_Type'First.
-
- procedure Append (Container : in out Vector; New_Item : in Element_Type)
with
- Pre => Length (Container) < Capacity,
- Post => Length (Container) = Length (Container'Old) + 1 and
- Element (Container, Last_Index (Container)) = New_Item and
- (for all I in Index_Type'First .. Last_Index (Container) - 1 =>
- Element (Container'Old, I) = Element (Container, I));
-
- procedure Prepend (Container : in out Vector; New_Item : in Element_Type)
with
- Pre => Length (Container) < Capacity,
- Post => Length (Container) = Length (Container'Old) + 1 and then
- (Element (Container, Index_Type'First) = New_Item and
- (for all I in Index_Type'First .. Last_Index (Container'Old) =>
- Element (Container'Old, I) = Element (Container, I + 1)));
- -- Insert New_Item at beginning of Container; current elements slide right.
-
- procedure Insert
- (Container : in out Vector;
- New_Item : in Element_Type;
- Before : in Extended_Index) with
- Pre => Length (Container) < Capacity and Before <= Last_Index
(Container),
- Contract_Cases =>
- (Before = No_Index =>
- Length (Container) = Length (Container'Old) + 1 and
- Element (Container, Last_Index (Container)) = New_Item and
- (for all I in Index_Type'First .. Last_Index (Container) - 1 =>
- Element (Container'Old, I) = Element (Container, I)),
- Before /= No_Index =>
- Length (Container) = Length (Container'Old) + 1 and
- Element (Container, Before) = New_Item and
- (for all I in Index_Type'First .. Before - 1 =>
- Element (Container'Old, I) = Element (Container, I)) and
- (for all I in Before + 1 .. Last_Index (Container) =>
- Element (Container'Old, I - 1) = Element (Container, I)));
- -- Insert New_Item before Before, or after Last_Index if Before is
- -- No_Index. Current elements at Before and after slide right.
- -- New_Item then has index Before.
-
- function "+" (Item : in Element_Type) return Vector with
- Post => Length ("+"'Result) = 1 and
- Element ("+"'Result, Index_Type'First) = Item;
-
- function "&" (Left : in Vector; Right : in Element_Type) return Vector with
- Pre => Length (Left) < Capacity,
- Post => Length ("&"'Result) = Length (Left) + 1 and
- (for all I in Index_Type'First .. Last_Index (Left) => Element
(Left, I) = Element ("&"'Result, I)) and
- Element ("&"'Result, Last_Index ("&"'Result)) = Right;
-
- procedure Delete_First (Container : in out Vector; Count : in
Ada.Containers.Count_Type := 1) with
- Pre => Length (Container) >= Count,
- Post => Length (Container) = Length (Container)'Old - Count and then
- (for all I in Index_Type'First .. Last_Index (Container) =>
- Element (Container'Old, Index_Type (Integer (I) + Integer
(Count))) = Element (Container, I));
- -- Remaining elements slide down.
-
-private
-
- type Array_Type is array (Peek_Type range 1 .. Peek_Type (Capacity)) of
aliased Element_Type;
-
- type Vector is
- record
- Elements : Array_Type;
- Last : Extended_Index := No_Index;
- end record with
- Type_Invariant => To_Peek_Index (Last) <= Elements'Last;
- pragma Annotate (GNATprove, Intentional, "type ""Vector"" is not fully
initialized",
- "Only items in Elements with index < Last are accessed");
-
- ----------
- -- For child units
-
- function To_Peek_Index (Index : in Extended_Index) return Base_Peek_Type is
- (Base_Peek_Type (Index - Index_Type'First + 1));
-
-end SAL.Gen_Bounded_Definite_Vectors;
diff --git
a/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.adb
b/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.adb
deleted file mode 100644
index cee9c74..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.adb
+++ /dev/null
@@ -1,35 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded;
-function SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Image_Aux (Item : in
Vector; Aux : in Aux_Data) return String
-is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- Last : constant Base_Peek_Type := Item.Last;
-begin
- for I in 1 .. Last loop
- Result := Result & Element_Image (Item.Elements (I), Aux);
- if I /= Last then
- Result := Result & ", ";
- end if;
- end loop;
- Result := Result & ")";
- return To_String (Result);
-end SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Image_Aux;
diff --git
a/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.ads
b/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.ads
deleted file mode 100644
index 28c56fd..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_image_aux.ads
+++ /dev/null
@@ -1,23 +0,0 @@
--- Abstract :
---
--- Image with auxiliary data for instantiations of parent.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Aux_Data (<>) is private;
- with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Image_Aux (Item : in
Vector; Aux : in Aux_Data) return String;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_refs.adb
b/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_refs.adb
deleted file mode 100644
index fb5d619..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_refs.adb
+++ /dev/null
@@ -1,29 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Refs is
-
- function Constant_Ref (Container : aliased Vector; Index : in Peek_Type)
return Constant_Reference_Type
- is begin
- return
- (Element => Container.Elements (Index)'Access,
- Dummy => 1);
- end Constant_Ref;
-
-end SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Refs;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_refs.ads
b/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_refs.ads
deleted file mode 100644
index 17e98c4..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors_sorted-gen_refs.ads
+++ /dev/null
@@ -1,39 +0,0 @@
--- Abstract :
---
--- Constant_Reference for parent.
---
--- In a child package because it's not Spark, and Spark does not
--- allow 'Spark_Mode => Off' on type declarations.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
-package SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Refs is
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Constant_Ref (Container : aliased Vector; Index : in Peek_Type)
return Constant_Reference_Type with
- Inline;
-
-private
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
-end SAL.Gen_Bounded_Definite_Vectors_Sorted.Gen_Refs;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors_sorted.adb
b/packages/wisi/sal-gen_bounded_definite_vectors_sorted.adb
deleted file mode 100644
index 8b89a7f..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors_sorted.adb
+++ /dev/null
@@ -1,96 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Bounded_Definite_Vectors_Sorted is
-
- function Length (Container : in Vector) return Ada.Containers.Count_Type
- is (Ada.Containers.Count_Type (Container.Last));
-
- function Is_Full (Container : in Vector) return Boolean
- is begin
- return Container.Last = Peek_Type (Capacity);
- end Is_Full;
-
- procedure Clear (Container : in out Vector)
- is begin
- Container.Last := No_Index;
- end Clear;
-
- function Last_Index (Container : in Vector) return Base_Peek_Type
- is (Container.Last);
-
- function Element (Container : in Vector; Index : in Peek_Type) return
Element_Type
- is (Container.Elements (Index));
-
- procedure Insert
- (Container : in out Vector;
- New_Item : in Element_Type;
- Ignore_If_Equal : in Boolean := False)
- is
- K : constant Base_Peek_Type := Container.Last;
- J : Base_Peek_Type := K;
- begin
- if K = 0 then
- -- Container empty
- Container.Last := 1;
- Container.Elements (1) := New_Item;
- return;
- end if;
-
- loop
- -- These seem obvious, but gnatprove needs them (in 2019).
- pragma Loop_Invariant (J <= Container.Last);
- pragma Loop_Invariant (J <= Container.Elements'Last);
- pragma Loop_Variant (Decreases => J);
-
- -- This is less obvious, helps a lot.
- pragma Loop_Invariant
- ((for all I in J + 1 .. Container.Last => Element_Compare
- (New_Item, Container.Elements (I)) = Less));
-
- exit when J < 1;
-
- case Element_Compare (New_Item, Container.Elements (J)) is
- when Less =>
- J := J - 1;
- when Equal =>
- if Ignore_If_Equal then
- return;
- else
- -- Insert after J
- exit;
- end if;
- when Greater =>
- -- Insert after J
- exit;
- end case;
- end loop;
-
- -- Note that this assertion is _not_ a Loop_Invariant; the whole
- -- point here is to find the right J.
- pragma Assert
- (for all I in 1 .. J - 1 =>
- Element_Compare (Container.Elements (I), New_Item) in Less | Equal);
-
- Container.Elements (J + 2 .. K + 1) := Container.Elements (J + 1 .. K);
- Container.Elements (J + 1) := New_Item;
- Container.Last := Container.Last + 1;
- end Insert;
-
-end SAL.Gen_Bounded_Definite_Vectors_Sorted;
diff --git a/packages/wisi/sal-gen_bounded_definite_vectors_sorted.ads
b/packages/wisi/sal-gen_bounded_definite_vectors_sorted.ads
deleted file mode 100644
index e86fbca..0000000
--- a/packages/wisi/sal-gen_bounded_definite_vectors_sorted.ads
+++ /dev/null
@@ -1,100 +0,0 @@
--- Abstract :
---
--- A simple bounded sorted vector of definite items, in Spark.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Element_Type is private;
- with function Element_Compare (Left, Right : in Element_Type) return
Compare_Result;
- Capacity : in Ada.Containers.Count_Type;
-package SAL.Gen_Bounded_Definite_Vectors_Sorted
- with Spark_Mode
-is
- use all type Ada.Containers.Count_Type;
-
- No_Index : constant Base_Peek_Type := 0;
-
- type Vector is private with
- Default_Initial_Condition => Last_Index (Vector) = No_Index;
-
- function Length (Container : in Vector) return Ada.Containers.Count_Type
with
- Post => Length'Result in 0 .. Capacity;
-
- function Is_Full (Container : in Vector) return Boolean with
- Post => Is_Full'Result = (Length (Container) = Capacity);
-
- procedure Clear (Container : in out Vector) with
- Post => Last_Index (Container) = No_Index;
-
- function First_Index (Container : in Vector) return Peek_Type
- is (Peek_Type'First) with
- Depends => (First_Index'Result => null, null => Container);
-
- function Last_Index (Container : in Vector) return Base_Peek_Type with
- Inline;
-
- function Element (Container : in Vector; Index : in Peek_Type) return
Element_Type with
- Pre => Index in First_Index (Container) .. Last_Index (Container);
-
- function Is_Sorted (Container : in Vector) return Boolean is
- -- See comment on similar Is_Sorted below
- (for all I in First_Index (Container) .. Last_Index (Container) - 1 =>
- (for all J in I + 1 .. Last_Index (Container) =>
- Element_Compare (Element (Container, I), Element (Container, J)) in
Less | Equal));
-
- procedure Insert
- (Container : in out Vector;
- New_Item : in Element_Type;
- Ignore_If_Equal : in Boolean := False) with
- Pre => Last_Index (Container) < Peek_Type (Capacity),
- Post => Is_Sorted (Container) and
- (if Ignore_If_Equal then
- (Last_Index (Container) = Last_Index (Container'Old) or
- Last_Index (Container) = Last_Index (Container'Old) + 1)
- else
- Last_Index (Container) = Last_Index (Container'Old) + 1);
- -- Insert New_Item in sorted position. Items are sorted in increasing
- -- order according to Element_Compare. New_Item is inserted after
- -- Equal items, unless Ignore_If_Equal is true, in which case
- -- New_Item is not inserted.
-
-private
-
- type Array_Type is array (Peek_Type range 1 .. Peek_Type (Capacity)) of
aliased Element_Type;
-
- function Is_Sorted (Container : in Array_Type; Last : in Base_Peek_Type)
return Boolean
- -- This is too hard for gnatprove (in 2019):
- -- is (for all I in Container'First .. Last - 1 =>
- -- Element_Compare (Container (I), Container (I + 1)) in Less |
Equal)
- -- This works:
- is (for all I in Container'First .. Last - 1 =>
- (for all J in I + 1 .. Last =>
- Element_Compare (Container (I), Container (J)) in Less | Equal))
- with Pre => Last <= Container'Last;
-
- subtype Index_Type is Base_Peek_Type range No_Index .. Base_Peek_Type
(Capacity);
- -- Helps with proofs
-
- type Vector is record
- Elements : Array_Type;
- Last : Index_Type := No_Index;
- end record with
- Type_Invariant => Last <= Elements'Last and Is_Sorted (Vector.Elements,
Vector.Last);
- pragma Annotate (GNATprove, Intentional, "type ""Vector"" is not fully
initialized",
- "Only items in Elements with index <= Last are accessed");
-
-end SAL.Gen_Bounded_Definite_Vectors_Sorted;
diff --git a/packages/wisi/sal-gen_definite_doubly_linked_lists.adb
b/packages/wisi/sal-gen_definite_doubly_linked_lists.adb
deleted file mode 100644
index d86441a..0000000
--- a/packages/wisi/sal-gen_definite_doubly_linked_lists.adb
+++ /dev/null
@@ -1,317 +0,0 @@
--- Abstract :
---
--- see spec
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This library is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
--- MA 02111-1307, USA.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Definite_Doubly_Linked_Lists is
-
- procedure Delete_Node (Container : in out List; Node : in out Node_Access)
- is begin
- if Node.Next = null then
- Container.Tail := Node.Prev;
- else
- Node.Next.Prev := Node.Prev;
- end if;
- if Node.Prev = null then
- Container.Head := Node.Next;
- else
- Node.Prev.Next := Node.Next;
- end if;
- Free (Node);
- end Delete_Node;
-
- ---------
- -- Public operations, declaration order.
-
- overriding
- procedure Adjust (Container : in out List)
- is
- Next_Source : Node_Access := Container.Head;
- New_Node : Node_Access;
- begin
- if Next_Source = null then
- return;
- end if;
-
- Container.Tail := null;
-
- loop
- New_Node := new Node_Type'
- (Element => Next_Source.Element,
- Next => null,
- Prev => Container.Tail);
- if Container.Tail = null then
- Container.Head := New_Node;
- Container.Tail := New_Node;
- else
- Container.Tail.Next := New_Node;
- Container.Tail := New_Node;
- end if;
- Next_Source := Next_Source.Next;
- exit when Next_Source = null;
- end loop;
- end Adjust;
-
- overriding
- procedure Finalize (Container : in out List)
- is
- Next : Node_Access := Container.Head;
- begin
- loop
- exit when Next = null;
- Next := Container.Head.Next;
- Free (Container.Head);
- Container.Head := Next;
- end loop;
- Container.Tail := null;
- end Finalize;
-
- function Length (Container : in List) return Ada.Containers.Count_Type
- is begin
- return Container.Count;
- end Length;
-
- procedure Append (Container : in out List; Element : in Element_Type)
- is
- use all type Ada.Containers.Count_Type;
- New_Node : constant Node_Access := new Node_Type'
- (Element => Element,
- Prev => Container.Tail,
- Next => null);
- begin
- if Container.Tail = null then
- Container.Head := New_Node;
- Container.Tail := New_Node;
- else
- Container.Tail.Next := New_Node;
- Container.Tail := New_Node;
- end if;
- Container.Count := Container.Count + 1;
- end Append;
-
- procedure Prepend (Container : in out List; Element : in Element_Type)
- is
- use all type Ada.Containers.Count_Type;
- New_Node : constant Node_Access := new Node_Type'
- (Element => Element,
- Prev => null,
- Next => Container.Head);
- begin
- if Container.Tail = null then
- Container.Head := New_Node;
- Container.Tail := New_Node;
- else
- Container.Head.Prev := New_Node;
- Container.Head := New_Node;
- end if;
- Container.Count := Container.Count + 1;
- end Prepend;
-
- function To_List (Element : in Element_Type) return List
- is begin
- return Result : List do
- Result.Append (Element);
- end return;
- end To_List;
-
- function Has_Element (Position : in Cursor) return Boolean
- is begin
- return Position.Ptr /= null;
- end Has_Element;
-
- function First (Container : in List) return Cursor
- is begin
- if Container.Head = null then
- return (Ptr => null);
- else
- return (Ptr => Container.Head);
- end if;
- end First;
-
- function Last (Container : in List) return Cursor
- is begin
- if Container.Tail = null then
- return (Ptr => null);
- else
- return (Ptr => Container.Tail);
- end if;
- end Last;
-
- procedure Next (Position : in out Cursor)
- is begin
- if Position.Ptr /= null then
- if Position.Ptr.Next = null then
- Position.Ptr := null;
- else
- Position.Ptr := Position.Ptr.Next;
- end if;
- end if;
- end Next;
-
- function Next (Position : in Cursor) return Cursor
- is begin
- if Position.Ptr = null then
- return Position;
- else
- if Position.Ptr.Next = null then
- return (Ptr => null);
- else
- return (Ptr => Position.Ptr.Next);
- end if;
- end if;
- end Next;
-
- function Previous (Position : in Cursor) return Cursor
- is begin
- if Position.Ptr = null then
- return Position;
- else
- if Position.Ptr.Prev = null then
- return (Ptr => null);
- else
- return (Ptr => Position.Ptr.Prev);
- end if;
- end if;
- end Previous;
-
- function Element (Position : in Cursor) return Element_Type
- is begin
- return Position.Ptr.Element;
- end Element;
-
- procedure Delete (Container : in out List; Position : in out Cursor)
- is
- use all type Ada.Containers.Count_Type;
- begin
- Delete_Node (Container, Position.Ptr);
- Position := (Ptr => null);
- Container.Count := Container.Count - 1;
- end Delete;
-
- procedure Delete_First (Container : in out List)
- is
- use all type Ada.Containers.Count_Type;
- Node : Node_Access := Container.Head;
- begin
- Delete_Node (Container, Node);
- Container.Count := Container.Count - 1;
- end Delete_First;
-
- procedure Insert
- (Container : in out List;
- Before : in Cursor;
- Element : in Element_Type)
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Before = (Ptr => null) then
- Container.Append (Element);
- else
- if Before.Ptr = Container.Head then
- declare
- -- old list: before ...
- -- newlist: new before ...
- New_Node : constant Node_Access := new Node_Type'
- (Element => Element,
- Prev => null,
- Next => Before.Ptr);
- begin
- Before.Ptr.Prev := New_Node;
- Container.Head := New_Node;
- end;
- else
- declare
- -- old list: ... prev before ...
- -- newlist: ... prev new before ...
- New_Node : constant Node_Access := new Node_Type'
- (Element => Element,
- Prev => Before.Ptr.Prev,
- Next => Before.Ptr);
- begin
- Before.Ptr.Prev.Next := New_Node;
- Before.Ptr.Prev := New_Node;
-
- end;
- end if;
- Container.Count := Container.Count + 1;
- end if;
- end Insert;
-
- function Persistent_Ref (Position : in Cursor) return access Element_Type
- is begin
- return Position.Ptr.Element'Access;
- end Persistent_Ref;
-
- function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type
- is
- pragma Unreferenced (Container);
- begin
- return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
- end Constant_Reference;
-
- function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
- is begin
- return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
- end Constant_Ref;
-
- function Variable_Reference (Container : in List; Position : in Cursor)
return Variable_Reference_Type
- is
- pragma Unreferenced (Container);
- begin
- return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
- end Variable_Reference;
-
- function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
- is begin
- return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
- end Variable_Ref;
-
- function Iterate (Container : aliased in List) return
Iterator_Interfaces.Reversible_Iterator'Class
- is begin
- return Iterator'(Container => Container'Access);
- end Iterate;
-
- overriding function First (Object : Iterator) return Cursor
- is begin
- return First (Object.Container.all);
- end First;
-
- overriding function Last (Object : Iterator) return Cursor
- is begin
- return Last (Object.Container.all);
- end Last;
-
- overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
- is
- pragma Unreferenced (Object);
- begin
- return Next (Position);
- end Next;
-
- overriding function Previous (Object : in Iterator; Position : in Cursor)
return Cursor
- is
- pragma Unreferenced (Object);
- begin
- return Previous (Position);
- end Previous;
-
-end SAL.Gen_Definite_Doubly_Linked_Lists;
diff --git a/packages/wisi/sal-gen_definite_doubly_linked_lists.ads
b/packages/wisi/sal-gen_definite_doubly_linked_lists.ads
deleted file mode 100644
index 8470daf..0000000
--- a/packages/wisi/sal-gen_definite_doubly_linked_lists.ads
+++ /dev/null
@@ -1,172 +0,0 @@
--- Abstract :
---
--- A generic doubly linked list with definite elements, allowing
--- permanent references to elements.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This library is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
--- MA 02111-1307, USA.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-with Ada.Finalization;
-with Ada.Iterator_Interfaces;
-with Ada.Unchecked_Deallocation;
-generic
- type Element_Type is private;
-package SAL.Gen_Definite_Doubly_Linked_Lists is
-
- type List is new Ada.Finalization.Controlled with private
- with
- Constant_Indexing => Constant_Reference,
- Variable_Indexing => Variable_Reference,
- Default_Iterator => Iterate,
- Iterator_Element => Element_Type;
-
- type List_Access_Constant is access constant List;
- for List_Access_Constant'Storage_Size use 0;
-
- type List_Access is access all List;
- for List_Access'Storage_Size use 0;
-
- Empty_List : constant List;
-
- overriding procedure Adjust (Container : in out List);
- -- Deep copy.
-
- overriding procedure Finalize (Container : in out List);
- -- Free all items in List.
-
- procedure Clear (Container : in out List) renames Finalize;
-
- function Length (Container : in List) return Ada.Containers.Count_Type;
-
- procedure Append (Container : in out List; Element : in Element_Type);
-
- procedure Prepend (Container : in out List; Element : in Element_Type);
-
- function To_List (Element : in Element_Type) return List;
-
- type Cursor is private;
-
- function Has_Element (Position : in Cursor) return Boolean;
-
- No_Element : constant Cursor;
- function First (Container : in List) return Cursor;
- function Last (Container : in List) return Cursor;
-
- procedure Next (Position : in out Cursor)
- with Pre => Has_Element (Position);
-
- function Next (Position : in Cursor) return Cursor
- with Pre => Has_Element (Position);
- function Previous (Position : in Cursor) return Cursor
- with Pre => Has_Element (Position);
-
- function Element (Position : in Cursor) return Element_Type
- with Pre => Has_Element (Position);
-
- procedure Delete (Container : in out List; Position : in out Cursor)
- with Pre => Has_Element (Position);
-
- procedure Delete_First (Container : in out List);
-
- procedure Insert
- (Container : in out List;
- Before : in Cursor;
- Element : in Element_Type);
- -- If Before is No_Element, insert after Last.
-
- function Persistent_Ref (Position : in Cursor) return access Element_Type
- with Pre => Has_Element (Position);
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type
- with Inline, Pre => Has_Element (Position);
- -- Not 'Constant_Ref' because that is taken, and it is wrong for
Constant_Indexing
-
- function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
- with Inline, Pre => Has_Element (Position);
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
private with
- Implicit_Dereference => Element;
-
- function Variable_Reference (Container : in List; Position : in Cursor)
return Variable_Reference_Type
- with Inline, Pre => Has_Element (Position);
-
- function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
- with Inline, Pre => Has_Element (Position);
-
- package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
-
- function Iterate (Container : aliased in List) return
Iterator_Interfaces.Reversible_Iterator'Class;
-
-private
- type Node_Type;
-
- type Node_Access is access Node_Type;
-
- type Node_Type is record
- Element : aliased Element_Type;
- Prev : Node_Access;
- Next : Node_Access;
- end record;
-
- procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-
- type List is new Ada.Finalization.Controlled with record
- Head : Node_Access := null;
- Tail : Node_Access := null;
- Count : Ada.Containers.Count_Type := 0;
- end record;
-
- type Cursor is record
- Ptr : Node_Access;
- end record;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- No_Element : constant Cursor := (Ptr => null);
-
- Empty_List : constant List := (Ada.Finalization.Controlled with null, null,
0);
-
- type Iterator (Container : not null access constant List) is new
Iterator_Interfaces.Reversible_Iterator with
- null record;
-
- overriding function First (Object : Iterator) return Cursor;
- overriding function Last (Object : Iterator) return Cursor;
-
- overriding function Next
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
- overriding function Previous
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
-end SAL.Gen_Definite_Doubly_Linked_Lists;
diff --git
a/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted-gen_image.adb
b/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted-gen_image.adb
deleted file mode 100644
index 6e6efb3..0000000
--- a/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted-gen_image.adb
+++ /dev/null
@@ -1,47 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded;
-function SAL.Gen_Definite_Doubly_Linked_Lists_Sorted.Gen_Image
- (Item : in List; Strict : in Boolean := False) return String
-is
- use Ada.Strings;
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- Need_Comma : Boolean := False;
-begin
- if Strict and Item.Length = 0 then
- return "(1 .. 0 => <>)";
-
- elsif Strict and Item.Length = 1 then
- return "(1 => " & Element_Image (Element (Item.First)) & ")";
-
- else
- for El of Item loop
- if Need_Comma then
- Result := Result & ", ";
- else
- Need_Comma := True;
- end if;
- Result := Result & Element_Image (El);
- end loop;
- Result := Result & ")";
- return To_String (Result);
- end if;
-end SAL.Gen_Definite_Doubly_Linked_Lists_Sorted.Gen_Image;
diff --git
a/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted-gen_image.ads
b/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted-gen_image.ads
deleted file mode 100644
index 4080707..0000000
--- a/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted-gen_image.ads
+++ /dev/null
@@ -1,25 +0,0 @@
--- Abstract :
---
--- Image of parent.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- with function Element_Image (Item : in Element_Type) return String;
-function SAL.Gen_Definite_Doubly_Linked_Lists_Sorted.Gen_Image
- (Item : in List; Strict : in Boolean := False) return String;
--- Image of Item, in Ada aggregate syntax. If Strict, use correct
--- syntax for 0 and 1 item; otherwise, use () and (item).
diff --git a/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted.adb
b/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted.adb
deleted file mode 100644
index 702914d..0000000
--- a/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted.adb
+++ /dev/null
@@ -1,542 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Definite_Doubly_Linked_Lists_Sorted is
-
- ----------
- -- Body subprograms, alphabetical
-
- procedure Find
- (Container : in List;
- Element : in Element_Type;
- Found : out Node_Access;
- Found_Compare : out Compare_Result)
- is
- -- Return pointer to first item in Container for which Compare (item,
- -- element) returns True or Greater. If no such element exists, Found
- -- is null, Found_Compare is Less.
- use Ada.Containers;
- begin
- if Container.Head = null then
- Found := null;
- Found_Compare := Less;
- return;
- end if;
-
- declare
- Low_Index : Count_Type := 1;
- High_Index : Count_Type := Container.Count;
- Next_Node : Node_Access := Container.Head;
- Next_Index : Count_Type := Low_Index;
- Old_Index : Count_Type;
- begin
- loop
- Old_Index := Next_Index;
- Next_Index := (Low_Index + High_Index) / 2;
-
- if Next_Index > Old_Index then
- for I in Old_Index + 1 .. Next_Index loop
- Next_Node := Next_Node.Next;
- end loop;
- elsif Next_Index < Old_Index then
- for I in Next_Index .. Old_Index - 1 loop
- Next_Node := Next_Node.Prev;
- end loop;
- end if;
-
- case Element_Compare (Next_Node.Element, Element) is
- when Less =>
- if Next_Index = High_Index then
- -- no more nodes to check
- Found := null;
- Found_Compare := Less;
- return;
- elsif Next_Index = Low_Index then
- -- force check of high_index
- Low_Index := High_Index;
- else
- Low_Index := Next_Index;
- end if;
-
- when Equal =>
- Found := Next_Node;
- Found_Compare := Equal;
- return;
-
- when Greater =>
- if Low_Index = Next_Index then
- -- no more nodes to check
- Found := Next_Node;
- Found_Compare := Greater;
- return;
- elsif High_Index = Next_Index then
- -- Desired result is either high_index or low_index
- pragma Assert (Low_Index + 1 = High_Index);
- case Element_Compare (Next_Node.Prev.Element, Element) is
- when Less =>
- Found := Next_Node;
- Found_Compare := Greater;
- return;
- when Equal =>
- Found := Next_Node.Prev;
- Found_Compare := Equal;
- return;
- when Greater =>
- Found := Next_Node.Prev;
- Found_Compare := Greater;
- return;
- end case;
- else
- High_Index := Next_Index;
- end if;
- end case;
- end loop;
- end;
- end Find;
-
- procedure Insert_Before
- (Container : in out List;
- Before : in Node_Access;
- Element : in Element_Type)
- is
- New_Node : constant Node_Access := new Node_Type'
- (Element => Element,
- Prev => Before.Prev,
- Next => Before);
- begin
- if Before = Container.Head then
- Before.Prev := New_Node;
- Container.Head := New_Node;
- else
- Before.Prev.Next := New_Node;
- Before.Prev := New_Node;
- end if;
- end Insert_Before;
-
- procedure Insert_After_Tail
- (Container : in out List;
- Element : in Element_Type)
- is
- New_Node : constant Node_Access := new Node_Type'
- (Element => Element,
- Prev => Container.Tail,
- Next => null);
- begin
- Container.Tail.Next := New_Node;
- Container.Tail := New_Node;
- end Insert_After_Tail;
-
- ---------
- -- Public operations, declaration order.
-
- overriding
- procedure Adjust (Container : in out List)
- is
- Next_Source : Node_Access := Container.Head;
- New_Node : Node_Access;
- begin
- if Next_Source = null then
- return;
- end if;
-
- Container.Tail := null;
-
- loop
- New_Node := new Node_Type'
- (Element => Next_Source.Element,
- Next => null,
- Prev => Container.Tail);
- if Container.Tail = null then
- Container.Head := New_Node;
- Container.Tail := New_Node;
- else
- Container.Tail.Next := New_Node;
- Container.Tail := New_Node;
- end if;
- Next_Source := Next_Source.Next;
- exit when Next_Source = null;
- end loop;
- end Adjust;
-
- overriding
- procedure Finalize (Container : in out List)
- is
- Next : Node_Access := Container.Head;
- begin
- loop
- exit when Next = null;
- Next := Container.Head.Next;
- Free (Container.Head);
- Container.Head := Next;
- end loop;
- Container.Tail := null;
- end Finalize;
-
- overriding function "=" (Left, Right : in List) return Boolean
- is
- Left_I : Node_Access := Left.Head;
- Right_I : Node_Access := Right.Head;
- begin
- loop
- exit when Left_I = null;
-
- if Right_I = null then
- return False;
- elsif Left_I.Element /= Right_I.Element then
- return False;
- end if;
-
- Left_I := Left_I.Next;
- Right_I := Right_I.Next;
- end loop;
- return Right_I = null;
- end "=";
-
- function Length (Container : in List) return Ada.Containers.Count_Type
- is begin
- return Container.Count;
- end Length;
-
- function To_List (Element : in Element_Type) return List
- is
- New_Node : constant Node_Access := new Node_Type'
- (Element => Element,
- Prev => null,
- Next => null);
- begin
- return Result : constant List :=
- (Ada.Finalization.Controlled with
- Head => New_Node,
- Tail => New_Node,
- Count => 1);
- end To_List;
-
- procedure Insert (Container : in out List; Element : in Element_Type)
- is
- Node : Node_Access := Container.Head;
- Compare : Compare_Result;
- begin
- if Node = null then
- Container := To_List (Element);
- else
- Find (Container, Element, Node, Compare);
-
- Container.Count := Container.Count + 1;
-
- if Node = null then
- Insert_After_Tail (Container, Element);
- else
- Insert_Before (Container, Node, Element);
- end if;
- end if;
- end Insert;
-
- function Contains (Container : in List; Element : in Element_Type) return
Boolean
- is
- Node : Node_Access := Container.Head;
- Compare : Compare_Result;
- begin
- Find (Container, Element, Node, Compare);
- return Compare = Equal;
- end Contains;
-
- procedure Merge
- (Target : in out List;
- Source : in List;
- Added : out Boolean)
- is
- Target_I : Node_Access := Target.Head;
- Source_I : Node_Access := Source.Head;
- begin
- if Target_I = null then
- if Source_I = null then
- Added := False;
- else
- Target.Head := Source.Head;
- Target.Tail := Source.Tail;
- Target.Count := Source.Count;
- Adjust (Target);
-
- Added := True;
- end if;
-
- elsif Source_I = null then
- Added := False;
-
- else
- Added := False;
- loop
- exit when Source_I = null;
-
- if Target_I = null then
- Added := True;
- Target.Count := Target.Count + 1;
- Insert_After_Tail (Target, Source_I.Element);
- Source_I := Source_I.Next;
-
- else
- case Element_Compare (Target_I.Element, Source_I.Element) is
- when Greater =>
- Added := True;
- Target.Count := Target.Count + 1;
- Insert_Before (Target, Target_I, Source_I.Element);
- Source_I := Source_I.Next;
-
- when Equal =>
- Target_I := Target_I.Next;
- Source_I := Source_I.Next;
-
- when Less =>
- Target_I := Target_I.Next;
- end case;
- end if;
- end loop;
- end if;
- end Merge;
-
- procedure Merge
- (Target : in out List;
- Source : in List;
- Added : out Boolean;
- Exclude : in Element_Type)
- is
- Target_I : Node_Access := Target.Head;
- Source_I : Node_Access := Source.Head;
- begin
- Added := False;
-
- if Target_I = null then
- if Source_I = null then
- return;
- else
- loop
- if Source_I = null then
- return;
- end if;
- exit when Source_I.Element /= Exclude;
- Source_I := Source_I.Next;
- end loop;
-
- Added := True;
- Target := To_List (Source_I.Element);
- Source_I := Source_I.Next;
- end if;
- end if;
-
- loop
- exit when Source_I = null;
-
- if Source_I.Element = Exclude then
- Source_I := Source_I.Next;
-
- elsif Target_I = null then
- Added := True;
- Target.Count := Target.Count + 1;
- Insert_After_Tail (Target, Source_I.Element);
- Source_I := Source_I.Next;
-
- else
- case Element_Compare (Target_I.Element, Source_I.Element) is
- when Greater =>
- Added := True;
- Target.Count := Target.Count + 1;
- Insert_Before (Target, Target_I, Source_I.Element);
- Source_I := Source_I.Next;
-
- when Equal =>
- Target_I := Target_I.Next;
- Source_I := Source_I.Next;
-
- when Less =>
- Target_I := Target_I.Next;
- end case;
- end if;
- end loop;
- end Merge;
-
- function Has_Element (Position : in Cursor) return Boolean
- is begin
- return Position.Ptr /= null;
- end Has_Element;
-
- function First (Container : aliased in List) return Cursor
- is begin
- if Container.Head = null then
- return (Container'Access, null);
- else
- return (Container'Access, Container.Head);
- end if;
- end First;
-
- function Last (Container : aliased in List) return Cursor
- is begin
- if Container.Tail = null then
- return (Container'Access, null);
- else
- return (Container'Access, Container.Tail);
- end if;
- end Last;
-
- function Find (Container : aliased in List; Element : in Element_Type)
return Cursor
- is
- Node : Node_Access;
- Compare : Compare_Result;
- begin
- Find (Container, Element, Node, Compare);
-
- if Node = null then
- return (Container'Access, null);
- elsif Compare = Equal then
- return (Container'Access, Node);
- else
- return (Container'Access, null);
- end if;
- end Find;
-
- procedure Next (Position : in out Cursor)
- is begin
- if Position.Ptr /= null then
- if Position.Ptr.Next = null then
- Position.Ptr := null;
- else
- Position.Ptr := Position.Ptr.Next;
- end if;
- end if;
- end Next;
-
- function Next (Position : in Cursor) return Cursor
- is begin
- if Position.Ptr = null then
- return Position;
- else
- if Position.Ptr.Next = null then
- return (Position.Container, null);
- else
- return (Position.Container, Position.Ptr.Next);
- end if;
- end if;
- end Next;
-
- function Previous (Position : in Cursor) return Cursor
- is begin
- if Position.Ptr = null then
- return Position;
- else
- if Position.Ptr.Prev = null then
- return (Position.Container, null);
- else
- return (Position.Container, Position.Ptr.Prev);
- end if;
- end if;
- end Previous;
-
- function Element (Position : in Cursor) return Element_Type
- is begin
- return Position.Ptr.Element;
- end Element;
-
- procedure Delete (Container : in out List; Position : in out Cursor)
- is
- Node : Node_Access renames Position.Ptr;
- begin
- if Node.Next = null then
- Container.Tail := Node.Prev;
- else
- Node.Next.Prev := Node.Prev;
- end if;
- if Node.Prev = null then
- Container.Head := Node.Next;
- else
- Node.Prev.Next := Node.Next;
- end if;
- Free (Node);
- Position := (Container'Access, null);
- Container.Count := Container.Count - 1;
- end Delete;
-
- function Pop (Container : in out List) return Element_Type
- is
- Node : Node_Access := Container.Head;
- begin
- return Result : constant Element_Type := Container.Head.Element do
- Container.Head := Node.Next;
- if Node.Next = null then
- Container.Tail := null;
- else
- Node.Next.Prev := null;
- end if;
- Free (Node);
- Container.Count := Container.Count - 1;
- end return;
- end Pop;
-
- function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type
- is
- pragma Unreferenced (Container);
- begin
- return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
- end Constant_Reference;
-
- function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
- is begin
- return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
- end Constant_Ref;
-
- function Variable_Reference (Container : in List; Position : in Cursor)
return Variable_Reference_Type
- is
- pragma Unreferenced (Container);
- begin
- return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
- end Variable_Reference;
-
- function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
- is begin
- return (Element => Position.Ptr.all.Element'Access, Dummy => 1);
- end Variable_Ref;
-
- function Iterate (Container : aliased in List) return
Iterator_Interfaces.Reversible_Iterator'Class
- is begin
- return Iterator'(Container => Container'Access);
- end Iterate;
-
- overriding function First (Object : Iterator) return Cursor
- is begin
- return First (Object.Container.all);
- end First;
-
- overriding function Last (Object : Iterator) return Cursor
- is begin
- return Last (Object.Container.all);
- end Last;
-
- overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
- is
- pragma Unreferenced (Object);
- begin
- return Next (Position);
- end Next;
-
- overriding function Previous (Object : in Iterator; Position : in Cursor)
return Cursor
- is
- pragma Unreferenced (Object);
- begin
- return Previous (Position);
- end Previous;
-
-end SAL.Gen_Definite_Doubly_Linked_Lists_Sorted;
diff --git a/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted.ads
b/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted.ads
deleted file mode 100644
index 91ffeda..0000000
--- a/packages/wisi/sal-gen_definite_doubly_linked_lists_sorted.ads
+++ /dev/null
@@ -1,190 +0,0 @@
--- Abstract :
---
--- A generic sorted doubly linked list with definite elements.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with Ada.Iterator_Interfaces;
-with Ada.Unchecked_Deallocation;
-generic
- type Element_Type is private;
- with function Element_Compare (Left, Right : in Element_Type) return
Compare_Result;
-package SAL.Gen_Definite_Doubly_Linked_Lists_Sorted is
- use all type Ada.Containers.Count_Type;
-
- type List is new Ada.Finalization.Controlled with private
- with
- Constant_Indexing => Constant_Reference,
- Variable_Indexing => Variable_Reference,
- Default_Iterator => Iterate,
- Iterator_Element => Element_Type;
-
- -- If user uses Variable_Indexing, they must not change the sort
- -- order of the elements.
-
- type List_Access is access all List;
- for List_Access'Storage_Size use 0;
-
- Empty_List : constant List;
-
- overriding procedure Adjust (Container : in out List);
- -- Deep copy.
-
- overriding procedure Finalize (Container : in out List);
- -- Free all items in List.
-
- procedure Clear (Container : in out List) renames Finalize;
-
- overriding function "=" (Left, Right : in List) return Boolean;
- -- True if contents are the same.
-
- function Length (Container : in List) return Ada.Containers.Count_Type;
-
- function To_List (Element : in Element_Type) return List;
-
- procedure Insert (Container : in out List; Element : in Element_Type);
- -- Insert Element before first item for which Element_Order (item,
- -- element) returns True.
-
- function Contains (Container : in List; Element : in Element_Type) return
Boolean;
-
- procedure Merge
- (Target : in out List;
- Source : in List;
- Added : out Boolean);
- -- Add all elements of Source to Target, if they are not already
- -- present.
- --
- -- Added is True if any element was not already present.
-
- procedure Merge
- (Target : in out List;
- Source : in List;
- Added : out Boolean;
- Exclude : in Element_Type);
- -- Add all elements of Source to Target, if they are not already
- -- present, and are not equal to Exclude.
- --
- -- Added is True if any element was not already present.
-
- type Cursor (<>) is private;
-
- function No_Element (Container : aliased in List) return Cursor;
-
- function Has_Element (Position : in Cursor) return Boolean;
-
- function First (Container : aliased in List) return Cursor;
- function Last (Container : aliased in List) return Cursor;
-
- function Find (Container : aliased in List; Element : in Element_Type)
return Cursor;
- -- No_Element if Element not found.
-
- procedure Next (Position : in out Cursor)
- with Pre => Has_Element (Position);
-
- function Next (Position : in Cursor) return Cursor
- with Pre => Has_Element (Position);
- function Previous (Position : in Cursor) return Cursor
- with Pre => Has_Element (Position);
-
- function Element (Position : in Cursor) return Element_Type
- with Pre => Has_Element (Position);
-
- procedure Delete (Container : in out List; Position : in out Cursor)
- with Pre => Has_Element (Position);
-
- function Pop (Container : in out List) return Element_Type
- with Pre => Container.Length > 0;
- -- Return Container.First, delete it from Container.
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Constant_Reference (Container : in List; Position : in Cursor)
return Constant_Reference_Type with
- Inline, Pre => Has_Element (Position);
-
- function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
with
- Inline, Pre => Has_Element (Position);
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
private with
- Implicit_Dereference => Element;
-
- function Variable_Reference (Container : in List; Position : in Cursor)
return Variable_Reference_Type
- with Inline, Pre => Has_Element (Position);
-
- function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
- with Inline, Pre => Has_Element (Position);
- -- User must not change the element in a way that affects the sort order.
-
- package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
-
- function Iterate (Container : aliased in List) return
Iterator_Interfaces.Reversible_Iterator'Class;
-
-private
- type Node_Type;
-
- type Node_Access is access Node_Type;
-
- type Node_Type is record
- Element : aliased Element_Type;
- Prev : Node_Access;
- Next : Node_Access;
- end record;
-
- procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-
- type List is new Ada.Finalization.Controlled with record
- Head : Node_Access := null;
- Tail : Node_Access := null;
- Count : Ada.Containers.Count_Type := 0;
- end record;
-
- type Cursor (Container : not null access constant List) is
- record
- Ptr : Node_Access;
- end record;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- Empty_List : constant List := (Ada.Finalization.Controlled with null, null,
0);
-
- function No_Element (Container : aliased in List) return Cursor
- is (Container'Access, null);
-
- type Iterator (Container : not null access constant List) is new
Iterator_Interfaces.Reversible_Iterator with
- null record;
-
- overriding function First (Object : Iterator) return Cursor;
- overriding function Last (Object : Iterator) return Cursor;
-
- overriding function Next
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
- overriding function Previous
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
-end SAL.Gen_Definite_Doubly_Linked_Lists_Sorted;
diff --git a/packages/wisi/sal-gen_graphs.adb b/packages/wisi/sal-gen_graphs.adb
deleted file mode 100644
index ef0fcc3..0000000
--- a/packages/wisi/sal-gen_graphs.adb
+++ /dev/null
@@ -1,719 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017, 2019 Free Software Foundation All Rights Reserved.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded;
-with Ada.Text_IO;
-with SAL.Gen_Bounded_Definite_Queues;
-with SAL.Gen_Unbounded_Definite_Stacks;
-package body SAL.Gen_Graphs is
-
- package Vertex_Queues is new SAL.Gen_Bounded_Definite_Queues (Vertex_Index);
- package Vertex_Stacks is new SAL.Gen_Unbounded_Definite_Stacks
(Vertex_Index);
-
- function Find (Data : in Edge_Data; List : in Edge_Node_Lists.List) return
Edge_Node_Lists.Cursor
- is begin
- for I in List.Iterate loop
- if Edge_Node_Lists.Element (I).Data = Data then
- return I;
- end if;
- end loop;
- return Edge_Node_Lists.No_Element;
- end Find;
-
- ----------
- -- Visible subprograms
-
- procedure Add_Edge
- (Graph : in out Gen_Graphs.Graph;
- Vertex_A : in Vertex_Index;
- Vertex_B : in Vertex_Index;
- Data : in Edge_Data)
- is
- Multigraph : Boolean := False;
-
- procedure Update_First_Last (Vertex : in Vertex_Index)
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Graph.Vertices.Length = 0 then
- Graph.Vertices.Set_First_Last (Vertex, Vertex);
- else
- if Vertex < Graph.Vertices.First_Index then
- Graph.Vertices.Set_First_Last (Vertex,
Graph.Vertices.Last_Index);
- elsif Vertex > Graph.Vertices.Last_Index then
- Graph.Vertices.Set_First_Last (Graph.Vertices.First_Index,
Vertex);
- end if;
- end if;
- end Update_First_Last;
-
- begin
- Update_First_Last (Vertex_A);
- Update_First_Last (Vertex_B);
-
- Graph.Last_Edge_ID := Graph.Last_Edge_ID + 1;
- if (for some E of Graph.Vertices (Vertex_A) => E.Vertex_B = Vertex_B)
then
- Multigraph := True;
- Graph.Multigraph := True;
- end if;
-
- Graph.Vertices (Vertex_A).Append ((Graph.Last_Edge_ID, Vertex_B,
Multigraph, Data));
- end Add_Edge;
-
- function Count_Nodes (Graph : in Gen_Graphs.Graph) return
Ada.Containers.Count_Type
- is begin
- return Graph.Vertices.Length;
- end Count_Nodes;
-
- function Count_Edges (Graph : in Gen_Graphs.Graph) return
Ada.Containers.Count_Type
- is
- use Ada.Containers;
- Result : Count_Type := 0;
- begin
- for Edges of Graph.Vertices loop
- Result := Result + Edges.Length;
- end loop;
- return Result;
- end Count_Edges;
-
- function Multigraph (Graph : in Gen_Graphs.Graph) return Boolean
- is begin
- return Graph.Multigraph;
- end Multigraph;
-
- function "+" (Right : in Edge_Item) return Edge_Lists.List
- is
- use Edge_Lists;
- begin
- return Result : List do
- Append (Result, Right);
- end return;
- end "+";
-
- function Edges (Graph : in Gen_Graphs.Graph; Vertex : in Vertex_Index)
return Edge_Lists.List
- is begin
- return Result : Edge_Lists.List do
- for E of Graph.Vertices (Vertex) loop
- Result.Append ((E.ID, E.Data));
- end loop;
- end return;
- end Edges;
-
- function Image (Item : in Path) return String
- is
- use Ada.Strings.Unbounded;
-
- Result : Unbounded_String := To_Unbounded_String ("(");
- begin
- for I in Item'Range loop
- Result := Result & Trimmed_Image (Item (I).Vertex) & " " &
- Image ((if I = Item'Last then Item (Item'First).Edges else Item (I
+ 1).Edges)) & " -> ";
- end loop;
- Result := Result & ")";
- return To_String (Result);
- end Image;
-
- function "<" (Left, Right : in Path) return Boolean
- is begin
- for I in Left'Range loop
- if I > Right'Last then
- return False;
- elsif Left (I).Vertex < Right (I).Vertex then
- return True;
- elsif Left (I).Vertex > Right (I).Vertex then
- return False;
- else
- -- =; check remaining elements
- null;
- end if;
- end loop;
-
- if Left'Last < Right'Last then
- return True;
- else
- -- All =
- return False;
- end if;
- end "<";
-
- function Find_Paths
- (Graph : in out Gen_Graphs.Graph;
- From : in Vertex_Index;
- To : in Edge_Data)
- return Path_Arrays.Vector
- is
- use Vertex_Queues;
-
- Vertex_Queue : Queue_Type
- (Size => Peek_Type (Graph.Vertices.Last_Index -
Graph.Vertices.First_Index + 1));
-
- type Colors is (White, Gray, Black);
-
- type Aux_Node is record
- Color : Colors := Colors'First;
- D : Natural := Natural'Last;
- Parent : Vertex_Index'Base := Invalid_Vertex;
- Parent_Set : Boolean := False;
- Parent_Edge : Edge_Node_Lists.Cursor := Edge_Node_Lists.No_Element;
- end record;
-
- package Aux_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
(Vertex_Index, Aux_Node, (others => <>));
- Aux : Aux_Arrays.Vector;
-
- function Build_Path
- (Tail_Vertex : in Vertex_Index;
- Tail_Edge : in Edge_Node_Lists.Cursor)
- return Path
- is
- begin
- return Result : Path (1 .. Aux (Tail_Vertex).D + 1)
- do
- declare
- use Edge_Node_Lists;
- V_Index : Vertex_Index := Tail_Vertex;
- Last_Edge : Cursor := Tail_Edge;
- begin
- for I in reverse 1 .. Result'Length loop
- declare
- V : Aux_Node renames Aux (V_Index);
- begin
- if Last_Edge = No_Element then
- Result (I) := (V_Index, Edge_Lists.Empty_List);
- else
- Result (I) := (V_Index, +(Element (Last_Edge).ID,
Element (Last_Edge).Data));
- end if;
-
- if V.Parent_Set then
- Last_Edge := V.Parent_Edge;
- V_Index := V.Parent;
- end if;
- end;
- end loop;
- end;
- end return;
- end Build_Path;
-
- Result_List : Path_Arrays.Vector;
- Result_Edge : Edge_Node_Lists.Cursor;
- begin
- -- [1] figure 22.3 breadth-first search; 'From' = s.
-
- Aux.Set_First_Last (Graph.Vertices.First_Index,
Graph.Vertices.Last_Index);
-
- for I in Aux.First_Index .. Aux.Last_Index loop
- if I = From then
- Aux (I).Color := Gray;
- Aux (I).D := 0;
- Aux (I).Parent_Set := False;
-
- else
- Aux (I).Color := White;
- Aux (I).D := Natural'Last;
- Aux (I).Parent_Set := False;
- end if;
- end loop;
-
- Put (Vertex_Queue, From);
-
- while not Is_Empty (Vertex_Queue) loop
- declare
- U_Index : constant Vertex_Index := Get (Vertex_Queue);
- U : Aux_Node renames Aux (U_Index);
- begin
- Edges :
- for C in Graph.Vertices (U_Index).Iterate loop
- declare
- use all type Edge_Node_Lists.Cursor;
- V_Index : constant Vertex_Index := Edge_Node_Lists.Element
(C).Vertex_B;
- V : Aux_Node renames Aux (V_Index);
- begin
- if V.Color = White then
- V.Color := Gray;
- V.D := U.D + 1;
- V.Parent := U_Index;
- V.Parent_Edge := C;
- V.Parent_Set := True;
-
- Result_Edge := Find (To, Graph.Vertices (V_Index));
- if Result_Edge /= Edge_Node_Lists.No_Element then
- Result_List.Append (Build_Path (V_Index, Result_Edge));
- end if;
-
- Put (Vertex_Queue, V_Index);
- end if;
- end;
- end loop Edges;
- U.Color := Black;
- end;
- end loop;
- return Result_List;
- end Find_Paths;
-
- function Find_Cycles_Tiernan (Graph : in Gen_Graphs.Graph)
- return Path_Arrays.Vector
- is
- -- Implements [2] "Algorithm EC"
- --
- -- vertex 0 = Invalid_Vertex
- -- vertex 1 = Graph.Vertices.First_Index
- -- vertex N = Graph.Vertices.Last_Index
-
- First : Vertex_Index renames Graph.Vertices.First_Index;
- Last : Vertex_Index renames Graph.Vertices.Last_Index;
-
- G : Vertex_Arrays.Vector renames Graph.Vertices;
- P : Path (1 .. Integer (Last - First + 1));
- K : Positive := 1; -- ie P_Last
-
- type H_Row is array (G.First_Index .. G.Last_Index) of Vertex_Index'Base;
- H : array (G.First_Index .. G.Last_Index) of H_Row := (others => (others
=> Invalid_Vertex));
-
- Next_Vertex_Found : Boolean;
-
- Result : Path_Arrays.Vector;
-
- function Contains (P : in Path; V : in Vertex_Index) return Boolean
- is (for some N of P => N.Vertex = V);
-
- function Contains (Row : in H_Row; V : in Vertex_Index) return Boolean
- is (for some N of Row => N = V);
-
- function Contains (Edges : in Edge_Lists.List; ID : in Edge_ID) return
Boolean
- is (for some E of Edges => E.ID = ID);
-
- procedure Add_Alternate_Edges (P : in out Path)
- is
- function Dec (I : in Positive) return Positive
- is (if I = P'First then P'Last else I - 1);
- begin
- for I in P'Range loop
- for New_Edge of G (P (Dec (I)).Vertex) loop
- if New_Edge.Vertex_B = P (I).Vertex and (not Contains (P
(I).Edges, New_Edge.ID)) then
- P (I).Edges.Append ((New_Edge.ID, New_Edge.Data));
- end if;
- end loop;
- end loop;
- end Add_Alternate_Edges;
-
- begin
- P (1) := (First, Edge_Lists.Empty_List);
-
- All_Initial_Vertices :
- loop
- Explore_Vertex :
- loop
- Path_Extension :
- loop -- EC2 Path Extension
- Next_Vertex_Found := False;
-
- Find_Next_Vertex :
- for Edge of G (P (K).Vertex) loop
- declare
- Next_Vertex : constant Vertex_Index := Edge.Vertex_B; --
ie G[P[k],j]
- begin
- if Next_Vertex > P (1).Vertex and -- (1)
- (not Contains (P, Next_Vertex)) and -- (2)
- (not Contains (H (P (K).Vertex), Next_Vertex))
- then
- K := K + 1;
- P (K) := (Next_Vertex, +(Edge.ID, Edge.Data));
-
- Next_Vertex_Found := True;
- exit Find_Next_Vertex;
- end if;
- end;
- end loop Find_Next_Vertex;
-
- exit Path_Extension when not Next_Vertex_Found;
- end loop Path_Extension;
-
- -- EC3 Circuit Confirmation
- for Edge of G (P (K).Vertex) loop
- if Edge.Vertex_B = P (1).Vertex then
- P (1).Edges := +(Edge.ID, Edge.Data);
- if Graph.Multigraph then
- Add_Alternate_Edges (P (1 .. K));
- end if;
- Result.Append (P (1 .. K));
- exit;
- end if;
- end loop;
-
- -- EC4 Vertex Closure
- exit Explore_Vertex when K = 1;
-
- H (P (K).Vertex) := (others => Invalid_Vertex);
- for M in H (P (K - 1).Vertex)'Range loop
- if H (P (K - 1).Vertex)(M) = Invalid_Vertex then
- H (P (K - 1).Vertex)(M) := P (K).Vertex;
- P (K) := (Invalid_Vertex, Edge_Lists.Empty_List);
- exit;
- end if;
- end loop;
- K := K - 1;
- end loop Explore_Vertex;
-
- -- EC5 Advance Initial Index
- exit All_Initial_Vertices when P (1).Vertex =
Graph.Vertices.Last_Index;
-
- P (1) := (P (1).Vertex + 1, Edge_Lists.Empty_List);
- pragma Assert (K = 1);
- H := (others => (others => Invalid_Vertex));
- end loop All_Initial_Vertices;
-
- -- EC6 Terminate
- return Result;
- end Find_Cycles_Tiernan;
-
- function Find_Cycles (Graph : in Gen_Graphs.Graph) return Path_Arrays.Vector
- is
- -- Implements Circuit-Finding Algorithm from [3]
-
- use all type Ada.Containers.Count_Type;
-
- pragma Warnings (Off, """Edited_Graph"" is not modified, could be
declared constant");
- Edited_Graph : Gen_Graphs.Graph := Graph;
-
- Result : Path_Arrays.Vector;
-
- A_K : Adjacency_Structures.Vector;
- B : Adjacency_Structures.Vector;
- Blocked : array (Graph.Vertices.First_Index ..
Graph.Vertices.Last_Index) of Boolean := (others => False);
-
- Stack : Vertex_Stacks.Stack;
- S : Vertex_Index := Graph.Vertices.First_Index;
-
- Dummy : Boolean;
- pragma Unreferenced (Dummy);
-
- function Circuit (V : in Vertex_Index) return Boolean
- is
- F : Boolean := False;
-
- procedure Unblock (U : in Vertex_Index)
- is begin
- Blocked (U) := False;
- declare
- use Vertex_Lists;
- Cur : Cursor := B (U).First;
- Temp : Cursor;
- W : Vertex_Index;
- begin
- loop
- exit when not Has_Element (Cur);
- W := Element (Cur);
- Temp := Cur;
- Next (Cur);
- B (U).Delete (Temp);
- if Blocked (W) then
- Unblock (W);
- end if;
- end loop;
- end;
- end Unblock;
-
- procedure Add_Result
- is
- Cycle : Path (1 .. Integer (Stack.Depth));
- begin
- for I in 1 .. Stack.Depth loop
- Cycle (Integer (Stack.Depth - I + 1)) := (Stack.Peek (I),
Edge_Lists.Empty_List);
- -- We add the edge info later, after finding all the cycles.
- end loop;
- Result.Append (Cycle);
- if Trace > 0 then
- Ada.Text_IO.Put_Line ("cycle " & Image (Cycle));
- end if;
- end Add_Result;
-
- begin
- if Trace > 0 then
- Ada.Text_IO.Put_Line ("circuit start" & V'Image);
- end if;
-
- Stack.Push (V);
- Blocked (V) := True;
- if V in A_K.First_Index .. A_K.Last_Index then
- for W of A_K (V) loop
- if W = S then
- Add_Result;
- F := True;
- elsif not Blocked (W) then
- if Circuit (W) then
- F := True;
- end if;
- end if;
- end loop;
- end if;
- if F then
- Unblock (V);
- else
- if V in A_K.First_Index .. A_K.Last_Index then
- for W of A_K (V) loop
- if (for all V1 of B (W) => V /= V1) then
- B (W).Append (V);
- end if;
- end loop;
- end if;
- end if;
- Stack.Pop;
- if Trace > 0 then
- Ada.Text_IO.Put_Line ("circuit finish" & V'Image);
- end if;
- return F;
- end Circuit;
-
- begin
- -- [3] restricts the graph to not have loops (edge v-v) or multiple
- -- edges between two nodes. So we first delete any such edges.
- Delete_Loops_Multigraph :
- for V in Edited_Graph.Vertices.First_Index ..
Edited_Graph.Vertices.Last_Index loop
- declare
- use Edge_Node_Lists;
- Cur : Cursor := Edited_Graph.Vertices (V).First;
- Temp : Cursor;
- Found_Loop : Boolean := False;
- begin
- loop
- exit when not Has_Element (Cur);
- if Element (Cur).Vertex_B = V then
- if not Found_Loop then
- -- This is a cycle we want in the result. Edge data is
added to all
- -- cycles later.
- Result.Append (Path'(1 => (V, Edge_Lists.Empty_List)));
- Found_Loop := True;
- end if;
- Temp := Cur;
- Next (Cur);
- Edited_Graph.Vertices (V).Delete (Temp);
- elsif Element (Cur).Multigraph then
- -- These will be added back from Graph after we find all
cycles.
- Temp := Cur;
- Next (Cur);
- Edited_Graph.Vertices (V).Delete (Temp);
- else
- Next (Cur);
- end if;
- end loop;
- end;
- end loop Delete_Loops_Multigraph;
-
- B.Set_First_Last (Graph.Vertices.First_Index, Graph.Vertices.Last_Index);
-
- -- Start of body of Circuit-Finding Algorithm from [3]
- loop
- exit when S = Graph.Vertices.Last_Index;
- declare
- use Component_Lists;
- Subgraph : Adjacency_Structures.Vector;
- Components : Component_Lists.List;
- Cur : Component_Lists.Cursor;
- Least_Vertex_Cur : Component_Lists.Cursor;
- Least_Vertex_V : Vertex_Index := Vertex_Index'Last;
-
- function Delete_Edges (Edges : in Edge_Node_Lists.List) return
Vertex_Lists.List
- is begin
- return Result : Vertex_Lists.List do
- for Edge of Edges loop
- if Edge.Vertex_B >= S then
- Result.Append (Edge.Vertex_B);
- end if;
- end loop;
- end return;
- end Delete_Edges;
- begin
- Subgraph.Set_First_Last (S, Edited_Graph.Vertices.Last_Index);
- for V in S .. Edited_Graph.Vertices.Last_Index loop
- Subgraph (V) := Delete_Edges (Edited_Graph.Vertices (V));
- end loop;
-
- Components := Strongly_Connected_Components (Subgraph,
Non_Trivial_Only => True);
- Cur := Components.First;
- loop
- exit when not Has_Element (Cur);
-
- if Element (Cur).Length > 1 then
- declare
- Comp : Vertex_Lists.List renames
Components.Constant_Reference (Cur);
- begin
- for W of Comp loop
- if W < Least_Vertex_V then
- Least_Vertex_Cur := Cur;
- Least_Vertex_V := W;
- end if;
- end loop;
- end;
- end if;
- Next (Cur);
- end loop;
-
- A_K.Clear;
- if Has_Element (Least_Vertex_Cur) then
- declare
- Component : Vertex_Lists.List renames Components
(Least_Vertex_Cur);
- Min : Vertex_Index := Vertex_Index'Last;
- Max : Vertex_Index := Vertex_Index'First;
- begin
- if Trace > 0 then
- Ada.Text_IO.Put_Line ("strong component " &
Least_Vertex_V'Image);
- Ada.Text_IO.Put_Line (Image (Component));
- end if;
- for V of Component loop
- if Min > V then
- Min := V;
- end if;
- if Max < V then
- Max := V;
- end if;
- end loop;
- A_K.Set_First_Last (Min, Max);
- for V of Component loop
- for Edge of Edited_Graph.Vertices (V) loop
- A_K (V).Append (Edge.Vertex_B);
- end loop;
- end loop;
- end;
- end if;
- end;
-
- if A_K.Length > 0 then
- S := A_K.First_Index;
- for I in A_K.First_Index .. A_K.Last_Index loop
- Blocked (I) := False;
- B (I).Clear;
- end loop;
- Dummy := Circuit (S);
- S := S + 1;
- else
- S := Graph.Vertices.Last_Index;
- end if;
- end loop;
-
- -- Add edge data.
- for Cycle of Result loop
- for I in Cycle'First .. Cycle'Last loop
- declare
- Prev_I : constant Positive := (if I = Cycle'First then
Cycle'Last else I - 1);
- begin
- for Edge of Graph.Vertices (Cycle (Prev_I).Vertex) loop
- if Cycle (I).Vertex = Edge.Vertex_B then
- Cycle (I).Edges.Append ((Edge.ID, Edge.Data));
- end if;
- end loop;
- end;
- end loop;
- end loop;
- return Result;
- end Find_Cycles;
-
- function Loops (Graph : in Gen_Graphs.Graph) return Vertex_Lists.List
- is begin
- return Result : Vertex_Lists.List do
- for V in Graph.Vertices.First_Index .. Graph.Vertices.Last_Index loop
- for Edge of Graph.Vertices (V) loop
- if V = Edge.Vertex_B then
- Result.Append (V);
- exit;
- end if;
- end loop;
- end loop;
- end return;
- end Loops;
-
- function To_Adjancency (Graph : in Gen_Graphs.Graph) return
Adjacency_Structures.Vector
- is
- function To_Vertex_List (Edges : in Edge_Node_Lists.List) return
Vertex_Lists.List
- is begin
- return Result : Vertex_Lists.List do
- for Edge of Edges loop
- Result.Append (Edge.Vertex_B);
- end loop;
- end return;
- end To_Vertex_List;
- begin
- return Result : Adjacency_Structures.Vector do
- Result.Set_First_Last (Graph.Vertices.First_Index,
Graph.Vertices.Last_Index);
- for V in Graph.Vertices.First_Index .. Graph.Vertices.Last_Index loop
- Result (V) := To_Vertex_List (Graph.Vertices (V));
- end loop;
- end return;
- end To_Adjancency;
-
- function Strongly_Connected_Components
- (Graph : in Adjacency_Structures.Vector;
- Non_Trivial_Only : in Boolean := False)
- return Component_Lists.List
- is
- -- Implements [4] section 4.
-
- Low_Link : array (Graph.First_Index .. Graph.Last_Index) of
Vertex_Index'Base := (others => Invalid_Vertex);
-
- Number : array (Graph.First_Index .. Graph.Last_Index) of
Vertex_Index'Base := (others => Invalid_Vertex);
- -- Number is the order visited in the depth-first search.
-
- Points : Vertex_Stacks.Stack;
-
- I : Vertex_Index'Base := Graph.First_Index - 1;
-
- Result : Component_Lists.List;
-
- procedure Strong_Connect (V : in Vertex_Index)
- is begin
- I := I + 1;
- Number (V) := I;
- Low_Link (V) := I;
- Points.Push (V);
-
- for W of Graph (V) loop
- if Number (W) = Invalid_Vertex then
- -- (v, w) is a tree arc
- Strong_Connect (W);
- Low_Link (V) := Vertex_Index'Min (Low_Link (V), Low_Link (W));
-
- elsif Number (W) < Number (V) then
- -- (v, w) is a frond or cross-link
- if (for some P of Points => P = W) then
- Low_Link (V) := Vertex_Index'Min (Low_Link (V), Low_Link
(W));
- end if;
- end if;
- end loop;
- if Low_Link (V) = Number (V) then
- -- v is the root of a component
- declare
- use all type Ada.Containers.Count_Type;
- Component : Vertex_Lists.List;
- begin
- while (not Points.Is_Empty) and then Number (Points.Peek) >=
Number (V) loop
- Component.Append (Points.Pop);
- end loop;
- if (not Non_Trivial_Only) or Component.Length > 1 then
- Result.Append (Component);
- end if;
- end;
- end if;
- end Strong_Connect;
- begin
- for W in Graph.First_Index .. Graph.Last_Index loop
- if Number (W) = Invalid_Vertex then
- Strong_Connect (W);
- end if;
- end loop;
- return Result;
- end Strongly_Connected_Components;
-
-end SAL.Gen_Graphs;
diff --git a/packages/wisi/sal-gen_graphs.ads b/packages/wisi/sal-gen_graphs.ads
deleted file mode 100644
index 03cc1c6..0000000
--- a/packages/wisi/sal-gen_graphs.ads
+++ /dev/null
@@ -1,190 +0,0 @@
--- Abstract :
---
--- Type and operations for graphs.
---
--- References:
---
--- [1] Introduction to Algorithms, Thomas H. Cormen, Charles E.
--- Leiserson, Ronald L. Rivest, Clifford Stein.
---
--- [2] "An Efficient Search Algorithm to Find the Elementary Circuits
--- of a Graph", James C. Tiernan, Communications of the ACM Volume 13
--- Number 12 December 1970.
---
https://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.516.9454&rep=rep1&type=pdf
---
--- [3] "Finding all the Elementary Circuits of a Directed Graph",
--- Donald B. Johnson, SIAM J. Comput. Vol 4, No. 1, March 1975.
--- https://epubs.siam.org/doi/abs/10.1137/0204007
---
--- [4] "Depth-First Search and Linear Graph Algorithms", Robert
--- Tarjan, SIAM J. Comput. Vol. 1, No 2, June 1972.
--- https://epubs.siam.org/doi/abs/10.1137/0201010
---
--- Copyright (C) 2017, 2019, 2020 Free Software Foundation All Rights
Reserved.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers.Doubly_Linked_Lists;
-with Ada.Containers.Indefinite_Vectors;
-with SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image;
-with SAL.Gen_Trimmed_Image;
-with SAL.Gen_Unbounded_Definite_Vectors;
-generic
- type Edge_Data is private;
- Default_Edge_Data : in Edge_Data;
- type Vertex_Index is range <>;
- Invalid_Vertex : in Vertex_Index'Base;
-
- type Path_Index is range <>;
-
- with function Edge_Image (Item : in Edge_Data) return String;
-
-package SAL.Gen_Graphs is
-
- type Graph is tagged private;
-
- procedure Add_Edge
- (Graph : in out Gen_Graphs.Graph;
- Vertex_A : in Vertex_Index;
- Vertex_B : in Vertex_Index;
- Data : in Edge_Data);
- -- Adds a directed edge from Vertex_A to Vertex_B.
-
- function Count_Nodes (Graph : in Gen_Graphs.Graph) return
Ada.Containers.Count_Type;
- function Count_Edges (Graph : in Gen_Graphs.Graph) return
Ada.Containers.Count_Type;
-
- function Multigraph (Graph : in Gen_Graphs.Graph) return Boolean;
- -- If more than one edge is added between two vertices, the graph is
- -- a multigraph. The edges are given separate identifiers internally.
-
- Multigraph_Error : exception;
-
- type Base_Edge_ID is range 0 .. Integer'Last;
- subtype Edge_ID is Base_Edge_ID range 1 .. Base_Edge_ID'Last;
- Invalid_Edge_ID : constant Base_Edge_ID := 0;
- -- Edge ids are unique graph-wide, assigned by Add_Edge.
-
- type Edge_Item is record
- ID : Base_Edge_ID := Invalid_Edge_ID;
- Data : Edge_Data := Default_Edge_Data;
- end record;
- function Image (Item : in Edge_Item) return String
- is (Edge_Image (Item.Data));
-
- package Edge_Lists is new Ada.Containers.Doubly_Linked_Lists (Edge_Item);
-
- function "+" (Right : in Edge_Item) return Edge_Lists.List;
-
- function Edges (Graph : in Gen_Graphs.Graph; Vertex : in Vertex_Index)
return Edge_Lists.List;
- -- All edges from Vertex, as set by Add_Edge.
-
- function Image is new SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
- (Element_Type => Edge_Item,
- Lists => Edge_Lists,
- Element_Image => Image);
-
- type Path_Item is record
- Vertex : Vertex_Index'Base := Invalid_Vertex;
- Edges : Edge_Lists.List;
- -- Edges describe the edges leading from the previous vertex
- -- in the path to Vertex. If this is the first vertex in an open
- -- path, Edges is empty. If it is the first vertex in a
- -- cycle, the edge are from the last vertex in the cycle.
- end record;
-
- type Path is array (Positive range <>) of Path_Item;
-
- function Image (Item : in Path) return String;
- -- For trace, debugging.
-
- package Path_Arrays is new Ada.Containers.Indefinite_Vectors (Path_Index,
Path);
-
- function "<" (Left, Right : in Path) return Boolean;
-
- package Sort_Paths is new Path_Arrays.Generic_Sorting;
-
- function Find_Paths
- (Graph : in out Gen_Graphs.Graph;
- From : in Vertex_Index;
- To : in Edge_Data)
- return Path_Arrays.Vector;
- -- Return all non-cyclic paths starting at From that lead to a To
- -- edge, using algorithm [1]. First entry in each item in result is
- -- From, with first edge. Last entry in result contains edge data for
- -- To.
- --
- -- Raises Multigraph_Error if Graph is a multigraph.
-
- function Find_Cycles_Tiernan (Graph : in Gen_Graphs.Graph) return
Path_Arrays.Vector;
- -- Return all cyclic paths in Graph, using algorithm [2] extended for
- -- multigraphs.
- --
- -- Time complexity is exponential in the number of nodes. Used in
- -- unit tests for Find_Cycles, since [2] is easier to
- -- implement.
-
- function Find_Cycles (Graph : in Gen_Graphs.Graph) return
Path_Arrays.Vector;
- -- Return all cyclic paths in Graph, using algorithm [3] extended for
- -- multigraphs.
- --
- -- Time complexity is linear in the number of nodes and edges.
-
- package Vertex_Lists is new Ada.Containers.Doubly_Linked_Lists
(Vertex_Index);
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Vertex_Index);
- function Image is new SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
- (Vertex_Index, "=", Vertex_Lists, Trimmed_Image);
-
- function Loops (Graph : in Gen_Graphs.Graph) return Vertex_Lists.List;
- -- List of vertices that have an edge to themselves.
-
- package Adjacency_Structures is new SAL.Gen_Unbounded_Definite_Vectors
- (Vertex_Index, Vertex_Lists.List, Vertex_Lists.Empty_List);
- -- Graphs with no Edge_ID or Edge_Data; useful as intermediate results.
-
- function To_Adjancency (Graph : in Gen_Graphs.Graph) return
Adjacency_Structures.Vector;
-
- package Component_Lists is new Ada.Containers.Doubly_Linked_Lists
(Vertex_Lists.List, Vertex_Lists."=");
-
- function Strongly_Connected_Components
- (Graph : in Adjacency_Structures.Vector;
- Non_Trivial_Only : in Boolean := False)
- return Component_Lists.List;
- -- Find strongly connected components of Graph, using algorithm in [4].
- -- If Non_Trivial_Only, don't include single-vertex components.
-
- Trace : Integer := 0;
- -- Some bodies output debug info to Text_IO.Current_Output for
- -- non-zero values of Trace.
-private
-
- type Edge_Node is record
- -- Edge is from vertex contaning this Node to Vertex_B
- ID : Edge_ID;
- Vertex_B : Vertex_Index;
- Multigraph : Boolean; -- Same Vertex_B as another edge in same vertex.
- Data : Edge_Data;
- end record;
-
- package Edge_Node_Lists is new Ada.Containers.Doubly_Linked_Lists
(Edge_Node);
-
- package Vertex_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Vertex_Index, Edge_Node_Lists.List, Edge_Node_Lists.Empty_List);
-
- type Graph is tagged record
- Last_Edge_ID : Base_Edge_ID := Invalid_Edge_ID;
- Multigraph : Boolean := False;
- Vertices : Vertex_Arrays.Vector;
- end record;
-
-end SAL.Gen_Graphs;
diff --git a/packages/wisi/sal-gen_indefinite_doubly_linked_lists.adb
b/packages/wisi/sal-gen_indefinite_doubly_linked_lists.adb
deleted file mode 100644
index 71d3f61..0000000
--- a/packages/wisi/sal-gen_indefinite_doubly_linked_lists.adb
+++ /dev/null
@@ -1,211 +0,0 @@
--- Abstract :
---
--- see spec
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This library is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
--- MA 02111-1307, USA.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Indefinite_Doubly_Linked_Lists is
-
- ---------
- -- Public operations, declaration order.
-
- overriding
- procedure Adjust (Container : in out List)
- is
- Source : Node_Access := Container.Head;
- New_Node : Node_Access;
- begin
- if Source = null then
- return;
- end if;
-
- Container.Tail := null;
-
- loop
- New_Node := new Node_Type'
- (Element => new Element_Type'(Source.Element.all),
- Next => null,
- Prev => Container.Tail);
- if Container.Tail = null then
- Container.Head := New_Node;
- Container.Tail := New_Node;
- else
- Container.Tail.Next := New_Node;
- Container.Tail := New_Node;
- end if;
- Source := Source.Next;
- exit when Source = null;
- end loop;
- end Adjust;
-
- overriding
- procedure Finalize (Container : in out List)
- is
- Next : Node_Access := Container.Head;
- begin
- loop
- exit when Next = null;
- Next := Container.Head.Next;
- Free (Container.Head.Element);
- Free (Container.Head);
- Container.Head := Next;
- end loop;
- Container.Tail := null;
- end Finalize;
-
- function Length (Container : in List) return SAL.Base_Peek_Type
- is begin
- return Container.Count;
- end Length;
-
- procedure Append (Container : in out List; Element : in Element_Type)
- is
- New_Node : constant Node_Access := new Node_Type'
- (Element => new Element_Type'(Element),
- Prev => Container.Tail,
- Next => null);
- begin
- if Container.Tail = null then
- Container.Head := New_Node;
- Container.Tail := New_Node;
- else
- Container.Tail.Next := New_Node;
- Container.Tail := New_Node;
- end if;
- Container.Count := Container.Count + 1;
- end Append;
-
- procedure Prepend (Container : in out List; Element : in Element_Type)
- is
- New_Node : constant Node_Access := new Node_Type'
- (Element => new Element_Type'(Element),
- Prev => null,
- Next => Container.Head);
- begin
- if Container.Tail = null then
- Container.Head := New_Node;
- Container.Tail := New_Node;
- else
- Container.Head.Prev := New_Node;
- Container.Head := New_Node;
- end if;
- Container.Count := Container.Count + 1;
- end Prepend;
-
- function Has_Element (Position : in Cursor) return Boolean
- is begin
- return Position.Ptr /= null;
- end Has_Element;
-
- function First (Container : in List) return Cursor
- is begin
- if Container.Head = null then
- return (Ptr => null);
- else
- return (Ptr => Container.Head);
- end if;
- end First;
-
- procedure Next (Position : in out Cursor)
- is begin
- if Position.Ptr /= null then
- if Position.Ptr.Next = null then
- Position.Ptr := null;
- else
- Position.Ptr := Position.Ptr.Next;
- end if;
- end if;
- end Next;
-
- function Next (Position : in Cursor) return Cursor
- is begin
- if Position.Ptr = null then
- return Position;
- else
- if Position.Ptr.Next = null then
- return (Ptr => null);
- else
- return (Ptr => Position.Ptr.Next);
- end if;
- end if;
- end Next;
-
- function Element (Position : in Cursor) return Element_Type
- is begin
- return Position.Ptr.Element.all;
- end Element;
-
- procedure Delete (Container : in out List; Position : in out Cursor)
- is
- Node : Node_Access renames Position.Ptr;
- begin
- if Node.Next = null then
- Container.Tail := Node.Prev;
- else
- Node.Next.Prev := Node.Prev;
- end if;
- if Node.Prev = null then
- Container.Head := Node.Next;
- else
- Node.Prev.Next := Node.Next;
- end if;
- Free (Node.Element);
- Free (Node);
- Position := (Ptr => null);
- Container.Count := Container.Count - 1;
- end Delete;
-
- function Persistent_Ref (Position : in Cursor) return access Element_Type
- is begin
- return Position.Ptr.Element;
- end Persistent_Ref;
-
- function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
- is begin
- return (Element => Position.Ptr.all.Element, Dummy => 1);
- end Constant_Ref;
-
- function Constant_Reference (Container : in List; Position : in Peek_Type)
return Constant_Reference_Type
- is
- Ptr : Node_Access := Container.Head;
- begin
- for I in 2 .. Position loop
- Ptr := Ptr.Next;
- end loop;
- return (Element => Ptr.all.Element, Dummy => 1);
- end Constant_Reference;
-
- function Variable_Reference (Container : in List; Position : in Peek_Type)
return Variable_Reference_Type
- is
- Ptr : Node_Access := Container.Head;
- begin
- for I in 2 .. Position loop
- Ptr := Ptr.Next;
- end loop;
- return (Element => Ptr.all.Element, Dummy => 1);
- end Variable_Reference;
-
- function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
- is begin
- return (Element => Position.Ptr.all.Element, Dummy => 1);
- end Variable_Ref;
-
-end SAL.Gen_Indefinite_Doubly_Linked_Lists;
diff --git a/packages/wisi/sal-gen_indefinite_doubly_linked_lists.ads
b/packages/wisi/sal-gen_indefinite_doubly_linked_lists.ads
deleted file mode 100644
index b1d1cdb..0000000
--- a/packages/wisi/sal-gen_indefinite_doubly_linked_lists.ads
+++ /dev/null
@@ -1,128 +0,0 @@
--- Abstract :
---
--- A generic doubly linked list with indefinite elements, allowing
--- permanent references to elements.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This library is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
--- MA 02111-1307, USA.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with Ada.Unchecked_Deallocation;
-generic
- type Element_Type (<>) is private;
-package SAL.Gen_Indefinite_Doubly_Linked_Lists is
-
- type List is new Ada.Finalization.Controlled with private with
- Constant_Indexing => Constant_Reference,
- Variable_Indexing => Variable_Reference;
-
- Empty_List : constant List;
-
- overriding procedure Adjust (Container : in out List);
- -- Deep copy.
-
- overriding procedure Finalize (Container : in out List);
- -- Free all items in List.
-
- function Length (Container : in List) return Base_Peek_Type;
-
- procedure Append (Container : in out List; Element : in Element_Type);
-
- procedure Prepend (Container : in out List; Element : in Element_Type);
-
- type Cursor is private;
-
- No_Element : constant Cursor;
-
- function Has_Element (Position : in Cursor) return Boolean;
-
- function First (Container : in List) return Cursor;
-
- procedure Next (Position : in out Cursor);
-
- function Next (Position : in Cursor) return Cursor;
-
- function Element (Position : in Cursor) return Element_Type
- with Pre => Has_Element (Position);
-
- procedure Delete (Container : in out List; Position : in out Cursor)
- with Pre => Has_Element (Position);
-
- function Persistent_Ref (Position : in Cursor) return access Element_Type
- with Pre => Has_Element (Position);
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Constant_Ref (Position : in Cursor) return Constant_Reference_Type
- with Inline, Pre => Has_Element (Position);
-
- function Constant_Reference (Container : in List; Position : in Peek_Type)
return Constant_Reference_Type
- with Inline, Pre => Position <= Container.Length;
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
private with
- Implicit_Dereference => Element;
-
- function Variable_Reference (Container : in List; Position : in Peek_Type)
return Variable_Reference_Type
- with Inline, Pre => Position <= Container.Length;
-
- function Variable_Ref (Position : in Cursor) return Variable_Reference_Type
- with Inline, Pre => Has_Element (Position);
-
-private
- type Node_Type;
- type Node_Access is access Node_Type;
- type Element_Access is access Element_Type;
-
-
- type Node_Type is record
- Element : Element_Access;
- Prev : Node_Access;
- Next : Node_Access;
- end record;
-
- procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
- procedure Free is new Ada.Unchecked_Deallocation (Element_Type,
Element_Access);
-
- type List is new Ada.Finalization.Controlled with record
- Head : Node_Access := null;
- Tail : Node_Access := null;
- Count : SAL.Base_Peek_Type := 0;
- end record;
-
- type Cursor is record
- Ptr : Node_Access;
- end record;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- Empty_List : constant List := (Ada.Finalization.Controlled with null, null,
0);
-
- No_Element : constant Cursor := (Ptr => null);
-
-end SAL.Gen_Indefinite_Doubly_Linked_Lists;
diff --git a/packages/wisi/sal-gen_trimmed_image.adb
b/packages/wisi/sal-gen_trimmed_image.adb
deleted file mode 100644
index 41fb042..0000000
--- a/packages/wisi/sal-gen_trimmed_image.adb
+++ /dev/null
@@ -1,28 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Stephen Leake All Rights Reserved.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings;
-with Ada.Strings.Fixed;
-function SAL.Gen_Trimmed_Image (Item : in Element_Type) return String
-is
- use Ada.Strings;
- use Ada.Strings.Fixed;
-begin
- return Trim (Element_Type'Image (Item), Both);
-end SAL.Gen_Trimmed_Image;
diff --git a/packages/wisi/sal-gen_trimmed_image.ads
b/packages/wisi/sal-gen_trimmed_image.ads
deleted file mode 100644
index 3ff29f9..0000000
--- a/packages/wisi/sal-gen_trimmed_image.ads
+++ /dev/null
@@ -1,23 +0,0 @@
--- Abstract :
---
--- Generic trimmed image.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Element_Type is range <>;
-function SAL.Gen_Trimmed_Image (Item : in Element_Type) return String;
--- Return image of Item with no leading space.
diff --git a/packages/wisi/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
b/packages/wisi/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
deleted file mode 100644
index c88a0cb..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_min_heaps_fibonacci.adb
+++ /dev/null
@@ -1,354 +0,0 @@
--- Abstract:
---
--- See spec.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Unchecked_Deallocation;
-with Long_Float_Elementary_Functions;
-package body SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci is
-
- ----------
- -- local subprogram specs (as needed), alphabetical order
-
- procedure Insert_Into_Root_List (Heap : in out Heap_Type; X : in
Node_Access);
-
- procedure Link (Y, X : in Node_Access);
-
- procedure Remove_From_List (X : in Node_Access);
-
- procedure Swap (A, B : in out Node_Access);
-
- ----------
- -- local subprogram bodies, alphabetical order
-
- procedure Consolidate (Heap : in out Heap_Type)
- is
- -- [1] 19.4 max degree of Fibonacci heap
- Phi : constant := 1.61803398874989484820458683436563811772; --
https://oeis.org/A001622/constant
- Max_Degree : constant Integer := Integer
- (Long_Float_Elementary_Functions.Log (Long_Float (Heap.Count), Base =>
Phi));
-
- -- [1] 19.2 CONSOLIDATE
- A : array (0 .. Max_Degree) of Node_Access := (others => null);
-
- W : Node_Access := Heap.Min;
- Last : Node_Access := Heap.Min;
- X, Y : Node_Access;
- D : Integer;
-
- Min_Key : Key_Type;
- begin
- loop
- X := W;
- W := W.Right;
-
- D := X.Degree;
-
- loop
- exit when A (D) = null;
-
- Y := A (D);
- if Key (Y.Element) < Key (X.Element) then
- Swap (X, Y);
- end if;
- if Y = Last and W /= Last then
- Last := Y.Right;
- end if;
- Link (Y, X);
- A (D) := null;
- D := D + 1;
- exit when D = A'Last;
- end loop;
-
- A (D) := X;
-
- exit when W = Last;
- end loop;
-
- Heap.Min := null;
- for I in A'Range loop
- if A (I) /= null then
- if Heap.Min = null then
- Heap.Min := A (I);
- Heap.Min.Left := Heap.Min;
- Heap.Min.Right := Heap.Min;
- Min_Key := Key (Heap.Min.Element);
- else
- Insert_Into_Root_List (Heap, A (I));
- if Key (A (I).Element) < Min_Key then
- Heap.Min := A (I);
- Min_Key := Key (A (I).Element);
- end if;
- end if;
- end if;
- end loop;
- end Consolidate;
-
- procedure Copy_Node (Old_Obj : in Node_Access; New_Obj : in out Heap_Type)
- is
- Child : Node_Access;
- begin
- if Old_Obj = null then
- return;
- end if;
-
- if Old_Obj.Child /= null then
- Child := Old_Obj.Child;
-
- loop
- Add (New_Obj, Child.Element);
- Child := Child.Right;
- exit when Child = Old_Obj.Child;
- end loop;
- end if;
-
- Add (New_Obj, Old_Obj.Element);
- end Copy_Node;
-
- procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Access);
-
- procedure Free_Node (Item : in out Node_Access)
- is
- Child : Node_Access;
- Temp : Node_Access;
- begin
- if Item = null then
- return;
- end if;
-
- -- Parent has already been free'd
- -- Siblings are freed by caller
-
- -- Free children
- if Item.Child /= null then
- Child := Item.Child;
-
- loop
- Temp := Child;
- Child := Child.Right;
- Free_Node (Temp);
- exit when Child = Item.Child;
- end loop;
- end if;
- Free (Item);
- end Free_Node;
-
- procedure Insert_Into_Root_List (Heap : in out Heap_Type; X : in
Node_Access)
- is begin
- -- match [1] fig 19.3
- X.Right := Heap.Min;
- X.Left := Heap.Min.Left;
- Heap.Min.Left.Right := X;
- Heap.Min.Left := X;
- end Insert_Into_Root_List;
-
- procedure Link (Y, X : in Node_Access)
- is begin
- -- [1] 19.2 FIB-HEAP-LINK
- Remove_From_List (Y);
- Y.Parent := X;
- X.Degree := X.Degree + 1;
- if X.Child = null then
- X.Child := Y;
- Y.Right := Y;
- Y.Left := Y;
- else
- -- Insert Y into X child list
- Y.Right := X.Child;
- Y.Left := X.Child.Left;
- X.Child.Left.Right := Y;
- X.Child.Left := Y;
- end if;
- Y.Mark := False;
- end Link;
-
- procedure Remove_From_List (X : in Node_Access)
- is begin
- X.Left.Right := X.Right;
- X.Right.Left := X.Left;
- end Remove_From_List;
-
- procedure Swap (A, B : in out Node_Access)
- is
- C : constant Node_Access := A;
- begin
- A := B;
- B := C;
- end Swap;
-
- ----------
- -- Visible operations
-
- overriding
- procedure Initialize (Object : in out Heap_Type)
- is begin
- -- Min is null by default.
- Object.Count := 0;
- end Initialize;
-
- overriding
- procedure Finalize (Object : in out Heap_Type)
- is
- Next : Node_Access := Object.Min;
- Temp : Node_Access;
- begin
- if Next = null then
- return;
- end if;
-
- loop
- Temp := Next;
- Next := Next.Right;
- Free_Node (Temp);
- exit when Next = Object.Min;
- end loop;
- Object.Min := null;
- Object.Count := 0;
- end Finalize;
-
- overriding
- procedure Adjust (Object : in out Heap_Type)
- is
- Old_Obj : Node_Access := Object.Min;
- Last : constant Node_Access := Old_Obj;
- begin
- if Old_Obj = null then
- return;
- end if;
-
- Object.Min := null;
- Object.Count := 0;
-
- loop
- Copy_Node (Old_Obj, Object);
- Old_Obj := Old_Obj.Right;
- exit when Old_Obj = Last;
- end loop;
- end Adjust;
-
- procedure Clear (Heap : in out Heap_Type)
- is begin
- Finalize (Heap);
- end Clear;
-
- function Count (Heap : in Heap_Type) return Base_Peek_Type
- is begin
- return Heap.Count;
- end Count;
-
- function Remove (Heap : in out Heap_Type) return Element_Type
- is
- Z : Node_Access := Heap.Min;
- Child, Temp : Node_Access;
- begin
- if Heap.Count = 0 then
- raise Container_Empty;
- end if;
-
- -- [1] 19.2 FIB-HEAP-EXTRACT-MIN
- Child := Z.Child;
- for I in 1 .. Z.Degree loop
- Temp := Child;
- Child := Child.Right;
- Temp.Parent := null;
- Insert_Into_Root_List (Heap, Temp);
- end loop;
-
- Remove_From_List (Z);
-
- if Z.Right = Z then
- Heap.Min := null;
- else
- Heap.Min := Z.Right;
- Consolidate (Heap);
- end if;
- Heap.Count := Heap.Count - 1;
-
- return Result : constant Element_Type := Z.Element do
- Free (Z);
- end return;
- end Remove;
-
- function Min_Key (Heap : in out Heap_Type) return Key_Type
- is begin
- return Key (Heap.Min.Element);
- end Min_Key;
-
- procedure Drop (Heap : in out Heap_Type)
- is
- Junk : Element_Type := Remove (Heap);
- pragma Unreferenced (Junk);
- begin
- null;
- end Drop;
-
- procedure Add (Heap : in out Heap_Type; Item : in Element_Type)
- is
- X : constant Node_Access := new Node'(Item, null, null, null, null, 0,
False);
- begin
- -- [1] 19.2 FIB-HEAP-INSERT
- if Heap.Min = null then
- Heap.Min := X;
- Heap.Min.Left := Heap.Min;
- Heap.Min.Right := Heap.Min;
- else
- Insert_Into_Root_List (Heap, X);
-
- if Key (Item) < Key (Heap.Min.Element) then
- Heap.Min := X;
- end if;
- end if;
- Heap.Count := Heap.Count + 1;
- end Add;
-
- function Peek (Heap : in Heap_Type) return Constant_Reference_Type
- is begin
- return (Element => Heap.Min.all.Element'Access, Dummy => 1);
- end Peek;
-
- procedure Process (Heap : in Heap_Type; Process_Element : access procedure
(Element : in Element_Type))
- is
- type Cursor is record
- -- Every node is in a circular list. List_Origin is the node where we
- -- entered the list, so we know when we are done.
- Node : Node_Access;
- List_Origin : Node_Access;
- end record;
-
- Cur : Cursor := (Heap.Min, Heap.Min);
-
- procedure Process_Node (Cur : in out Cursor)
- is
- Next_Cur : Cursor;
- begin
- loop
- if Cur.Node.Child /= null then
- Next_Cur := (Cur.Node.Child, Cur.Node.Child);
- Process_Node (Next_Cur);
- end if;
- Process_Element (Cur.Node.Element);
- Cur.Node := Cur.Node.Right;
- exit when Cur.Node = Cur.List_Origin;
- end loop;
- end Process_Node;
- begin
- if Cur.Node /= null then
- Process_Node (Cur);
- end if;
- end Process;
-
-end SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci;
diff --git a/packages/wisi/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
b/packages/wisi/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
deleted file mode 100644
index aab9fcf..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_min_heaps_fibonacci.ads
+++ /dev/null
@@ -1,112 +0,0 @@
--- Abstract:
---
--- An unbounded minimum Fibonacci heap of definite non-limited elements.
---
--- References:
---
--- [1] Introduction to Algorithms, Third Edition. Thomas H. Cormen,
--- Charles E. Leiserson, Ronald L. Rivest, Clifford Stein. Chapter 19.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-generic
- type Element_Type is private;
- type Key_Type is private;
- with function Key (Item : in Element_Type) return Key_Type;
- with procedure Set_Key (Item : in out Element_Type; Key : in Key_Type);
- pragma Unreferenced (Set_Key); -- needed for Decrease_Key
- with function "<" (Left, Right : in Key_Type) return Boolean is <>;
-package SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci is
-
- type Heap_Type is new Ada.Finalization.Controlled with private;
-
- Empty_Heap : constant Heap_Type;
-
- overriding
- procedure Initialize (Object : in out Heap_Type);
-
- overriding
- procedure Finalize (Object : in out Heap_Type);
-
- overriding
- procedure Adjust (Object : in out Heap_Type);
-
- procedure Clear (Heap : in out Heap_Type);
- -- Empty Heap.
-
- function Count (Heap : in Heap_Type) return Base_Peek_Type;
- -- Return count of elements in Heap.
-
- function Remove (Heap : in out Heap_Type) return Element_Type;
- -- Remove minimum element in Heap, return it.
-
- function Min_Key (Heap : in out Heap_Type) return Key_Type;
- -- Return a copy of the minimum key value.
-
- function Get (Heap : in out Heap_Type) return Element_Type renames Remove;
-
- procedure Drop (Heap : in out Heap_Type);
- -- Remove minimum element in Heap, discard it.
-
- procedure Add (Heap : in out Heap_Type; Item : in Element_Type);
- -- Add Item to Heap.
-
- procedure Insert (Heap : in out Heap_Type; Item : in Element_Type) renames
Add;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Peek (Heap : in Heap_Type) return Constant_Reference_Type;
- -- Return a constant reference to the min element.
- pragma Inline (Peek);
-
- -- We don't provide a Cursor/Iterator interface; to complex to
- -- implement. So far, we only need a read-only forward iterator,
- -- which Process provides.
-
- procedure Process (Heap : in Heap_Type; Process_Element : access procedure
(Element : in Element_Type));
- -- Call Process_Element with each Element in Heap. Min is first; rest are
in
- -- arbitrary order.
-
-private
-
- type Node;
- type Node_Access is access Node;
-
- type Node is record
- Element : aliased Element_Type;
- Parent : Node_Access;
- Child : Node_Access;
- Left : Node_Access;
- Right : Node_Access;
- Degree : Natural;
- Mark : Boolean;
- end record;
-
- type Heap_Type is new Ada.Finalization.Controlled with record
- Min : Node_Access;
- Count : Base_Peek_Type;
- end record;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- Empty_Heap : constant Heap_Type := (Ada.Finalization.Controlled with Min =>
null, Count => 0);
-
-end SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci;
diff --git a/packages/wisi/sal-gen_unbounded_definite_queues-gen_image_aux.adb
b/packages/wisi/sal-gen_unbounded_definite_queues-gen_image_aux.adb
deleted file mode 100644
index 2a1990b..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_queues-gen_image_aux.adb
+++ /dev/null
@@ -1,35 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded;
-function SAL.Gen_Unbounded_Definite_Queues.Gen_Image_Aux (Item : in Queue; Aux
: in Aux_Data) return String
-is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- Last : constant Base_Peek_Type := Item.Count;
-begin
- for I in 1 .. Last loop
- Result := Result & Element_Image (Item.Peek (I), Aux);
- if I /= Last then
- Result := Result & ", ";
- end if;
- end loop;
- Result := Result & ")";
- return To_String (Result);
-end SAL.Gen_Unbounded_Definite_Queues.Gen_Image_Aux;
diff --git a/packages/wisi/sal-gen_unbounded_definite_queues-gen_image_aux.ads
b/packages/wisi/sal-gen_unbounded_definite_queues-gen_image_aux.ads
deleted file mode 100644
index dafa8d9..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_queues-gen_image_aux.ads
+++ /dev/null
@@ -1,23 +0,0 @@
--- Abstract :
---
--- Image with auxiliary data for instantiations of parent.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Aux_Data (<>) is private;
- with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Unbounded_Definite_Queues.Gen_Image_Aux (Item : in Queue; Aux
: in Aux_Data) return String;
diff --git a/packages/wisi/sal-gen_unbounded_definite_queues.adb
b/packages/wisi/sal-gen_unbounded_definite_queues.adb
deleted file mode 100644
index af53823..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_queues.adb
+++ /dev/null
@@ -1,97 +0,0 @@
--- Abstract:
---
--- See spec.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Unbounded_Definite_Queues is
-
- procedure Clear (Queue : in out Pkg.Queue)
- is begin
- Queue.Data.Clear;
- end Clear;
-
- function Count (Queue : in Pkg.Queue) return Base_Peek_Type
- is begin
- return Base_Peek_Type (Queue.Data.Length);
- end Count;
-
- function Is_Empty (Queue : in Pkg.Queue) return Boolean
- is
- use all type Ada.Containers.Count_Type;
- begin
- return Queue.Data.Length = 0;
- end Is_Empty;
-
- function Remove (Queue : in out Pkg.Queue) return Element_Type
- is
- use Element_Lists;
- begin
- return A : constant Element_Type := Element (Queue.Data.First) do
- Queue.Data.Delete_First;
- end return;
- end Remove;
-
- procedure Drop (Queue : in out Pkg.Queue)
- is begin
- Queue.Data.Delete_First;
- end Drop;
-
- function Peek (Queue : in Pkg.Queue; N : Peek_Type := 1) return
Constant_Reference_Type
- is
- use Ada.Containers;
- use Element_Lists;
- I : Cursor := Queue.Data.First;
- begin
- if Count_Type (N) > Queue.Data.Length then
- raise Parameter_Error;
- end if;
-
- for K in 2 .. N loop
- Next (I);
- end loop;
-
- return (Element => Element_Lists.Constant_Reference (Queue.Data,
I).Element, Dummy => 1);
- end Peek;
-
- function Variable_Peek (Queue : in out Pkg.Queue; N : Peek_Type := 1)
return Variable_Reference_Type
- is
- use Ada.Containers;
- use Element_Lists;
- I : Cursor := Queue.Data.First;
- begin
- if Count_Type (N) > Queue.Data.Length then
- raise Parameter_Error;
- end if;
-
- for K in 2 .. N loop
- Next (I);
- end loop;
-
- return (Element => Element_Lists.Variable_Reference (Queue.Data,
I).Element, Dummy => 1);
- end Variable_Peek;
-
- procedure Add (Queue : in out Pkg.Queue; Item : in Element_Type)
- is begin
- Queue.Data.Append (Item);
- end Add;
-
- procedure Add_To_Head (Queue : in out Pkg.Queue; Item : in Element_Type)
- is begin
- Queue.Data.Prepend (Item);
- end Add_To_Head;
-
-end SAL.Gen_Unbounded_Definite_Queues;
diff --git a/packages/wisi/sal-gen_unbounded_definite_queues.ads
b/packages/wisi/sal-gen_unbounded_definite_queues.ads
deleted file mode 100644
index 237800d..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_queues.ads
+++ /dev/null
@@ -1,110 +0,0 @@
--- Abstract:
---
--- An unbounded queue of definite non-limited elements.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with SAL.Gen_Definite_Doubly_Linked_Lists;
-generic
- type Element_Type is private;
-package SAL.Gen_Unbounded_Definite_Queues is
-
- package Pkg renames SAL.Gen_Unbounded_Definite_Queues;
-
- type Queue is tagged private;
-
- Empty_Queue : constant Queue;
-
- procedure Clear (Queue : in out Pkg.Queue);
- -- Empty Queue.
-
- function Count (Queue : in Pkg.Queue) return Base_Peek_Type;
- -- Return count of items in the Queue
-
- function Length (Queue : in Pkg.Queue) return Base_Peek_Type renames Count;
-
- function Is_Empty (Queue : in Pkg.Queue) return Boolean;
- -- Return true if no items are in Queue.
-
- function Is_Full (Queue : in Pkg.Queue) return Boolean is (False);
- -- Return true if Queue is full.
-
- function Remove (Queue : in out Pkg.Queue) return Element_Type;
- -- Remove head/front item from Queue, return it.
- --
- -- Raise Container_Empty if Is_Empty.
-
- function Get (Queue : in out Pkg.Queue) return Element_Type renames Remove;
-
- procedure Drop (Queue : in out Pkg.Queue);
- -- Remove head/front item from Queue, discard it.
- --
- -- Raise Container_Empty if Is_Empty.
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private
- with
- Implicit_Dereference => Element;
-
- function Peek (Queue : in Pkg.Queue; N : Peek_Type := 1) return
Constant_Reference_Type;
- pragma Inline (Peek);
- -- Return a constant reference to a queue item. N = 1 is the queue
- -- head.
- --
- -- Raise Parameter_Error if N > Count
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
private
- with Implicit_Dereference => Element;
-
- function Variable_Peek (Queue : in out Pkg.Queue; N : Peek_Type := 1)
return Variable_Reference_Type;
- pragma Inline (Variable_Peek);
- -- Return a variable reference to a queue item. N = 1 is the queue
- -- head.
- --
- -- Raises Parameter_Error if N > Count
-
- procedure Add (Queue : in out Pkg.Queue; Item : in Element_Type);
- -- Add Element to the tail/back of Queue.
-
- procedure Put (Queue : in out Pkg.Queue; Item : in Element_Type) renames
Add;
-
- procedure Add_To_Head (Queue : in out Pkg.Queue; Item : in Element_Type);
- -- Add Element to the head/front of Queue.
-
-private
-
- package Element_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists
(Element_Type);
-
- -- We don't provide cursors or write access to queue elements, so we
- -- don't need any tampering checks.
-
- type Queue is tagged record
- Data : Element_Lists.List;
- -- Add at Tail/Back = Last, remove at Head/Front = First.
- end record;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- Empty_Queue : constant Queue := (Data => Element_Lists.Empty_List);
-
-end SAL.Gen_Unbounded_Definite_Queues;
diff --git a/packages/wisi/sal-gen_unbounded_definite_red_black_trees.adb
b/packages/wisi/sal-gen_unbounded_definite_red_black_trees.adb
deleted file mode 100644
index 0cbd6dd..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_red_black_trees.adb
+++ /dev/null
@@ -1,870 +0,0 @@
--- Abstract :
---
--- Generic unbounded red-black tree with definite elements.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Unbounded_Definite_Red_Black_Trees is
-
- -- Local declarations (alphabetical order)
-
- function Count_Tree (Item : in Node_Access; Nil : in Node_Access) return
Ada.Containers.Count_Type
- with Pre => Nil /= null;
-
- procedure Delete_Fixup (T : in out Tree; X : in out Node_Access);
-
- function Find (Root : in Node_Access; Key : in Key_Type; Nil : in
Node_Access) return Node_Access
- with Pre => Nil /= null;
-
- procedure Left_Rotate (Tree : in out Pkg.Tree; X : in Node_Access)
- with Pre => X /= null;
-
- procedure Right_Rotate (Tree : in out Pkg.Tree; X : in Node_Access)
- with Pre => X /= null;
-
- procedure Transplant (T : in out Pkg.Tree; U, V : in Node_Access)
- with Pre => U /= null and T.Root /= null;
-
- ----------
- -- local bodies (alphabetical order)
-
- function Count_Tree (Item : in Node_Access; Nil : in Node_Access) return
Ada.Containers.Count_Type
- is
- use all type Ada.Containers.Count_Type;
- Result : Ada.Containers.Count_Type := 0;
- begin
- if Item.Left /= Nil then
- Result := Result + Count_Tree (Item.Left, Nil);
- end if;
-
- if Item.Right /= Nil then
- Result := Result + Count_Tree (Item.Right, Nil);
- end if;
-
- return Result + 1;
- end Count_Tree;
-
- procedure Delete_Fixup (T : in out Tree; X : in out Node_Access)
- is
- W : Node_Access;
- begin
- -- [1] 13.3 RB-Delete-Fixup
- -- X is either "doubly black" or "red and black"
- -- X.Parent is set, even if X = Nil.
- -- In all cases, Nil.Left = null.Right = null.
-
- while X /= T.Root and X.Color = Black loop
- if X = X.Parent.Left then
- W := X.Parent.Right;
- if W.Color = Red then
- W.Color := Black;
- X.Parent.Color := Red;
- Left_Rotate (T, X.Parent);
- W := X.Parent.Right;
- end if;
-
- if W.Left.Color = Black and W.Right.Color = Black then
- W.Color := Red;
- X := X.Parent;
- else
- if W.Right.Color = Black then
- W.Left.Color := Black;
- W.Color := Red;
- Right_Rotate (T, W);
- W := X.Parent.Right;
- end if;
- W.Color := X.Parent.Color;
- X.Parent.Color := Black;
- W.Right.Color := Black;
- Left_Rotate (T, X.Parent);
- X := T.Root;
- end if;
- else
- W := X.Parent.Left;
- if W.Color = Red then
- W.Color := Black;
- X.Parent.Color := Red;
- Right_Rotate (T, X.Parent);
- W := X.Parent.Left;
- end if;
-
- if W.Right.Color = Black and W.Left.Color = Black then
- W.Color := Red;
- X := X.Parent;
- else
- if W.Left.Color = Black then
- W.Right.Color := Black;
- W.Color := Red;
- Left_Rotate (T, W);
- W := X.Parent.Left;
- end if;
- W.Color := X.Parent.Color;
- X.Parent.Color := Black;
- W.Left.Color := Black;
- Right_Rotate (T, X.Parent);
- X := T.Root;
- end if;
- end if;
- end loop;
- X.Color := Black;
- end Delete_Fixup;
-
- function Find (Root : in Node_Access; Key : in Key_Type; Nil : in
Node_Access) return Node_Access
- is
- Node : Node_Access := Root;
- begin
- while Node /= Nil loop
- case Key_Compare (Key, Pkg.Key (Node.Element)) is
- when Equal =>
- return Node;
- when Less =>
- Node := Node.Left;
- when Greater =>
- Node := Node.Right;
- end case;
- end loop;
- return null;
- end Find;
-
- procedure Free_Tree (Item : in out Node_Access; Nil : in Node_Access)
- is begin
- if Item = Nil or Item = null then
- raise Programmer_Error;
- end if;
-
- if Item.Left /= Nil then
- Free_Tree (Item.Left, Nil);
- end if;
-
- if Item.Right /= Nil then
- Free_Tree (Item.Right, Nil);
- end if;
-
- Free (Item);
- end Free_Tree;
-
- procedure Insert_Fixup (Tree : in out Pkg.Tree; Z : in out Node_Access)
- is
- -- [1] 13.3 RB-Insert-Fixup (T, z)
- Nil : Node_Access renames Tree.Nil;
- Y : Node_Access;
- begin
- while Z.Parent /= Nil and then Z.Parent.Color = Red loop
- if Z.Parent = Z.Parent.Parent.Left then
- Y := Z.Parent.Parent.Right;
- if Y /= Nil and then Y.Color = Red then
- Z.Parent.Color := Black;
- Y.Color := Black;
- Z.Parent.Parent.Color := Red;
- Z := Z.Parent.Parent;
- else
- if Z = Z.Parent.Right then
- Z := Z.Parent;
- Left_Rotate (Tree, Z);
- end if;
- Z.Parent.Color := Black;
- Z.Parent.Parent.Color := Red;
- Right_Rotate (Tree, Z.Parent.Parent);
- end if;
- else
- Y := Z.Parent.Parent.Left;
- if Y /= Nil and then Y.Color = Red then
- Z.Parent.Color := Black;
- Y.Color := Black;
- Z.Parent.Parent.Color := Red;
- Z := Z.Parent.Parent;
- else
- if Z = Z.Parent.Left then
- Z := Z.Parent;
- Right_Rotate (Tree, Z);
- end if;
- Z.Parent.Color := Black;
- Z.Parent.Parent.Color := Red;
- Left_Rotate (Tree, Z.Parent.Parent);
- end if;
- end if;
- end loop;
- Tree.Root.Color := Black;
- end Insert_Fixup;
-
- procedure Left_Rotate (Tree : in out Pkg.Tree; X : in Node_Access)
- is
- -- [1] 13.2 Left-Rotate (T, x)
- Nil : Node_Access renames Tree.Nil;
- Y : constant Node_Access := X.Right;
- begin
- X.Right := Y.Left;
- if Y.Left /= Nil then
- Y.Left.Parent := X;
- end if;
- Y.Parent := X.Parent;
- if X.Parent = Nil then
- Tree.Root := Y;
- elsif X = X.Parent.Left then
- X.Parent.Left := Y;
- else
- X.Parent.Right := Y;
- end if;
- Y.Left := X;
- X.Parent := Y;
- end Left_Rotate;
-
- function Minimum (Node : in Node_Access; Nil : in Node_Access) return
Node_Access
- is begin
- return Result : Node_Access := Node
- do
- while Result.Left /= Nil loop
- Result := Result.Left;
- end loop;
- end return;
- end Minimum;
-
- procedure Right_Rotate (Tree : in out Pkg.Tree; X : in Node_Access)
- is
- -- [1] 13.2 Right-Rotate (T, x)
- Nil : Node_Access renames Tree.Nil;
- Y : constant Node_Access := X.Left;
- begin
- X.Left := Y.Right;
- if Y.Right /= Nil then
- Y.Right.Parent := X;
- end if;
- Y.Parent := X.Parent;
- if X.Parent = Nil then
- Tree.Root := Y;
- elsif X = X.Parent.Right then
- X.Parent.Right := Y;
- else
- X.Parent.Left := Y;
- end if;
- Y.Right := X;
- X.Parent := Y;
- end Right_Rotate;
-
- procedure Transplant (T : in out Pkg.Tree; U, V : in Node_Access)
- is
- Nil : Node_Access renames T.Nil;
- begin
- -- [1] 13.4 RB-Transplant, 12.3 Transplant
-
- if U.Parent = Nil then
- T.Root := V;
- elsif U = U.Parent.Left then
- U.Parent.Left := V;
- else
- U.Parent.Right := V;
- end if;
- V.Parent := U.Parent;
- end Transplant;
-
- ----------
- -- Public subprograms, spec order
-
- overriding procedure Finalize (Object : in out Tree)
- is begin
- if Object.Root /= null then
- if Object.Root = Object.Nil then
- Free (Object.Nil);
- Object.Root := null;
- else
- Free_Tree (Object.Root, Object.Nil);
- Free (Object.Nil);
- end if;
- end if;
- end Finalize;
-
- overriding procedure Initialize (Object : in out Tree)
- is begin
- Object.Nil := new Node;
- Object.Nil.Color := Black;
- Object.Root := Object.Nil;
- end Initialize;
-
- function Has_Element (Cursor : in Pkg.Cursor) return Boolean
- is begin
- return Cursor.Node /= null;
- end Has_Element;
-
- function Constant_Reference
- (Container : aliased in Tree;
- Position : in Cursor)
- return Constant_Reference_Type
- is
- pragma Unreferenced (Container);
- begin
- return (Element => Position.Node.all.Element'Access, Dummy => 1);
- end Constant_Reference;
-
- function Constant_Reference
- (Container : aliased in Tree;
- Key : in Key_Type)
- return Constant_Reference_Type
- is
- Node : constant Node_Access := Find (Container.Root, Key, Container.Nil);
- begin
- if Node = null then
- raise Not_Found;
- else
- -- WORKAROUND: GNAT Community 2019 requires .all here, GNAT Pro 21.0w
- -- 20200426 requires it _not_ be here. The code is technically legal
- -- either way, so both compilers have a bug. Keeping .all for now;
- -- just delete it if you are using 21.0w. Hopefully 21 will fix the
- -- bug. AdaCore ticket T503-001 on Eurocontrol support contract.
- return (Element => Node.all.Element'Access, Dummy => 1);
- end if;
- end Constant_Reference;
-
- function Variable_Reference
- (Container : aliased in Tree;
- Position : in Cursor)
- return Variable_Reference_Type
- is
- pragma Unreferenced (Container);
- begin
- -- WORKAROUND: see note in Constant_Reference
- return (Element => Position.Node.all.Element'Access, Dummy => 1);
- end Variable_Reference;
-
- function Variable_Reference
- (Container : aliased in Tree;
- Key : in Key_Type)
- return Variable_Reference_Type
- is
- Node : constant Node_Access := Find (Container.Root, Key, Container.Nil);
- begin
- if Node = null then
- raise Not_Found;
- else
- -- WORKAROUND: see note in Constant_Reference
- return (Element => Node.all.Element'Access, Dummy => 1);
- end if;
- end Variable_Reference;
-
- function Iterate (Tree : in Pkg.Tree'Class) return Iterator
- is begin
- return (Tree.Root, Tree.Nil);
- end Iterate;
-
- overriding function First (Iterator : in Pkg.Iterator) return Cursor
- is
- Nil : Node_Access renames Iterator.Nil;
- Node : Node_Access := Iterator.Root;
- begin
- if Node = Nil then
- return
- (Node => null,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
- else
- loop
- exit when Node.Left = Nil;
- Node := Node.Left;
- end loop;
-
- return
- (Node => Node,
- Direction => Ascending,
- Left_Done => True,
- Right_Done => False);
- end if;
-
- end First;
-
- overriding function Next (Iterator : in Pkg.Iterator; Position : in Cursor)
return Cursor
- is
- Nil : Node_Access renames Iterator.Nil;
- begin
- if Position.Direction /= Ascending then
- raise Programmer_Error;
- end if;
-
- if Position.Node = null then
- return
- (Node => null,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
-
- elsif Position.Left_Done or Position.Node.Left = Nil then
- if Position.Right_Done or Position.Node.Right = Nil then
- if Position.Node.Parent = Nil then
- return
- (Node => null,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
- else
- declare
- Node : constant Node_Access := Position.Node.Parent;
- Temp : constant Cursor :=
- (Node => Node,
- Direction => Ascending,
- Left_Done => Node.Right = Position.Node or Node.Left =
Position.Node,
- Right_Done => Node.Right = Position.Node);
- begin
- if Temp.Right_Done then
- return Next (Iterator, Temp);
- else
- return Temp;
- end if;
- end;
- end if;
- else
- declare
- Node : constant Node_Access := Position.Node.Right;
- Temp : constant Cursor :=
- (Node => Node,
- Direction => Ascending,
- Left_Done => Node.Left = Nil,
- Right_Done => False);
- begin
- if Temp.Left_Done then
- return Temp;
- else
- return Next (Iterator, Temp);
- end if;
- end;
- end if;
- else
- declare
- Node : constant Node_Access := Position.Node.Left;
- Temp : constant Cursor :=
- (Node => Node,
- Direction => Ascending,
- Left_Done => Node.Left = Nil,
- Right_Done => False);
- begin
- if Temp.Left_Done then
- return Temp;
- else
- return Next (Iterator, Temp);
- end if;
- end;
- end if;
- end Next;
-
- overriding function Last (Iterator : in Pkg.Iterator) return Cursor
- is
- Nil : Node_Access renames Iterator.Nil;
- Node : Node_Access := Iterator.Root;
- begin
- if Node = Nil then
- return
- (Node => null,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
- else
- loop
- exit when Node.Right = Nil;
- Node := Node.Right;
- end loop;
- return
- (Node => Node,
- Direction => Descending,
- Right_Done => True,
- Left_Done => False);
- end if;
- end Last;
-
- overriding function Previous (Iterator : in Pkg.Iterator; Position : in
Cursor) return Cursor
- is
- Nil : Node_Access renames Iterator.Nil;
- begin
- if Position.Direction /= Descending then
- raise Programmer_Error;
- end if;
-
- if Position.Node = null then
- return
- (Node => null,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
-
- elsif Position.Right_Done or Position.Node.Right = Nil then
- if Position.Left_Done or Position.Node.Left = Nil then
- if Position.Node.Parent = Nil then
- return
- (Node => null,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
- else
- declare
- Node : constant Node_Access := Position.Node.Parent;
- Temp : constant Cursor :=
- (Node => Node,
- Direction => Descending,
- Right_Done => Node.Left = Position.Node or Node.Right =
Position.Node,
- Left_Done => Node.Left = Position.Node);
- begin
- if Temp.Left_Done then
- return Previous (Iterator, Temp);
- else
- return Temp;
- end if;
- end;
- end if;
- else
- declare
- Node : constant Node_Access := Position.Node.Left;
- Temp : constant Cursor :=
- (Node => Node,
- Direction => Descending,
- Right_Done => Node.Right = Nil,
- Left_Done => False);
- begin
- if Temp.Right_Done then
- return Temp;
- else
- return Previous (Iterator, Temp);
- end if;
- end;
- end if;
- else
- declare
- Node : constant Node_Access := Position.Node.Right;
- Temp : constant Cursor :=
- (Node => Node,
- Direction => Descending,
- Right_Done => Node.Right = Nil,
- Left_Done => False);
- begin
- if Temp.Right_Done then
- return Temp;
- else
- return Previous (Iterator, Temp);
- end if;
- end;
- end if;
- end Previous;
-
- function Previous (Iterator : in Pkg.Iterator; Key : in Key_Type) return
Cursor
- is
- Nil : Node_Access renames Iterator.Nil;
- Node : Node_Access := Iterator.Root;
- begin
- while Node /= Nil loop
- declare
- Current_Key : Key_Type renames Pkg.Key (Node.Element);
- begin
- case Key_Compare (Key, Current_Key) is
- when Equal =>
- return Previous (Iterator, (Node, Descending, Right_Done =>
True, Left_Done => False));
-
- when Less =>
- if Node.Left = Nil then
- return Previous (Iterator, (Node, Descending, Right_Done =>
True, Left_Done => True));
- else
- Node := Node.Left;
- end if;
-
- when Greater =>
- if Node.Right = Nil then
- return (Node, Descending, Right_Done => True, Left_Done =>
False);
- else
- Node := Node.Right;
- end if;
- end case;
- end;
- end loop;
-
- return
- (Node => null,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
- end Previous;
-
- function Find
- (Iterator : in Pkg.Iterator;
- Key : in Key_Type;
- Direction : in Direction_Type := Ascending)
- return Cursor
- is
- Nil : Node_Access renames Iterator.Nil;
- Node : constant Node_Access := Find (Iterator.Root, Key, Nil);
- begin
- if Node = null then
- return
- (Node => null,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
- else
- return
- (Node => Node,
- Direction => Direction,
- Left_Done =>
- (case Direction is
- when Ascending | Unknown => True,
- when Descending => Node.Left = Nil),
- Right_Done =>
- (case Direction is
- when Ascending => Node.Right = Nil,
- when Descending | Unknown => True));
- end if;
- end Find;
-
- function Find_In_Range
- (Iterator : in Pkg.Iterator;
- Direction : in Known_Direction_Type;
- First, Last : in Key_Type)
- return Cursor
- is
- Nil : Node_Access renames Iterator.Nil;
- Node : Node_Access := Iterator.Root;
- Candidate : Node_Access := null; -- best result found so far
- begin
- while Node /= Nil loop
- declare
- Current_Key : Key_Type renames Key (Node.Element);
- begin
- case Direction is
- when Ascending =>
- case Key_Compare (First, Current_Key) is
- when Equal =>
- return (Node, Ascending, Right_Done => False, Left_Done
=> True);
-
- when Less =>
- if Node.Left = Nil then
- case Key_Compare (Current_Key, Last) is
- when Less | Equal =>
- return (Node, Ascending, Right_Done => False,
Left_Done => True);
- when Greater =>
- if Candidate = null then
- return No_Element;
- else
- return (Candidate, Ascending, Right_Done => False,
Left_Done => True);
- end if;
- end case;
- else
- case Key_Compare (Last, Current_Key) is
- when Greater | Equal =>
- Candidate := Node;
- when Less =>
- null;
- end case;
- Node := Node.Left;
- end if;
-
- when Greater =>
- if Node.Right = Nil then
- if Candidate = null then
- return No_Element;
- else
- return (Candidate, Ascending, Right_Done => False,
Left_Done => True);
- end if;
- else
- Node := Node.Right;
- end if;
- end case;
-
- when Descending =>
- if Last = Current_Key then
- return (Node, Descending, Right_Done => True, Left_Done =>
False);
-
- else
- case Key_Compare (Last, Current_Key) is
- when Greater =>
- if Node.Right = Nil then
- case Key_Compare (Current_Key, First) is
- when Greater | Equal =>
- return (Node, Descending, Right_Done => True,
Left_Done => False);
- when Less =>
- if Candidate = null then
- return No_Element;
- else
- return (Candidate, Ascending, Right_Done =>
False, Left_Done => True);
- end if;
- end case;
- else
- case Key_Compare (First, Current_Key) is
- when Less | Equal =>
- Candidate := Node;
- when Greater =>
- null;
- end case;
- Node := Node.Right;
- end if;
- when Equal | Less =>
- if Node.Left = Nil then
- if Candidate = null then
- return No_Element;
- else
- return (Candidate, Ascending, Right_Done => False,
Left_Done => True);
- end if;
- else
- Node := Node.Left;
- end if;
- end case;
- end if;
- end case;
- end;
- end loop;
-
- return No_Element;
- end Find_In_Range;
-
- function Count (Tree : in Pkg.Tree) return Ada.Containers.Count_Type
- is begin
- if Tree.Root = Tree.Nil then
- return 0;
- else
- return Count_Tree (Tree.Root, Tree.Nil);
- end if;
- end Count;
-
- function Present (Container : in Tree; Key : in Key_Type) return Boolean
- is
- Nil : Node_Access renames Container.Nil;
- Node : Node_Access := Container.Root;
- begin
- while Node /= Nil loop
- case Key_Compare (Key, Pkg.Key (Node.Element)) is
- when Equal =>
- return True;
- when Less =>
- Node := Node.Left;
- when Greater =>
- Node := Node.Right;
- end case;
- end loop;
- return False;
- end Present;
-
- function Insert (Tree : in out Pkg.Tree; Element : in Element_Type) return
Cursor
- is
- -- [1] 13.3 RB-Insert (T, z)
- Nil : Node_Access renames Tree.Nil;
- Z : Node_Access := new Node'(Element, Nil, Nil, Nil, Red);
- Key_Z : constant Key_Type := Key (Z.Element);
- Y : Node_Access := Nil;
- X : Node_Access := Tree.Root;
-
- Result : Node_Access;
- Compare_Z_Y : Compare_Result;
- begin
- Nil.Parent := null;
- Nil.Left := null;
- Nil.Right := null;
-
- while X /= Nil loop
- Y := X;
- Compare_Z_Y := Key_Compare (Key_Z, Key (X.Element));
- case Compare_Z_Y is
- when Less =>
- X := X.Left;
- when Equal | Greater =>
- X := X.Right;
- end case;
- end loop;
-
- Z.Parent := Y;
- if Y = Nil then
- Tree.Root := Z;
- else
- case Compare_Z_Y is
- when Less =>
- Y.Left := Z;
- when Equal | Greater =>
- Y.Right := Z;
- end case;
- end if;
-
- Result := Z;
- if Z = Tree.Root then
- Z.Color := Black;
- else
- Insert_Fixup (Tree, Z);
- end if;
-
- return
- (Node => Result,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
- end Insert;
-
- procedure Insert (Tree : in out Pkg.Tree; Element : in Element_Type)
- is
- Temp : Cursor := Insert (Tree, Element);
- pragma Unreferenced (Temp);
- begin
- null;
- end Insert;
-
- procedure Delete (Tree : in out Pkg.Tree; Position : in out Cursor)
- is
- Nil : Node_Access renames Tree.Nil;
- T : Pkg.Tree renames Tree;
- Z : constant Node_Access :=
- (if Position.Node = null then raise Parameter_Error else
Position.Node);
- Y : Node_Access := Z;
- Y_Orig_Color : Color := Y.Color;
- X : Node_Access;
- begin
- -- Catch logic errors in use of Nil
- Nil.Parent := null;
- Nil.Left := null;
- Nil.Right := null;
-
- -- [1] 13.4 RB-Delete.
- if Z.Left = Nil then
- X := Z.Right;
- Transplant (T, Z, Z.Right);
-
- elsif Z.Right = Nil then
- X := Z.Left;
- Transplant (T, Z, Z.Left);
-
- else
- Y := Minimum (Z.Right, Nil);
- Y_Orig_Color := Y.Color;
- X := Y.Right;
- if Y.Parent = Z then
- X.Parent := Y;
- -- This is already true unless X = Nil, in which case delete_fixup
- -- needs the info.
- else
- Transplant (T, Y, Y.Right);
- Y.Right := Z.Right;
-
- Y.Right.Parent := Y;
- -- This is already true unless Y.Right = Nil, in which case
- -- delete_fixup needs the info.
- end if;
-
- Transplant (T, Z, Y);
- Y.Left := Z.Left;
-
- Y.Left.Parent := Y;
- -- This is already true unless Y.Left = Nil, in which case
- -- delete_fixup needs the info.
-
- Y.Color := Z.Color;
- end if;
-
- if Y_Orig_Color = Black then
- Delete_Fixup (T, X);
- end if;
-
- Free (Position.Node);
- end Delete;
-
-end SAL.Gen_Unbounded_Definite_Red_Black_Trees;
diff --git a/packages/wisi/sal-gen_unbounded_definite_red_black_trees.ads
b/packages/wisi/sal-gen_unbounded_definite_red_black_trees.ads
deleted file mode 100644
index f886ed9..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_red_black_trees.ads
+++ /dev/null
@@ -1,198 +0,0 @@
--- Abstract :
---
--- Generic unbounded red-black tree with definite elements, definite
--- or indefinite key.
---
--- References :
---
--- [1] Introduction to Algorithms, Thomas H. Cormen, Charles E.
--- Leiserson, Ronald L. Rivest, Clifford Stein.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with Ada.Iterator_Interfaces;
-with Ada.Unchecked_Deallocation;
-generic
- type Element_Type is private;
- type Key_Type (<>) is private;
- with function Key (Element : in Element_Type) return Key_Type is <>;
- with function Key_Compare (Left, Right : in Key_Type) return Compare_Result
is <>;
-package SAL.Gen_Unbounded_Definite_Red_Black_Trees is
-
- package Pkg renames Gen_Unbounded_Definite_Red_Black_Trees;
-
- type Tree is new Ada.Finalization.Limited_Controlled with private
- with
- Constant_Indexing => Constant_Reference,
- Variable_Indexing => Variable_Reference,
- Default_Iterator => Iterate,
- Iterator_Element => Element_Type;
-
- overriding procedure Finalize (Object : in out Tree);
- overriding procedure Initialize (Object : in out Tree);
-
- type Direction_Type is (Ascending, Descending, Unknown);
- subtype Known_Direction_Type is Direction_Type range Ascending ..
Descending;
- -- Direction of Iterators.
- -- If Ascending, Next may be called.
- -- If Descending, Previous may be called.
- -- If Unknown, neither.
-
- type Cursor is private;
-
- No_Element : constant Cursor;
-
- function Has_Element (Cursor : in Pkg.Cursor) return Boolean;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Constant_Reference
- (Container : aliased in Tree;
- Position : in Cursor)
- return Constant_Reference_Type with
- Inline, Pre => Has_Element (Position);
-
- function Constant_Reference
- (Container : aliased in Tree;
- Key : in Key_Type)
- return Constant_Reference_Type with
- Inline;
- -- Raises Not_Found if Key not found in Container.
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
private with
- Implicit_Dereference => Element;
-
- function Variable_Reference
- (Container : aliased in Tree;
- Position : in Cursor)
- return Variable_Reference_Type with
- Inline, Pre => Has_Element (Position);
-
- function Variable_Reference
- (Container : aliased in Tree;
- Key : in Key_Type)
- return Variable_Reference_Type with
- Inline;
- -- Raises Not_Found if Key not found in Container.
-
- package Iterators is new Ada.Iterator_Interfaces (Cursor, Has_Element);
-
- type Iterator is new Iterators.Reversible_Iterator with private;
-
- function Iterate (Tree : in Pkg.Tree'Class) return Iterator;
-
- overriding function First (Iterator : in Pkg.Iterator) return Cursor;
- overriding function Next (Iterator : in Pkg.Iterator; Position : in Cursor)
return Cursor;
- overriding function Last (Iterator : in Pkg.Iterator) return Cursor;
- overriding function Previous (Iterator : in Pkg.Iterator; Position : in
Cursor) return Cursor;
-
- function Previous (Iterator : in Pkg.Iterator; Key : in Key_Type) return
Cursor;
- -- Initialise Iterator to descending, starting at element with
- -- largest key < Key. Has_Element (result) is False if there is no
- -- such element.
-
- function Find
- (Iterator : in Pkg.Iterator;
- Key : in Key_Type;
- Direction : in Direction_Type := Ascending)
- return Cursor;
- -- Has_Element is False if Key is not in Container.
-
- function Find_In_Range
- (Iterator : in Pkg.Iterator;
- Direction : in Known_Direction_Type;
- First, Last : in Key_Type)
- return Cursor;
- -- Find first element with key in range First .. Last. If Direction
- -- is Ascending, start at First, otherwise start at Last.
- --
- -- Has_Element (result) is False if there is no such element.
- --
- -- The Iterator does not remember First, Last; the user must check
- -- those for any element that Next or Previous returns.
-
- function Count (Tree : in Pkg.Tree) return Ada.Containers.Count_Type;
-
- function Present (Container : in Tree; Key : in Key_Type) return Boolean;
-
- procedure Insert (Tree : in out Pkg.Tree; Element : in Element_Type);
- function Insert (Tree : in out Pkg.Tree; Element : in Element_Type) return
Cursor;
- -- Result points to newly inserted element.
-
- procedure Delete (Tree : in out Pkg.Tree; Position : in out Cursor);
- -- Delete element at Position, set Position to No_Element.
-private
-
- type Node;
- type Node_Access is access Node;
-
- type Color is (Red, Black);
-
- type Node is record
- Element : aliased Element_Type;
- Parent : Node_Access;
- Left : Node_Access;
- Right : Node_Access;
- Color : Pkg.Color;
- end record;
-
- procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Access);
-
- type Tree is new Ada.Finalization.Limited_Controlled with record
- Root : Node_Access;
- Nil : Node_Access;
- -- Nil is the node pointed to by all links that would otherwise be
- -- 'null'. This simplifies several algorithm (for example,
- -- Node.Left.Color is always valid). Its parent, left, right links
- -- are used as temp storage for some algorithms (especially Delete).
- -- Nil.Color is Black.
- end record;
-
- type Cursor is record
- Node : Node_Access := null;
-
- Direction : Direction_Type := Unknown;
- -- Set in First or Last, enforced in next/prev (cannot change
direction).
-
- Left_Done : Boolean := True;
- Right_Done : Boolean := True;
- end record;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- No_Element : constant Cursor :=
- (Node => null,
- Direction => Unknown,
- Left_Done => True,
- Right_Done => True);
-
- type Iterator is new Iterators.Reversible_Iterator with
- record
- Root : Node_Access;
- Nil : Node_Access;
- end record;
-
-end SAL.Gen_Unbounded_Definite_Red_Black_Trees;
diff --git a/packages/wisi/sal-gen_unbounded_definite_stacks-gen_image_aux.adb
b/packages/wisi/sal-gen_unbounded_definite_stacks-gen_image_aux.adb
deleted file mode 100644
index c4b52a6..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_stacks-gen_image_aux.adb
+++ /dev/null
@@ -1,42 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded;
-function SAL.Gen_Unbounded_Definite_Stacks.Gen_Image_Aux
- (Item : in Stack;
- Aux : in Aux_Data;
- Depth : in SAL.Base_Peek_Type := 0)
- return String
-is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- Last : constant Base_Peek_Type :=
- (if Depth = 0
- then Item.Top
- else Base_Peek_Type'Min (Depth, Item.Top));
-begin
- for I in 1 .. Last loop
- Result := Result & Element_Image (Item.Peek (I), Aux);
- if I /= Last then
- Result := Result & ", ";
- end if;
- end loop;
- Result := Result & ")";
- return To_String (Result);
-end SAL.Gen_Unbounded_Definite_Stacks.Gen_Image_Aux;
diff --git a/packages/wisi/sal-gen_unbounded_definite_stacks-gen_image_aux.ads
b/packages/wisi/sal-gen_unbounded_definite_stacks-gen_image_aux.ads
deleted file mode 100644
index 801ffd3..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_stacks-gen_image_aux.ads
+++ /dev/null
@@ -1,27 +0,0 @@
--- Abstract :
---
--- Image with auxiliary data for instantiations of parent.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Aux_Data (<>) is private;
- with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Unbounded_Definite_Stacks.Gen_Image_Aux
- (Item : in Stack;
- Aux : in Aux_Data;
- Depth : in SAL.Base_Peek_Type := 0)
- return String;
diff --git a/packages/wisi/sal-gen_unbounded_definite_stacks.adb
b/packages/wisi/sal-gen_unbounded_definite_stacks.adb
deleted file mode 100644
index 072c104..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_stacks.adb
+++ /dev/null
@@ -1,219 +0,0 @@
--- Abstract:
---
--- see spec
---
--- Copyright (C) 1998, 2003, 2009, 2015, 2017 - 2020 Free Software
Foundation, Inc.
---
--- SAL is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the
--- Free Software Foundation; either version 3, or (at your option)
--- any later version. SAL is distributed in the hope that it will be
--- useful, but WITHOUT ANY WARRANTY; without even the implied
--- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
--- See the GNU General Public License for more details. You should
--- have received a copy of the GNU General Public License distributed
--- with SAL; see file COPYING. If not, write to the Free Software
--- Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--- USA.
---
--- As a special exception, if other files instantiate generics from
--- SAL, or you link SAL object files with other files to produce an
--- executable, that does not by itself cause the resulting executable
--- to be covered by the GNU General Public License. This exception
--- does not however invalidate any other reasons why the executable
--- file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Unbounded_Definite_Stacks is
-
- ----------
- -- local subprogram bodies
-
- procedure Grow (Stack : in out Sguds.Stack; Desired_Size : in
Base_Peek_Type)
- is
- New_Data : constant Element_Array_Access := new Element_Array (1 ..
Desired_Size);
- begin
- New_Data (1 .. Stack.Top) := Stack.Data (1 .. Stack.Top);
- Free (Stack.Data);
- Stack.Data := New_Data;
- end Grow;
-
- ----------
- -- Spec visible subprograms
- overriding procedure Finalize (Stack : in out Sguds.Stack)
- is begin
- if Stack.Data /= null then
- Free (Stack.Data);
- Stack.Top := Invalid_Peek_Index;
- end if;
- end Finalize;
-
- overriding procedure Adjust (Stack : in out Sguds.Stack)
- is begin
- if Stack.Data /= null then
- Stack.Data := new Element_Array'(Stack.Data.all);
- end if;
- end Adjust;
-
- overriding
- function "=" (Left, Right : in Sguds.Stack) return Boolean
- is begin
- if Left.Data = null then
- return Right.Data = null;
- elsif Left.Top /= Right.Top then
- return False;
- else
- -- Assume stacks differ near top.
- for I in reverse 1 .. Left.Top loop
- if Left.Data (I) /= Right.Data (I) then
- return False;
- end if;
- end loop;
- return True;
- end if;
- end "=";
-
- procedure Clear (Stack : in out Sguds.Stack)
- is begin
- -- We don't change the reserved capacity, on the assumption the
- -- stack will be used again.
- Stack.Top := 0;
- end Clear;
-
- function Depth (Stack : in Sguds.Stack) return Base_Peek_Type
- is begin
- return Stack.Top;
- end Depth;
-
- function Is_Empty (Stack : in Sguds.Stack) return Boolean
- is begin
- return Stack.Top = 0;
- end Is_Empty;
-
- function Peek
- (Stack : in Sguds.Stack;
- Index : in Peek_Type := 1)
- return Element_Type
- is begin
- return Stack.Data (Stack.Top - Index + 1);
- end Peek;
-
- procedure Pop (Stack : in out Sguds.Stack; Count : in Base_Peek_Type := 1)
- is begin
- if Stack.Top < Count then
- raise Container_Empty;
- else
- Stack.Top := Stack.Top - Count;
- end if;
- end Pop;
-
- function Pop (Stack : in out Sguds.Stack) return Element_Type
- is begin
- if Stack.Top = 0 then
- raise Container_Empty;
- else
- return Result : constant Element_Type := Stack.Peek (1)
- do
- Stack.Top := Stack.Top - 1;
- end return;
- end if;
- end Pop;
-
- procedure Push (Stack : in out Sguds.Stack; Item : in Element_Type)
- is begin
- if Stack.Data = null then
- -- Adding a generic parameter for a reasonably large default initial
- -- size here makes Wisitoken McKenzie recover slightly slower,
- -- presumably due to increased cache thrashing.
- Stack.Data := new Element_Array (1 .. 2);
- elsif Stack.Top = Stack.Data'Last then
- Grow (Stack, Desired_Size => 2 * Stack.Data'Last);
- end if;
- Stack.Top := Stack.Top + 1;
- Stack.Data (Stack.Top) := Item;
- end Push;
-
- function Top (Stack : in Sguds.Stack) return Element_Type
- is begin
- if Stack.Top < 1 then
- raise SAL.Container_Empty;
- else
- return Peek (Stack, 1);
- end if;
- end Top;
-
- procedure Set_Depth
- (Stack : in out Sguds.Stack;
- Depth : in Peek_Type)
- is begin
- if Stack.Data = null then
- Stack.Data := new Element_Array (1 .. 2 * Depth);
- elsif Depth > Stack.Data'Last then
- Grow (Stack, Desired_Size => 2 * Depth);
- end if;
- end Set_Depth;
-
- procedure Set
- (Stack : in out Sguds.Stack;
- Index : in Peek_Type;
- Depth : in Peek_Type;
- Element : in Element_Type)
- is begin
- -- Same Position algorithm as in Peek
- Stack.Top := Depth;
- Stack.Data (Depth - Index + 1) := Element;
- end Set;
-
- function Constant_Reference
- (Container : aliased in Stack'Class;
- Position : in Peek_Type)
- return Constant_Reference_Type
- is begin
- return
- (Element => Container.Data (Container.Top - Position + 1)'Access,
- Dummy => 1);
- end Constant_Reference;
-
- function Constant_Reference
- (Container : aliased in Stack'Class;
- Position : in Cursor)
- return Constant_Reference_Type
- is begin
- return
- (Element => Container.Data (Container.Top - Position.Ptr + 1)'Access,
- Dummy => 1);
- end Constant_Reference;
-
- function Has_Element (Position : in Cursor) return Boolean
- is begin
- return Position.Container.Depth >= Position.Ptr;
- end Has_Element;
-
- type Iterator (Container : not null access constant Stack) is new
Iterator_Interfaces.Forward_Iterator with
- null record;
-
- overriding function First (Object : Iterator) return Cursor;
-
- overriding function Next
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
- function Iterate (Container : aliased in Stack) return
Iterator_Interfaces.Forward_Iterator'Class
- is begin
- return Iterator'(Container => Container'Access);
- end Iterate;
-
- overriding function First (Object : Iterator) return Cursor
- is begin
- return (Object.Container, 1);
- end First;
-
- overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
- is
- pragma Unreferenced (Object);
- begin
- return (Position.Container, Position.Ptr + 1);
- end Next;
-
-end SAL.Gen_Unbounded_Definite_Stacks;
diff --git a/packages/wisi/sal-gen_unbounded_definite_stacks.ads
b/packages/wisi/sal-gen_unbounded_definite_stacks.ads
deleted file mode 100644
index 3d1e1e7..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_stacks.ads
+++ /dev/null
@@ -1,158 +0,0 @@
--- Abstract:
---
--- Stack implementation.
---
--- Copyright (C) 1998-2000, 2002-2003, 2009, 2015, 2017 - 2020 Free Software
Foundation, Inc.
---
--- SAL is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the
--- Free Software Foundation; either version 3, or (at your option)
--- any later version. SAL is distributed in the hope that it will be
--- useful, but WITHOUT ANY WARRANTY; without even the implied
--- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
--- See the GNU General Public License for more details. You should
--- have received a copy of the GNU General Public License distributed
--- with SAL; see file COPYING. If not, write to the Free Software
--- Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--- USA.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with Ada.Iterator_Interfaces;
-with Ada.Unchecked_Deallocation;
-generic
- type Element_Type is private;
-package SAL.Gen_Unbounded_Definite_Stacks is
-
- package Sguds renames SAL.Gen_Unbounded_Definite_Stacks;
-
- type Stack is new Ada.Finalization.Controlled with private
- with
- Constant_Indexing => Constant_Reference,
- Default_Iterator => Iterate,
- Iterator_Element => Element_Type;
-
- Empty_Stack : constant Stack;
-
- overriding procedure Finalize (Stack : in out Sguds.Stack);
- overriding procedure Adjust (Stack : in out Sguds.Stack);
-
- overriding function "=" (Left, Right : in Sguds.Stack) return Boolean;
-
- procedure Clear (Stack : in out Sguds.Stack);
- -- Empty Stack of all items.
-
- function Depth (Stack : in Sguds.Stack) return Base_Peek_Type;
- -- Returns current count of items in the Stack
-
- function Is_Empty (Stack : in Sguds.Stack) return Boolean;
- -- Returns true iff no items are in Stack.
-
- function Peek
- (Stack : in Sguds.Stack;
- Index : in Peek_Type := 1)
- return Element_Type with Inline;
- -- Return the Index'th item from the top of Stack; the Item is _not_
removed.
- -- Top item has index 1.
- --
- -- Raises Constraint_Error if Index > Depth.
- --
- -- See also Constant_Ref, implicit indexing
-
- procedure Pop (Stack : in out Sguds.Stack; Count : in Base_Peek_Type := 1);
- -- Remove Count Items from the top of Stack, discard them.
- --
- -- Raises Container_Empty if there are fewer than Count items on
- -- Stack.
-
- function Pop (Stack : in out Sguds.Stack) return Element_Type;
- -- Remove Item from the top of Stack, and return it.
- --
- -- Raises Container_Empty if Is_Empty.
-
- procedure Push (Stack : in out Sguds.Stack; Item : in Element_Type);
- -- Add Item to the top of Stack.
- --
- -- May raise Container_Full.
-
- function Top (Stack : in Sguds.Stack) return Element_Type;
- -- Return the item at the top of Stack; the Item is _not_ removed.
- -- Same as Peek (Stack, 1).
- --
- -- Raises Container_Empty if Is_Empty.
-
- procedure Set_Depth
- (Stack : in out Sguds.Stack;
- Depth : in Peek_Type);
- -- Empty Stack, set its Depth to Depth. Must be followed by Set
- -- for each element.
- --
- -- Useful when creating a stack from pre-existing data.
-
- procedure Set
- (Stack : in out Sguds.Stack;
- Index : in Peek_Type;
- Depth : in Peek_Type;
- Element : in Element_Type);
- -- Set a Stack element. Index is the same as Peek Index; Depth is
- -- used to compute the index in the underlying array.
- --
- -- Stack must have been initialized by Set_Depth.
- --
- -- Useful when creating a stack from pre-existing data.
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Constant_Reference
- (Container : aliased in Stack'Class;
- Position : in Peek_Type)
- return Constant_Reference_Type
- with Inline, Pre => Position in 1 .. Container.Depth;
-
- type Cursor (<>) is private;
-
- function Constant_Reference
- (Container : aliased in Stack'Class;
- Position : in Cursor)
- return Constant_Reference_Type
- with Inline, Pre => Has_Element (Position);
-
- function Has_Element (Position : in Cursor) return Boolean;
-
- package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
-
- function Iterate (Container : aliased in Stack) return
Iterator_Interfaces.Forward_Iterator'Class;
-
-private
-
- type Element_Array is array (Peek_Type range <>) of aliased Element_Type;
- type Element_Array_Access is access Element_Array;
- procedure Free is new Ada.Unchecked_Deallocation (Element_Array,
Element_Array_Access);
-
- type Stack is new Ada.Finalization.Controlled with record
- Top : Base_Peek_Type := Invalid_Peek_Index; -- empty
- Data : Element_Array_Access;
-
- -- Top of stack is at Data (Top).
- -- Data (1 .. Top) has been set at some point.
- end record;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- Empty_Stack : constant Stack := (Ada.Finalization.Controlled with
Invalid_Peek_Index, null);
-
- type Cursor (Container : not null access constant Stack) is
- record
- Ptr : Peek_Type;
- end record;
-
-end SAL.Gen_Unbounded_Definite_Stacks;
diff --git
a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_comparable.adb
b/packages/wisi/sal-gen_unbounded_definite_vectors-gen_comparable.adb
deleted file mode 100644
index 16c1fe8..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_comparable.adb
+++ /dev/null
@@ -1,73 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable is
-
- function Compare (Left, Right : in Vector) return Compare_Result
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Left.Length = 0 then
- if Right.Length = 0 then
- return Equal;
- else
- -- null is less than non-null
- return Less;
- end if;
-
- elsif Right.Length = 0 then
- return Greater;
-
- else
- declare
- I : Base_Peek_Type := To_Peek_Type (Left.First);
- J : Base_Peek_Type := To_Peek_Type (Right.First);
-
- Left_Last : constant Base_Peek_Type := To_Peek_Type (Left.Last);
- Right_Last : constant Base_Peek_Type := To_Peek_Type (Right.Last);
- begin
- loop
- exit when I > Left_Last or J > Right_Last;
-
- case Element_Compare (Left.Elements (I), Right.Elements (J)) is
- when Less =>
- return Less;
- when Equal =>
- I := I + 1;
- J := J + 1;
- when Greater =>
- return Greater;
- end case;
- end loop;
- if I > Left_Last then
- if J > Right_Last then
- return Equal;
- else
- -- right is longer
- return Less;
- end if;
- else
- -- left is longer
- return Greater;
- end if;
- end;
- end if;
- end Compare;
-
-end SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable;
diff --git
a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_comparable.ads
b/packages/wisi/sal-gen_unbounded_definite_vectors-gen_comparable.ads
deleted file mode 100644
index 56d84c0..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_comparable.ads
+++ /dev/null
@@ -1,30 +0,0 @@
--- Abstract :
---
--- Add "<" to parent
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- with function Element_Compare (Left, Right : in Element_Type) return
Compare_Result;
-package SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable is
-
- type Vector is new SAL.Gen_Unbounded_Definite_Vectors.Vector with null
record;
-
- function Compare (Left, Right : in Vector) return Compare_Result;
- -- Similar to Ada "<" for arrays; Ada Reference Manual
- -- section 4.5.2 para 26/3.
-
-end SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable;
diff --git a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image.adb
b/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image.adb
deleted file mode 100644
index 929994a..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image.adb
+++ /dev/null
@@ -1,50 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Fixed;
-with Ada.Strings.Unbounded;
-function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image (Item : in Vector;
Strict : in Boolean := False) return String
-is
- use all type Ada.Containers.Count_Type;
- use Ada.Strings;
- use Ada.Strings.Fixed;
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- First : constant Base_Peek_Type := To_Peek_Type (Item.First_Index);
- Last : constant Base_Peek_Type := To_Peek_Type (Item.Last_Index);
-begin
- if Strict and Item.Length = 0 then
- return "(" & Trim (Index_Type'Image (Index_Type'First), Left) & " .. " &
- Trim (Index_Type'Image (Extended_Index'First), Left) & " => <>)";
-
- elsif Strict and Item.Length = 1 then
- return "(" & Trim (Index_Type'Image (Index_Type'First), Left) & " => " &
- Element_Image (Item.Elements (First)) & ")";
-
- else
- for I in First .. Last loop
- Result := Result & Element_Image (Item.Elements (I));
- if I /= Last then
- Result := Result & ", ";
- end if;
- end loop;
- Result := Result & ")";
- return To_String (Result);
- end if;
-end SAL.Gen_Unbounded_Definite_Vectors.Gen_Image;
diff --git a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image.ads
b/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image.ads
deleted file mode 100644
index 274e1f1..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image.ads
+++ /dev/null
@@ -1,24 +0,0 @@
--- Abstract :
---
--- Image of parent.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- with function Element_Image (Item : in Element_Type) return String;
-function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image (Item : in Vector;
Strict : in Boolean := False) return String;
--- Image of Item, in Ada aggregate syntax. If Strict, use correct
--- syntax for 0 and 1 item; otherwise, use () and (item).
diff --git a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
b/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
deleted file mode 100644
index e0d90a6..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image_aux.adb
+++ /dev/null
@@ -1,43 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2019 Stephen Leake All Rights Reserved.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded;
-function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux
- (Item : in Vector;
- Aux : in Aux_Data;
- Association : in Boolean := False)
- return String
-is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := To_Unbounded_String ("(");
- First : constant Base_Peek_Type := To_Peek_Type (Item.First_Index);
- Last : constant Base_Peek_Type := To_Peek_Type (Item.Last_Index);
-begin
- for I in First .. Last loop
- if Association then
- Result := Result & Index_Trimmed_Image (To_Index_Type (I)) & " => ";
- end if;
- Result := Result & Element_Image (Item.Elements (I), Aux);
- if I /= Last then
- Result := Result & ", ";
- end if;
- end loop;
- Result := Result & ")";
- return To_String (Result);
-end SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux;
diff --git a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
b/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
deleted file mode 100644
index eb8a89a..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors-gen_image_aux.ads
+++ /dev/null
@@ -1,28 +0,0 @@
--- Abstract :
---
--- Image with auxiliary data for instantiations of parent.
---
--- Copyright (C) 2018 - 2019 Stephen Leake All Rights Reserved.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-generic
- type Aux_Data (<>) is private;
- with function Index_Trimmed_Image (Item : in Index_Type) return String;
- with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Unbounded_Definite_Vectors.Gen_Image_Aux
- (Item : in Vector;
- Aux : in Aux_Data;
- Association : in Boolean := False)
- return String;
diff --git a/packages/wisi/sal-gen_unbounded_definite_vectors.adb
b/packages/wisi/sal-gen_unbounded_definite_vectors.adb
deleted file mode 100644
index 9e1c189..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors.adb
+++ /dev/null
@@ -1,585 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Unbounded_Definite_Vectors is
-
- function To_Peek_Type (Item : in Extended_Index) return Base_Peek_Type
- is begin
- return Base_Peek_Type'Base (Item - Index_Type'First) + Peek_Type'First;
- end To_Peek_Type;
-
- function To_Index_Type (Item : in Base_Peek_Type) return Extended_Index
- is begin
- return Extended_Index (Item - Peek_Type'First) + Index_Type'First;
- end To_Index_Type;
-
- procedure Grow (Elements : in out Array_Access; Index : in Base_Peek_Type)
- is
- -- Reallocate Elements so Elements (Index) is a valid element.
-
- Old_First : constant Peek_Type := Elements'First;
- Old_Last : constant Peek_Type := Elements'Last;
- New_First : Peek_Type := Old_First;
- New_Last : Peek_Type := Old_Last;
- New_Length : Peek_Type := Elements'Length;
-
- New_Array : Array_Access;
- begin
- loop
- exit when New_First <= Index;
- New_Length := New_Length * 2;
- New_First := Peek_Type'Max (Peek_Type'First, Old_Last - New_Length +
1);
- end loop;
- loop
- exit when New_Last >= Index;
- New_Length := New_Length * 2;
- New_Last := Peek_Type'Min (Peek_Type'Last, New_First + New_Length -
1);
- end loop;
-
- New_Array := new Array_Type (New_First .. New_Last);
-
- -- We'd like to use this:
- --
- -- New_Array (New_First .. Old_First - 1) := (others => <>);
- --
- -- but that can overflow the stack, since the aggregate is allocated
- -- on the stack.
-
- for I in New_First .. Old_First - 1 loop
- New_Array (I .. I) := (others => <>);
- end loop;
-
- New_Array (Old_First .. Old_Last) := Elements.all;
-
- for I in Old_Last + 1 .. New_Last loop
- New_Array (I .. I) := (others => <>);
- end loop;
-
- Free (Elements);
- Elements := New_Array;
- end Grow;
-
- ----------
- -- public subprograms
-
- overriding procedure Finalize (Container : in out Vector)
- is begin
- Free (Container.Elements);
- Container.First := No_Index;
- Container.Last := No_Index;
- end Finalize;
-
- overriding procedure Adjust (Container : in out Vector)
- is begin
- if Container.Elements /= null then
- Container.Elements := new Array_Type'(Container.Elements.all);
- end if;
- end Adjust;
-
- function Length (Container : in Vector) return Ada.Containers.Count_Type
- is begin
- -- We assume the type ranges are sensible, so no exceptions occur
- -- here.
- if Container.Elements = null then
- return 0;
- else
- return Ada.Containers.Count_Type (To_Peek_Type (Container.Last) -
Container.Elements'First + 1);
- end if;
- end Length;
-
- function Capacity (Container : in Vector) return Ada.Containers.Count_Type
- is begin
- if Container.Elements = null then
- return 0;
- else
- return Ada.Containers.Count_Type (Container.Elements'Length);
- end if;
- end Capacity;
-
- procedure Set_Capacity
- (Container : in out Vector;
- First : in Index_Type;
- Last : in Extended_Index)
- is
- First_Peek : constant Peek_Type := To_Peek_Type (First);
- Last_Peek : constant Peek_Type := To_Peek_Type (Last);
- begin
- if Container.Elements = null then
- Container.Elements := new Array_Type (First_Peek .. Last_Peek);
- else
- if First_Peek < Container.Elements'First then
- Grow (Container.Elements, First_Peek);
- end if;
- if Last_Peek < Container.Elements'Last then
- Grow (Container.Elements, Last_Peek);
- end if;
- end if;
- end Set_Capacity;
-
- function Element (Container : Vector; Index : Index_Type) return
Element_Type
- is begin
- return Container.Elements (To_Peek_Type (Index));
- end Element;
-
- procedure Replace_Element (Container : Vector; Index : Index_Type; New_Item
: in Element_Type)
- is begin
- Container.Elements (To_Peek_Type (Index)) := New_Item;
- end Replace_Element;
-
- function First_Index (Container : Vector) return Extended_Index
- is begin
- if Container.First = No_Index then
- return No_Index + 1;
- else
- return Container.First;
- end if;
- end First_Index;
-
- function Last_Index (Container : Vector) return Extended_Index
- is begin
- return Container.Last;
- end Last_Index;
-
- procedure Append (Container : in out Vector; New_Item : in Element_Type)
- is begin
- if Container.First = No_Index then
- Container.First := Index_Type'First;
- Container.Last := Index_Type'First;
- else
- Container.Last := Container.Last + 1;
- end if;
-
- declare
- J : constant Base_Peek_Type := To_Peek_Type (Container.Last);
- begin
- if Container.Elements = null then
- Container.Elements := new Array_Type (J .. J);
-
- elsif J > Container.Elements'Last then
- Grow (Container.Elements, J);
- end if;
-
- Container.Elements (J) := New_Item;
- end;
- end Append;
-
- procedure Append (Container : in out Vector; New_Items : in Vector)
- is
- use all type Ada.Containers.Count_Type;
- Old_Last : Extended_Index := Container.Last;
- begin
- if New_Items.Length = 0 then
- return;
- end if;
-
- if Container.First = No_Index then
- Container.First := Index_Type'First;
- Old_Last := Container.First - 1;
- Container.Last := Container.First + Extended_Index
(New_Items.Length) - 1;
- else
- Container.Last := Container.Last + Extended_Index (New_Items.Length);
- end if;
-
- declare
- I : constant Peek_Type := To_Peek_Type (Old_Last + 1);
- J : constant Peek_Type := To_Peek_Type (Container.Last);
- begin
- if Container.Elements = null then
- Container.Elements := new Array_Type (I .. J);
- elsif J > Container.Elements'Last then
- Grow (Container.Elements, J);
- end if;
-
- Container.Elements (I .. J) := New_Items.Elements
- (To_Peek_Type (New_Items.First) .. To_Peek_Type (New_Items.Last));
- end;
- end Append;
-
- procedure Prepend (Container : in out Vector; New_Item : in Element_Type)
- is begin
- if Container.First = No_Index then
- Container.First := Index_Type'First;
- Container.Last := Index_Type'First;
- else
- Container.First := Container.First - 1;
- end if;
-
- declare
- J : constant Peek_Type := To_Peek_Type (Container.First);
- begin
- if Container.Elements = null then
- Container.Elements := new Array_Type (J .. J);
-
- elsif J < Container.Elements'First then
- Grow (Container.Elements, J);
- end if;
-
- Container.Elements (J) := New_Item;
- end;
- end Prepend;
-
- procedure Prepend
- (Target : in out Vector;
- Source : in Vector;
- Source_First : in Index_Type;
- Source_Last : in Index_Type)
- is
- Source_I : constant Peek_Type := To_Peek_Type (Source_First);
- Source_J : constant Peek_Type := To_Peek_Type (Source_Last);
- begin
- if Target.Elements = null then
- Target.Elements := new Array_Type'(Source.Elements (Source_I ..
Source_J));
- Target.First := Source_First;
- Target.Last := Source_Last;
- else
- declare
- New_First : constant Index_Type := Target.First - (Source_Last -
Source_First + 1);
- I : constant Peek_Type := To_Peek_Type (New_First);
- J : constant Peek_Type := To_Peek_Type (Target.First - 1);
- begin
- if Target.Elements'First > I then
- Grow (Target.Elements, I);
- end if;
- Target.Elements (I .. J) := Source.Elements (Source_I .. Source_J);
- Target.First := New_First;
- end;
- end if;
- end Prepend;
-
- procedure Insert
- (Container : in out Vector;
- Element : in Element_Type;
- Before : in Index_Type)
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Container.Length = 0 then
- Container.Append (Element);
- else
- Container.Last := Container.Last + 1;
-
- declare
- J : constant Peek_Type := To_Peek_Type (Before);
- K : constant Base_Peek_Type := To_Peek_Type (Container.Last);
- begin
- if K > Container.Elements'Last then
- Grow (Container.Elements, K);
- end if;
-
- Container.Elements (J + 1 .. K) := Container.Elements (J .. K - 1);
- Container.Elements (J) := Element;
- end;
- end if;
- end Insert;
-
- procedure Merge
- (Target : in out Vector;
- Source : in out Vector)
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Source.Length = 0 then
- Source.Clear;
-
- elsif Target.Length = 0 then
- Target := Source;
- Source.Clear;
-
- else
- declare
- New_First : constant Index_Type := Extended_Index'Min
(Target.First, Source.First);
- New_Last : constant Index_Type := Extended_Index'Max
(Target.Last, Source.Last);
- New_I : constant Peek_Type := To_Peek_Type (New_First);
- New_J : constant Base_Peek_Type := To_Peek_Type (New_Last);
- begin
- if New_I < Target.Elements'First then
- Grow (Target.Elements, New_I);
- end if;
- if New_J > Target.Elements'Last then
- Grow (Target.Elements, New_J);
- end if;
-
- Target.Elements (To_Peek_Type (Source.First) .. To_Peek_Type
(Source.Last)) := Source.Elements
- (To_Peek_Type (Source.First) .. To_Peek_Type (Source.Last));
-
- Target.First := New_First;
- Target.Last := New_Last;
-
- Source.Clear;
- end;
- end if;
- end Merge;
-
- function To_Vector (Item : in Element_Type; Count : in
Ada.Containers.Count_Type := 1) return Vector
- is begin
- return Result : Vector do
- for I in 1 .. Count loop
- Result.Append (Item);
- end loop;
- end return;
- end To_Vector;
-
- function "+" (Element : in Element_Type) return Vector
- is begin
- return Result : Vector do
- Result.Append (Element);
- end return;
- end "+";
-
- function "&" (Left, Right : in Element_Type) return Vector
- is begin
- return Result : Vector do
- Result.Append (Left);
- Result.Append (Right);
- end return;
- end "&";
-
- function "&" (Left : in Vector; Right : in Element_Type) return Vector
- is begin
- return Result : Vector := Left do
- Result.Append (Right);
- end return;
- end "&";
-
- procedure Set_First (Container : in out Vector; First : in Index_Type)
- is
- J : constant Peek_Type := To_Peek_Type (First);
- begin
- Container.First := First;
- if Container.Last = No_Index then
- Container.Last := First - 1;
- end if;
-
- if Container.Last >= First then
- if Container.Elements = null then
- Container.Elements := new Array_Type'(J .. To_Peek_Type
(Container.Last) => Default_Element);
-
- elsif Container.Elements'First > J then
- Grow (Container.Elements, J);
- end if;
- end if;
- end Set_First;
-
- procedure Set_Last (Container : in out Vector; Last : in Extended_Index)
- is
- J : constant Base_Peek_Type := To_Peek_Type (Last);
- begin
- Container.Last := Last;
- if Container.First = No_Index then
- Container.First := Last + 1;
- end if;
-
- if Last >= Container.First then
- if Container.Elements = null then
- Container.Elements := new Array_Type'(To_Peek_Type
(Container.First) .. J => Default_Element);
-
- elsif Container.Elements'Last < J then
- Grow (Container.Elements, J);
- end if;
- end if;
- end Set_Last;
-
- procedure Set_First_Last
- (Container : in out Vector;
- First : in Index_Type;
- Last : in Extended_Index)
- is begin
- Set_First (Container, First);
- Set_Last (Container, Last);
- end Set_First_Last;
-
- procedure Delete (Container : in out Vector; Index : in Index_Type)
- is
- J : constant Peek_Type := To_Peek_Type (Index);
- begin
- Container.Elements (J .. J) := (J => <>);
- if Index = Container.Last then
- Container.Last := Container.Last - 1;
- end if;
- end Delete;
-
- function Contains (Container : in Vector; Element : in Element_Type) return
Boolean
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Container.Length = 0 then
- return False;
- else
- for It of Container.Elements.all loop
- if It = Element then
- return True;
- end if;
- end loop;
- return False;
- end if;
- end Contains;
-
- function Element (Position : Cursor) return Element_Type
- is begin
- return Position.Container.Elements (Position.Index);
- end Element;
-
- function First (Container : aliased in Vector) return Cursor
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Container.Length = 0 then
- return (Container'Access, Invalid_Peek_Index);
- else
- return (Container'Access, To_Peek_Type (Container.First));
- end if;
- end First;
-
- function Next (Position : in Cursor) return Cursor
- is begin
- if Position.Index = Invalid_Peek_Index then
- return (Position.Container, Invalid_Peek_Index);
- elsif Position.Index < To_Peek_Type (Position.Container.Last) then
- return (Position.Container, Position.Index + 1);
- else
- return (Position.Container, Invalid_Peek_Index);
- end if;
- end Next;
-
- procedure Next (Position : in out Cursor)
- is begin
- if Position.Index = Invalid_Peek_Index then
- null;
- elsif Position.Index < To_Peek_Type (Position.Container.Last) then
- Position.Index := Position.Index + 1;
- else
- Position := (Position.Container, Invalid_Peek_Index);
- end if;
- end Next;
-
- function Prev (Position : in Cursor) return Cursor
- is begin
- if Position.Index = Invalid_Peek_Index then
- return (Position.Container, Invalid_Peek_Index);
- elsif Position.Index > To_Peek_Type (Position.Container.First) then
- return (Position.Container, Position.Index - 1);
- else
- return (Position.Container, Invalid_Peek_Index);
- end if;
- end Prev;
-
- procedure Prev (Position : in out Cursor)
- is begin
- if Position.Index = Invalid_Peek_Index then
- null;
- elsif Position.Index > To_Peek_Type (Position.Container.First) then
- Position.Index := Position.Index - 1;
- else
- Position := (Position.Container, Invalid_Peek_Index);
- end if;
- end Prev;
-
- function To_Cursor
- (Container : aliased in Vector;
- Index : in Extended_Index)
- return Cursor
- is begin
- return (Container'Access, To_Peek_Type (Index));
- end To_Cursor;
-
- function To_Index (Position : in Cursor) return Extended_Index
- is begin
- if Position.Index = Invalid_Peek_Index then
- return No_Index;
- else
- return To_Index_Type (Position.Index);
- end if;
- end To_Index;
-
- function Constant_Ref (Container : aliased Vector; Index : in Index_Type)
return Constant_Reference_Type
- is
- J : constant Peek_Type := To_Peek_Type (Index);
- begin
- return (Element => Container.Elements (J)'Access, Dummy => 1);
- end Constant_Ref;
-
- function Variable_Ref
- (Container : aliased in Vector;
- Index : in Index_Type)
- return Variable_Reference_Type
- is
- J : constant Peek_Type := To_Peek_Type (Index);
- begin
- return (Element => Container.Elements (J)'Access, Dummy => 1);
- end Variable_Ref;
-
- overriding function First (Object : Iterator) return Cursor
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Object.Container.Length = 0 then
- return (Object.Container, Invalid_Peek_Index);
- else
- return (Object.Container, To_Peek_Type (Object.Container.First));
- end if;
- end First;
-
- overriding function Last (Object : Iterator) return Cursor
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Object.Container.Length = 0 then
- return (Object.Container, Invalid_Peek_Index);
- else
- return (Object.Container, To_Peek_Type (Object.Container.Last));
- end if;
- end Last;
-
- overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
- is begin
- if Position.Index = To_Peek_Type (Object.Container.Last) then
- return (Object.Container, Invalid_Peek_Index);
- else
- return (Object.Container, Position.Index + 1);
- end if;
- end Next;
-
- overriding function Previous (Object : in Iterator; Position : in Cursor)
return Cursor
- is begin
- if Position.Index = To_Peek_Type (Index_Type'First) then
- return (Object.Container, Invalid_Peek_Index);
- else
- return (Object.Container, Position.Index - 1);
- end if;
- end Previous;
-
- function Iterate (Container : aliased in Vector) return
Iterator_Interfaces.Reversible_Iterator'Class
- is begin
- return Iterator'(Container => Container'Access);
- end Iterate;
-
- function Constant_Ref (Container : aliased Vector; Position : in Cursor)
return Constant_Reference_Type
- is begin
- return (Element => Container.Elements (Position.Index)'Access, Dummy =>
1);
- end Constant_Ref;
-
- function Variable_Ref
- (Container : aliased in Vector;
- Position : in Cursor)
- return Variable_Reference_Type
- is begin
- return (Element => Container.Elements (Position.Index)'Access, Dummy =>
1);
- end Variable_Ref;
-
-end SAL.Gen_Unbounded_Definite_Vectors;
diff --git a/packages/wisi/sal-gen_unbounded_definite_vectors.ads
b/packages/wisi/sal-gen_unbounded_definite_vectors.ads
deleted file mode 100644
index 29ecae0..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors.ads
+++ /dev/null
@@ -1,252 +0,0 @@
--- Abstract :
---
--- A simple unbounded vector of definite items, intended to be faster
--- than Ada.Containers.Vectors.
---
--- Prepend is as fast (in amortized time) as Append.
---
--- It provides no checking of cursor tampering; higher level code
--- must ensure that.
---
--- Design:
---
--- See ARM 3.10.2 "explicitly aliased" for why we need 'aliased' in
--- several subprogram argument modes, and why Container must be an
--- access discriminant in Cursor and Iterator.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with Ada.Iterator_Interfaces;
-with Ada.Unchecked_Deallocation;
-generic
- type Index_Type is range <>;
- type Element_Type is private;
- Default_Element : in Element_Type;
-package SAL.Gen_Unbounded_Definite_Vectors is
-
- subtype Extended_Index is Index_Type'Base
- range Index_Type'First - 1 ..
- Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
-
- No_Index : constant Extended_Index := Extended_Index'First;
-
- type Vector is new Ada.Finalization.Controlled with private with
- Constant_Indexing => Constant_Ref,
- Variable_Indexing => Variable_Ref,
- Default_Iterator => Iterate,
- Iterator_Element => Element_Type;
-
- Empty_Vector : constant Vector;
-
- overriding procedure Finalize (Container : in out Vector);
- overriding procedure Adjust (Container : in out Vector);
-
- overriding function "=" (Left, Right : in Vector) return Boolean is
- (raise Programmer_Error);
- -- Use Gen_Comparable child.
-
- function Length (Container : in Vector) return Ada.Containers.Count_Type;
- function Capacity (Container : in Vector) return Ada.Containers.Count_Type;
-
- procedure Set_Capacity
- (Container : in out Vector;
- First : in Index_Type;
- Last : in Extended_Index);
- -- Allocates memory, but does not change Container.First, Container.Last.
-
- procedure Clear (Container : in out Vector)
- renames Finalize;
-
- function First_Index (Container : Vector) return Extended_Index;
- -- No_Index + 1 when Container is empty, so "for I in C.First_Index
- -- .. C.Last_Index loop" works.
- --
- -- If you need No_Index for an empty Container, use To_Index
(Container.First).
-
- function Last_Index (Container : Vector) return Extended_Index;
- -- No_Index when Container is empty.
-
- function Element (Container : Vector; Index : Index_Type) return
Element_Type
- with Pre => Index >= Container.First_Index and Index <=
Container.Last_Index;
-
- procedure Replace_Element (Container : Vector; Index : Index_Type; New_Item
: in Element_Type);
-
- procedure Append (Container : in out Vector; New_Item : in Element_Type);
- -- Insert New_Item at end of Container.
- --
- -- Raises Constraint_Error if index of new item would be greater than
- -- Index_Type'Last.
-
- procedure Append (Container : in out Vector; New_Items : in Vector);
- -- Insert all elements of New_Items at end of Container.
-
- procedure Prepend (Container : in out Vector; New_Item : in Element_Type);
- -- Insert New_Item at beginning of Container.
- --
- -- Raises Constraint_Error if index of new item would be less than
- -- Index_Type'First.
-
- procedure Prepend
- (Target : in out Vector;
- Source : in Vector;
- Source_First : in Index_Type;
- Source_Last : in Index_Type);
- -- Copy Source (Source_First .. Source_Last) to Target, before
- -- Target.First_Index.
-
- procedure Insert
- (Container : in out Vector;
- Element : in Element_Type;
- Before : in Index_Type);
- -- Existing elements at Before and after are slid to higher indices.
-
- procedure Merge
- (Target : in out Vector;
- Source : in out Vector);
- -- Copy all elements from Source to Target, to the same index range,
- -- deleting them from Source, and overwriting overlapping ranges.
-
- function To_Vector (Item : in Element_Type; Count : in
Ada.Containers.Count_Type := 1) return Vector;
-
- function "+" (Element : in Element_Type) return Vector;
-
- function "&" (Left, Right : in Element_Type) return Vector;
- function "&" (Left : in Vector; Right : in Element_Type) return Vector;
-
- procedure Set_First_Last
- (Container : in out Vector;
- First : in Index_Type;
- Last : in Extended_Index);
- -- Elements in First .. Last that have not been set have
- -- Default_Element value.
-
- procedure Delete (Container : in out Vector; Index : in Index_Type);
- -- Replace Index element contents with default. If Index =
- -- Container.Last_Index, Container.Last_Index is decremented.
-
- function Contains (Container : in Vector; Element : in Element_Type) return
Boolean;
- -- Return True if Element is in Container, False if not.
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Constant_Ref (Container : aliased in Vector; Index : in
Index_Type) return Constant_Reference_Type
- with Inline, Pre => Index in Container.First_Index .. Container.Last_Index;
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
private with
- Implicit_Dereference => Element;
-
- function Variable_Ref (Container : aliased in Vector; Index : in
Index_Type) return Variable_Reference_Type
- with Inline, Pre => Index in Container.First_Index .. Container.Last_Index;
-
- type Cursor (<>) is private;
-
- function Has_Element (Position : Cursor) return Boolean;
- function Element (Position : Cursor) return Element_Type
- with Pre => Has_Element (Position);
- function First (Container : aliased in Vector) return Cursor;
- function Next (Position : in Cursor) return Cursor;
- procedure Next (Position : in out Cursor);
- function Prev (Position : in Cursor) return Cursor;
- procedure Prev (Position : in out Cursor);
-
- function To_Cursor
- (Container : aliased in Vector;
- Index : in Extended_Index)
- return Cursor
- with Pre => Index = No_Index or Index in Container.First_Index ..
Container.Last_Index;
-
- function To_Index (Position : in Cursor) return Extended_Index;
-
- package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
-
- function Iterate (Container : aliased in Vector) return
Iterator_Interfaces.Reversible_Iterator'Class;
-
- function Constant_Ref (Container : aliased in Vector; Position : in Cursor)
return Constant_Reference_Type
- with Pre => Has_Element (Position) and then
- To_Index (Position) in Container.First_Index ..
Container.Last_Index;
-
- function Variable_Ref (Container : aliased in Vector; Position : in
Cursor) return Variable_Reference_Type
- with Pre => Has_Element (Position) and then
- To_Index (Position) in Container.First_Index ..
Container.Last_Index;
- pragma Inline (Variable_Ref);
-
-private
-
- type Array_Type is array (SAL.Peek_Type range <>) of aliased Element_Type;
- type Array_Access is access Array_Type;
- procedure Free is new Ada.Unchecked_Deallocation (Array_Type, Array_Access);
-
- type Vector is new Ada.Finalization.Controlled with
- record
- Elements : Array_Access;
- -- Elements may be non-null with First = No_Index, after
- -- Set_Capacity. If First /= No_Index and Last >= First, Elements /=
- -- null. First > Last means Vector is empty.
- First : Extended_Index := No_Index;
- Last : Extended_Index := No_Index;
- end record;
-
- type Vector_Access is access constant Vector;
- for Vector_Access'Storage_Size use 0;
-
- type Cursor (Container : not null access constant Vector) is
- record
- Index : Base_Peek_Type := Invalid_Peek_Index;
- end record;
-
- type Iterator (Container : not null access constant Vector) is new
Iterator_Interfaces.Reversible_Iterator with
- null record;
-
- overriding function First (Object : Iterator) return Cursor;
- overriding function Last (Object : Iterator) return Cursor;
-
- overriding function Next
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
- overriding function Previous
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- type Variable_Reference_Type (Element : not null access Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- Empty_Vector : constant Vector := (Ada.Finalization.Controlled with others
=> <>);
-
- ----------
- -- Visible for contracts/SPARK
-
- function Has_Element (Position : Cursor) return Boolean
- is (Position.Index /= Invalid_Peek_Index);
-
- ----------
- -- Visible for child package
-
- function To_Peek_Type (Item : in Extended_Index) return Base_Peek_Type with
Inline;
- function To_Index_Type (Item : in Base_Peek_Type) return Extended_Index;
-
- procedure Grow (Elements : in out Array_Access; Index : in Base_Peek_Type);
-
-end SAL.Gen_Unbounded_Definite_Vectors;
diff --git a/packages/wisi/sal-gen_unbounded_definite_vectors_sorted.adb
b/packages/wisi/sal-gen_unbounded_definite_vectors_sorted.adb
deleted file mode 100644
index 8e40695..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors_sorted.adb
+++ /dev/null
@@ -1,374 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body SAL.Gen_Unbounded_Definite_Vectors_Sorted is
-
- ----------
- -- Body subprograms, arbitrary order
-
- procedure Grow (Elements : in out Array_Access; Index : in Base_Peek_Type)
- is
- -- Reallocate Elements so Elements (Index) is a valid element.
-
- Old_First : constant Peek_Type := Elements'First;
- Old_Last : constant Peek_Type := Elements'Last;
- New_First : Peek_Type := Old_First;
- New_Last : Peek_Type := Old_Last;
- New_Length : Peek_Type := Elements'Length;
-
- New_Array : Array_Access;
- begin
- loop
- exit when New_First <= Index;
- New_Length := New_Length * 2;
- New_First := Peek_Type'Max (Peek_Type'First, Old_Last - New_Length +
1);
- end loop;
- loop
- exit when New_Last >= Index;
- New_Length := New_Length * 2;
- New_Last := Peek_Type'Min (Peek_Type'Last, New_First + New_Length -
1);
- end loop;
-
- New_Array := new Array_Type (New_First .. New_Last);
-
- -- We'd like to use this:
- --
- -- New_Array (New_First .. Old_First - 1) := (others => <>);
- --
- -- but that can overflow the stack, since the aggregate is allocated
- -- on the stack.
-
- for I in New_First .. Old_First - 1 loop
- New_Array (I .. I) := (others => <>);
- end loop;
-
- New_Array (Old_First .. Old_Last) := Elements.all;
-
- for I in Old_Last + 1 .. New_Last loop
- New_Array (I .. I) := (others => <>);
- end loop;
-
- Free (Elements);
- Elements := New_Array;
- end Grow;
-
- procedure Find
- (Container : in Vector;
- Key : in Key_Type;
- Found : out Boolean;
- At_After : out Base_Peek_Type)
- with Pre => Container.Last /= No_Index
- is
- -- If Found is True, item is at At_After. If False, item should be
- -- inserted after At_After.
- Low : Base_Peek_Type := Peek_Type'First - 1;
- High : Base_Peek_Type := Container.Last + 1;
- I : Base_Peek_Type := Low + High / 2;
- begin
- loop
- case Key_Compare (Key, To_Key (Container.Elements (I))) is
- when Less =>
- High := I;
- if I = Low then
- Found := False;
- At_After := I;
- return;
-
- elsif I - 1 = Low then
- Found := False;
- At_After := I - 1;
- return;
-
- else
- I := I - (I - Low) / 2;
- end if;
-
- when Equal =>
- Found := True;
- At_After := I;
- return;
-
- when Greater =>
- Low := I;
- if I = High then
- Found := False;
- At_After := I - 1;
- return;
-
- elsif I + 1 = High then
- Found := False;
- At_After := I;
- return;
-
- else
- I := I + (High - I) / 2;
- end if;
- end case;
- end loop;
- end Find;
-
- ----------
- -- Public subprograms
-
- overriding procedure Finalize (Container : in out Vector)
- is begin
- Free (Container.Elements);
- Container.Last := No_Index;
- end Finalize;
-
- overriding procedure Adjust (Container : in out Vector)
- is begin
- if Container.Elements /= null then
- Container.Elements := new Array_Type'(Container.Elements.all);
- end if;
- end Adjust;
-
- function Length (Container : in Vector) return Ada.Containers.Count_Type
- is begin
- -- We assume the type ranges are sensible, so no exceptions occur
- -- here.
- if Container.Elements = null then
- return 0;
- else
- return Ada.Containers.Count_Type (Container.Last -
Container.Elements'First + 1);
- end if;
- end Length;
-
- function Capacity (Container : in Vector) return Ada.Containers.Count_Type
- is begin
- if Container.Elements = null then
- return 0;
- else
- return Ada.Containers.Count_Type (Container.Elements'Length);
- end if;
- end Capacity;
-
- procedure Set_Capacity
- (Container : in out Vector;
- Length : in Ada.Containers.Count_Type)
- is
- First_Peek : constant Peek_Type := Peek_Type'First;
- Last_Peek : constant Base_Peek_Type := Base_Peek_Type (Length);
- begin
- if Length = 0 then
- return;
- elsif Container.Elements = null then
- Container.Elements := new Array_Type (First_Peek .. Last_Peek);
- else
- if First_Peek < Container.Elements'First then
- Grow (Container.Elements, First_Peek);
- end if;
- if Last_Peek < Container.Elements'Last then
- Grow (Container.Elements, Last_Peek);
- end if;
- end if;
- end Set_Capacity;
-
- function Has_Element (Position : Cursor) return Boolean is
- begin
- return Position.Index /= Invalid_Peek_Index;
- end Has_Element;
-
- function "&" (Left, Right : in Element_Type) return Vector
- is begin
- return Result : Vector do
- Result.Insert (Left);
- Result.Insert (Right);
- end return;
- end "&";
-
- function "&" (Left : in Vector; Right : in Element_Type) return Vector
- is begin
- return Result : Vector := Left do
- Result.Insert (Right);
- end return;
- end "&";
-
- function Contains (Container : in Vector; Key : in Key_Type) return Boolean
- is
- Found : Boolean;
- I : Base_Peek_Type;
- begin
- if Container.Last = No_Index then
- return False;
- end if;
- Find (Container, Key, Found, I);
- return Found;
- end Contains;
-
- procedure Insert
- (Container : in out Vector;
- New_Item : in Element_Type)
- is
- New_Key : constant Key_Type := To_Key (New_Item);
- J : constant Peek_Type := Peek_Type'First;
- K : constant Base_Peek_Type := Container.Last;
- I : Base_Peek_Type := K;
- begin
- if Container.Last = No_Index then
- Container.Last := Peek_Type'First;
- I := Container.Last;
-
- if Container.Elements = null then
- Container.Elements := new Array_Type (I .. I);
- -- else Set_Capacity called.
- end if;
- Container.Elements (I) := New_Item;
- return;
-
- else
- Container.Last := Container.Last + 1;
- end if;
-
- pragma Assert (Container.Elements /= null);
-
- if I + 1 > Container.Elements'Last then
- Grow (Container.Elements, I + 1);
- end if;
-
- loop
- exit when I < J;
-
- case Key_Compare (New_Key, To_Key (Container.Elements (I))) is
- when Less =>
- -- Linear search is simple, we assume insert is used far less
often
- -- than Find. And this is optimal when inserting in Key order.
- I := I - 1;
- when Equal =>
- -- Insert after I
- exit;
- when Greater =>
- -- Insert after I
- exit;
- end case;
- end loop;
-
- if I < J then
- -- Insert before all
- Container.Elements (J + 1 .. K + 1) := Container.Elements (J .. K);
- Container.Elements (J) := New_Item;
- else
- -- Insert after I
- Container.Elements (I + 2 .. K + 1) := Container.Elements (I + 1 ..
K);
- Container.Elements (I + 1) := New_Item;
- end if;
- end Insert;
-
- function Find
- (Container : aliased in Vector;
- Key : in Key_Type)
- return Find_Reference_Type
- is
- Found : Boolean;
- I : Base_Peek_Type;
- begin
- if Container.Last = No_Index then
- return (Element => null, Dummy => 1);
- end if;
- Find (Container, Key, Found, I);
- if Found then
- return (Element => Container.Elements (I)'Access, Dummy => 1);
- else
- return (Element => null, Dummy => 1);
- end if;
- end Find;
-
- function Find_Constant
- (Container : aliased in Vector;
- Key : in Key_Type)
- return Find_Reference_Constant_Type
- is
- Found : Boolean;
- I : Base_Peek_Type;
- begin
- if Container.Last = No_Index then
- return (Element => null, Dummy => 1);
- end if;
- Find (Container, Key, Found, I);
- if Found then
- return (Element => Container.Elements (I)'Access, Dummy => 1);
- else
- return (Element => null, Dummy => 1);
- end if;
- end Find_Constant;
-
- overriding function First (Object : Iterator) return Cursor
- is begin
- if Object.Container.Elements = null then
- return (Index => Invalid_Peek_Index);
- else
- return (Index => Peek_Type'First);
- end if;
- end First;
-
- overriding function Last (Object : Iterator) return Cursor
- is begin
- if Object.Container.Elements = null then
- return (Index => Invalid_Peek_Index);
- else
- return (Index => Object.Container.Last);
- end if;
- end Last;
-
- overriding function Next (Object : in Iterator; Position : in Cursor)
return Cursor
- is begin
- if Position.Index = Object.Container.Last then
- return (Index => Invalid_Peek_Index);
- else
- return (Index => Position.Index + 1);
- end if;
- end Next;
-
- overriding function Previous (Object : in Iterator; Position : in Cursor)
return Cursor
- is
- pragma Unreferenced (Object);
- begin
- if Position.Index = Peek_Type'First then
- return (Index => Invalid_Peek_Index);
- else
- return (Index => Position.Index - 1);
- end if;
- end Previous;
-
- function Iterate (Container : aliased in Vector) return
Iterator_Interfaces.Reversible_Iterator'Class
- is begin
- return Iterator'(Container => Container'Access);
- end Iterate;
-
- function Constant_Ref (Container : aliased Vector; Position : in Cursor)
return Constant_Reference_Type
- is begin
- return (Element => Container.Elements (Position.Index)'Access, Dummy =>
1);
- end Constant_Ref;
-
- function Last_Index (Container : in Vector) return Base_Peek_Type
- is begin
- return Container.Last;
- end Last_Index;
-
- function To_Index (Position : in Cursor) return Base_Peek_Type
- is begin
- return Position.Index;
- end To_Index;
-
- function Constant_Ref (Container : aliased Vector; Index : in Peek_Type)
return Constant_Reference_Type
- is begin
- return (Element => Container.Elements (Index)'Access, Dummy => 1);
- end Constant_Ref;
-
-end SAL.Gen_Unbounded_Definite_Vectors_Sorted;
diff --git a/packages/wisi/sal-gen_unbounded_definite_vectors_sorted.ads
b/packages/wisi/sal-gen_unbounded_definite_vectors_sorted.ads
deleted file mode 100644
index 2a52c74..0000000
--- a/packages/wisi/sal-gen_unbounded_definite_vectors_sorted.ads
+++ /dev/null
@@ -1,172 +0,0 @@
--- Abstract :
---
--- A simple unbounded sorted vector of definite items.
---
--- Copyright (C) 2019 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with Ada.Iterator_Interfaces;
-with Ada.Unchecked_Deallocation;
-generic
- type Element_Type is private;
- type Key_Type is private;
- with function To_Key (Item : in Element_Type) return Key_Type;
- with function Key_Compare (Left, Right : in Key_Type) return Compare_Result;
-package SAL.Gen_Unbounded_Definite_Vectors_Sorted is
-
- use all type Ada.Containers.Count_Type;
-
- type Vector is new Ada.Finalization.Controlled with private with
- Constant_Indexing => Constant_Ref,
- Default_Iterator => Iterate,
- Iterator_Element => Element_Type;
-
- Empty_Vector : constant Vector;
-
- overriding procedure Finalize (Container : in out Vector);
- overriding procedure Adjust (Container : in out Vector);
-
- procedure Clear (Container : in out Vector)
- renames Finalize;
-
- function Length (Container : in Vector) return Ada.Containers.Count_Type;
- function Capacity (Container : in Vector) return Ada.Containers.Count_Type;
-
- procedure Set_Capacity
- (Container : in out Vector;
- Length : in Ada.Containers.Count_Type);
- -- Allocates uninitialized memory; does not change Container.First,
- -- Container.Last.
-
- function "&" (Left, Right : in Element_Type) return Vector;
- function "&" (Left : in Vector; Right : in Element_Type) return Vector;
-
- function Contains (Container : in Vector; Key : in Key_Type) return Boolean;
-
- procedure Insert
- (Container : in out Vector;
- New_Item : in Element_Type);
- -- Insert New_Item in sorted position. Items are sorted in increasing
- -- order according to Element_Compare.
- --
- -- Raises Duplicate_Key if To_Key (New_Item) is already in Container.
-
- type Find_Reference_Type (Element : access Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Find
- (Container : aliased in Vector;
- Key : in Key_Type)
- return Find_Reference_Type;
- -- Result.Element is null if Key not in Container. User must not modify
Key.
-
- type Find_Reference_Constant_Type (Element : access constant Element_Type)
is private with
- Implicit_Dereference => Element;
-
- function Find_Constant
- (Container : aliased in Vector;
- Key : in Key_Type)
- return Find_Reference_Constant_Type;
- -- Result.Element is null if Key not in Container.
-
- type Cursor is private;
-
- No_Element : constant Cursor;
-
- function Has_Element (Position : Cursor) return Boolean;
-
- package Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor,
Has_Element);
-
- function Iterate (Container : aliased in Vector) return
Iterator_Interfaces.Reversible_Iterator'Class;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is private with
- Implicit_Dereference => Element;
-
- function Constant_Ref (Container : aliased Vector; Position : in Cursor)
return Constant_Reference_Type
- with Inline,
- Pre => To_Index (Position) in Container.First_Index ..
Container.Last_Index;
-
- function First_Index (Container : in Vector) return Peek_Type is
(Peek_Type'First);
- function Last_Index (Container : in Vector) return Base_Peek_Type
- with Inline;
- function To_Index (Position : in Cursor) return Base_Peek_Type;
- function Constant_Ref (Container : aliased Vector; Index : in Peek_Type)
return Constant_Reference_Type
- with Inline,
- Pre => Index in Container.First_Index .. Container.Last_Index;
-
-private
-
- type Array_Type is array (SAL.Peek_Type range <>) of aliased Element_Type;
- type Array_Access is access Array_Type;
- procedure Free is new Ada.Unchecked_Deallocation (Array_Type, Array_Access);
-
- No_Index : constant Base_Peek_Type := 0;
-
- type Vector is new Ada.Finalization.Controlled with
- record
- Elements : Array_Access;
- -- Elements may be non-null with First = No_Index, after
- -- Set_Capacity. If First /= No_Index and Last >= First, Elements /=
- -- null.
- Last : Base_Peek_Type := No_Index;
- end record;
-
- type Vector_Access is access constant Vector;
- for Vector_Access'Storage_Size use 0;
-
- type Cursor is record
- Index : Base_Peek_Type := No_Index;
- end record;
-
- type Iterator (Container : not null access constant Vector) is new
Iterator_Interfaces.Reversible_Iterator
- with null record;
-
- overriding function First (Object : Iterator) return Cursor;
- overriding function Last (Object : Iterator) return Cursor;
-
- overriding function Next
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
- overriding function Previous
- (Object : Iterator;
- Position : Cursor) return Cursor;
-
- type Find_Reference_Type (Element : access Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- type Find_Reference_Constant_Type (Element : access constant Element_Type)
is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- type Constant_Reference_Type (Element : not null access constant
Element_Type) is
- record
- Dummy : Integer := raise Program_Error with "uninitialized reference";
- end record;
-
- Empty_Vector : constant Vector := (Ada.Finalization.Controlled with others
=> <>);
-
- No_Element : constant Cursor := (others => <>);
-
- ----------
- -- Visible for child package
-
- procedure Grow (Elements : in out Array_Access; Index : in Base_Peek_Type);
-
-end SAL.Gen_Unbounded_Definite_Vectors_Sorted;
diff --git a/packages/wisi/sal-gen_unconstrained_array_image.adb
b/packages/wisi/sal-gen_unconstrained_array_image.adb
deleted file mode 100644
index 7ea1c83..0000000
--- a/packages/wisi/sal-gen_unconstrained_array_image.adb
+++ /dev/null
@@ -1,34 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-function SAL.Gen_Unconstrained_Array_Image (Item : in Array_Type) return String
-is
- Result : Unbounded_String := To_Unbounded_String ("(");
-begin
- for I in Item'Range loop
- Result := Result & Element_Image (Item (I));
- if I = Item'Last then
- Result := Result & ")";
- else
- Result := Result & ", ";
- end if;
- end loop;
- return To_String (Result);
-end SAL.Gen_Unconstrained_Array_Image;
diff --git a/packages/wisi/sal-gen_unconstrained_array_image.ads
b/packages/wisi/sal-gen_unconstrained_array_image.ads
deleted file mode 100644
index 226ba00..0000000
--- a/packages/wisi/sal-gen_unconstrained_array_image.ads
+++ /dev/null
@@ -1,24 +0,0 @@
--- Abstract :
---
--- Image for unconstrained Ada array types
---
--- Copyright (C) 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-generic
- type Index_Type is (<>);
- type Element_Type is private;
- type Array_Type is array (Index_Type range <>) of Element_Type;
- with function Element_Image (Item : in Element_Type) return String;
-function SAL.Gen_Unconstrained_Array_Image (Item : in Array_Type) return
String;
diff --git a/packages/wisi/sal-gen_unconstrained_array_image_aux.adb
b/packages/wisi/sal-gen_unconstrained_array_image_aux.adb
deleted file mode 100644
index 9e4c5cd..0000000
--- a/packages/wisi/sal-gen_unconstrained_array_image_aux.adb
+++ /dev/null
@@ -1,33 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019, 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-function SAL.Gen_Unconstrained_Array_Image_Aux (Item : in Array_Type; Aux : in
Aux_Data) return String
-is
- Result : Unbounded_String := To_Unbounded_String ("(");
-begin
- for I in Item'Range loop
- Result := Result & Element_Image (Item (I), Aux);
- if I < Item'Last then
- Result := Result & ", ";
- end if;
- end loop;
- Result := Result & ")";
- return To_String (Result);
-end SAL.Gen_Unconstrained_Array_Image_Aux;
diff --git a/packages/wisi/sal-gen_unconstrained_array_image_aux.ads
b/packages/wisi/sal-gen_unconstrained_array_image_aux.ads
deleted file mode 100644
index ad2b9cb..0000000
--- a/packages/wisi/sal-gen_unconstrained_array_image_aux.ads
+++ /dev/null
@@ -1,25 +0,0 @@
--- Abstract :
---
--- Image for unconstrained Ada array types
---
--- Copyright (C) 2019, 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-generic
- type Index_Type is (<>);
- type Element_Type is private;
- type Array_Type is array (Index_Type range <>) of Element_Type;
- type Aux_Data (<>) is private;
- with function Element_Image (Item : in Element_Type; Aux : in Aux_Data)
return String;
-function SAL.Gen_Unconstrained_Array_Image_Aux (Item : in Array_Type; Aux : in
Aux_Data) return String;
diff --git a/packages/wisi/sal-generic_decimal_image.adb
b/packages/wisi/sal-generic_decimal_image.adb
deleted file mode 100644
index 2699277..0000000
--- a/packages/wisi/sal-generic_decimal_image.adb
+++ /dev/null
@@ -1,48 +0,0 @@
--- Abstract:
---
--- see spec
---
--- Copyright (C) 2005, 2006, 2009 Stephen Leake. All Rights Reserved.
---
--- This library is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This library is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
--- MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-function SAL.Generic_Decimal_Image
- (Item : in Number_Type;
- Width : in Natural)
- return String
-is
- pragma Warnings (Off);
- -- Avoid warning about "abs applied to non-negative value has no
- -- effect" for some instantiations.
- Temp : Integer := abs Integer (Item);
- -- IMPROVEME: need test for Decimal_Image, include constrained positive
number_type
- pragma Warnings (On);
- Digit : Integer;
- Image : String (1 .. Width);
-begin
- for I in reverse Image'Range loop
- Digit := Temp mod 10;
- Temp := Temp / 10;
- Image (I) := Character'Val (Character'Pos ('0') + Digit);
- end loop;
- return Image;
-end SAL.Generic_Decimal_Image;
diff --git a/packages/wisi/sal-generic_decimal_image.ads
b/packages/wisi/sal-generic_decimal_image.ads
deleted file mode 100644
index ec749f6..0000000
--- a/packages/wisi/sal-generic_decimal_image.ads
+++ /dev/null
@@ -1,37 +0,0 @@
--- Abstract:
---
--- Generic leading zero unsigned decimal image
---
--- Copyright (C) 2004, 2009, 2019 Free Software Foundation. All Rights
Reserved.
---
--- This library is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This library is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
--- MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-generic
- type Number_Type is range <>;
-function SAL.Generic_Decimal_Image
- (Item : in Number_Type;
- Width : in Natural)
- return String;
--- Return a decimal unsigned image of Item, padded with leading zeros
--- to Width. If Width is too small for Item, leading digits are
--- silently truncated.
-pragma Pure (SAL.Generic_Decimal_Image);
diff --git a/packages/wisi/sal.adb b/packages/wisi/sal.adb
deleted file mode 100644
index 6265651..0000000
--- a/packages/wisi/sal.adb
+++ /dev/null
@@ -1,32 +0,0 @@
--- Abstract:
---
--- See spec.
---
--- Copyright (C) 1997 - 2004, 2006, 2009, 2019, 2020 Free Software
Foundation, Inc.
---
--- SAL is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the
--- Free Software Foundation; either version 3, or (at your option) any
--- later version. SAL is distributed in the hope that it will be
--- useful, but WITHOUT ANY WARRANTY; without even the implied warranty
--- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
--- General Public License for more details. You should have received a
--- copy of the GNU General Public License distributed with SAL; see
--- file COPYING. If not, write to the Free Software Foundation, 59
--- Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- SAL, or you link SAL object files with other files to produce
--- an executable, that does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
---
-package body SAL is
-
- function Version return String is
- begin
- return "SAL 3.5";
- end Version;
-
-end SAL;
diff --git a/packages/wisi/sal.ads b/packages/wisi/sal.ads
deleted file mode 100644
index 1e63dbc..0000000
--- a/packages/wisi/sal.ads
+++ /dev/null
@@ -1,75 +0,0 @@
--- Abstract:
---
--- Root package for Stephe's Ada Library packages.
---
--- See sal.html for more information.
---
--- See http://stephe-leake.org/ada/sal.html for the
--- latest version.
---
--- Contact Stephe at stephen_leake@stephe-leake.org.
---
--- Copyright (C) 1997 - 2004, 2008, 2009, 2015, 2017, 2018 Free Software
Foundation, Inc.
---
--- SAL is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the
--- Free Software Foundation; either version 3, or (at your option) any
--- later version. SAL is distributed in the hope that it will be
--- useful, but WITHOUT ANY WARRANTY; without even the implied warranty
--- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
--- General Public License for more details. You should have received a
--- copy of the GNU General Public License distributed with SAL; see
--- file COPYING. If not, write to the Free Software Foundation, 59
--- Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- SAL, or you link SAL object files with other files to produce
--- an executable, that does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-
-package SAL is
- pragma Pure;
-
- function Version return String;
- -- Returns string with format "SAL x.xx".
-
- Container_Empty : exception;
- Container_Full : exception;
- Config_File_Error : exception;
- Domain_Error : exception;
- Duplicate_Key : exception;
- Initialization_Error : exception;
- Invalid_Format : exception;
- Invalid_Limit : exception;
- Invalid_Operation : exception;
- Invalid_Range : exception;
- Iterator_Error : exception;
- Not_Found : exception;
- Not_Implemented : exception;
- Parameter_Error : exception;
- Programmer_Error : exception;
- Range_Error : exception;
-
- --------------
- -- General options
-
- type Direction_Type is (Forward, Backward);
-
- type Duplicate_Action_Type is (Allow, Ignore, Error);
-
- type Overflow_Action_Type is (Overwrite, Error);
-
- -- We use a new type for Peek_Type, not just
- -- Ada.Containers.Count_Type, to enforce Peek_Type'First = top/first.
- type Base_Peek_Type is new Ada.Containers.Count_Type range 0 ..
Ada.Containers.Count_Type'Last;
- subtype Peek_Type is Base_Peek_Type range 1 .. Base_Peek_Type'Last;
- Invalid_Peek_Index : constant Base_Peek_Type := 0;
-
- type Compare_Result is (Less, Equal, Greater);
-end SAL;
diff --git a/packages/wisi/standard_common.gpr
b/packages/wisi/standard_common.gpr
deleted file mode 100644
index ce019c7..0000000
--- a/packages/wisi/standard_common.gpr
+++ /dev/null
@@ -1,152 +0,0 @@
--- Abstract :
---
--- Standard settings for all of Stephe's Ada projects.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-project Standard_Common is
- for Source_Dirs use ();
-
- type Build_Type is ("Debug", "Normal");
- Build : Build_Type := External ("Standard_Common_Build", "Normal");
-
- type Profile_Type is ("On", "Off");
- Profile : Profile_Type := External ("Standard_Common_Profile", "Off");
-
- type Mem_Check_Type is ("On", "Off");
- Mem_Check : Profile_Type := External ("Standard_Common_Mem_Check", "Off");
- -- Note that Mem_Check requires Build_Type = Debug to be useful
-
- -- In main project file, add:
- -- case Standard_Common.Mem_Check is
- -- when "On" =>
- -- for Runtime ("Ada") use "adalib_debug";
- -- when "Off" =>
- -- null;
- -- end case;
-
- package Compiler is
- -- Switches for gcc
-
- Base_Style_Checks := "-gnaty3abcefhiklnOprtx";
- Line_Length := "-gnatyM120";
-
- Style_Checks := (Base_Style_Checks, Line_Length);
-
- Common_Switches :=
- (
- "-fstack-check",
- "-g",
- "-gnat2012",
- "-gnatfqQ", -- f = all error messages, qQ = process semantics,
generate .ali if syntax errors
- "-gnatw.d", -- warnings about tags
- "-gnatwaBCeJL", -- wa = most warnings, wB = no warn on bad fixed
values, wC = no warn on conditionals
- -- we = error on warning, wJ = no warn on
obsolescent, wL = no warn on elaboration
- "-gnatyO" -- warn on overriding
- );
-
- -- -gnatVa causes some inline procedures to be non-inlineable;
- -- suppress that warning with -gnatwP.
- Debug_Switches := Common_Switches &
- (
- "-O0", -- we don't use -Og because that causes gdb to report
incorrect results in some cases in Ada.
- "-gnata", -- assertions, pre/post-conditions
- "-gnatVa", -- validity checks
- "-gnateE", -- extra info in exceptions
- "-gnatwaP" -- no warn on Inline
- );
-
- -- -O3 is measurably faster than -O2 for wisitoken generate
- -- LR1. We include -fstack-check because it catches
- -- hard-to-find bugs, and the processors are so fast.
- -- -fno-var-tracking-assignments speeds compiling of large
- -- files; var tracking is only useful for debugging.
- Base_Release_Switches := Common_Switches &
- (
- "-O3",
- "-fno-var-tracking-assignments",
- "-gnatyO"
- );
-
- Inlining := ("-gnatn");
-
- Release_Switches := Base_Release_Switches & Inlining;
-
- -- No -ansi; GNAT 7.1 compiler C header files are mingw 64, which don't
support -ansi
- Debug_Switches_C := ("-Wall", "-Wstrict-prototypes", "-pedantic",
"-Werror", "-g", "-O0", "-funwind-tables");
- Debug_Switches_C_Non_Pedantic := ("-Wall", "-Wstrict-prototypes",
"-Werror", "-g", "-O0", "-funwind-tables");
- Release_Switches_C := ("-Wall", "-Wstrict-prototypes", "-pedantic",
"-Werror", "-g", "-O2", "-funwind-tables");
- Release_Switches_C_Non_Pedantic := ("-Wall", "-Wstrict-prototypes",
"-Werror", "-g", "-O2", "-funwind-tables");
-
- end Compiler;
-
- -- In project files, normally use this:
- -- package Compiler is
- -- for Default_Switches ("Ada") use
- -- Standard_Common.Compiler.Release_Switches &
- -- Standard_Common.Compiler.Style_Checks;
- -- end Compiler;
-
- package Builder is
- -- Switches for gnatmake
- for Default_Switches ("Ada") use ("-C");
-
- case Profile is
- when "On" =>
- for Global_Compilation_Switches ("Ada") use ("-pg");
- when "Off" =>
- null;
- end case;
- end Builder;
-
- -- In project files, normally use this:
- -- package Builder is
- -- for Default_Switches ("Ada") use
Standard_Common.Builder'Default_Switches ("Ada");
- -- end Builder;
-
- package Binder is
- -- Switches for gnatbind
- for Default_Switches ("Ada") use ("-E");
-
- Debug_Configuration_Pragmas := "Normalize_Scalars";
- end Binder;
-
- -- In project files, normally use this:
- -- package Binder is
- -- for Default_Switches ("Ada") use
Standard_Common.Binder'Default_Switches ("Ada");
- -- end Binder;
-
- package Linker is
- case Profile is
- when "On" =>
- case Mem_Check is
- when "On" =>
- for Linker_Options use ("-pg", "-lgmem");
- when "Off" =>
- for Linker_Options use ("-pg");
- end case;
-
- when "Off" =>
- case Mem_Check is
- when "On" =>
- for Linker_Options use ("-lgmem");
- when "Off" =>
- null;
- end case;
- end case;
- end Linker;
-
- -- In project files, no linker package is needed.
-end Standard_Common;
diff --git a/packages/wisi/wisi-fringe.el b/packages/wisi/wisi-fringe.el
deleted file mode 100644
index 2194b09..0000000
--- a/packages/wisi/wisi-fringe.el
+++ /dev/null
@@ -1,152 +0,0 @@
-;;; wisi-fringe.el --- show approximate error locations in the fringe
-;;
-;; Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-;;
-;; Design:
-;;
-;; Bitmaps are displayed in the fringe by putting a 'display property
-;; on buffer text. However, just doing that also hides the buffer
-;; text. To avoid that, we put the ’display property on a string, and
-;; then an overlay containing that string as ’before-string or
-;; ’after-string on the newline of a buffer line.
-;;
-;; We show approximate error positions in the entire buffer with
-;; single-pixel lines in the right fringe, and mark error lines with
-;; ’!!’ in the left fringe.
-
-(defun wisi-fringe-create-bitmaps ()
- "Return an array of bitmap symbols containing the fringe bitmaps."
- ;; First create the ’!!’ bitmap.
- (define-fringe-bitmap 'wisi-fringe--double-exclaim-bmp
- (vector
- #b00000000
- #b01100110
- #b01100110
- #b01100110
- #b01100110
- #b01100110
- #b00000000
- #b01100110
- #b01010110
- #b00000000))
-
- ;; In condensing the entire buffer to the current window height, we
- ;; assume a 10 point font, which allows 6 distinct line positions
- ;; each one pixel high, with one blank pixel between.
-
- (let ((result (make-vector 64 nil))
- (i 1))
- (while (<= i (length result))
- (aset result (1- i)
- (define-fringe-bitmap (intern (format "wisi-fringe--line-%d-bmp" i))
- (vector
- (if (>= i 32) #b11111111 #b00000000)
- #b00000000
- (if (>= (% i 32) 16) #b11111111 #b00000000)
- #b00000000
- (if (>= (% i 16) 8) #b11111111 #b00000000)
- #b00000000
- (if (>= (% i 8) 4) #b11111111 #b00000000)
- #b00000000
- (if (>= (% i 4) 2) #b11111111 #b00000000)
- #b00000000
- (if (>= (% i 2) 1) #b11111111 #b00000000)
- )))
- (setq i (1+ i)))
- result))
-
-(defconst wisi-fringe-bitmaps (wisi-fringe-create-bitmaps)
- "Array of 64 bitmap symbols.")
-
-(defun wisi-fringe--put-right (line bitmap-index)
- (save-excursion
- (goto-char (point-min))
- (forward-line (1- line))
- (let* ((endpos (line-end-position))
- (ov (make-overlay endpos (1+ endpos)))
- (bmp (aref wisi-fringe-bitmaps bitmap-index)))
- (overlay-put ov 'after-string (propertize "-" 'display (list
'right-fringe bmp 'compilation-error)))
- (overlay-put ov 'wisi-fringe t)
- )))
-
-(defun wisi-fringe--put-left (line)
- (save-excursion
- (goto-char (point-min))
- (forward-line (1- line))
- (let* ((endpos (line-end-position))
- (ov (make-overlay endpos (1+ endpos)))
- (bmp 'wisi-fringe--double-exclaim-bmp))
- (overlay-put ov 'before-string (propertize "-" 'display (list
'left-fringe bmp 'compilation-error)))
- (overlay-put ov 'wisi-fringe t)
- )))
-
-(defun wisi-fringe--scale (error-line buffer-lines window-line-first
window-lines)
- "Return a cons (LINE . BIN) for ERROR-LINE,
-where LINE is the line to display the error bar on, and BIN is a
-6-bit bit vector giving the relative position in that line.
-BUFFER-LINES is the count of lines in the buffer.
-WINDOW-LINE-FIRST is the first and last lines of the buffer
-visible in the window. WINDOW-LINES is the count of lines visible
-in the window."
- ;; If the end of buffer is inside the window, and this calculation
- ;; puts a mark after that, it will actually be put on the last real
- ;; line. That’s good enough for our purposes.
-
- ;; partial-lines / window-line = 6
- ;; buffer-lines / window-line = 1/scale
- ;; buffer-lines / partial-line = (window-line / partial-lines) *
(buffer-lines / window-line) = 1/6 * 1/scale
- (let* ((scale (/ window-lines (float buffer-lines)))
- (line (floor (* scale error-line)))
- (rem (- error-line (floor (/ line scale)))))
- (cons (+ window-line-first line) (lsh 1 (min 5 (floor (* rem (* 6
scale))))))))
-
-(defun wisi-fringe-clean ()
- "Remove all wisi-fringe marks."
- (remove-overlays (point-min) (point-max) 'wisi-fringe t))
-
-(defun wisi-fringe-display-errors (positions)
- "Display markers in the left and right fringe for each buffer position in
POSITIONS.
-The buffer containing POSITIONS must be current, and the window
-displaying that buffer must be current."
- ;; We don't recompute fringe display on scroll, because the user
- ;; will probably have edited the code by then, triggering a new
- ;; parse.
- (wisi-fringe-clean)
- (let (scaled-posns
- (buffer-lines (line-number-at-pos (point-max)))
- (window-lines (window-height))
- (window-pos-first (window-start))
- (window-pos-last (window-end))
- (window-line-first (line-number-at-pos (window-start))))
- (dolist (pos positions)
- (let* ((line (line-number-at-pos pos))
- (scaled-pos (wisi-fringe--scale line buffer-lines
window-line-first window-lines)))
- (when (and (>= pos window-pos-first)
- (<= pos window-pos-last))
- (wisi-fringe--put-left line))
- (if (and scaled-posns
- (= (caar scaled-posns) (car scaled-pos)))
- (setcdr (car scaled-posns) (logior (cdar scaled-posns) (cdr
scaled-pos)))
- (push scaled-pos scaled-posns))
- ))
-
- (dolist (pos scaled-posns)
- (wisi-fringe--put-right (car pos) (1- (cdr pos))))
- ))
-
-(provide 'wisi-fringe)
diff --git a/packages/wisi/wisi-parse-common.el
b/packages/wisi/wisi-parse-common.el
deleted file mode 100644
index 2140b50..0000000
--- a/packages/wisi/wisi-parse-common.el
+++ /dev/null
@@ -1,403 +0,0 @@
-;;; wisi-parse-common.el --- declarations used by wisi-parse.el,
wisi-ada-parse.el, and wisi.el -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2014, 2015, 2017 - 2019 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@member.fsf.org>
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Code:
-
-(defcustom wisi-partial-parse-threshold 100001
- "Minimum size that will be parsed by each call to the parser.
-A parse is always requested at a point (or on a region); the
-point is first expanded to a start point before the region and an
-end point after the region, that the parser can gracefully
-handle. If the final region covers the entire buffer, a complete
-parse is done. Indent assumes the start point of the parse region
-is properly indented. Most navigate parses ignore this setting
-and parse the whole buffer."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-partial-parse-threshold)
-
-(cl-defstruct (wisi--lexer-error)
- pos ;; position (integer) in buffer where error was detected.
- message ;; string error message
- inserted ;; char inserted after pos.
- )
-
-(cl-defstruct (wisi--parse-error-repair)
- pos ;; position (integer) in buffer where insert/delete is done.
- inserted ;; list of token IDs that were inserted before pos
- deleted ;; list of token IDs that were deleted after pos
- deleted-region ;; buffer (cons FIRST LAST) region deleted
- )
-
-(cl-defstruct (wisi--parse-error)
- ;; Includes information derived from compiler error recovery to edit
- ;; text to fix one error. Used by ’wisi-repair-error’ to edit buffer.
- pos ;; position (integer or marker) in buffer where error was detected.
- message ;; string error message
- repair ;; list of wisi--parse-error-repair.
- )
-
-(cl-defstruct wisi-parser
- ;; Separate lists for lexer and parse errors, because lexer errors
- ;; must be repaired first, before parse errors can be repaired. And
- ;; they have different structures.
- lexer-errors
- ;; list of wisi--lexer-errors from last parse. Can be more than one if
- ;; lexer supports error recovery.
- parse-errors
- ;; List of wisi--parse-errors from last parse. Can be more than one if
- ;; parser supports error recovery.
-
- repair-image
- ;; alist of (TOKEN-ID . STRING); used by repair error
-)
-
-(cl-defgeneric wisi-parse-format-language-options ((parser wisi-parser))
- "Return a string to be sent to the parser, containing settings
-for the language-specific parser options."
- )
-
-(cl-defgeneric wisi-parse-expand-region ((_parser wisi-parser) begin end)
- "Return a cons SEND-BEGIN . SEND-END that is an expansion of
-region BEGIN END that starts and ends at points the parser can
-handle gracefully."
- (cons begin end))
-
-(defvar-local wisi--parser nil
- "The current wisi parser; a ‘wisi-parser’ object.")
-
-(defun wisi-read-parse-action ()
- "Read a parse action symbol from the minibuffer."
- (intern-soft (completing-read "parse action (indent): " '(face navigate
indent) nil t nil nil 'indent)))
-
-(defun wisi-search-backward-skip (regexp skip-p)
- "Search backward for REGEXP. If SKIP-P returns non-nil, search again.
-SKIP-P is a function taking no parameters.
-Return nil if no match found before bob."
- (let ((maybe-found-p (search-backward-regexp regexp nil t)))
- (while (and maybe-found-p
- (funcall skip-p)
- (setq maybe-found-p (search-backward-regexp regexp nil t))))
- maybe-found-p))
-
-(defun wisi-search-forward-skip (regexp skip-p)
- "Search forward for REGEXP. If SKIP-P returns non-nil, search again.
-SKIP-P is a function taking no parameters.
-Return nil if no match found before eob."
- (let ((maybe-found-p (search-forward-regexp regexp nil t)))
- (while (and maybe-found-p
- (funcall skip-p)
- (setq maybe-found-p (search-forward-regexp regexp nil t))))
- maybe-found-p))
-
-(defun wisi-show-expanded-region ()
- "For debugging. Expand currently selected region."
- (interactive)
- (let ((region (wisi-parse-expand-region wisi--parser (region-beginning)
(region-end))))
- (message "pre (%d . %d) post %s" (region-beginning) (region-end) region)
- (set-mark (car region))
- (goto-char (cdr region))
- ))
-
-(cl-defgeneric wisi-parse-adjust-indent ((_parser wisi-parser) indent _repair)
- "Adjust INDENT for REPAIR (a wisi--parse-error-repair struct). Return new
indent."
- indent)
-
-(cl-defgeneric wisi-parse-current ((parser wisi-parser) begin send-end
parse-end)
- "Parse current buffer starting at BEGIN, continuing at least thru PARSE-END.
-If using an external parser, send it BEGIN thru SEND-END.")
-
-(cl-defgeneric wisi-refactor ((parser wisi-parser) refactor-action parse-begin
parse-end edit-begin)
- "Send parser command to perform REFACTOR-ACTION on region PARSE-BEGIN
PARSE-END at point EDIT_BEGIN.
-The parse region is not expanded first; it must be the statement
-or declaration containing EDIT_BEGIN.")
-
-(cl-defgeneric wisi-parse-kill ((parser wisi-parser))
- "Kill any external process associated with parser.")
-
-(cl-defgeneric wisi-parse-find-token ((parser wisi-parser) token-symbol)
- "Find token with TOKEN-SYMBOL on current parser stack, return token struct.
-For use in grammar actions.")
-
-(cl-defgeneric wisi-parse-stack-peek ((parser wisi-parser) n)
- "Return the Nth token on the parse stack.
-For use in grammar actions.")
-
-(cl-defstruct
- (wisi-cache
- (:constructor wisi-cache-create)
- (:copier nil))
- nonterm;; nonterminal from parse
-
- token
- ;; terminal symbol from wisi-keyword-table or
- ;; wisi-punctuation-table, or lower-level nonterminal from parse
-
- last ;; pos of last char in token, relative to first (0 indexed)
-
- class ;; one of wisi-class-list
-
- containing
- ;; Marker at the start of the containing statement for this token.
- ;; nil for outermost containing.
-
- prev ;; marker at previous motion token in statement; nil if none
- next ;; marker at next motion token in statement; nil if none
- end ;; marker at token at end of current statement
- )
-
-(defun wisi-get-cache (pos)
- "Return `wisi-cache' struct from the `wisi-cache' text property at POS."
- (get-text-property pos 'wisi-cache))
-
-(defun wisi-backward-cache ()
- "Move point backward to the beginning of the first token preceding point
that has a cache.
-Returns cache, or nil if at beginning of buffer."
- ;; If point is not near cache, p-s-p-c will return pos just after
- ;; cache, so 1- is the beginning of cache.
- ;;
- ;; If point is just after end of cache, p-s-p-c will return pos at
- ;; start of cache.
- ;;
- ;; So we test for the property before subtracting 1.
- (let ((pos (previous-single-property-change (point) 'wisi-cache))
- cache)
- (cond
- ((null pos)
- (goto-char (point-min))
- nil)
-
- ((setq cache (get-text-property pos 'wisi-cache))
- (goto-char pos)
- cache)
-
- (t
- (setq pos (1- pos))
- (setq cache (get-text-property pos 'wisi-cache))
- (goto-char pos)
- cache)
- )))
-
-(defun wisi-forward-cache ()
- "Move point forward to the beginning of the first token after point that has
a cache.
-Returns cache, or nil if at end of buffer."
- (let (cache pos)
- (when (get-text-property (point) 'wisi-cache)
- ;; on a cache; get past it
- (goto-char (1+ (point))))
-
- (setq cache (get-text-property (point) 'wisi-cache))
- (if cache
- nil
-
- (setq pos (next-single-property-change (point) 'wisi-cache))
- (if pos
- (progn
- (goto-char pos)
- (setq cache (get-text-property pos 'wisi-cache)))
- ;; at eob
- (goto-char (point-max))
- (setq cache nil))
- )
- cache
- ))
-
-(defun wisi-cache-region (cache &optional start)
- "Return region designated by START (default point) to cache last."
- (unless start (setq start (point)))
- (cons start (+ start (wisi-cache-last cache))))
-
-(defvar wisi-debug 0
- "wisi debug mode:
-0 : normal - ignore parse errors, for indenting new code
-1 : report parse errors (for running tests)
-2 : show parse states, position point at parse errors
-3 : also show top 10 items of parser stack.")
-
-;; The following parameters are easily changeable for debugging.
-(defvar wisi-action-disable nil
- "If non-nil, disable all elisp actions during parsing.
-Allows timing parse separate from actions.")
-
-(defvar-local wisi-trace-mckenzie 0
- "McKenzie trace level; 0 for none")
-
-(defvar-local wisi-trace-action 0
- "Parse action trace level; 0 for none")
-
-(defvar-local wisi-mckenzie-disable nil
- "If non-nil, disable McKenzie error recovery. Otherwise, use parser
default.")
-
-(defcustom wisi-mckenzie-task-count nil
- "If integer, sets McKenzie error recovery task count.
-Higher value (up to system processor limit) runs error recovery
-faster, but may encounter race conditions. Using only one task
-makes error recovery repeatable; useful for tests. If nil, uses
-value from grammar file."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-mckenzie-task-count)
-
-(defcustom wisi-mckenzie-check-limit nil
- "If integer, sets McKenzie error recovery algorithm token check limit.
-This sets the number of tokens past the error point that must be
-parsed successfully for a solution to be deemed successful.
-Higher value gives better solutions, but may fail if there are
-two errors close together. If nil, uses value from grammar
-file."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-mckenzie-check-limit)
-
-(defcustom wisi-mckenzie-enqueue-limit nil
- "If integer, sets McKenzie error recovery algorithm enqueue limit.
-This sets the maximum number of solutions that will be considered.
-Higher value has more recover power, but will be slower to fail.
-If nil, uses value from grammar file."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-mckenzie-enqueue-limit)
-
-(defcustom wisi-parse-max-parallel 15
- "Maximum number of parallel parsers during regular parsing.
-Parallel parsers are used to resolve redundancy in the grammar.
-If a file needs more than this, it's probably an indication that
-the grammar is excessively redundant."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-
-(defvar wisi-parse-max-stack-size 500
- "Maximum parse stack size.
-Larger stack size allows more deeply nested constructs.")
-;; end of easily changeable parameters
-
-(defvar wisi--parse-action nil
- ;; not buffer-local; only let-bound in wisi-indent-region,
wisi-validate-cache
- "Reason current parse is begin run; one of
-{indent, face, navigate}.")
-
-(defvar-local wisi-indent-comment-col-0 nil
- "If non-nil, comments currently starting in column 0 are left in column 0.
-Otherwise, they are indented with previous comments or code.
-Normally set from a language-specific option.")
-
-(defvar-local wisi-end-caches nil
- "List of buffer positions of caches in current statement that need
wisi-cache-end set.")
-
-(defconst wisi-eoi-term 'Wisi_EOI
- ;; must match FastToken wisi-output_elisp.adb EOI_Name, which must
- ;; be part of a valid Ada identifer.
- "End Of Input token.")
-
-(defconst wisi-class-list
- [motion ;; motion-action
- statement-end
- statement-override
- statement-start
- misc ;; other stuff
- ]
- "array of valid token classes; checked in wisi-statement-action, used in
wisi-process-parse.")
-
-(defun wisi-error-msg (message &rest args)
- (let ((line (line-number-at-pos))
- (col (- (point) (line-beginning-position))))
- (format
- "%s:%d:%d: %s"
- (buffer-name) ;; buffer-file-name is sometimes nil here!?
- line col
- (apply 'format message args))))
-
-(defvar wisi-parse-error nil)
-(put 'wisi-parse-error
- 'error-conditions
- '(error wisi-parse-error))
-(put 'wisi-parse-error
- 'error-message
- "wisi parse error")
-
-(cl-defstruct wisi-tok
- token ;; symbol from a token table ;; IMPROVEME: rename to ’id’?
- region ;; cons giving buffer region containing token text
-
- nonterminal ;; t if a nonterminal
-
- line ;; Line number at start of token. Nil for empty nonterminals
-
- first
- ;; For terminals, t if token is the first token on a line.
- ;;
- ;; For nonterminals, line number of first contained line (not
- ;; including trailing comments) that needs indenting; it is a
- ;; comment, or begins with a contained token.
- ;;
- ;; Otherwise nil.
-
- ;; The following are non-nil if token (terminal or non-terminal) is
- ;; followed by blank or comment lines
- comment-line ;; first blank or comment line following token
- comment-end ;; position at end of blank or comment lines
- )
-
-(defun wisi-token-text (token)
- "Return buffer text from token range."
- (let ((region (wisi-tok-region token)))
- (and region
- (buffer-substring-no-properties (car region) (cdr region)))))
-
-(defun wisi-and-regions (left right)
- "Return region enclosing both LEFT and RIGHT."
- (if left
- (if right
- (cons (min (car left) (car right))
- (max (cdr left) (cdr right)))
- left)
- right))
-
-(defun wisi--set-line-begin (line-count)
- "Return a vector of line-beginning positions, with length LINE-COUNT."
- (let ((result (make-vector line-count 0)))
- (save-excursion
- (goto-char (point-min))
-
- (dotimes (i line-count)
- (aset result i (point))
- (forward-line 1)))
- result))
-
-;;;; debugging
-(defun wisi-tok-debug-image (tok)
- "Return id and region from TOK, as string."
- (cond
- ((wisi-tok-region tok)
- (format "(%s %d . %d)"
- (wisi-tok-token tok)
- (car (wisi-tok-region tok))
- (cdr (wisi-tok-region tok))))
- (t
- (format "(%s)" (wisi-tok-token tok)))
- ))
-
-(provide 'wisi-parse-common)
diff --git a/packages/wisi/wisi-prj.el b/packages/wisi/wisi-prj.el
deleted file mode 100644
index 501c09f..0000000
--- a/packages/wisi/wisi-prj.el
+++ /dev/null
@@ -1,1614 +0,0 @@
-;;; wisi-prj.el --- project integration -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2019 - 2020 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@member.fsf.org>
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Usage:
-;;
-;; See wisi.info (compiled from wisi.texi).
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'find-file)
-(require 'wisi)
-
-(cl-defstruct wisi-prj
- name ;; A user-friendly string, used in menus and messages.
-
- compile-env
- ;; List of strings NAME=VALUE for `compilation-environment'; used
- ;; when running the compiler or makefile. Also prepended to
- ;; `process-environment' when the project file is parsed, or when
- ;; the project file is used by a tool in an external process.
-
- file-env
- ;; Environment (list of strings NAME=VALUE) set in project file;
- ;; prepended to `process-environment' running tools in an external
- ;; process.
-
- compiler
- xref
- ;; xref functionality is often provided by the compiler. We allow
- ;; for separate compiler and xref objects, to handle the case where
- ;; the compiler is a cross-compiler for an embedded target, and xref
- ;; is provided by a host compiler.
-
- (case-exception-files nil)
- ;; List of casing exception files; from `casing' project variable.
- ;;
- ;; New exceptions may be added interactively via
- ;; `wisi-case-create-exception'. If an exception is defined in
- ;; multiple files, the first occurence is used.
- ;;
- ;; The file format is one word per line, which gives the casing to be
- ;; used for that word in source code. If the line starts with
- ;; the character *, then the exception will be used for partial
- ;; words that either start at the beginning of a word or after a _
- ;; character, and end either at the end of the word or at a _
- ;; character. Characters after the first word are ignored, and not
- ;; preserved when the list is written back to the file."
-
- (case-full-exceptions '())
- ;; Alist of full words that have special casing, built from
- ;; case-exception-files. Indexed by properly cased word; value is t.
-
- (case-partial-exceptions '())
- ;; Alist of partial words that have special casing, built from
- ;; project casing files list partial word exceptions. Indexed by
- ;; properly cased word; value is t.
-
- source-path ;; list of absolute directory file names
-
- file-pred
- ;; Function taking an absolute file name, returns non-nil
- ;; if the file should be included in `project-files'.
- )
-
-(defun wisi-prj-require-prj ()
- "Return current `wisi-prj' object.
-Throw an error if current project is not an wisi-prj."
- (let ((prj (project-current)))
- (if (wisi-prj-p prj)
- prj
- (error "current project is not a wisi project."))))
-
-(defun wisi-prj-current-prj ()
- "Return current `wisi-prj' object.
-If (project-current) does not return a wisi-prj, return a default prj."
- (let ((prj (project-current)))
- (if (wisi-prj-p prj)
- prj
- (make-wisi-prj :name "default"))))
-
-(defvar wisi-prj-file-extensions (list "prj")
- "List of wisi project file extensions.
-Used when searching for project files.")
-
-(defvar wisi-prj--cache nil
- "Alist holding currently parsed project objects.
-Indexed by absolute project file name.")
-
-(cl-defgeneric wisi-prj-default (prj)
- "Return a project with default values.
-Used to reset a project before refreshing it.")
-
-(cl-defgeneric wisi-prj-parse-one (_project _name _value)
- "If recognized by PROJECT, set NAME, VALUE in PROJECT, return non-nil.
-Else return nil."
- nil)
-
-(cl-defgeneric wisi-prj-parse-final (_project _prj-file-name)
- "Do any final processing on PROJECT
-after the project file PRJ-FILE-NAME is parsed."
- nil)
-
-(cl-defgeneric wisi-prj-select (project)
- "PROJECT is selected; perform any required actions.")
-
-(cl-defgeneric wisi-prj-deselect (project)
- "PROJECT is deselected; undo any select actions.")
-
-(cl-defgeneric wisi-prj-refresh-cache (prj not-full)
- "Reparse the project file for PRJ, refresh all cached data in PRJ.
-If NOT-FULL is non-nil, very slow refresh operations may be skipped.")
-
-(cl-defgeneric wisi-prj-identifier-ignore-case (prj)
- "Return non-nil if case should be ignored when comparing identifiers.")
-
-;; We provide nil defaults for some methods, because some language
-;; modes don't have a language-specific compiler (eg java-wisi) or
-;; xref process (eg gpr-mode).
-
-(cl-defgeneric wisi-compiler-parse-one (compiler project name value)
- "Set NAME, VALUE in COMPILER, if recognized by COMPILER.
-PROJECT is an `wisi-prj' object; COMPILER is `wisi-prj-compiler'.")
-
-(cl-defgeneric wisi-compiler-parse-final (_compiler _project _prj-file-name)
- "Do any compiler-specific processing on COMPILER and PROJECT
-after the project file PRJ-FILE-NAME is parsed."
- nil)
-
-(cl-defgeneric wisi-compiler-select-prj (_compiler _project)
- "PROJECT has been selected; do any compiler-specific actions required."
- nil)
-
-(cl-defgeneric wisi-compiler-deselect-prj (_compiler _project)
- "PROJECT has been de-selected; undo any compiler-specific select actions."
- nil)
-
-(cl-defgeneric wisi-compiler-show-prj-path (compiler)
- "Display buffer listing project file search path.")
-
-(cl-defgeneric wisi-compiler-fix-error (compiler source-buffer)
- "Attempt to fix a compilation error, return non-nil if fixed.
-Current buffer is compilation buffer; point is at an error message.
-SOURCE-BUFFER contains the source code referenced in the error message.")
-
-(cl-defgeneric wisi-xref-parse-one (_xref _project _name _value)
- "If recognized by XREF, set NAME, VALUE in XREF, return non-nil.
-Else return nil."
- nil)
-
-(cl-defgeneric wisi-xref-parse-final (_xref _project _prj-file-name)
- "Do any xref-specific processing on XREF and PROJECT
-after the project file PRJ-FILE-NAME is parsed."
- nil)
-
-(cl-defgeneric wisi-xref-select-prj (_xref _project)
- "PROJECT has been selected; do any xref-specific actions required."
- nil)
-
-(cl-defgeneric wisi-xref-deselect-prj (_xref _project)
- "PROJECT has been de-selected; undo any xref-specific select actions."
- nil)
-
-(cl-defgeneric wisi-xref-refresh-cache (_xref _project _no-full)
- "Refresh cached information in XREF. If no-full is non-nil,
-slow refresh operations may be skipped."
- nil)
-
-(cl-defgeneric wisi-xref-completion-table (xref project)
- "Return a completion table of names defined in PROJECT, for navigating to
the declarations.
-The table is an alist of (ANNOTATED-SYMBOL . LOC), where:
-
-- ANNOTATED-SYMBOL is the simple name and possibly annotations
-such as function arguments, controlling type, containing package,
-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.")
-
-(cl-defgeneric wisi-xref-completion-at-point-table (xref project)
- "Return a completion table of names defined in PROJECT, for
`completion-at-point'.
-The table is a simple list of symbols.")
-
-(cl-defgeneric wisi-xref-definitions (xref project item)
- "Return all definitions (classwide) of ITEM (an xref-item), as a list of
xref-items.")
-
-(cl-defgeneric wisi-xref-references (xref project item)
- "Return all references to ITEM (an xref-item), as a list of xref-items.")
-
-(cl-defgeneric wisi-xref-other (project &key identifier filename line column)
- "Return cross reference information.
-PROJECT - dispatching object, normally a `wisi-prj' object.
-IDENTIFIER - an identifier or operator_symbol
-FILENAME - absolute filename containing the identifier
-LINE - line number containing the identifier (may be nil)
-COLUMN - Emacs column of the start of the identifier (may be nil)
-Point is on the start of the identifier.
-Returns a list (FILE LINE COLUMN) giving the corresponding location;
-FILE is an absolute file name. If point is at the specification, the
-corresponding location is the
-body, and vice versa.")
-
-(defvar-local wisi-xref-full-path nil
- "If non-nil, xref functions show full paths in results.")
-
-(defun wisi-goto-source (file line column)
- "Find and select FILE, at LINE and COLUMN.
-FILE may be absolute, or on `compilation-search-path'.
-LINE, COLUMN are Emacs origin."
- (let ((file-1
- (if (file-name-absolute-p file) file
- (ff-get-file-name compilation-search-path file))))
- (if file-1
- (setq file file-1)
- (error "File %s not found; installed library, or set project?" file))
- )
-
- (push-mark (point) t)
-
- (let ((buffer (get-file-buffer file)))
- (cond
- ((bufferp buffer)
- ;; use pop-to-buffer, so package other-frame-window works.
- (pop-to-buffer buffer (list #'display-buffer-same-window)))
-
- ((file-exists-p file)
- (find-file file))
-
- (t
- (error "'%s' not found" file))))
-
- ;; move the cursor to the correct position
- (goto-char (point-min))
- (forward-line (1- line))
- (forward-char column))
-
-(defun wisi-show-xref (xref)
- "Display XREF location."
- (let ((marker (xref-location-marker (xref-item-location xref))))
- (push-mark)
- (pop-to-buffer (marker-buffer marker) (list #'display-buffer-same-window))
- (goto-char (marker-position marker))))
-
-(defun wisi-filter-table (table file)
- "If FILE is nil, return TABLE. Otherwise return only items in TABLE with
location FILE."
- (cond
- ((null file)
- table)
-
- (t
- (let (result)
- (dolist (item table)
- (when (string= file (car (cdr item)))
- (push item result)))
- result))))
-
-(defun wisi-get-identifier (prompt)
- "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
- ;; table, because we want a more specific reference.
- (let* ((prj (project-current))
- (def (xref-backend-identifier-at-point prj)))
-
- (cond
- ((or current-prefix-arg
- (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.
- (completing-read prompt table nil nil nil
'xref--read-identifier-history)))
- (if (equal id "")
- (user-error "No identifier provided")
-
- ;; The user may have forced exit from completing-read with a
- ;; string that is not in the table (because gpr-query is out
- ;; of date, for example).
- (or (and (consp (car table)) ;; alist; return key and value.
- (assoc id table))
- id))))
- (t def))))
-
-(defun wisi-goto-spec/body (identifier)
- "Goto declaration or body for IDENTIFIER (default symbol at point).
-If no symbol at point, or with prefix arg, prompt for symbol, goto spec."
- (interactive (list (wisi-get-identifier "Goto spec/body of: ")))
- (let ((prj (project-current))
- desired-loc)
- (cond
- ((consp identifier)
- ;; alist element from wisi-xref-completion-table; desired
- ;; location is primary declaration
- (setq desired-loc
- (xref-make (car identifier)
- (xref-make-file-location
- (nth 0 (cdr identifier)) ;; file
- (nth 1 (cdr identifier)) ;; line
- (nth 2 (cdr identifier)) ;; column
- ))))
-
- ((stringp identifier)
- ;; from xref-backend-identifier-at-point; desired location is 'other'
- (let ((item (wisi-xref-item identifier prj)))
- (condition-case-unless-debug err
- (with-slots (summary location) item
- (let ((eieio-skip-typecheck t))
- (with-slots (file line column) location
- (let ((target
- (wisi-xref-other
- (wisi-prj-xref prj) prj
- :identifier summary
- :filename file
- :line line
- :column column)))
- (setq desired-loc
- (xref-make summary
- (xref-make-file-location
- (nth 0 target) ;; file
- (nth 1 target) ;; line
- (nth 2 target))) ;; column
- )))))
- (user-error ;; from gpr-query; current file might be new to project,
so try wisi-names
- (let ((item (assoc identifier (wisi-names nil t))))
- (if item
- (setq desired-loc
- (xref-make identifier
- (xref-make-file-location
- (nth 1 item) ;; file
- (nth 2 item) ;; line
- (nth 3 item))))
- (signal (car err) (cdr err)))))
- )))
-
- (t ;; something else
- (error "unknown case in wisi-goto-spec/body")))
- (wisi-show-xref desired-loc)
- ))
-
-(cl-defgeneric wisi-prj-identifier-at-point (_project)
- "Return (IDENT START END) giving the identifier and its bounds at point.
-Return nil if no identifier is at point."
- ;; default implementation
- (let ((bounds (bounds-of-thing-at-point 'symbol)))
- (when bounds
- (list (car bounds) (cdr bounds) (buffer-substring-no-properties (car
bounds) (cdr bounds))))))
-
-(defun wisi-completion-at-point ()
- "For `completion-at-point-functions'."
- (let ((prj (project-current)))
- (when (wisi-prj-p prj)
- (save-excursion
- (let ((table (wisi-xref-completion-at-point-table (wisi-prj-xref prj)
prj))
- (bounds (wisi-prj-identifier-at-point prj)))
- (when bounds
- ;; xref symbol table may be out of date; try dabbrevs
- (list (nth 0 bounds) (nth 1 bounds) table :exclusive 'no))
- )))
- ))
-
-(defun wisi-check-current-project (file-name &optional default-prj-function)
- "If FILE-NAME (must be absolute) is found in the current
-project source directories, return the current
-project. Otherwise, if the current project is a wisi project,
-throw an error. If the current project is not a wisi project,
-and DEFAULT-PRJ-FUNCTION is non-nil, use it to return a default
-project. Otherwise throw an error."
- (let ((visited-file (file-truename file-name)) ;; file-truename handles
symbolic links
- (project (project-current)))
- (if (wisi-prj-p project)
- (let ((found-file (locate-file (file-name-nondirectory visited-file)
- (wisi-prj-source-path project))))
- (unless found-file
- (error "current file not part of current project; wrong project?"))
-
- (setq found-file (file-truename found-file))
-
- ;; (nth 10 (file-attributes ...)) is the inode; required when hard
- ;; links are present.
- (let* ((visited-file-inode (nth 10 (file-attributes visited-file)))
- (found-file-inode (nth 10 (file-attributes found-file))))
- (unless (equal visited-file-inode found-file-inode)
- (error "%s (opened) and %s (found in project) are two different
files"
- file-name found-file)))
- project)
-
- ;; create a project?
- (if default-prj-function
- (funcall default-prj-function nil (file-name-directory file-name))
- (error "current project is not a wisi project."))
- )))
-
-(cl-defgeneric wisi-xref-parents (xref project &key identifier filename line
column)
- "Displays parent type declarations.
-XREF - dispatching object.
-PROJECT - a `wisi-prj' object.
-IDENTIFIER - an identifier or operator_symbol
-FILENAME - absolute filename containing the identifier
-LINE - line number containing the identifier
-COLUMN - Emacs column of the start of the identifier
-
-Displays a buffer in compilation-mode giving locations of the parent type
declarations.")
-
-(defun wisi-show-declaration-parents ()
- "Display the locations of the parent type declarations of the type
identifier around point."
- (interactive)
- (let* ((project (wisi-check-current-project (buffer-file-name)))
- (id (wisi-prj-identifier-at-point project)))
- (wisi-xref-parents
- (wisi-prj-xref project)
- project
- :identifier (nth 2 id)
- :filename (file-name-nondirectory (buffer-file-name))
- :line (line-number-at-pos)
- :column (save-excursion (goto-char (nth 0 id)) (current-column)))
- ))
-
-(cl-defgeneric wisi-xref-all (xref project &key identifier filename line
column local-only append)
- "Displays cross reference information.
-XREF - dispatching object.
-PROJECT - a `wisi-prj' object.
-IDENTIFIER - an identifier or operator_symbol (a string).
-FILENAME - absolute filename containing the identifier
-LINE - line number containing the identifier
-COLUMN - Emacs column of the start of the identifier
-LOCAL-ONLY - if t, show references in FILE only
-APPEND - if t, keep previous output in result buffer
-Displays a buffer in compilation-mode giving locations where the
-identifier is declared or referenced.")
-
-(defun wisi-show-references (&optional append)
- "Show all references of identifier at point.
-With prefix, keep previous references in output buffer."
- (interactive "P")
- (let* ((project (wisi-check-current-project (buffer-file-name)))
- (id (wisi-prj-identifier-at-point project)))
- (wisi-xref-all
- (wisi-prj-xref project)
- project
- :identifier (nth 2 id)
- :filename (file-name-nondirectory (buffer-file-name))
- :line (line-number-at-pos)
- :column (save-excursion (goto-char (nth 0 id)) (current-column))
- :local-only nil
- :append append)
- ))
-
-(defun wisi-show-local-references (&optional append)
- "Show all references of identifier at point occuring in current file.
-With prefix, keep previous references in output buffer."
- (interactive "P")
- (let* ((project (wisi-check-current-project (buffer-file-name)))
- (id (wisi-prj-identifier-at-point project)))
- (wisi-xref-all
- (wisi-prj-xref project)
- project
- :identifier (nth 2 id)
- :filename (file-name-nondirectory (buffer-file-name))
- :line (line-number-at-pos)
- :column (save-excursion (goto-char (nth 0 id)) (current-column))
- :local-only t
- :append append)
- ))
-
-(cl-defgeneric wisi-xref-overriding (xref project &key identifier filename
line column)
- "Displays a buffer in compilation-mode giving locations of the overriding
declarations.
-XREF - dispatching object.
-PROJECT - a `wisi-prj' object.
-IDENTIFIER - an identifier or operator_symbol
-FILENAME - filename containing the identifier
-LINE - line number containing the identifier
-COLUMN - Emacs column of the start of the identifier ")
-
-(defun wisi-show-overriding ()
- "Show all overridings of identifier at point."
- (interactive)
- (let* ((project (wisi-check-current-project (buffer-file-name)))
- (id (wisi-prj-identifier-at-point project)))
- (wisi-xref-overriding
- (wisi-prj-xref project)
- project
- :identifier (nth 2 id)
- :filename (file-name-nondirectory (buffer-file-name))
- :line (line-number-at-pos)
- :column (save-excursion (goto-char (nth 0 id)) (current-column)))
- ))
-
-(cl-defgeneric wisi-xref-overridden (xref project &key identifier filename
line column)
- "Returns a list (FILE LINE COLUMN) giving the location of the overridden
declaration.
-XREF - dispatching object.
-PROJECT - a `wisi-prj' object.
-IDENTIFIER - an identifier or operator_symbol
-FILENAME - absolute filename containing the identifier
-LINE - line number containing the identifier
-COLUMN - Emacs column of the start of the identifier")
-
-(defun wisi-show-overridden ()
- "Show the overridden declaration of identifier at point."
- (interactive)
- (let* ((project (wisi-check-current-project (buffer-file-name)))
- (id (wisi-prj-identifier-at-point project))
- (target
- (wisi-xref-overridden
- (wisi-prj-xref project)
- project
- :identifier (nth 2 id)
- :filename (file-name-nondirectory (buffer-file-name))
- :line (line-number-at-pos)
- :column (save-excursion (goto-char (nth 0 id)) (current-column)))))
-
- (wisi-goto-source (nth 0 target)
- (nth 1 target)
- (nth 2 target))
- ))
-
-;;;; wisi-prj specific methods
-
-(cl-defmethod project-roots ((_project wisi-prj))
- ;; Not meaningful
- nil)
-
-(cl-defmethod project-files ((project wisi-prj) &optional dirs)
- (let (result)
- (dolist (dir (or dirs
- (wisi-prj-source-path project)))
- (mapc
- (lambda (absfile)
- (when (and (not (string-equal "." (substring absfile -1)))
- (not (string-equal ".." (substring absfile -2)))
- (not (file-directory-p absfile))
- (or (null (wisi-prj-file-pred project))
- (funcall (wisi-prj-file-pred project) absfile)))
- (push absfile result)))
- (when (file-readable-p dir) ;; GNAT puts non-existing dirs on path.
- (directory-files dir t))))
- result))
-
-(defun wisi-refresh-prj-cache (not-full)
- "Refresh all cached data in the current project, and re-select it.
-With prefix arg, very slow refresh operations may be skipped."
- (interactive "P")
- (let ((prj (project-current)))
- (unless (wisi-prj-p prj)
- (error "current project is not a wisi project"))
- (wisi-prj-refresh-cache prj not-full)
- (wisi-prj-select prj)))
-
-(defvar wisi-prj--current-file nil
- "Current wisi project file (the most recently selected); an
-absolute file name.")
-
-(defun wisi-prj-clear-current ()
- "Clear the current project selection; make no project current."
- (interactive)
- (setq wisi-prj--current-file nil))
-
-(defun wisi-prj-show ()
- "Show name of current project."
- (interactive)
- (message
- (cond
- (wisi-prj--current-file
- (wisi-prj-name (cdr (assoc wisi-prj--current-file wisi-prj--cache))))
- (t
- (let ((prj (project-current)))
- (if (wisi-prj-p prj)
- (wisi-prj-name prj)
- "not a wisi project"))))))
-
-(cl-defmethod wisi-prj-parse-final (project _prj-file)
- (wisi--case-read-all-exceptions project))
-
-(cl-defmethod wisi-prj-refresh-cache ((project wisi-prj) not-full)
- (when wisi-prj--cache
- (wisi-prj-deselect project)
- (let ((prj-file (car (rassoc project wisi-prj--cache))))
- (setq wisi-prj--cache (delete (cons prj-file project) wisi-prj--cache))
- (setq project (wisi-prj-default project))
- (wisi-prj-parse-file :prj-file prj-file :init-prj project :cache t)
- (wisi-xref-refresh-cache (wisi-prj-xref project) project not-full)
- (wisi-prj-select project))))
-
-(cl-defmethod wisi-prj-select ((project wisi-prj))
- (setq compilation-search-path (wisi-prj-source-path project))
-
- ;; ‘compilation-environment’ is buffer-local, but the user might
- ;; delete that buffer. So set both global and local.
- (let ((comp-env
- (append
- (wisi-prj-compile-env project)
- (wisi-prj-file-env project)
- (copy-sequence (wisi-prj-file-env project))))
- (comp-buf (get-buffer "*compilation*")))
- (when (buffer-live-p comp-buf)
- (with-current-buffer comp-buf
- (setq compilation-environment comp-env)))
- (set-default 'compilation-environment comp-env))
-
- (wisi-compiler-select-prj (wisi-prj-compiler project) project)
- (wisi-xref-select-prj (wisi-prj-xref project) project))
-
-(cl-defmethod wisi-prj-deselect ((project wisi-prj))
- (wisi-xref-deselect-prj (wisi-prj-xref project) project)
- (wisi-compiler-deselect-prj (wisi-prj-compiler project) project)
- (setq compilation-environment nil)
- (setq compilation-search-path nil))
-
-(defvar wisi-prj-parse-hook nil
- "Hook run at start of `wisi-prj-parse-file'.")
-
-(defvar wisi-prj-parser-alist (list (cons "prj" #'wisi-prj-parse-file-1))
- "Alist of parsers for project files, indexed by file extension.
-Parser is called with two arguments; the project file name and
-a project. Parser should update the project with values from the file.")
-
-(cl-defmethod wisi-prj-parse-one (project name value)
- "If NAME is a wisi-prj slot, set it to VALUE, return t.
-Else return nil."
- (cond
- ((string= name "casing")
- (cl-pushnew (expand-file-name
- (substitute-in-file-name value))
- (wisi-prj-case-exception-files project)
- :test #'string-equal)
- t)
-
- ((string= name "src_dir")
- (cl-pushnew (directory-file-name (expand-file-name
(substitute-in-file-name value)))
- (wisi-prj-source-path project)
- :test #'string-equal)
- t)
-
- ((= ?$ (elt name 0))
- ;; Process env var.
- (setf (wisi-prj-file-env project)
- (cons (concat (substring name 1) "=" (substitute-in-file-name value))
- (wisi-prj-file-env project)))
- t)
-
- ))
-
-(defvar-local wisi-prj-parse-undefined-function nil
- "Function called if a project file variable name is not recognized.
-Called with three args: PROJECT NAME VALUE.")
-
-(defun wisi-prj-parse-file-1 (prj-file project)
- "Wisi project file parser."
- (with-current-buffer (find-file-noselect prj-file)
- (goto-char (point-min))
-
- ;; process each line
- (while (not (eobp))
-
- ;; ignore lines that don't have the format "name=value", put
- ;; 'name', 'value' in match-string.
- (when (looking-at "^\\([^= \n]+\\)=\\(.*\\)")
- (let ((name (match-string 1))
- (value (match-string 2))
- result)
-
- ;; Both compiler and xref need to see some settings; eg gpr_file, env
vars.
- (when (wisi-compiler-parse-one (wisi-prj-compiler project) project
name value)
- (setq result t))
- (when (wisi-xref-parse-one (wisi-prj-xref project) project name value)
- (setq result t))
-
- (unless result
- (setq result (wisi-prj-parse-one project name value)))
-
- (when (and (not result)
- wisi-prj-parse-undefined-function)
- (funcall wisi-prj-parse-undefined-function project name value))
-
- ))
-
- (forward-line 1)
- )
- ))
-
-(cl-defun wisi-prj-parse-file (&key prj-file init-prj cache)
- "Read project file PRJ-FILE with default values from INIT-PRJ.
-PRJ-FILE parser is from `wisi-prj-parser-alist'; if that yields
-no parser, no error occurs; the file is just a placeholder. If
-CACHE is non-nil, add the project to `wisi-prj--cache'. In any
-case, return the project."
- (setq prj-file (expand-file-name prj-file))
-
- (run-hooks 'wisi-prj-parse-hook)
-
- (let* ((default-directory (file-name-directory prj-file))
- (parser (cdr (assoc (file-name-extension prj-file)
wisi-prj-parser-alist)))
- (project init-prj)
- (process-environment (append (wisi-prj-compile-env init-prj)
process-environment)))
-
- (when parser
- ;; If no parser, prj-file is just a placeholder; there is no file to
parse.
- ;; For example, sal-android-prj has no project file.
- (funcall parser prj-file project)
- (wisi-prj-parse-final project prj-file)
- (wisi-compiler-parse-final (wisi-prj-compiler project) project prj-file)
- (wisi-xref-parse-final (wisi-prj-xref project) project prj-file))
-
- (when cache
- ;; Cache the project properties
- (if (assoc prj-file wisi-prj--cache)
- (setcdr (assoc prj-file wisi-prj--cache) project)
- (push (cons prj-file project) wisi-prj--cache)))
-
- project))
-
-(defun wisi-prj-show-prj-path ()
- "Show the compiler project file search path."
- (interactive)
- (wisi-compiler-show-prj-path (wisi-prj-compiler (wisi-prj-require-prj))))
-
-(defun wisi-prj-show-src-path ()
- "Show the project source file search path."
- (interactive)
- (if compilation-search-path
- (progn
- (pop-to-buffer (get-buffer-create "*source file search path*"))
- (erase-buffer)
- (dolist (file compilation-search-path)
- (insert (format "%s\n" file))))
- (message "no source file search path set")
- ))
-
-(defun wisi-fix-compiler-error ()
- "Attempt to fix the current compiler error.
-Point must be at the source location referenced in a compiler error.
-In `compilation-last-buffer', point must be at the compiler error.
-Leave point at fixed code."
- (interactive)
- (let ((source-buffer (current-buffer))
- (line-move-visual nil)); screws up next-line otherwise
-
- (cond
- ((equal compilation-last-buffer wisi-error-buffer)
- (set-buffer source-buffer)
- (wisi-repair-error))
-
- (t
- (with-current-buffer compilation-last-buffer
- (let ((comp-buf-pt (point))
- (success
- (wisi-compiler-fix-error
- (wisi-prj-compiler (wisi-prj-require-prj))
- source-buffer)))
- ;; restore compilation buffer point
- (set-buffer compilation-last-buffer)
- (goto-char comp-buf-pt)
-
- (unless success
- (error "error not recognized"))
- )))
- )))
-
-;;;; auto-casing
-
-(defvar-local wisi-auto-case nil
- "Buffer-local value indicating whether to change case while typing.
-When non-nil, automatically change case of preceding word while
-typing. Casing of keywords is done according to
-`wisi-case-keyword', identifiers according to
-`wisi-case-identifier'."
- ;; This is not a defcustom, because it's buffer-local.
- )
-
-(defvar-local wisi-case-keyword 'lower-case
- "Indicates how to adjust the case of `wisi-keywords'.
-Value is one of lower-case, upper-case."
- ;; This is not a defcustom, because it's buffer-local
- )
-
-(defvar-local wisi-case-identifier 'mixed-case
- "Buffer-local value indicating how to case language keywords.
-Value is one of:
-
-- mixed-case : Mixed_Case
-- lower-case : lower_case
-- upper-case : UPPER_CASE")
-
-(defvar-local wisi-case-strict t
- "If nil, preserve uppercase chars in identifiers.")
-
-(defvar-local wisi-language-keywords nil
- "List of keywords for auto-case.")
-
-(defvar-local wisi-case-adjust-p-function nil
- "Function taking one argument, the typed char; called from wisi-case-adjust.
-Return non-nil if case of symbol at point should be adjusted.
-Point is on last char of symbol.")
-
-(defun wisi-case-show-files ()
- "Show casing files list for the current project."
- (interactive)
- (let ((project (project-current)))
-
- (if (and (wisi-prj-p project)
- (wisi-prj-case-exception-files project))
- (progn
- (pop-to-buffer (get-buffer-create "*casing files*"))
- (erase-buffer)
- (dolist (file (wisi-prj-case-exception-files project))
- (insert (format "%s\n" file))))
- (message "no casing files")
- )))
-
-(defun wisi--case-save-exceptions (full-exceptions partial-exceptions
file-name)
- "Save FULL-EXCEPTIONS, PARTIAL-EXCEPTIONS to the file FILE-NAME."
- ;; If there is a buffer visiting file-name, it may be out of date
- ;; due to a previous save-exceptions, which will give a user prompt
- ;; about editing a file that has changed on disk. Update the buffer
- (let ((buf (get-file-buffer file-name)))
- (when buf
- (with-current-buffer buf
- (revert-buffer nil t t))))
-
- (with-temp-file (expand-file-name file-name)
- (mapc (lambda (x) (insert (car x) "\n"))
- (sort (copy-sequence full-exceptions)
- (lambda(a b) (string< (car a) (car b)))))
- (mapc (lambda (x) (insert "*" (car x) "\n"))
- (sort (copy-sequence partial-exceptions)
- (lambda(a b) (string< (car a) (car b)))))
- ))
-
-(defun wisi--case-read-exceptions (file-name)
- "Read the content of the casing exception file FILE-NAME.
-Return (cons full-exceptions partial-exceptions)."
- (setq file-name (expand-file-name (substitute-in-file-name file-name)))
- (if (file-readable-p file-name)
- (let (full-exceptions partial-exceptions word)
- (with-temp-buffer
- (insert-file-contents file-name)
- (while (not (eobp))
-
- (setq word (buffer-substring-no-properties
- (point) (save-excursion (skip-syntax-forward "w_")
(point))))
-
- (if (char-equal (string-to-char word) ?*)
- ;; partial word exception
- (progn
- (setq word (substring word 1))
- (unless (assoc-string word partial-exceptions t)
- (push (cons word t) partial-exceptions)))
-
- ;; full word exception
- (unless (assoc-string word full-exceptions t)
- (push (cons word t) full-exceptions)))
-
- (forward-line 1))
- )
- (cons full-exceptions partial-exceptions))
-
- ;; else file not readable; might be a new project with no
- ;; exceptions yet, so just return empty pair
- (message "'%s' is not a readable file." file-name)
- '(nil . nil)
- ))
-
-(defun wisi--case-merge-exceptions (result new)
- "Merge NEW exeptions into RESULT.
-An item in both lists has the RESULT value."
- (dolist (item new)
- (unless (assoc-string (car item) result t)
- (push item result)))
- result)
-
-(defun wisi--case-merge-all-exceptions (exceptions project)
- "Merge EXCEPTIONS into PROJECT case-full-exceptions,
case-partial-exceptions."
- (setf (wisi-prj-case-full-exceptions project)
- (wisi--case-merge-exceptions (wisi-prj-case-full-exceptions project)
- (car exceptions)))
- (setf (wisi-prj-case-partial-exceptions project)
- (wisi--case-merge-exceptions (wisi-prj-case-partial-exceptions project)
- (cdr exceptions))))
-
-(defun wisi--case-read-all-exceptions (project)
- "Read case exceptions from all files in PROJECT casing files."
- (setf (wisi-prj-case-full-exceptions project) '())
- (setf (wisi-prj-case-partial-exceptions project) '())
-
- (dolist (file (wisi-prj-case-exception-files project))
- (wisi--case-merge-all-exceptions (wisi--case-read-exceptions file)
project)))
-
-(defun wisi--case-add-exception (word exceptions)
- "Add case exception WORD to EXCEPTIONS, replacing current entry, if any."
- (if (assoc-string word exceptions t)
- (setcar (assoc-string word exceptions t) word)
- (push (cons word t) exceptions))
- exceptions)
-
-(defun wisi-case-create-exception (&optional partial)
- "Define a word as an auto-casing exception in the current project.
-The word is the active region, or the symbol at point. If
-PARTIAL is non-nil, create a partial word exception. User is
-prompted to choose a file from the project case-exception-files
-if it is a list."
- (interactive)
- (let* ((project (wisi-prj-require-prj))
- (file-name
- (cond
- ((< 1 (length (wisi-prj-case-exception-files project)))
- (completing-read "case exception file: "
(wisi-prj-case-exception-files project)
- nil ;; predicate
- t ;; require-match
- nil ;; initial-input
- nil ;; hist
- (car (wisi-prj-case-exception-files project)) ;;
default
- ))
-
- ((= 1 (length (wisi-prj-case-exception-files project)))
- (car (wisi-prj-case-exception-files project)))
-
- (t
- (error "No exception file specified; set `casing' in project
file."))
- ))
- word)
-
- (if (use-region-p)
- (progn
- (setq word (buffer-substring-no-properties (region-beginning)
(region-end)))
- (deactivate-mark))
- (save-excursion
- (let ((syntax (if partial "w" "w_")))
- (skip-syntax-backward syntax)
- (setq word
- (buffer-substring-no-properties
- (point)
- (progn (skip-syntax-forward syntax) (point))
- )))))
-
- (let* ((exceptions (wisi--case-read-exceptions file-name))
- (file-full-exceptions (car exceptions))
- (file-partial-exceptions (cdr exceptions)))
-
- (cond
- ((null partial)
- (setf (wisi-prj-case-full-exceptions project)
- (wisi--case-add-exception word (wisi-prj-case-full-exceptions
project)))
- (setq file-full-exceptions (wisi--case-add-exception word
file-full-exceptions)))
-
- (t
- (setf (wisi-prj-case-partial-exceptions project)
- (wisi--case-add-exception word (wisi-prj-case-partial-exceptions
project)))
- (setq file-partial-exceptions (wisi--case-add-exception word
file-partial-exceptions)))
-
- )
- (wisi--case-save-exceptions file-full-exceptions file-partial-exceptions
file-name)
- (message "created %s case exception '%s' in file '%s'"
- (if partial "partial" "full")
- word
- file-name)
- )
- ))
-
-(defun wisi-case-create-partial-exception ()
- "Define active region or word at point as a partial word exception.
-User is prompted to choose a file from the project
-case-exception-files if it is a list."
- (interactive)
- (wisi-case-create-exception t))
-
-(defun wisi-after-keyword-p ()
- "Return non-nil if point is after an element of `wisi-language-keywords'."
- (let ((word (buffer-substring-no-properties
- (save-excursion (skip-syntax-backward "w_") (point))
- (point))))
- (member (downcase word) wisi-language-keywords)))
-
-(defvar-local wisi--ret-binding #'wisi-indent-newline-indent)
-(defvar-local wisi--lfd-binding #'newline-and-indent)
-
-(defun wisi-case-keyword (beg end)
- (cl-ecase wisi-case-keyword
- (lower-case (downcase-region beg end))
- (upper-case (upcase-region beg end))
- ))
-
-(defun wisi-case-identifier (start end case-strict)
- (cl-ecase wisi-case-identifier
- (mixed-case (wisi-mixed-case start end case-strict))
- (lower-case (downcase-region start end))
- (upper-case (upcase-region start end))
- ))
-
-(defun wisi-mixed-case (start end case-strict)
- "Adjust case of region START END to Mixed_Case."
- (let ((done nil)
- next)
- (if (or case-strict wisi-case-strict)
- (downcase-region start end))
- (goto-char start)
- (while (not done)
- (setq next
- (or
- (save-excursion (when (search-forward "_" end t) (point-marker)))
- (copy-marker (1+ end))))
-
- ;; upcase first char
- (upcase-region (point) (1+ (point)))
-
- (goto-char next)
- (if (< (point) end)
- (setq start (point))
- (setq done t))
- )))
-
-(defun wisi-case-adjust-identifier (&optional force-case)
- "Adjust case of the previous word as an identifier.
-Uses `wisi-case-identifier', with exceptions defined in
-`wisi-case-full-exceptions', `wisi-case-partial-exceptions'. If
-force-case non-nil (default prefix), treat `wisi-strict-case' as
-t."
- (interactive "P")
- (save-excursion
- ;; We don't complain when there is no project; we may be editing a
- ;; random Ada file.
- (let ((prj (wisi-prj-current-prj))
- (end (point-marker))
- (start (progn (skip-syntax-backward "w_") (point)))
- match
- next
- (done nil))
-
- (if (setq match
- (assoc-string (buffer-substring-no-properties start end)
- (wisi-prj-case-full-exceptions prj)
- t ;; case-fold
- ))
- ;; full word exception
- (progn
- ;; 'save-excursion' puts a marker at 'end'; if we do
- ;; 'delete-region' first, it moves that marker to 'start',
- ;; then 'insert' inserts replacement text after the
- ;; marker, defeating 'save-excursion'. So we do 'insert' first.
- (insert (car match))
- (delete-region (point) end))
-
- ;; else apply wisi-case-identifier
- (wisi-case-identifier start end force-case)
-
- ;; apply partial-exceptions
- (goto-char start)
- (while (not done)
- (setq next
- (or
- (save-excursion (when (search-forward "_" end t)
(point-marker)))
- (copy-marker (1+ end))))
-
- (when (setq match (assoc-string (buffer-substring-no-properties start
(1- next))
- (wisi-prj-case-partial-exceptions prj)
- t))
- ;; see comment above at 'full word exception' for why
- ;; we do insert first.
- (insert (car match))
- (delete-region (point) (1- next)))
-
- (goto-char next)
- (if (< (point) end)
- (setq start (point))
- (setq done t))
- ))
- )))
-
-(defun wisi-case-adjust-keyword ()
- "Adjust the case of the previous symbol as a keyword."
- (save-excursion
- (let ((end (point-marker))
- (start (progn (skip-syntax-backward "w_") (point))))
- (wisi-case-keyword start end)
- )))
-
-(defun wisi-case-adjust (&optional typed-char in-comment)
- "Adjust the case of the symbol before point.
-When invoked interactively, TYPED-CHAR must be
-`last-command-event', and it must not have been inserted yet. If
-IN-COMMENT is non-nil, adjust case of words in comments and
-strings as code, and treat `wisi-case-strict' as t in code."
- (when (not (bobp))
- (when (save-excursion
- (forward-char -1); back to last character in symbol
- (and (not (bobp))
- (eq (char-syntax (char-after)) ?w); it can be capitalized
-
- (or in-comment
- (not (wisi-in-string-or-comment-p)))
-
- (or (null wisi-case-adjust-p-function)
- (funcall wisi-case-adjust-p-function typed-char))
- ))
-
- ;; The indentation engine may trigger a reparse on
- ;; non-whitespace changes, but we know we don't need to reparse
- ;; for this change (assuming the user has not abused case
- ;; exceptions!).
- (let ((inhibit-modification-hooks t))
- (cond
- ;; Some attributes are also keywords, but captialized as
- ;; attributes. So check for attribute first.
- ((and
- (not in-comment)
- (save-excursion
- (skip-syntax-backward "w_")
- (eq (char-before) ?')))
- (wisi-case-adjust-identifier in-comment))
-
- ((and
- (not in-comment)
- (not (eq typed-char ?_))
- (wisi-after-keyword-p))
- (wisi-case-adjust-keyword))
-
- (t (wisi-case-adjust-identifier in-comment))
- ))
- )))
-
-(defun wisi-case-adjust-at-point (&optional in-comment)
- "If ’wisi-auto-case’ is non-nil, adjust case of symbol at point.
-Also move to end of symbol. With prefix arg, adjust case as code
-even if in comment or string; otherwise, capitalize words in
-comments and strings. If ’wisi-auto-case’ is nil, capitalize
-current word."
- (interactive "P")
- (cond
- ((or (null wisi-auto-case)
- (and (not in-comment)
- (wisi-in-string-or-comment-p)))
- (skip-syntax-backward "w_")
- (capitalize-word 1))
-
- (t
- (when
- (and (not (eobp))
- ;; We use '(syntax-after (point))' here, not '(char-syntax
- ;; (char-after))', because the latter does not respect
- ;; syntax-propertize functions
- (memq (syntax-class (syntax-after (point))) '(2 3)))
- (skip-syntax-forward "w_"))
- (wisi-case-adjust nil in-comment))
- ))
-
-(defun wisi-case-adjust-region (begin end)
- "Adjust case of all words in region BEGIN END."
- (interactive "r")
- (narrow-to-region begin end)
- (save-excursion
- (goto-char begin)
- (while (not (eobp))
- (forward-comment (point-max))
- (skip-syntax-forward "^w_")
- (skip-syntax-forward "w_")
- (wisi-case-adjust)))
- (widen))
-
-(defun wisi-case-adjust-buffer ()
- "Adjust case of current buffer."
- (interactive)
- (wisi-case-adjust-region (point-min) (point-max)))
-
-(defun wisi-case-adjust-interactive (arg)
- "If `wisi-auto-case' is non-nil, adjust the case of the previous symbol,
-and process the character just typed. To be bound to keys that
-should cause auto-casing. ARG is the prefix the user entered
-with \\[universal-argument]."
- (interactive "P")
-
- ;; Character typed has not been inserted yet.
- (let ((lastk last-command-event)
- (do-adjust nil))
- (cond
- ((null wisi-auto-case))
- (t
- (setq do-adjust t)))
-
- (cond
- ((eq lastk ?\n)
- (when do-adjust
- (wisi-case-adjust lastk))
- (funcall wisi--lfd-binding))
-
- ((memq lastk '(?\r return))
- (when do-adjust
- (wisi-case-adjust lastk))
- (funcall wisi--ret-binding))
-
- (t
- (when do-adjust
- (wisi-case-adjust lastk))
- (self-insert-command (prefix-numeric-value arg)))
- )))
-
-(defun wisi-case-activate-keys (map)
- "Modify the key bindings for all the keys that should adjust casing."
- (mapc (function
- (lambda(key)
- (define-key
- map
- (char-to-string key)
- 'wisi-case-adjust-interactive)))
- '( ?_ ?% ?& ?* ?\( ?\) ?- ?= ?+
- ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r ))
- )
-
-;;;; xref backend
-
-(defconst wisi-file-line-col-regexp
- ;; matches Gnu-style file references:
- ;;
C:\Projects\GDS\work_dscovr_release\common\1553\gds-mil_std_1553-utf.ads:252:25
- ;;
/Projects/GDS/work_dscovr_release/common/1553/gds-mil_std_1553-utf.ads:252:25
- ;; gds-mil_std_1553-utf.ads:252:25 - when wisi-xref-full-path is nil
- "\\(\\(?:.:\\\\\\|/\\)?[^:]*\\):\\([0-9]+\\):\\([0-9]+\\)"
- ;; 1 2 3
- "Regexp matching <file>:<line>:<column> where <file> is an absolute file
name or basename.")
-
-(defun wisi-xref-item (identifier prj)
- "Given IDENTIFIER, return an xref-item, with line, column nil if unknown.
-IDENTIFIER is from a user prompt with completion, or from
-`xref-backend-identifier-at-point'."
- (let* ((t-prop (get-text-property 0 'xref-identifier identifier))
- ident file line column)
- (cond
- (t-prop
- ;; IDENTIFIER is from wisi-xref-identifier-at-point.
- (setq ident (substring-no-properties identifier 0 nil))
- (setq file (plist-get t-prop :file))
- (setq line (plist-get t-prop :line))
- (setq column (plist-get t-prop :column))
- )
-
- ((string-match (wisi-xref-completion-regexp (wisi-prj-xref prj))
identifier)
- ;; IDENTIFIER is from prompt/completion on wisi-xref-completion-table
- (setq ident (match-string 1 identifier))
-
- (let* ((table (wisi-xref-completion-table (wisi-prj-xref prj) prj))
- (loc (cdr (assoc identifier table))))
-
- (setq file (nth 0 loc))
- (setq line (nth 1 loc))
- (setq column (nth 2 loc))
- ))
-
- ((string-match wisi-names-regexp identifier)
- ;; IDENTIFIER is from prompt/completion on wisi-names.
- (setq ident (match-string 1 identifier))
- (setq file (buffer-file-name))
- (when (match-string 2 identifier)
- (setq line (string-to-number (match-string 2 identifier))))
- )
-
- (t
- ;; IDENTIFIER has no line/column info
- (setq ident identifier)
- (setq file (buffer-file-name)))
- )
-
- (unless (file-name-absolute-p file)
- (setq file (locate-file file compilation-search-path)))
-
- (let ((eieio-skip-typecheck t)) ;; allow line, column nil.
- (xref-make ident (xref-make-file-location file line column)))
- ))
-
-(cl-defmethod xref-backend-definitions ((prj wisi-prj) identifier)
- (wisi-xref-definitions (wisi-prj-xref prj) prj (wisi-xref-item identifier
prj)))
-
-(cl-defmethod xref-backend-identifier-at-point ((prj wisi-prj))
- (save-excursion
- (let ((id (wisi-prj-identifier-at-point prj)))
- (when id
- (put-text-property
- 0 1
- 'xref-identifier
- (list ':file (buffer-file-name)
- ':line (line-number-at-pos)
- ':column (save-excursion (goto-char (nth 0 id))
(current-column)))
- (nth 2 id))
- (nth 2 id)))))
-
-(cl-defmethod xref-backend-identifier-completion-table ((prj wisi-prj))
- (wisi-filter-table (wisi-xref-completion-table (wisi-prj-xref prj) prj)
- (when (equal '(16) current-prefix-arg)
(buffer-file-name))))
-
-(cl-defmethod xref-backend-references ((prj wisi-prj) identifier)
- (wisi-xref-references (wisi-prj-xref prj) prj (wisi-xref-item identifier
prj)))
-
-;;;###autoload
-(defun wisi-prj-xref-backend ()
- "For `xref-backend-functions'; return the current wisi project."
- ;; We return the project, not the xref object, because the
- ;; wisi-xref-* functions need the project.
- (let ((prj (project-current)))
- (when (wisi-prj-p prj)
- prj)))
-
-;;;; project-find-functions alternatives
-
-(defvar wisi-prj--dominating-alist nil
-"Alist of (DOMINATING-FILE . PRJ-FILE-NAME): DOMINATING-FILE is
-an absolute filename that can be found by
-`wisi-prj-find-dominating-cached' or
-`wisi-prj-find-dominating-cached'. PRJ-FILE-NAME is the wisi
-project file for the project for that file.")
-
-;;;###autoload
-(defun wisi-prj-select-cache (prj-file init-prj &optional dominating-file)
- "Select project matching PRJ-FILE in `wisi-prj--cache' as current project,
-parsing and caching if needed. Also add DOMINATING-FILE (default
-current buffer file name) to `wisi-prj--dominating-alist' (for
-`wisi-prj-select-dominating'.)"
- (let ((old-prj (project-current)))
- ;; If old-prj is not a wisi-prj, we don't know how to deselect it;
- ;; just ignore that. If prj-file is the current file, user is
- ;; re-selecting it.
- (when (wisi-prj-p old-prj)
- (wisi-prj-deselect old-prj)))
-
- (unless (or (memq #'wisi-prj-current-cached project-find-functions)
- (memq #'wisi-prj-current-cached (default-value
'project-find-functions)))
- (message "wisi-prj-select-cache used without wisi-prj-current-cached in
project-find-functions"))
-
- (setq dominating-file (if dominating-file (expand-file-name dominating-file)
(buffer-file-name)))
- (setq prj-file (expand-file-name prj-file))
- (add-to-list 'wisi-prj--dominating-alist (cons dominating-file prj-file))
-
- (let ((new-prj (cdr (assoc prj-file wisi-prj--cache))))
- (unless new-prj
- (setq new-prj (wisi-prj-parse-file :prj-file prj-file :init-prj init-prj
:cache t))
- (unless new-prj
- (error "parsing project file '%s' failed" prj-file)))
-
- (setq wisi-prj--current-file prj-file)
- (wisi-prj-select new-prj)))
-
-;;;###autoload
-(defun wisi-prj-select-dominating (&optional dominating-file)
- "Unless it is already current, select a wisi-prj matching DOMINATING-FILE.
-DOMINATING-FILE defaults to the current buffer file name.
-Useful before running `compilation-start', to ensure the correct
-project is current."
- (when (or dominating-file (buffer-file-name))
- ;; buffer-file-name is nil in *compilation* buffer
- (let ((prj-file (cdr (assoc (or dominating-file (buffer-file-name))
wisi-prj--dominating-alist))))
- (unless (string-equal prj-file wisi-prj--current-file)
- (message "Switching to project file '%s'" prj-file)
- (let ((old-prj (cdr (assoc wisi-prj--current-file wisi-prj--cache)))
- (new-prj (cdr (assoc prj-file wisi-prj--cache))))
- (when (wisi-prj-p old-prj)
- (wisi-prj-deselect old-prj))
- (when (wisi-prj-p new-prj)
- (wisi-prj-select new-prj))
- (setq wisi-prj--current-file prj-file))))))
-
-;;;###autoload
-(defun wisi-prj-current-cached (_dir)
- "For `project-find-functions'; return the current project from
`wisi-prj--cache'."
- (cdr (assoc wisi-prj--current-file wisi-prj--cache)))
-
-(defvar wisi-prj--default nil
- "Alist of (PRJ-FILE . INIT-PRJ), for `wisi-prj-parse-current'.
-PRJ-FILE is an absolute project file name; INIT-PRJ is the
-initial `wisi-prj' object for that project file.")
-
-;;;###autoload
-(defun wisi-prj-select-file (prj-file default-prj &optional dominating-file)
- "Set PRJ-FILE as current project, add DEFAULT-PRJ to `wisi-prj--default'.
-Also add DOMINATING-FILE (default current buffer file name) to
-`wisi-prj--dominating-alist' (for `wisi-prj-select-dominating'.)"
- (unless (or (memq #'wisi-prj-current-parse project-find-functions)
- (memq #'wisi-prj-current-parse (default-value
'project-find-functions)))
- (message "wisi-prj-select-file used without wisi-prj-current-parse in
project-find-functions"))
-
- (setq dominating-file (if dominating-file (expand-file-name dominating-file)
(buffer-file-name)))
- (setq prj-file (expand-file-name prj-file))
- (add-to-list 'wisi-prj--dominating-alist (cons dominating-file prj-file))
- (setq wisi-prj--current-file prj-file)
- (add-to-list 'wisi-prj--default (cons prj-file default-prj)))
-
-;;;###autoload
-(defun wisi-prj-current-parse (_dir)
- "For `project-find-functions'; parse the current project file, select and
return the project"
- (let ((prj (wisi-prj-parse-file
- :prj-file wisi-prj--current-file
- :init-prj (cdr (assoc-string wisi-prj--current-file
wisi-prj--default))
- :cache nil)))
- (wisi-prj-select prj)
- prj))
-
-(defvar wisi-prj--dominating nil
- "List of relative filenames for `wisi-prj-find-dominating-cached'
-and `wisi-prj-find-dominating-parse'. Set by `wisi-prj-set-dominating'.")
-
-(defun wisi-prj-reset-cache ()
- "Delete all wisi project cached info."
- (interactive)
- (setq wisi-prj--cache nil)
- (setq wisi-prj--current-file nil)
- (setq wisi-prj--default nil)
- (setq wisi-prj--dominating nil)
- (setq wisi-prj--dominating-alist nil))
-
-;;;###autoload
-(defun wisi-prj-cache-dominating (prj-file default-prj &optional
dominating-file)
- "Parse prj-file, add to `wisi-prj--cache'.
-Also add (DOMINATING-FILE . PRJ-FILE) to `wisi-prj--dominating-alist'.
-DOMINATING-FILE defaults to (buffer-file-name). "
- (unless (or (memq #'wisi-prj-find-dominating-cached project-find-functions)
- (memq #'wisi-prj-find-dominating-cached (default-value
'project-find-functions)))
- (message "wisi-prj-cache-dominating used without
wisi-prj-find-dominating-cached in project-find-functions"))
-
- (setq dominating-file (if dominating-file (expand-file-name dominating-file)
(buffer-file-name)))
- (setq prj-file (expand-file-name prj-file))
- (add-to-list 'wisi-prj--dominating (file-name-nondirectory dominating-file))
- (add-to-list 'wisi-prj--dominating-alist (cons dominating-file prj-file))
- (wisi-prj-parse-file :prj-file prj-file :init-prj default-prj :cache t)
- nil)
-
-(defun wisi-prj--find-dominating-file (start-dir)
- "Return the project file matching `wisi-prj--dominating'."
- (let* (dom-file
- (_dom-dir
- (locate-dominating-file
- start-dir
- (lambda (dir)
- (let ((names wisi-prj--dominating))
- (while names
- (let ((filename (expand-file-name (pop names) dir)))
- (when (file-exists-p filename)
- (setq dom-file filename)
- (setq names nil)))))
- dom-file))))
- (cdr (assoc-string dom-file wisi-prj--dominating-alist))))
-
-;;;###autoload
-(defun wisi-prj-find-dominating-cached (dir)
- "For `project-find-functions'; return the cached project
-matching `wisi-prj--dominating' (nil if none). Select it if it is
-not the current project."
- (let* ((prj-file (wisi-prj--find-dominating-file dir))
- (new-prj (cdr (assoc-string prj-file wisi-prj--cache))))
- (when prj-file
- (unless (string= prj-file wisi-prj--current-file)
- (let ((old-prj (cdr (assoc-string wisi-prj--current-file
wisi-prj--cache))))
- (when old-prj (wisi-prj-deselect old-prj))
- (unless new-prj
- ;; User may have used `wisi-prj-set-dominating' instead of
- ;; `wisi-prj-cache-dominating'; parse the project file now.
- (wisi-prj-parse-file
- :prj-file prj-file
- :init-prj (cdr (assoc-string prj-file wisi-prj--default))
- :cache t))
- (when new-prj (wisi-prj-select new-prj))))
- new-prj)))
-
-;;;###autoload
-(defun wisi-prj-set-dominating (prj-file default-prj &optional dom-file)
- "Add (DOM-FILE . PRJ-FILE) to `wisi-prj--dominating-alist',
-and (PRJ-FILE . DEFAULT-PRJ) to `wisi-prj--default'.
-DOM-FILE defaults to (buffer-file-name).
-For example, call this in the Local Vars of a Makefile to
-associate a project with that Makefile."
- (unless (or (memq #'wisi-prj-find-dominating-parse project-find-functions)
- (memq #'wisi-prj-find-dominating-parse (default-value
'project-find-functions)))
- (message "wisi-prj-cache-dominating used without
wisi-prj-find-dominating-parse in project-find-functions"))
-
- (setq dom-file (if dom-file (expand-file-name dom-file) (buffer-file-name)))
- (setq prj-file (expand-file-name prj-file))
- (add-to-list 'wisi-prj--dominating (file-name-nondirectory dom-file))
- (add-to-list 'wisi-prj--dominating-alist (cons dom-file prj-file))
- (add-to-list 'wisi-prj--default (cons prj-file default-prj))
- nil)
-
-;;;###autoload
-(defun wisi-prj-find-dominating-parse (dir)
- "For `project-find-functions'; parse, select, and return the project
-file matching `wisi-prj--dominating'."
- (let ((prj-file (wisi-prj--find-dominating-file dir)))
- (when prj-file
- (let ((prj (wisi-prj-parse-file
- :prj-file prj-file
- :init-prj (cdr (assoc-string prj-file wisi-prj--default))
- :cache nil)))
- (wisi-prj-select prj)
- prj))))
-
-;;;###autoload
-(defun wisi-prj-dtrt-parse-file (prj-file default-prj dominating-file
&optional dir)
- "Depending on wisi-prj function in `project-find-functions',
-Do The Right Thing to make PRJ-FILE active and selected; return the project."
- (cond
- ((memq #'wisi-prj-find-dominating-parse project-find-functions)
- (wisi-prj-set-dominating prj-file default-prj dominating-file))
-
- ((memq #'wisi-prj-find-dominating-cached project-find-functions)
- (wisi-prj-cache-dominating prj-file default-prj dominating-file))
-
- ((memq #'wisi-prj-current-cached project-find-functions)
- (wisi-prj-select-cache prj-file default-prj dominating-file))
-
- ((memq #'wisi-prj-current-parse project-find-functions)
- (wisi-prj-select-file prj-file default-prj dominating-file))
-
- (t
- (user-error "No wisi-prj function in project-find-functions"))
- )
- (project-current nil (or dir default-directory)))
-
-;;;###autoload
-(defun wisi-prj-find-function-set-p ()
- "Return non-nil if a wisi-prj function is present in
`project-find-functions'."
- (or (memq #'wisi-prj-find-dominating-parse project-find-functions)
- (memq #'wisi-prj-find-dominating-cached project-find-functions)
- (memq #'wisi-prj-current-cached project-find-functions)
- (memq #'wisi-prj-current-parse project-find-functions)))
-
-;;;; project menu
-
-(defun wisi-prj--menu-compute ()
- "Return an easy-menu menu for `wisi-prj-menu--install'.
-Menu displays cached wisi projects."
- (let (menu)
- (dolist (item wisi-prj--cache)
- (push
- (vector
- (concat (wisi-prj-name (cdr item))
- (when (equal (car item) wisi-prj--current-file) " *")) ;;
current project
- `(lambda () (interactive)
- (when wisi-prj--current-file
- (wisi-prj-deselect (cdr (assoc wisi-prj--current-file
wisi-prj--cache))))
- (setq wisi-prj--current-file ,(car item))
- (wisi-prj-select ,(cdr item)))
- t)
- menu)
- )
- (nreverse menu)))
-
-(defun wisi-prj-menu-install ()
- "Install the project menu if appropriate, to display cached wisi projects."
- (when
- (or (memq #'wisi-prj-find-dominating-cached project-find-functions)
- (memq #'wisi-prj-current-cached project-find-functions))
-
- (let ((menu (wisi-prj--menu-compute)))
- (if menu
- (define-key-after
- global-map
- [menu-bar wisi-prj-select]
- (easy-menu-binding
- (easy-menu-create-menu
- "Wisi Prj Select";; EDE uses "Project" menu
- menu))
- (lookup-key global-map [menu-bar tools]))
- ;; delete empty menu
- (define-key-after
- global-map
- [menu-bar wisi-prj-select]
- nil
- (lookup-key global-map [menu-bar tools]))
- ))
- ))
-
-(add-hook 'menu-bar-update-hook 'wisi-prj-menu-install)
-
-(defun wisi-prj-completion-table ()
- "Return list of names of cached projects."
- (mapcar (lambda (item) (wisi-prj-name (cdr item))) wisi-prj--cache))
-
-(defun wisi-prj-delete (name)
- "Delete project NAME (default prompt) from the cached projects."
- (interactive (list (completing-read "project name: "
(wisi-prj-completion-table))))
- (let (pair)
- (dolist (item wisi-prj--cache)
- (if (string= name (wisi-prj-name (cdr item)))
- (setq pair item)))
-
- (setq wisi-prj--cache (delete pair wisi-prj--cache))
-
- (setq wisi-prj--dominating-alist
- (cl-delete-if (lambda (item)
- (string= (car pair) (cdr item)))
- wisi-prj--dominating-alist))
- ))
-
-(provide 'wisi-prj)
-;; end wisi-prj.el
diff --git a/packages/wisi/wisi-process-parse.el
b/packages/wisi/wisi-process-parse.el
deleted file mode 100644
index bddd033..0000000
--- a/packages/wisi/wisi-process-parse.el
+++ /dev/null
@@ -1,844 +0,0 @@
-;;; wisi-process-parse.el --- interface to external parse program
-;;
-;; Copyright (C) 2014, 2017 - 2020 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@member.fsf.org>
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-(require 'cl-lib)
-(require 'wisi-parse-common)
-
-(defgroup wisi nil
- "Options for Wisi package."
- :group 'programming)
-
-(defcustom wisi-process-time-out 5.0
- "Time out waiting for parser response. An error occurs if there
- is no response from the parser after waiting this amount (in
- seconds)."
- :type 'float
- :safe 'numberp)
-(make-variable-buffer-local 'wisi-process-time-out)
-
-(defconst wisi-process-parse-protocol-version "5"
- "Defines data exchanged between this package and the background process.
-Must match emacs_wisi_common_parse.ads Protocol_Version.")
-
-(defconst wisi-process-parse-prompt "^;;> "
- "Regexp matching executable prompt; indicates previous command is complete.")
-
-(defconst wisi-process-parse-quit-cmd "004quit\n"
- "Command to external process telling it to quit.")
-
-;;;;; sessions
-
-;; The executable builds internal parser structures on startup,
-;; then runs a loop, waiting for parse requests.
-;;
-;; We only need one process per language; there is no persistent state
-;; in the process between parses, and processes are too heavy-weight
-;; to have one per buffer. We use a global alist of parser objects to
-;; find the right one for the current buffer.
-
-(cl-defstruct (wisi-process--parser (:include wisi-parser))
- (label nil) ;; string uniquely identifying parser
- language-protocol-version ;; string identifying language-specific params
- (exec-file nil) ;; absolute file name of executable
- (exec-opts nil) ;; list of process start options for executable
- (token-table nil) ;; vector of token symbols, indexed by integer
- (face-table nil) ;; vector of face symbols, indexed by integer
- (busy nil) ;; t while parser is active
- (process nil) ;; running *_wisi_parse executable
- (buffer nil) ;; receives output of executable
- line-begin ;; vector of beginning-of-line positions in buffer
- (total-wait-time 0.0) ;; total time during last parse spent waiting for
subprocess output.
- (response-count 0) ;; responses received from subprocess during last
parse; for profiling.
- end-pos ;; last character position parsed
- language-action-table ;; array of function pointers, each taking an sexp
sent by the process
- )
-
-(defvar wisi-process--alist nil
- "Alist mapping string label to ‘wisi-process--session’ struct")
-
-;;;###autoload
-(defun wisi-process-parse-get (parser)
- "Return a ‘wisi-process--parser’ object matching PARSER label.
-If label found in ‘wisi-process--alist’, return that.
-Otherwise add PARSER to ‘wisi-process--alist’, return it."
- (or (cdr (assoc (wisi-process--parser-label parser) wisi-process--alist))
- (let ((exec-file (locate-file (wisi-process--parser-exec-file parser)
exec-path '("" ".exe"))))
-
- (unless exec-file
- (error "%s not found on `exec-path'; run 'build.sh' in the ELPA
package."
- (wisi-process--parser-exec-file parser)))
-
- (push (cons (wisi-process--parser-label parser) parser)
wisi-process--alist)
-
- parser
- )))
-
-(defun wisi-process-parse-set-exec (label exec-file)
- "Change the EXEC-FILE for parsers with LABEL."
- (let ((parser (cdr (assoc label wisi-process--alist))))
- (when parser
- (wisi-parse-kill parser)
- (setf (wisi-process--parser-exec-file parser) exec-file))))
-
-(defun wisi-process-parse--check-version (parser)
- "Verify protocol version reported by process."
- ;; The process has just started; the first non-comment line in the
- ;; process buffer contains the process and language protocol versions.
- (with-current-buffer (wisi-process--parser-buffer parser)
- (goto-char (point-min))
- (if (search-forward-regexp "protocol: process version \\([0-9]+\\)
language version \\([0-9]+\\)" nil t)
- (unless (and (match-string 1)
- (string-equal (match-string 1)
wisi-process-parse-protocol-version)
- (match-string 2)
- (string-equal (match-string 2)
(wisi-process--parser-language-protocol-version parser)))
- (wisi-parse-kill parser)
- (error "%s parser process protocol version mismatch: elisp %s %s,
process %s %s"
- (wisi-process--parser-label parser)
- wisi-process-parse-protocol-version
(wisi-process--parser-language-protocol-version parser)
- (match-string 1) (match-string 2)))
- ;; Search failed
- (error "%s parser process protocol version message not found"
- (wisi-process--parser-label parser))
- )))
-
-(defun wisi-process-parse--require-process (parser)
- "Start the process for PARSER if not already started."
- (unless (process-live-p (wisi-process--parser-process parser))
- (let ((process-connection-type nil) ;; use a pipe, not a pty; avoid
line-by-line reads
- (process-name (format " *%s_wisi_parse*" (wisi-process--parser-label
parser))))
-
- (unless (buffer-live-p (wisi-process--parser-buffer parser))
- ;; User may have killed buffer to kill parser.
- (setf (wisi-process--parser-buffer parser)
- (get-buffer-create process-name)))
-
- (with-current-buffer (wisi-process--parser-buffer parser)
- (erase-buffer)); delete any previous messages, prompt
-
- (setf (wisi-process--parser-process parser)
- (make-process
- :name process-name
- :buffer (wisi-process--parser-buffer parser)
- :command (append (list (wisi-process--parser-exec-file parser))
- (wisi-process--parser-exec-opts parser))))
-
- (set-process-query-on-exit-flag (wisi-process--parser-process parser)
nil)
-
- (wisi-process-parse--wait parser)
- (wisi-process-parse--check-version parser)
- )))
-
-(defun wisi-process-parse--wait (parser)
- "Wait for the current command to complete."
- (let ((process (wisi-process--parser-process parser))
- (search-start (point-min))
- (wait-count 0)
- (found nil))
-
- (with-current-buffer (wisi-process--parser-buffer parser)
- (while (and (process-live-p process)
- (progn
- ;; process output is inserted before point, so move back
over it to search it
- (goto-char search-start)
- (not (setq found (re-search-forward
wisi-process-parse-prompt (point-max) t)))))
- (setq search-start (point));; don't search same text again
- (setq wait-count (1+ wait-count))
- (accept-process-output process 0.1))
-
- (unless found
- (wisi-process-parse-show-buffer parser)
- (error "%s process died" (wisi-process--parser-exec-file parser)))
- )))
-
-(defun wisi-process-parse-show-buffer (parser)
- "Show PARSER buffer."
- (if (buffer-live-p (wisi-process--parser-buffer parser))
- (pop-to-buffer (wisi-process--parser-buffer parser))
- (error "wisi-process-parse process not active")))
-
-(defun wisi-process-parse--send-parse (parser begin send-end parse-end)
- "Send a parse command to PARSER external process, followed by
-the content of the current buffer from BEGIN thru SEND-END. Does
-not wait for command to complete. PARSE-END is end of desired
-parse region."
- ;; Must match "parse" command arguments read by
- ;; emacs_wisi_common_parse.adb Get_Parse_Params.
- (let* ((cmd (format "parse %d \"%s\" %d %d %d %d %d %d %d %d %d %d %d %d %d
%d %d %d %d %d %s"
- (cl-ecase wisi--parse-action
- (navigate 0)
- (face 1)
- (indent 2))
- (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
- (position-bytes begin)
- (position-bytes send-end)
- (position-bytes parse-end)
- begin ;; char_pos
- (line-number-at-pos begin)
- (line-number-at-pos send-end)
- (save-excursion (goto-char begin) (back-to-indentation)
(current-column));; indent-begin
- (if (or (and (= begin (point-min)) (= parse-end
(point-max)))
- (< (point-max) wisi-partial-parse-threshold))
- 0 1) ;; partial parse active
- (if (> wisi-debug 0) 1 0) ;; debug_mode
- (1- wisi-debug) ;; trace_parse
- wisi-trace-mckenzie
- wisi-trace-action
- (if wisi-mckenzie-disable 1 0)
- (or wisi-mckenzie-task-count -1)
- (or wisi-mckenzie-check-limit -1)
- (or wisi-mckenzie-enqueue-limit -1)
- (or wisi-parse-max-parallel -1)
- (- (position-bytes send-end) (position-bytes begin)) ;;
send-end is after last byte
- (wisi-parse-format-language-options parser)
- ))
- (msg (format "%03d%s" (length cmd) cmd))
- (process (wisi-process--parser-process parser)))
- (with-current-buffer (wisi-process--parser-buffer parser)
- (erase-buffer))
-
- (process-send-string process msg)
- (process-send-string process (buffer-substring-no-properties begin
send-end))
-
- ;; We don’t wait for the send to complete; the external process
- ;; may start parsing and send an error message.
- ))
-
-(defun wisi-process-parse--send-refactor (parser refactor-action parse-begin
parse-end edit-begin)
- "Send a refactor command to PARSER external process, followed
-by the content of the current buffer from PARSE-BEGIN thru
-PARSE-END, wait for command to complete. PARSER will respond with
-one or more Edit messages."
- ;; Must match "refactor" command arguments read by
- ;; emacs_wisi_common_parse.adb Get_Refactor_Params.
- (let* ((cmd (format "refactor %d \"%s\" %d %d %d %d %d %d %d %d %d %d %d %d"
- refactor-action
- (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
- (position-bytes parse-begin)
- (position-bytes parse-end)
- (position-bytes edit-begin)
- parse-begin ;; char_pos
- (line-number-at-pos parse-begin)
- (line-number-at-pos parse-end)
- (save-excursion (goto-char parse-begin)
(back-to-indentation) (current-column));; indent-begin
- (if (> wisi-debug 0) 1 0) ;; debug-mode
- (1- wisi-debug) ;; trace_parse
- wisi-trace-action
- (or wisi-parse-max-parallel -1)
- (- (position-bytes parse-end) (position-bytes
parse-begin)) ;; parse-end is after last byte
- ))
- (msg (format "%03d%s" (length cmd) cmd))
- (process (wisi-process--parser-process parser)))
- (with-current-buffer (wisi-process--parser-buffer parser)
- (erase-buffer))
-
- (process-send-string process msg)
- (process-send-string process (buffer-substring-no-properties parse-begin
parse-end))
- (wisi-process-parse--wait parser)
- ))
-
-(defun wisi-process-parse--send-noop (parser)
- "Send a noop command to PARSER external process, followed by
-the content of the current buffer. Does not wait for command to
-complete."
- (let* ((cmd (format "noop %d" (1- (position-bytes (point-max)))))
- (msg (format "%03d%s" (length cmd) cmd))
- (process (wisi-process--parser-process parser)))
- (with-current-buffer (wisi-process--parser-buffer parser)
- (erase-buffer))
-
- (process-send-string process msg)
- (process-send-string process (buffer-substring-no-properties (point-min)
(point-max)))
- ))
-
-(defun wisi-process-parse--marker-or-nil (item)
- (if (= -1 item) nil (copy-marker item t)))
-
-(defun wisi-process-parse--Navigate_Cache (parser sexp)
- ;; sexp is [Navigate_Cache pos statement_id id length class containing_pos
prev_pos next_pos end_pos]
- ;; see ‘wisi-process-parse--execute’
- (let ((pos (aref sexp 1)))
- (with-silent-modifications
- (put-text-property
- pos
- (1+ pos)
- 'wisi-cache
- (wisi-cache-create
- :nonterm (aref (wisi-process--parser-token-table parser) (aref sexp
2))
- :token (aref (wisi-process--parser-token-table parser) (aref sexp
3))
- :last (aref sexp 4)
- :class (aref wisi-class-list (aref sexp 5))
- :containing (wisi-process-parse--marker-or-nil (aref sexp 6))
- :prev (wisi-process-parse--marker-or-nil (aref sexp 7))
- :next (wisi-process-parse--marker-or-nil (aref sexp 8))
- :end (wisi-process-parse--marker-or-nil (aref sexp 9))
- )))
- ))
-
-(defun wisi-process-parse--Name_Property (parser sexp)
- ;; sexp is [Name_Property first-pos last-pos]
- ;; see ‘wisi-process-parse--execute’
- ;; implements wisi-name-action
- (with-silent-modifications
- (put-text-property (aref sexp 1) (1+ (aref sexp 2)) 'wisi-name t)))
-
-(defun wisi-process-parse--Face_Property (parser sexp)
- ;; sexp is [Face_Property first-pos last-pos face-index]
- ;; see ‘wisi-process-parse--execute’
- ;; implements wisi--face-action-1
- (with-silent-modifications
- (add-text-properties
- (aref sexp 1)
- (1+ (aref sexp 2))
- (list 'font-lock-face (aref (wisi-process--parser-face-table parser)
(aref sexp 3))
- 'fontified t)
- )))
-
-(defun wisi-process-parse--Indent (parser sexp)
- ;; sexp is [Indent line-number indent]
- ;; see ‘wisi-process-parse--execute’
- (let ((pos (aref (wisi-process--parser-line-begin parser) (1- (aref sexp
1)))))
- (with-silent-modifications
- (when (< (point-min) pos)
- (put-text-property
- (1- pos)
- pos
- 'wisi-indent
- (aref sexp 2)))
- )))
-
-(defun wisi-process-parse--Lexer_Error (parser sexp)
- ;; sexp is [Lexer_Error char-position <message> <repair-char>]
- ;; see ‘wisi-process-parse--execute’
- (let ((pos (aref sexp 1))
- err)
-
- (goto-char pos);; for current-column
-
- (setq err
- (make-wisi--lexer-error
- :pos (copy-marker pos)
- :message
- (format "%s:%d:%d: %s"
- (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
- ;; file-name can be nil during vc-resolve-conflict
- (line-number-at-pos pos)
- (current-column)
- (aref sexp 2))
- :inserted (when (= 4 (length sexp)) (aref sexp 3))))
-
- (push err (wisi-parser-lexer-errors parser))
- ))
-
-(defun wisi-process-parse--Parser_Error (parser sexp)
- ;; sexp is [Parser_Error char-position <string>]
- ;; see ‘wisi-process-parse--execute’
- (let ((pos (aref sexp 1))
- err)
-
- (goto-char pos);; for current-column
-
- (setq err
- (make-wisi--parse-error
- :pos (copy-marker pos)
- :message
- (format "%s:%d:%d: %s"
- (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "")
- ;; file-name can be nil during vc-resolve-conflict
- (line-number-at-pos pos)
- (1+ (current-column))
- (aref sexp 2))))
-
- (push err (wisi-parser-parse-errors parser))
- ))
-
-(defun wisi-process-parse--Check_Error (parser sexp)
- ;; sexp is [Check_Error code name-1-pos name-2-pos <string>]
- ;; see ‘wisi-process-parse--execute’
- (let* ((name-1-pos (aref sexp 2))
- (name-1-col (1+ (progn (goto-char name-1-pos)(current-column)))) ;;
gnat columns are 1 + emacs columns
- (name-2-pos (aref sexp 3))
- (name-2-col (1+ (progn (goto-char name-2-pos)(current-column))))
- (file-name (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) ""))
- ;; file-name can be nil during vc-resolve-conflict
- (err (make-wisi--parse-error
- :pos (copy-marker name-1-pos)
- :message
- (format "%s:%d:%d: %s %s:%d:%d"
- file-name (line-number-at-pos name-1-pos) name-1-col
- (aref sexp 4)
- file-name (line-number-at-pos name-2-pos) name-2-col)))
- )
-
- (push err (wisi-parser-parse-errors parser))
- ))
-
-(defun wisi-process-parse--Recover (parser sexp)
- ;; sexp is [Recover [pos [inserted] [deleted] deleted-region]...]
- ;; see ‘wisi-process-parse--execute’
- ;; convert to list of wisi--parse-error-repair, add to last error
- (let* ((token-table (wisi-process--parser-token-table parser))
- (last-error (car (wisi-parser-parse-errors parser))))
- (unless (= 1 (length sexp))
- (cl-do ((i 1 (1+ i))) ((= i (length sexp)))
- (push
- (make-wisi--parse-error-repair
- :pos (copy-marker (aref (aref sexp i) 0))
- :inserted (mapcar (lambda (id) (aref token-table id)) (aref (aref
sexp i) 1))
- :deleted (mapcar (lambda (id) (aref token-table id)) (aref (aref
sexp i) 2))
- :deleted-region (aref (aref sexp i) 3))
- (wisi--parse-error-repair last-error)))
- )))
-
-(defun wisi-process-parse--End (parser sexp)
- ;; sexp is [End pos]
- ;; see ‘wisi-process-parse--execute’
- (setf (wisi-process--parser-end-pos parser) (1+ (aref sexp 1))))
-
-(defun wisi-process-parse--Edit (parser sexp)
- ;; sexp is [Edit begin end text]
- (delete-region (aref sexp 1) (1+ (aref sexp 2)))
- (goto-char (aref sexp 1))
- (insert (aref sexp 3)))
-
-(defun wisi-process-parse--Language (parser sexp)
- ;; sexp is [Language language-action ...]
- (funcall (aref (wisi-process--parser-language-action-table parser) (aref
sexp 1)) sexp))
-
-(defun wisi-process-parse--execute (parser sexp)
- "Execute encoded SEXP sent from external process."
- ;; sexp is [action arg ...]; an encoded instruction that we need to execute
- ;;
- ;; Actions:
- ;;
- ;; [Navigate_Cache pos statement_id id length class containing_pos prev_pos
next_pos end_pos]
- ;; Set a wisi-cache text-property.
- ;; *pos : integer buffer position; -1 if nil (not set)
- ;; *id : integer index into parser-token-table
- ;; length : integer character count
- ;; class : integer index into wisi-class-list
- ;;
- ;; [Name_Property first-pos last-pos]
- ;;
- ;; [Face_Property first-pos last-pos face-index]
- ;; Set a font-lock-face text-property
- ;; face-index: integer index into parser-elisp-face-table
- ;;
- ;; [Indent line-number indent]
- ;; Set an indent text property
- ;;
- ;; [Lexer_Error char-position <message> <repair-char>]
- ;; The lexer detected an error at char-position.
- ;;
- ;; If <repair-char> is not ASCII NUL, it was inserted immediately
- ;; after char-position to fix the error.
- ;;
- ;; [Parser_Error char-position <message>]
- ;; The parser detected a syntax error; save information for later
- ;; reporting.
- ;;
- ;; If error recovery is successful, there can be more than one
- ;; error reported during a parse.
- ;;
- ;; [Check_Error code name-1-pos name-2-pos <string>]
- ;; The parser detected a semantic check error; save information
- ;; for later reporting.
- ;;
- ;; If error recovery is successful, there can be more than one
- ;; error reported during a parse.
- ;;
- ;; [Recover [pos [inserted] [deleted] deleted-region]...]
- ;; The parser finished a successful error recovery.
- ;;
- ;; pos: Buffer position
- ;;
- ;; inserted: Virtual tokens (terminal or non-terminal) inserted
- ;; before pos.
- ;;
- ;; deleted: Tokens deleted after pos.
- ;;
- ;; deleted-region: source buffer region containing deleted tokens
- ;;
- ;; Args are token ids; index into parser-token-table. Save the
- ;; information for later use by ’wisi-repair-error’.
- ;;
- ;; [Edit begin end text]
- ;; Replace region BEGIN . END with TEXT; normally the result of a
- ;; refactor command.
- ;;
- ;; [Language ...]
- ;; Dispatch to a language-specific action, via
- ;; `wisi-process--parser-language-action-table'.
- ;;
- ;;
- ;; Numeric action codes are given in the case expression below
-
- (cl-ecase (aref sexp 0)
- (1 (wisi-process-parse--Navigate_Cache parser sexp))
- (2 (wisi-process-parse--Face_Property parser sexp))
- (3 (wisi-process-parse--Indent parser sexp))
- (4 (wisi-process-parse--Lexer_Error parser sexp))
- (5 (wisi-process-parse--Parser_Error parser sexp))
- (6 (wisi-process-parse--Check_Error parser sexp))
- (7 (wisi-process-parse--Recover parser sexp))
- (8 (wisi-process-parse--End parser sexp))
- (9 (wisi-process-parse--Name_Property parser sexp))
- (10 (wisi-process-parse--Edit parser sexp))
- (11 (wisi-process-parse--Language parser sexp))
- ))
-
-;;;;; main
-
-(cl-defmethod wisi-parse-kill ((parser wisi-process--parser))
- (when (process-live-p (wisi-process--parser-process parser))
- ;; We used to send a quit command first, to be nice. But there's
- ;; no timeout on that, so it would hang when the process
- ;; executable is not reading command input.
- (when (process-live-p (wisi-process--parser-process parser))
- (kill-process (wisi-process--parser-process parser)))
- )
- (setf (wisi-process--parser-busy parser) nil))
-
-(defvar wisi--lexer nil) ;; wisi-elisp-lexer.el
-(declare-function wisi-elisp-lexer-reset "wisi-elisp-lexer")
-
-(defun wisi-process-parse--prepare (parser)
- ;; font-lock can trigger a face parse while navigate or indent parse
- ;; is active, due to ‘accept-process-output’ below. Signaling an
- ;; error tells font-lock to try again later.
- (if (wisi-process--parser-busy parser)
- (progn
- (setf (wisi-parser-parse-errors parser)
- (list
- (make-wisi--parse-error
- :pos 0
- :message (format "%s:%d:%d: parser busy (try
’wisi-kill-parser’)"
- (if (buffer-file-name) (file-name-nondirectory
(buffer-file-name)) "") 1 1))
- ))
- (error "%s parse abandoned; parser busy - use partial parse?"
wisi--parse-action)
- )
-
- ;; It is not possible for a background elisp function (ie
- ;; font-lock) to interrupt this code between checking and setting
- ;; parser-busy; background elisp can only run when we call
- ;; accept-process-output below.
- (setf (wisi-process--parser-busy parser) t)
-
- ;; If the parser process has not started yet,
- ;; wisi-process-parse--require-process calls
- ;; wisi-process-parse--wait, which can let font-lock invoke the
- ;; parser again. Thus this call must be after we set
- ;; wisi-process--parser-busy t
- (wisi-process-parse--require-process parser)
-
- (setf (wisi-process--parser-total-wait-time parser) 0.0)
- (setf (wisi-parser-lexer-errors parser) nil)
- (setf (wisi-parser-parse-errors parser) nil)
- ))
-
-(defun wisi-process-parse--handle-messages (parser)
- (condition-case-unless-debug err
- (let* ((source-buffer (current-buffer))
- (response-buffer (wisi-process--parser-buffer parser))
- (process (wisi-process--parser-process parser))
- (w32-pipe-read-delay 0) ;; fastest subprocess read
- response
- response-end
- (response-count 0)
- sexp-start
- (need-more nil) ;; point-max if need more, to check for new input
- (done nil)
- start-wait-time)
-
- (set-buffer response-buffer)
- (setq sexp-start (point-min))
-
- ;; process responses until prompt received
- (while (not done)
-
- ;; process all complete responses currently in buffer
- (while (and (not need-more)
- (not done))
-
- (goto-char sexp-start)
-
- (cond
- ((eobp)
- (setq need-more (point-max)))
-
- ((looking-at wisi-process-parse-prompt)
- (setq done t))
-
- ((or (looking-at "\\[") ;; encoded action
- (looking-at "(")) ;; error or other elisp expression to eval
- (condition-case nil
- (setq response-end (scan-sexps (point) 1))
- (error
- ;; incomplete response
- (setq need-more (point-max))
- nil))
-
- (unless need-more
- (setq response-count (1+ response-count))
- (setq response (car (read-from-string
(buffer-substring-no-properties (point) response-end))))
- (goto-char response-end)
- (forward-line 1)
- (setq sexp-start (point))
-
- (set-buffer source-buffer) ;; for put-text-property in actions
- (cond
- ((listp response)
- ;; non-syntax error of some sort
- (cond
- ((equal '(parse_error) response)
- ;; Parser detected a syntax error, and recovery failed, so
signal it.
-
- (when (> wisi-debug 0)
- ;; Save a copy of parser output; may be overwritten by
subsequent parse face attempts.
- (set-buffer response-buffer)
- (let ((content (buffer-substring-no-properties
(point-min) (point-max)))
- (buf-name (concat (buffer-name) "-save-error")))
- (set-buffer (get-buffer-create buf-name))
- (insert content)))
-
- (if (wisi-parser-parse-errors parser)
- (signal 'wisi-parse-error
- (wisi--parse-error-message (car
(wisi-parser-parse-errors parser))))
-
- ;; can have no errors when testing a new parser
- (push
- (make-wisi--parse-error :pos 0 :message "parser failed
with no message")
- (wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error "parser failed with no
message")))
-
- ((equal 'parse_error (car response))
- ;; Parser detected some other error non-fatal error, so
signal it.
- (push
- (make-wisi--parse-error :pos 0 :message (cadr response))
- (wisi-parser-parse-errors parser))
- (signal 'wisi-parse-error (cdr response)))
-
- ((and (eq 'error (car response))
- (string-prefix-p "bad command:" (cadr response)))
- ;; Parser dropped bytes, is treating buffer
- ;; content bytes as commands. Kill the process
- ;; to kill the pipes; there is no other way to
- ;; flush them.
- (kill-process (wisi-process--parser-process parser))
- (signal 'wisi-parse-error "parser lost sync; killed"))
-
- (t
- ;; Some other error
- (condition-case-unless-debug err
- (eval response)
- (error
- (push (make-wisi--parse-error :pos (point) :message
(cadr err)) (wisi-parser-parse-errors parser))
- (signal (car err) (cdr err)))))
- ))
-
- ((arrayp response)
- ;; encoded action
- (condition-case-unless-debug err
- (wisi-process-parse--execute parser response)
- (wisi-parse-error
- (push (make-wisi--parse-error :pos (point) :message (cadr
err)) (wisi-parser-parse-errors parser))
- (signal (car err) (cdr err)))
-
- (error ;; ie from un-commented
[C:\Windows\system32\KERNEL32.DLL], or bug in action code above.
- (set-buffer response-buffer)
- (let ((content (buffer-substring-no-properties (point-min)
(point-max)))
- (buf-name (concat (buffer-name) "-save-error")))
- (set-buffer (get-buffer-create buf-name))
- (insert content)
- (insert (format "%s" err))
- (error "parser failed; error messages in %s" buf-name)))
- ))
- )
-
- (set-buffer response-buffer)
- ))
-
- (t
- ;; debug output
- (forward-line 1)
- (setq sexp-start (point)))
- )
- )
-
- (unless done
- ;; end of response buffer
- (unless (process-live-p process)
- (set-buffer response-buffer)
- (let ((content (buffer-substring-no-properties (point-min)
(point-max)))
- (buf-name (concat (buffer-name) "-save-error")))
- (set-buffer (get-buffer-create buf-name))
- (insert content)
- (error "parser failed; error messages in %s" buf-name)))
-
- (setq start-wait-time (float-time))
-
- ;; If we specify no time-out here, we get messages about
- ;; "blocking call with quit inhibited", when this is
- ;; called by font-lock from the display engine.
- ;;
- ;; Specifying just-this-one t prevents C-q from
- ;; interrupting this?
- (accept-process-output
- process
- wisi-process-time-out
- nil ;; milliseconds
- nil) ;; just-this-one
-
- (setf (wisi-process--parser-total-wait-time parser)
- (+ (wisi-process--parser-total-wait-time parser)
- (- (float-time) start-wait-time)))
-
- (when (and (= (point-max) need-more)
- (> (wisi-process--parser-total-wait-time parser)
wisi-process-time-out))
- (error "wisi-process-parse timing out; increase
`wisi-process-time-out'? (or bad syntax in process output)"))
-
- (setq need-more nil))
- );; while not done
-
- ;; got command prompt
- (unless (process-live-p process)
- (wisi-process-parse-show-buffer parser)
- (error "wisi-process-parse process died"))
-
- (setf (wisi-process--parser-response-count parser) response-count)
-
- (setf (wisi-process--parser-busy parser) nil)
- (set-buffer source-buffer)
- ;; If we get here, the parse succeeded (possibly with error
- ;; recovery); move point to end of parsed region.
- (goto-char (wisi-process--parser-end-pos parser))
- )
-
- (wisi-parse-error
- (setf (wisi-process--parser-busy parser) nil)
- (signal (car err) (cdr err)))
-
- (error
- (setf (wisi-process--parser-busy parser) nil)
- (signal (car err) (cdr err))
- )))
-
-(cl-defmethod wisi-parse-current ((parser wisi-process--parser) begin send-end
parse-end)
- (wisi-process-parse--prepare parser)
- (let ((total-line-count (1+ (count-lines (point-max) (point-min)))))
- (setf (wisi-process--parser-line-begin parser) (wisi--set-line-begin
total-line-count))
- (wisi-process-parse--send-parse parser begin send-end parse-end)
-
- ;; We reset the elisp lexer, because post-parse actions may use it.
- (when wisi--lexer
- (wisi-elisp-lexer-reset total-line-count wisi--lexer))
- )
- (wisi-process-parse--handle-messages parser)
- (cons begin (point))
- )
-
-(cl-defmethod wisi-refactor ((parser wisi-process--parser) refactor-action
parse-begin parse-end edit-begin)
- (save-excursion
- (wisi-process-parse--prepare parser)
- (wisi-process-parse--send-refactor parser refactor-action parse-begin
parse-end edit-begin)
- (wisi-process-parse--handle-messages parser))
- )
-
-(defvar wisi--parser nil) ;; wisi.el
-
-(defun wisi-process-send-tokens-noop ()
- "Run lexer, send tokens to subprocess; otherwise no operation.
-For use with ’wisi-time’."
- (wisi-process-parse--require-process wisi--parser)
- (if (wisi-process--parser-busy wisi--parser)
- (error "%s parser busy" wisi--parse-action)
-
- ;; not busy
- (let* ((source-buffer (current-buffer))
- (action-buffer (wisi-process--parser-buffer wisi--parser))
- (process (wisi-process--parser-process wisi--parser))
- (sexp-start (point-min))
- (need-more nil)
- (done nil))
-
- (setf (wisi-process--parser-busy wisi--parser) t)
- (wisi-process-parse--send-noop wisi--parser)
-
- (set-buffer action-buffer)
- (while (and (process-live-p process)
- (not done))
- (goto-char sexp-start)
- (cond
- ((eobp)
- (setq need-more t))
-
- ((looking-at wisi-process-parse-prompt)
- (setq done t))
-
- (t
- (forward-line 1)
- (setq sexp-start (point)))
- )
-
- (unless done
- ;; end of response buffer
- (unless (process-live-p process)
- (wisi-process-parse-show-buffer wisi--parser)
- (error "wisi-process-parse process died"))
-
- (accept-process-output process 1.0 nil nil)
- (setq need-more nil))
- )
- (set-buffer source-buffer)
- (setf (wisi-process--parser-busy wisi--parser) nil)
- )))
-
-;;;;; debugging
-(defun wisi-process-parse-ids-to-enum (token-table &rest int-ids)
- "Translate INT-IDS from process integer token ids to elisp enumeral ids.
-Returns reversed sequence."
- (let ((enum-ids nil))
- (cl-dolist (i int-ids)
- (push (aref token-table i) enum-ids))
- enum-ids))
-
-(defun wisi-process-parse-show-args ()
- "Show the partial parse command-line args for run_ada_[lalr | lr1]_parse for
current region.
-Also add it to the kill ring."
- (interactive)
- (let* ((begin (region-beginning))
- (end (region-end))
- (parse-action (wisi-read-parse-action))
- (msg
- (format "%s %s %d %d %d %d %d %d %d"
- (file-name-nondirectory (buffer-file-name))
- parse-action
- (position-bytes begin)
- (position-bytes end)
- (position-bytes end)
- begin ;; char_pos
- (line-number-at-pos begin)
- (line-number-at-pos end)
- (save-excursion (goto-char begin) (back-to-indentation)
(current-column));; indent-begin
- )))
- (kill-new msg)
- (message msg)))
-
-(provide 'wisi-process-parse)
diff --git a/packages/wisi/wisi-run-indent-test.el
b/packages/wisi/wisi-run-indent-test.el
deleted file mode 100644
index 8c0eef0..0000000
--- a/packages/wisi/wisi-run-indent-test.el
+++ /dev/null
@@ -1,399 +0,0 @@
-;;; wisi-run-indent-test.el --- utils for automating indentation and casing
tests
-;;
-;; Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-(require 'wisi-tests)
-(require 'wisi-prj)
-
-;; user can set these to t in an EMACSCMD
-(defvar skip-cmds nil)
-(defvar skip-reindent-test nil)
-(defvar skip-recase-test nil)
-(defvar skip-write nil)
-
-(defun test-in-comment-p ()
- (nth 4 (syntax-ppss)))
-
-(defun test-face (token face)
- "Test if all of TOKEN in next code line has FACE.
-FACE may be a list."
- (save-excursion
- (when (test-in-comment-p)
- (beginning-of-line); forward-comment doesn't move if inside a comment!
- (forward-comment (point-max)))
- (condition-case err
- (search-forward token (line-end-position 5))
- (error
- (error "can't find '%s'" token)))
-
- (save-match-data
- (wisi-validate-cache (line-beginning-position) (line-end-position) nil
'face)
- (font-lock-ensure (line-beginning-position) (line-end-position)))
-
- ;; We don't use face-at-point, because it doesn't respect
- ;; font-lock-face set by the parser! And we want to check for
- ;; conflicts between font-lock-keywords and the parser.
-
- ;; font-lock-keywords sets 'face property, parser sets 'font-lock-face.
-
- ;; In emacs < 27, if we use (get-text-property (point) 'face), we
- ;; also get 'font-lock-face, but not vice-versa. So we have to use
- ;; text-properties-at to check for both.
- (let* ((token (match-string 0))
- (props (text-properties-at (match-beginning 0)))
- key
- token-face)
-
- (cond
- ((plist-get props 'font-lock-face)
- (setq key 'font-lock-face)
- (setq token-face (plist-get props 'font-lock-face)))
-
- ((plist-get props 'face)
- (setq key 'face)
- (setq token-face (plist-get props 'face)))
- )
-
- (when (and (memq 'font-lock-face props)
- (memq 'face props))
- (describe-text-properties (match-beginning 0))
- (error "mixed font-lock-keyword and parser faces for '%s'" token))
-
- (unless (not (text-property-not-all 0 (length token) key token-face
token))
- (error "mixed faces, expecting %s for '%s'" face token))
-
- (unless (or (and (listp face)
- (memq token-face face))
- (eq token-face face))
- (error "found face %s, expecting %s for '%s'" token-face face token))
- )))
-
-(defun test-face-1 (search token face)
- "Move to end of comment, search for SEARCH, call `test-face'."
- (save-excursion
- (when (test-in-comment-p)
- (beginning-of-line); forward-comment doesn't move if inside a comment!
- (forward-comment (point-max)))
- (search-forward search)
- (test-face token face)
- ))
-
-(defun test-cache-class (token class)
- "Test if TOKEN in next code line has wisi-cache with class CLASS."
- (save-excursion
- (wisi-validate-cache (line-beginning-position 0) (line-end-position 3) nil
'navigate)
- (beginning-of-line); forward-comment doesn't move if inside a comment!
- (forward-comment (point-max))
- (condition-case err
- (search-forward token (line-end-position 5))
- (error
- (error "can't find '%s'" token)))
-
- (let ((cache (get-text-property (match-beginning 0) 'wisi-cache)))
-
- (unless cache (error "no cache"))
- (unless (eq (wisi-cache-class cache) class)
- (error "expecting class %s, found '%s'" class (wisi-cache-class cache)))
- )))
-
-(defun test-cache-containing (containing contained)
- "Test if CONTAINING in next code line has wisi-cache with that contains
CONTAINED."
- (save-excursion
- (wisi-validate-cache (line-beginning-position 0) (line-end-position 3) nil
'navigate)
- (beginning-of-line)
- (forward-comment (point-max))
- (let (containing-pos contained-cache)
- (search-forward containing (line-end-position 5))
- (setq containing-pos (match-beginning 0))
-
- (search-forward contained (line-end-position 5))
- (setq contained-cache (get-text-property (match-beginning 0)
'wisi-cache))
-
- (unless contained-cache (error "no cache on %s" contained))
- (unless (= containing-pos (wisi-cache-containing contained-cache))
- (error "expecting %d, got %d" containing-pos (wisi-cache-containing
contained-cache)))
- )))
-
-(defvar test-refactor-markers nil
- "Stores positions altered by `test-refactor-1' for `test-refactor-2'.
-Each item is a list (ACTION PARSE-BEGIN PARSE-END EDIT-BEGIN)")
-
-(defun test-refactor-1 (action inverse-action search-string refactor-string)
- (beginning-of-line)
- (forward-comment (point-max)) ;; forward-comment does not work from inside
comment
- (search-forward search-string (line-end-position 7))
- (wisi-validate-cache (line-end-position -7) (line-end-position 7) t
'navigate)
- (search-forward refactor-string (line-end-position 7))
- (let* ((edit-begin (match-beginning 0))
- (cache (wisi-goto-statement-start))
- (parse-begin (point))
- (parse-end (wisi-cache-end cache)))
- (setq parse-end (+ parse-end (wisi-cache-last (wisi-get-cache
(wisi-cache-end cache)))))
- (push (list
- inverse-action
- (copy-marker parse-begin nil)
- (copy-marker parse-end nil)
- (copy-marker edit-begin nil))
- test-refactor-markers)
- (wisi-refactor wisi--parser action parse-begin parse-end edit-begin)
- ))
-
-(defun test-refactor-inverse ()
- "Reverse refactors done by recent set of `test-refactor-1'."
- (save-excursion
- (condition-case-unless-debug nil
- (dolist (item test-refactor-markers)
- (wisi-refactor wisi--parser
- (nth 0 item)
- (marker-position (nth 1 item))
- (marker-position (nth 2 item))
- (marker-position (nth 3 item))))
- (error nil))
- (setq test-refactor-markers nil)))
-
-(defun run-test-here ()
- "Run an indentation and casing test on the current buffer."
- (interactive)
- (setq indent-tabs-mode nil)
- (setq jit-lock-context-time 0.0);; for test-face
-
- ;; Test files use wisi-prj-select-cached to parse and select a project file.
- (setq project-find-functions (list #'wisi-prj-current-cached))
- (setq xref-backend-functions (list #'wisi-prj-xref-backend))
-
-
- (let ((error-count 0)
- (test-buffer (current-buffer))
- cmd-line
- last-result last-cmd expected-result)
- ;; Look for EMACS* comments in the file:
- ;;
- ;; EMACSCMD: <form>
- ;; Executes the lisp form inside a save-excursion, saves the result as
a lisp object.
- ;;
- ;; EMACSRESULT: <form>
- ;; point is moved to end of line, <form> is evaluated inside
- ;; save-excursion and compared (using `equal') with the result
- ;; of the previous EMACSCMD, and the test fails if they don't
- ;; match.
- ;;
- ;; EMACSRESULT_START:<first list element>
- ;; EMACSRESULT_ADD: <list element>
- ;; EMACSRESULT_FINISH:
- ;; build a list, compare it to the result of the previous EMACSCMD.
- ;;
- ;; EMACS_SKIP_UNLESS: <form>
- ;; skip entire test if form evals nil
- ;;
- ;; EMACSDEBUG: <form>
- ;; Eval form, display result. Also used for setting breakpoint.
-
- (goto-char (point-min))
- (while (and (not skip-cmds)
- (re-search-forward (concat comment-start "EMACS\\([^:]+\\):")
nil t))
- (cond
- ((string= (match-string 1) "CMD")
- (looking-at ".*$")
- (save-excursion
- (setq cmd-line (line-number-at-pos)
- last-cmd (match-string 0)
- last-result
- (condition-case-unless-debug err
- (eval (car (read-from-string last-cmd)))
- (error
- (setq error-count (1+ error-count))
- (message "%s:%d: command: %s"
- (buffer-file-name) cmd-line last-cmd)
- (message "%s:%d: %s: %s"
- (buffer-file-name)
- (line-number-at-pos)
- (car err)
- (cdr err))))
- )
- ;; save-excursion does not preserve mapping of buffer to
- ;; window, but some tests depend on that. For example,
- ;; execute-kbd-macro doesn’t work properly if current buffer
- ;; is not visible..
- (pop-to-buffer test-buffer)))
-
- ((string= (match-string 1) "RESULT")
- (looking-at ".*$")
- (setq expected-result (save-excursion (end-of-line 1) (eval (car
(read-from-string (match-string 0))))))
- (unless (equal expected-result last-result)
- (setq error-count (1+ error-count))
- (message
- (concat
- (format "error: %s:%d:\n" (buffer-file-name) (line-number-at-pos))
- (format "Result of '%s' does not match.\nGot '%s',\nexpect '%s'"
- last-cmd
- last-result
- expected-result)
- ))))
-
- ((string= (match-string 1) "RESULT_START")
- (looking-at ".*$")
- (setq expected-result (list (save-excursion (end-of-line 1) (eval (car
(read-from-string (match-string 0))))))))
-
- ((string= (match-string 1) "RESULT_ADD")
- (looking-at ".*$")
- (let ((val (save-excursion (end-of-line 1)
- (eval (car (read-from-string (match-string
0)))))))
- (when val
- (setq expected-result (append expected-result (list val))))))
-
- ((string= (match-string 1) "RESULT_FINISH")
- (unless (equal (length expected-result) (length last-result))
- (setq error-count (1+ error-count))
- (message
- (concat
- (format "error: %s:%d:\n" (buffer-file-name) (line-number-at-pos))
- (format "Length of result of '%s' does not match.\nGot
'%s',\nexpect '%s'"
- last-cmd
- (length last-result)
- (length expected-result)))))
-
- (let ((i 0))
- (while (< i (length expected-result))
- (unless (equal (nth i expected-result) (nth i last-result))
- (setq error-count (1+ error-count))
- (message
- (concat
- (format "error: %s:%d:\n" (buffer-file-name)
(line-number-at-pos))
- (format "Nth (%d) result of '%s' does not match.\nGot
'%s',\nexpect '%s'"
- i
- last-cmd
- (nth i last-result)
- (nth i expected-result))
- )))
- (setq i (1+ i)))))
-
- ((string= (match-string 1) "_SKIP_UNLESS")
- (looking-at ".*$")
- (unless (eval (car (read-from-string (match-string 0))))
- (setq skip-cmds t)
- (setq skip-reindent-test t)
- (setq skip-recase-test t)
- ;; We don’t set ‘skip-write’ t here, so the *.diff Make target
succeeds.
- ))
-
- ((string= (match-string 1) "DEBUG")
- (looking-at ".*$")
- (message "DEBUG: %s:%d %s"
- (current-buffer)
- (line-number-at-pos)
- (save-excursion
- (eval (car (read-from-string (match-string 0)))))))
-
- (t
- (setq error-count (1+ error-count))
- (error (concat "Unexpected EMACS test command " (match-string 1))))))
-
- (when (> error-count 0)
- (error
- "%s:%d: aborting due to previous errors (%d)"
- (buffer-file-name) (line-number-at-pos (point)) error-count))
- )
-
- (unless skip-reindent-test
- ;; Reindent the buffer
- (message "indenting")
-
- ;; first unindent; if the indentation rules do nothing, the test
- ;; would pass, otherwise! Only unindent by 1 column, so comments
- ;; not currently in column 0 are still not in column 0, in case
- ;; the mode supports a special case for comments in column 0.
- (indent-rigidly (point-min) (point-max) -1)
-
- ;; indent-region uses save-excursion, so we can't goto an error location
- (indent-region (point-min) (point-max))
-
- ;; Cleanup the buffer; indenting often leaves trailing whitespace;
- ;; files must be saved without any.
- (delete-trailing-whitespace)
- )
-
- (when (and wisi-auto-case (not skip-recase-test))
- (message "casing")
- (wisi-case-adjust-buffer))
- )
-
-(defvar cl-print-readably); cl-print.el, used by edebug
-
-(defun large-frame ()
- (interactive)
- (modify-frame-parameters
- nil
- (list
- (cons 'width 120) ;; characters; fringe extra
- (cons 'height 71) ;; characters
- (cons 'left 0) ;; pixels
- (cons 'top 0))))
-(define-key global-map "\C-cp" 'large-screen)
-
-(defun run-test (file-name)
- "Run an indentation and casing test on FILE-NAME."
- (interactive "f")
-
- (package-initialize) ;; for uniquify-files
-
- ;; Let edebug display strings full-length, and show internals of records
- (setq cl-print-readably t)
-
- ;; we'd like to run emacs from a makefile as:
- ;;
- ;; emacs -Q --batch -l runtest.el -f run-test-here <filename>
- ;;
- ;; However, the function specified with -f is run _before_
- ;; <filename> is visited. So we try this instead:
- ;;
- ;; emacs -Q --batch -l runtest.el --eval '(run-test "<filename>")'
- ;;
- ;; And then we discover that processes spawned with start-process
- ;; don't run when emacs is in --batch mode. So we try this:
- ;;
- ;; emacs -Q -l runtest.el --eval '(progn (run-test
"<filename>")(kill-emacs))'
- ;;
- ;; Then we have problems with font lock defaulting to jit-lock; that
- ;; screws up font-lock tests because the test runs before jit-lock
- ;; does. This forces default font-lock, which fontifies the whole
- ;; buffer when (font-lock-fontify-buffer) is called, which tests
- ;; that rely on font-lock do explicitly.
- (setq font-lock-support-mode nil)
-
- (setq xref-prompt-for-identifier nil)
-
- (let ((dir default-directory))
- (find-file file-name) ;; sets default-directory
-
- (run-test-here)
-
- (unless skip-write
- ;; Write the result file; makefile will diff.
- (when skip-reindent-test
- ;; user sets skip-reindent-test when testing interactive editing
- ;; commands, so the diff would fail. Revert to the original file,
- ;; save a copy of that.
- (revert-buffer t t))
-
- (delete-trailing-whitespace)
- (write-file (concat dir (file-name-nondirectory file-name) ".tmp")) )
- )
- )
-
-(provide 'wisi-run-indent-test)
-;; end of file
diff --git a/packages/wisi/wisi-skel.el b/packages/wisi/wisi-skel.el
deleted file mode 100644
index 9af5b9b..0000000
--- a/packages/wisi/wisi-skel.el
+++ /dev/null
@@ -1,187 +0,0 @@
-;;; wisi-skel.el --- Extensions skeleton -*- lexical-binding:t -*-
-
-;; Copyright (C) 1987, 1993, 1994, 1996-2020 Free Software Foundation, Inc.
-
-;; Authors: Stephen Leake <stephen_leake@stephe-leake.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Design:
-;;
-;; The primary user command is `wisi-skel-expand', which inserts the
-;; skeleton associated with the previous word (possibly skipping a
-;; name).
-
-(require 'skeleton)
-
-(defvar-local wisi-skel-token-alist nil
- "Alist of (STRING . ELEMENT), used by `wisi-skel-expand'.
-STRING should be a grammar symbol in the current language.
-
-ELEMENT may be:
-- a skeleton, which is inserted
-- an alist of (STRING . SKELETON). User is prompted with `completing-read',
- selected skeleton is inserted.")
-
-(defun wisi-skel-add-token-after (alist token skel after-1 &optional after-2)
- "Add a new entry in ALIST (should be an instance of `wisi-skel-token-alist')
-after AFTER-1. If AFTER-1 is a nested alist, add the new entry after AFTER-2."
- (let ((tail alist)
- done)
- (if (string= after-1 (car (car alist)))
- (setcdr alist (cons (cons token skel) (cdr alist)))
-
- (while (and (not done) tail)
- (if (string= after-1 (car-safe (car (cdr tail))))
- (cond
- ((symbolp (cdr (car (cdr tail))))
- (setcdr tail (cons (cons token skel) (cdr (cdr tail))))
- (setq done t))
-
- ((consp (cdr (car (cdr tail))))
- (wisi-skel-add-token-after (cdr (car (cdr tail))) token skel
after-2)
- (setq done t))
- )
- ;; else
- (setq tail (cdr tail))
- ))
- )))
-
-(defun wisi-skel-build-prompt (alist count)
- "Build a prompt from the keys of the ALIST.
-The prompt consists of the first COUNT keys from the alist, separated by `|',
with
-trailing `...' if there are more keys."
- (if (>= count (length alist))
- (concat (mapconcat 'car alist " | ") " : ")
- (let ((alist-1 (butlast alist (- (length alist) count))))
- (concat (mapconcat 'car alist-1 " | ") " | ... : "))
- ))
-
-(defvar wisi-skel-test-input nil
- "Override prompt for input from wisi-skel-token-alist, for unit testing."
- ;; see test/ada_skel.adb
- )
-
-(defun wisi-skel-expand (&optional name)
- "Expand the token or placeholder before point to a skeleton.
-Tokens are defined by `wisi-skel-token-alist'; they must have
-symbol syntax. A placeholder is a token enclosed in generic
-comment delimiters. If the symbol before point is not in
-`wisi-skel-token-alist', assume it is a name, and use the symbol
-before that as the token."
- (interactive "*")
-
- ;; Skip trailing space, newline, and placeholder delimiter.
- ;; Standard comment end included for languages where that is newline.
- (skip-syntax-backward " !>")
-
- (let* ((wisi-inhibit-parse t) ;; don't parse until skeleton is fully inserted
- (end (point))
- ;; Include punctuation here, to handle a dotted name (ie Ada.Text_IO)
- (token (progn (skip-syntax-backward "w_.")
- (downcase (buffer-substring-no-properties (point) end))))
- (skel (assoc-string token wisi-skel-token-alist))
- (handled nil))
-
- (if skel
- (progn
- (when (listp (cdr skel))
- (let* ((alist (cdr skel))
- (prompt (wisi-skel-build-prompt alist 4)))
- (setq skel (assoc-string
- (or wisi-skel-test-input (completing-read prompt
alist))
- alist))
- ))
-
- ;; delete placeholder delimiters around token, token, and
- ;; name. point is currently before token.
- (skip-syntax-backward "!")
- (delete-region
- (point)
- (progn
- (skip-syntax-forward "!w_")
- (when name
- (skip-syntax-forward " ")
- (skip-syntax-forward "w_."))
- (point)))
- (let ((skeleton-end-newline nil))
- (funcall (cdr skel) name))
- (setq handled t))
-
- ;; word in point .. end is not a token; assume it is a name
- (when (not name)
- ;; avoid infinite recursion
-
- (when wisi-auto-case
- ;; Adjust case now, because skeleton insert won't.
- ;;
- ;; We didn't do it above, because we don't want to adjust case
- ;; on tokens and placeholders.
- (save-excursion (wisi-case-adjust-region (point) end)))
-
- (condition-case-unless-debug nil
- (progn
- (wisi-skel-expand (buffer-substring-no-properties (point) end))
- (setq handled t))
- (user-error ;; leave handled nil
- ))
- ))
-
- (when (not handled)
- (setq name (buffer-substring-no-properties (point) end))
- ;; restore point
- (goto-char end)
- (user-error "'%s' is not a skeleton token" name))
- ))
-
-;;;###autoload
-(defun wisi-skel-hippie-try (old)
- "For `hippie-expand-try-functions-list'."
- (if old
- ;; hippie is asking us to try the "next" completion; we don't have one
- nil
- (let ((pos (point))
- (undo-len (if (eq 't pending-undo-list)
- 0
- (length pending-undo-list))))
- (undo-boundary)
- (condition-case nil
- (progn
- (wisi-skel-expand)
- t)
- (error
- ;; undo hook action if any
- (unless (or (eq 't pending-undo-list)
- (= undo-len (length pending-undo-list)))
- (undo))
-
- ;; undo motion
- (goto-char pos)
- nil)))))
-
-(defun wisi-skel-next-placeholder ()
- "Move point to after next placeholder."
- (interactive)
- (skip-syntax-forward "^!")
- (skip-syntax-forward "w_!"))
-
-(defun wisi-skel-prev-placeholder ()
- "Move point to after previous placeholder."
- (interactive)
- (skip-syntax-backward "^!"))
-
-(provide 'wisi-skel)
-;;; wisi-skel.el ends here
diff --git a/packages/wisi/wisi-tests.el b/packages/wisi/wisi-tests.el
deleted file mode 100644
index b730cf1..0000000
--- a/packages/wisi/wisi-tests.el
+++ /dev/null
@@ -1,120 +0,0 @@
-;;; wisi-tests.el --- Common utils for wisi tests -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2012 - 2019 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-;;
-
-(require 'cl-lib)
-(require 'wisi)
-
-(defvar wisi-test-parser 'process
- "Set to ’process to test external process parser.")
-
-(defvar test-syntax-table
- (let ((table (make-syntax-table)))
- ;; make-syntax-table sets all alphanumeric to w, etc; so we only
- ;; have to add test-specific things.
-
- ;; operator symbols
- (modify-syntax-entry ?& "." table)
- (modify-syntax-entry ?* "." table)
- (modify-syntax-entry ?+ "." table)
- (modify-syntax-entry ?- "." table)
- (modify-syntax-entry ?/ "." table)
- (modify-syntax-entry ?< "." table)
- (modify-syntax-entry ?= "." table)
- (modify-syntax-entry ?> "." table)
- (modify-syntax-entry ?| "." table)
-
- ;; \f and \n end a comment - see test-syntax-propertize for comment start
- (modify-syntax-entry ?\f "> " table)
- (modify-syntax-entry ?\n "> " table)
- table
- ))
-
-(defun test-syntax-propertize (start end)
- "Assign `syntax-table' properties in accessible part of buffer."
- ;; (info "(elisp)Syntax Properties")
- (let ((modified (buffer-modified-p))
- (buffer-undo-list t)
- (inhibit-read-only t)
- (inhibit-point-motion-hooks t)
- (inhibit-modification-hooks t))
- (goto-char start)
- (while (re-search-forward
- "\\(--\\)"; 1: comment start
- end t)
- ;; The help for syntax-propertize-extend-region-functions
- ;; implies that 'start end' will always include whole lines, in
- ;; which case we don't need
- ;; syntax-propertize-extend-region-functions
- (cond
- ((match-beginning 1)
- (put-text-property
- (match-beginning 1) (match-end 1) 'syntax-table '(11 . nil)))
- ))
- (unless modified
- (restore-buffer-modified-p nil))))
-
-(defun wisi-tests-setup (grammar-name)
- ;; grammar-elisp file must be on load-path
- ;; use Ada style comments in source
- (set-syntax-table test-syntax-table)
- (set (make-local-variable 'syntax-propertize-function)
'test-syntax-propertize)
- (syntax-ppss-flush-cache (point-min));; force re-evaluate with hook.
-
- (cl-ecase wisi-test-parser
- (process
- (require 'wisi-process-parse)
- (require (intern (concat grammar-name "-process"))) ;; generated by
wisi-generate
- (require (intern grammar-name)) ;; declares parser cl-defstruct
- (add-to-list 'exec-path default-directory)
- (wisi-setup
- :indent-calculate nil
- :post-indent-fail nil
- :parser
- (wisi-process-parse-get
- (funcall
- (intern-soft (concat "make-" grammar-name "-wisi-parser"))
- :label grammar-name
- :exec-file (concat grammar-name "_wisi_parse.exe")
- :face-table (symbol-value (intern-soft (concat grammar-name
"-process-face-table")))
- :token-table (symbol-value (intern-soft (concat grammar-name
"-process-token-table")))
- )))
- (setq wisi-mckenzie-disable nil)
- )
- )
-
- ;; Not clear why this is not being done automatically
- (syntax-propertize (point-max))
- )
-
-;;; Initialization
-
-;; Default includes mtn, among others, which is broken in Emacs 22.2
-(setq vc-handled-backends '(CVS))
-
-(setq eval-expression-debug-on-error nil)
-
-;; ’package-initialize’ is not here; it must be run as part of one of the
-;; -l or --eval command line options
-
-(provide 'wisi-tests)
-;; end of file
diff --git a/packages/wisi/wisi.adb b/packages/wisi/wisi.adb
deleted file mode 100644
index 91dacab..0000000
--- a/packages/wisi/wisi.adb
+++ /dev/null
@@ -1,2434 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Ada.Strings.Unbounded;
-with Ada.Text_IO;
-with SAL;
-with WisiToken.Semantic_Checks;
-package body Wisi is
- use WisiToken;
-
- Chars_Per_Int : constant Integer := Integer'Width;
-
- ----------
- -- body subprogram specs (as needed), alphabetical
-
- function Indent_Nil_P (Indent : in Indent_Type) return Boolean;
-
- function Max_Anchor_ID
- (Data : in out Parse_Data_Type;
- First_Line : in Line_Number_Type;
- Last_Line : in Line_Number_Type)
- return Integer;
-
- function Paren_In_Anchor_Line
- (Data : in out Parse_Data_Type'Class;
- Tree : in Syntax_Trees.Tree'Class;
- Anchor_Token : in Augmented_Token;
- Offset : in Integer)
- return Integer;
-
- ----------
- -- body subprograms bodies, alphabetical
-
- procedure Adjust_Paren_State
- (Data : in out Parse_Data_Type;
- Tree : in Syntax_Trees.Tree'Class;
- First_Token_Index : in Token_Index;
- First_Line : in Line_Number_Type;
- Adjust : in Integer)
- is begin
- for I in First_Token_Index .. Data.Terminals.Last_Index loop
- declare
- Aug : Augmented_Token renames Get_Aug_Token_Var (Data, Tree, I);
- begin
- Aug.Paren_State := Aug.Paren_State + Adjust;
- end;
- end loop;
-
- for Line in First_Line .. Data.Line_Paren_State.Last_Index loop
- Data.Line_Paren_State (Line) := Data.Line_Paren_State (Line) + Adjust;
- end loop;
- end Adjust_Paren_State;
-
- function Image (Aug : in WisiToken.Base_Token_Class_Access; Descriptor : in
WisiToken.Descriptor) return String
- is begin
- 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;
- Result : Unbounded_String := +"(";
- begin
- for I in Anchor_IDs.First_Index .. Anchor_IDs.Last_Index loop
- Result := Result & Integer'Image (Anchor_IDs (I));
- if I /= Anchor_IDs.Last_Index then
- Result := Result & ", ";
- else
- Result := Result & ")";
- end if;
- end loop;
- return -Result;
- end Image;
-
- function Image (Indent : in Indent_Type) return String
- is begin
- case Indent.Label is
- when Not_Set =>
- return "(" & Indent_Label'Image (Indent.Label) & ")";
-
- when Int =>
- return "(" & Indent_Label'Image (Indent.Label) & Integer'Image
(Indent.Int_Indent) & ")";
-
- when Anchor_Nil =>
- return "(" & Indent_Label'Image (Indent.Label) & ", " & Image
(Indent.Anchor_Nil_IDs) & ", nil)";
-
- when Anchor_Int =>
- return "(" & Indent_Label'Image (Indent.Label) & ", " & Image
(Indent.Anchor_Int_IDs) & ", " & Integer'Image
- (Indent.Anchor_Int_Indent) & ")";
-
- when Anchored =>
- return "(" & Indent_Label'Image (Indent.Label) & ", " & Integer'Image
(Indent.Anchored_ID) & ", " &
- Integer'Image (Indent.Anchored_Delta) & ")";
-
- when Anchor_Anchored =>
- return "(" & Indent_Label'Image (Indent.Label) & ", " & Image
(Indent.Anchor_Anchored_IDs) & Integer'Image
- (Indent.Anchor_Anchored_ID) & ", " & Integer'Image
(Indent.Anchor_Anchored_Delta) & ")";
- end case;
- end Image;
-
- procedure Indent_Apply_Anchored
- (Delta_Indent : in Simple_Delta_Type;
- Indent : in out Indent_Type)
- with Pre => Delta_Indent.Label = Anchored
- is begin
- -- Add Delta_Indent to Indent
-
- case Indent.Label is
- when Not_Set =>
- Indent := (Anchored, Delta_Indent.Anchored_ID,
Delta_Indent.Anchored_Delta);
-
- when Int =>
- if Delta_Indent.Anchored_Accumulate then
- Indent := (Anchored, Delta_Indent.Anchored_ID, Indent.Int_Indent +
Delta_Indent.Anchored_Delta);
- end if;
-
- when Anchor_Nil =>
- Indent :=
- (Anchor_Anchored,
- Indent.Anchor_Nil_IDs,
- Delta_Indent.Anchored_ID,
- Delta_Indent.Anchored_Delta);
-
- when Anchor_Int =>
- if Delta_Indent.Anchored_Accumulate then
- Indent :=
- (Anchor_Anchored,
- Indent.Anchor_Int_IDs,
- Delta_Indent.Anchored_ID,
- Delta_Indent.Anchored_Delta + Indent.Anchor_Int_Indent);
- end if;
-
- when Anchored | Anchor_Anchored =>
- -- already anchored
- null;
- end case;
- end Indent_Apply_Anchored;
-
- procedure Indent_Apply_Int (Indent : in out Indent_Type; Offset : in
Integer)
- is begin
- -- Add an Int indent to Indent
- case Indent.Label is
- when Not_Set =>
- Indent := (Int, Offset);
-
- when Int =>
- Indent.Int_Indent := Indent.Int_Indent + Offset;
-
- when Anchor_Nil =>
- Indent :=
- (Label => Anchor_Int,
- Anchor_Int_IDs => Indent.Anchor_Nil_IDs,
- Anchor_Int_Indent => Offset);
-
- when Anchor_Int =>
- Indent.Anchor_Int_Indent := Indent.Anchor_Int_Indent + Offset;
-
- when Anchored | Anchor_Anchored =>
- null;
- end case;
- end Indent_Apply_Int;
-
- procedure Indent_Line
- (Data : in out Parse_Data_Type;
- Line : in Line_Number_Type;
- Delta_Indent : in Delta_Type)
- is
- -- See note in Indent_Anchored_2 for why we can't use renames here.
- Indent : Indent_Type := Data.Indents (Line);
- begin
- case Delta_Indent.Label is
- when Simple =>
- case Delta_Indent.Simple_Delta.Label is
- when None =>
- null;
-
- when Int =>
- Indent_Apply_Int (Indent, Delta_Indent.Simple_Delta.Int_Delta);
-
- when Anchored =>
- Indent_Apply_Anchored (Delta_Indent.Simple_Delta, Indent);
- end case;
-
- when Hanging =>
- if Delta_Indent.Hanging_Accumulate or Indent_Nil_P (Data.Indents
(Line)) then
- if Line = Delta_Indent.Hanging_First_Line then
- -- Apply delta_1
- case Delta_Indent.Hanging_Delta_1.Label is
- when None =>
- null;
- when Int =>
- Indent_Apply_Int (Indent,
Delta_Indent.Hanging_Delta_1.Int_Delta);
- when Anchored =>
- Indent_Apply_Anchored (Delta_Indent.Hanging_Delta_1, Indent);
- end case;
- else
- if Delta_Indent.Hanging_Paren_State = Data.Line_Paren_State
(Line) then
- case Delta_Indent.Hanging_Delta_2.Label is
- when None =>
- null;
- when Int =>
- Indent_Apply_Int (Indent,
Delta_Indent.Hanging_Delta_2.Int_Delta);
- when Anchored =>
- Indent_Apply_Anchored (Delta_Indent.Hanging_Delta_2,
Indent);
- end case;
- end if;
- end if;
- end if;
- end case;
-
- if Trace_Action > Extra then
- Ada.Text_IO.Put_Line (";; indent_line: " & Line_Number_Type'Image
(Line) & " => " & Image (Indent));
- end if;
-
- Data.Indents.Replace_Element (Line, Indent);
- end Indent_Line;
-
- function Indent_Nil_P (Indent : in Indent_Type) return Boolean
- is begin
- return Indent.Label in Not_Set | Anchor_Nil;
- end Indent_Nil_P;
-
- function Max_Anchor_ID
- (Data : in out Parse_Data_Type;
- First_Line : in Line_Number_Type;
- Last_Line : in Line_Number_Type)
- return Integer
- is
- Result : Integer := First_Anchor_ID - 1;
- begin
- for Line in First_Line .. Last_Line loop
- declare
- Indent : Indent_Type renames Data.Indents (Line);
- begin
- case Indent.Label is
- when Not_Set | Int =>
- null;
- when Anchor_Nil =>
- Result := Integer'Max (Result, Indent.Anchor_Nil_IDs
(Indent.Anchor_Nil_IDs.First_Index));
- when Anchor_Int =>
- Result := Integer'Max (Result, Indent.Anchor_Int_IDs
(Indent.Anchor_Int_IDs.First_Index));
- when Anchored =>
- Result := Integer'Max (Result, Indent.Anchored_ID);
- when Anchor_Anchored =>
- Result := Integer'Max (Result, Indent.Anchor_Anchored_ID);
- end case;
- end;
- end loop;
- return Result;
- end Max_Anchor_ID;
-
- function Paren_In_Anchor_Line
- (Data : in out Parse_Data_Type'Class;
- Tree : in Syntax_Trees.Tree'Class;
- Anchor_Token : in Augmented_Token;
- Offset : in Integer)
- return Integer
- is
- use Valid_Node_Index_Arrays;
- use all type Ada.Containers.Count_Type;
-
- Left_Paren_ID : Token_ID renames Data.Left_Paren_ID;
- Right_Paren_ID : Token_ID renames Data.Right_Paren_ID;
-
- I : Base_Token_Index := Anchor_Token.First_Terminals_Index;
- Paren_Count : Integer := 0;
- Paren_Char_Pos : Buffer_Pos := Invalid_Buffer_Pos;
- Text_Begin_Pos : Buffer_Pos := Invalid_Buffer_Pos;
- begin
- Find_First :
- loop
- declare
- Tok : Aug_Token_Const_Ref renames Get_Aug_Token_Const (Data, Tree,
I);
- begin
- if Tok.Deleted then
- null;
-
- elsif Tok.ID = Left_Paren_ID then
- Paren_Count := Paren_Count + 1;
- if Paren_Count = 1 then
- Paren_Char_Pos := Tok.Char_Region.First;
- end if;
-
- elsif Tok.ID = Right_Paren_ID then
- Paren_Count := Paren_Count - 1;
-
- end if;
-
- if Tok.First then
- Text_Begin_Pos := Tok.Char_Region.First;
- exit Find_First;
- else
- if Length (Tok.Inserted_Before) > 0 then
- for Node of Tok.Inserted_Before loop
- declare
- Ins_Tok : Augmented_Token renames Augmented_Token
(Tree.Augmented (Node).all);
- begin
- if Ins_Tok.ID = Left_Paren_ID then
- Paren_Count := Paren_Count + 1;
- if Paren_Count = 1 then
- Paren_Char_Pos := Tok.Char_Region.First;
- end if;
-
- elsif Ins_Tok.ID = Right_Paren_ID then
- Paren_Count := Paren_Count - 1;
-
- end if;
-
- if Ins_Tok.First then
- Text_Begin_Pos := Tok.Char_Region.First;
- exit Find_First;
- end if;
- end;
- end loop;
- end if;
- end if;
- end;
- I := I - 1;
- end loop Find_First;
-
- if Paren_Char_Pos /= Invalid_Buffer_Pos and Text_Begin_Pos /=
Invalid_Buffer_Pos then
- return 1 + Offset + Integer (Paren_Char_Pos - Text_Begin_Pos);
- else
- return Offset;
- end if;
- end Paren_In_Anchor_Line;
-
- procedure Put (Cache : in Navigate_Cache_Type)
- is
- package Bounded is new Ada.Strings.Bounded.Generic_Bounded_Length (Max
=> 2 + 11 * Chars_Per_Int);
- use Bounded;
-
- Line : Bounded_String := To_Bounded_String ("[");
-
- procedure Append (Item : in Nil_Buffer_Pos)
- is begin
- if Item.Set then
- Append (Line, Buffer_Pos'Image (Item.Item));
- else
- Append (Line, " -1");
- end if;
- end Append;
- begin
- Append (Line, Navigate_Cache_Code);
- Append (Line, Buffer_Pos'Image (Cache.Pos));
- Append (Line, Token_ID'Image (Cache.Statement_ID));
- Append (Line, Token_ID'Image (Cache.ID));
- Append (Line, Integer'Image (Cache.Length));
- Append (Line, Integer'Image (Navigate_Class_Type'Pos (Cache.Class)));
- Append (Cache.Containing_Pos);
- Append (Cache.Prev_Pos);
- Append (Cache.Next_Pos);
- Append (Cache.End_Pos);
- Append (Line, ']');
- Ada.Text_IO.Put_Line (To_String (Line));
- end Put;
-
- procedure Put (Cache : in WisiToken.Buffer_Region)
- is begin
- Ada.Text_IO.Put_Line
- ("[" & Name_Property_Code & Buffer_Pos'Image (Cache.First) &
Buffer_Pos'Image (Cache.Last) & "]");
- end Put;
-
- procedure Put (Cache : in Face_Cache_Type)
- is
- package Bounded is new Ada.Strings.Bounded.Generic_Bounded_Length (Max
=> 2 + 4 * Chars_Per_Int);
- use Bounded;
-
- Line : Bounded_String := To_Bounded_String ("[");
- begin
- if Cache.Face.Set then
- Append (Line, Face_Property_Code);
- Append (Line, Buffer_Pos'Image (Cache.Char_Region.First));
- Append (Line, Buffer_Pos'Image (Cache.Char_Region.Last));
- Append (Line, Integer'Image (Cache.Face.Item));
- Append (Line, ']');
- Ada.Text_IO.Put_Line (To_String (Line));
- end if;
- end Put;
-
- procedure Put (Line_Number : in Line_Number_Type; Item : in Indent_Type)
- is begin
- -- All Anchors must be resolved at this point, but not all lines have
- -- an indent computed. A negative indent is an error in either the
- -- grammar indent rules or the algorithms in this package.
- case Item.Label is
- when Not_Set =>
- -- Especially with partial parse, we have no idea what this indent
should be.
- null;
-
- when Int =>
- declare
- -- We can easily get negative indents when there are syntax
errors.
- Ind : constant Integer := Integer'Max (0, Item.Int_Indent);
- begin
- Ada.Text_IO.Put_Line
- ('[' & Indent_Code & Line_Number_Type'Image (Line_Number) &
Integer'Image (Ind) & ']');
- end;
-
- when Anchor_Nil | Anchor_Int | Anchored | Anchor_Anchored =>
- raise SAL.Programmer_Error with "Indent item has non-int label: " &
Indent_Label'Image (Item.Label);
- end case;
- end Put;
-
- procedure Put
- (Item : in Parse.LR.Configuration;
- Data : in Parse_Data_Type;
- Tree : in Syntax_Trees.Tree)
- is
- use Ada.Strings.Unbounded;
- use Parse.LR;
- use Parse.LR.Config_Op_Arrays, Parse.LR.Config_Op_Array_Refs;
-
- -- Output is a sequence of edit regions; each is:
- -- [edit-pos [inserted token-ids] [deleted token-ids] deleted-region]
-
- type State_Label is
- (None, -- not started yet
- Inserted, -- edit-pos, some insert ids appended
- Deleted); -- some delete ids appended
-
- State : State_Label := None;
- -- State of the current edit region.
-
- Line : Unbounded_String := To_Unbounded_String ("[");
- Deleted_Region : Buffer_Region := Null_Buffer_Region;
- Last_Deleted : Config_Op (Delete) := (Delete, Invalid_Token_ID,
Invalid_Token_Index);
-
- procedure Start_Edit_Region (Op : in Insert_Delete_Op)
- is begin
- Append (Line, "[");
- Append (Line, Get_Aug_Token_Const (Data, Tree, Parse.LR.Token_Index
(Op)).Char_Region.First'Image);
- Append (Line, "[");
- end Start_Edit_Region;
-
- function Deleted_Region_Image return String
- is begin
- return "(" & Deleted_Region.First'Image & " . " & Buffer_Pos'Image
(Deleted_Region.Last + 1) & ")";
- end Deleted_Region_Image;
-
- procedure Terminate_Edit_Region
- is begin
- case State is
- when None =>
- null;
- when Inserted =>
- Append (Line, "][]" & Deleted_Region_Image & "]");
- when Deleted =>
- Append (Line, "]" & Deleted_Region_Image & "]");
- end case;
- Deleted_Region := Null_Buffer_Region;
- end Terminate_Edit_Region;
- begin
- if Trace_Action > Outline then
- Ada.Text_IO.Put_Line (";; " & Parse.LR.Image (Item.Ops,
Data.Descriptor.all));
- end if;
-
- Append (Line, Recover_Code);
- for I in First_Index (Item.Ops) .. Last_Index (Item.Ops) loop
- declare
- Op : Config_Op renames Constant_Ref (Item.Ops, I);
- begin
- case Op.Op is
- when Fast_Forward =>
- Terminate_Edit_Region;
- State := None;
-
- when Undo_Reduce | Push_Back =>
- null;
-
- when Insert =>
- case State is
- when None =>
- Start_Edit_Region (Op);
-
- when Inserted =>
- null;
-
- when Deleted =>
- Terminate_Edit_Region;
- Start_Edit_Region (Op);
-
- end case;
- Append (Line, Token_ID'Image (Op.Ins_ID));
- State := Inserted;
-
- when Delete =>
- Deleted_Region := Deleted_Region and Get_Aug_Token_Const (Data,
Tree, Op.Del_Token_Index).Char_Region;
- declare
- Skip : Boolean := False;
- begin
- case State is
- when None =>
- Start_Edit_Region (Op);
- Append (Line, "][");
-
- when Inserted =>
- Append (Line, "][");
-
- when Deleted =>
- if Data.Embedded_Quote_Escape_Doubled and then
- ((Last_Deleted.Del_ID = Data.Descriptor.String_1_ID and
- Op.Del_ID = Data.Descriptor.String_1_ID) or
- (Last_Deleted.Del_ID = Data.Descriptor.String_2_ID
and
- Op.Del_ID = Data.Descriptor.String_2_ID))
- then
- declare
- Tok_1 : Augmented_Token renames Get_Aug_Token_Const
- (Data, Tree, Last_Deleted.Del_Token_Index);
- Tok_2 : Augmented_Token renames Get_Aug_Token_Const
(Data, Tree, Op.Del_Token_Index);
- begin
- if Tok_1.Char_Region.Last + 1 =
Tok_2.Char_Region.First then
- -- Buffer text was '"""', lexer repair changed
it to '""""'. The
- -- repaired text looks like a single string
with an embedded quote.
- -- But here, it is two STRING_LITERAL tokens.
Don't send the second
- -- delete to elisp. See
test/ada_mode-recover_string_quote_1.adb
- Skip := True;
- end if;
- end;
- end if;
- end case;
- State := Deleted;
-
- if not Skip then
- Append (Line, Token_ID'Image (Op.Del_ID));
- end if;
- end;
- Last_Deleted := Op;
- end case;
- end;
- end loop;
-
- case State is
- when None =>
- null;
- when Inserted | Deleted =>
- Terminate_Edit_Region;
- end case;
- Append (Line, "]");
- Ada.Text_IO.Put_Line (To_String (Line));
- end Put;
-
- procedure Resolve_Anchors (Data : in out Parse_Data_Type)
- is
- Begin_Indent : Integer renames Data.Begin_Indent;
- Anchor_Indent : array (First_Anchor_ID .. Data.Max_Anchor_ID) of Integer;
- begin
- if Trace_Action > Outline then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line (";; Begin_Indent: " & Integer'Image
(Data.Begin_Indent));
- for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop
- Ada.Text_IO.Put_Line (";; " & Line_Number_Type'Image (I) & ", " &
Image (Data.Indents (I)));
- end loop;
- Ada.Text_IO.Put_Line (";; resolve anchors");
- end if;
-
- for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop
- declare
- Indent : constant Indent_Type := Data.Indents (I);
- begin
- case Indent.Label is
- when Not_Set =>
- -- Indent not computed, therefore not output.
- null;
-
- when Int =>
- Data.Indents.Replace_Element (I, (Int, Indent.Int_Indent +
Begin_Indent));
-
- when Anchor_Nil =>
- for I of Indent.Anchor_Nil_IDs loop
- Anchor_Indent (I) := Begin_Indent;
- end loop;
- Data.Indents.Replace_Element (I, (Int, Begin_Indent));
-
- when Anchor_Int =>
- for I of Indent.Anchor_Int_IDs loop
- Anchor_Indent (I) := Indent.Anchor_Int_Indent + Begin_Indent;
- end loop;
- Data.Indents.Replace_Element (I, (Int, Indent.Anchor_Int_Indent
+ Begin_Indent));
-
- when Anchored =>
- Data.Indents.Replace_Element
- (I, (Int, Anchor_Indent (Indent.Anchored_ID) +
Indent.Anchored_Delta));
-
- when Anchor_Anchored =>
- declare
- Temp : constant Integer :=
- Anchor_Indent (Indent.Anchor_Anchored_ID) +
Indent.Anchor_Anchored_Delta;
- begin
- for I of Indent.Anchor_Anchored_IDs loop
- Anchor_Indent (I) := Temp;
- end loop;
- Data.Indents.Replace_Element (I, (Int, Temp));
- end;
- end case;
- end;
- end loop;
- end Resolve_Anchors;
-
- procedure Set_End
- (Data : in out Parse_Data_Type;
- Containing_Pos : in Buffer_Pos;
- End_Pos : in Buffer_Pos)
- is
- use Navigate_Cursor_Lists;
- I : Cursor := Data.End_Positions.First;
- Delete_Cache : Boolean;
- Temp : Cursor;
- begin
- loop
- exit when not Has_Element (I);
- declare
- Cache : Navigate_Cache_Type renames Data.Navigate_Caches (Element
(I));
- begin
- if Cache.Pos in Containing_Pos .. End_Pos then
- Cache.End_Pos := (True, End_Pos);
- Delete_Cache := True;
- else
- Delete_Cache := False;
- end if;
- end;
- if Delete_Cache then
- Temp := Next (I);
- Delete (Data.End_Positions, I);
-
- I := Temp;
- else
- Next (I);
- end if;
-
- end loop;
- end Set_End;
-
- ----------
- -- public subprograms (declaration order)
-
- procedure Initialize
- (Data : in out Parse_Data_Type;
- Lexer : in WisiToken.Lexer.Handle;
- Descriptor : access constant WisiToken.Descriptor;
- Base_Terminals : in Base_Token_Array_Access;
- Post_Parse_Action : in Post_Parse_Action_Type;
- Begin_Line : in Line_Number_Type;
- End_Line : in Line_Number_Type;
- Begin_Indent : in Integer;
- Params : in String)
- is
- pragma Unreferenced (Params);
- begin
- Data.Line_Begin_Char_Pos.Set_First_Last
- (First => Begin_Line,
- Last => End_Line);
-
- -- + 1 for data on line following last line; see Lexer_To_Augmented.
- Data.Line_Paren_State.Set_First_Last
- (First => Begin_Line,
- Last => End_Line + 1);
-
- Data.Lexer := Lexer;
- Data.Descriptor := Descriptor;
- Data.Base_Terminals := Base_Terminals;
- Data.Post_Parse_Action := Post_Parse_Action;
-
- case Post_Parse_Action is
- when Navigate | Face =>
- null;
- when Indent =>
- Data.Indents.Set_First_Last
- (First => Begin_Line,
- Last => End_Line);
-
- Data.Begin_Indent := Begin_Indent;
- end case;
-
- Data.Reset;
- exception
- when E : others =>
- raise SAL.Programmer_Error with "wisi.initialize: " &
Ada.Exceptions.Exception_Name (E) & ": " &
- Ada.Exceptions.Exception_Message (E);
- end Initialize;
-
- overriding procedure Reset (Data : in out Parse_Data_Type)
- is begin
- Data.Last_Terminal_Node := WisiToken.Invalid_Node_Index;
-
- Data.Leading_Non_Grammar.Clear;
-
- -- Data.Line_Begin_Char_Pos set in Initialize, overwritten in
Lexer_To_Augmented
-
- for S of Data.Line_Paren_State loop
- S := 0;
- end loop;
- Data.Current_Paren_State := 0;
-
- Data.Navigate_Caches.Finalize;
- Data.Navigate_Caches.Initialize;
-
- Data.Name_Caches.Finalize;
- Data.Name_Caches.Initialize;
-
- Data.End_Positions.Clear;
-
- Data.Face_Caches.Finalize;
- Data.Face_Caches.Initialize;
-
- for I in Data.Indents.First_Index .. Data.Indents.Last_Index loop
- Data.Indents.Replace_Element (I, (Label => Not_Set));
- end loop;
- Data.Max_Anchor_ID := First_Anchor_ID - 1;
- end Reset;
-
- function Source_File_Name (Data : in Parse_Data_Type) return String
- is begin
- return Data.Lexer.File_Name;
- end Source_File_Name;
-
- function Post_Parse_Action (Data : in Parse_Data_Type) return
Post_Parse_Action_Type
- is begin
- return Data.Post_Parse_Action;
- end Post_Parse_Action;
-
- overriding
- procedure Lexer_To_Augmented
- (Data : in out Parse_Data_Type;
- Tree : in out Syntax_Trees.Tree'Class;
- Token : in Base_Token;
- Lexer : not null access WisiToken.Lexer.Instance'Class)
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Lexer.First then
- Data.Line_Begin_Char_Pos (Token.Line) := Token.Char_Region.First;
-
- if Token.Line > Data.Line_Begin_Char_Pos.First_Index and then
- Data.Line_Begin_Char_Pos (Token.Line - 1) = Invalid_Buffer_Pos
- then
- -- Previous token contains multiple lines; ie %code in
wisitoken_grammar.wy
- declare
- First_Set_Line : Line_Number_Type;
- begin
- for Line in reverse Data.Line_Begin_Char_Pos.First_Index ..
Token.Line - 1 loop
- if Data.Line_Begin_Char_Pos (Line) /= Invalid_Buffer_Pos then
- First_Set_Line := Line;
- exit;
- end if;
- end loop;
- for Line in First_Set_Line + 1 .. Token.Line - 1 loop
- Data.Line_Begin_Char_Pos (Line) := Data.Line_Begin_Char_Pos
(First_Set_Line); -- good enough
- end loop;
- end;
- end if;
- end if;
-
- if Token.ID < Data.Descriptor.First_Terminal then
- -- Non-grammar token
-
- if Token.ID = Data.Descriptor.New_Line_ID then
- Data.Line_Paren_State (Token.Line + 1) := Data.Current_Paren_State;
- end if;
-
- if Data.Last_Terminal_Node = Invalid_Node_Index then
- Data.Leading_Non_Grammar.Append ((Token with Lexer.First));
- else
- declare
- Containing_Token : Aug_Token_Var_Ref renames Get_Aug_Token_Var
(Tree, Data.Last_Terminal_Node);
-
- Trailing_Blank : constant Boolean :=
- Token.ID = Data.Descriptor.New_Line_ID and
- (Containing_Token.Non_Grammar.Length > 0 and then
- Containing_Token.Non_Grammar
- (Containing_Token.Non_Grammar.Last_Index).ID =
Data.Descriptor.New_Line_ID);
- begin
- if Lexer.First and
- (Token.ID in Data.First_Comment_ID .. Data.Last_Comment_ID or
- Trailing_Blank)
- then
- if Containing_Token.First_Trailing_Comment_Line =
Invalid_Line_Number then
- Containing_Token.First_Trailing_Comment_Line :=
Token.Line;
- end if;
- Containing_Token.Last_Trailing_Comment_Line := Token.Line;
- end if;
-
- Containing_Token.Non_Grammar.Append ((Token with Lexer.First));
- end;
- end if;
-
- else
- -- grammar token
- declare
- Temp : constant Augmented_Token_Access := new Augmented_Token'
- (Token with
- Deleted => False,
- First => Lexer.First,
- Paren_State => Data.Current_Paren_State,
- First_Terminals_Index => Data.Terminals.Last_Index,
- Last_Terminals_Index => Data.Terminals.Last_Index,
- First_Indent_Line => (if Lexer.First then Token.Line
else Invalid_Line_Number),
- Last_Indent_Line => (if Lexer.First then Token.Line
else Invalid_Line_Number),
- First_Trailing_Comment_Line => Invalid_Line_Number, -- Set by
Reduce
- Last_Trailing_Comment_Line => Invalid_Line_Number,
- Non_Grammar =>
Non_Grammar_Token_Arrays.Empty_Vector,
- Inserted_Before =>
Valid_Node_Index_Arrays.Empty_Vector);
- begin
- Data.Last_Terminal_Node := Token.Tree_Index;
-
- if Token.ID = Data.Left_Paren_ID then
- Data.Current_Paren_State := Data.Current_Paren_State + 1;
-
- elsif Token.ID = Data.Right_Paren_ID then
- Data.Current_Paren_State := Data.Current_Paren_State - 1;
- end if;
-
- Tree.Set_Augmented (Token.Tree_Index, Base_Token_Class_Access
(Temp));
- end;
- end if;
- end Lexer_To_Augmented;
-
- overriding
- procedure Insert_Token
- (Data : in out Parse_Data_Type;
- Tree : in out Syntax_Trees.Tree'Class;
- Token : in Valid_Node_Index)
- is
- use Valid_Node_Index_Arrays;
-
- Before_Index : constant Token_Index := Tree.Before (Token);
- Before_Aug : Aug_Token_Var_Ref renames Get_Aug_Token_Var (Data, Tree,
Before_Index);
-
- -- Set data that allows using Token when computing indent.
-
- Indent_Line : constant Line_Number_Type :=
- (if Before_Aug.First
- then Before_Aug.Line
- else Invalid_Line_Number);
-
- -- Set for Insert_After False; see below for True.
- New_Aug : constant Augmented_Token_Access := new Augmented_Token'
- (ID => Tree.ID (Token),
- Tree_Index => Token,
- Byte_Region => (First | Last =>
Before_Aug.Byte_Region.First),
- Line => Before_Aug.Line,
- Column => Before_Aug.Column,
- Char_Region => (First | Last =>
Before_Aug.Char_Region.First),
- Deleted => False,
- First => Before_Aug.First,
- Paren_State => Before_Aug.Paren_State,
- First_Terminals_Index => Invalid_Token_Index,
- Last_Terminals_Index => Invalid_Token_Index,
- First_Indent_Line => Indent_Line,
- Last_Indent_Line => Indent_Line,
- First_Trailing_Comment_Line => Invalid_Line_Number,
- Last_Trailing_Comment_Line => Invalid_Line_Number,
- Non_Grammar => Non_Grammar_Token_Arrays.Empty_Vector,
- Inserted_Before => Valid_Node_Index_Arrays.Empty_Vector);
-
- Prev_Terminal : constant Node_Index := Tree.Prev_Terminal (Token);
- -- Invalid_Node_Index if Token is inserted before first grammar token
-
- Insert_After : Boolean := False;
- begin
- Tree.Set_Augmented (Token, Base_Token_Class_Access (New_Aug));
-
- Append (Before_Aug.Inserted_Before, Token);
-
- if Prev_Terminal /= Invalid_Node_Index and Before_Aug.First then
- declare
- use all type Ada.Containers.Count_Type;
- use all type Ada.Text_IO.Count;
-
- -- See test/ada_mode-interactive_2.adb, "Typing ..."; three tests.
- --
- -- When typing new code, we want a new blank line to be indented
as
- -- if the code was there already. To accomplish that, we put the
- -- inserted tokens at the end of the line before the Before token;
- -- that will be after the non-grammar on the previous terminal.
- --
- -- Compare to test/ada_mode-recover_20.adb. There we are not
typing
- -- new code, but there is a blank line; the right paren is placed
at
- -- the end of the blank line, causing the comment to be indented.
-
- Prev_Aug : Aug_Token_Var_Ref renames Get_Aug_Token_Var (Tree,
Prev_Terminal);
-
- -- Prev_Aug.Non_Grammar must have at least one New_Line, since
- -- Before_Aug.First is True. The whitespace after the New_Line is
not
- -- given a token.
- --
- -- If the first two tokens in Prev_Non_Grammar are both New_Lines,
- -- there is a blank line after the code line (and before any
- -- comments); assume that is the edit point.
- Insert_On_Blank_Line : constant Boolean :=
Prev_Aug.Non_Grammar.Length >= 2 and then
- (Prev_Aug.Non_Grammar (Prev_Aug.Non_Grammar.First_Index).ID =
Data.Descriptor.New_Line_ID and
- Prev_Aug.Non_Grammar (Prev_Aug.Non_Grammar.First_Index +
1).ID = Data.Descriptor.New_Line_ID);
-
- -- In Ada, 'end' is Insert_After except when Insert_On_Blank_Line
is
- -- True (see test/ada_mode-interactive_2.adb Record_1), so
Insert_After
- -- needs Insert_On_Blank_Line.
- begin
- Insert_After := Parse_Data_Type'Class (Data).Insert_After (Tree,
Token, Insert_On_Blank_Line);
-
- if Insert_After then
- if Insert_On_Blank_Line then
- declare
- Prev_Non_Grammar : constant Non_Grammar_Token :=
- Prev_Aug.Non_Grammar (Prev_Aug.Non_Grammar.First_Index
+ 1);
- -- The newline nominally after the inserted token.
- begin
- New_Aug.Byte_Region := (First | Last =>
Prev_Non_Grammar.Byte_Region.Last - 1);
- New_Aug.Char_Region := (First | Last =>
Prev_Non_Grammar.Char_Region.Last - 1);
-
- New_Aug.First := True;
- New_Aug.Line := Prev_Non_Grammar.Line;
- New_Aug.Column := Prev_Aug.Column + Ada.Text_IO.Count
(Length (New_Aug.Char_Region)) - 1;
-
- New_Aug.First_Indent_Line := Prev_Non_Grammar.Line;
- New_Aug.Last_Indent_Line := Prev_Non_Grammar.Line;
-
- for I in Prev_Aug.Non_Grammar.First_Index + 1 ..
Prev_Aug.Non_Grammar.Last_Index loop
- New_Aug.Non_Grammar.Append (Prev_Aug.Non_Grammar (I));
- end loop;
-
- Prev_Aug.Non_Grammar.Set_First_Last
- (Prev_Aug.Non_Grammar.First_Index,
Prev_Aug.Non_Grammar.First_Index);
- end;
- else
- New_Aug.Byte_Region := (First | Last =>
Prev_Aug.Byte_Region.Last);
- New_Aug.Char_Region := (First | Last =>
Prev_Aug.Char_Region.Last);
-
- New_Aug.First := False;
- New_Aug.Line := Prev_Aug.Line;
- New_Aug.Column := Prev_Aug.Column + Ada.Text_IO.Count
(Length (Prev_Aug.Char_Region)) - 1;
-
- New_Aug.First_Indent_Line := Invalid_Line_Number;
- New_Aug.Last_Indent_Line := Invalid_Line_Number;
-
- New_Aug.Non_Grammar := Prev_Aug.Non_Grammar;
- Prev_Aug.Non_Grammar :=
Non_Grammar_Token_Arrays.Empty_Vector;
-
- end if;
-
- New_Aug.First_Trailing_Comment_Line :=
Prev_Aug.First_Trailing_Comment_Line;
- New_Aug.Last_Trailing_Comment_Line :=
Prev_Aug.Last_Trailing_Comment_Line;
-
- Prev_Aug.First_Trailing_Comment_Line := Invalid_Line_Number;
- Prev_Aug.Last_Trailing_Comment_Line := Invalid_Line_Number;
- end if;
- end;
- end if;
-
- if New_Aug.First and not Insert_After then
- Before_Aug.First := False;
- Before_Aug.First_Indent_Line := Invalid_Line_Number;
- Before_Aug.Last_Indent_Line := Invalid_Line_Number;
- end if;
-
- if New_Aug.ID = Data.Left_Paren_ID then
- Adjust_Paren_State (Data, Tree, Before_Index, New_Aug.Line + 1, +1);
-
- elsif New_Aug.ID = Data.Right_Paren_ID then
- Adjust_Paren_State (Data, Tree, Before_Index, New_Aug.Line + 1, -1);
- end if;
- end Insert_Token;
-
- overriding
- procedure Delete_Token
- (Data : in out Parse_Data_Type;
- Tree : in out Syntax_Trees.Tree'Class;
- Deleted_Token_Index : in WisiToken.Token_Index)
- is
- use all type Ada.Containers.Count_Type;
- Deleted_Token : Augmented_Token renames Get_Aug_Token_Var (Data,
Tree, Deleted_Token_Index);
- Prev_Token_Index : Base_Token_Index := Deleted_Token_Index - 1;
- Next_Token_Index : Base_Token_Index := Deleted_Token_Index + 1;
- begin
- if Deleted_Token.Deleted then
- -- This can happen if error recovery screws up.
- if WisiToken.Trace_Action > WisiToken.Detail then
- Ada.Text_IO.Put_Line (";; delete token again; ignored " & Image
(Deleted_Token, Data.Descriptor.all));
- end if;
- return;
- end if;
- if WisiToken.Trace_Action > WisiToken.Detail then
- Ada.Text_IO.Put_Line (";; delete token " & Image (Deleted_Token,
Data.Descriptor.all));
- end if;
-
- Deleted_Token.Deleted := True;
-
- if Deleted_Token.Non_Grammar.Length > 0 then
- -- Move Non_Grammar to previous non-deleted token
-
- loop
- exit when Prev_Token_Index = Base_Token_Index'First;
- exit when Get_Aug_Token_Const (Data, Tree,
Prev_Token_Index).Deleted = False;
- Prev_Token_Index := Prev_Token_Index - 1;
- end loop;
-
- if Prev_Token_Index = Base_Token_Index'First then
- Deleted_Token.Non_Grammar
(Deleted_Token.Non_Grammar.First_Index).First := Deleted_Token.First;
- Data.Leading_Non_Grammar.Append (Deleted_Token.Non_Grammar);
- else
- declare
- Prev_Token : Augmented_Token renames Get_Aug_Token_Var (Data,
Tree, Prev_Token_Index);
- begin
- Prev_Token.Non_Grammar.Append (Deleted_Token.Non_Grammar);
-
- if Deleted_Token.First_Trailing_Comment_Line /=
Invalid_Line_Number then
- if Prev_Token.First_Trailing_Comment_Line =
Invalid_Line_Number then
- Prev_Token.First_Trailing_Comment_Line :=
Deleted_Token.First_Trailing_Comment_Line;
- end if;
- Prev_Token.Last_Trailing_Comment_Line :=
Deleted_Token.Last_Trailing_Comment_Line;
- end if;
- end;
- end if;
- end if;
-
- -- Data.Terminals.Last_Index is Wisi_EOI; it is never deleted
- loop
- exit when Get_Aug_Token_Const (Data, Tree, Next_Token_Index).Deleted
= False;
- Next_Token_Index := Next_Token_Index + 1;
- exit when Next_Token_Index = Data.Terminals.Last_Index;
- end loop;
-
- if Deleted_Token.First and
- (Next_Token_Index = Data.Terminals.Last_Index or else
- Get_Aug_Token_Const (Data, Tree, Next_Token_Index).Line >
Deleted_Token.Line)
- then
- -- Deleted_Token.Line is now blank; add to previous token non
- -- grammar.
- if Prev_Token_Index > Base_Token_Index'First then
- declare
- Prev_Token : Augmented_Token renames Get_Aug_Token_Var (Data,
Tree, Prev_Token_Index);
- begin
- if Prev_Token.First_Trailing_Comment_Line = Invalid_Line_Number
then
- Prev_Token.First_Trailing_Comment_Line := Deleted_Token.Line;
- Prev_Token.Last_Trailing_Comment_Line := Deleted_Token.Line;
- else
- if Prev_Token.First_Trailing_Comment_Line >
Deleted_Token.Line then
- Prev_Token.First_Trailing_Comment_Line :=
Deleted_Token.Line;
- end if;
- if Prev_Token.Last_Trailing_Comment_Line <
Deleted_Token.Line then
- Prev_Token.Last_Trailing_Comment_Line :=
Deleted_Token.Line;
- end if;
- end if;
- end;
- end if;
- end if;
-
- if Deleted_Token.First and Next_Token_Index < Data.Terminals.Last_Index
then
- declare
- Next_Token : Augmented_Token renames Get_Aug_Token_Var (Data,
Tree, Next_Token_Index);
- begin
- if not Next_Token.First then
- Next_Token.First := True;
- Next_Token.First_Indent_Line := Deleted_Token.First_Indent_Line;
- Next_Token.Last_Indent_Line := Deleted_Token.Last_Indent_Line;
- end if;
- end;
- end if;
-
- if Deleted_Token.ID = Data.Left_Paren_ID then
- Adjust_Paren_State (Data, Tree, Deleted_Token_Index + 1,
Deleted_Token.Line + 1, -1);
-
- elsif Deleted_Token.ID = Data.Right_Paren_ID then
- Adjust_Paren_State (Data, Tree, Deleted_Token_Index + 1,
Deleted_Token.Line + 1, +1);
-
- end if;
- end Delete_Token;
-
- overriding
- procedure Reduce
- (Data : in out Parse_Data_Type;
- Tree : in out Syntax_Trees.Tree'Class;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array)
- is
- Aug_Nonterm : constant Augmented_Token_Access := new Augmented_Token'
- (ID => Tree.ID (Nonterm),
- Byte_Region => Tree.Byte_Region (Nonterm),
- others => <>);
-
- Trailing_Comment_Done : Boolean := False;
- begin
- Tree.Set_Augmented (Nonterm, Base_Token_Class_Access (Aug_Nonterm));
-
- for I in reverse Tokens'Range loop
- -- 'reverse' to find token containing trailing comments; last
- -- non-empty token.
- declare
- Aug_Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, Tokens (I));
- begin
-
- if Data.Post_Parse_Action = Indent then
- if Aug_Token.First_Terminals_Index /= Invalid_Token_Index then
- Aug_Nonterm.First_Terminals_Index :=
Aug_Token.First_Terminals_Index;
- end if;
-
- if Aug_Nonterm.Last_Terminals_Index = Invalid_Token_Index then
- Aug_Nonterm.Last_Terminals_Index :=
Aug_Token.Last_Terminals_Index;
- end if;
-
- Aug_Nonterm.First := Aug_Nonterm.First or Aug_Token.First;
-
- if Aug_Token.First_Indent_Line /= Invalid_Line_Number then
- Aug_Nonterm.First_Indent_Line := Aug_Token.First_Indent_Line;
- elsif Trailing_Comment_Done and
Aug_Token.First_Trailing_Comment_Line /= Invalid_Line_Number then
- Aug_Nonterm.First_Indent_Line :=
Aug_Token.First_Trailing_Comment_Line;
- end if;
-
- if Aug_Nonterm.Last_Indent_Line = Invalid_Line_Number then
- if Trailing_Comment_Done and
Aug_Token.Last_Trailing_Comment_Line /= Invalid_Line_Number then
- Aug_Nonterm.Last_Indent_Line :=
Aug_Token.Last_Trailing_Comment_Line;
- elsif Aug_Token.Last_Indent_Line /= Invalid_Line_Number then
- Aug_Nonterm.Last_Indent_Line :=
Aug_Token.Last_Indent_Line;
- end if;
- end if;
-
- if not Trailing_Comment_Done then
- Aug_Nonterm.First_Trailing_Comment_Line :=
Aug_Token.First_Trailing_Comment_Line;
- Aug_Nonterm.Last_Trailing_Comment_Line :=
Aug_Token.Last_Trailing_Comment_Line;
- Trailing_Comment_Done := True;
- end if;
-
- end if; -- Compute_Indent
-
- if Aug_Token.Line /= Invalid_Line_Number then
- Aug_Nonterm.Line := Aug_Token.Line;
- Aug_Nonterm.Column := Aug_Token.Column;
- end if;
-
- if Aug_Nonterm.Char_Region.First > Aug_Token.Char_Region.First then
- Aug_Nonterm.Char_Region.First := Aug_Token.Char_Region.First;
- end if;
-
- if Aug_Nonterm.Char_Region.Last < Aug_Token.Char_Region.Last then
- Aug_Nonterm.Char_Region.Last := Aug_Token.Char_Region.Last;
- end if;
-
- Aug_Nonterm.Paren_State := Aug_Token.Paren_State;
- end;
- end loop;
- end Reduce;
-
- procedure Statement_Action
- (Data : in out Parse_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array;
- Params : in Statement_Param_Array)
- is
- Nonterm_Tok : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, Nonterm);
- First_Item : Boolean := True;
- Start_Set : Boolean := False;
- Override_Start_Set : Boolean := False;
- Containing_Pos : Nil_Buffer_Pos := Nil;
- begin
- for Pair of Params loop
- if not (Pair.Index in Tokens'Range) then
- raise Fatal_Error with Error_Message
- (File_Name => Data.Lexer.File_Name,
- Line => Nonterm_Tok.Line,
- Column => Nonterm_Tok.Column,
- Message => "wisi-statement-action: " & Trimmed_Image
(Tree.Production_ID (Nonterm)) &
- " token index" & SAL.Peek_Type'Image (Pair.Index) &
- " not in tokens range (" & SAL.Peek_Type'Image (Tokens'First)
& " .." &
- SAL.Peek_Type'Image (Tokens'Last) & "); bad grammar action.");
-
- elsif Tree.Byte_Region (Tokens (Pair.Index)) /= Null_Buffer_Region
then
- declare
- use all type WisiToken.Syntax_Trees.Node_Label;
- Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
- (Tree,
- (if Pair.Class = Statement_End and then
- Tree.Label (Tokens (Pair.Index)) =
WisiToken.Syntax_Trees.Nonterm
- then Tree.Last_Terminal (Tokens (Pair.Index))
- else Tokens (Pair.Index)));
-
- Cache_Pos : constant Buffer_Pos :=
Token.Char_Region.First;
- Cursor : Navigate_Cache_Trees.Cursor :=
Navigate_Cache_Trees.Find
- (Data.Navigate_Caches.Iterate, Cache_Pos,
- Direction => Navigate_Cache_Trees.Unknown);
- begin
- if Navigate_Cache_Trees.Has_Element (Cursor) then
- declare
- Cache : Navigate_Cache_Type renames Data.Navigate_Caches
(Cursor);
- begin
- if Pair.Class = Statement_Start then
- if Start_Set then
- Cache.Class := Motion;
- else
- Cache.Class := Statement_Start;
- Start_Set := True;
- end if;
- elsif Override_Start_Set then
- Cache.Class := Statement_Start;
- Start_Set := True;
- else
- Cache.Class := Pair.Class;
- end if;
- Cache.Statement_ID := Tree.ID (Nonterm);
- Cache.Containing_Pos := Containing_Pos;
- end;
- else
- Cursor := Data.Navigate_Caches.Insert
- ((Pos => Cache_Pos,
- Statement_ID => Tree.ID (Nonterm),
- ID => Token.ID,
- Length => Length (Token.Char_Region),
- Class => (if Override_Start_Set then
Statement_Start else Pair.Class),
- Containing_Pos => Containing_Pos,
- others => Nil));
- end if;
-
- Data.End_Positions.Append (Cursor);
-
- if First_Item then
- First_Item := False;
- if Override_Start_Set or Pair.Class = Statement_Start then
- Override_Start_Set := False;
- Containing_Pos := (True, Token.Char_Region.First);
-
- -- Set containing on all contained caches
- declare
- use Navigate_Cache_Trees;
- Iterator : constant Navigate_Cache_Trees.Iterator :=
Data.Navigate_Caches.Iterate;
- Cursor : Navigate_Cache_Trees.Cursor :=
Find_In_Range
- (Iterator, Ascending, Nonterm_Tok.Char_Region.First
+ 1, -- don't set containing on start
- Nonterm_Tok.Char_Region.Last);
- begin
- loop
- exit when not Has_Element (Cursor);
- declare
- Cache : Navigate_Cache_Type renames
Data.Navigate_Caches (Cursor);
- begin
- if not Cache.Containing_Pos.Set then
- Cache.Containing_Pos := Containing_Pos;
- end if;
- exit when Nonterm_Tok.Char_Region.Last <
Cache.Pos + 1;
- end;
- Cursor := Iterator.Next (Cursor);
- end loop;
- end;
- end if;
- end if;
-
- if Pair.Class = Statement_End and Containing_Pos.Set then
- Set_End (Data, Containing_Pos.Item, Cache_Pos);
- end if;
- end;
-
- else
- -- Token.Byte_Region is null
- if First_Item and Pair.Class = Statement_Start then
- Override_Start_Set := True;
- end if;
- end if;
- end loop;
- end Statement_Action;
-
- procedure Name_Action
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Name : in WisiToken.Positive_Index_Type)
- 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));
- begin
- raise Fatal_Error with Error_Message
- (File_Name => Data.Lexer.File_Name,
- Line => Token.Line,
- Column => Token.Column,
- Message => "wisi-name-action: " & Trimmed_Image
(Tree.Production_ID (Nonterm)) & " name (" &
- Trimmed_Image (Name) & ") not in Tokens range (" &
SAL.Peek_Type'Image (Tokens'First) & " .." &
- SAL.Peek_Type'Image (Tokens'Last) & "); bad grammar action.");
- end;
- end if;
-
- 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;
-
- declare
- use Name_Cache_Trees;
- Name_Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1 (Tree,
Tokens (Name));
- Cursor : constant Name_Cache_Trees.Cursor := Find
- (Data.Name_Caches.Iterate, Name_Token.Char_Region.First,
- Direction => Name_Cache_Trees.Unknown);
- begin
- if Name_Token.Char_Region = Null_Buffer_Region then
- 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 => 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;
- end Name_Action;
-
- procedure Motion_Action
- (Data : in out Parse_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array;
- Params : in Motion_Param_Array)
- is
- use Navigate_Cache_Trees;
-
- Start : Nil_Buffer_Pos := (Set => False);
- Iter : constant Iterator := Data.Navigate_Caches.Iterate;
- Prev_Cache_Cur : Cursor;
- Cache_Cur : Cursor;
- begin
- if WisiToken.Trace_Action > Outline then
- Ada.Text_IO.Put_Line
- ("Motion_Action " & Image (Tree.ID (Nonterm), Data.Descriptor.all)
& " " &
- Image (Tree.Byte_Region (Nonterm)));
- end if;
- for Param of Params loop
- if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then
- declare
- use all type WisiToken.Syntax_Trees.Node_Label;
- Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, Tokens (Param.Index));
- Region : constant Buffer_Region := Token.Char_Region;
- Skip : Boolean := False;
- begin
- if not Start.Set then
- Start := (True, Region.First);
- end if;
-
- case Tree.Label (Tokens (Param.Index)) is
- when Shared_Terminal =>
- Cache_Cur := Find (Iter, Region.First);
- when Virtual_Terminal | Virtual_Identifier =>
- return;
-
- when Syntax_Trees.Nonterm =>
- if Param.ID = Invalid_Token_ID then
- Cache_Cur := Find (Iter, Region.First);
-
- else
- Skip := True;
- Cache_Cur := Find_In_Range (Iter, Ascending,
Region.First, Region.Last);
- loop
- exit when not Has_Element (Cache_Cur);
- if Data.Navigate_Caches (Cache_Cur).Pos > Region.Last
then
- Cache_Cur := No_Element;
- exit;
-
- elsif Data.Navigate_Caches (Cache_Cur).ID = Param.ID
and
- not Data.Navigate_Caches (Cache_Cur).Prev_Pos.Set
- then
- Skip := False;
- exit;
- end if;
-
- Cache_Cur := Next (Iter, Cache_Cur);
- end loop;
- end if;
- end case;
-
- if not Skip then
- if not Has_Element (Cache_Cur) then
- raise Fatal_Error with Error_Message
- (File_Name => Data.Lexer.File_Name,
- Line => Token.Line,
- Column => Token.Column,
- Message => "wisi-motion-action: token " &
- WisiToken.Image (Token.ID, Data.Descriptor.all) &
- " has no cache; add to statement-action for " &
- Trimmed_Image (Tree.Production_ID (Nonterm)) & ".");
- end if;
-
- if Has_Element (Prev_Cache_Cur) then
- declare
- Cache : Navigate_Cache_Type renames
Data.Navigate_Caches (Cache_Cur);
- Prev_Cache : Navigate_Cache_Type renames
Data.Navigate_Caches (Prev_Cache_Cur);
- begin
- if not Cache.Prev_Pos.Set then
- Cache.Prev_Pos := (True, Prev_Cache.Pos);
- if WisiToken.Trace_Action > Detail then
- Ada.Text_IO.Put_Line (" " & Cache.Pos'Image &
" prev to " & Cache.Prev_Pos.Item'Image);
- end if;
- end if;
-
- if not Prev_Cache.Next_Pos.Set then
- Prev_Cache.Next_Pos := (True, Cache.Pos);
- if WisiToken.Trace_Action > Detail then
- Ada.Text_IO.Put_Line
- (" " & Prev_Cache.Pos'Image & " next to " &
Prev_Cache.Next_Pos.Item'Image);
- end if;
- end if;
- end;
- end if;
-
- loop
- -- Set Prev_Cache_Cur to last motion cache in nonterm
chain
- exit when not Data.Navigate_Caches
(Cache_Cur).Next_Pos.Set;
-
- Cache_Cur := Find (Iter, Data.Navigate_Caches
(Cache_Cur).Next_Pos.Item);
- pragma Assert (Has_Element (Cache_Cur)); -- otherwise
there's a bug in this subprogram.
-
- end loop;
- Prev_Cache_Cur := Cache_Cur;
- end if;
- end;
- end if;
- end loop;
- end Motion_Action;
-
- procedure Face_Apply_Action
- (Data : in out Parse_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array;
- Params : in Face_Apply_Param_Array)
- is
- pragma Unreferenced (Nonterm);
-
- use Face_Cache_Trees;
-
- Iter : constant Iterator := Data.Face_Caches.Iterate;
- Cache_Cur : Cursor;
- Suffix_Cur : Cursor;
- begin
- for Param of Params loop
- if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then
- declare
- Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, Tokens (Param.Index));
- begin
- Cache_Cur := Find (Iter, Token.Char_Region.First, Direction =>
Ascending);
- if Has_Element (Cache_Cur) then
- declare
- Cache : Face_Cache_Type renames Data.Face_Caches
(Cache_Cur);
- begin
- case Cache.Class is
- when Prefix =>
- Cache.Face := (True, Param.Prefix_Face);
-
- -- Check for suffix
- Suffix_Cur := Next (Iter, Cache_Cur);
- if Has_Element (Suffix_Cur) then
- declare
- Suf_Cache : Face_Cache_Type renames
Data.Face_Caches (Suffix_Cur);
- begin
- if Suffix = Suf_Cache.Class and
- Inside (Suf_Cache.Char_Region.First,
Token.Char_Region)
- then
- Suf_Cache.Face := (True, Param.Suffix_Face);
- end if;
- end;
- end if;
-
- when Suffix =>
- Cache.Face := (True, Param.Suffix_Face);
- end case;
- end;
- else
- Data.Face_Caches.Insert ((Token.Char_Region, Suffix, (True,
Param.Suffix_Face)));
- end if;
- end;
- end if;
- end loop;
- end Face_Apply_Action;
-
- procedure Face_Apply_List_Action
- (Data : in out Parse_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array;
- Params : in Face_Apply_Param_Array)
- is
- pragma Unreferenced (Nonterm);
- use Face_Cache_Trees;
-
- Iter : constant Iterator := Data.Face_Caches.Iterate;
- Cache_Cur : Cursor;
- begin
- for Param of Params loop
- if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then
- declare
- Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, Tokens (Param.Index));
- begin
- Cache_Cur := Find_In_Range (Iter, Ascending,
Token.Char_Region.First, Token.Char_Region.Last);
- loop
- exit when not Has_Element (Cache_Cur) or else
- Data.Face_Caches (Cache_Cur).Char_Region.First >
Token.Char_Region.Last;
- declare
- Cache : Face_Cache_Type renames Data.Face_Caches
(Cache_Cur);
- begin
- case Cache.Class is
- when Prefix =>
- Cache.Face := (True, Param.Prefix_Face);
-
- when Suffix =>
- Cache.Face := (True, Param.Suffix_Face);
- end case;
- end;
- Cache_Cur := Next (Iter, Cache_Cur);
- end loop;
- end;
- end if;
- end loop;
- end Face_Apply_List_Action;
-
- procedure Face_Mark_Action
- (Data : in out Parse_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array;
- Params : in Face_Mark_Param_Array)
- is
- pragma Unreferenced (Nonterm);
-
- use Face_Cache_Trees;
-
- Iter : constant Iterator := Data.Face_Caches.Iterate;
- Cache_Cur : Cursor;
- begin
- for Param of Params loop
- if Tree.Byte_Region (Tokens (Param.Index)) /= Null_Buffer_Region then
- declare
- Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, Tokens (Param.Index));
- begin
- Cache_Cur := Find (Iter, Token.Char_Region.First, Direction =>
Ascending);
- if Has_Element (Cache_Cur) then
- declare
- Cache : Face_Cache_Type renames Data.Face_Caches
(Cache_Cur);
- Other_Cur : Cursor := Find_In_Range
- (Iter, Ascending, Cache.Char_Region.Last + 1,
Token.Char_Region.Last);
- Temp : Cursor;
- begin
- loop
- exit when not Has_Element (Other_Cur) or else
- Data.Face_Caches (Other_Cur).Char_Region.First >
Token.Char_Region.Last;
- Temp := Other_Cur;
- Other_Cur := Next (Iter, Other_Cur);
- Delete (Data.Face_Caches, Temp);
- end loop;
-
- Cache.Class := Param.Class;
- Cache.Char_Region.Last := Token.Char_Region.Last;
- end;
- else
- Data.Face_Caches.Insert ((Token.Char_Region, Param.Class,
(Set => False)));
- end if;
- end;
- end if;
- end loop;
- end Face_Mark_Action;
-
- procedure Face_Remove_Action
- (Data : in out Parse_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array;
- Params : in Face_Remove_Param_Array)
- is
- pragma Unreferenced (Nonterm);
- use Face_Cache_Trees;
-
- Iter : constant Iterator := Data.Face_Caches.Iterate;
- Cache_Cur : Cursor;
- Temp : Cursor;
- begin
- for I of Params loop
- if Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region then
- declare
- Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, Tokens (I));
- begin
- Cache_Cur := Find_In_Range (Iter, Ascending,
Token.Char_Region.First, Token.Char_Region.Last);
- loop
- exit when not Has_Element (Cache_Cur) or else
- Data.Face_Caches (Cache_Cur).Char_Region.First >
Token.Char_Region.Last;
- Temp := Cache_Cur;
- Cache_Cur := Next (Iter, Cache_Cur);
- Delete (Data.Face_Caches, Temp);
- end loop;
- end;
- end if;
- end loop;
- end Face_Remove_Action;
-
- function "+" (Item : in Integer) return Indent_Arg_Arrays.Vector
- is begin
- return Result : Indent_Arg_Arrays.Vector do
- Result.Append (Item);
- end return;
- end "+";
-
- function "&" (List : in Indent_Arg_Arrays.Vector; Item : in Integer) return
Indent_Arg_Arrays.Vector
- is begin
- return Result : Indent_Arg_Arrays.Vector := List do
- Result.Append (Item);
- end return;
- end "&";
-
- function "&" (Left, Right : in Integer) return Indent_Arg_Arrays.Vector
- is begin
- return Result : Indent_Arg_Arrays.Vector do
- Result.Append (Left);
- Result.Append (Right);
- end return;
- end "&";
-
- function Image (Item : in Simple_Indent_Param) return String
- is begin
- return "(" & Simple_Indent_Param_Label'Image (Item.Label) &
- (case Item.Label is
- when None => "",
- when Int => Integer'Image (Item.Int_Delta),
- when Anchored_Label => Positive_Index_Type'Image
(Item.Anchored_Index) & "," &
- Integer'Image (Item.Anchored_Delta),
- when Language => "<language_function>") & ")";
- end Image;
-
- function Image (Item : in Indent_Param) return String
- is begin
- return "(" & Indent_Param_Label'Image (Item.Label) & ", " &
- (case Item.Label is
- when Simple => Image (Item.Param),
- when Hanging_Label =>
- Image (Item.Hanging_Delta_1) & ", " & Image
(Item.Hanging_Delta_2) & ")");
- end Image;
-
- function Image (Item : in Indent_Pair) return String
- is begin
- return "(" & Image (Item.Code_Delta) &
- (if Item.Comment_Present
- then ", " & Image (Item.Comment_Delta)
- else "") & ")";
- end Image;
-
- procedure Indent_Action_0
- (Data : in out Parse_Data_Type'Class;
- Tree : in Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array;
- Params : in Indent_Param_Array)
- is begin
- if Trace_Action > Outline then
- Ada.Text_IO.Put_Line (";; indent_action_0: " & Tree.Image (Nonterm,
Data.Descriptor.all));
- end if;
-
- for I in Tokens'Range loop
- if (Tree.Is_Virtual_Terminal (Tokens (I)) or
- Tree.Byte_Region (Tokens (I)) /= Null_Buffer_Region) and
- I in Params'Range -- in some translated EBNF, not every token has
an indent param
- then
- declare
- use all type SAL.Base_Peek_Type;
- Tree_Token : constant Valid_Node_Index := Tokens (I);
- Token : Aug_Token_Const_Ref renames
Get_Aug_Token_Const_1 (Tree, Tree_Token);
- Pair : Indent_Pair renames Params (I);
- Code_Delta : Delta_Type;
- Comment_Param : Indent_Param;
- Comment_Param_Set : Boolean :=
False;
- Comment_Delta : Delta_Type;
- begin
- if Trace_Action > Detail then
- Ada.Text_IO.Put_Line
- (";; indent_action_0 a: " & Tree.Image (Tree_Token,
Data.Descriptor.all) & ": " & Image (Pair));
- end if;
-
- if Token.First_Indent_Line /= Invalid_Line_Number then
- Code_Delta := Indent_Compute_Delta
- (Data, Tree, Tokens, Pair.Code_Delta, Tree_Token,
Indenting_Comment => False);
-
- Indent_Token_1 (Data, Tree, Token, Code_Delta,
Indenting_Comment => False);
- end if;
-
- if Token.First_Trailing_Comment_Line /= Invalid_Line_Number then
- if Pair.Comment_Present then
- Comment_Param := Pair.Comment_Delta;
- Comment_Param_Set := True;
-
- elsif I < Tokens'Last then
- Comment_Param := Params (I + 1).Code_Delta;
- Comment_Param_Set := True;
-
- end if;
-
- if Comment_Param_Set then
- Comment_Delta := Indent_Compute_Delta
- (Data, Tree, Tokens, Comment_Param, Tree_Token,
Indenting_Comment => True);
-
- Indent_Token_1 (Data, Tree, Token, Comment_Delta,
Indenting_Comment => True);
- end if;
- end if;
- end;
- end if;
- end loop;
- end Indent_Action_0;
-
- procedure Indent_Action_1
- (Data : in out Parse_Data_Type'Class;
- Tree : in Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array;
- N : in Positive_Index_Type;
- Params : in Indent_Param_Array)
- is
- use all type Syntax_Trees.Node_Label;
- begin
- for I in Tokens'First .. N loop
- declare
- Aug : Aug_Token_Const_Ref renames Wisi.Get_Aug_Token_Const_1
(Tree, Tokens (I));
- begin
- if Tree.Label (Tokens (I)) /= Virtual_Terminal and then Aug.First
then
- Indent_Action_0 (Data, Tree, Nonterm, Tokens, Params);
- return;
- end if;
- end;
- end loop;
- end Indent_Action_1;
-
- function Indent_Hanging_1
- (Data : in out Parse_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Tokens : in Valid_Node_Index_Array;
- Tree_Indenting : in Valid_Node_Index;
- Indenting_Comment : in Boolean;
- Delta_1 : in Simple_Indent_Param;
- Delta_2 : in Simple_Indent_Param;
- Option : in Boolean;
- Accumulate : in Boolean)
- return Delta_Type
- is
- Indenting_Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, Tree_Indenting);
- begin
- if Indenting_Comment then
- return Indent_Compute_Delta
- (Data, Tree, Tokens, (Simple, Delta_1), Tree_Indenting,
Indenting_Comment);
- else
- return
- (Hanging,
- Hanging_First_Line => Indenting_Token.Line,
- Hanging_Paren_State => Indenting_Token.Paren_State,
- Hanging_Delta_1 => Indent_Compute_Delta
- (Data, Tree, Tokens, (Simple, Delta_1), Tree_Indenting,
Indenting_Comment).Simple_Delta,
- Hanging_Delta_2 =>
- (if (not Option) or
- Indenting_Token.Line = Indenting_Token.First_Indent_Line --
first token in tok is first on line
- then Indent_Compute_Delta
- (Data, Tree, Tokens, (Simple, Delta_2), Tree_Indenting,
Indenting_Comment).Simple_Delta
- else Indent_Compute_Delta
- (Data, Tree, Tokens, (Simple, Delta_1), Tree_Indenting,
Indenting_Comment).Simple_Delta),
- Hanging_Accumulate => Accumulate);
- end if;
- end Indent_Hanging_1;
-
- procedure Put_Language_Action
- (Data : in Parse_Data_Type;
- Content : in String)
- is
- pragma Unreferenced (Data);
- begin
- Ada.Text_IO.Put_Line ("[" & Language_Action_Code & Content & "]");
- end Put_Language_Action;
-
- procedure Put (Data : in out Parse_Data_Type; Parser : in
Parse.Base_Parser'Class)
- is
- use all type Ada.Containers.Count_Type;
-
- Last_Term : constant Node_Index := Parser.Tree.Last_Terminal
(Parser.Tree.Root);
-
- function Get_Last_Char_Pos return Buffer_Pos
- is begin
-
- if Last_Term = Invalid_Node_Index then
- -- All comments, or empty
- if Data.Leading_Non_Grammar.Length > 0 then
- return Data.Leading_Non_Grammar
(Data.Leading_Non_Grammar.Last_Index).Char_Region.Last;
- else
- return Buffer_Pos'First;
- end if;
- else
- declare
- Aug : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Parser.Tree, Last_Term);
- begin
- if Aug.Non_Grammar.Length = 0 then
- return Aug.Char_Region.Last;
- else
- return Aug.Non_Grammar
(Aug.Non_Grammar.Last_Index).Char_Region.Last;
- end if;
- end;
- end if;
- end Get_Last_Char_Pos;
-
- Last_Char_Pos : constant Buffer_Pos := Get_Last_Char_Pos;
-
- function Get_Last_Line return Line_Number_Type
- is begin
- for I in Data.Line_Begin_Char_Pos.First_Index ..
Data.Line_Begin_Char_Pos.Last_Index loop
- if Data.Line_Begin_Char_Pos (I) = Invalid_Buffer_Pos then
- raise SAL.Programmer_Error with "line_begin_pos" &
Line_Number_Type'Image (I) & " invalid";
- end if;
- if Data.Line_Begin_Char_Pos (I) > Last_Char_Pos then
- if I > Line_Number_Type'First then
- return I - 1;
- else
- return I;
- end if;
- end if;
- end loop;
- return Data.Line_Begin_Char_Pos.Last_Index;
- end Get_Last_Line;
-
- begin
- if Trace_Action > Outline then
- Ada.Text_IO.Put_Line
- (";; last_char_pos:" & Buffer_Pos'Image (Last_Char_Pos + 1) &
- " last_line:" & Line_Number_Type'Image (Get_Last_Line));
- end if;
-
- -- +1 to match Emacs region
- Ada.Text_IO.Put_Line ('[' & End_Code & Buffer_Pos'Image (Last_Char_Pos +
1) & ']');
-
- case Data.Post_Parse_Action is
- when Navigate =>
- for Cache of Data.Navigate_Caches loop
- Put (Cache);
- end loop;
- for Cache of Data.Name_Caches loop
- Put (Cache);
- end loop;
-
- when Face =>
- for Cache of Data.Face_Caches loop
- Put (Cache);
- end loop;
-
- when Indent =>
-
- Resolve_Anchors (Data);
-
- if Trace_Action > Outline then
- Ada.Text_IO.Put_Line (";; indent leading non_grammar");
- end if;
- for Token of Data.Leading_Non_Grammar loop
- if Token.First then
- Put (Token.Line, (Int, Data.Begin_Indent));
- end if;
- end loop;
-
- -- It may be that not all lines in Data.Indents were parsed.
- if Trace_Action > Outline then
- Ada.Text_IO.Put_Line (";; indent grammar");
- end if;
- for I in Data.Indents.First_Index .. Get_Last_Line loop
- Put (I, Data.Indents (I));
- end loop;
- end case;
- end Put;
-
- procedure Put (Lexer_Errors : in Lexer.Error_Lists.List)
- is begin
- for Item of Lexer_Errors loop
- Ada.Text_IO.Put_Line
- ('[' & Lexer_Error_Code & Buffer_Pos'Image (Item.Char_Pos) &
- " ""lexer error" &
- (if Item.Recover_Char (1) = ASCII.NUL
- then """"
- elsif Item.Recover_Char (1) = '"'
- then """ ?\"""
- else """ ?" & Item.Recover_Char (1)) &
- "]");
- if Item.Recover_Char (2) /= ASCII.NUL then
- raise SAL.Programmer_Error with "lexer error with non-ascii or
multiple repair char";
- end if;
- end loop;
- end Put;
-
- procedure Put
- (Data : in Parse_Data_Type;
- Lexer_Errors : in Lexer.Error_Lists.List;
- Parse_Errors : in Parse.LR.Parse_Error_Lists.List;
- Tree : in Syntax_Trees.Tree)
- is
- use all type SAL.Base_Peek_Type;
- use Ada.Text_IO;
- use Semantic_Checks;
-
- function Safe_Pos (Node : in Valid_Node_Index) return Buffer_Pos
- is
- -- Return a reasonable position for the error at Node.
- --
- -- In a successful parse with error recovery, Node is a terminal with
- -- an augmented token in Data.Terminals, so that is the first
- -- choice.
- --
- -- If this is an error due to a bad recovery, Node may be a virtual
- -- token, with no position information, so we try to get information
- -- from its parent.
- use Syntax_Trees;
-
- N : Node_Index := Node;
- begin
- loop
- if Tree.Label (N) /= Virtual_Terminal then
- declare
- Ref : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, N);
- begin
- if Ref.Char_Region /= Null_Buffer_Region then
- return Ref.Element.Char_Region.First;
- end if;
-
- end;
- end if;
- N := Tree.Parent (N);
- exit when N = Invalid_Node_Index;
- end loop;
- return Buffer_Pos'First;
- end Safe_Pos;
-
- function Safe_Pos (Token : in Recover_Token) return Buffer_Pos
- is begin
- if Token.Name /= Null_Buffer_Region then
- return Token.Name.First;
-
- elsif Token.Byte_Region = Null_Buffer_Region then
- return Buffer_Pos'First;
-
- else
- return Token.Byte_Region.First;
- end if;
- end Safe_Pos;
-
- begin
- Put (Lexer_Errors);
-
- for Item of Parse_Errors loop
- case Item.Label is
- when Parse.LR.Action =>
- Put_Line
- ('[' & Parser_Error_Code & Buffer_Pos'Image (Safe_Pos
(Item.Error_Token)) &
- " ""syntax error: expecting " & Image (Item.Expecting,
Data.Descriptor.all) &
- ", found '" & Image (Tree.ID (Item.Error_Token),
Data.Descriptor.all) & "'""]");
-
- when Parse.LR.Check =>
- Put_Line
- ('[' & Check_Error_Code & Integer'Image
- (Semantic_Checks.Check_Status_Label'Pos
(Item.Check_Status.Label)) &
- (case Item.Check_Status.Label is
- when Ok => "",
- when Error =>
- Buffer_Pos'Image (Safe_Pos
(Item.Check_Status.Begin_Name)) &
- Buffer_Pos'Image (Safe_Pos
(Item.Check_Status.End_Name)) &
- " ""block name error""]"));
-
- when Parse.LR.Message =>
- Put_Line
- ('[' & Parser_Error_Code & Buffer_Pos'Image (Buffer_Pos'First) &
- " """ & (-Item.Msg) & """]");
- end case;
-
- if Item.Recover.Stack.Depth > 0 then
- Put (Item.Recover, Data, Tree);
- end if;
- end loop;
- end Put;
-
- procedure Put_Error (Data : in Parse_Data_Type; Line_Number : in
Line_Number_Type; Message : in String)
- is
- use Ada.Text_IO;
- begin
- Put_Line ("(error """ & Error_Message (Data.Lexer.File_Name,
Line_Number, 0, Message) & """)");
- end Put_Error;
-
- ----------
- -- Spec visible private subprograms, alphabetical
-
- function Image (Item : in Simple_Delta_Type) return String
- is begin
- return "(" & Simple_Delta_Labels'Image (Item.Label) &
- (case Item.Label is
- when None => "",
- when Int => Integer'Image (Item.Int_Delta),
- when Anchored => Integer'Image (Item.Anchored_ID) & Integer'Image
(Item.Anchored_Delta) & " " &
- Boolean'Image (Item.Anchored_Accumulate))
- & ")";
- end Image;
-
- function Image (Item : in Delta_Type) return String
- is begin
- return "(" & Delta_Labels'Image (Item.Label) &
- (case Item.Label is
- when Simple => " " & Image (Item.Simple_Delta),
- when Hanging => Line_Number_Type'Image (Item.Hanging_First_Line) &
Integer'Image (Item.Hanging_Paren_State) &
- " " & Image (Item.Hanging_Delta_1) & " " & Image
(Item.Hanging_Delta_2) & " " &
- Boolean'Image (Item.Hanging_Accumulate)) & ")";
- end Image;
-
- function Current_Indent_Offset
- (Data : in Parse_Data_Type;
- Anchor_Token : in Augmented_Token'Class;
- Offset : in Integer)
- return Integer
- is begin
- return Offset + Integer (Anchor_Token.Char_Region.First -
Data.Line_Begin_Char_Pos (Anchor_Token.Line));
- end Current_Indent_Offset;
-
- function First_Line
- (Token : in Augmented_Token;
- Indenting_Comment : in Boolean)
- return Line_Number_Type
- is begin
- return
- (if Indenting_Comment then
- (if Token.First_Trailing_Comment_Line = Invalid_Line_Number
- then Token.Line
- else Token.First_Trailing_Comment_Line)
- else
- (if Token.First_Indent_Line = Invalid_Line_Number
- then Token.Line
- else Token.First_Indent_Line));
- end First_Line;
-
- function Get_Aug_Token_Const_1
- (Tree : in Syntax_Trees.Tree'Class;
- Tree_Index : in Valid_Node_Index)
- return Aug_Token_Const_Ref
- is begin
- return To_Aug_Token_Const_Ref (Tree.Augmented (Tree_Index));
- end Get_Aug_Token_Const_1;
-
- function Get_Aug_Token_Const
- (Data : in Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree'Class;
- Token : in WisiToken.Token_Index)
- return Aug_Token_Const_Ref
- is begin
- return Get_Aug_Token_Const_1 (Tree, Data.Terminals.all
(Token).Tree_Index);
- end Get_Aug_Token_Const;
-
- function Get_Aug_Token_Var
- (Tree : in Syntax_Trees.Tree'Class;
- Tree_Index : in Valid_Node_Index)
- return Aug_Token_Var_Ref
- is begin
- return To_Aug_Token_Var_Ref (Tree.Augmented (Tree_Index));
- end Get_Aug_Token_Var;
-
- function Get_Aug_Token_Var
- (Data : in Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree'Class;
- Token : in WisiToken.Token_Index)
- return Aug_Token_Var_Ref
- is begin
- return Get_Aug_Token_Var (Tree, Data.Terminals.all (Token).Tree_Index);
- end Get_Aug_Token_Var;
-
- function Get_Text
- (Data : in Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tree_Index : in WisiToken.Valid_Node_Index)
- return String
- is
- use all type Syntax_Trees.Node_Label;
- begin
- case Tree.Label (Tree_Index) is
- when Shared_Terminal | Nonterm =>
- return Data.Lexer.Buffer_Text (Tree.Byte_Region (Tree_Index));
-
- when Virtual_Terminal | Virtual_Identifier =>
- raise SAL.Programmer_Error;
-
- end case;
- end Get_Text;
-
- function Elisp_Escape_Quotes (Item : in String) return String
- is
- Result : String (Item'First .. Item'First + Item'Length * 2);
- Last : Integer := Item'First - 1;
- begin
- for I in Item'Range loop
- if Item (I) = '"' then
- Last := Last + 1;
- Result (Last) := '\';
- end if;
- Last := Last + 1;
- Result (Last) := Item (I);
- end loop;
- return Result (Result'First .. Last);
- end Elisp_Escape_Quotes;
-
- overriding
- function Image
- (Item : in Augmented_Token;
- Descriptor : in WisiToken.Descriptor)
- return String
- is
- ID_Image : constant String := Image (Item.ID, Descriptor);
- begin
- if Item.Line /= Invalid_Line_Number then
- return "(" & ID_Image &
- Line_Number_Type'Image (Item.Line) & ":" & Trimmed_Image (Integer
(Item.Column)) & ")";
-
- elsif Item.Char_Region = Null_Buffer_Region then
- 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;
- end Image;
-
- function Indent_Anchored_2
- (Data : in out Parse_Data_Type;
- Anchor_Line : in Line_Number_Type;
- Last_Line : in Line_Number_Type;
- Offset : in Integer;
- Accumulate : in Boolean)
- return Delta_Type
- is
- -- Return an anchored delta
- use Anchor_ID_Vectors;
- -- We can't use a Reference here, because the Element in reference
- -- types is constrained (as are all allocated objects of access
- -- types; AARM 4.8 (6/3)), and we may need to change the Label.
- Indent : Indent_Type := Data.Indents (Anchor_Line);
- Anchor_ID : constant Integer := 1 + Max_Anchor_ID (Data, Anchor_Line,
Last_Line);
- begin
- Data.Max_Anchor_ID := Integer'Max (Data.Max_Anchor_ID, Anchor_ID);
-
- case Indent.Label is
- when Not_Set =>
- Indent := (Anchor_Nil, To_Vector (Anchor_ID, 1));
-
- if Trace_Action > Extra then
- Ada.Text_IO.Put_Line
- (";; indent_anchored: " & Line_Number_Type'Image (Anchor_Line) &
" => " & Image (Indent));
- end if;
-
- when Int =>
- Indent := (Anchor_Int, To_Vector (Anchor_ID, 1), Indent.Int_Indent);
-
- if Trace_Action > Extra then
- Ada.Text_IO.Put_Line
- (";; indent_anchored: " & Line_Number_Type'Image (Anchor_Line) &
" => " & Image (Indent));
- end if;
-
- when Anchor_Nil =>
- Indent.Anchor_Nil_IDs := Anchor_ID & Indent.Anchor_Nil_IDs;
-
- when Anchor_Int =>
- Indent.Anchor_Int_IDs := Anchor_ID & Indent.Anchor_Int_IDs;
-
- when Anchored =>
- Indent := (Anchor_Anchored, To_Vector (Anchor_ID, 1),
Indent.Anchored_ID, Indent.Anchored_Delta);
-
- when Anchor_Anchored =>
- Indent.Anchor_Anchored_IDs := Anchor_ID & Indent.Anchor_Anchored_IDs;
- end case;
-
- Data.Indents.Replace_Element (Anchor_Line, Indent);
-
- return (Simple, (Anchored, Anchor_ID, Offset, Accumulate));
- end Indent_Anchored_2;
-
- function Indent_Compute_Delta
- (Data : in out Parse_Data_Type'Class;
- Tree : in Syntax_Trees.Tree;
- Tokens : in Valid_Node_Index_Array;
- Param : in Indent_Param;
- Tree_Indenting : in Valid_Node_Index;
- Indenting_Comment : in Boolean)
- return Delta_Type
- is
- Indenting_Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
(Tree, Tree_Indenting);
- begin
- -- Evaluate wisi-anchored*, wisi-hanging*.
- case Param.Label is
- when Simple =>
- case Param.Param.Label is
- when None =>
- return (Simple, (Label => None));
-
- when Int =>
- return (Simple, (Int, Param.Param.Int_Delta));
-
- when Anchored_Label =>
- declare
- Anchor_Token : Aug_Token_Const_Ref renames Get_Aug_Token_Const_1
- (Tree, Tokens (Param.Param.Anchored_Index));
- begin
- case Anchored_Label'(Param.Param.Label) is
- when Anchored_0 =>
- -- [2] wisi-anchored
- return Indent_Anchored_2
- (Data,
- Anchor_Line => Anchor_Token.Line,
- Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
- Offset => Current_Indent_Offset (Data, Anchor_Token,
Param.Param.Anchored_Delta),
- Accumulate => True);
-
- when Anchored_1 =>
- -- [2] wisi-anchored%
- return Indent_Anchored_2
- (Data,
- Anchor_Line => Anchor_Token.Line,
- Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
- Offset => Paren_In_Anchor_Line (Data, Tree,
Anchor_Token, Param.Param.Anchored_Delta),
- Accumulate => True);
-
- when Anchored_2 =>
- -- [2] wisi-anchored%-
- return Indent_Anchored_2
- (Data,
- Anchor_Line => Anchor_Token.Line,
- Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
- Offset => Paren_In_Anchor_Line (Data, Tree,
Anchor_Token, Param.Param.Anchored_Delta),
- Accumulate => False);
-
- when Anchored_3 =>
- -- [2] wisi-anchored*
- if Indenting_Token.First then
- return Indent_Anchored_2
- (Data,
- Anchor_Line => Anchor_Token.Line,
- Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
- Offset => Current_Indent_Offset (Data,
Anchor_Token, Param.Param.Anchored_Delta),
- Accumulate => True);
-
- else
- return Null_Delta;
- end if;
-
- when Anchored_4 =>
- -- [2] wisi-anchored*-
- return Indent_Anchored_2
- (Data,
- Anchor_Line => Anchor_Token.Line,
- Last_Line => Indenting_Token.Last_Line
(Indenting_Comment),
- Offset => Current_Indent_Offset (Data, Anchor_Token,
Param.Param.Anchored_Delta),
- Accumulate => False);
-
- end case;
- end;
-
- when Language =>
- return Param.Param.Function_Ptr
- (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Param.Args);
- end case;
-
- when Hanging_Label =>
- case Hanging_Label'(Param.Label) is
- when Hanging_0 => -- wisi-hanging
- return Indent_Hanging_1
- (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
- Param.Hanging_Delta_2,
- Option => False, Accumulate => True);
- when Hanging_1 => -- wisi-hanging-
- return Indent_Hanging_1
- (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
- Param.Hanging_Delta_2,
- Option => False, Accumulate => False);
- when Hanging_2 => -- wisi-hanging%
- return Indent_Hanging_1
- (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
- Param.Hanging_Delta_2,
- Option => True, Accumulate => True);
- when Hanging_3 => -- wisi-hanging%-
- return Indent_Hanging_1
- (Data, Tree, Tokens, Tree_Indenting, Indenting_Comment,
Param.Hanging_Delta_1,
- Param.Hanging_Delta_2,
- Option => True, Accumulate => False);
- end case;
- end case;
- end Indent_Compute_Delta;
-
- procedure Indent_Token_1
- (Data : in out Parse_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Indenting_Token : in Augmented_Token'Class;
- Delta_Indent : in Delta_Type;
- Indenting_Comment : in Boolean)
- is
- -- Aplly Delta_Indent to Indenting_Token
- First_Line : constant Line_Number_Type := Indenting_Token.First_Line
(Indenting_Comment);
- Last_Line : constant Line_Number_Type := Indenting_Token.Last_Line
(Indenting_Comment);
- begin
- if Trace_Action > Detail then
- Ada.Text_IO.Put_Line
- (";; indent_token_1: " & Indenting_Token.Image
(Data.Descriptor.all) & " " & Image (Delta_Indent) &
- Line_Number_Type'Image (First_Line) & " .." &
Line_Number_Type'Image (Last_Line) &
- (if Indenting_Comment then " comment" else ""));
- end if;
-
- for Line in First_Line .. Last_Line loop
- if Data.Indent_Comment_Col_0 then
- declare
- use all type Ada.Text_IO.Count;
-
- function Containing_Token return Base_Token_Index
- is
- -- Return token index of terminal containing non_grammer on
Line;
- -- Invalid_Token_Index if none.
- I : Line_Number_Type := Line;
- J : Base_Token_Index;
- begin
- if Line < Data.Line_Begin_Token.First_Index then
- -- Line is before first grammar token;
Leading_Non_Grammar checked
- -- below.
- return Invalid_Token_Index;
- end if;
-
- loop
- 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;
-
- J := Data.Line_Begin_Token.all (I);
- declare
- Aug : Augmented_Token renames Get_Aug_Token_Const (Data,
Tree, J);
- begin
- if Line in Aug.First_Trailing_Comment_Line ..
Aug.Last_Trailing_Comment_Line then
- return J;
- else
- return Invalid_Token_Index;
- end if;
- end;
- end Containing_Token;
-
- Indent : Boolean := True;
- Containing : constant Base_Token_Index := Containing_Token;
- begin
- if Line < Data.Line_Begin_Token.First_Index then
- -- Line is before the first grammar token. We may be doing
a partial
- -- parse where the initial indent is non-zero, so we still
have to
- -- check for column 0.
- for Tok of Data.Leading_Non_Grammar loop
- if Tok.Line = Line and then
- Tok.ID in Data.First_Comment_ID .. Data.Last_Comment_ID
and then
- Tok.Column = 0
- then
- Indent := False;
- exit;
- end if;
- end loop;
-
- elsif Containing /= Invalid_Token_Index then
- for Tok of Get_Aug_Token_Const (Data, Tree,
Containing).Non_Grammar loop
- if Tok.Line = Line and then
- Tok.ID in Data.First_Comment_ID .. Data.Last_Comment_ID
and then
- Tok.Column = 0
- then
- Indent := False;
- exit;
- end if;
- end loop;
- end if;
-
- if Indent then
- Indent_Line (Data, Line, Delta_Indent);
- else
- Indent_Line (Data, Line, (Simple, (Int, 0)));
- end if;
- end;
- else
- Indent_Line (Data, Line, Delta_Indent);
- end if;
- end loop;
- end Indent_Token_1;
-
- function Last_Line
- (Token : in Augmented_Token;
- Indenting_Comment : in Boolean)
- return Line_Number_Type
- is begin
- return
- (if Indenting_Comment then
- (if Token.Last_Trailing_Comment_Line = Invalid_Line_Number
- then Token.Line
- else Token.Last_Trailing_Comment_Line)
- else
- (if Token.Last_Indent_Line = Invalid_Line_Number
- then Token.Line
- else Token.Last_Indent_Line));
- end Last_Line;
-
-end Wisi;
diff --git a/packages/wisi/wisi.ads b/packages/wisi/wisi.ads
deleted file mode 100644
index e707ab8..0000000
--- a/packages/wisi/wisi.ads
+++ /dev/null
@@ -1,769 +0,0 @@
--- Abstract :
---
--- Ada implementation of wisi parser actions.
---
--- References
---
--- [1] wisi-parse-common.el - defines common stuff.
---
--- [2] wisi.texi - defines parse action functions.
---
--- [3] wisi-process-parse.el - defines elisp/process API
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers.Doubly_Linked_Lists;
-with Ada.Containers.Vectors;
-with SAL.Gen_Unbounded_Definite_Red_Black_Trees;
-with SAL.Gen_Unbounded_Definite_Vectors;
-with WisiToken.Parse.LR;
-with WisiToken.Lexer;
-with WisiToken.Syntax_Trees;
-package Wisi is
- use all type WisiToken.Base_Buffer_Pos;
-
- function Image (Aug : in WisiToken.Base_Token_Class_Access; Descriptor : in
WisiToken.Descriptor) return String;
- 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);
-
- type Parse_Data_Type
- (Terminals : not null access constant
WisiToken.Base_Token_Arrays.Vector;
- Line_Begin_Token : not null access constant
WisiToken.Line_Begin_Token_Vectors.Vector)
- is new WisiToken.Syntax_Trees.User_Data_Type with private;
-
- procedure Initialize
- (Data : in out Parse_Data_Type;
- Lexer : in WisiToken.Lexer.Handle;
- Descriptor : access constant WisiToken.Descriptor;
- Base_Terminals : in WisiToken.Base_Token_Array_Access;
- Post_Parse_Action : in Post_Parse_Action_Type;
- Begin_Line : in WisiToken.Line_Number_Type;
- End_Line : in WisiToken.Line_Number_Type;
- Begin_Indent : in Integer;
- Params : in String);
- -- Begin_Line, Begin_Indent, Line_Count only used for Indent. Params
- -- contains language-specific indent parameter values.
-
- overriding procedure Reset (Data : in out Parse_Data_Type);
- -- Reset for a new parse, with data from previous Initialize.
-
- function Source_File_Name (Data : in Parse_Data_Type) return String;
- function Post_Parse_Action (Data : in Parse_Data_Type) return
Post_Parse_Action_Type;
-
- overriding
- procedure Lexer_To_Augmented
- (Data : in out Parse_Data_Type;
- Tree : in out WisiToken.Syntax_Trees.Tree'Class;
- Token : in WisiToken.Base_Token;
- Lexer : not null access WisiToken.Lexer.Instance'Class);
-
- overriding
- procedure Insert_Token
- (Data : in out Parse_Data_Type;
- Tree : in out WisiToken.Syntax_Trees.Tree'Class;
- Token : in WisiToken.Valid_Node_Index);
-
- overriding
- procedure Delete_Token
- (Data : in out Parse_Data_Type;
- Tree : in out WisiToken.Syntax_Trees.Tree'Class;
- Deleted_Token_Index : in WisiToken.Token_Index);
-
- overriding
- procedure Reduce
- (Data : in out Parse_Data_Type;
- Tree : in out WisiToken.Syntax_Trees.Tree'Class;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array);
-
- type Navigate_Class_Type is (Motion, Statement_End, Statement_Override,
Statement_Start, Misc);
- -- Matches [1] wisi-class-list.
-
- type Index_Navigate_Class is record
- Index : WisiToken.Positive_Index_Type; -- into Tokens
- Class : Navigate_Class_Type;
- end record;
-
- type Statement_Param_Array is array (Natural range <>) of
Index_Navigate_Class;
-
- procedure Statement_Action
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Params : in Statement_Param_Array);
- -- Implements [2] wisi-statement-action.
-
- procedure Name_Action
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Name : in WisiToken.Positive_Index_Type);
- -- Implements [2] wisi-name-action.
-
- type Index_ID is record
- Index : WisiToken.Positive_Index_Type; -- into Tokens
- ID : WisiToken.Token_ID;
- -- If ID is not Invalid_Token_ID, it is the first token in the
- -- nonterm that Index points to that should have a navigate cache for
- -- Motion_Action to link to; an error is reported by Motion_Action if
- -- it does not.
- --
- -- If ID is Invalid_Token_ID, and the token at Index is a
- -- nonterminal, the first token in that nonterminal must have a
- -- navigate cache; an error is reported by Motion_Action if not.
- end record;
-
- package Index_ID_Vectors is new Ada.Containers.Vectors
(Ada.Containers.Count_Type, Index_ID);
-
- subtype Motion_Param_Array is Index_ID_Vectors.Vector;
-
- Invalid_Token_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
- -- So Create_Parser can just use "Invalid_Token_ID".
-
- procedure Motion_Action
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Params : in Motion_Param_Array);
- -- Implements [2] wisi-motion-action.
-
- type Index_Faces is record
- Index : WisiToken.Positive_Index_Type; -- into Tokens
- Prefix_Face : Integer; -- into grammar.Face_List
- Suffix_Face : Integer; -- into grammar.Face_List
- end record;
-
- type Face_Apply_Param_Array is array (Natural range <>) of Index_Faces;
-
- procedure Face_Apply_Action
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Params : in Face_Apply_Param_Array);
- -- Implements [2] wisi-face-apply-action.
-
- procedure Face_Apply_List_Action
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Params : in Face_Apply_Param_Array);
- -- Implements [2] wisi-face-apply-list-action.
-
- type Face_Class_Type is (Prefix, Suffix);
-
- type Index_Face_Class is record
- Index : WisiToken.Positive_Index_Type; -- into Tokens
- Class : Face_Class_Type;
- end record;
-
- type Face_Mark_Param_Array is array (Natural range <>) of Index_Face_Class;
-
- procedure Face_Mark_Action
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Params : in Face_Mark_Param_Array);
- -- Implements [2] wisi-face-mark-action.
-
- type Face_Remove_Param_Array is array (Natural range <>) of
WisiToken.Positive_Index_Type;
-
- procedure Face_Remove_Action
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Params : in Face_Remove_Param_Array);
- -- Implements [2] wisi-face-remove-action.
-
- ----------
- -- Indent
- --
- -- Indent functions are represented by the Indent_Param type.
-
- type Simple_Indent_Param_Label is -- not hanging
- (None,
- Int,
- Anchored_0, -- [2] wisi-anchored
- Anchored_1, -- [2] wisi-anchored%
- Anchored_2, -- [2] wisi-anchored%-
- Anchored_3, -- [2] wisi-anchored*
- Anchored_4, -- [2] wisi-anchored*-
- Language -- [2] language-specific function
- );
- subtype Anchored_Label is Simple_Indent_Param_Label range Anchored_0 ..
Anchored_4;
-
- -- Arguments to language-specific functions are integers; one of
- -- delta, Token_Number, or Token_ID - the syntax does not distinguish
- -- among these three types.
-
- package Indent_Arg_Arrays is new Ada.Containers.Vectors
(WisiToken.Positive_Index_Type, Integer);
-
- function "+" (Item : in Integer) return Indent_Arg_Arrays.Vector;
- function "&" (List : in Indent_Arg_Arrays.Vector; Item : in Integer) return
Indent_Arg_Arrays.Vector;
- function "&" (Left, Right : in Integer) return Indent_Arg_Arrays.Vector;
-
- type Delta_Type (<>) is private;
-
- type Language_Indent_Function is access function
- (Data : in out Parse_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tree_Tokens : in WisiToken.Valid_Node_Index_Array;
- Tree_Indenting : in WisiToken.Valid_Node_Index;
- Indenting_Comment : in Boolean;
- Args : in Indent_Arg_Arrays.Vector)
- return Delta_Type;
-
- Null_Args : Indent_Arg_Arrays.Vector renames Indent_Arg_Arrays.Empty_Vector;
-
- type Simple_Indent_Param (Label : Simple_Indent_Param_Label := None) is
- record
- case Label is
- when None =>
- null;
-
- when Int =>
- Int_Delta : Integer;
-
- when Anchored_Label =>
- Anchored_Index : WisiToken.Positive_Index_Type;
- Anchored_Delta : Integer;
-
- when Language =>
- Function_Ptr : Language_Indent_Function;
- Args : Indent_Arg_Arrays.Vector;
- end case;
- end record;
-
- function Image (Item : in Simple_Indent_Param) return String;
-
- type Indent_Param_Label is
- (Simple,
- Hanging_0, -- [2] wisi-hanging
- Hanging_1, -- [2] wisi-hanging-
- Hanging_2, -- [2] wisi-hanging%
- Hanging_3 -- [2] wisi-hanging%-
- );
- subtype Hanging_Label is Indent_Param_Label range Hanging_0 .. Hanging_3;
-
- type Indent_Param (Label : Indent_Param_Label := Simple) is
- record
- case Label is
- when Simple =>
- Param : Simple_Indent_Param;
-
- when Hanging_Label =>
- Hanging_Delta_1 : Simple_Indent_Param;
- Hanging_Delta_2 : Simple_Indent_Param;
-
- end case;
- end record;
-
- function Image (Item : in Indent_Param) return String;
-
- type Indent_Pair (Comment_Present : Boolean := False) is
- record
- Code_Delta : Indent_Param;
- case Comment_Present is
- when True =>
- Comment_Delta : Indent_Param;
- when False =>
- null;
- end case;
- end record;
-
- function Image (Item : in Indent_Pair) return String;
-
- type Indent_Param_Array is array (WisiToken.Positive_Index_Type range <>)
of Indent_Pair;
-
- procedure Indent_Action_0
- (Data : in out Parse_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Params : in Indent_Param_Array);
- -- Implements [2] wisi-indent-action.
-
- procedure Indent_Action_1
- (Data : in out Parse_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- N : in WisiToken.Positive_Index_Type;
- Params : in Indent_Param_Array);
- -- Implements [2] wisi-indent-action*.
-
- function Indent_Hanging_1
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Tree_Indenting : in WisiToken.Valid_Node_Index;
- Indenting_Comment : in Boolean;
- Delta_1 : in Simple_Indent_Param;
- Delta_2 : in Simple_Indent_Param;
- Option : in Boolean;
- Accumulate : in Boolean)
- return Delta_Type;
- -- Implements [2] wisi-hanging, wisi-hanging%, wisi-hanging%-.
- --
- -- Language specific child packages may override this to implement
- -- language-specific cases.
-
- ----------
- -- Other
-
- procedure Refactor
- (Data : in out Parse_Data_Type;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Action : in Positive;
- Edit_Begin : in WisiToken.Buffer_Pos) is null;
-
- type Arg_Index_Array is array (Positive range <>) of
WisiToken.Positive_Index_Type;
-
- procedure Put_Language_Action
- (Data : in Parse_Data_Type;
- Content : in String);
- -- Send a Language_Action message to Emacs.
-
- procedure Put (Data : in out Parse_Data_Type; Parser : in
WisiToken.Parse.Base_Parser'Class);
- -- Perform additional post-parse actions, then put result to
- -- Ada.Text_IO.Current_Output, as encoded responses as defined in [3]
- -- wisi-process-parse--execute.
-
- procedure Put (Lexer_Errors : in WisiToken.Lexer.Error_Lists.List);
- procedure Put
- (Data : in Parse_Data_Type;
- Lexer_Errors : in WisiToken.Lexer.Error_Lists.List;
- Parse_Errors : in WisiToken.Parse.LR.Parse_Error_Lists.List;
- Tree : in WisiToken.Syntax_Trees.Tree);
- -- Put Lexer_Errors and Parse_Errors to Ada.Text_IO.Current_Output,
- -- as encoded error responses as defined in [3]
- -- wisi-process-parse--execute.
-
- procedure Put_Error (Data : in Parse_Data_Type; Line_Number : in
WisiToken.Line_Number_Type; Message : in String);
- -- Put an error elisp form to Ada.Text_IO.Standard_Output.
-
-private
-
- type Non_Grammar_Token is new WisiToken.Base_Token with record
- First : Boolean := False;
- end record;
-
- package Non_Grammar_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (WisiToken.Token_Index, Non_Grammar_Token, Default_Element => (others =>
<>));
-
- type Augmented_Token is new WisiToken.Base_Token with record
- -- Most fields are set by Lexer_To_Augmented at parse time; others
- -- are set by Reduce for nonterminals.
-
- Deleted : Boolean := False;
- -- Set True by Parse_Data_Type.Delete_Token; Non_Grammar tokens are
- -- moved to the previous non-deleted token.
-
- -- The following fields are only needed for indent.
-
- First : Boolean := False;
- -- For a terminal, True if the token is first on a line.
- --
- -- For a nonterminal, True if some contained token's First is True.
-
- Paren_State : Integer := 0;
- -- Parenthesis nesting count, before token.
-
- First_Terminals_Index : WisiToken.Base_Token_Index :=
WisiToken.Invalid_Token_Index;
- -- For virtual tokens, Invalid_Token_Index
- --
- -- For terminal tokens, index of this token in Parser.Terminals.
- --
- -- For nonterminal tokens, index of first contained token in
- -- Parser.Terminals.
-
- Last_Terminals_Index : WisiToken.Base_Token_Index :=
WisiToken.Base_Token_Arrays.No_Index;
- -- For non-virtual nonterminal tokens, index of last contained
- -- token in Parser.Terminals.
- --
- -- For all others, same as First_Terminals_Index.
-
- First_Indent_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
- Last_Indent_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
- -- Lines that need indenting; first token on these lines is contained
- -- in this token. If First is False, these are Invalid_Line_Number.
- --
- -- First_, Last_Indent_Line include blank and comment lines between
- -- grammar tokens, but exclude trailing blanks and comments after the
- -- last token, so they can be indented differently.
-
- First_Trailing_Comment_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
- Last_Trailing_Comment_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
- -- Trailing comment or blank lines (after the last contained grammar
- -- token) that need indenting. Excludes comments following code on a
- -- line. If there are no such lines, these are Invalid_Line_Number.
-
- Non_Grammar : Non_Grammar_Token_Arrays.Vector;
- -- For terminals, non-grammar tokens immediately following. For
- -- nonterminals, empty.
-
- Inserted_Before : WisiToken.Valid_Node_Index_Arrays.Vector;
- -- Tokens inserted before this token by error recovery.
-
- end record;
- type Augmented_Token_Access is access all Augmented_Token;
- type Augmented_Token_Access_Constant is access constant Augmented_Token;
-
- type Aug_Token_Const_Ref (Element : not null access constant
Augmented_Token) is null record with
- Implicit_Dereference => Element;
-
- function To_Aug_Token_Const_Ref (Item : in
WisiToken.Base_Token_Class_Access) return Aug_Token_Const_Ref
- is (Element => Augmented_Token_Access_Constant (Item));
-
- type Aug_Token_Var_Ref (Element : not null access Augmented_Token) is null
record with
- Implicit_Dereference => Element;
-
- function To_Aug_Token_Var_Ref (Item : in WisiToken.Base_Token_Class_Access)
return Aug_Token_Var_Ref
- is (Element => Augmented_Token_Access (Item));
-
- overriding
- function Image
- (Item : in Augmented_Token;
- Descriptor : in WisiToken.Descriptor)
- return String;
- -- Return a string for debug/test messages
-
- function First_Line
- (Token : in Augmented_Token;
- Indenting_Comment : in Boolean)
- return WisiToken.Line_Number_Type;
- function Last_Line
- (Token : in Augmented_Token;
- Indenting_Comment : in Boolean)
- return WisiToken.Line_Number_Type;
- -- Return first and last line in Token's region.
-
- package Line_Paren_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
- (WisiToken.Line_Number_Type, Integer, Default_Element => Integer'Last);
- package Line_Begin_Pos_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
- (WisiToken.Line_Number_Type, WisiToken.Buffer_Pos, Default_Element =>
WisiToken.Invalid_Buffer_Pos);
-
- type Nil_Buffer_Pos (Set : Boolean := False) is record
- case Set is
- when True =>
- Item : WisiToken.Buffer_Pos;
- when False =>
- null;
- end case;
- end record;
-
- Nil : constant Nil_Buffer_Pos := (Set => False);
-
- type Navigate_Cache_Type is record
- Pos : WisiToken.Buffer_Pos; -- implicit in [1] wisi-cache
- Statement_ID : WisiToken.Token_ID; -- [1] wisi-cache-nonterm
- ID : WisiToken.Token_ID; -- [1] wisi-cache-token
- Length : Natural; -- [1] wisi-cache-last
- Class : Navigate_Class_Type; -- [1] wisi-cache-class
- Containing_Pos : Nil_Buffer_Pos; -- [1] wisi-cache-containing
- Prev_Pos : Nil_Buffer_Pos; -- [1] wisi-cache-prev
- Next_Pos : Nil_Buffer_Pos; -- [1] wisi-cache-next
- End_Pos : Nil_Buffer_Pos; -- [1] wisi-cache-end
- end record;
-
- function Key (Cache : in Navigate_Cache_Type) return WisiToken.Buffer_Pos
is (Cache.Pos);
-
- function Key_Compare (Left, Right : in WisiToken.Buffer_Pos) return
SAL.Compare_Result is
- (if Left > Right then SAL.Greater
- elsif Left = Right then SAL.Equal
- else SAL.Less);
-
- package Navigate_Cache_Trees is new
SAL.Gen_Unbounded_Definite_Red_Black_Trees
- (Navigate_Cache_Type, WisiToken.Buffer_Pos);
-
- function Key (Cache : in WisiToken.Buffer_Region) return
WisiToken.Buffer_Pos is (Cache.First);
-
- package Name_Cache_Trees is new SAL.Gen_Unbounded_Definite_Red_Black_Trees
- (WisiToken.Buffer_Region, WisiToken.Buffer_Pos);
-
- type Nil_Integer (Set : Boolean := False) is record
- case Set is
- when True =>
- Item : Integer;
- when False =>
- null;
- end case;
- end record;
-
- type Face_Cache_Type is record
- Char_Region : WisiToken.Buffer_Region;
- Class : Face_Class_Type;
- Face : Nil_Integer; -- not set, or index into
*-process-faces-names
- end record;
-
- function Key (Cache : in Face_Cache_Type) return WisiToken.Buffer_Pos is
(Cache.Char_Region.First);
-
- package Face_Cache_Trees is new SAL.Gen_Unbounded_Definite_Red_Black_Trees
(Face_Cache_Type, WisiToken.Buffer_Pos);
-
- type Indent_Label is (Not_Set, Int, Anchor_Nil, Anchor_Int, Anchored,
Anchor_Anchored);
-
- package Anchor_ID_Vectors is new Ada.Containers.Vectors (Natural, Positive);
-
- type Indent_Type (Label : Indent_Label := Not_Set) is record
- -- Indent values may be negative while indents are being computed.
- case Label is
- when Not_Set =>
- null;
-
- when Int =>
- Int_Indent : Integer;
-
- when Anchor_Nil =>
- Anchor_Nil_IDs : Anchor_ID_Vectors.Vector; -- Largest ID first.
-
- when Anchor_Int =>
- Anchor_Int_IDs : Anchor_ID_Vectors.Vector; -- Largest ID first.
- Anchor_Int_Indent : Integer; -- Indent for this token.
-
- when Anchored =>
- Anchored_ID : Positive;
- Anchored_Delta : Integer; -- added to Anchor_Indent of Anchor_ID
-
- when Anchor_Anchored =>
- Anchor_Anchored_IDs : Anchor_ID_Vectors.Vector;
- Anchor_Anchored_ID : Natural;
- Anchor_Anchored_Delta : Integer;
- end case;
- end record;
- First_Anchor_ID : constant Positive := Positive'First;
-
- package Indent_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
- (WisiToken.Line_Number_Type, Indent_Type, Default_Element => (others =>
<>));
- package Navigate_Cursor_Lists is new Ada.Containers.Doubly_Linked_Lists
- (Navigate_Cache_Trees.Cursor, Navigate_Cache_Trees."=");
-
- type Parse_Data_Type
- (Terminals : not null access constant
WisiToken.Base_Token_Arrays.Vector;
- Line_Begin_Token : not null access constant
WisiToken.Line_Begin_Token_Vectors.Vector)
- is new WisiToken.Syntax_Trees.User_Data_Type with
- record
- -- Aux token info
- First_Comment_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
- Last_Comment_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
- Left_Paren_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
- Right_Paren_ID : WisiToken.Token_ID := WisiToken.Invalid_Token_ID;
-
- Embedded_Quote_Escape_Doubled : Boolean := False;
-
- -- Data from parsing
-
- -- All Augmented_Tokens are stored in the syntax tree.
- Last_Terminal_Node : WisiToken.Node_Index :=
WisiToken.Invalid_Node_Index;
-
- Leading_Non_Grammar : Non_Grammar_Token_Arrays.Vector;
- -- non-grammar tokens before first grammar token.
-
- Line_Begin_Char_Pos : Line_Begin_Pos_Vectors.Vector;
- -- Character position at the start of the first token on each line.
- -- Cached from Line_Begin_Token to simplify indent computations.
-
- Line_Paren_State : Line_Paren_Vectors.Vector;
- -- Parenthesis nesting state at the start of each line; used by
- -- Indent. Set by Lexer_To_Augmented on New_Line_ID, updated by
- -- Insert_Token, Delete_Token.
-
- Current_Paren_State : Integer;
- -- Current parenthesis nesting state; used by Indent. Set by
- -- Lexer_To_Augmented on Left_Paren_ID, Right_Paren_ID.
-
- -- Data for post-parse actions
-
- Lexer : WisiToken.Lexer.Handle;
- Descriptor : access constant WisiToken.Descriptor;
- Base_Terminals : WisiToken.Base_Token_Array_Access;
- Post_Parse_Action : Post_Parse_Action_Type;
- Navigate_Caches : Navigate_Cache_Trees.Tree; -- Set by Navigate.
- Name_Caches : Name_Cache_Trees.Tree; -- Set by Navigate.
- End_Positions : Navigate_Cursor_Lists.List; -- Dynamic data for
Navigate.
- Face_Caches : Face_Cache_Trees.Tree; -- Set by Face.
- Indents : Indent_Vectors.Vector; -- Set by Indent.
- Begin_Indent : Integer; -- Indentation of line
at start of parse.
-
- -- Copied from language-specific parameters
- Indent_Comment_Col_0 : Boolean := False;
-
- -- Dynamic data for Indent
- Max_Anchor_ID : Integer;
- end record;
-
- type Simple_Delta_Labels is (None, Int, Anchored);
-
- -- subtype Non_Anchored_Delta_Labels is Simple_Delta_Labels range None ..
Int;
-
- -- type Non_Anchored_Delta (Label : Non_Anchored_Delta_Labels := None) is
- -- record
- -- case Label is
- -- when None =>
- -- null;
- -- when Int =>
- -- Int_Delta : Integer;
- -- end case;
- -- end record;
-
- -- function Image (Item : in Non_Anchored_Delta) return String;
- -- For debugging
-
- type Simple_Delta_Type (Label : Simple_Delta_Labels := None) is
- record
- case Label is
- when None =>
- null;
-
- when Int =>
- Int_Delta : Integer;
-
- when Anchored =>
- Anchored_ID : Natural;
- Anchored_Delta : Integer;
- Anchored_Accumulate : Boolean;
-
- end case;
- end record;
-
- function Image (Item : in Simple_Delta_Type) return String;
- -- For debugging
-
- type Delta_Labels is (Simple, Hanging);
-
- type Delta_Type (Label : Delta_Labels := Simple) is
- record
- case Label is
- when Simple =>
- Simple_Delta : Simple_Delta_Type;
-
- when Hanging =>
- Hanging_First_Line : WisiToken.Line_Number_Type;
- Hanging_Paren_State : Integer;
- Hanging_Delta_1 : Simple_Delta_Type; -- indentation of first line
- Hanging_Delta_2 : Simple_Delta_Type; -- indentation of
continuation lines
- Hanging_Accumulate : Boolean;
- end case;
- end record;
-
- Null_Delta : constant Delta_Type := (Simple, (Label => None));
-
- function Image (Item : in Delta_Type) return String;
- -- For debugging
-
- ----------
- -- Utilities for language-specific child packages
-
- function Current_Indent_Offset
- (Data : in Parse_Data_Type;
- Anchor_Token : in Augmented_Token'Class;
- Offset : in Integer)
- return Integer;
- -- Return offset from beginning of first token on line containing
- -- Anchor_Token, to beginning of Anchor_Token, plus Offset.
-
- function Get_Aug_Token_Const_1
- (Tree : in WisiToken.Syntax_Trees.Tree'Class;
- Tree_Index : in WisiToken.Valid_Node_Index)
- return Aug_Token_Const_Ref;
- -- WORKAROUND: GNAT Community 2019 can't do the overload resolution
- -- between the two Get_Aug_Token_Const without an explicit renames,
- -- so we add _1 to this one.
-
- function Get_Aug_Token_Const
- (Data : in Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree'Class;
- Token : in WisiToken.Token_Index)
- return Aug_Token_Const_Ref;
-
- function Get_Aug_Token_Var
- (Tree : in WisiToken.Syntax_Trees.Tree'Class;
- Tree_Index : in WisiToken.Valid_Node_Index)
- return Aug_Token_Var_Ref;
-
- function Get_Aug_Token_Var
- (Data : in Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree'Class;
- Token : in WisiToken.Token_Index)
- return Aug_Token_Var_Ref;
-
- -- function Get_First_Terminal
- -- (Data : in Parse_Data_Type;
- -- Tree : in WisiToken.Syntax_Trees.Tree'Class;
- -- Token : in WisiToken.Token_Index)
- -- return Aug_Token_Const_Ref;
- -- Return Augmented for first Token.Inserted_Before, or if that is
- -- empty, for Token.
-
- function Get_Text
- (Data : in Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tree_Index : in WisiToken.Valid_Node_Index)
- return String;
- -- Return text contained by Tree_Index token in source file
- -- (lexer.buffer).
-
- function Elisp_Escape_Quotes (Item : in String) return String;
- -- Prefix any '"' in Item with '\' for elisp.
-
- function Indent_Anchored_2
- (Data : in out Parse_Data_Type;
- Anchor_Line : in WisiToken.Line_Number_Type;
- Last_Line : in WisiToken.Line_Number_Type;
- Offset : in Integer;
- Accumulate : in Boolean)
- return Delta_Type;
-
- function Indent_Compute_Delta
- (Data : in out Parse_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Param : in Indent_Param;
- Tree_Indenting : in WisiToken.Valid_Node_Index;
- Indenting_Comment : in Boolean)
- return Delta_Type;
-
- procedure Indent_Token_1
- (Data : in out Parse_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Indenting_Token : in Augmented_Token'Class;
- Delta_Indent : in Delta_Type;
- Indenting_Comment : in Boolean);
- -- Sets Data.Indents, so caller may not be in a renames for a
- -- Data.Indents element.
-
- -- Visible for language-specific children. Must match list in
- -- [3] wisi-process-parse--execute.
- Navigate_Cache_Code : constant String := "1";
- Face_Property_Code : constant String := "2";
- Indent_Code : constant String := "3";
- Lexer_Error_Code : constant String := "4";
- Parser_Error_Code : constant String := "5";
- Check_Error_Code : constant String := "6";
- Recover_Code : constant String := "7 ";
- End_Code : constant String := "8";
- Name_Property_Code : constant String := "9";
- Edit_Action_Code : constant String := "10";
- Language_Action_Code : constant String := "11 ";
-
-end Wisi;
diff --git a/packages/wisi/wisi.el b/packages/wisi/wisi.el
deleted file mode 100644
index a7b88ff..0000000
--- a/packages/wisi/wisi.el
+++ /dev/null
@@ -1,1725 +0,0 @@
-;;; wisi.el --- Utilities for implementing an indentation/navigation engine
using a generalized LALR parser -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2012 - 2020 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Keywords: parser
-;; indentation
-;; navigation
-;; Version: 3.1.3
-;; package-requires: ((emacs "25.0") (seq "2.20"))
-;; URL: http://stephe-leake.org/ada/wisitoken.html
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-;;
-
-;;; Commentary:
-
-;;;; History: see NEWS-wisi.text
-;;
-;;;; Design:
-;;
-;; 'wisi' was originally short for "wisent indentation engine", but
-;; now is just a name. wisi was developed to support Emacs ada-mode
-;; 5.0 indentation, font-lock, and navigation, which are parser based.
-;;
-;; The approach to indenting a given token is to parse the buffer,
-;; computing a delta indent at each parse action.
-;;
-;; The parser actions also cache face and navigation information
-;; as text properties on tokens in statements.
-;;
-;; The three reasons to run the parser (indent, face, navigate) occur
-;; at different times (user indent, font-lock, user navigate), so only
-;; the relevant parser actions are run.
-;;
-;; Parsing can be noticeably slow in large files, so sometimes we do a
-;; partial parse, and keep a list of parsed regions.
-;;
-;; Since we have a cache (the text properties), we need to consider
-;; when to invalidate it. Ideally, we invalidate only when a change
-;; to the buffer would change the result of a parse that crosses that
-;; change, or starts after that change. Changes in whitespace
-;; (indentation and newlines) do not affect an Ada parse. Other
-;; languages are sensitive to newlines (Bash for example) or
-;; indentation (Python). Adding comments does not change a parse,
-;; unless code is commented out.
-;;
-;; For navigate, we expect fully accurate results, and can tolerate
-;; one initial delay, so we always parse the entire file.
-;;
-;; For font-lock, we only parse the portion of the file requested by
-;; font-lock, so we keep a list of regions, and edit that list when
-;; the buffer is changed..
-;;
-;; For indenting, we expect fast results, and can tolerate some
-;; inaccuracy until the editing is done, so we allow partial parse. We
-;; cache the indent for each line in a text property on the newline
-;; char preceding the line. `wisi-indent-region' sets the cache on all
-;; the lines computed (part of the buffer in large files), but
-;; performs the indent only on the lines in the indent
-;; region. Subsequent calls to `wisi-indent-region' apply the cached
-;; indents. Non-whitespace edits to the buffer invalidate the indent
-;; caches in the edited region and after. Since we can do partial
-;; parse, we keep a list of parsed regions.
-;;
-;; See `wisi--post-change' for the details of what we check for
-;; invalidating.
-;;
-;;;; Choice of grammar compiler and parser
-;;
-;; There are two other parsing engines available in Emacs:
-;;
-;; - SMIE
-;;
-;; We don't use this because it is designed to parse small snippets
-;; of code. For Ada indentation, we always need to parse the entire
-;; buffer.
-;;
-;; - semantic
-;;
-;; The Ada grammar as given in the Ada language reference manual is
-;; not LALR(1). So we use a generalized parser. In addition, the
-;; semantic lexer is more complex, and gives different information
-;; than we need. Finally, the semantic parser does not support error
-;; correction, and thus fails in most editing situations.
-;;
-;; We use the WisiToken tool wisi-bnf-generate to compile BNF or EBNF
-;; to Ada source, See ada-mode.info and wisi.info for more information
-;; on the developer tools used for ada-mode and wisi.
-;;
-;;; Code:
-
-(require 'cl-lib)
-(require 'compile)
-(require 'seq)
-(require 'semantic/lex)
-(require 'wisi-parse-common)
-(require 'wisi-fringe)
-(require 'xref)
-
-(defcustom wisi-size-threshold most-positive-fixnum
- "Max size (in characters) for using wisi parser results for anything."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-(make-variable-buffer-local 'wisi-size-threshold)
-
-(defcustom wisi-indent-context-lines 0
- "Minimum number of lines before point to include in a parse for indent.
-Increasing this will give better results when in the middle of a
-deeply nested statement, but worse in some situations."
- :type 'integer
- :group 'wisi
- :safe 'integerp)
-
-(defcustom wisi-disable-face nil
- "When non-nil, `wisi-setup' does not enable use of parser for font-lock.
-Useful when debugging parser or parser actions."
- :type 'boolean
- :group 'wisi
- :safe 'booleanp)
-
-(defconst wisi-error-buffer-name "*wisi syntax errors*"
- "Name of buffer for displaying syntax errors.")
-
-(defvar wisi-error-buffer nil
- "Buffer for displaying syntax errors.")
-
-(defvar wisi-inhibit-parse nil
- "When non-nil, don't run the parser.
-Language code can set this non-nil when syntax is known to be
-invalid temporarily, or when making lots of changes.")
-
-(defun wisi-safe-marker-pos (pos)
- "Return an integer buffer position from POS, an integer or marker"
- (cond
- ((markerp pos)
- (marker-position pos))
-
- (t pos)))
-
-;;;; misc
-
-(defun wisi-in-paren-p (&optional parse-result)
- "Return t if point is inside a pair of parentheses.
-If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
- (> (nth 0 (or parse-result (syntax-ppss))) 0))
-
-(defun wisi-pos-in-paren-p (pos)
- "Return t if POS is inside a pair of parentheses."
- (save-excursion
- (> (nth 0 (syntax-ppss pos)) 0)))
-
-(defun wisi-same-paren-depth-p (pos1 pos2)
- "Return t if POS1 is at same parentheses depth as POS2."
- (= (nth 0 (syntax-ppss pos1)) (nth 0 (syntax-ppss pos2))))
-
-(defun wisi-goto-open-paren (&optional offset parse-result)
- "Move point to innermost opening paren surrounding current point, plus
OFFSET.
-Throw error if not in paren. If PARSE-RESULT is non-nil, use it
-instead of calling `syntax-ppss'."
- (goto-char (+ (or offset 0) (nth 1 (or parse-result (syntax-ppss))))))
-
-(defun wisi-in-comment-p (&optional parse-result)
- "Return t if inside a comment.
-If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
- (nth 4 (or parse-result (syntax-ppss))))
-
-(defun wisi-in-string-p (&optional parse-result)
- "Return t if point is inside a string.
-If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
- (nth 3 (or parse-result (syntax-ppss))))
-
-(defun wisi-in-string-or-comment-p (&optional parse-result)
- "Return t if inside a comment or string.
-If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
- (setq parse-result (or parse-result (syntax-ppss)))
- (or (wisi-in-string-p parse-result) (wisi-in-comment-p parse-result)))
-
-(defun wisi-indent-newline-indent ()
- "insert a newline, indent the old and new lines."
- (interactive "*")
- ;; point may be in the middle of a word, so insert newline first,
- ;; then go back and indent.
- (insert "\n")
- (forward-char -1)
- (funcall indent-line-function)
- (forward-char 1)
- (funcall indent-line-function))
-
-;;;; token info cache
-
-(defvar-local wisi-parse-failed nil
- "Non-nil when last parse failed - cleared when parse succeeds.")
-
-(defvar-local wisi--parse-try
- (list
- (cons 'face t)
- (cons 'navigate t)
- (cons 'indent t))
- "Non-nil when parse is needed because text has changed - cleared when parse
succeeds.")
-
-(defun wisi-parse-try (&optional parse-action)
- (cdr (assoc (or parse-action wisi--parse-action) wisi--parse-try)))
-
-(defun wisi-set-parse-try (value &optional parse-action)
- (setcdr (assoc (or parse-action wisi--parse-action) wisi--parse-try) value))
-
-(defvar-local wisi--last-parse-region
- (list
- (cons 'face nil)
- (cons 'navigate nil)
- (cons 'indent nil))
- "Last region on which parse was requested.")
-
-(defun wisi-last-parse-region (&optional parse-action)
- (cdr (assoc (or parse-action wisi--parse-action) wisi--last-parse-region)))
-
-(defun wisi-set-last-parse-region (begin end parse-action)
- (setcdr (assoc parse-action wisi--last-parse-region) (cons begin end)))
-
-(defvar-local wisi--cached-regions
- (list
- (cons 'face nil)
- (cons 'navigate nil)
- (cons 'indent nil))
- "Alist of lists of regions in buffer where parser text properties are valid.
-Regions in a list are in random order.")
-
-(defun wisi--contained-region (begin end region)
- "Non-nil if BEGIN and END (buffer positions) are both contained in REGION (a
cons of positions)."
- ;; We assume begin < end
- (and (<= (car region) begin)
- (<= end (cdr region))))
-
-(defun wisi--contained-pos (pos region)
- "Non-nil if POS (a buffer position) is contained in REGION (a cons of
positions)."
- (and (<= (car region) pos)
- (<= pos (cdr region))))
-
-(defun wisi-cache-covers-region (begin end &optional parse-action)
- "Non-nil if BEGIN END is contained in a parsed region."
- (let ((region-list (cdr (assoc (or parse-action wisi--parse-action)
wisi--cached-regions)))
- region)
- (while (and region-list
- (marker-buffer (caar region-list)) ;; this can fail after
editing during ediff-regions.
- (marker-buffer (cdar region-list))
- (not (wisi--contained-region begin end (car region-list))))
- (pop region-list))
-
- (when region-list
- ;; return a nice value for verbosity in wisi-validate-cache
- (setq region (car region-list))
- (cons (marker-position (car region)) (marker-position (cdr region))))))
-
-(defun wisi-cache-covers-pos (parse-action pos)
- "Non-nil if POS is contained in a PARSE-ACTION parsed region."
- (let ((region-list (cdr (assoc parse-action wisi--cached-regions))))
- (while (and region-list
- (not (wisi--contained-pos pos (car region-list))))
- (pop region-list))
-
- (when region-list
- t)))
-
-(defun wisi-cache-contains-pos (parse-action pos)
- "Non-nil if POS is at or before the end of any PARSE-ACTION parsed region."
- (let ((region-list (cdr (assoc parse-action wisi--cached-regions)))
- result)
- (while (and (not result) region-list)
- (when (<= pos (cdr (car region-list)))
- (setq result t))
- (pop region-list))
-
- result))
-
-(defun wisi-cache-set-region (region)
- "Set the cached region list for `wisi--parse-action' to REGION."
- (setcdr (assoc wisi--parse-action wisi--cached-regions)
- (list (cons (copy-marker (car region))
- (copy-marker (cdr region))))))
-
-(defun wisi-cache-add-region (region)
- "Add REGION to the cached region list for `wisi--parse-action'."
- (push (cons (copy-marker (car region))
- (copy-marker (cdr region)))
- (cdr (assoc wisi--parse-action wisi--cached-regions))))
-
-(defun wisi-cache-delete-regions-after (parse-action pos)
- "Delete any PARSE-ACTION parsed region at or after POS.
-Truncate any region that overlaps POS."
- (let ((region-list (cdr (assoc parse-action wisi--cached-regions)))
- result)
- (while (and (not result) region-list)
- (cond
- ((and (> pos (car (car region-list)))
- (<= pos (cdr (car region-list))))
- ;; region contains POS; keep truncated
- (push (cons (car (car region-list)) (copy-marker pos)) result))
-
- ((> pos (car (car region-list)))
- ;; region is entirely before POS; keep
- (push (car region-list) result))
-
- ;; else region is entirely after POS; delete
- )
-
- (pop region-list))
- (setcdr (assoc parse-action wisi--cached-regions) result)
- ))
-
-(defun wisi--delete-face-cache (after)
- (with-silent-modifications
- (remove-text-properties after (point-max) '(font-lock-face nil)))
- (if (= after (point-min))
- (setcdr (assoc 'face wisi--cached-regions) nil)
- (wisi-cache-delete-regions-after 'face after)))
-
-(defun wisi--delete-navigate-cache (after)
- (with-silent-modifications
- ;; This text property is 'wisi-cache', not 'wisi-navigate', for
- ;; historical reasons.
- (remove-text-properties after (point-max) '(wisi-cache nil wisi-name nil)))
- (if (= after (point-min))
- (setcdr (assoc 'navigate wisi--cached-regions) nil)
- (wisi-cache-delete-regions-after 'navigate after)))
-
-(defun wisi--delete-indent-cache (after)
- (with-silent-modifications
- (remove-text-properties after (point-max) '(wisi-indent nil)))
- (if (= after (point-min))
- (setcdr (assoc 'indent wisi--cached-regions) nil)
- (wisi-cache-delete-regions-after 'indent after)))
-
-(defun wisi-invalidate-cache (action after)
- "Invalidate ACTION caches for the current buffer from AFTER to end of
buffer."
- (cond
- ((= after (point-min))
- (cond
- ((eq 'face action)
- (wisi--delete-face-cache after))
-
- ((eq 'navigate action)
- (wisi--delete-navigate-cache after))
-
- ((eq 'indent action)
- (wisi--delete-indent-cache after))
- ))
-
- ((wisi-cache-contains-pos action after)
- (when (> wisi-debug 0) (message "wisi-invalidate-cache %s:%s:%d" action
(current-buffer) after))
- (cond
- ((eq 'face action)
- (wisi--delete-face-cache after))
-
- ((eq 'navigate action)
- (when (wisi-cache-covers-pos 'navigate after)
- ;; We goto statement start to ensure that motion within nested
- ;; structures is properly done (ie prev/next on ’elsif’ is not
- ;; set by wisi-motion-action if already set by a lower level
- ;; statement). We don’t do it for ’face or ’indent, because that
- ;; might require a parse, and they don’t care about nested
- ;; structures.
- (save-excursion
- (goto-char after)
-
- ;; This is copied from ‘wisi-goto-statement-start’; we can’t
- ;; call that because it would call ‘wisi-validate-cache’,
- ;; which would call ‘wisi-invalidate-cache’; infinite loop.
- ;; If this needed a navigate parse to succeed, we would not
- ;; get here.
- (let ((cache (or (wisi-get-cache (point))
- (wisi-backward-cache))))
- (cond
- ((null cache)
- ;; at bob
- nil)
-
- ((eq 'statement-end (wisi-cache-class cache))
- ;; If the change did affect part of a structure statement,
- ;; this is a lower level statement. Otherwise, we are
- ;; invalidating more than necessary; not a problem.
- (wisi-goto-start cache)
- (setq cache (wisi-backward-cache))
- (when cache ;; else bob
- (wisi-goto-start cache)))
-
- (t
- (wisi-goto-start cache))
- ))
-
- (setq after (point))))
- (wisi--delete-navigate-cache after))
-
- ((eq 'indent action)
- ;; The indent cache is stored on newline before line being
- ;; indented. We delete that, because changing text on a line can
- ;; change the indent of that line.
- (setq after
- (save-excursion
- (goto-char after)
- (line-beginning-position)))
- (wisi--delete-indent-cache (max 1 (1- after))))
- )
- )))
-
-(defun wisi-reset-parser ()
- "Force a parse."
- (interactive)
- (syntax-ppss-flush-cache (point-min)) ;; necessary after edit during
ediff-regions
- (setq wisi--cached-regions ;; necessary instead of wisi-invalidate after
ediff-regions
- (list
- (cons 'face nil)
- (cons 'navigate nil)
- (cons 'indent nil)))
- (wisi-set-parse-try t 'indent)
- (wisi-set-parse-try t 'face)
- (wisi-set-parse-try t 'navigate)
- (wisi-set-last-parse-region (point-min) (point-min) 'indent)
- (wisi-set-last-parse-region (point-min) (point-min) 'face)
- (wisi-set-last-parse-region (point-min) (point-min) 'navigate)
- (wisi-fringe-clean))
-
-;; wisi--change-* keep track of buffer modifications.
-;; If wisi--change-end comes before wisi--change-beg, it means there were
-;; no modifications.
-(defvar-local wisi--change-beg most-positive-fixnum
- "First position where a change may have taken place.")
-
-(defvar-local wisi--change-end nil
- "Marker pointing to the last position where a change may have taken place.")
-
-(defvar-local wisi--deleted-syntax nil
- "Worst syntax class of characters deleted in changes.
-One of:
-nil - no deletions since reset
-0 - only whitespace or comment deleted
-2 - some other syntax deleted
-
-Set by `wisi-before-change', used and reset by `wisi--post-change'.")
-
-(defvar-local wisi-indenting-p nil
- "Non-nil when `wisi-indent-region' is actively indenting.
-Used to ignore whitespace changes in before/after change hooks.")
-
-(defvar-local wisi--last-parse-action nil
- "Value of `wisi--parse-action' when `wisi-validate-cache' was last run.")
-
-(defun wisi-before-change (begin end)
- "For `before-change-functions'."
- ;; begin . (1- end) is range of text being deleted
- (unless wisi-indenting-p
- ;; We set wisi--change-beg, -end even if only inserting, so we
- ;; don't have to do it again in wisi-after-change.
- (setq wisi--change-beg (min wisi--change-beg begin))
-
- ;; `buffer-base-buffer' deals with edits in indirect buffers
- ;; created by ediff-regions-*
-
- (cond
- ((null wisi--change-end)
- (setq wisi--change-end (make-marker))
- (set-marker wisi--change-end end (or (buffer-base-buffer)
(current-buffer))))
-
- ((> end wisi--change-end)
- (set-marker wisi--change-end end (or (buffer-base-buffer)
(current-buffer))))
- )
-
- (unless (= begin end)
- (cond
- ((or (null wisi--deleted-syntax)
- (= 0 wisi--deleted-syntax))
- (save-excursion
- (if (or (nth 4 (syntax-ppss begin)) ; in comment, moves point to begin
- (= end (skip-syntax-forward " " end)));; whitespace
- (setq wisi--deleted-syntax 0)
- (setq wisi--deleted-syntax 2))))
-
- (t
- ;; wisi--deleted-syntax is 2; no change.
- )
- ))))
-
-(defun wisi-after-change (begin end _length)
- "For `after-change-functions'"
- ;; begin . end is range of text being inserted (empty if equal);
- ;; length is the size of the deleted text.
-
- ;; Remove caches on inserted text, which could have caches from
- ;; anywhere, and are in any case invalid.
-
- ;; If the insertion changes a word that has wisi fontification,
- ;; remove fontification from the entire word, so it is all
- ;; refontified consistently.
-
- (let (word-begin word-end)
- (save-excursion
- (goto-char end)
- (skip-syntax-forward "w_")
- (setq word-end (point))
- (goto-char begin)
- (skip-syntax-backward "w_")
- (setq word-begin (point)))
- (if (get-text-property word-begin 'font-lock-face)
- (with-silent-modifications
- (remove-text-properties
- word-begin word-end
- '(font-lock-face nil wisi-cache nil wisi-indent nil fontified nil)))
-
- ;; No point in removing
- ;; 'fontified here; that's already handled by jit-lock.
- (with-silent-modifications
- (remove-text-properties
- begin end
- '(font-lock-face nil wisi-cache nil wisi-indent nil))))
- ))
-
-(defun wisi--post-change (begin end)
- "Update wisi text properties for changes in region BEG END."
- ;; (syntax-ppss-flush-cache begin) is in before-change-functions
-
- (save-excursion
- (let ((need-invalidate t)
- (done nil)
- ;; non-nil if require a parse because the syntax may have
- ;; changed.
-
- (begin-state (syntax-ppss begin))
- (end-state (syntax-ppss end)))
- ;; (info "(elisp)Parser State")
- ;; syntax-ppss has moved point to "end"; might be eob.
-
- ;; consider deletion
- (cond
- ((null wisi--deleted-syntax)
- ;; no deletions
- )
-
- ((= 0 wisi--deleted-syntax)
- ;; Only deleted whitespace; may have joined two words
- (when
- (and (= begin end) ;; no insertions
- (or
- (= (point-min) begin)
- (= 0 (syntax-class (syntax-after (1- begin))))
- (= (point-max) end)
- (= 0 (syntax-class (syntax-after end)))))
- ;; More whitespace on at least one side of deletion; did not
- ;; join two words.
- (setq need-invalidate nil)
- (setq done t)
- ))
-
- (t
- ;; wisi--deleted-syntax is 2; need invalidate and parse for all
- ;; parse actions
- (setq done t)
- ))
-
- (setq wisi--deleted-syntax nil)
-
- (unless done
- ;; consider insertion
- (cond
- ((= begin end)
- ;; no insertions
- nil)
-
- ((and
- (nth 3 begin-state);; in string
- (nth 3 end-state)
- (= (nth 8 begin-state) (nth 8 end-state)));; no intervening
non-string
- (setq need-invalidate nil))
-
- ((and
- (nth 4 begin-state) ;; in comment
- (nth 4 end-state)
- (= (nth 8 begin-state) (nth 8 end-state))) ;; no intervening
non-comment
-
- (if (and
- (= 11 (car (syntax-after begin)))
- (progn (goto-char begin)
- (skip-syntax-backward "<")
- (not (= (point) begin))))
-
- ;; Either inserted last char of a multi-char comment
- ;; start, or inserted extra comment-start chars.
- (setq need-invalidate begin)
- (setq need-invalidate nil)))
-
- ((and
- (or
- (= (point-min) begin)
- (= 0 (syntax-class (syntax-after (1- begin)))); whitespace
- (= (point-max) end)
- (= 0 (syntax-class (syntax-after end))))
- (progn
- (goto-char begin)
- (= (- end begin) (skip-syntax-forward " " end))
- ))
- ;; Inserted only whitespace, there is more whitespace on at
- ;; least one side, and we are not in a comment or string
- ;; (checked above). This may affect indentation, but not
- ;; the indentation cache.
- (setq need-invalidate nil))
- ))
-
- (when need-invalidate
- (wisi-set-parse-try t 'face)
- (wisi-set-parse-try t 'navigate)
- (wisi-set-parse-try t 'indent)
-
- (wisi-invalidate-cache 'face begin)
- (wisi-invalidate-cache 'navigate begin)
- (wisi-invalidate-cache 'indent begin))
- )))
-
-(defun wisi-goto-error ()
- "Move point to position in last error message (if any)."
- (cond
- ((wisi-parser-parse-errors wisi--parser)
- (let ((data (car (wisi-parser-parse-errors wisi--parser))))
- (cond
- ((wisi--parse-error-pos data)
- (push-mark)
- (goto-char (wisi--parse-error-pos data)))
-
- ((string-match ":\\([0-9]+\\):\\([0-9]+\\):" (wisi--parse-error-message
data))
- (let* ((msg (wisi--parse-error-message data))
- (line (string-to-number (match-string 1 msg)))
- (col (string-to-number (match-string 2 msg))))
- (push-mark)
- (goto-char (point-min))
- (condition-case nil
- (progn
- ;; line can be wrong if parser screws up, or user edits buffer
- (forward-line (1- line))
- (forward-char col))
- (error
- ;; just stay at eob.
- nil))))
- )))
- ((wisi-parser-lexer-errors wisi--parser)
- (push-mark)
- (goto-char (wisi--lexer-error-pos (car (wisi-parser-lexer-errors
wisi--parser)))))
- ))
-
-(defun wisi-show-parse-error ()
- "Show current wisi-parse errors."
- (interactive)
- (cond
- ((or (wisi-parser-lexer-errors wisi--parser)
- (wisi-parser-parse-errors wisi--parser))
- (if (and (= 1 (+ (length (wisi-parser-lexer-errors wisi--parser))
- (length (wisi-parser-parse-errors wisi--parser))))
- (or (and (wisi-parser-parse-errors wisi--parser)
- (not (wisi--parse-error-repair (car
(wisi-parser-parse-errors wisi--parser)))))
- (and (wisi-parser-lexer-errors wisi--parser)
- (not (wisi--lexer-error-inserted (car
(wisi-parser-lexer-errors wisi--parser)))))))
- ;; There is exactly one error; if there is error correction
- ;; information, use a ’compilation’ buffer, so
- ;; *-fix-compiler-error will call
- ;; wisi-repair-error. Otherwise, just position cursor at
- ;; error.
- (progn
- (wisi-goto-error)
- (message (or (and (wisi-parser-parse-errors wisi--parser)
- (wisi--parse-error-message (car
(wisi-parser-parse-errors wisi--parser))))
- (and (wisi-parser-lexer-errors wisi--parser)
- (wisi--lexer-error-message (car
(wisi-parser-lexer-errors wisi--parser)))))
- ))
-
- ;; else show all errors in a ’compilation’ buffer
- (setq wisi-error-buffer (get-buffer-create wisi-error-buffer-name))
-
- (let ((lexer-errs (sort (cl-copy-seq (wisi-parser-lexer-errors
wisi--parser))
- (lambda (a b) (< (wisi--parse-error-pos a)
(wisi--parse-error-pos b)))))
- (parse-errs (sort (cl-copy-seq (wisi-parser-parse-errors
wisi--parser))
- (lambda (a b) (< (wisi--parse-error-pos a)
(wisi--parse-error-pos b)))))
- (dir default-directory))
- (with-current-buffer wisi-error-buffer
- (setq window-size-fixed nil)
- (compilation-mode)
- (setq-local compilation-search-path (list dir))
- (setq default-directory dir)
- (setq next-error-last-buffer (current-buffer))
- (setq buffer-read-only nil)
- (erase-buffer)
- ;; compilation-nex-error-function assumes there is not an
- ;; error at point-min, so we need a comment.
- (insert "wisi syntax errors")
- (newline)
- (dolist (err lexer-errs)
- (insert (wisi--lexer-error-message err))
- (put-text-property (line-beginning-position) (1+
(line-beginning-position)) 'wisi-error-data err)
- (newline 2))
- (dolist (err parse-errs)
- (insert (wisi--parse-error-message err))
- (put-text-property (line-beginning-position) (1+
(line-beginning-position)) 'wisi-error-data err)
- (newline 2))
- (compilation--flush-parse (point-min) (point-max))
- (compilation--ensure-parse (point-max))
- (when compilation-filter-hook
- (let ((compilation-filter-start (point-min)))
- (run-hooks 'compilation-filter-hook)))
-
- (setq buffer-read-only t)
- (goto-char (point-min)))
-
- (let ((win (display-buffer
- wisi-error-buffer
- (cons #'display-buffer-at-bottom
- (list (cons 'window-height
#'shrink-window-if-larger-than-buffer))))))
- (set-window-dedicated-p win t))
-
- (with-current-buffer wisi-error-buffer
- (setq window-size-fixed t))
- (next-error))
- ))
-
- ((wisi-parse-try wisi--last-parse-action)
- (message "need parse"))
-
- (t
- (message "parse succeeded"))
- ))
-
-(defun wisi-kill-parser ()
- "Kill the background process running the parser for the current buffer.
-Usefull if the parser appears to be hung."
- (interactive)
- (wisi-parse-kill wisi--parser)
- ;; also force re-parse
- (wisi-reset-parser)
- )
-
-(defun wisi-partial-parse-p (begin end)
- (and (wisi-process--parser-p wisi--parser)
- (not (and (= begin (point-min))
- (= end (point-max))))
- (>= (point-max) wisi-partial-parse-threshold)))
-
-(defun wisi--run-parse (begin parse-end)
- "Run the parser, on at least region BEGIN PARSE-END."
- (unless (or (buffer-narrowed-p)
- (= (point-min) (point-max))) ;; some parsers can’t handle an
empty buffer.
- (let* ((partial-parse-p (wisi-partial-parse-p begin parse-end))
- (msg (when (> wisi-debug 0)
- (format "wisi: %sparsing %s %s:%d %d %d ..."
- (if partial-parse-p "partial " "")
- wisi--parse-action
- (buffer-name)
- begin
- (if (markerp parse-end) (marker-position parse-end)
parse-end)
- (line-number-at-pos begin))))
- (parsed-region nil))
-
- (when msg
- (message msg))
-
- (setq wisi--last-parse-action wisi--parse-action)
- (wisi-set-last-parse-region begin parse-end wisi--parse-action)
-
- (unless (eq wisi--parse-action 'face)
- (when (buffer-live-p wisi-error-buffer)
- (with-current-buffer wisi-error-buffer
- (setq buffer-read-only nil)
- (erase-buffer)
- (setq buffer-read-only t)
- (when (get-buffer-window wisi-error-buffer)
- (delete-window (get-buffer-window wisi-error-buffer))))))
-
- (condition-case-unless-debug err
- (save-excursion
- (if partial-parse-p
- (let ((send-region (wisi-parse-expand-region wisi--parser begin
parse-end)))
- (setq parsed-region (wisi-parse-current wisi--parser (car
send-region) (cdr send-region) parse-end))
- (wisi-cache-add-region parsed-region))
-
- ;; parse full buffer
- (setq parsed-region (cons (point-min) (point-max)))
- (wisi-cache-set-region (wisi-parse-current wisi--parser
(point-min) (point-max) (point-max))))
-
- (when (> wisi-debug 0) (message "... parsed %s" parsed-region))
- (setq wisi-parse-failed nil))
- (wisi-parse-error
- (cl-ecase wisi--parse-action
- (face
- ;; Caches set by failed elisp parse are ok, but some parse
- ;; failures return 'nil' in parse-region.
- (when (cdr parsed-region)
- (wisi--delete-face-cache (cdr parsed-region))))
-
- (navigate
- ;; elisp parse partially resets caches
- (wisi--delete-navigate-cache (point-min)))
-
- (indent
- ;; parse does not set caches; see `wisi-indent-region'
- nil))
- (setq wisi-parse-failed t)
- ;; parser should have stored this error message in parser-error-msgs
- (when (> wisi-debug 0)
- (signal (car err) (cdr err)))
- )
- (error
- ;; parser failed for other reason
- (setq wisi-parse-failed t)
- (signal (car err) (cdr err)))
- )
-
- (unless partial-parse-p
- (wisi-fringe-display-errors
- (append
- (seq-map (lambda (err) (wisi--lexer-error-pos err))
(wisi-parser-lexer-errors wisi--parser))
- (seq-map (lambda (err) (wisi--parse-error-pos err))
(wisi-parser-parse-errors wisi--parser)))))
-
- (when (> wisi-debug 1)
- (if (or (wisi-parser-lexer-errors wisi--parser)
- (wisi-parser-parse-errors wisi--parser))
- (progn
- (message "%s error" msg)
- (wisi-goto-error)
- (error (or (and (wisi-parser-lexer-errors wisi--parser)
- (wisi--lexer-error-message (car
(wisi-parser-lexer-errors wisi--parser))))
- (and (wisi-parser-parse-errors wisi--parser)
- (wisi--parse-error-message (car
(wisi-parser-parse-errors wisi--parser))))
- )))
-
- ;; no error
- (message "%s done" msg))
- ))))
-
-(defun wisi--check-change ()
- "Process `wisi--change-beg', `wisi--change-end'.
-`wisi--parse-action' must be bound."
- (when (and wisi--change-beg
- wisi--change-end
- (or (integerp wisi--change-beg)
- (marker-buffer wisi--change-beg)) ;; this can fail after
editing during ediff-regions.
- (or (integerp wisi--change-end)
- (marker-buffer wisi--change-end))
- (<= wisi--change-beg wisi--change-end))
- (wisi--post-change wisi--change-beg (marker-position wisi--change-end))
- (setq wisi--change-beg most-positive-fixnum)
- (move-marker wisi--change-end (point-min))
- ))
-
-(defun wisi-validate-cache (begin end error-on-fail parse-action)
- "Ensure cached data for PARSE-ACTION is valid in region BEGIN END in current
buffer."
- (if (and (not wisi-inhibit-parse)
- (< (point-max) wisi-size-threshold))
- (let ((wisi--parse-action parse-action))
- (wisi--check-change)
-
- ;; Now we can rely on wisi-cache-covers-region.
- ;;
- ;; If the last parse failed but was partial, and we are trying
- ;; a different region, it may succeed. Otherwise, don't keep
- ;; retrying a failed parse until the text changes again.
- (cond
- ((and (not wisi-parse-failed)
- (wisi-cache-covers-region begin end))
- (when (> wisi-debug 0)
- (message "parse %s skipped: cache-covers-region %s %s.%s"
- parse-action
- (wisi-cache-covers-region begin end)
- begin end)))
-
- ((and wisi-parse-failed
- (equal (cons begin end) (wisi-last-parse-region parse-action))
- (not (wisi-parse-try parse-action)))
- (when (> wisi-debug 0)
- (message "parse %s skipped: parse-failed" parse-action)))
-
- (t
- (progn
- (wisi-set-parse-try nil)
- (wisi--run-parse begin end))))
-
- ;; We want this error even if we did not try to parse; it means
- ;; the parse results are not valid.
- (when (and error-on-fail wisi-parse-failed)
- (error "parse %s failed" parse-action))
- )
- (when (> wisi-debug 0)
- (message "parse %s skipped inihibit-parse %s wisi-size-threshold %d"
- parse-action
- wisi-inhibit-parse
- wisi-size-threshold))))
-
-(defun wisi-fontify-region (begin end)
- "For `jit-lock-functions'."
- (wisi-validate-cache begin end nil 'face))
-
-(defun wisi-get-containing-cache (cache)
- "Return cache from (wisi-cache-containing CACHE)."
- (when cache
- (let ((containing (wisi-cache-containing cache)))
- (and containing
- (wisi-get-cache containing)))))
-
-(defun wisi-cache-text (cache)
- "Return property-less buffer substring designated by cache.
-Point must be at cache."
- (buffer-substring-no-properties (point) (+ (point) (wisi-cache-last cache))))
-
-;;;; navigation
-
-(defun wisi-forward-find-class (class limit)
- "Search at point or forward for a token that has a cache with CLASS.
-Return cache, or nil if at end of buffer.
-If LIMIT (a buffer position) is reached, throw an error."
- (let ((cache (or (wisi-get-cache (point))
- (wisi-forward-cache))))
- (while (not (eq class (wisi-cache-class cache)))
- (setq cache (wisi-forward-cache))
- (when (>= (point) limit)
- (error "cache with class %s not found" class)))
- cache))
-
-(defun wisi-forward-find-cache-token (ids limit)
- "Search forward for a cache with token in IDS (a list of token ids).
-Return cache, or nil if at LIMIT or end of buffer."
- (let ((cache (wisi-forward-cache)))
- (while (and (< (point) limit)
- (not (eobp))
- (not (memq (wisi-cache-token cache) ids)))
- (setq cache (wisi-forward-cache)))
- cache))
-
-(defun wisi-forward-find-nonterm (nonterm limit)
- "Search forward for a token that has a cache with NONTERM.
-NONTERM may be a list; stop on any cache that has a member of the list.
-Return cache, or nil if at end of buffer.
-If LIMIT (a buffer position) is reached, throw an error."
- (let ((nonterm-list (cond
- ((listp nonterm) nonterm)
- (t (list nonterm))))
- (cache (wisi-forward-cache)))
- (while (not (memq (wisi-cache-nonterm cache) nonterm-list))
- (setq cache (wisi-forward-cache))
- (when (>= (point) limit)
- (error "cache with nonterm %s not found" nonterm)))
- cache))
-
-(defun wisi-goto-cache-next (cache)
- (goto-char (wisi-cache-next cache))
- (wisi-get-cache (point))
- )
-
-(defun wisi-forward-statement-keyword ()
- "If not at a cached token, move forward to next
-cache. Otherwise move to cache-next, or cache-end, or next cache
-if both nil. Return cache found."
- (unless (eobp)
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (let ((cache (wisi-get-cache (point))))
- (if (and cache
- (not (eq (wisi-cache-class cache) 'statement-end)))
- (let ((next (or (wisi-cache-next cache)
- (wisi-cache-end cache))))
- (if next
- (goto-char next)
- (wisi-forward-cache)))
- (wisi-forward-cache))
- )
- (wisi-get-cache (point))
- ))
-
-(defun wisi-backward-statement-keyword ()
- "If not at a cached token, move backward to prev
-cache. Otherwise move to cache-prev, or prev cache if nil."
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (let ((cache (wisi-get-cache (point)))
- prev)
- (when cache
- (setq prev (wisi-cache-prev cache))
- (unless prev
- (unless (eq 'statement-start (wisi-cache-class cache))
- (setq prev (wisi-cache-containing cache)))))
- (if prev
- (goto-char prev)
- (wisi-backward-cache))
- ))
-
-(defun wisi-forward-sexp (&optional arg)
- "For `forward-sexp-function'."
- (interactive "^p")
- (or arg (setq arg 1))
- (cond
- ((and (> arg 0) (= 4 (syntax-class (syntax-after (point))))) ;; on open
paren
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- ((and (< arg 0) (= 5 (syntax-class (syntax-after (1- (point)))))) ;; after
close paren
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- ((and (> arg 0) (= 7 (syntax-class (syntax-after (point))))) ;; on (open)
string quote
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- ((and (< arg 0) (= 7 (syntax-class (syntax-after (1- (point)))))) ;; after
(close) string quote
- (let ((forward-sexp-function nil))
- (forward-sexp arg)))
-
- (t
- (dotimes (_i (abs arg))
- (if (> arg 0)
- (wisi-forward-statement-keyword)
- (wisi-backward-statement-keyword))))
- ))
-
-(defun wisi-goto-containing (cache &optional error)
- "Move point to containing token for CACHE, return cache at that point.
-If ERROR, throw error when CACHE has no container; else return nil."
- (cond
- ((and (markerp (wisi-cache-containing cache))
-
- (not (= (wisi-cache-containing cache) (point))))
- ;; This check is only needed if some cache points to itself as a
- ;; container. Apparently that happend once that I caught in the
- ;; debugger; emacs hung because we got here in the font-lock
- ;; timer.
-
- (goto-char (wisi-cache-containing cache))
- (wisi-get-cache (point)))
- (t
- (when error
- (error "already at outermost containing token")))
- ))
-
-(defun wisi-goto-containing-paren (cache)
- "Move point to just after the open-paren containing CACHE.
-Return cache for paren, or nil if no containing paren."
- (while (and cache
- (not (eq (wisi-cache-class cache) 'open-paren)))
- (setq cache (wisi-goto-containing cache)))
- (when cache
- (forward-char 1))
- cache)
-
-(defun wisi-goto-start (cache)
- "Move point to containing ancestor of CACHE that has class statement-start.
-Return start cache."
- ;; cache nil at bob, or on cache in partially parsed statement
- (while (and cache
- (not (eq (wisi-cache-class cache) 'statement-start)))
- (setq cache (wisi-goto-containing cache)))
- cache)
-
-(defun wisi-goto-end-1 (cache)
- (goto-char (wisi-cache-end cache)))
-
-(defun wisi-goto-statement-start ()
- "Move point to token at start of statement point is in or after.
-Return start cache."
- (interactive)
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (wisi-goto-start (or (wisi-get-cache (point))
- (wisi-backward-cache))))
-
-(defun wisi-goto-statement-end ()
- "Move point to token at end of statement point is in or before."
- (interactive)
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (let ((cache (or (wisi-get-cache (point))
- (wisi-forward-cache))))
- (when (wisi-cache-end cache)
- ;; nil when cache is statement-end
- (wisi-goto-end-1 cache))
- ))
-
-(defun wisi-goto-containing-statement-start ()
- "Move point to the start of the statement containing the current statement."
- (interactive)
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (let ((cache (or (wisi-get-cache (point))
- (wisi-backward-cache))))
- (when cache
- (setq cache (wisi-goto-start cache)))
- (when cache
- (setq cache (wisi-goto-containing cache nil)))
- ))
-
-(defun wisi-next-statement-cache (cache)
- "Move point to CACHE-next, return cache; error if nil."
- (when (not (markerp (wisi-cache-next cache)))
- (error "no next statement cache"))
- (goto-char (wisi-cache-next cache))
- (wisi-get-cache (point)))
-
-(defun wisi-prev-statement-cache (cache)
- "Move point to CACHE-prev, return cache; error if nil."
- (when (not (markerp (wisi-cache-prev cache)))
- (error "no prev statement cache"))
- (goto-char (wisi-cache-prev cache))
- (wisi-get-cache (point)))
-
-;;;; indentation
-
-(defun wisi-comment-indent ()
- "For `comment-indent-function'. Indent single line comment to
-the comment on the previous line."
- ;; Called from `comment-indent', either to insert a new comment, or
- ;; to indent the first line of an existing one. In either case, the
- ;; comment may be after code on the same line. For an existing
- ;; comment, point is at the start of the starting delimiter.
- (or
- (save-excursion
- ;; Check for a preceding comment line; fail if comment follows code.
- (when (forward-comment -1)
- ;; For the case:
- ;;
- ;; code;-- comment
- ;;
- ;; point is on '--', and 'forward-comment' does not move point,
- ;; returns nil.
- (when (looking-at comment-start)
- (current-column))))
-
- (save-excursion
- (back-to-indentation)
- (if (looking-at comment-start)
- ;; An existing comment, no code preceding comment, and
- ;; no comment on preceding line. Return nil, so
- ;; `comment-indent' will call `indent-according-to-mode'
- nil
-
- ;; A comment after code on the same line.
- comment-column))
- ))
-
-(defun wisi-indent-statement ()
- "Indent region given by `wisi-goto-start', `wisi-cache-end'."
- (interactive)
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
-
- (save-excursion
- (let ((cache (or (wisi-get-cache (point))
- (wisi-backward-cache))))
- (when cache
- ;; can be nil if in header comment
- (let ((start (progn (wisi-goto-start cache) (point)))
- (end (if (wisi-cache-end cache)
- ;; nil when cache is statement-end
- (wisi-cache-end cache)
- (point))))
- (indent-region start end)
- ))
- )))
-
-(defun wisi-indent-containing-statement ()
- "Indent region given by `wisi-goto-containing-statement-start',
`wisi-cache-end'."
- (interactive)
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
-
- (save-excursion
- (let ((cache (or (wisi-get-cache (point))
- (wisi-backward-cache))))
- (when cache
- ;; can be nil if in header comment
- (let ((start (progn
- (setq cache (wisi-goto-containing (wisi-goto-start
cache)))
- (point)))
- (end (if (wisi-cache-end cache)
- ;; nil when cache is statement-end
- (wisi-cache-end cache)
- (point))))
- (indent-region start end)
- ))
- )))
-
-(defvar-local wisi-indent-calculate-functions nil
- "Functions to compute indentation special cases.
-Called with point at current indentation of a line; return
-indentation column, or nil if function does not know how to
-indent that line. Run after parser indentation, so other lines
-are indented correctly.")
-
-(defvar-local wisi-post-indent-fail-hook
- "Function to reindent portion of buffer.
-Called from `wisi-indent-region' when a parse succeeds after
-failing; assumes user was editing code that is now syntactically
-correct. Must leave point at indentation of current line.")
-
-(defvar-local wisi-indent-failed nil
- "Non-nil when wisi-indent-region fails due to parse failing; cleared when
indent succeeds.")
-
-(defvar-local wisi-indent-region-fallback 'wisi-indent-region-fallback-default
- "Function to compute indent for lines in region when wisi parse fails.
-Called with BEGIN END.")
-
-(defun wisi-indent-region-fallback-default (begin end)
- ;; Assume there is no indent info at point; user is editing. Indent
- ;; to previous lines.
- (goto-char begin)
- (forward-line -1);; safe at bob
- (back-to-indentation)
- (let ((col (current-column)))
- (while (and (not (eobp))
- (< (point) end))
- (if (= 1 (forward-line 1))
- (indent-line-to col)
- ;; on last line of buffer; terminate loop
- (goto-char (point-max)))
- (when (bobp)
- ;; single line in buffer; terminate loop
- (goto-char (point-max))))))
-
-(defun wisi-list-memq (a b)
- "Return non-nil if any member of A is a memq of B."
- (let ((temp (copy-sequence a))
- result)
- (while (and (not result)
- temp)
- (when (memq (pop temp) b)
- (setq result t)))
- result))
-
-(defun wisi--get-cached-indent (begin end)
- "Return cached indent for point (must be bol), after correcting
-for parse errors. BEGIN, END is the parsed region."
- (let ((indent (get-text-property (1- (point)) 'wisi-indent)))
- (if indent
- (when (and (wisi-partial-parse-p begin end)
- (< 0 (length (wisi-parser-parse-errors wisi--parser))))
- (dolist (err (wisi-parser-parse-errors wisi--parser))
- (dolist (repair (wisi--parse-error-repair err))
- ;; point is at bol; error pos may be at first token on same line.
- (save-excursion
- (back-to-indentation)
- (when (>= (point) (wisi--parse-error-repair-pos repair))
- (setq indent (max 0 (wisi-parse-adjust-indent wisi--parser
indent repair))))
- ))))
- ;; parse did not compute indent for point. Assume the error will
- ;; go away soon as the user edits the code, so just return 0.
- (if (= wisi-debug 0)
- (setq indent 0)
- (error "nil indent for line %d" (line-number-at-pos (point)))))
-
- indent))
-
-(defun wisi-indent-region (begin end &optional indent-blank-lines)
- "For `indent-region-function', using the wisi indentation engine.
-If INDENT-BLANK-LINES is non-nil, also indent blank lines (for use as
-`indent-line-function')."
- (if wisi-inhibit-parse
- (when (< 0 wisi-debug)
- (message "wisi-indent-region %d %d skipped; wisi-inhibit-parse"
- (wisi-safe-marker-pos begin)
- (wisi-safe-marker-pos end)))
-
- (let ((wisi--parse-action 'indent)
- (parse-required nil)
- (end-mark (copy-marker end))
- (prev-indent-failed wisi-indent-failed))
-
- (when (< 0 wisi-debug)
- (message "wisi-indent-region %d %d"
- (wisi-safe-marker-pos begin)
- (wisi-safe-marker-pos end)))
-
- (wisi--check-change)
-
- ;; BEGIN is inclusive; END is exclusive.
- (save-excursion
- (goto-char begin)
- (setq begin (line-beginning-position))
-
- (when (bobp) (forward-line))
- (while (and (not parse-required)
- (or (and (= begin end) (= (point) end))
- (< (point) end))
- (not (eobp)))
- (unless (get-text-property (1- (point)) 'wisi-indent)
- (setq parse-required t))
- (forward-line))
- )
-
- ;; A parse either succeeds and sets the indent cache on all
- ;; lines in the parsed region, or fails and leaves valid caches
- ;; untouched.
- (when (and parse-required
- (or (not wisi-parse-failed)
- (wisi-parse-try 'indent)))
-
- (wisi-set-parse-try nil)
- (wisi--run-parse begin end)
-
- ;; If there were errors corrected, the indentation is
- ;; potentially ambiguous; see
- ;; test/ada_mode-interactive_2.adb. Or it was a partial parse,
- ;; where errors producing bad indent are pretty much expected.
- (unless (wisi-partial-parse-p begin end)
- (setq wisi-indent-failed (< 0 (+ (length (wisi-parser-lexer-errors
wisi--parser))
- (length (wisi-parser-parse-errors
wisi--parser))))))
- )
-
- (if wisi-parse-failed
- (progn
- ;; primary indent failed
- (setq wisi-indent-failed t)
- (when (functionp wisi-indent-region-fallback)
- (when (< 0 wisi-debug)
- (message "wisi-indent-region fallback"))
- (funcall wisi-indent-region-fallback begin end)))
-
- (save-excursion
- ;; Apply cached indents. Start from end, so indenting
- ;; doesn't affect correcting for errors in
- ;; wisi--get-cached-indent.
- (goto-char (1- end)) ;; end is exclusive
- (goto-char (line-beginning-position))
- (let ((wisi-indenting-p t))
- (while (and (not (bobp))
- (or (and (= begin end) (= (point) end))
- (>= (point) begin)))
- (when (or indent-blank-lines (not (eolp)))
- ;; ’indent-region’ doesn’t indent an empty line; ’indent-line’
does
- (let ((indent (if (bobp) 0 (wisi--get-cached-indent begin
end))))
- (indent-line-to indent))
- )
- (forward-line -1))
-
- ;; Run wisi-indent-calculate-functions
- (when wisi-indent-calculate-functions
- (goto-char begin)
- (while (and (not (eobp))
- (< (point) end-mark))
- (back-to-indentation)
- (let ((indent
- (run-hook-with-args-until-success
'wisi-indent-calculate-functions)))
- (when indent
- (indent-line-to indent)))
-
- (forward-line 1)))
- )
-
- (when
- (and prev-indent-failed
- (not wisi-indent-failed))
- ;; Previous parse failed or indent was potentially
- ;; ambiguous, this one is not.
- (goto-char end-mark)
- (when (< 0 wisi-debug)
- (message "wisi-indent-region post-parse-fail-hook"))
- (run-hooks 'wisi-post-indent-fail-hook))
- ))
- )))
-
-(defun wisi-indent-line ()
- "For `indent-line-function'."
- (let ((savep (copy-marker (point)))
- (to-indent nil))
- (back-to-indentation)
- (when (>= (point) savep)
- (setq to-indent t))
-
- (wisi-indent-region (line-beginning-position (1+ (-
wisi-indent-context-lines))) (1+ (line-end-position)) t)
-
- (goto-char savep)
- (when to-indent (back-to-indentation))
- ))
-
-(defun wisi-repair-error-1 (data)
- "Repair error reported in DATA (a ’wisi--parse-error’ or
’wisi--lexer-error’)"
- (let ((wisi--parse-action 'navigate))
- (cond
- ((wisi--lexer-error-p data)
- (goto-char (1+ (wisi--lexer-error-pos data)))
- (insert (wisi--lexer-error-inserted data)))
- ((wisi--parse-error-p data)
- (dolist (repair (wisi--parse-error-repair data))
- (goto-char (wisi--parse-error-repair-pos repair))
- (when (< 0 (length (wisi--parse-error-repair-deleted repair)))
- (delete-region (car (wisi--parse-error-repair-deleted-region repair))
- (cdr (wisi--parse-error-repair-deleted-region repair)))
- (when (= ? (char-after (point)))
- (delete-char 1)))
- (dolist (id (wisi--parse-error-repair-inserted repair))
- (when (and (not (bobp))
- (not (= ?\( (char-before (point))))
- (member (syntax-class (syntax-after (1- (point)))) '(2
3))) ;; word or symbol
- (insert " "))
- (insert (cdr (assoc id (wisi-parser-repair-image wisi--parser)))))
- ))
- )))
-
-(defun wisi-repair-error ()
- "Repair the current error."
- (interactive)
- (let ((wisi-inhibit-parse t)) ;; don’t let the error list change while we
are processing it.
- (if (= 1 (+ (length (wisi-parser-lexer-errors wisi--parser))
- (length (wisi-parser-parse-errors wisi--parser))))
- (progn
- (wisi-repair-error-1 (or (car (wisi-parser-lexer-errors wisi--parser))
- (car (wisi-parser-parse-errors
wisi--parser)))))
- (if (buffer-live-p wisi-error-buffer)
- (let ((err
- (with-current-buffer wisi-error-buffer
- (get-text-property (point) 'wisi-error-data))))
- (wisi-repair-error-1 err))
- (error "no current error found")
- ))))
-
-(defun wisi-repair-errors (&optional beg end)
- "Repair errors reported by last parse.
-If non-nil, only repair errors in BEG END region."
- (interactive)
- (let ((wisi-inhibit-parse t)) ;; don’t let the error list change while we
are processing it.
- (dolist (data (wisi-parser-lexer-errors wisi--parser))
- (when (or (null beg)
- (and (not (= 0 (wisi--lexer-error-inserted data)))
- (wisi--lexer-error-pos data)
- (<= beg (wisi--lexer-error-pos data))
- (<= (wisi--lexer-error-pos data) end)))
- (wisi-repair-error-1 data)))
-
- (dolist (data (wisi-parser-parse-errors wisi--parser))
- (when (or (null beg)
- (and (wisi--parse-error-pos data)
- (<= beg (wisi--parse-error-pos data))
- (<= (wisi--parse-error-pos data) end)))
- (wisi-repair-error-1 data)))
- ))
-
-;;; xref integration
-
-(defun wisi-xref-identifier-at-point ()
- (let ((ident (thing-at-point 'symbol)))
- (when ident
- (put-text-property
- 0 1
- 'xref-identifier
- (list :file (buffer-file-name)
- :line (line-number-at-pos)
- :column (current-column))
- ident)
- ident)))
-
-(defun wisi-next-name-region ()
- "Return the next region at or after point with text property 'wisi-name'."
- (let* ((begin
- (if (get-text-property (point) 'wisi-name)
- (point)
- (next-single-property-change (point) 'wisi-name)))
- (end (next-single-property-change begin 'wisi-name)))
- (cons begin end)))
-
-(defun wisi-prev-name-region ()
- "Return the prev region at or before point with text property 'wisi-name'."
- (let* ((end
- (if (get-text-property (point) 'wisi-name)
- (point)
- (previous-single-property-change (point) 'wisi-name)))
- (begin (previous-single-property-change end 'wisi-name)))
- (cons begin end)))
-
-(defun wisi-next-name ()
- "Return the text at or after point with text property 'wisi-name'."
- (let ((region (wisi-next-name-region)))
- (buffer-substring-no-properties (car region) (cdr region))))
-
-(defun wisi-prev-name ()
- "Return the text at or before point with text property 'wisi-name'."
- (let ((region (wisi-prev-name-region)))
- (buffer-substring-no-properties (car region) (cdr region))))
-
-(defconst wisi-names-regexp "\\([^<]*\\)<\\([0-9]+\\)>"
- "Match line number encoded into identifier by `wisi-names'.")
-
-(defun wisi-names (append-lines alist)
- "List of names; each is text from one 'wisi-name property in current buffer.
-If APPEND-LINES is non-nil, each name has the line number it
-occurs on appended. If ALIST is non-nil, the result is an alist
-where the car is a list (FILE LINE COL)."
- (when wisi--parser
- ;; wisi--parser is nil in a non-language buffer, like Makefile
- (wisi-validate-cache (point-min) (point-max) t 'navigate)
- (let ((table nil)
- (pos (point-min))
- end-pos)
- (while (setq pos (next-single-property-change pos 'wisi-name))
- ;; We can’t store location data in a string text property -
- ;; it does not survive completion. So we include the line
- ;; number in the identifier string. This also serves to
- ;; disambiguate overloaded identifiers in the user interface.
- (setq end-pos (next-single-property-change pos 'wisi-name))
- (let* ((line (line-number-at-pos pos))
- (summary
- (if append-lines
- (format "%s<%d>"
- (buffer-substring-no-properties pos end-pos)
- line)
- (buffer-substring-no-properties pos end-pos))))
- (if alist
- (save-excursion
- (goto-char pos)
- (push (cons summary (list (buffer-file-name) line
(current-column)))
- table))
- (push summary table)))
- (setq pos end-pos)
- )
- table)))
-
-;;;; debugging
-
-(defun wisi-show-region ()
- (interactive)
- (cond
- ((use-region-p)
- (message "(%s . %s)" (region-beginning) (region-end)))
- (t
- (let ((string (read-from-minibuffer "region: ")))
- (when (not (= ?\( (aref string 0)))
- (setq string (concat "(" string ")")))
-
- (let ((region (read string)))
- (cond
- ((consp (cdr region))
- ;; region is a list; (begin end)
- (set-mark (nth 0 region))
- (goto-char (nth 1 region)))
-
- ((consp region)
- ;; region is a cons; (begin . end)
- (set-mark (car region))
- (goto-char (cdr region)))
- ))))
- ))
-
-(defun wisi-debug-keys ()
- "Add debug key definitions to `global-map'."
- (interactive)
- (define-key global-map "\M-h" 'wisi-show-containing-or-previous-cache)
- (define-key global-map "\M-i" 'wisi-show-indent)
- (define-key global-map "\M-j" 'wisi-show-cache)
- )
-
-(defun wisi-parse-buffer (&optional parse-action begin end)
- (interactive)
- (unless parse-action
- (setq parse-action (wisi-read-parse-action)))
- (if (use-region-p)
- (progn
- (setq begin (region-beginning))
- (setq end (region-end)))
-
- (unless begin (setq begin (point-min)))
- (unless end (setq end (point-max))))
-
- (wisi-set-parse-try t parse-action)
- (wisi-invalidate-cache parse-action begin)
-
- (cl-ecase parse-action
- (face
- (with-silent-modifications
- (remove-text-properties
- begin end
- (list
- 'font-lock-face nil
- 'fontified nil)))
- (wisi-validate-cache begin end t parse-action)
- (font-lock-ensure))
-
- (navigate
- (wisi-validate-cache begin end t parse-action))
-
- (indent
- (wisi-indent-region begin end))
- ))
-
-(defun wisi-time (func count &optional report-wait-time)
- "call FUNC COUNT times, show total time"
- (interactive "afunction \nncount ")
-
- (let ((start-time (float-time))
- (start-gcs gcs-done)
- (cum-wait-time 0.0)
- (i 0)
- diff-time
- diff-gcs)
- (while (not (eq (1+ count) (setq i (1+ i))))
- (save-excursion
- (funcall func))
- (when report-wait-time
- (setq cum-wait-time (+ cum-wait-time
(wisi-process--parser-total-wait-time wisi--parser)))))
- (setq diff-time (- (float-time) start-time))
- (setq diff-gcs (- gcs-done start-gcs))
- (if report-wait-time
- (progn
- (message "Total %f seconds, %d gcs; per iteration %f seconds %d gcs
%d responses %f wait"
- diff-time
- diff-gcs
- (/ diff-time count)
- (/ (float diff-gcs) count)
- (wisi-process--parser-response-count wisi--parser)
- (/ cum-wait-time count)))
-
- (message "Total %f seconds, %d gcs; per iteration %f seconds %d gcs"
- diff-time
- diff-gcs
- (/ diff-time count)
- (/ (float diff-gcs) count))
- ))
- nil)
-
-(defun wisi-time-indent-middle-line-cold-cache (count &optional
report-wait-time)
- (goto-char (point-min))
- (forward-line (1- (/ (count-lines (point-min) (point-max)) 2)))
- (let ((cum-wait-time 0.0))
- (wisi-time
- (lambda ()
- (wisi-set-parse-try t 'indent)
- (wisi-invalidate-cache 'indent (point-min))
- (wisi-indent-line)
- (when (wisi-process--parser-p wisi--parser)
- (setq cum-wait-time (+ cum-wait-time
(wisi-process--parser-total-wait-time wisi--parser)))))
- count
- report-wait-time)
- ))
-
-(defun wisi-time-indent-middle-line-warm-cache (count)
- (wisi-set-parse-try t 'indent)
- (wisi-invalidate-cache 'indent (point-min))
- (goto-char (point-min))
- (forward-line (/ (count-lines (point-min) (point-max)) 2))
- (wisi-indent-line)
- (wisi-time #'wisi-indent-line count))
-
-(defun wisi-show-indent ()
- "Show indent cache for current line."
- (interactive)
- (message "%s" (get-text-property (1- (line-beginning-position))
'wisi-indent)))
-
-(defun wisi-show-cache ()
- "Show wisi text properties at point."
- (interactive)
- (message "%s:%s:%s:%s"
- (wisi-get-cache (point))
- (get-text-property (point) 'face)
- (get-text-property (point) 'font-lock-face)
- (get-text-property (point) 'wisi-name)
- ))
-
-(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)))
- ))
-
-;;;;; setup
-
-(cl-defun wisi-setup (&key indent-calculate post-indent-fail parser)
- "Set up a buffer for parsing files with wisi."
- (when wisi--parser
- (wisi-kill-parser))
-
- (setq wisi--parser parser)
- (setq wisi--cached-regions
- (list
- (cons 'face nil)
- (cons 'navigate nil)
- (cons 'indent nil)))
-
- (setq wisi--parse-try
- (list
- (cons 'face t)
- (cons 'navigate t)
- (cons 'indent t)))
-
- (setq wisi--last-parse-region
- (list
- (cons 'face nil)
- (cons 'navigate nil)
- (cons 'indent nil)))
-
- (setq wisi-indent-calculate-functions (append
wisi-indent-calculate-functions indent-calculate))
- (set (make-local-variable 'indent-line-function) #'wisi-indent-line)
- (set (make-local-variable 'indent-region-function) #'wisi-indent-region)
- (set (make-local-variable 'forward-sexp-function) #'wisi-forward-sexp)
-
- (setq wisi-post-indent-fail-hook post-indent-fail)
- (setq wisi-indent-failed nil)
-
- (add-hook 'before-change-functions #'wisi-before-change 'append t)
- (add-hook 'after-change-functions #'wisi-after-change nil t)
- (setq wisi--change-end (copy-marker (point-min) t))
-
- (set (make-local-variable 'comment-indent-function) 'wisi-comment-indent)
-
- (add-hook 'completion-at-point-functions #'wisi-completion-at-point -90 t)
-
- (add-hook 'hack-local-variables-hook 'wisi-post-local-vars nil t)
- )
-
-(defun wisi-post-local-vars ()
- "See wisi-setup."
- (remove-hook 'hack-local-variables-hook #'wisi-post-local-vars)
-
- (unless wisi-disable-face
- (jit-lock-register #'wisi-fontify-region)))
-
-
-(provide 'wisi)
-;;; wisi.el ends here
diff --git a/packages/wisi/wisi.gpr.gp b/packages/wisi/wisi.gpr.gp
deleted file mode 100644
index 1c17529..0000000
--- a/packages/wisi/wisi.gpr.gp
+++ /dev/null
@@ -1,64 +0,0 @@
--- Abstract :
---
--- Make installed and source ELPA package wisi Ada code available for
--- other projects.
---
--- Copyright (C) 2017, 2019 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-with "gnatcoll";
-with "standard_common";
-#if ELPA="no"
-with "sal";
-with "wisitoken";
-#end if;
-project Wisi is
-
- for Source_Dirs use (".");
-
- case Standard_Common.Profile is
- when "On" =>
- for Object_Dir use "obj_pro";
- for Exec_Dir use "exec_pro";
-
- when "Off" =>
- for Object_Dir use "obj";
- for Exec_Dir use ".";
- end case;
-
- for Languages use ("Ada", "C"); -- C needed for wisitoken-bnf-generate;
wisitoken_grammar_re2c.c
-
- package Compiler is
-
- case Standard_Common.Build is
- when "Debug" =>
- for Default_Switches ("Ada") use
- Standard_Common.Compiler.Common_Switches &
- Standard_Common.Compiler.Style_Checks &
- Standard_Common.Compiler.Debug_Switches;
-
- for Default_Switches ("C") use
Standard_Common.Compiler.Debug_Switches_C;
-
- when "Normal" =>
- for Default_Switches ("Ada") use
- Standard_Common.Compiler.Common_Switches &
- Standard_Common.Compiler.Style_Checks &
- Standard_Common.Compiler.Release_Switches;
-
- for Default_Switches ("C") use
Standard_Common.Compiler.Release_Switches_C;
- end case;
-
- end Compiler;
-
-end Wisi;
diff --git a/packages/wisi/wisi.info b/packages/wisi/wisi.info
deleted file mode 100644
index e24dcee..0000000
--- a/packages/wisi/wisi.info
+++ /dev/null
@@ -1,1294 +0,0 @@
-This is wisi.info, produced by makeinfo version 6.7 from wisi.texi.
-
-Copyright (C) 1999 - 2020 Free Software Foundation, Inc.
-
- Permission is granted to copy, distribute and/or modify this
- document under the terms of the GNU Free Documentation License,
- Version 1.3 or any later version published by the Free Software
- Foundation; with no Invariant Sections, with the Front-Cover texts
- being "A GNU Manual", and with the Back-Cover Texts as in (a)
- below. A copy of the license is included in the section entitled
- "GNU Free Documentation License".
-
- (a) The FSF's Back-Cover Text is: "You have the freedom to copy and
- modify this GNU manual. Buying copies from the FSF supports it in
- developing GNU and promoting software freedom."
-INFO-DIR-SECTION Emacs
-START-INFO-DIR-ENTRY
-* Wisi: (wisi). Error-correcting LR parsers and project integration.
-END-INFO-DIR-ENTRY
-
-
-File: wisi.info, Node: Top, Next: Overview, Up: (dir)
-
-Top
-***
-
-Wisi Version 3.1.2
-
-* Menu:
-
-* Overview::
-* Grammar actions::
-* Project extension::
-* GNU Free Documentation License::
-* Index::
-
-
-File: wisi.info, Node: Overview, Next: Grammar actions, Prev: Top, Up: Top
-
-1 Overview
-**********
-
-"wisi" used to be an acronym, but now it's just a name.
-
- The wisi package provides an elisp interface to an external parser.
-It assumes the parser generator package WisiToken
-(<http://stephe-leake.org/ada/wisitoken.html>, implemented in Ada), but
-can use any parser that meets the same API. wisi provides several
-grammar actions, to implement indentation, navigating, and syntax
-highlighting (fontification).
-
- wisi also provides an extension to Emacs 'project.el', providing
-operations useful for compilation and cross-reference.
-
-
-File: wisi.info, Node: Grammar actions, Next: Project extension, Prev:
Overview, Up: Top
-
-2 Grammar Actions
-*****************
-
-Grammar actions are specified in the grammar file, in a nonterminal
-declaration. We assume the user is familiar with parser grammars and
-grammar actions. For example, a simple "if" statement can be declared
-as:
-
- if_statement
- : IF expression THEN statements elsif_list ELSE statements END IF
SEMICOLON
- %((wisi-statement-action [1 statement-start 3 motion 6 motion 10
statement-end])
- (wisi-motion-action [1 3 5 6 10])
- (wisi-indent-action [nil
- [(wisi-hanging% ada-indent-broken (* 2
ada-indent-broken))
- ada-indent-broken]
- nil
- [ada-indent ada-indent] nil nil
- [ada-indent ada-indent] nil nil nil]))%
-
- The item before ':' is the "left hand side", or "nonterminal". The
-list of tokens after ':' is the "right hand side"; in general there can
-be more than one right hand side for each nonterminal (separated by
-'|').
-
- The items enclosed in "%()%" are the grammar actions. They are
-specified as list of elisp forms; an earlier version of the wisi package
-generated an elisp parser. We keep the elisp form because it is
-compact, and easier to read and write than the equivalent Ada code. The
-'wisi-bnf-generate' tool converts the elisp into the required Ada
-statements.
-
- There are two classes of actions; in-parse and post-parse. WisiToken
-calls these "semantic checks" and "user actions". The in-parse actions
-are done as parsing procedes; they provide extra checks that can cause
-the parse to fail. Currently the only one provided is 'match-names'; it
-is used to check that the declaration and end names in named Ada blocks
-are the same (which can aid significantly in error correction). In the
-grammar file, in-parse actions are specified in a second '%()%' block,
-which can be omitted if empty. In this document, the term "action"
-means "post-parse action", we use "in-parse action" unless the meaning
-is clear from context.
-
- Executing the wisi grammar actions creates text properties in the
-source file; those text properties are then used by elisp code for
-various purposes.
-
- The text properties applied are:
-
-'wisi-cache'
- This should be named 'wisi-navigate', but isn't for historical
- reasons (there used to be only one kind of text property).
-
- The property contains a 'wisi-cache' object, containing:
-
- 'nonterm'
- The nonterminal in the grammar production that specified the
- action that produced this text property.
-
- 'token'
- A token identifier naming a token in the production right hand
- side containing the text this text property is applied to.
-
- 'last'
- The position of the last character in the token, relative to
- the first character (0 indexed). The text property is only
- applied to the first character in the token (mostly for
- historical reasons).
-
- 'class'
- A token class; see the list of possible values in
- 'wisi-statement-action' below.
-
- 'containing'
- A marker pointing to the start of the containing token for
- this token; only 'nil' for the outermost containing token in a
- file.
-
- 'prev'
- A marker pointing to the previous "motion token" in the
- statement or declaration. These are normally language
- keywords, but can be other things.
-
- 'next'
- A marker pointing to the next "motion token" in the statement
- or declaration.
-
- 'end'
- A marker pointing to the end of the statement or declaration.
-
- wisi provides motion commands for going to the various markers.
-
-'wisi-name'
- Contains no data, applied to a "name" of some sort. wisi provides
- commands for finding the next/previous name, and returning the
- text. Useful for the names of subprograms, which can then be used
- to build a completion table; see
- 'wisi-xref-identifier-completion-table'.
-
-'font-lock-face'
- The standard font-lock property, specifying the face for the text.
-
- Some major modes do not use this for simple keywords; they use
- font-lock regular expressions instead. One reason for this is so
- keywords are still highlighted when the parser fails, which can
- happen if there are severe syntax errors.
-
- Other items, like function and package names, are typically marked
- with 'font-lock-face' by the parser.
-
-'fontified'
- Another standard font-lock text property; applied whenever
- 'font-lock-face' is.
-
-'wisi-indent'
- Contains the indent (in characters) for the next line; applied to
- the newline character on the preceding line. The first line in a
- buffer is assumed to have indent 0.
-
- Each action is classified as one of 'navigate, face, indent,
-in-parse'; when actions are executed, only one of the first three
-classes is executed (in-parse is always executed). This reflects the
-reasons the parser is run; to figure out how to go somehere (end of
-current statement, start of current procedure, etc), to apply faces for
-syntax highlighting, or to indent the code.
-
-* Menu:
-
-* Navigate actions::
-* Face actions::
-* Indent actions::
-* In-parse actions::
-
-
-File: wisi.info, Node: Navigate actions, Next: Face actions, Up: Grammar
actions
-
-2.1 Navigate actions
-====================
-
-'wisi-statement-action [TOKEN CLASS ...]'
- The argument is a vector; alternating items are a token index (an
- integer or label indicating a token in the right hand side) and a
- "token class"; one of:
-
- 'motion'
- Create a 'wisi-cache' text property on the token, for use in a
- subsequent 'wisi-motion-action'.
-
- 'statement-end'
- Create a 'wisi-cache' text property on the token, enter a
- pointer to it in the other 'wisi-cache' objects in the
- statement or declaration.
-
- 'statement-start'
- Create a 'wisi-cache' text property on the token, enter a
- pointer to it in the other 'wisi-cache' objects (in the
- 'containing' slot) in the statement or declaration.
-
- 'statement-override'
- Same as 'statement-start'; marks the token to be used as the
- statement start if the first token is optional.
-
- 'misc'
- Create a 'wisi-cache' text property on the token, to be used
- for some other purpose. It is good style to indicate the
- purpose in a comment.
-
- For example, ada-mode uses a 'misc' property on left
- parentheses that start a subprogram parameter list; this
- distinquishes them from other left parentheses, and makes it
- possible to automatically call 'ada-format-paramlist' to
- format the parameter list, instead of using the standard Emacs
- 'align'.
-
-'wisi-motion-action [TOKEN ...]'
- The argument is a vector, where each element is either a token
- index or a vector [INDEX ID].
-
- Each terminal token must already have a 'wisi-cache' created by a
- 'wisi-statement-action' (this is checked at action execution, not
- during grammar generation). This action sets the 'prev, next'
- slots for the chain of tokens, creating a chain of motion tokens.
-
- If TOKEN is a nonterminal without an ID specified, the 'wisi-cache'
- must be on the first token in the nonterminal, and it is assumed to
- have a valid pointer in the 'next' slot, indicating a chain of
- motion tokens. That chain is linked into the chain for the current
- right hand side.
-
- If TOKEN is a nonterminal with an ID, the region contained by the
- nonterminal is searched for all 'wisi-cache' with that token ID,
- and for each one where prev/next is not already set, it is linked
- into the motion chain.
-
- Note that the "search" described here is done in the parser
- process, on a tree data structure containing the data that will
- eventually be stored in Emacs text properties.
-
-'wisi-name-action TOKEN'
- TOKEN is a token index. Create a 'wisi-name' text property on the
- token.
-
-
-File: wisi.info, Node: Face actions, Next: Indent actions, Prev: Navigate
actions, Up: Grammar actions
-
-2.2 Face actions
-================
-
-'wisi-face-mark-action [INDEX CLASS ...]'
- The argument is a vector; alternating elements form pairs of INDEX
- CLASS, where class is one of 'prefix, suffix'.
-
- Mark the tokens as part of a compound name, for use by later face
- actions.
-
-'wisi-face-apply-action [TOKEN PREFIX-FACE SUFFIX-FACE ...]'
- The argument is a vector; triples of items specify TOKEN,
- PREFIX-FACE, SUFFIX-FACE. The faces are the elisp names of face
- objects (which must declared by an '%elisp_face' declaration).
-
- If the token is a nonterminal, and it has been marked by a previous
- 'wisi-face-mark-action', the specified faces are applied to the
- prefix and suffix in the token as 'font-lock-face' text properties.
-
- If the token is a terminal, or a non-terminal with no face mark,
- the suffix face is applied to the entire text contained by the
- token.
-
-'wisi-face-apply-list-action [TOKEN PREFIX-FACE SUFFIX-FACE ...]'
- Similar to ’wisi-face-apply-action’, but applies faces to all
- tokens marked by 'wisi-face-mark-action' in each indicated
- production token, and does not apply a face if there are no such
- marks.
-
-
-File: wisi.info, Node: Indent actions, Next: In-parse actions, Prev: Face
actions, Up: Grammar actions
-
-2.3 Indent actions
-==================
-
-Indents are computed for each line in a cumulative way as the grammar
-actions are executed. Initially, each indent is set to 'nil', which
-means "not computed"; this is not the same as the value '0'. The
-grammar actions are executed in a bottom-up fashion; low level
-productions are executed before higher level ones. In general, the
-indent action for a production specifies a "delta indent"; the indent is
-incremented by that amount. When all productions have been processed,
-the indent has been computed for all lines.
-
- Indents are often given as a function call; the arguments to the
-function can be other function calls, or integer expressions.
-'wisitoken-bnf-generate' supports only simple integer expressions; those
-using integers, integer-valued variables, parenthesis, + (plus), -
-(minus), and * (multiply).
-
-'wisi-indent-action [INDENT ...]'
- The argument is a vector, giving an indent for each token in the
- production right-hand side.
-
- For terminals, the indents only have meaning, and are only
- computed, if the token is the first on a line. For nonterminals
- where the indent is not a variant of 'wisi-hanging', the indent is
- only computed if the first terminal token in the nonterminal is the
- first on a line. See 'wisi-hanging' in *note Indent functions::
- for the remaining case.
-
- An indent can have several forms. In the descriptions below, the
- "current token" is given by the position of the indent expression
- in the 'wisi-indent-action' argument list.
-
- An integer
- This gives a delta indent; it is added to the total indent for
- the line.
-
- A variable name
- The name is translated to an Ada identifier by replacing "-"
- with "_", and applying 'Camel_Case'. The translated name must
- identify a directly visible run-time Ada integer variable;
- this is checked at Ada compile time. It provides an integer
- delta indent.
-
- For example, in Ada two indent variable names are 'ada-indent'
- and 'ada-indent-broken', giving the basic ident, and the
- continuation line indent. They are runtime variables so
- different projects can specify them as part of a coding
- standard.
-
- A function call
- A function that computes a delta indent. See *note Indent
- functions::.
-
- [CODE-INDENT , COMMENT-INDENT]
- A vector giving separate indents for code and comments.
-
- Normally, the indent for trailing comments (on lines with no
- code, after all code in the token) is given by the indent of
- the following token in the production. When the current token
- is the last, or the following tokens may be empty, or the
- indent of the following token would be wrong for some reason
- (for example, it is a block end), the comment indent may be
- specified separately. If it is not specified, and the indent
- from the next token is not available, the indent for the
- current token is used for code and comments.
-
- Comment lines that are not trailing are indented by
- CODE-INDENT.
-
- (label . INDENT)
- If token labels are used in a right hand side, they must be
- given explicitly in the indent arguments, using he lisp "cons"
- syntax. Labels are normally only used with EBNF grammars,
- which expand into multiple right hand sides, with optional
- tokens simply left out. Explicit labels on the indent
- arguments allow them to be left out as well.
-
-* Menu:
-
-* Indent functions::
-* Indent example::
-
-
-File: wisi.info, Node: Indent functions, Next: Indent example, Up: Indent
actions
-
-2.3.1 Indent functions
-----------------------
-
-'wisi-anchored TOKEN OFFSET'
- Sets the indent for the current token to be OFFSET (an integer
- expression) from the start of TOKEN (a token index); the current
- token is "anchored to" TOKEN.
-
-'wisi-anchored* TOKEN OFFSET'
- Sets the indent for the current token to be OFFSET from the start
- of TOKEN, but only if TOKEN is the first token on a line; otherwise
- no indent
-
-'wisi-anchored*- TOKEN OFFSET'
- Sets the indent for the current token to be OFFSET from the start
- of TOKEN, but only if TOKEN is the first token on a line and the
- indent for the current token accumulated so far is nil.
-
-'wisi-anchored% TOKEN OFFSET'
- If there is an opening parenthesis containing TOKEN in the line
- containing TOKEN, set the current indent to OFFSET from that
- parenthesis. Otherwise, OFFSET gives an indent delta.
-
-'wisi-anchored%- TOKEN OFFSET'
- Same as 'wisi-anchored%', but only if the current token accumulated
- indent is nil.
-
-'wisi-hanging DELTA-1 DELTA-2'
- The current token is assumed to be a nonterminal. If the text it
- contains spans multiple lines, use DELTA-1 for the first line,
- DELTA-2 for the rest. If the current token is only on one line,
- use DELTA-1.
-
- DELTA-1 and DELTA-2 can be any IDENT expression, except a variant
- of 'wisi-hanging'.
-
-'wisi-hanging% DELTA-1 DELTA-2'
- Similar to 'wisi-hanging'; if the first terminal token in the
- current nonterminal is the first token on the first line, use
- DELTA-1 for the first line and DELTA-2 for the rest. Otherwise,
- use DELTA-1 for all lines.
-
-'wisi-hanging%- DELTA-1 DELTA-2'
- Same as 'wisi-hanging%', except applied only if the current token
- accumulated indent is nil.
-
-'Language-specific function'
- Language-specific indent functions are specified by an
- '%elisp_indent' declaration in the grammar file. Each function
- specifies how many arguments it accepts; this is checked at action
- runtime, not during grammar generation. Each argument is an INDENT
- as described above, or a token ID prefixed by ''' (to allow
- distinguishing token IDs from variable names).
-
-
-File: wisi.info, Node: Indent example, Prev: Indent functions, Up: Indent
actions
-
-2.3.2 Indent example
---------------------
-
-The example 'if_statement' grammar nonterminal is:
-
- if_statement
- : IF expression THEN statements elsif_list ELSE statements END IF
SEMICOLON
- %((wisi-indent-action [nil
- [(wisi-hanging% ada-indent-broken (* 2
ada-indent-broken))
- ada-indent-broken]
- nil
- [ada-indent ada-indent] nil nil
- [ada-indent ada-indent] nil nil nil]))%
-
- We trace how the indent is computed for this sample Ada code:
-
- 1: if A < B and
- 2: C < D
- 3: -- comment on expression
- 4: then
- 5: if E then
- 6: Do_E;
- 7: -- comment on statement
- 8: elsif F then
- 9: G := A + Compute_Something
- 10: (arg_1, arg_2);
- 11: end if;
- 12: end if;
-
- First, the indent for the lower-level nonterminals ('expression,
-statements, elsif_list') are computed. Assume they set the indent for
-line 10 to 2 (for the hanging expression) and leave the rest at nil.
-
- Next, the action for the inner 'if_statement' is executed. Most of
-the tokens specify an indent of 'nil', which means the current
-accumulated indent is not changed. For the others, the action is as
-follows:
-
-'expression:'
- The expression 'E' is contained on one line, and it is not the
- first token on that line, so the indent for line 5 is not changed.
-
-'statements: [ada-indent ada-indent]'
- This specifies separate indents for code and trailing comments,
- because otherwise the trailing comments would be indented with the
- following 'THEN'; instead they are indented with the expression
- code; see the comment on line 7.
-
- Here 'ada-indent' is 3, so the indent for lines 6 and 7 (for the
- first occurence of 'statments') is incremented from 'nil' to '3'.
-
- For the second occurence of 'statements', line 9 is incremented
- from 'nil' to '3', and line 10 from '2' to '5'.
-
- At this point, the accumulated indents are (the indent is given after
-the line number):
- 1: nil : if A < B and
- 2: nil : C < D
- 3: nil : -- comment on expression
- 4: nil : then
- 5: nil : if E then
- 6: 3 : Do_E;
- 7: 3 : -- comment on statement
- 8: nil : elsif F then
- 9: 3 : G := A + Compute_Something
- 10: 5 : (arg_1, arg_2);
- 11: nil : end if;
- 12: nil : end if;
-
- Then the action is executed for the outer 'if_statement':
-
-'expression: [(wisi-hanging% ada-indent-broken (* 2 ada-indent-broken))
ada-indent-broken]'
- This specifies separate indents for code and trailing comments,
- because otherwise the trailing comments would be indented with the
- following 'THEN'; instead they are indented with the expression
- code; see the comment on line 3.
-
- In this case, 'wisi-hanging%' returns DELTA-1, which is
- 'ada-indent-broken', which is 2. So the indent for line 2 is
- incremented from 'nil' to '2'.
-
- The indent for line 3 is also incremented from 'nil' to '2'.
-
-'statements: [ada-indent ada-indent]'
- Here there is only one statement; the nested 'if_statement'. The
- indent for lines 5 .. 11 are each incremented by 3.
-
- The final result is:
- 1: nil : if A < B and
- 2: 2 : C < D
- 3: 2 : -- comment on expression
- 4: nil : then
- 5: 3 : if E then
- 6: 6 : Do_E;
- 7: 6 : -- comment on statement
- 8: 3 : elsif F then
- 9: 6 : G := A + Compute_Something
- 10: 8 : (arg_1, arg_2);
- 11: 6 : end if;
- 12: nil : end if;
-
- In a full grammar, the top production should specify an indent of 0,
-not nil, for tokens that are not indented; then every line will have a
-non-nil indent. However, in normal operation a nil indent is treated as
-0; the 'wisi-indent' text property is not set for lines that have nil
-indent, and 'wisi-indent-region' detects that and uses 0 for the indent.
-You can set the variable 'wisi-debug' to a value > 0 to signal an error
-for nil indents; this is useful to catch indent errors during grammar
-development.
-
-
-File: wisi.info, Node: In-parse actions, Prev: Indent actions, Up: Grammar
actions
-
-2.4 In-parse actions
-====================
-
-'wisi-propagate-name TOKEN'
- The argument is a token index. Set the 'name' component of the
- left-hand-side parse-time token object to the 'name' component of
- the identified token, if it is not empty. Otherwise use the
- 'byte_region' component.
-
-'wisi-merge-name FIRST-TOKEN, LAST-TOKEN'
- The arguments are token indices, giving a range of tokens.
- LAST-TOKEN may be omitted if it is the same as FIRST-TOKEN.
-
- Set the 'name' component of the left-hand-side to the merger of the
- 'name' or 'byte-region' components of the identified tokens.
-
-'wisi-match-name START-TOKEN END-TOKEN'
- The arguments are token indices. Compare the text contained by the
- 'name' (or 'byte_region' if 'name' is empty) token components for
- START-TOKEN and END-TOKEN; signal a parse error if they are
- different.
-
- The behavior when a name is missing is determined by the runtime
- language variable given in the '%end_names_optional_option'
- declaration; if True, a missing name that is supposed to match a
- present name is an error. Both names missing is not an error
- (assuming that is allowed by the grammar).
-
-
-File: wisi.info, Node: Project extension, Next: GNU Free Documentation
License, Prev: Grammar actions, Up: Top
-
-3 Project extension
-*******************
-
-wisi defines the 'cl-defstuct' 'wisi-prj', with operations suitable for
-compilation and cross-reference.
-
- In order to use wisi projects, the user must write project files and
-customize 'project-find-functions' and 'xref-backend-functions'.
-
-* Menu:
-
-* Project files::
-* Selecting projects::
-* Casing exception files::
-* Other project functions::
-
-
-File: wisi.info, Node: Project files, Next: Selecting projects, Up: Project
extension
-
-3.1 Project files
-=================
-
-Project file names must have an extension given by
-'wisi-prj-file-extensions' (default '.adp, .prj').
-
- Project files have a simple syntax; they may be edited directly.
-Each line specifies a project variable name and its value, separated by
-"=":
-
- src_dir=/Projects/my_project/src_1
- src_dir=/Projects/my_project/src_2
-
- There must be no space between the variable name and "=", and no
-trailing spaces after the value.
-
- Any line that does not have an "=" is a comment.
-
- Some variables (like 'src_dir') are lists; each line in the project
-file specifies one element of the list. The value on the last line is
-the last element in the list.
-
- A variable name that starts with '$' is set as a process environment
-variable, for processes launched from Emacs for the project.
-
- In values, process environment variables can be referenced using the
-normal '$var' syntax.
-
- In values, relative file names are expanded relative to the directory
-containing the project file.
-
- Here is the list of project variables defined by wisi; major modes
-may add more.
-
-'casing' [slot: 'case-exception-files']
- List of files containing casing exceptions. *Note Casing exception
- files::.
-
-'src_dir' [slot: 'source-path']
- A list of directories to search for source files.
-
-
-File: wisi.info, Node: Selecting projects, Next: Casing exception files,
Prev: Project files, Up: Project extension
-
-3.2 Selecting projects
-======================
-
-The current project can either be indicated by a global variable (called
-a "selected project"), or depend on the current buffer.
-
- In addition, the project file can be parsed each time it is needed,
-or the result cached to improve response time,
-
- One reason to use a selected project is to handle a hierarchy of
-projects; if projects B and C both depend on library project A, then
-when in a file of project A, there is no way to determine which of the
-three projects to return. So the user must indicate which is active, by
-using one of 'wisi-prj-select-file' or 'wisi-prj-select-cache'.
-
- In addition, if changing from one project to another requires setting
-global resources that must also be unset (such as a syntax propertize
-hook or compilation filter hook), then the project should define
-'wisi-prj-deselect' in addition to 'wisi-prj-select'. Such projects
-require having a selected current project, so it can be deselected
-before a new one is selected. One example of such projects is ada-mode.
-
- One way to declare each project is to add a Local Variables section
-in the main Makefile for the project; when the Makefile is first
-visited, the project is declared. In the examples here, we assume that
-approach is used; each gives an :eval line.
-
- Note that 'wisi-prj-current-parse' and 'wisi-prj-current-cached'
-always succeed after some project is selected; no functions after them
-on 'project-find-functions' will be called. That's why the depth is 90
-for those in the examples.
-
-No caching, current project depends on current buffer
-
- (add-hook 'project-find-functions #'wisi-prj-find-dominating-parse 0)
-
- :eval (wisi-prj-set-dominating "foo.prj" (foo-prj-default
"prj-name"))
-
- 'wisi-prj-set-dominating' declares the name of a project file with
- a default project object, and ensures that the current buffer file
- name is in 'wisi-prj--dominating'.
-
- 'wisi-prj-find-dominating-parse' looks for the filenames in
- 'wisi-prj--dominiating' in the parent directories of the current
- buffer. When one is found, the associated project file is parsed,
- using the default project object to dispatch to the appropriate
- parsers. Then the final project object is returned.
-
-Caching, current project depends on current buffer
-
- (add-hook 'project-find-functions #'wisi-prj-find-dominating-cached
0)
-
- :eval (wisi-prj-cache-dominating "foo.prj" (foo-prj-default
"prj-name"))
-
- 'wisi-prj-cache-dominating' declares the project file, parses it,
- and saves the project object in a cache indexed by the absolute
- project file name.
-
- 'wisi-prj-find-dominating-cached' finds the dominating project
- file, and retrieves the object from the cache.
-
-No caching, last selected project is current
-
- (add-hook 'project-find-functions #'wisi-prj-current-parse 90)
-
- :eval: (wisi-prj-select-file <prj-file> (foo-prj-default "prj-name"))
-
- 'wisi-prj-select-file' sets the project file as the current
- project, and saves the default project object.
-
- 'wisi-prj-current-parse' parses the current project file, using the
- saved default project object, and returns the project object.
-
-Caching, last selected project is current
-
- (add-hook 'project-find-functions #'wisi-prj-current-cached 90)
-
- :eval: (wisi-prj-select-cache <prj-file> (foo-prj-default
"prj-name"))
-
- 'wisi-prj-select-cache' parses the project file, caches the project
- object.
-
- 'wisi-prj-current-cached' returns the cached current project
- object.
-
- In addition, the user should set 'xref-backend-functions'.
-Currently, there is only one choice for wisi projects:
-
- (add-to-list 'xref-backend-functions #'wisi-prj-xref-backend 90)
-
- 'wisi-prj-xref-backend' returns the current wisi project object.
-
-
-File: wisi.info, Node: Casing exception files, Next: Other project
functions, Prev: Selecting projects, Up: Project extension
-
-3.3 Casing exception files
-==========================
-
-Each line in a case exception file specifies the casing of one word or
-word fragment. If an exception is defined in multiple files, the first
-occurrence is used.
-
- If the word starts with an asterisk ('*'), it defines the casing of a
-word fragment (or "substring"); part of a word between two underscores
-or word boundary.
-
- For example:
-
- DOD
- *IO
- GNAT
-
- The word fragment '*IO' applies to any word containing "_io";
-'Text_IO', 'Hardware_IO', etc.
-
-
-File: wisi.info, Node: Other project functions, Prev: Casing exception
files, Up: Project extension
-
-3.4 Other project functions
-===========================
-
-'wisi-refresh-prj-cache (not-full)'
- Refreshes all cached data in the project, and re-selects the
- project. If NOT-FULL is non-nil, slow refresh operations are
- skipped.
-
- This reparses the project file, and any cross reference
- information.
-
-'wisi-prj-select-dominating (dominating-file)'
- Find a wisi-prj matching DOMINATING-FILE (defaults to the current
- buffer file). If the associated project is current, do nothing.
- If it is not current, select it.
-
- This is useful before running 'compilation-start', to ensure the
- correct project is current.
-
-
-File: wisi.info, Node: GNU Free Documentation License, Next: Index, Prev:
Project extension, Up: Top
-
-Appendix A GNU Free Documentation License
-*****************************************
-
- Version 1.3, 3 November 2008
-
- Copyright (C) 2000, 2001, 2002, 2007, 2008, 2009 Free Software
Foundation, Inc.
- <http://fsf.org/>
-
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- 0. PREAMBLE
-
- The purpose of this License is to make a manual, textbook, or other
- functional and useful document "free" in the sense of freedom: to
- assure everyone the effective freedom to copy and redistribute it,
- with or without modifying it, either commercially or
- noncommercially. Secondarily, this License preserves for the
- author and publisher a way to get credit for their work, while not
- being considered responsible for modifications made by others.
-
- This License is a kind of "copyleft", which means that derivative
- works of the document must themselves be free in the same sense.
- It complements the GNU General Public License, which is a copyleft
- license designed for free software.
-
- We have designed this License in order to use it for manuals for
- free software, because free software needs free documentation: a
- free program should come with manuals providing the same freedoms
- that the software does. But this License is not limited to
- software manuals; it can be used for any textual work, regardless
- of subject matter or whether it is published as a printed book. We
- recommend this License principally for works whose purpose is
- instruction or reference.
-
- 1. APPLICABILITY AND DEFINITIONS
-
- This License applies to any manual or other work, in any medium,
- that contains a notice placed by the copyright holder saying it can
- be distributed under the terms of this License. Such a notice
- grants a world-wide, royalty-free license, unlimited in duration,
- to use that work under the conditions stated herein. The
- "Document", below, refers to any such manual or work. Any member
- of the public is a licensee, and is addressed as "you". You accept
- the license if you copy, modify or distribute the work in a way
- requiring permission under copyright law.
-
- A "Modified Version" of the Document means any work containing the
- Document or a portion of it, either copied verbatim, or with
- modifications and/or translated into another language.
-
- A "Secondary Section" is a named appendix or a front-matter section
- of the Document that deals exclusively with the relationship of the
- publishers or authors of the Document to the Document's overall
- subject (or to related matters) and contains nothing that could
- fall directly within that overall subject. (Thus, if the Document
- is in part a textbook of mathematics, a Secondary Section may not
- explain any mathematics.) The relationship could be a matter of
- historical connection with the subject or with related matters, or
- of legal, commercial, philosophical, ethical or political position
- regarding them.
-
- The "Invariant Sections" are certain Secondary Sections whose
- titles are designated, as being those of Invariant Sections, in the
- notice that says that the Document is released under this License.
- If a section does not fit the above definition of Secondary then it
- is not allowed to be designated as Invariant. The Document may
- contain zero Invariant Sections. If the Document does not identify
- any Invariant Sections then there are none.
-
- The "Cover Texts" are certain short passages of text that are
- listed, as Front-Cover Texts or Back-Cover Texts, in the notice
- that says that the Document is released under this License. A
- Front-Cover Text may be at most 5 words, and a Back-Cover Text may
- be at most 25 words.
-
- A "Transparent" copy of the Document means a machine-readable copy,
- represented in a format whose specification is available to the
- general public, that is suitable for revising the document
- straightforwardly with generic text editors or (for images composed
- of pixels) generic paint programs or (for drawings) some widely
- available drawing editor, and that is suitable for input to text
- formatters or for automatic translation to a variety of formats
- suitable for input to text formatters. A copy made in an otherwise
- Transparent file format whose markup, or absence of markup, has
- been arranged to thwart or discourage subsequent modification by
- readers is not Transparent. An image format is not Transparent if
- used for any substantial amount of text. A copy that is not
- "Transparent" is called "Opaque".
-
- Examples of suitable formats for Transparent copies include plain
- ASCII without markup, Texinfo input format, LaTeX input format,
- SGML or XML using a publicly available DTD, and standard-conforming
- simple HTML, PostScript or PDF designed for human modification.
- Examples of transparent image formats include PNG, XCF and JPG.
- Opaque formats include proprietary formats that can be read and
- edited only by proprietary word processors, SGML or XML for which
- the DTD and/or processing tools are not generally available, and
- the machine-generated HTML, PostScript or PDF produced by some word
- processors for output purposes only.
-
- The "Title Page" means, for a printed book, the title page itself,
- plus such following pages as are needed to hold, legibly, the
- material this License requires to appear in the title page. For
- works in formats which do not have any title page as such, "Title
- Page" means the text near the most prominent appearance of the
- work's title, preceding the beginning of the body of the text.
-
- The "publisher" means any person or entity that distributes copies
- of the Document to the public.
-
- A section "Entitled XYZ" means a named subunit of the Document
- whose title either is precisely XYZ or contains XYZ in parentheses
- following text that translates XYZ in another language. (Here XYZ
- stands for a specific section name mentioned below, such as
- "Acknowledgements", "Dedications", "Endorsements", or "History".)
- To "Preserve the Title" of such a section when you modify the
- Document means that it remains a section "Entitled XYZ" according
- to this definition.
-
- The Document may include Warranty Disclaimers next to the notice
- which states that this License applies to the Document. These
- Warranty Disclaimers are considered to be included by reference in
- this License, but only as regards disclaiming warranties: any other
- implication that these Warranty Disclaimers may have is void and
- has no effect on the meaning of this License.
-
- 2. VERBATIM COPYING
-
- You may copy and distribute the Document in any medium, either
- commercially or noncommercially, provided that this License, the
- copyright notices, and the license notice saying this License
- applies to the Document are reproduced in all copies, and that you
- add no other conditions whatsoever to those of this License. You
- may not use technical measures to obstruct or control the reading
- or further copying of the copies you make or distribute. However,
- you may accept compensation in exchange for copies. If you
- distribute a large enough number of copies you must also follow the
- conditions in section 3.
-
- You may also lend copies, under the same conditions stated above,
- and you may publicly display copies.
-
- 3. COPYING IN QUANTITY
-
- If you publish printed copies (or copies in media that commonly
- have printed covers) of the Document, numbering more than 100, and
- the Document's license notice requires Cover Texts, you must
- enclose the copies in covers that carry, clearly and legibly, all
- these Cover Texts: Front-Cover Texts on the front cover, and
- Back-Cover Texts on the back cover. Both covers must also clearly
- and legibly identify you as the publisher of these copies. The
- front cover must present the full title with all words of the title
- equally prominent and visible. You may add other material on the
- covers in addition. Copying with changes limited to the covers, as
- long as they preserve the title of the Document and satisfy these
- conditions, can be treated as verbatim copying in other respects.
-
- If the required texts for either cover are too voluminous to fit
- legibly, you should put the first ones listed (as many as fit
- reasonably) on the actual cover, and continue the rest onto
- adjacent pages.
-
- If you publish or distribute Opaque copies of the Document
- numbering more than 100, you must either include a machine-readable
- Transparent copy along with each Opaque copy, or state in or with
- each Opaque copy a computer-network location from which the general
- network-using public has access to download using public-standard
- network protocols a complete Transparent copy of the Document, free
- of added material. If you use the latter option, you must take
- reasonably prudent steps, when you begin distribution of Opaque
- copies in quantity, to ensure that this Transparent copy will
- remain thus accessible at the stated location until at least one
- year after the last time you distribute an Opaque copy (directly or
- through your agents or retailers) of that edition to the public.
-
- It is requested, but not required, that you contact the authors of
- the Document well before redistributing any large number of copies,
- to give them a chance to provide you with an updated version of the
- Document.
-
- 4. MODIFICATIONS
-
- You may copy and distribute a Modified Version of the Document
- under the conditions of sections 2 and 3 above, provided that you
- release the Modified Version under precisely this License, with the
- Modified Version filling the role of the Document, thus licensing
- distribution and modification of the Modified Version to whoever
- possesses a copy of it. In addition, you must do these things in
- the Modified Version:
-
- A. Use in the Title Page (and on the covers, if any) a title
- distinct from that of the Document, and from those of previous
- versions (which should, if there were any, be listed in the
- History section of the Document). You may use the same title
- as a previous version if the original publisher of that
- version gives permission.
-
- B. List on the Title Page, as authors, one or more persons or
- entities responsible for authorship of the modifications in
- the Modified Version, together with at least five of the
- principal authors of the Document (all of its principal
- authors, if it has fewer than five), unless they release you
- from this requirement.
-
- C. State on the Title page the name of the publisher of the
- Modified Version, as the publisher.
-
- D. Preserve all the copyright notices of the Document.
-
- E. Add an appropriate copyright notice for your modifications
- adjacent to the other copyright notices.
-
- F. Include, immediately after the copyright notices, a license
- notice giving the public permission to use the Modified
- Version under the terms of this License, in the form shown in
- the Addendum below.
-
- G. Preserve in that license notice the full lists of Invariant
- Sections and required Cover Texts given in the Document's
- license notice.
-
- H. Include an unaltered copy of this License.
-
- I. Preserve the section Entitled "History", Preserve its Title,
- and add to it an item stating at least the title, year, new
- authors, and publisher of the Modified Version as given on the
- Title Page. If there is no section Entitled "History" in the
- Document, create one stating the title, year, authors, and
- publisher of the Document as given on its Title Page, then add
- an item describing the Modified Version as stated in the
- previous sentence.
-
- J. Preserve the network location, if any, given in the Document
- for public access to a Transparent copy of the Document, and
- likewise the network locations given in the Document for
- previous versions it was based on. These may be placed in the
- "History" section. You may omit a network location for a work
- that was published at least four years before the Document
- itself, or if the original publisher of the version it refers
- to gives permission.
-
- K. For any section Entitled "Acknowledgements" or "Dedications",
- Preserve the Title of the section, and preserve in the section
- all the substance and tone of each of the contributor
- acknowledgements and/or dedications given therein.
-
- L. Preserve all the Invariant Sections of the Document, unaltered
- in their text and in their titles. Section numbers or the
- equivalent are not considered part of the section titles.
-
- M. Delete any section Entitled "Endorsements". Such a section
- may not be included in the Modified Version.
-
- N. Do not retitle any existing section to be Entitled
- "Endorsements" or to conflict in title with any Invariant
- Section.
-
- O. Preserve any Warranty Disclaimers.
-
- If the Modified Version includes new front-matter sections or
- appendices that qualify as Secondary Sections and contain no
- material copied from the Document, you may at your option designate
- some or all of these sections as invariant. To do this, add their
- titles to the list of Invariant Sections in the Modified Version's
- license notice. These titles must be distinct from any other
- section titles.
-
- You may add a section Entitled "Endorsements", provided it contains
- nothing but endorsements of your Modified Version by various
- parties--for example, statements of peer review or that the text
- has been approved by an organization as the authoritative
- definition of a standard.
-
- You may add a passage of up to five words as a Front-Cover Text,
- and a passage of up to 25 words as a Back-Cover Text, to the end of
- the list of Cover Texts in the Modified Version. Only one passage
- of Front-Cover Text and one of Back-Cover Text may be added by (or
- through arrangements made by) any one entity. If the Document
- already includes a cover text for the same cover, previously added
- by you or by arrangement made by the same entity you are acting on
- behalf of, you may not add another; but you may replace the old
- one, on explicit permission from the previous publisher that added
- the old one.
-
- The author(s) and publisher(s) of the Document do not by this
- License give permission to use their names for publicity for or to
- assert or imply endorsement of any Modified Version.
-
- 5. COMBINING DOCUMENTS
-
- You may combine the Document with other documents released under
- this License, under the terms defined in section 4 above for
- modified versions, provided that you include in the combination all
- of the Invariant Sections of all of the original documents,
- unmodified, and list them all as Invariant Sections of your
- combined work in its license notice, and that you preserve all
- their Warranty Disclaimers.
-
- The combined work need only contain one copy of this License, and
- multiple identical Invariant Sections may be replaced with a single
- copy. If there are multiple Invariant Sections with the same name
- but different contents, make the title of each such section unique
- by adding at the end of it, in parentheses, the name of the
- original author or publisher of that section if known, or else a
- unique number. Make the same adjustment to the section titles in
- the list of Invariant Sections in the license notice of the
- combined work.
-
- In the combination, you must combine any sections Entitled
- "History" in the various original documents, forming one section
- Entitled "History"; likewise combine any sections Entitled
- "Acknowledgements", and any sections Entitled "Dedications". You
- must delete all sections Entitled "Endorsements."
-
- 6. COLLECTIONS OF DOCUMENTS
-
- You may make a collection consisting of the Document and other
- documents released under this License, and replace the individual
- copies of this License in the various documents with a single copy
- that is included in the collection, provided that you follow the
- rules of this License for verbatim copying of each of the documents
- in all other respects.
-
- You may extract a single document from such a collection, and
- distribute it individually under this License, provided you insert
- a copy of this License into the extracted document, and follow this
- License in all other respects regarding verbatim copying of that
- document.
-
- 7. AGGREGATION WITH INDEPENDENT WORKS
-
- A compilation of the Document or its derivatives with other
- separate and independent documents or works, in or on a volume of a
- storage or distribution medium, is called an "aggregate" if the
- copyright resulting from the compilation is not used to limit the
- legal rights of the compilation's users beyond what the individual
- works permit. When the Document is included in an aggregate, this
- License does not apply to the other works in the aggregate which
- are not themselves derivative works of the Document.
-
- If the Cover Text requirement of section 3 is applicable to these
- copies of the Document, then if the Document is less than one half
- of the entire aggregate, the Document's Cover Texts may be placed
- on covers that bracket the Document within the aggregate, or the
- electronic equivalent of covers if the Document is in electronic
- form. Otherwise they must appear on printed covers that bracket
- the whole aggregate.
-
- 8. TRANSLATION
-
- Translation is considered a kind of modification, so you may
- distribute translations of the Document under the terms of section
- 4. Replacing Invariant Sections with translations requires special
- permission from their copyright holders, but you may include
- translations of some or all Invariant Sections in addition to the
- original versions of these Invariant Sections. You may include a
- translation of this License, and all the license notices in the
- Document, and any Warranty Disclaimers, provided that you also
- include the original English version of this License and the
- original versions of those notices and disclaimers. In case of a
- disagreement between the translation and the original version of
- this License or a notice or disclaimer, the original version will
- prevail.
-
- If a section in the Document is Entitled "Acknowledgements",
- "Dedications", or "History", the requirement (section 4) to
- Preserve its Title (section 1) will typically require changing the
- actual title.
-
- 9. TERMINATION
-
- You may not copy, modify, sublicense, or distribute the Document
- except as expressly provided under this License. Any attempt
- otherwise to copy, modify, sublicense, or distribute it is void,
- and will automatically terminate your rights under this License.
-
- However, if you cease all violation of this License, then your
- license from a particular copyright holder is reinstated (a)
- provisionally, unless and until the copyright holder explicitly and
- finally terminates your license, and (b) permanently, if the
- copyright holder fails to notify you of the violation by some
- reasonable means prior to 60 days after the cessation.
-
- Moreover, your license from a particular copyright holder is
- reinstated permanently if the copyright holder notifies you of the
- violation by some reasonable means, this is the first time you have
- received notice of violation of this License (for any work) from
- that copyright holder, and you cure the violation prior to 30 days
- after your receipt of the notice.
-
- Termination of your rights under this section does not terminate
- the licenses of parties who have received copies or rights from you
- under this License. If your rights have been terminated and not
- permanently reinstated, receipt of a copy of some or all of the
- same material does not give you any rights to use it.
-
- 10. FUTURE REVISIONS OF THIS LICENSE
-
- The Free Software Foundation may publish new, revised versions of
- the GNU Free Documentation License from time to time. Such new
- versions will be similar in spirit to the present version, but may
- differ in detail to address new problems or concerns. See
- <http://www.gnu.org/copyleft/>.
-
- Each version of the License is given a distinguishing version
- number. If the Document specifies that a particular numbered
- version of this License "or any later version" applies to it, you
- have the option of following the terms and conditions either of
- that specified version or of any later version that has been
- published (not as a draft) by the Free Software Foundation. If the
- Document does not specify a version number of this License, you may
- choose any version ever published (not as a draft) by the Free
- Software Foundation. If the Document specifies that a proxy can
- decide which future versions of this License can be used, that
- proxy's public statement of acceptance of a version permanently
- authorizes you to choose that version for the Document.
-
- 11. RELICENSING
-
- "Massive Multiauthor Collaboration Site" (or "MMC Site") means any
- World Wide Web server that publishes copyrightable works and also
- provides prominent facilities for anybody to edit those works. A
- public wiki that anybody can edit is an example of such a server.
- A "Massive Multiauthor Collaboration" (or "MMC") contained in the
- site means any set of copyrightable works thus published on the MMC
- site.
-
- "CC-BY-SA" means the Creative Commons Attribution-Share Alike 3.0
- license published by Creative Commons Corporation, a not-for-profit
- corporation with a principal place of business in San Francisco,
- California, as well as future copyleft versions of that license
- published by that same organization.
-
- "Incorporate" means to publish or republish a Document, in whole or
- in part, as part of another Document.
-
- An MMC is "eligible for relicensing" if it is licensed under this
- License, and if all works that were first published under this
- License somewhere other than this MMC, and subsequently
- incorporated in whole or in part into the MMC, (1) had no cover
- texts or invariant sections, and (2) were thus incorporated prior
- to November 1, 2008.
-
- The operator of an MMC Site may republish an MMC contained in the
- site under CC-BY-SA on the same site at any time before August 1,
- 2009, provided the MMC is eligible for relicensing.
-
-ADDENDUM: How to use this License for your documents
-====================================================
-
-To use this License in a document you have written, include a copy of
-the License in the document and put the following copyright and license
-notices just after the title page:
-
- Copyright (C) YEAR YOUR NAME.
- Permission is granted to copy, distribute and/or modify this document
- under the terms of the GNU Free Documentation License, Version 1.3
- or any later version published by the Free Software Foundation;
- with no Invariant Sections, no Front-Cover Texts, and no Back-Cover
- Texts. A copy of the license is included in the section entitled ``GNU
- Free Documentation License''.
-
- If you have Invariant Sections, Front-Cover Texts and Back-Cover
-Texts, replace the "with...Texts." line with this:
-
- with the Invariant Sections being LIST THEIR TITLES, with
- the Front-Cover Texts being LIST, and with the Back-Cover Texts
- being LIST.
-
- If you have Invariant Sections without Cover Texts, or some other
-combination of the three, merge those two alternatives to suit the
-situation.
-
- If your document contains nontrivial examples of program code, we
-recommend releasing these examples in parallel under your choice of free
-software license, such as the GNU General Public License, to permit
-their use in free software.
-
-
-File: wisi.info, Node: Index, Prev: GNU Free Documentation License, Up: Top
-
-Index
-*****
-
-
-
-Tag Table:
-Node: Top920
-Node: Overview1119
-Node: Grammar actions1761
-Node: Navigate actions7174
-Node: Face actions10027
-Node: Indent actions11338
-Node: Indent functions15148
-Node: Indent example17443
-Node: In-parse actions21781
-Node: Project extension23077
-Node: Project files23586
-Node: Selecting projects25006
-Node: Casing exception files29008
-Node: Other project functions29666
-Node: GNU Free Documentation License30424
-Node: Index55580
-
-End Tag Table
-
-
-Local Variables:
-coding: utf-8
-End:
diff --git a/packages/wisi/wisi.texi b/packages/wisi/wisi.texi
deleted file mode 100644
index 3a7d3b3..0000000
--- a/packages/wisi/wisi.texi
+++ /dev/null
@@ -1,812 +0,0 @@
-\input texinfo @c -*-texinfo-*-
-@settitle Wisi
-
-@copying
-Copyright @copyright{} 1999 - 2020 Free Software Foundation, Inc.
-
-@quotation
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.3 or
-any later version published by the Free Software Foundation; with no
-Invariant Sections, with the Front-Cover texts being ``A GNU Manual'',
-and with the Back-Cover Texts as in (a) below. A copy of the license
-is included in the section entitled ``GNU Free Documentation License''.
-
-(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and
-modify this GNU manual. Buying copies from the FSF supports it in
-developing GNU and promoting software freedom.''
-@end quotation
-@end copying
-
-@dircategory Emacs
-@direntry
-* Wisi: (wisi). Error-correcting LR parsers and project integration.
-@end direntry
-
-@titlepage
-@sp 10
-@title Wisi Version 3.1.2
-@page
-@vskip 0pt plus 1filll
-@insertcopying
-@end titlepage
-
-@contents
-
-@ifnottex
-@node Top
-@top Top
-
-Wisi Version 3.1.2
-@end ifnottex
-
-@menu
-* Overview::
-* Grammar actions::
-* Project extension::
-* GNU Free Documentation License::
-* Index::
-@end menu
-
-@node Overview
-@chapter Overview
-``wisi'' used to be an acronym, but now it's just a name.
-
-The wisi package provides an elisp interface to an external parser. It
-assumes the parser generator package WisiToken
-(@url{http://stephe-leake.org/ada/wisitoken.html}, implemented in
-Ada), but can use any parser that meets the same API. wisi provides
-several grammar actions, to implement indentation, navigating, and
-syntax highlighting (fontification).
-
-wisi also provides an extension to Emacs @file{project.el}, providing
-operations useful for compilation and cross-reference.
-
-@node Grammar actions
-@chapter Grammar Actions
-
-Grammar actions are specified in the grammar file, in a nonterminal
-declaration. We assume the user is familiar with parser grammars and
-grammar actions. For example, a simple ``if'' statement can be
-declared as:
-
-@example
-if_statement
- : IF expression THEN statements elsif_list ELSE statements END IF SEMICOLON
- %((wisi-statement-action [1 statement-start 3 motion 6 motion 10
statement-end])
- (wisi-motion-action [1 3 5 6 10])
- (wisi-indent-action [nil
- [(wisi-hanging% ada-indent-broken (* 2
ada-indent-broken))
- ada-indent-broken]
- nil
- [ada-indent ada-indent] nil nil
- [ada-indent ada-indent] nil nil nil]))%
-@end example
-
-The item before @code{:} is the ``left hand side'', or
-``nonterminal''. The list of tokens after @code{:} is the ``right hand
-side''; in general there can be more than one right hand side for each
-nonterminal (separated by @code{|}).
-
-The items enclosed in ``%()%'' are the grammar actions. They are
-specified as list of elisp forms; an earlier version of the wisi
-package generated an elisp parser. We keep the elisp form because it
-is compact, and easier to read and write than the equivalent Ada
-code. The @code{wisi-bnf-generate} tool converts the elisp into the
-required Ada statements.
-
-There are two classes of actions; in-parse and post-parse. WisiToken
-calls these ``semantic checks'' and ``user actions''. The in-parse
-actions are done as parsing procedes; they provide extra checks that
-can cause the parse to fail. Currently the only one provided is
-@code{match-names}; it is used to check that the declaration and end
-names in named Ada blocks are the same (which can aid significantly in
-error correction). In the grammar file, in-parse actions are specified
-in a second @code{%()%} block, which can be omitted if empty. In this
-document, the term ``action'' means ``post-parse action'', we use
-``in-parse action'' unless the meaning is clear from context.
-
-Executing the wisi grammar actions creates text properties in the
-source file; those text properties are then used by elisp code for
-various purposes.
-
-The text properties applied are:
-
-@table @code
-@item wisi-cache
-This should be named @code{wisi-navigate}, but isn't for historical
-reasons (there used to be only one kind of text property).
-
-The property contains a @code{wisi-cache} object, containing:
-
-@table @code
-@item nonterm
-The nonterminal in the grammar production that specified the action
-that produced this text property.
-
-@item token
-A token identifier naming a token in the production right hand side
-containing the text this text property is applied to.
-
-@item last
-The position of the last character in the token, relative to the first
-character (0 indexed). The text property is only applied to the first
-character in the token (mostly for historical reasons).
-
-@item class
-A token class; see the list of possible values in
-@code{wisi-statement-action} below.
-
-@item containing
-A marker pointing to the start of the containing token for this token;
-only @code{nil} for the outermost containing token in a file.
-
-@item prev
-A marker pointing to the previous ``motion token'' in the statement or
-declaration. These are normally language keywords, but can be other
-things.
-
-@item next
-A marker pointing to the next ``motion token'' in the statement or
-declaration.
-
-@item end
-A marker pointing to the end of the statement or declaration.
-
-@end table
-
-wisi provides motion commands for going to the various markers.
-
-@item wisi-name
-Contains no data, applied to a ``name'' of some sort. wisi provides
-commands for finding the next/previous name, and returning the
-text. Useful for the names of subprograms, which can then be used to
-build a completion table; see @code{wisi-xref-identifier-completion-table}.
-
-@item font-lock-face
-The standard font-lock property, specifying the face for the
-text.
-
-Some major modes do not use this for simple keywords; they use
-font-lock regular expressions instead. One reason for this
-is so keywords are still highlighted when the parser fails, which
-can happen if there are severe syntax errors.
-
-Other items, like function and package names, are typically marked
-with @code{font-lock-face} by the parser.
-
-@item fontified
-Another standard font-lock text property; applied whenever
-@code{font-lock-face} is.
-
-@item wisi-indent
-Contains the indent (in characters) for the next line; applied to
-the newline character on the preceding line. The first line in a
-buffer is assumed to have indent 0.
-
-@end table
-
-Each action is classified as one of @code{navigate, face, indent,
-in-parse}; when actions are executed, only one of the first three classes
-is executed (in-parse is always executed). This reflects the reasons
-the parser is run; to figure out how to go somehere (end of current
-statement, start of current procedure, etc), to apply faces for syntax
-highlighting, or to indent the code.
-
-@menu
-* Navigate actions::
-* Face actions::
-* Indent actions::
-* In-parse actions::
-@end menu
-
-@node Navigate actions
-@section Navigate actions
-@table @code
-@item wisi-statement-action [TOKEN CLASS ...]
-The argument is a vector; alternating items are a token index (an
-integer or label indicating a token in the right hand side) and a
-``token class''; one of:
-
-@table @code
-@item motion
-Create a @code{wisi-cache} text property on the token, for use in a
-subsequent @code{wisi-motion-action}.
-
-@item statement-end
-Create a @code{wisi-cache} text property on the token, enter a pointer
-to it in the other @code{wisi-cache} objects in the statement or
-declaration.
-
-@item statement-start
-Create a @code{wisi-cache} text property on the token, enter a pointer
-to it in the other @code{wisi-cache} objects (in the @code{containing}
-slot) in the statement or declaration.
-
-@item statement-override
-Same as @code{statement-start}; marks the token to be used as the
-statement start if the first token is optional.
-
-@item misc
-Create a @code{wisi-cache} text property on the token, to be used for
-some other purpose. It is good style to indicate the purpose in a
-comment.
-
-For example, ada-mode uses a 'misc' property on left parentheses that
-start a subprogram parameter list; this distinquishes them from other
-left parentheses, and makes it possible to automatically call
-@code{ada-format-paramlist} to format the
-parameter list, instead of using the standard Emacs @code{align}.
-
-@end table
-
-@item wisi-motion-action [TOKEN ...]
-The argument is a vector, where each element is either a token index
-or a vector [INDEX ID].
-
-Each terminal token must already have a @code{wisi-cache} created by a
-@code{wisi-statement-action} (this is checked at action execution, not
-during grammar generation). This action sets the @code{prev, next}
-slots for the chain of tokens, creating a chain of motion tokens.
-
-If TOKEN is a nonterminal without an ID specified, the @code{wisi-cache}
-must be on the first token in the nonterminal, and it is assumed to
-have a valid pointer in the @code{next} slot, indicating a chain of
-motion tokens. That chain is linked into the chain for the current
-right hand side.
-
-If TOKEN is a nonterminal with an ID, the region contained by the
-nonterminal is searched for all @code{wisi-cache} with that token ID,
-and for each one where prev/next is not already set, it is linked into
-the motion chain.
-
-Note that the ``search'' described here is done in the parser process, on
-a tree data structure containing the data that will eventually be
-stored in Emacs text properties.
-
-@item wisi-name-action TOKEN
-TOKEN is a token index. Create a @code{wisi-name} text property on the
-token.
-
-@end table
-
-@node Face actions
-@section Face actions
-@table @code
-@item wisi-face-mark-action [INDEX CLASS ...]
-The argument is a vector; alternating elements form pairs of INDEX
-CLASS, where class is one of @code{prefix, suffix}.
-
-Mark the tokens as part of a compound name, for use by later face
-actions.
-
-@item wisi-face-apply-action [TOKEN PREFIX-FACE SUFFIX-FACE ...]
-The argument is a vector; triples of items specify TOKEN,
-PREFIX-FACE, SUFFIX-FACE. The faces are the elisp names of face
-objects (which must declared by an @code{%elisp_face} declaration).
-
-If the token is a nonterminal, and it has been marked by a previous
-@code{wisi-face-mark-action}, the specified faces are applied to the
-prefix and suffix in the token as @code{font-lock-face} text
-properties.
-
-If the token is a terminal, or a non-terminal with no face mark, the
-suffix face is applied to the entire text contained by the token.
-
-@item wisi-face-apply-list-action [TOKEN PREFIX-FACE SUFFIX-FACE ...]
-Similar to ’wisi-face-apply-action’, but applies faces to all tokens
-marked by @code{wisi-face-mark-action} in each indicated production
-token, and does not apply a face if there are no such marks.
-
-@end table
-
-@node Indent actions
-@section Indent actions
-
-Indents are computed for each line in a cumulative way as the grammar
-actions are executed. Initially, each indent is set to @code{nil},
-which means ``not computed''; this is not the same as the value
-@code{0}. The grammar actions are executed in a bottom-up fashion; low
-level productions are executed before higher level ones. In general,
-the indent action for a production specifies a ``delta indent''; the
-indent is incremented by that amount. When all productions have been
-processed, the indent has been computed for all lines.
-
-Indents are often given as a function call; the arguments to the
-function can be other function calls, or integer
-expressions. @code{wisitoken-bnf-generate} supports only simple integer
-expressions; those using integers, integer-valued variables,
-parenthesis, + (plus), - (minus), and * (multiply).
-
-@table @code
-@item wisi-indent-action [INDENT ...]
-The argument is a vector, giving an indent for each token in the
-production right-hand side.
-
-For terminals, the indents only have meaning, and are only computed,
-if the token is the first on a line. For nonterminals where the indent
-is not a variant of @code{wisi-hanging}, the indent is only computed
-if the first terminal token in the nonterminal is the first on a
-line. See @code{wisi-hanging} in @ref{Indent functions} for the
-remaining case.
-
-An indent can have several forms. In the descriptions below, the
-``current token'' is given by the position of the indent expression in
-the @code{wisi-indent-action} argument list.
-
-@table @asis
-@item An integer
-This gives a delta indent; it is added to the total indent for the
-line.
-
-@item A variable name
-The name is translated to an Ada identifier by replacing ``-'' with
-``_'', and applying @code{Camel_Case}. The translated name must
-identify a directly visible run-time Ada integer variable; this is
-checked at Ada compile time. It provides an integer delta indent.
-
-For example, in Ada two indent variable names are @code{ada-indent}
-and @code{ada-indent-broken}, giving the basic ident, and the
-continuation line indent. They are runtime variables so different
-projects can specify them as part of a coding standard.
-
-@item A function call
-A function that computes a delta indent. See @ref{Indent functions}.
-
-@item [CODE-INDENT , COMMENT-INDENT]
-A vector giving separate indents for code and comments.
-
-Normally, the indent for trailing comments (on lines with no code,
-after all code in the token) is given by the indent of the following
-token in the production. When the current token is the last, or the
-following tokens may be empty, or the indent of the following token
-would be wrong for some reason (for example, it is a block end), the
-comment indent may be specified separately. If it is not specified,
-and the indent from the next token is not available, the indent for
-the current token is used for code and comments.
-
-Comment lines that are not trailing are indented by CODE-INDENT.
-
-@item (label . INDENT)
-If token labels are used in a right hand side, they must be given
-explicitly in the indent arguments, using he lisp ``cons''
-syntax. Labels are normally only used with EBNF grammars, which expand
-into multiple right hand sides, with optional tokens simply left
-out. Explicit labels on the indent arguments allow them to be left out
-as well.
-
-@end table
-
-@end table
-
-@menu
-* Indent functions::
-* Indent example::
-@end menu
-
-@node Indent functions
-@subsection Indent functions
-@table @code
-@item wisi-anchored TOKEN OFFSET
-Sets the indent for the current token to be OFFSET (an integer
-expression) from the start of TOKEN (a token index); the
-current token is ``anchored to'' TOKEN.
-
-@item wisi-anchored* TOKEN OFFSET
-Sets the indent for the current token to be OFFSET from the start of
-TOKEN, but only if TOKEN is the first token on a line; otherwise no indent
-
-@item wisi-anchored*- TOKEN OFFSET
-Sets the indent for the current token to be OFFSET from the start of
-TOKEN, but only if TOKEN is the first token on a line and the indent
-for the current token accumulated so far is nil.
-
-@item wisi-anchored% TOKEN OFFSET
-If there is an opening parenthesis containing TOKEN in the line
-containing TOKEN, set the current indent to OFFSET from that
-parenthesis. Otherwise, OFFSET gives an indent delta.
-
-@item wisi-anchored%- TOKEN OFFSET
-Same as @code{wisi-anchored%}, but only if the current token
-accumulated indent is nil.
-
-@item wisi-hanging DELTA-1 DELTA-2
-The current token is assumed to be a nonterminal. If the text it
-contains spans multiple lines, use DELTA-1 for the first line, DELTA-2
-for the rest. If the current token is only on one line, use DELTA-1.
-
-DELTA-1 and DELTA-2 can be any IDENT expression, except a variant of
-@code{wisi-hanging}.
-
-@item wisi-hanging% DELTA-1 DELTA-2
-Similar to @code{wisi-hanging}; if the first terminal token in the
-current nonterminal is the first token on the first line, use DELTA-1
-for the first line and DELTA-2 for the rest. Otherwise, use DELTA-1
-for all lines.
-
-@item wisi-hanging%- DELTA-1 DELTA-2
-Same as @code{wisi-hanging%}, except applied only if the current token
-accumulated indent is nil.
-
-@item Language-specific function
-Language-specific indent functions are specified by an
-@code{%elisp_indent} declaration in the grammar file. Each function
-specifies how many arguments it accepts; this is checked at action
-runtime, not during grammar generation. Each argument is an INDENT as
-described above, or a token ID prefixed by @code{'} (to allow
-distinguishing token IDs from variable names).
-@end table
-
-@node Indent example
-@subsection Indent example
-
-The example @code{if_statement} grammar nonterminal is:
-
-@example
-if_statement
- : IF expression THEN statements elsif_list ELSE statements END IF SEMICOLON
- %((wisi-indent-action [nil
- [(wisi-hanging% ada-indent-broken (* 2
ada-indent-broken))
- ada-indent-broken]
- nil
- [ada-indent ada-indent] nil nil
- [ada-indent ada-indent] nil nil nil]))%
-@end example
-
-We trace how the indent is computed for this sample Ada code:
-
-@example
- 1: if A < B and
- 2: C < D
- 3: -- comment on expression
- 4: then
- 5: if E then
- 6: Do_E;
- 7: -- comment on statement
- 8: elsif F then
- 9: G := A + Compute_Something
-10: (arg_1, arg_2);
-11: end if;
-12: end if;
-@end example
-
-First, the indent for the lower-level nonterminals (@code{expression,
-statements, elsif_list}) are computed. Assume they set the indent for
-line 10 to 2 (for the hanging expression) and leave the rest at nil.
-
-Next, the action for the inner @code{if_statement} is executed. Most
-of the tokens specify an indent of @code{nil}, which means the current
-accumulated indent is not changed. For the others, the action is as
-follows:
-
-@table @code
-@item expression:
-The expression @code{E} is contained on one line, and it is not the
-first token on that line, so the indent for line 5 is not changed.
-
-@item statements: [ada-indent ada-indent]
-This specifies separate indents for code and trailing comments,
-because otherwise the trailing comments would be indented with the
-following @code{THEN}; instead they are indented with the expression
-code; see the comment on line 7.
-
-Here @code{ada-indent} is 3, so the indent for lines 6 and 7 (for the
-first occurence of @code{statments}) is
-incremented from @code{nil} to @code{3}.
-
-For the second occurence of @code{statements}, line 9 is incremented
-from @code{nil} to @code{3}, and line 10 from @code{2} to @code{5}.
-@end table
-
-At this point, the accumulated indents are (the indent is given after
-the line number):
-@example
- 1: nil : if A < B and
- 2: nil : C < D
- 3: nil : -- comment on expression
- 4: nil : then
- 5: nil : if E then
- 6: 3 : Do_E;
- 7: 3 : -- comment on statement
- 8: nil : elsif F then
- 9: 3 : G := A + Compute_Something
-10: 5 : (arg_1, arg_2);
-11: nil : end if;
-12: nil : end if;
-@end example
-
-Then the action is executed for the outer @code{if_statement}:
-
-@table @code
-@item expression: [(wisi-hanging% ada-indent-broken (* 2 ada-indent-broken))
ada-indent-broken]
-This specifies separate indents for code and trailing comments,
-because otherwise the trailing comments would be indented with the
-following @code{THEN}; instead they are indented with the expression
-code; see the comment on line 3.
-
-In this case, @code{wisi-hanging%} returns DELTA-1, which is
-@code{ada-indent-broken}, which is 2. So the indent for line 2 is
-incremented from @code{nil} to @code{2}.
-
-The indent for line 3 is also incremented from @code{nil} to @code{2}.
-
-@item statements: [ada-indent ada-indent]
-Here there is only one statement; the nested @code{if_statement}. The
-indent for lines 5 .. 11 are each incremented by 3.
-@end table
-
-The final result is:
-@example
- 1: nil : if A < B and
- 2: 2 : C < D
- 3: 2 : -- comment on expression
- 4: nil : then
- 5: 3 : if E then
- 6: 6 : Do_E;
- 7: 6 : -- comment on statement
- 8: 3 : elsif F then
- 9: 6 : G := A + Compute_Something
-10: 8 : (arg_1, arg_2);
-11: 6 : end if;
-12: nil : end if;
-@end example
-
-In a full grammar, the top production should specify an indent of 0,
-not nil, for tokens that are not indented; then every line will have a
-non-nil indent. However, in normal operation a nil indent is treated
-as 0; the @code{wisi-indent} text property is not set for lines that
-have nil indent, and @code{wisi-indent-region} detects that and uses 0
-for the indent. You can set the variable @code{wisi-debug} to a value
-> 0 to signal an error for nil indents; this is useful to catch indent
-errors during grammar development.
-
-@node In-parse actions
-@section In-parse actions
-@table @code
-
-@item wisi-propagate-name TOKEN
-The argument is a token index. Set the @code{name} component of the
-left-hand-side parse-time token object to the @code{name} component of
-the identified token, if it is not empty. Otherwise use the
-@code{byte_region} component.
-
-@item wisi-merge-name FIRST-TOKEN, LAST-TOKEN
-The arguments are token indices, giving a range of
-tokens. LAST-TOKEN may be omitted if it is the same as FIRST-TOKEN.
-
-Set the @code{name} component of the left-hand-side to the merger of
-the @code{name} or @code{byte-region} components of the identified tokens.
-
-@item wisi-match-name START-TOKEN END-TOKEN
-The arguments are token indices. Compare the text contained by the
-@code{name} (or @code{byte_region} if @code{name} is empty) token
-components for START-TOKEN and END-TOKEN; signal a parse error if they
-are different.
-
-The behavior when a name is missing is determined by the runtime
-language variable given in the @code{%end_names_optional_option}
-declaration; if True, a missing name that is supposed to match a
-present name is an error. Both names missing is not an error (assuming
-that is allowed by the grammar).
-
-@end table
-
-@node Project extension
-@chapter Project extension
-wisi defines the @code{cl-defstuct} @code{wisi-prj}, with operations
-suitable for compilation and cross-reference.
-
-In order to use wisi projects, the user must write project files and
-customize @code{project-find-functions} and
-@code{xref-backend-functions}.
-
-@menu
-* Project files::
-* Selecting projects::
-* Casing exception files::
-* Other project functions::
-@end menu
-
-@node Project files
-@section Project files
-
-Project file names must have an extension given by
-@code{wisi-prj-file-extensions} (default @file{.adp, .prj}).
-
-Project files have a simple syntax; they may be edited directly. Each
-line specifies a project variable name and its value, separated by
-``='':
-
-@example
-src_dir=/Projects/my_project/src_1
-src_dir=/Projects/my_project/src_2
-@end example
-
-There must be no space between the variable name and ``='', and no
-trailing spaces after the value.
-
-Any line that does not have an ``='' is a comment.
-
-Some variables (like @code{src_dir}) are lists; each line in the
-project file specifies one element of the list. The value on the last
-line is the last element in the list.
-
-A variable name that starts with @code{$} is set as a process
-environment variable, for processes launched from Emacs for the
-project.
-
-In values, process environment variables can be referenced
-using the normal @code{$var} syntax.
-
-In values, relative file names are expanded relative to the
-directory containing the project file.
-
-Here is the list of project variables defined by wisi; major modes may
-add more.
-
-@table @asis
-@item @code{casing} [slot: @code{case-exception-files}]
-List of files containing casing exceptions. @xref{Casing exception files}.
-
-@item @code{src_dir} [slot: @code{source-path}]
-A list of directories to search for source files.
-
-@end table
-
-@node Selecting projects
-@section Selecting projects
-The current project can either be indicated by a global variable
-(called a ``selected project''), or depend on the current buffer.
-
-In addition, the project file can be parsed each time it is needed, or
-the result cached to improve response time,
-
-One reason to use a selected project is to handle a hierarchy of
-projects; if projects B and C both depend on library project A, then
-when in a file of project A, there is no way to determine which of the
-three projects to return. So the user must indicate which is active,
-by using one of @code{wisi-prj-select-file} or
-@code{wisi-prj-select-cache}.
-
-In addition, if changing from one project to another requires setting
-global resources that must also be unset (such as a syntax propertize
-hook or compilation filter hook), then the project should define
-@code{wisi-prj-deselect} in addition to @code{wisi-prj-select}. Such
-projects require having a selected current project, so it can be
-deselected before a new one is selected. One example of such projects
-is ada-mode.
-
-One way to declare each project is to add a Local Variables section
-in the main Makefile for the project; when the Makefile is first
-visited, the project is declared. In the examples here, we assume
-that approach is used; each gives an :eval line.
-
-Note that @code{wisi-prj-current-parse} and
-@code{wisi-prj-current-cached} always succeed after some project is
-selected; no functions after them on @code{project-find-functions} will
-be called. That's why the depth is 90 for those in the examples.
-
-@table @asis
-@item No caching, current project depends on current buffer
-
-@example
-(add-hook 'project-find-functions #'wisi-prj-find-dominating-parse 0)
-
-:eval (wisi-prj-set-dominating "foo.prj" (foo-prj-default "prj-name"))
-@end example
-
-@code{wisi-prj-set-dominating} declares the name of a project file with a
-default project object, and ensures that the current buffer file name
-is in @code{wisi-prj--dominating}.
-
-@code{wisi-prj-find-dominating-parse} looks for the filenames in
-@code{wisi-prj--dominiating} in the parent directories of the current
-buffer. When one is found, the associated project file is parsed,
-using the default project object to dispatch to the appropriate
-parsers. Then the final project object is returned.
-
-@item Caching, current project depends on current buffer
-
-@example
-(add-hook 'project-find-functions #'wisi-prj-find-dominating-cached 0)
-
-:eval (wisi-prj-cache-dominating "foo.prj" (foo-prj-default "prj-name"))
-@end example
-
-@code{wisi-prj-cache-dominating} declares the project file, parses it,
-and saves the project object in a cache indexed by the absolute
-project file name.
-
-@code{wisi-prj-find-dominating-cached} finds the dominating
-project file, and retrieves the object from the cache.
-
-@item No caching, last selected project is current
-
-@example
-(add-hook 'project-find-functions #'wisi-prj-current-parse 90)
-
-:eval: (wisi-prj-select-file <prj-file> (foo-prj-default "prj-name"))
-@end example
-
-@code{wisi-prj-select-file} sets the project file as the current
-project, and saves the default project object.
-
-@code{wisi-prj-current-parse} parses the current project file, using
-the saved default project object, and returns the project object.
-
-@item Caching, last selected project is current
-
-@example
-(add-hook 'project-find-functions #'wisi-prj-current-cached 90)
-
-:eval: (wisi-prj-select-cache <prj-file> (foo-prj-default "prj-name"))
-@end example
-
-@code{wisi-prj-select-cache} parses the project file, caches the
-project object.
-
-@code{wisi-prj-current-cached} returns the cached current project
-object.
-
-@end table
-
-In addition, the user should set @code{xref-backend-functions}. Currently,
-there is only one choice for wisi projects:
-
-@example
-(add-to-list 'xref-backend-functions #'wisi-prj-xref-backend 90)
-@end example
-
-@code{wisi-prj-xref-backend} returns the current wisi project object.
-
-@node Casing exception files
-@section Casing exception files
-Each line in a case exception
-file specifies the casing of one word or word fragment. If an
-exception is defined in multiple files, the first occurrence is used.
-
-If the word starts with an asterisk (@code{*}), it defines the casing
-of a word fragment (or ``substring''); part of a word between two
-underscores or word boundary.
-
-For example:
-
-@example
-DOD
-*IO
-GNAT
-@end example
-
-The word fragment @code{*IO} applies to any word containing ``_io'';
-@code{Text_IO}, @code{Hardware_IO}, etc.
-
-@node Other project functions
-@section Other project functions
-
-@table @code
-@item wisi-refresh-prj-cache (not-full)
-Refreshes all cached data in the project, and re-selects the
-project. If NOT-FULL is non-nil, slow refresh operations are skipped.
-
-This reparses the project file, and any cross reference information.
-
-@item wisi-prj-select-dominating (dominating-file)
- Find a wisi-prj matching DOMINATING-FILE (defaults to the current
-buffer file). If the associated project is current, do nothing. If it
-is not current, select it.
-
-This is useful before running `compilation-start', to ensure the correct
-project is current.
-
-@end table
-
-@node GNU Free Documentation License
-@appendix GNU Free Documentation License
-@include doclicense.texi
-
-@node Index, , GNU Free Documentation License, Top
-@unnumbered Index
-
-@printindex fn
-
-@bye
diff --git a/packages/wisi/wisitoken-bnf-generate.adb
b/packages/wisi/wisitoken-bnf-generate.adb
deleted file mode 100644
index 821ef6f..0000000
--- a/packages/wisi/wisitoken-bnf-generate.adb
+++ /dev/null
@@ -1,634 +0,0 @@
--- Abstract :
---
--- Parser for Wisi grammar files, producing Ada source
--- files for a parser.
---
--- Copyright (C) 2012 - 2015, 2017 - 2020 Free Software Foundation, Inc.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Command_Line;
-with Ada.Directories;
-with Ada.Exceptions;
-with Ada.Real_Time;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Ada.Strings.Unbounded;
-with Ada.Text_IO;
-with GNAT.Traceback.Symbolic;
-with WisiToken.BNF.Generate_Utils;
-with WisiToken.BNF.Output_Ada;
-with WisiToken.BNF.Output_Ada_Common;
-with WisiToken.BNF.Output_Ada_Emacs;
-with WisiToken.BNF.Output_Elisp_Common;
-with WisiToken.Generate.LR.LALR_Generate;
-with WisiToken.Generate.LR.LR1_Generate;
-with WisiToken.Generate.Packrat;
-with WisiToken.Parse.LR.Parser_No_Recover; -- for reading BNF file
-with WisiToken.Productions;
-with WisiToken.Syntax_Trees;
-with WisiToken.Text_IO_Trace;
-with WisiToken_Grammar_Runtime;
-with Wisitoken_Grammar_Actions;
-with Wisitoken_Grammar_Main;
-procedure WisiToken.BNF.Generate
-is
- procedure Put_Usage
- is
- use Ada.Text_IO;
- First : Boolean := True;
- begin
- 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);
- Put_Line (Standard_Error, "The following grammar file directives control
parser generation:");
- Put_Line (Standard_Error,
- "%generate <algorithm> <output language> [<lexer>]
[<interface>] [text_rep]");
- Put_Line (Standard_Error, " specify one of each generate parameter.
May be repeated.");
- Put (Standard_Error, " algorithm: ");
- for I of Generate_Algorithm_Image loop
- if First then
- First := False;
- else
- Put (Standard_Error, " | ");
- end if;
- Put (Standard_Error, I.all);
- end loop;
- New_Line (Standard_Error);
-
- Put (Standard_Error, " output language: ");
- First := True;
- for I of Output_Language_Image loop
- if First then
- First := False;
- else
- Put (Standard_Error, " | ");
- end if;
- Put (Standard_Error, I.all);
- end loop;
- New_Line (Standard_Error);
-
- Put_Line (Standard_Error, " interface: interface Process | Module");
- Put_Line (Standard_Error, " only valid with Ada_Emacs:");
- Put_Line (Standard_Error, " Process is for an external subprocess
communicating with Emacs.");
- Put_Line (Standard_Error, " Module is for a dynamically loaded
Emacs module.");
- Put (Standard_Error, " lexer: ");
- First := True;
- for I of Output_Language_Image loop
- if First then
- First := False;
- else
- Put (Standard_Error, " | ");
- end if;
- Put (Standard_Error, I.all);
- end loop;
- New_Line (Standard_Error);
- Put_Line
- (Standard_Error, " text_rep: output LR parse table in a text file,
not as source code; for large tables");
-
- New_Line (Standard_Error);
- Put_Line (Standard_Error, "options:");
- Put_Line (Standard_Error, " --help: show this help");
-
- -- verbosity meaning is actually determined by output choice;
- -- they should be consistent with this description.
- Put_Line
- (Standard_Error, " -v <EBNF level> <Table level> <Minimal_Complete
level>: sets verbosity (default 0):");
- Put_Line (Standard_Error, " 0 - only error messages to standard
error");
- Put_Line (Standard_Error, " 1 - add diagnostics to standard out");
- Put_Line (Standard_Error, " 2 - more diagnostics to standard out,
ignore unused tokens, unknown conflicts");
- Put_Line (Standard_Error, " --generate ...: override grammar file
%generate directive");
- Put_Line (Standard_Error, " --output_bnf <file_name> : output
translated BNF source to file_name");
- Put_Line (Standard_Error, " --suffix <string>; appended to grammar file
name");
- Put_Line (Standard_Error, " --ignore_conflicts; ignore excess/unknown
conflicts");
- Put_Line (Standard_Error,
- " --test_main; generate standalone main program for running
the generated parser, modify file names");
- Put_Line (Standard_Error, " --time; output execution time of various
stages");
-
- end Put_Usage;
-
- Language_Name : Ada.Strings.Unbounded.Unbounded_String; -- The
language the grammar defines
- Output_File_Name_Root : Ada.Strings.Unbounded.Unbounded_String;
- Suffix : Ada.Strings.Unbounded.Unbounded_String;
- BNF_File_Name : Ada.Strings.Unbounded.Unbounded_String;
- Output_BNF : Boolean := False;
- Ignore_Conflicts : Boolean := False;
- Test_Main : Boolean := False;
-
- Command_Generate_Set : Generate_Set_Access; -- override grammar file
declarations
-
- Trace : aliased WisiToken.Text_IO_Trace.Trace
(Wisitoken_Grammar_Actions.Descriptor'Access);
- Input_Data : aliased WisiToken_Grammar_Runtime.User_Data_Type;
- Grammar_Parser : WisiToken.Parse.LR.Parser_No_Recover.Parser;
-
- procedure Use_Input_File (File_Name : in String)
- is
- use Ada.Strings.Unbounded;
- use Ada.Text_IO;
- begin
- Output_File_Name_Root := +Ada.Directories.Base_Name (File_Name) & Suffix;
-
- Wisitoken_Grammar_Main.Create_Parser
- (Parser => Grammar_Parser,
- Trace => Trace'Unchecked_Access,
- User_Data => Input_Data'Unchecked_Access);
-
- Grammar_Parser.Lexer.Reset_With_File (File_Name);
-
- declare
- Language_Name_Dir : constant Integer := Ada.Strings.Fixed.Index
- (File_Name, Ada.Strings.Maps.To_Set ("/\"), Going =>
Ada.Strings.Backward);
- Language_Name_Ext : constant Integer := Ada.Strings.Fixed.Index
(File_Name, ".wy");
- begin
- Language_Name := +WisiToken.BNF.Output_Elisp_Common.Elisp_Name_To_Ada
- (File_Name
- ((if Language_Name_Dir = 0
- then File_Name'First
- else Language_Name_Dir + 1) ..
- Language_Name_Ext - 1),
- Append_ID => False,
- Trim => 0);
- end;
- exception
- when Name_Error | Use_Error =>
- raise Name_Error with "input file '" & File_Name & "' could not be
opened.";
- end Use_Input_File;
-
-begin
- declare
- use Ada.Command_Line;
- Arg_Next : Integer := 1;
- begin
- loop
- exit when Argument (Arg_Next)(1) /= '-';
-
- -- --help, -v first, then alphabetical
-
- if Argument (Arg_Next) = "--help" then
- Put_Usage;
- return;
-
- elsif Argument (Arg_Next) = "-v" then
- Arg_Next := Arg_Next + 1;
- WisiToken.Trace_Generate_EBNF := Integer'Value (Argument
(Arg_Next));
- Arg_Next := Arg_Next + 1;
- WisiToken.Trace_Generate_Table := Integer'Value (Argument
(Arg_Next));
- Arg_Next := Arg_Next + 1;
- WisiToken.Trace_Generate_Minimal_Complete := Integer'Value
(Argument (Arg_Next));
- Arg_Next := Arg_Next + 1;
-
- elsif Argument (Arg_Next) = "--ignore_conflicts" then
- Ignore_Conflicts := True;
- Arg_Next := Arg_Next + 1;
-
- elsif Argument (Arg_Next) = "--generate" then
- Arg_Next := Arg_Next + 1;
- declare
- Tuple : Generate_Tuple;
- Done : Boolean := False;
- begin
- begin
- Tuple.Gen_Alg := Generate_Algorithm'Value (Argument
(Arg_Next));
- Arg_Next := Arg_Next + 1;
- exception
- when Constraint_Error =>
- raise User_Error with "invalid value for
generator_algorithm: '" & Argument (Arg_Next) & ";";
- end;
- if Tuple.Gen_Alg /= None then
- begin
- Tuple.Out_Lang := To_Output_Language (Argument
(Arg_Next));
- Arg_Next := Arg_Next + 1;
- end;
-
- loop
- exit when Done;
- declare
- Text : constant String := Argument (Arg_Next);
- begin
- if Text = "text_rep" then
- Tuple.Text_Rep := True;
- Arg_Next := Arg_Next + 1;
-
- elsif (for some I of Lexer_Image => To_Lower (Text) =
I.all) then
- Tuple.Lexer := To_Lexer (Text);
- Arg_Next := Arg_Next + 1;
-
- elsif (for some I in Valid_Interface =>
- To_Lower (Text) = To_Lower
(Valid_Interface'Image (I)))
- then
- Tuple.Interface_Kind :=
WisiToken.BNF.Valid_Interface'Value (Text);
- Arg_Next := Arg_Next + 1;
-
- else
- Done := True;
- end if;
- end;
- end loop;
- end if;
- Add (Command_Generate_Set, Tuple);
- end;
-
- elsif Argument (Arg_Next) = "--output_bnf" then
- Output_BNF := True;
- Arg_Next := Arg_Next + 1;
- BNF_File_Name := +Argument (Arg_Next);
- Arg_Next := Arg_Next + 1;
-
- elsif Argument (Arg_Next) = "--suffix" then
- Arg_Next := Arg_Next + 1;
- Suffix := +Argument (Arg_Next);
- Arg_Next := Arg_Next + 1;
-
- elsif Argument (Arg_Next) = "--test_main" then
- Arg_Next := Arg_Next + 1;
- Test_Main := True;
-
- elsif Argument (Arg_Next) = "--time" then
- Arg_Next := Arg_Next + 1;
- WisiToken.Trace_Time := True;
-
- else
- raise User_Error with "invalid argument '" & Argument (Arg_Next) &
"'";
- end if;
- end loop;
-
- Use_Input_File (Argument (Arg_Next));
-
- if Arg_Next /= Argument_Count then
- raise User_Error with "arg count" & Integer'Image (Argument_Count) &
- " different from expected count" & Integer'Image (Arg_Next);
- end if;
- end;
-
- begin
- Grammar_Parser.Parse;
- exception
- when WisiToken.Syntax_Error =>
- Grammar_Parser.Put_Errors;
- raise;
- when E : WisiToken.Parse_Error =>
- WisiToken.Generate.Put_Error (Ada.Exceptions.Exception_Message (E));
- raise;
- end;
-
- declare
- use all type Ada.Strings.Unbounded.Unbounded_String;
- use Ada.Text_IO;
-
- Generate_Set : Generate_Set_Access;
- Multiple_Tuples : Boolean;
-
- Lexer_Done : Lexer_Set := (others => False);
-
- -- In general, all of the data in Generate_Utils.Generate_Data
- -- depends on the generate tuple parameters. However, if
- -- 'If_Lexer_Present' is false, then they don't depend on the lexer,
- -- and if 'If_Parser_Present' is false, then they don't depend on the
- -- Gen_Alg, except for the parser table. But it's not worth trying to
- -- cache results in those cases; they only happen in test grammars,
- -- which are small.
-
- procedure Parse_Check
- (Lexer : in Lexer_Type;
- Parser : in Generate_Algorithm;
- Phase : in WisiToken_Grammar_Runtime.Action_Phase)
- is
- use all type Ada.Containers.Count_Type;
- use all type WisiToken_Grammar_Runtime.Action_Phase;
- use all type WisiToken_Grammar_Runtime.Meta_Syntax;
- begin
- Input_Data.User_Parser := Parser;
- Input_Data.User_Lexer := Lexer;
- -- Specifying the parser and lexer can change the parsed grammar, due
- -- to %if {parser | lexer}.
-
- Input_Data.Reset; -- only resets Other data
-
- Input_Data.Phase := Phase;
- Grammar_Parser.Execute_Actions;
-
- case Phase is
- when Meta =>
- case Input_Data.Meta_Syntax is
- when Unknown =>
- Input_Data.Meta_Syntax := BNF_Syntax;
-
- when BNF_Syntax =>
- null;
-
- when EBNF_Syntax =>
- declare
- Tree : WisiToken.Syntax_Trees.Tree renames
Grammar_Parser.Parsers.First_State_Ref.Tree;
- begin
- if Trace_Generate_EBNF > Outline then
- Ada.Text_IO.Put_Line ("Translate EBNF tree to BNF");
- end if;
-
- if Trace_Generate_EBNF > Detail then
- Ada.Text_IO.Put_Line ("EBNF tree:");
- 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);
-
- 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,
- Image_Action =>
WisiToken_Grammar_Runtime.Image_Grammar_Action'Access);
- end if;
-
- if Output_BNF then
- WisiToken_Grammar_Runtime.Print_Source (-BNF_File_Name,
Tree, Input_Data);
- end if;
-
- if WisiToken.Generate.Error then
- raise WisiToken.Grammar_Error with "errors during
translating EBNF to BNF: aborting";
- end if;
- end;
- end case;
-
- when Other =>
- if Input_Data.Rule_Count = 0 or Input_Data.Tokens.Rules.Length = 0
then
- raise WisiToken.Grammar_Error with "no rules";
- end if;
- end case;
- exception
- when E : WisiToken.Syntax_Error | WisiToken.Parse_Error =>
- Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error,
Ada.Exceptions.Exception_Message (E));
- Grammar_Parser.Put_Errors;
- raise;
- end Parse_Check;
-
- begin
- -- Get the the input file quads, translate EBNF
- Parse_Check (None, None, WisiToken_Grammar_Runtime.Meta);
-
- if Command_Generate_Set = null then
- if Input_Data.Generate_Set = null then
- raise User_Error with
- WisiToken.Generate.Error_Message
- (Input_Data.Grammar_Lexer.File_Name, 1,
- "generate algorithm, output_language, lexer, interface not
specified");
- end if;
-
- Generate_Set := Input_Data.Generate_Set;
- else
- Generate_Set := Command_Generate_Set;
- end if;
-
- Multiple_Tuples := Generate_Set'Length > 1;
-
- for Tuple of Generate_Set.all loop
- Parse_Check
- (Lexer => Tuple.Lexer,
- Parser => Tuple.Gen_Alg,
- Phase => WisiToken_Grammar_Runtime.Other);
-
- declare
- use Ada.Real_Time;
-
- Time_Start : Time;
- Time_End : Time;
-
- Generate_Data : aliased WisiToken.BNF.Generate_Utils.Generate_Data
:=
- WisiToken.BNF.Generate_Utils.Initialize (Input_Data,
Ignore_Conflicts);
-
- Packrat_Data : WisiToken.Generate.Packrat.Data
- (Generate_Data.Descriptor.First_Terminal,
Generate_Data.Descriptor.First_Nonterminal,
- Generate_Data.Descriptor.Last_Nonterminal);
-
- Parse_Table_File_Name : constant String :=
- (if WisiToken.Trace_Generate_Table = 0 and Tuple.Gen_Alg in LALR
.. Packrat_Proc
- then -Output_File_Name_Root & "_" & To_Lower
(Generate_Algorithm'Image (Tuple.Gen_Alg)) &
- (if Input_Data.If_Lexer_Present
- then "_" & Lexer_Image (Input_Data.User_Lexer).all
- else "") &
- ".parse_table"
- else "");
-
- procedure Parse_Table_Append_Stats
- is
- Parse_Table_File : File_Type;
- begin
- Open (Parse_Table_File, Append_File, Parse_Table_File_Name);
- Set_Output (Parse_Table_File);
- Generate_Data.Parser_State_Count :=
- Generate_Data.LR_Parse_Table.State_Last -
Generate_Data.LR_Parse_Table.State_First + 1;
- WisiToken.BNF.Generate_Utils.Put_Stats (Input_Data,
Generate_Data);
- Set_Output (Standard_Output);
- Close (Parse_Table_File);
- end Parse_Table_Append_Stats;
-
- begin
- if not Lexer_Done (Input_Data.User_Lexer) then
- Lexer_Done (Input_Data.User_Lexer) := True;
- case Input_Data.User_Lexer is
- when re2c_Lexer =>
- WisiToken.BNF.Output_Ada_Common.Create_re2c
- (Input_Data, Tuple, Generate_Data, -Output_File_Name_Root);
- when others =>
- null;
- end case;
- end if;
-
- case Tuple.Gen_Alg is
- when None =>
- -- Just translate EBNF to BNF, done in Parse_Check
- null;
-
- when LALR =>
-
- Time_Start := Clock;
-
- 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;
- end if;
- end if;
-
- when LR1 =>
- Time_Start := Clock;
-
- 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;
- end if;
- end if;
-
- when Packrat_Generate_Algorithm =>
- -- The only significant computation done for Packrat is First,
done
- -- in Initialize; not worth timing.
-
- Packrat_Data := WisiToken.Generate.Packrat.Initialize
- (Input_Data.Grammar_Lexer.File_Name, Generate_Data.Grammar,
Generate_Data.Source_Line_Map,
- Generate_Data.Descriptor.First_Terminal);
-
- if Parse_Table_File_Name /= "" then
- declare
- Parse_Table_File : File_Type;
- begin
- Create (Parse_Table_File, Out_File,
Parse_Table_File_Name);
- Set_Output (Parse_Table_File);
- Put_Line ("Tokens:");
- WisiToken.Put_Tokens (Generate_Data.Descriptor.all);
- New_Line;
- Put_Line ("Productions:");
- WisiToken.Productions.Put (Generate_Data.Grammar,
Generate_Data.Descriptor.all);
- Set_Output (Standard_Output);
- Close (Parse_Table_File);
- end;
- end if;
-
- Packrat_Data.Check_All (Generate_Data.Descriptor.all);
-
- when External =>
- null;
- end case;
-
- if WisiToken.Generate.Error then
- raise WisiToken.Grammar_Error with "errors: aborting";
- end if;
-
- case Tuple.Gen_Alg is
- when LR_Generate_Algorithm =>
- if Tuple.Text_Rep then
- WisiToken.Generate.LR.Put_Text_Rep
- (Generate_Data.LR_Parse_Table.all,
- -Output_File_Name_Root & "_" &
- To_Lower (Generate_Algorithm_Image (Tuple.Gen_Alg).all)
&
- "_parse_table.txt",
- Generate_Data.Action_Names.all,
Generate_Data.Check_Names.all);
- end if;
-
- when others =>
- null;
- end case;
-
- if Tuple.Gen_Alg /= None then
- case Tuple.Out_Lang is
- when Ada_Lang =>
- WisiToken.BNF.Output_Ada
- (Input_Data, -Output_File_Name_Root, Generate_Data,
Packrat_Data, Tuple, Test_Main,
- Multiple_Tuples);
-
- when Ada_Emacs_Lang =>
- WisiToken.BNF.Output_Ada_Emacs
- (Input_Data, -Output_File_Name_Root, Generate_Data,
Packrat_Data, Tuple,
- Test_Main, Multiple_Tuples, -Language_Name);
-
- end case;
- if WisiToken.Generate.Error then
- raise WisiToken.Grammar_Error with "errors: aborting";
- end if;
- end if;
- end;
- end loop;
- end;
-exception
-when WisiToken.Syntax_Error | WisiToken.Parse_Error =>
- -- error message already output
- Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
-
-when E : User_Error =>
- declare
- use Ada.Command_Line;
- use Ada.Exceptions;
- use Ada.Text_IO;
- begin
- Put_Line (Standard_Error, Exception_Message (E));
- Put_Command_Line (Ada_Comment);
- Set_Exit_Status (Failure);
- Put_Usage;
- end;
-
-when E : WisiToken.Grammar_Error =>
- -- error message not already output
- declare
- use Ada.Command_Line;
- use Ada.Exceptions;
- use Ada.Text_IO;
- begin
- Put_Line (Standard_Error, Exception_Message (E));
- Set_Exit_Status (Failure);
- end;
-
-when E : others =>
- -- IMPROVEME: for some exceptions, Error message already output via
wisi.utils.Put_Error
- declare
- use Ada.Text_IO;
- use Ada.Exceptions;
- use Ada.Command_Line;
- begin
- Put_Line (Standard_Error, Exception_Name (E) & ": " & Exception_Message
(E));
- Put_Line (Standard_Error, GNAT.Traceback.Symbolic.Symbolic_Traceback
(E));
- Set_Exit_Status (Failure);
- end;
-
-end WisiToken.BNF.Generate;
diff --git a/packages/wisi/wisitoken-bnf-generate_grammar.adb
b/packages/wisi/wisitoken-bnf-generate_grammar.adb
deleted file mode 100644
index cd165c4..0000000
--- a/packages/wisi/wisitoken-bnf-generate_grammar.adb
+++ /dev/null
@@ -1,86 +0,0 @@
--- Abstract :
---
--- Output Ada source code to recreate Grammar.
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Text_IO; use Ada.Text_IO;
-with WisiToken.Generate;
-with WisiToken.Productions;
-procedure WisiToken.BNF.Generate_Grammar
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Action_Names : in WisiToken.Names_Array_Array)
-is
- use all type Ada.Containers.Count_Type;
- use Ada.Strings.Unbounded;
- use WisiToken.Generate;
- use WisiToken.Productions;
- Text : Unbounded_String;
- Need_Comma : Boolean := False;
-begin
- Indent_Line
- ("Grammar.Set_First_Last (" & Trimmed_Image (Grammar.First_Index) & ", " &
- Trimmed_Image (Grammar.Last_Index) & ");");
-
- for Prod of Grammar loop
- Indent_Line ("declare");
- Indent_Line (" Prod : Instance;");
- Indent_Line ("begin");
- Indent := Indent + 3;
- Indent_Line ("Prod.LHS := " & Trimmed_Image (Prod.LHS) & ";");
- Indent_Line ("Prod.RHSs.Set_First_Last (0, " & Trimmed_Image
(Prod.RHSs.Last_Index) & ");");
- for RHS_Index in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
- declare
- RHS : Right_Hand_Side renames Prod.RHSs (RHS_Index);
- begin
- Indent_Line ("declare");
- Indent_Line (" RHS : Right_Hand_Side;");
- Indent_Line ("begin");
- Indent := Indent + 3;
- if RHS.Tokens.Length > 0 then
- Indent_Line
- ("RHS.Tokens.Set_First_Last (1, " & Trimmed_Image (Prod.RHSs
(RHS_Index).Tokens.Last_Index) & ");");
-
- if RHS.Tokens.Length = 1 then
- Indent_Line ("To_Vector ((1 => " & Trimmed_Image (RHS.Tokens
(1)) & "), RHS.Tokens);");
- else
- Need_Comma := False;
- Text := +"To_Vector ((";
- for ID of RHS.Tokens loop
- if Need_Comma then
- Text := Text & ", ";
- else
- Need_Comma := True;
- end if;
- Text := Text & Trimmed_Image (ID);
- end loop;
- Text := Text & "), RHS.Tokens);";
- Indent_Wrap (-Text);
- end if;
- end if;
- if Action_Names (Prod.LHS) /= null and then Action_Names
(Prod.LHS)(RHS_Index) /= null then
- Indent_Line ("RHS.Action := " & Action_Names
(Prod.LHS)(RHS_Index).all & "'Access;");
- end if;
- Indent_Line ("Prod.RHSs (" & Trimmed_Image (RHS_Index) & ") :=
RHS;");
- Indent := Indent - 3;
- Indent_Line ("end;");
- end;
- end loop;
- Indent_Line ("Grammar (" & Trimmed_Image (Prod.LHS) & ") := Prod;");
- Indent := Indent - 3;
- Indent_Line ("end;");
- end loop;
-end WisiToken.BNF.Generate_Grammar;
diff --git a/packages/wisi/wisitoken-bnf-generate_packrat.adb
b/packages/wisi/wisitoken-bnf-generate_packrat.adb
deleted file mode 100644
index b4592e5..0000000
--- a/packages/wisi/wisitoken-bnf-generate_packrat.adb
+++ /dev/null
@@ -1,333 +0,0 @@
--- Abstract :
---
--- Generate Ada code for a Packrat parser.
---
--- References:
---
--- See wisitoken-parse-packrat.ads.
---
--- Copyright (C) 2018, 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Text_IO; use Ada.Text_IO;
-with WisiToken.BNF.Generate_Utils;
-with WisiToken.Generate.Packrat;
-with WisiToken.Productions;
-procedure WisiToken.BNF.Generate_Packrat
- (Data : in WisiToken.Generate.Packrat.Data;
- Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data)
-is
- use WisiToken.Generate;
-
- Descriptor : WisiToken.Descriptor renames Generate_Data.Descriptor.all;
- Action_Names : Names_Array_Array renames Generate_Data.Action_Names.all;
-
- subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
-
- -- FIXME: optimize memoizing? small productions not worth the memory cost?
- -- or just use langkit space optimization.
-
- function Parser_Name (Nonterm : in Token_ID) return String
- is begin
- return "Parse_" & Image (Nonterm, Descriptor);
- end Parser_Name;
-
- procedure Put_Parser_Spec (Name : in String)
- is begin
- Indent_Line ("function " & Name);
- Indent_Start (" (Parser : in out Generated.Parser; Last_Pos : in
Base_Token_Index) return Result_Type");
- end Put_Parser_Spec;
-
- function Var_Suffix (I, J : in Integer) return String
- is begin
- return Trimmed_Image (I) & '_' & Trimmed_Image (J);
- end Var_Suffix;
-
- procedure Generate_Parser_Body (Prod : in Productions.Instance)
- is
- use all type Ada.Containers.Count_Type;
-
- Result_ID : constant String := Trimmed_Image (Prod.LHS);
- begin
- -- We use gotos and function scope vars rather than nested if/declare
- -- to avoid excessive indenting for long productions.
-
- Put_Parser_Spec (Parser_Name (Prod.LHS)); New_Line;
- Indent_Line ("is");
- Indent := Indent + 3;
-
- Indent_Line ("Descriptor : WisiToken.Descriptor renames
Parser.Trace.Descriptor.all;");
- Indent_Line ("Start_Pos : constant Token_Index := Last_Pos + 1; --
first token in current nonterm");
- Indent_Line ("Pos : Base_Token_Index := Last_Pos; -- last token
parsed.");
-
- for RHS_Index in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
- declare
- RHS : Productions.Right_Hand_Side renames Prod.RHSs (RHS_Index);
- begin
- for Token_Index in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index
loop
- if RHS.Tokens (Token_Index) in Descriptor.First_Terminal ..
Descriptor.Last_Terminal then
- Indent_Line ("Pos_" & Var_Suffix (RHS_Index, Token_Index) &
" : Token_Index;");
- else
- Indent_Line ("Memo_" & Var_Suffix (RHS_Index, Token_Index) &
" : Memo_Entry;");
- end if;
- end loop;
- end;
- end loop;
-
- if Data.Direct_Left_Recursive (Prod.LHS) then
- Indent_Line ("Pos_Recurse_Last : Base_Token_Index := Last_Pos;");
- Indent_Line ("Result_Recurse : Memo_Entry;");
- end if;
-
- Indent := Indent - 3;
- Indent_Line ("begin");
- Indent := Indent + 3;
-
- Indent_Line ("if Pos = Parser.Terminals.Last_Index then");
- Indent_Line (" return (State => Failure);");
- Indent_Line ("end if;");
- Indent_Line ("declare");
- Indent_Line (" Memo : Memo_Entry renames Parser.Derivs (" & Result_ID
& ")(Start_Pos);");
- Indent_Line ("begin");
- Indent := Indent + 3;
- Indent_Line ("case Memo.State is");
- Indent_Line ("when Success =>");
- Indent_Line (" return Parser.Derivs (" & Result_ID & ")(Start_Pos);");
- Indent_Line ("when Failure =>");
-
- -- FIXME: Could simplify this when not doing left recursion
- Indent_Line (" goto RHS_" & Trimmed_Image (Prod.RHSs.Last_Index) &
"_Fail;");
-
- Indent_Line ("when No_Result =>");
- Indent_Line (" if Memo.Recursive then");
- Indent_Start (" raise Recursive with Image (" & Result_ID & ",
Descriptor) &");
- Put_Line (" Token_Index'Image (Start_Pos) & "": recursive"";");
- Indent_Line (" end if;");
- Indent_Line (" Memo.Recursive := True;");
- Indent_Line ("end case;");
- Indent := Indent - 3;
- Indent_Line ("end;");
- New_Line;
-
- if Data.Direct_Left_Recursive (Prod.LHS) then
- -- This is the top of the 'while' loop in [warth 2008] figure 3
Grow-LR.
- Indent_Line ("Parser.Derivs (" & Result_ID & ").Replace_Element
(Start_Pos, (State => Failure));");
- Indent_Line ("<<Recurse_Start>>");
- end if;
-
- for RHS_Index in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
- declare
- RHS : Productions.Right_Hand_Side renames Prod.RHSs (RHS_Index);
-
- procedure Finish
- is begin
- if Data.Direct_Left_Recursive (Prod.LHS) then
- Indent_Line ("Result_Recurse :=");
- Indent := Indent + 2;
- else
- Indent_Line ("Parser.Derivs (" & Result_ID &
").Replace_Element");
- Indent_Line (" (Start_Pos,");
- Indent := Indent + 3;
- end if;
- Indent_Line ("(State => Success,");
- Indent_Line (" Result => Parser.Tree.Add_Nonterm");
-
- Indent := Indent + 3;
- Indent_Line ("(Production => (" & Result_ID & ", " &
Trimmed_Image (RHS_Index) & "),");
- Indent_Line
- (" Action => " &
- (if Action_Names (Prod.LHS) = null or else Action_Names
(Prod.LHS)(RHS_Index) = null
- then "null,"
- else Action_Names (Prod.LHS)(RHS_Index).all &
"'Access,"));
-
- if RHS.Tokens.Length = 0 then
- Indent_Line (" Children => (1 .. 0 =>
Invalid_Node_Index),");
-
- elsif RHS.Tokens.Length = 1 then
- Indent_Start (" Children => ");
- if RHS.Tokens (RHS.Tokens.First_Index) in Terminal then
- Put ("(1 => Tree_Index (Pos_" & Var_Suffix (RHS_Index,
RHS.Tokens.First_Index) & ")),");
- else
- Put ("(1 => Memo_" & Var_Suffix (RHS_Index,
RHS.Tokens.First_Index) & ".Result),");
- end if;
-
- else
- Indent_Line (" Children =>");
-
- for Token_Index in RHS.Tokens.First_Index ..
RHS.Tokens.Last_Index loop
- if RHS.Tokens (Token_Index) in Terminal then
- Indent_Start
- ((if Token_Index = RHS.Tokens.First_Index
- then " ("
- else " ") &
- "Tree_Index (Pos_" & Var_Suffix (RHS_Index,
Token_Index) & ")");
- else
- Indent_Start
- ((if Token_Index = RHS.Tokens.First_Index
- then " ("
- else " ") &
- "Memo_" & Var_Suffix (RHS_Index, Token_Index) &
".Result");
- end if;
- if Token_Index = RHS.Tokens.Last_Index then
- Put_Line ("),");
- else
- Put_Line (",");
- end if;
- end loop;
- end if;
-
- Indent_Line (" Default_Virtual => False),");
- Indent := Indent - 3;
- Indent_Start (" Last_Token => Pos)");
-
- if Data.Direct_Left_Recursive (Prod.LHS) then
- Put_Line (";");
- Indent := Indent - 2;
- Indent_Line ("goto Finish;");
- else
- Put_Line (");");
- Indent := Indent - 3;
- Indent_Line ("goto Succeed;");
- end if;
- end Finish;
-
- begin
- Indent_Wrap_Comment (Productions.Image (Prod.LHS, RHS_Index,
RHS.Tokens, Descriptor), Ada_Comment);
- Indent_Line ("Pos := Last_Pos;");
-
- if RHS.Tokens.Length = 0 then
- Finish;
- else
- for Token_Index in RHS.Tokens.First_Index ..
RHS.Tokens.Last_Index loop
- declare
- ID : constant String := Trimmed_Image (RHS.Tokens
(Token_Index));
- Var_Suf : constant String := Var_Suffix (RHS_Index,
Token_Index);
- begin
- if RHS.Tokens (Token_Index) in Terminal then
- Indent_Line ("if Parser.Terminals (Pos + 1).ID = " &
ID & " then");
- Indent := Indent + 3;
- Indent_Line ("Pos := Pos + 1;");
- Indent_Line ("Pos_" & Var_Suf & " := Pos;");
- if Token_Index = RHS.Tokens.Last_Index then
- Finish;
- end if;
- Indent := Indent - 3;
- Indent_Line ("else");
- Indent_Line (" goto RHS_" & Trimmed_Image
(RHS_Index) & "_Fail;");
- Indent_Line ("end if;");
-
- else -- nonterminal
- Indent_Line
- ("Memo_" & Var_Suf & " := Parse_" & Image
(RHS.Tokens (Token_Index), Descriptor) &
- " (Parser, Pos);");
- Indent_Line ("case Result_States'(Memo_" & Var_Suf &
".State) is");
- Indent_Line ("when Success =>");
- Indent := Indent + 3;
- Indent_Line ("Pos := Memo_" & Var_Suf &
".Last_Token;");
- if Token_Index = RHS.Tokens.Last_Index then
- Finish;
- end if;
- Indent := Indent - 3;
- Indent_Line ("when Failure =>");
- Indent_Line (" goto RHS_" & Trimmed_Image
(RHS_Index) & "_Fail;");
- Indent_Line ("end case;");
- end if;
- end;
- end loop;
- end if;
-
- Indent_Line ("<<RHS_" & Trimmed_Image (RHS_Index) & "_Fail>>");
- New_Line;
- end;
- end loop;
-
- -- We get here if the last alternative fails.
- if Data.Direct_Left_Recursive (Prod.LHS) then
- Indent_Line ("Result_Recurse := (State => Failure);");
- else
- Indent_Line ("Parser.Derivs (" & Result_ID & ").Replace_Element
(Start_Pos, (State => Failure));");
- Indent_Line ("return Parser.Derivs (" & Result_ID & ")(Start_Pos);");
- end if;
-
- if Data.Direct_Left_Recursive (Prod.LHS) then
- Indent_Line ("<<Finish>>");
- Indent_Line ("if Result_Recurse.State = Success then");
- Indent := Indent + 3;
- Indent_Line ("if Pos > Pos_Recurse_Last then");
- -- made progress, try again
- Indent := Indent + 3;
- Indent_Line ("Parser.Derivs (" & Result_ID & ").Replace_Element
(Start_Pos, Result_Recurse);");
- Indent_Line ("Pos_Recurse_Last := Pos;");
- Indent_Line ("if WisiToken.Trace_Parse > Detail then");
- Indent_Line (" Parser.Trace.Put_Line");
- Indent_Line
- (" (Parser.Tree.Image (Result_Recurse.Result, Descriptor,
Include_Children => True));");
- Indent_Line ("end if;");
- Indent_Line ("goto Recurse_Start;");
- Indent := Indent - 3;
- Indent_Line
- ("elsif Pos = Pos_Recurse_Last and then " &
- "Parser.Tree.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 (" & Result_ID & ").Replace_Element
(Start_Pos, Result_Recurse);");
- Indent_Line ("end if;");
- Indent := Indent - 3;
- Indent_Line ("end if;");
- end if;
- New_Line;
-
- if not Data.Direct_Left_Recursive (Prod.LHS) then
- Indent_Line ("<<Succeed>>");
- Indent_Line ("if WisiToken.Trace_Parse > Detail then");
- Indent := Indent + 3;
- Indent_Line ("Parser.Trace.Put_Line");
- Indent_Line (" (Parser.Tree.Image");
- Indent_Line
- (" (Parser.Derivs (" & Result_ID & ")(Start_Pos).Result,
Descriptor, Include_Children => True));");
- Indent := Indent - 3;
- Indent_Line ("end if;");
- end if;
-
- Indent_Line ("return Parser.Derivs (" & Result_ID & ")(Start_Pos);");
- Indent := Indent - 3;
- Indent_Line ("end " & Parser_Name (Prod.LHS) & ";");
- New_Line;
- end Generate_Parser_Body;
-
-begin
- Indent_Line ("use WisiToken;");
- Indent_Line ("use WisiToken.Parse.Packrat;");
- Indent_Line ("use WisiToken.Parse.Packrat.Generated;");
-
- for Prod of Data.Grammar loop
- Put_Parser_Spec (Parser_Name (Prod.LHS)); Put_Line (";");
- end loop;
- New_Line;
-
- for Prod of Data.Grammar loop
- Generate_Parser_Body (Prod);
- end loop;
-
- Indent_Line ("function Parse_wisitoken_accept_1");
- Indent_Line
- -- WORKAROUND: using Parse.Packrat.Parser'Class here generates GNAT bug
box with GPL 2018
- (" (Parser : in out WisiToken.Parse.Base_Parser'Class; Last_Pos : in
Base_Token_Index) return Result_Type");
- Indent_Line ("is begin");
- Indent_Line (" return Parse_wisitoken_accept (Generated.Parser (Parser),
Last_Pos);");
- Indent_Line ("end Parse_wisitoken_accept_1;");
- New_Line;
-
-end WisiToken.BNF.Generate_Packrat;
diff --git a/packages/wisi/wisitoken-bnf-generate_utils.adb
b/packages/wisi/wisitoken-bnf-generate_utils.adb
deleted file mode 100644
index b5622d0..0000000
--- a/packages/wisi/wisitoken-bnf-generate_utils.adb
+++ /dev/null
@@ -1,724 +0,0 @@
--- Abstract :
---
--- see spec
---
--- Copyright (C) 2014, 2015, 2017 - 2020 All Rights Reserved.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Exceptions;
-with Ada.Text_IO;
-with WisiToken.Generate; use WisiToken.Generate;
-with WisiToken.Syntax_Trees;
-with WisiToken.Wisi_Ada;
-package body WisiToken.BNF.Generate_Utils is
-
- -- For Constant_Reference
- Aliased_EOI_Name : aliased constant
Ada.Strings.Unbounded.Unbounded_String := +EOI_Name;
- Aliased_WisiToken_Accept_Name : aliased constant
Ada.Strings.Unbounded.Unbounded_String :=
- +WisiToken_Accept_Name;
-
- -- body specs, as needed.
-
- ----------
- -- Body subprograms
-
- function Find_Kind (Data : aliased Generate_Data; Target_Kind : in String)
return Token_ID
- is begin
- for Cursor in All_Tokens (Data).Iterate loop
- if Kind (Cursor) = Target_Kind then
- return ID (Cursor);
- end if;
- end loop;
- return Invalid_Token_ID;
- end Find_Kind;
-
- function Name_1 (Cursor : in Token_Cursor) return String
- is begin
- -- This function is used to compute Descriptor.Image
- case Cursor.Kind is
- when Non_Grammar_Kind =>
- return -Cursor.Data.Tokens.Non_Grammar (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Name;
-
- when Terminals_Keywords =>
- return -Cursor.Data.Tokens.Keywords (Cursor.Keyword).Name;
-
- when Terminals_Others =>
- return -Cursor.Data.Tokens.Tokens (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Name;
-
- when EOI =>
- return EOI_Name;
-
- when WisiToken_Accept =>
- return WisiToken_Accept_Name;
-
- when Nonterminal =>
- return -Cursor.Data.Tokens.Rules (Cursor.Nonterminal).Left_Hand_Side;
-
- when Done =>
- raise SAL.Programmer_Error with "token cursor is done";
- end case;
- end Name_1;
-
- procedure To_Grammar
- (Data : aliased in out Generate_Data;
- Source_File_Name : in String;
- Start_Token : in String)
- is
- use WisiToken.Wisi_Ada;
- Descriptor : WisiToken.Descriptor renames Data.Descriptor.all;
- begin
- Data.Grammar.Set_First_Last (Descriptor.First_Nonterminal,
Descriptor.Last_Nonterminal);
- Data.Source_Line_Map.Set_First_Last (Descriptor.First_Nonterminal,
Descriptor.Last_Nonterminal);
-
- Data.Action_Names := new Names_Array_Array (Descriptor.First_Nonterminal
.. Descriptor.Last_Nonterminal);
- Data.Check_Names := new Names_Array_Array (Descriptor.First_Nonterminal
.. Descriptor.Last_Nonterminal);
-
- pragma Assert (Descriptor.Accept_ID = Descriptor.First_Nonterminal);
-
- 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
- RHS_Index : Natural := 0;
- RHSs : WisiToken.Productions.RHS_Arrays.Vector;
- LHS : Token_ID; -- not initialized for exception
handler
- Action_Names : Names_Array (0 .. Integer
(Rule.Right_Hand_Sides.Length) - 1);
- Action_All_Empty : Boolean := True;
- Check_Names : Names_Array (0 .. Integer
(Rule.Right_Hand_Sides.Length) - 1);
- Check_All_Empty : Boolean := True;
- begin
- LHS := Find_Token_ID (Data, -Rule.Left_Hand_Side);
-
- RHSs.Set_First_Last (RHS_Index, Natural
(Rule.Right_Hand_Sides.Length) - 1);
-
- Data.Source_Line_Map (LHS).Line := Rule.Source_Line;
- Data.Source_Line_Map (LHS).RHS_Map.Set_First_Last
(RHSs.First_Index, RHSs.Last_Index);
-
- for Right_Hand_Side of Rule.Right_Hand_Sides loop
- declare
- use Ada.Strings.Unbounded;
- use all type Ada.Containers.Count_Type;
- Tokens : WisiToken.Token_ID_Arrays.Vector;
- I : Integer := 1;
- begin
- if Right_Hand_Side.Tokens.Length > 0 then
- Tokens.Set_First_Last (I, Integer
(Right_Hand_Side.Tokens.Length));
- for Token of Right_Hand_Side.Tokens loop
- Tokens (I) := Find_Token_ID (Data, -Token.Identifier);
- I := I + 1;
- end loop;
- end if;
- RHSs (RHS_Index) :=
- (Tokens => Tokens, Action => null, Check => null,
Recursion => <>);
- if Length (Right_Hand_Side.Action) > 0 then
- Action_All_Empty := False;
- Action_Names (RHS_Index) := new String'
- (-Rule.Left_Hand_Side & '_' & WisiToken.Trimmed_Image
(RHS_Index));
- end if;
- if Length (Right_Hand_Side.Check) > 0 then
- Check_All_Empty := False;
- Check_Names (RHS_Index) := new String'
- (-Rule.Left_Hand_Side & '_' & WisiToken.Trimmed_Image
(RHS_Index) & "_check");
- end if;
-
- Data.Source_Line_Map (LHS).RHS_Map (RHS_Index) :=
Right_Hand_Side.Source_Line;
- exception
- when E : Not_Found =>
- -- From "&"
- Put_Error
- (Error_Message
- (Source_File_Name, Right_Hand_Side.Source_Line,
Ada.Exceptions.Exception_Message (E)));
- end;
- RHS_Index := RHS_Index + 1;
- end loop;
-
- Data.Grammar (LHS) := LHS <= RHSs;
- if not Action_All_Empty then
- Data.Action_Names (LHS) := new Names_Array'(Action_Names);
- end if;
- if not Check_All_Empty then
- Data.Check_Names (LHS) := new Names_Array'(Check_Names);
- end if;
-
- exception
- when E : Not_Found =>
- -- From Find_Token_ID (left_hand_side)
- Put_Error
- (Error_Message
- (Source_File_Name, Rule.Source_Line,
Ada.Exceptions.Exception_Message (E)));
- end;
- end loop;
-
- WisiToken.Generate.Check_Consistent (Data.Grammar, Descriptor,
Source_File_Name);
- end To_Grammar;
-
- ----------
- -- Public subprograms, declaration order
-
- function Initialize
- (Input_Data : aliased in WisiToken_Grammar_Runtime.User_Data_Type;
- Ignore_Conflicts : in Boolean := False)
- return Generate_Data
- is
- EOI_ID : constant Token_ID := Token_ID
- (Count (Input_Data.Tokens.Non_Grammar) + Count
(Input_Data.Tokens.Tokens)) + Token_ID
- (Input_Data.Tokens.Keywords.Length) + Token_ID'First;
- begin
- return Result : aliased Generate_Data :=
- (Tokens => Input_Data.Tokens'Access,
-
- Descriptor => new WisiToken.Descriptor
- (First_Terminal =>
- (if Count (Input_Data.Tokens.Non_Grammar) > 0
- then Token_ID (Count (Input_Data.Tokens.Non_Grammar)) +
Token_ID'First
- else Token_ID'First),
- Last_Terminal => EOI_ID,
- EOI_ID => EOI_ID,
- Accept_ID => EOI_ID + 1,
- First_Nonterminal => EOI_ID + 1,
- Last_Nonterminal => EOI_ID + 1 + Token_ID
(Input_Data.Tokens.Rules.Length)),
-
- others => <>)
- do
- Result.Descriptor.Case_Insensitive :=
Input_Data.Language_Params.Case_Insensitive;
- Result.Descriptor.New_Line_ID := Find_Kind (Result, "new-line");
- Result.Descriptor.String_1_ID := Find_Kind (Result,
"string-single");
- Result.Descriptor.String_2_ID := Find_Kind (Result,
"string-double");
-
- -- Image set in loop below, which also updates these widths.
- Result.Descriptor.Terminal_Image_Width := 0;
- Result.Descriptor.Image_Width := 0;
-
- Result.Descriptor.Last_Lookahead :=
- (case (Input_Data.User_Parser) is
- when None => Invalid_Token_ID,
- when LR1 =>
Result.Descriptor.Last_Terminal,
- when LALR =>
Result.Descriptor.First_Nonterminal,
- when Packrat_Generate_Algorithm | External => Invalid_Token_ID);
-
- for Cursor in All_Tokens (Result).Iterate loop
- Result.Descriptor.Image (ID (Cursor)) := new String'(Name_1
(Cursor));
- end loop;
-
- for ID in Result.Descriptor.Image'Range loop
- if ID in Result.Descriptor.First_Terminal ..
Result.Descriptor.Last_Terminal then
- if Result.Descriptor.Image (ID).all'Length >
Result.Descriptor.Terminal_Image_Width then
- Result.Descriptor.Terminal_Image_Width :=
Result.Descriptor.Image (ID).all'Length;
- end if;
- end if;
-
- if Result.Descriptor.Image (ID).all'Length >
Result.Descriptor.Image_Width then
- Result.Descriptor.Image_Width := Result.Descriptor.Image
(ID).all'Length;
- end if;
- end loop;
-
- To_Grammar (Result, Input_Data.Grammar_Lexer.File_Name,
-Input_Data.Language_Params.Start_Token);
- Result.Ignore_Conflicts := Ignore_Conflicts;
- end return;
- end Initialize;
-
- function Find_Token_ID (Data : aliased in Generate_Data; Token : in String)
return Token_ID
- is begin
- for Cursor in All_Tokens (Data).Iterate loop
- if Name (Cursor) = Token then
- return ID (Cursor);
- end if;
- end loop;
- raise Not_Found with "token '" & Token & "' not found";
- end Find_Token_ID;
-
- function All_Tokens (Data : aliased in Generate_Data) return Token_Container
- is begin
- return (Data => Data'Access);
- end All_Tokens;
-
- function Constant_Reference
- (Container : aliased in Token_Container'Class;
- Cursor : in Token_Cursor)
- return Token_Constant_Reference_Type
- is begin
- case Cursor.Kind is
- when Non_Grammar_Kind =>
- return
- (Element => Container.Data.Tokens.Non_Grammar
(Cursor.Token_Kind).Tokens (Cursor.Token_Item).Name'Access);
-
- when Terminals_Keywords =>
- return (Element => Container.Data.Tokens.Keywords
(Cursor.Keyword).Name'Access);
-
- when Terminals_Others =>
- return (Element => Container.Data.Tokens.Tokens
(Cursor.Token_Kind).Tokens (Cursor.Token_Item).Name'Access);
-
- when EOI =>
- return (Element => Aliased_EOI_Name'Access);
-
- when WisiToken_Accept =>
- return (Element => Aliased_WisiToken_Accept_Name'Access);
-
- when Nonterminal =>
- return (Element => Container.Data.Tokens.Rules
(Cursor.Nonterminal).Left_Hand_Side'Access);
-
- when Done =>
- raise SAL.Programmer_Error with "token cursor is done";
- end case;
- end Constant_Reference;
-
- type Iterator (Container : not null access constant Token_Container)
- is new Iterator_Interfaces.Forward_Iterator with record
- Non_Grammar : Boolean;
- Nonterminals : Boolean;
- end record;
-
- overriding function First (Object : Iterator) return Token_Cursor;
- overriding function Next (Object : Iterator; Position : Token_Cursor)
return Token_Cursor;
-
- overriding function First (Object : Iterator) return Token_Cursor
- is begin
- return First (Object.Container.Data.all, Object.Non_Grammar,
Object.Nonterminals);
- end First;
-
- overriding function Next (Object : Iterator; Position : Token_Cursor)
return Token_Cursor
- is
- Next_Position : Token_Cursor := Position;
- begin
- Next (Next_Position, Object.Nonterminals);
- return Next_Position;
- end Next;
-
- function Iterate
- (Container : aliased Token_Container;
- Non_Grammar : in Boolean := True;
- Nonterminals : in Boolean := True)
- return Iterator_Interfaces.Forward_Iterator'Class
- is begin
- return Iterator'(Container'Access, Non_Grammar, Nonterminals);
- end Iterate;
-
- function Next_Kind_Internal
- (Cursor : in out Token_Cursor;
- Nonterminals : in Boolean)
- return Boolean
- is begin
- -- Advance Cursor to the next kind; return True if any of that
- -- kind exist, or kind is Done; False otherwise.
- case Cursor.Kind is
- when Non_Grammar_Kind =>
-
- Cursor :=
- (Data => Cursor.Data,
- Kind => Terminals_Keywords,
- ID => Cursor.Data.Descriptor.First_Terminal,
- Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
- Token_Item => String_Triple_Lists.No_Element,
- Keyword => Cursor.Data.Tokens.Keywords.First,
- Nonterminal => Rule_Lists.No_Element);
-
- return String_Pair_Lists.Has_Element (Cursor.Keyword);
-
- when Terminals_Keywords =>
-
- Cursor :=
- (Data => Cursor.Data,
- Kind => Terminals_Others,
- ID => Cursor.ID,
- Token_Kind => Cursor.Data.Tokens.Tokens.First,
- Token_Item => String_Triple_Lists.No_Element,
- Keyword => String_Pair_Lists.No_Element,
- Nonterminal => Rule_Lists.No_Element);
-
- if WisiToken.BNF.Token_Lists.Has_Element (Cursor.Token_Kind) then
- Cursor.Token_Item := Cursor.Data.Tokens.Tokens
(Cursor.Token_Kind).Tokens.First;
- return WisiToken.BNF.String_Triple_Lists.Has_Element
(Cursor.Token_Item);
- else
- return False;
- end if;
-
- when Terminals_Others =>
-
- Cursor :=
- (Data => Cursor.Data,
- Kind => EOI,
- ID => Cursor.ID,
- Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
- Token_Item => String_Triple_Lists.No_Element,
- Keyword => String_Pair_Lists.No_Element,
- Nonterminal => Rule_Lists.No_Element);
-
- return True;
-
- when EOI =>
- if Nonterminals then
- if Rule_Lists.Has_Element (Cursor.Data.Tokens.Rules.First) then
- Cursor :=
- (Data => Cursor.Data,
- Kind => WisiToken_Accept,
- ID => Cursor.ID,
- Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
- Token_Item => String_Triple_Lists.No_Element,
- Keyword => String_Pair_Lists.No_Element,
- Nonterminal => Rule_Lists.No_Element);
- else
- Cursor.Kind := Done;
- end if;
- return True;
- else
- Cursor.Kind := Done;
- return True;
- end if;
-
- when WisiToken_Accept =>
-
- Cursor :=
- (Data => Cursor.Data,
- Kind => Nonterminal,
- ID => Cursor.ID,
- Token_Kind => WisiToken.BNF.Token_Lists.No_Element,
- Token_Item => String_Triple_Lists.No_Element,
- Keyword => String_Pair_Lists.No_Element,
- Nonterminal => Cursor.Data.Tokens.Rules.First);
-
- -- Can't get here with no rules
- return True;
-
- when Nonterminal =>
- Cursor.Kind := Done;
- return True;
-
- when Done =>
- return True;
- end case;
- end Next_Kind_Internal;
-
- function First
- (Data : aliased in Generate_Data;
- Non_Grammar : in Boolean;
- Nonterminals : in Boolean)
- return Token_Cursor
- is
- Cursor : Token_Cursor :=
- (Data => Data'Access,
- Kind => Non_Grammar_Kind,
- ID => Token_ID'First,
- Token_Kind => Data.Tokens.Non_Grammar.First,
- Token_Item => String_Triple_Lists.No_Element,
- Keyword => String_Pair_Lists.No_Element,
- Nonterminal => Rule_Lists.No_Element);
- begin
- if Non_Grammar then
- if WisiToken.BNF.Token_Lists.Has_Element (Cursor.Token_Kind) then
- Cursor.Token_Item := Cursor.Data.Tokens.Non_Grammar
(Cursor.Token_Kind).Tokens.First;
- if WisiToken.BNF.String_Triple_Lists.Has_Element
(Cursor.Token_Item) then
- return Cursor;
- end if;
- end if;
- end if;
-
- -- There are no non_grammar tokens, or Non_Grammar false
- loop
- exit when Next_Kind_Internal (Cursor, Nonterminals);
- end loop;
- return Cursor;
- end First;
-
- procedure Next (Cursor : in out Token_Cursor; Nonterminals : in Boolean)
- is begin
- Cursor.ID := Cursor.ID + 1;
-
- case Cursor.Kind is
- when Non_Grammar_Kind =>
- String_Triple_Lists.Next (Cursor.Token_Item);
- if String_Triple_Lists.Has_Element (Cursor.Token_Item) then
- return;
- else
- WisiToken.BNF.Token_Lists.Next (Cursor.Token_Kind);
-
- if WisiToken.BNF.Token_Lists.Has_Element (Cursor.Token_Kind) then
- Cursor.Token_Item := Cursor.Data.Tokens.Non_Grammar
(Cursor.Token_Kind).Tokens.First;
- if String_Triple_Lists.Has_Element (Cursor.Token_Item) then
- return;
- end if;
- end if;
- end if;
-
- loop
- exit when Next_Kind_Internal (Cursor, Nonterminals);
- end loop;
- return;
-
- when Terminals_Keywords =>
- -- Keywords before other terminals, so they have precedence over
Identifiers
-
- String_Pair_Lists.Next (Cursor.Keyword);
- if String_Pair_Lists.Has_Element (Cursor.Keyword) then
- return;
- end if;
-
- loop
- exit when Next_Kind_Internal (Cursor, Nonterminals);
- end loop;
- return;
-
- when Terminals_Others =>
- WisiToken.BNF.String_Triple_Lists.Next (Cursor.Token_Item);
- if WisiToken.BNF.String_Triple_Lists.Has_Element (Cursor.Token_Item)
then
- return;
- else
- WisiToken.BNF.Token_Lists.Next (Cursor.Token_Kind);
- if WisiToken.BNF.Token_Lists.Has_Element (Cursor.Token_Kind) then
- Cursor.Token_Item := Cursor.Data.Tokens.Tokens
(Cursor.Token_Kind).Tokens.First;
- if WisiToken.BNF.String_Triple_Lists.Has_Element
(Cursor.Token_Item) then
- return;
- end if;
- end if;
- end if;
-
- loop
- exit when Next_Kind_Internal (Cursor, Nonterminals);
- end loop;
- return;
-
- when EOI =>
- if Next_Kind_Internal (Cursor, Nonterminals) then
- return;
- else
- raise SAL.Programmer_Error;
- end if;
-
- when WisiToken_Accept =>
- if Next_Kind_Internal (Cursor, Nonterminals) then
- return;
- else
- raise SAL.Programmer_Error;
- end if;
-
- when Nonterminal =>
- Rule_Lists.Next (Cursor.Nonterminal);
- if Rule_Lists.Has_Element (Cursor.Nonterminal) then
- return;
- end if;
-
- loop
- exit when Next_Kind_Internal (Cursor, Nonterminals);
- end loop;
- return;
-
- when Done =>
- null;
- end case;
- end Next;
-
- function Is_Done (Cursor : in Token_Cursor) return Boolean
- is begin
- return Cursor.Kind = Done;
- end Is_Done;
-
- function ID (Cursor : in Token_Cursor) return Token_ID
- is begin
- return Cursor.ID;
- end ID;
-
- function Name (Cursor : in Token_Cursor) return String
- is begin
- return Cursor.Data.Descriptor.Image (Cursor.ID).all;
- end Name;
-
- function Kind (Cursor : in Token_Cursor) return String
- is begin
- case Cursor.Kind is
- when Non_Grammar_Kind =>
- return -Cursor.Data.Tokens.Non_Grammar (Cursor.Token_Kind).Kind;
-
- when Terminals_Keywords =>
- return "keyword";
-
- when Terminals_Others =>
- return -Cursor.Data.Tokens.Tokens (Cursor.Token_Kind).Kind;
-
- when EOI =>
- return "EOI";
-
- when WisiToken_Accept =>
- return "accept";
-
- when Nonterminal =>
- return "nonterminal";
-
- when Done =>
- raise SAL.Programmer_Error with "token cursor is done";
- end case;
- end Kind;
-
- function Value (Cursor : in Token_Cursor) return String
- is begin
- case Cursor.Kind is
- when Non_Grammar_Kind =>
- return -Cursor.Data.Tokens.Non_Grammar (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Value;
-
- when Terminals_Keywords =>
- return -Cursor.Data.Tokens.Keywords (Cursor.Keyword).Value;
-
- when Terminals_Others =>
- return -Cursor.Data.Tokens.Tokens (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Value;
-
- when EOI | WisiToken_Accept | Nonterminal =>
- return "";
-
- when Done =>
- raise SAL.Programmer_Error with "token cursor is done";
- end case;
- end Value;
-
- function Repair_Image (Cursor : in Token_Cursor) return String
- is begin
- case Cursor.Kind is
- when Non_Grammar_Kind =>
- return -Cursor.Data.Tokens.Non_Grammar (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Repair_Image;
-
- when Terminals_Keywords =>
- return "";
-
- when Terminals_Others =>
- return -Cursor.Data.Tokens.Tokens (Cursor.Token_Kind).Tokens
(Cursor.Token_Item).Repair_Image;
-
- when EOI | WisiToken_Accept | Nonterminal =>
- return "";
-
- when Done =>
- raise SAL.Programmer_Error with "token cursor is done";
- end case;
- end Repair_Image;
-
- function To_Conflicts
- (Data : aliased in out Generate_Data;
- Conflicts : in WisiToken.BNF.Conflict_Lists.List;
- Source_File_Name : in String)
- return WisiToken.Generate.LR.Conflict_Lists.List
- is
- use WisiToken.Generate.LR;
- Result : WisiToken.Generate.LR.Conflict_Lists.List;
- Conflict : WisiToken.Generate.LR.Conflict;
- begin
- for Item of Conflicts loop
- begin
- Conflict :=
- (Conflict_Parse_Actions'Value (-Item.Action_A),
- Find_Token_ID (Data, -Item.LHS_A),
- Conflict_Parse_Actions'Value (-Item.Action_B),
- Find_Token_ID (Data, -Item.LHS_B),
- -1,
- Find_Token_ID (Data, -Item.On));
-
- Result.Append (Conflict);
- exception
- when E : Not_Found =>
- if not Data.Ignore_Conflicts then
- Put_Error
- (Error_Message
- (Source_File_Name, Item.Source_Line,
Ada.Exceptions.Exception_Message (E)));
- end if;
- end;
- end loop;
- return Result;
- end To_Conflicts;
-
- function To_Nonterminal_ID_Set
- (Data : aliased in Generate_Data;
- Item : in String_Lists.List)
- return Token_ID_Set
- is
- Result : Token_ID_Set := (Data.Descriptor.First_Nonterminal ..
Data.Descriptor.Last_Nonterminal => False);
- begin
- for Token of Item loop
- Result (Find_Token_ID (Data, Token)) := True;
- end loop;
- return Result;
- end To_Nonterminal_ID_Set;
-
- function To_McKenzie_Param
- (Data : aliased in Generate_Data;
- Item : in McKenzie_Recover_Param_Type)
- return WisiToken.Parse.LR.McKenzie_Param_Type
- is
- use Ada.Strings.Unbounded;
-
- Result : WisiToken.Parse.LR.McKenzie_Param_Type :=
- -- We use an aggregate, and overwrite some below, so the compiler
- -- reminds us to change this when we modify McKenzie_Param_Type.
- (Data.Descriptor.First_Terminal,
- Data.Descriptor.Last_Terminal,
- Data.Descriptor.First_Nonterminal,
- Data.Descriptor.Last_Nonterminal,
- Insert => (others => Item.Default_Insert),
- Delete => (others =>
Item.Default_Delete_Terminal),
- Push_Back => (others => Item.Default_Push_Back),
- Undo_Reduce => (others => Item.Default_Push_Back), --
no separate default for undo_reduce
- Minimal_Complete_Cost_Delta => Item.Minimal_Complete_Cost_Delta,
- Fast_Forward => Item.Fast_Forward,
- Matching_Begin => Item.Matching_Begin,
- Ignore_Check_Fail => Item.Ignore_Check_Fail,
- Task_Count => 0,
- Check_Limit => Item.Check_Limit,
- Check_Delta_Limit => Item.Check_Delta_Limit,
- Enqueue_Limit => Item.Enqueue_Limit);
- begin
- for Pair of Item.Delete loop
- Result.Delete (Find_Token_ID (Data, -Pair.Name)) := Natural'Value
(-Pair.Value);
- end loop;
- for Pair of Item.Insert loop
- Result.Insert (Find_Token_ID (Data, -Pair.Name)) := Natural'Value
(-Pair.Value);
- end loop;
- for Pair of Item.Push_Back loop
- Result.Push_Back (Find_Token_ID (Data, -Pair.Name)) := Natural'Value
(-Pair.Value);
- end loop;
- for Pair of Item.Undo_Reduce loop
- Result.Undo_Reduce (Find_Token_ID (Data, -Pair.Name)) :=
Natural'Value (-Pair.Value);
- end loop;
-
- return Result;
- end To_McKenzie_Param;
-
- procedure Put_Stats
- (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Generate_Data : in Generate_Utils.Generate_Data)
- is
- use Ada.Text_IO;
- begin
- New_Line;
- Put_Line
- (Integer'Image (Input_Data.Rule_Count) & " rules," &
- Integer'Image (Input_Data.Action_Count) & " user actions," &
- Integer'Image (Input_Data.Check_Count) & " checks," &
- WisiToken.State_Index'Image (Generate_Data.Parser_State_Count) & "
states");
- end Put_Stats;
-
-end WisiToken.BNF.Generate_Utils;
diff --git a/packages/wisi/wisitoken-bnf-generate_utils.ads
b/packages/wisi/wisitoken-bnf-generate_utils.ads
deleted file mode 100644
index a2f31a2..0000000
--- a/packages/wisi/wisitoken-bnf-generate_utils.ads
+++ /dev/null
@@ -1,174 +0,0 @@
--- Abstract :
---
--- Utilities for translating input file structures to WisiToken
--- structures needed for LALR.Generate.
---
--- Copyright (C) 2014, 2015, 2017 - 2020 Free Software Foundation, Inc.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Iterator_Interfaces;
-with WisiToken.Generate.LR;
-with WisiToken.Parse.LR;
-with WisiToken.Productions;
-with WisiToken_Grammar_Runtime;
-package WisiToken.BNF.Generate_Utils is
-
- EOI_Name : constant String := "Wisi_EOI";
- -- EOI_Name is used for Descriptor.EOI_ID token; it must match Emacs
ada-mode
- -- wisi.el wisi-eoi-term. It must be a valid Ada identifier when
- -- "_ID" is appended.
-
- WisiToken_Accept_Name : constant String := "wisitoken_accept";
-
- type Generate_Data (Tokens : not null access constant WisiToken.BNF.Tokens)
is limited record
- Descriptor : WisiToken.Descriptor_Access;
- Grammar : WisiToken.Productions.Prod_Arrays.Vector;
-
- Action_Names : Names_Array_Array_Access;
- Check_Names : Names_Array_Array_Access;
- -- Names of subprograms for each grammar semantic action and check;
- -- non-null only if there is an action or check in the grammar.
-
- Start_ID : WisiToken.Token_ID;
- Source_Line_Map : WisiToken.Productions.Source_Line_Maps.Vector;
-
- -- The following fields are LR specific; so far, it's not worth
- -- splitting them out.
-
- Ignore_Conflicts : Boolean := False;
- Conflicts : WisiToken.Generate.LR.Conflict_Lists.List;
- LR_Parse_Table : WisiToken.Parse.LR.Parse_Table_Ptr;
- Parser_State_Count : WisiToken.Unknown_State_Index := 0;
- end record;
-
- function Initialize
- (Input_Data : aliased in WisiToken_Grammar_Runtime.User_Data_Type;
- Ignore_Conflicts : in Boolean := False)
- return Generate_Data;
-
- function Find_Token_ID (Data : aliased in Generate_Data; Token : in String)
return Token_ID;
-
- type Token_Container (Data : not null access constant Generate_Data) is
tagged null record
- with
- Constant_Indexing => Constant_Reference,
- Default_Iterator => Iterate,
- Iterator_Element => Ada.Strings.Unbounded.Unbounded_String;
- -- We need a container type to define an iterator; the actual data is
- -- in Data.Tokens. The Iterator_Element is given by Token_Name below.
-
- function All_Tokens (Data : aliased in Generate_Data) return
Token_Container;
-
- type Token_Constant_Reference_Type
- (Element : not null access constant
Ada.Strings.Unbounded.Unbounded_String)
- is null record
- with Implicit_Dereference => Element;
-
- type Token_Cursor (<>) is private;
- -- Iterate thru Keywords, Tokens, Rules in a canonical order:
- --
- -- 1. Non_Grammar
- -- 2. Keywords
- -- 3. other terminal tokens, in declaration order
- -- 4. EOI
- -- 5. Accept
- -- 6. Nonterminals
- --
- -- Within each group, tokens occur in the order they were declared in
- -- the grammar file.
-
- function Constant_Reference
- (Container : aliased in Token_Container'Class;
- Cursor : in Token_Cursor)
- return Token_Constant_Reference_Type;
-
- function Is_Done (Cursor : in Token_Cursor) return Boolean;
- function Has_Element (Cursor : in Token_Cursor) return Boolean is (not
Is_Done (Cursor));
- package Iterator_Interfaces is new Ada.Iterator_Interfaces (Token_Cursor,
Has_Element);
- function Iterate
- (Container : aliased Token_Container;
- Non_Grammar : in Boolean := True;
- Nonterminals : in Boolean := True)
- return Iterator_Interfaces.Forward_Iterator'Class;
-
- function First
- (Data : aliased in Generate_Data;
- Non_Grammar : in Boolean;
- Nonterminals : in Boolean)
- return Token_Cursor;
- procedure Next (Cursor : in out Token_Cursor; Nonterminals : in Boolean);
-
- function ID (Cursor : in Token_Cursor) return Token_ID;
-
- function Name (Cursor : in Token_Cursor) return String;
- -- Return the token name from the .wy file:
- -- Keywords: Keywords (i).name
- -- Tokens : Tokens (i).Tokens (j).name
- -- Rules : Rules (i).Left_Hand_Side
-
- function Kind (Cursor : in Token_Cursor) return String;
- -- Return the token kind from the .wy file:
- -- Keywords: "keyword"
- -- Tokens : Tokens (i).Kind
- -- Rules : "nonterminal"
-
- function Value (Cursor : in Token_Cursor) return String;
- -- Return the token value from the .wy file:
- -- Keywords: Keywords (i).value
- -- Tokens : Tokens (i).Tokens (j).Value
- -- Rules : empty string (they have no Value)
-
- function Repair_Image (Cursor : in Token_Cursor) return String;
- -- Return the token repair image from the .wy file:
- -- Keywords: empty string
- -- Tokens : Tokens (i).Tokens (j).Repair_Image
- -- Rules : empty string
-
- function To_Conflicts
- (Data : aliased in out Generate_Data;
- Conflicts : in WisiToken.BNF.Conflict_Lists.List;
- Source_File_Name : in String)
- return WisiToken.Generate.LR.Conflict_Lists.List;
- -- Not included in Initialize because algorithms have no conflicts.
-
- function To_Nonterminal_ID_Set
- (Data : aliased in Generate_Data;
- Item : in String_Lists.List)
- return Token_ID_Set;
-
- function To_McKenzie_Param
- (Data : aliased in Generate_Data;
- Item : in McKenzie_Recover_Param_Type)
- return WisiToken.Parse.LR.McKenzie_Param_Type;
-
- procedure Put_Stats
- (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Generate_Data : in Generate_Utils.Generate_Data);
-
-private
-
- type Token_Cursor_Kind is
- (Non_Grammar_Kind, Terminals_Keywords, Terminals_Others, EOI,
WisiToken_Accept, Nonterminal, Done);
-
- type Token_Cursor (Data : not null access constant Generate_Data) is record
- Kind : Token_Cursor_Kind;
- ID : Token_ID;
- Token_Kind : WisiToken.BNF.Token_Lists.Cursor; -- Non_Grammar or
Tokens, depending on Kind
- Token_Item : String_Triple_Lists.Cursor;
- Keyword : String_Pair_Lists.Cursor;
- Nonterminal : Rule_Lists.Cursor;
- end record;
-
-end WisiToken.BNF.Generate_Utils;
diff --git a/packages/wisi/wisitoken-bnf-output_ada.adb
b/packages/wisi/wisitoken-bnf-output_ada.adb
deleted file mode 100644
index 3857a0f..0000000
--- a/packages/wisi/wisitoken-bnf-output_ada.adb
+++ /dev/null
@@ -1,512 +0,0 @@
--- Abstract :
---
--- Output Ada code implementing the grammar defined by input
--- parameters, and a parser for that grammar. The grammar parser
--- actions must be Ada.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Strings.Fixed;
-with Ada.Text_IO; use Ada.Text_IO;
-with GNAT.Regexp;
-with WisiToken.BNF.Generate_Packrat;
-with WisiToken.BNF.Generate_Utils;
-with WisiToken.BNF.Output_Ada_Common; use WisiToken.BNF.Output_Ada_Common;
-with WisiToken.Generate.Packrat;
-with WisiToken_Grammar_Runtime;
-procedure WisiToken.BNF.Output_Ada
- (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Output_File_Name_Root : in String;
- Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
- Packrat_Data : in WisiToken.Generate.Packrat.Data;
- Tuple : in Generate_Tuple;
- Test_Main : in Boolean;
- Multiple_Tuples : in Boolean)
-is
- Common_Data : Output_Ada_Common.Common_Data :=
WisiToken.BNF.Output_Ada_Common.Initialize
- (Input_Data, Tuple, Output_File_Name_Root, Check_Interface => False);
-
- Gen_Alg_Name : constant String :=
- (if Test_Main or Multiple_Tuples
- then "_" & Generate_Algorithm_Image (Common_Data.Generate_Algorithm).all
- else "");
-
- function Symbol_Regexp (Item : in String) return String
- is begin
- -- Return a regular expression string that matches Item as a symbol;
- -- it must be preceded and followed by non-symbol characters.
- --
- -- GNAT.Regexp does not have a char for 'end of string', so we hope
- -- that doesn't occur. Sigh.
- return ".*[ (\.]" & Item & "[ );\.,].*";
- end Symbol_Regexp;
-
- procedure Create_Ada_Actions_Body
- (Action_Names : not null access WisiToken.Names_Array_Array;
- Check_Names : not null access WisiToken.Names_Array_Array;
- Label_Count : in Ada.Containers.Count_Type;
- Package_Name : in String)
- is
- use all type Ada.Containers.Count_Type;
- use GNAT.Regexp;
- use Generate_Utils;
- use WisiToken.Generate;
-
- File_Name : constant String := Output_File_Name_Root & "_actions.adb";
-
- User_Data_Regexp : constant Regexp := Compile (Symbol_Regexp
("User_Data"), Case_Sensitive => False);
- Tree_Regexp : constant Regexp := Compile (Symbol_Regexp ("Tree"),
Case_Sensitive => False);
- Nonterm_Regexp : constant Regexp := Compile (Symbol_Regexp
("Nonterm"), Case_Sensitive => False);
- Tokens_Regexp : constant Regexp := Compile (Symbol_Regexp ("Tokens"),
Case_Sensitive => False);
-
- Body_File : File_Type;
- begin
- Create (Body_File, Out_File, File_Name);
- Set_Output (Body_File);
- Indent := 1;
- Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Body_Context));
- New_Line;
-
- if Label_Count > 0 then
- Put_Line ("with SAL;");
- end if;
-
- Put_Line ("package body " & Package_Name & " is");
- Indent := Indent + 3;
- New_Line;
-
- if Input_Data.Check_Count > 0 then
- Indent_Line ("use WisiToken.Semantic_Checks;");
- New_Line;
- end if;
-
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Body_Pre));
-
- -- generate Action and Check subprograms.
-
- for Rule of Input_Data.Tokens.Rules loop
- -- No need for a Token_Cursor here, since we only need the
- -- nonterminals.
- declare
- use Ada.Strings.Unbounded;
-
- LHS_ID : constant WisiToken.Token_ID := Find_Token_ID
(Generate_Data, -Rule.Left_Hand_Side);
- RHS_Index : Integer := 0;
-
- function Is_Elisp (Action : in Unbounded_String) return Boolean
- is begin
- return Length (Action) >= 6 and then
- (Slice (Action, 1, 6) = "(progn" or
- Slice (Action, 1, 5) = "wisi-");
- end Is_Elisp;
-
- procedure Put_Labels (RHS : in RHS_Type; Line : in String)
- is
- Output : array (Rule.Labels.First_Index ..
Rule.Labels.Last_Index) of Boolean := (others => False);
-
- procedure Update_Output (Label : in String)
- is begin
- for I in Rule.Labels.First_Index .. Rule.Labels.Last_Index
loop
- if Label = Rule.Labels (I) then
- Output (I) := True;
- end if;
- end loop;
- end Update_Output;
- begin
- for I in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index loop
- if Length (RHS.Tokens (I).Label) > 0 then
- declare
- Label : constant String := -RHS.Tokens (I).Label;
- begin
- if Match (Line, Compile (Symbol_Regexp (Label),
Case_Sensitive => False)) then
- Indent_Line
- (Label & " : constant SAL.Peek_Type :=" &
SAL.Peek_Type'Image (I) & ";");
- Update_Output (Label);
- end if;
- end;
- end if;
- end loop;
-
- for I in Rule.Labels.First_Index .. Rule.Labels.Last_Index loop
- if not Output (I) and
- Match (Line, Compile (Symbol_Regexp (-Rule.Labels (I)),
Case_Sensitive => False))
- then
- Indent_Line (-Rule.Labels (I) & " : constant
SAL.Base_Peek_Type := SAL.Base_Peek_Type'First;");
- end if;
- end loop;
- end Put_Labels;
-
- begin
- for RHS of Rule.Right_Hand_Sides loop
- if Length (RHS.Action) > 0 and then not Is_Elisp (RHS.Action)
then
- declare
- Line : constant String := -RHS.Action;
- -- Actually multiple lines; we assume the formatting is
adequate.
-
- Name : constant String := Action_Names
(LHS_ID)(RHS_Index).all;
-
- Unref_User_Data : Boolean := True;
- Unref_Tree : Boolean := True;
- Unref_Nonterm : Boolean := True;
- Unref_Tokens : Boolean := True;
- Need_Comma : Boolean := False;
-
- procedure Check_Unref (Line : in String)
- is begin
- if Match (Line, User_Data_Regexp) then
- Unref_User_Data := False;
- end if;
- if Match (Line, Tree_Regexp) then
- Unref_Tree := False;
- end if;
- if Match (Line, Nonterm_Regexp) then
- Unref_Nonterm := False;
- end if;
- if Match (Line, Tokens_Regexp) then
- Unref_Tokens := False;
- end if;
- end Check_Unref;
- begin
- Check_Unref (Line);
- Indent_Line ("procedure " & Name);
- Indent_Line (" (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class;");
- Indent_Line (" Tree : in out
WisiToken.Syntax_Trees.Tree;");
- Indent_Line (" Nonterm : in
WisiToken.Valid_Node_Index;");
- Indent_Line (" Tokens : in
WisiToken.Valid_Node_Index_Array)");
- Indent_Line ("is");
-
- Indent := Indent + 3;
- if Unref_User_Data or Unref_Tree or Unref_Nonterm or
Unref_Tokens then
- Indent_Start ("pragma Unreferenced (");
-
- if Unref_User_Data then
- Put ("User_Data");
- Need_Comma := True;
- end if;
- if Unref_Tree then
- Put ((if Need_Comma then ", " else "") & "Tree");
- Need_Comma := True;
- end if;
- if Unref_Nonterm then
- Put ((if Need_Comma then ", " else "") & "Nonterm");
- Need_Comma := True;
- end if;
- if Unref_Tokens then
- Put ((if Need_Comma then ", " else "") & "Tokens");
- Need_Comma := True;
- end if;
- Put_Line (");");
- end if;
-
- Put_Labels (RHS, Line);
- Indent := Indent - 3;
- Indent_Line ("begin");
- Indent := Indent + 3;
-
- Indent_Line (Line);
- Indent := Indent - 3;
- Indent_Line ("end " & Name & ";");
- New_Line;
- end;
- end if;
-
- if Length (RHS.Check) > 0 and then not Is_Elisp (RHS.Check) then
- declare
- use Ada.Strings.Fixed;
- Line : constant String := -RHS.Check;
- Name : constant String := Check_Names
(LHS_ID)(RHS_Index).all;
- Unref_Lexer : constant Boolean := 0 = Index (Line,
"Lexer");
- Unref_Nonterm : constant Boolean := 0 = Index (Line,
"Nonterm");
- Unref_Tokens : constant Boolean := 0 = Index (Line,
"Tokens");
- Unref_Recover : constant Boolean := 0 = Index (Line,
"Recover_Active");
- Need_Comma : Boolean := False;
- begin
- Indent_Line ("function " & Name);
- Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
- Indent_Line (" Nonterm : in out
WisiToken.Recover_Token;");
- Indent_Line (" Tokens : in
WisiToken.Recover_Token_Array;");
- Indent_Line (" Recover_Active : in Boolean)");
- Indent_Line (" return
WisiToken.Semantic_Checks.Check_Status");
- Indent_Line ("is");
-
- Indent := Indent + 3;
- if Unref_Lexer or Unref_Nonterm or Unref_Tokens or
Unref_Recover then
- Indent_Start ("pragma Unreferenced (");
-
- if Unref_Lexer then
- Put ("Lexer");
- Need_Comma := True;
- end if;
- if Unref_Nonterm then
- Put ((if Need_Comma then ", " else "") & "Nonterm");
- Need_Comma := True;
- end if;
- if Unref_Tokens then
- Put ((if Need_Comma then ", " else "") & "Tokens");
- Need_Comma := True;
- end if;
- if Unref_Recover then
- Put ((if Need_Comma then ", " else "") &
"Recover_Active");
- Need_Comma := True;
- end if;
- Put_Line (");");
- end if;
-
- Put_Labels (RHS, Line);
- Indent := Indent - 3;
-
- Indent_Line ("begin");
- Indent := Indent + 3;
- Indent_Line (Line);
- Indent := Indent - 3;
- Indent_Line ("end " & Name & ";");
- New_Line;
- end;
- end if;
-
- RHS_Index := RHS_Index + 1;
- end loop;
- end;
- end loop;
-
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Body_Post));
-
- Put_Line ("end " & Package_Name & ";");
- Close (Body_File);
-
- Set_Output (Standard_Output);
-
- end Create_Ada_Actions_Body;
-
- procedure Create_Ada_Main_Body
- (Actions_Package_Name : in String;
- Main_Package_Name : in String)
- is
- use WisiToken.Generate;
-
- File_Name : constant String := To_Lower (Main_Package_Name) &
".adb";
- re2c_Package_Name : constant String := -Common_Data.Lower_File_Name_Root
& "_re2c_c";
-
- Body_File : File_Type;
- begin
- Create (Body_File, Out_File, File_Name);
- Set_Output (Body_File);
- Indent := 1;
-
- Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
- New_Line;
-
- if (case Common_Data.Generate_Algorithm is
- when LR_Generate_Algorithm => Input_Data.Action_Count > 0 or
Input_Data.Check_Count > 0,
- when Packrat_Generate_Algorithm | External =>
Input_Data.Action_Count > 0)
- then
- Put_Line ("with " & Actions_Package_Name & "; use " &
Actions_Package_Name & ";");
- end if;
-
- case Common_Data.Lexer is
- when None | Elisp_Lexer =>
- null;
-
- when re2c_Lexer =>
- Put_Line ("with WisiToken.Lexer.re2c;");
- Put_Line ("with " & re2c_Package_Name & ";");
- end case;
-
- case Common_Data.Generate_Algorithm is
- when LR_Generate_Algorithm =>
- null;
-
- when Packrat_Gen =>
- Put_Line ("with WisiToken.Parse.Packrat.Generated;");
-
- when Packrat_Proc =>
- Put_Line ("with WisiToken.Parse.Packrat.Procedural;");
- Put_Line ("with WisiToken.Productions;");
-
- when External =>
- null;
- end case;
-
- Put_Line ("package body " & Main_Package_Name & " is");
- Indent := Indent + 3;
- New_Line;
-
- case Common_Data.Lexer is
- when None | Elisp_Lexer =>
- null;
-
- when re2c_Lexer =>
- Indent_Line ("package Lexer is new WisiToken.Lexer.re2c");
- Indent_Line (" (" & re2c_Package_Name & ".New_Lexer,");
- Indent_Line (" " & re2c_Package_Name & ".Free_Lexer,");
- Indent_Line (" " & re2c_Package_Name & ".Reset_Lexer,");
- Indent_Line (" " & re2c_Package_Name & ".Next_Token);");
- New_Line;
- end case;
-
- case Common_Data.Generate_Algorithm is
- when LR_Generate_Algorithm =>
- LR_Create_Create_Parser (Input_Data, Common_Data, Generate_Data);
-
- when Packrat_Gen =>
- WisiToken.BNF.Generate_Packrat (Packrat_Data, Generate_Data);
-
- Packrat_Create_Create_Parser (Common_Data, Generate_Data,
Packrat_Data);
-
- when Packrat_Proc =>
- Packrat_Create_Create_Parser (Common_Data, Generate_Data,
Packrat_Data);
-
- when External =>
- External_Create_Create_Grammar (Generate_Data);
- end case;
-
- Put_Line ("end " & Main_Package_Name & ";");
- Close (Body_File);
- Set_Output (Standard_Output);
- end Create_Ada_Main_Body;
-
- procedure Create_Ada_Test_Main
- (Actions_Package_Name : in String;
- Main_Package_Name : in String)
- is
- use WisiToken.Generate;
-
- Generic_Package_Name : constant String :=
- (case Common_Data.Generate_Algorithm is
- when LR_Generate_Algorithm =>
- (if Input_Data.Language_Params.Error_Recover then
- (if Common_Data.Text_Rep
- then "Gen_LR_Text_Rep_Parser_Run"
- else "Gen_LR_Parser_Run")
- else
- (if Common_Data.Text_Rep
- then "Gen_LR_Text_Rep_Parser_No_Recover_Run"
- else "Gen_LR_Parser_No_Recover_Run")),
-
- when Packrat_Generate_Algorithm => "Gen_Packrat_Parser_Run",
- when External => raise SAL.Programmer_Error);
-
- Unit_Name : constant String := File_Name_To_Ada (Output_File_Name_Root) &
- "_" & Generate_Algorithm'Image (Common_Data.Generate_Algorithm) &
"_Run";
-
- Default_Language_Runtime_Package : constant String :=
"WisiToken.Parse.LR.McKenzie_Recover." & File_Name_To_Ada
- (Output_File_Name_Root);
-
- File_Name : constant String := To_Lower (Unit_Name) & ".ads";
-
- File : File_Type;
- begin
- Create (File, Out_File, File_Name);
- Set_Output (File);
- Indent := 1;
-
- Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
- -- no Copyright_License; just a test file
- New_Line;
-
- Put_Line ("with " & Generic_Package_Name & ";");
- Put_Line ("with " & Actions_Package_Name & ";");
- Put_Line ("with " & Main_Package_Name & ";");
- if Input_Data.Language_Params.Error_Recover and
- Input_Data.Language_Params.Use_Language_Runtime
- then
- declare
- Pkg : constant String :=
- (if -Input_Data.Language_Params.Language_Runtime_Name = ""
- then Default_Language_Runtime_Package
- else -Input_Data.Language_Params.Language_Runtime_Name);
- begin
- -- For language-specific names in actions, checks.
- Put_Line ("with " & Pkg & ";");
- Put_Line ("use " & Pkg & ";");
- end;
- end if;
-
- Put_Line ("procedure " & Unit_Name & " is new " & Generic_Package_Name);
- Put_Line (" (" & Actions_Package_Name & ".Descriptor,");
- if Common_Data.Text_Rep then
- Put_Line (" """ & Output_File_Name_Root & "_" &
- To_Lower (Generate_Algorithm_Image (Tuple.Gen_Alg).all) &
- "_parse_table.txt"",");
- end if;
- if Input_Data.Language_Params.Error_Recover then
- if Input_Data.Language_Params.Use_Language_Runtime then
- Put_Line ("Fixes'Access, Matching_Begin_Tokens'Access,
String_ID_Set'Access,");
- else
- Put_Line ("null, null, null,");
- end if;
- end if;
- Put_Line (Main_Package_Name & ".Create_Parser);");
- Close (File);
- Set_Output (Standard_Output);
- end Create_Ada_Test_Main;
-
-begin
- case Common_Data.Lexer is
- when None | re2c_Lexer =>
- null;
-
- when Elisp_Lexer =>
- raise User_Error with WisiToken.Generate.Error_Message
- (Input_Data.Grammar_Lexer.File_Name, 1, "Ada output language does not
support " & Lexer_Image
- (Common_Data.Lexer).all & " lexer");
- end case;
-
- case Tuple.Interface_Kind is
- when None =>
- null;
-
- when Module | Process =>
- raise User_Error with WisiToken.Generate.Error_Message
- (Input_Data.Grammar_Lexer.File_Name, 1, "Ada output language does not
support setting Interface");
- end case;
-
- declare
- Main_Package_Name : constant String := File_Name_To_Ada
(Output_File_Name_Root & Gen_Alg_Name) & "_Main";
- Actions_Package_Name : constant String := File_Name_To_Ada
(Output_File_Name_Root) & "_Actions";
- begin
- if Input_Data.Action_Count > 0 or Input_Data.Check_Count > 0 then
- -- Some WisiToken tests have no actions or checks.
- Create_Ada_Actions_Body
- (Generate_Data.Action_Names, Generate_Data.Check_Names,
Input_Data.Label_Count, Actions_Package_Name);
- end if;
-
- Create_Ada_Actions_Spec
- (Output_File_Name_Root & "_actions.ads", Actions_Package_Name,
Input_Data, Common_Data, Generate_Data);
-
- if Tuple.Gen_Alg = External then
- Create_External_Main_Spec (Main_Package_Name, Tuple, Input_Data);
- Create_Ada_Main_Body (Actions_Package_Name, Main_Package_Name);
- else
- Create_Ada_Main_Body (Actions_Package_Name, Main_Package_Name);
-
- Create_Ada_Main_Spec (To_Lower (Main_Package_Name) & ".ads",
Main_Package_Name, Input_Data, Common_Data);
-
- if Test_Main then
- Create_Ada_Test_Main (Actions_Package_Name, Main_Package_Name);
- end if;
- end if;
- end;
-
-exception
-when others =>
- Set_Output (Standard_Output);
- raise;
-end WisiToken.BNF.Output_Ada;
diff --git a/packages/wisi/wisitoken-bnf-output_ada_common.adb
b/packages/wisi/wisitoken-bnf-output_ada_common.adb
deleted file mode 100644
index 3a594bb..0000000
--- a/packages/wisi/wisitoken-bnf-output_ada_common.adb
+++ /dev/null
@@ -1,1392 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (GPL);
-
-with Ada.Strings.Fixed;
-with Ada.Text_IO; use Ada.Text_IO;
-with System.Multiprocessors;
-with WisiToken.BNF.Generate_Grammar;
-with WisiToken.BNF.Utils;
-with WisiToken.Generate; use WisiToken.Generate;
-with WisiToken.Parse.LR;
-with WisiToken.Productions;
-with WisiToken.Syntax_Trees;
-package body WisiToken.BNF.Output_Ada_Common is
-
- -- Body subprograms, alphabetical
-
- function Duplicate_Reduce (State : in Parse.LR.Parse_State) return Boolean
- is
- use Parse.LR;
- Action_Node : Parse_Action_Node_Ptr;
- First : Boolean := True;
- Action : Reduce_Action_Rec;
- begin
- for Node of State.Action_List loop
- Action_Node := Node.Actions;
- if Action_Node.Next /= null then
- -- conflict
- return False;
- elsif Action_Node.Item.Verb /= Reduce then
- return False;
- end if;
-
- if First then
- Action := Action_Node.Item;
- First := False;
- else
- if not Equal (Action, Action_Node.Item) then
- return False;
- end if;
- end if;
- end loop;
- return True;
- end Duplicate_Reduce;
-
- function Image (Item : in Boolean) return String
- is (if Item then "True" else "False");
-
- function Symbols_Image (State : in Parse.LR.Parse_State) return String
- is
- use all type Ada.Containers.Count_Type;
- use Ada.Strings.Unbounded;
-
- Result : Unbounded_String;
- Need_Comma : Boolean := False;
- begin
- if State.Action_List.Length = 1 then
- return "(1 => " & Token_ID'Image (State.Action_List (1).Symbol) & ")";
- else
- Result := +"(";
- for Node of State.Action_List loop
- Result := Result &
- (if Need_Comma then ", " else "") &
- Trimmed_Image (Node.Symbol);
- Need_Comma := True;
- end loop;
- Result := Result & ")";
- return -Result;
- end if;
- end Symbols_Image;
-
- ----------
- -- Public subprograms in alphabetical order
-
- procedure Create_Ada_Actions_Spec
- (Output_File_Name : in String;
- Package_Name : in String;
- Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Common_Data : in Output_Ada_Common.Common_Data;
- Generate_Data : aliased in WisiToken.BNF.Generate_Utils.Generate_Data)
- is
- use Generate_Utils;
-
- Descriptor : WisiToken.Descriptor renames Generate_Data.Descriptor.all;
- Spec_File : File_Type;
- Paren_Done : Boolean := False;
- Cursor : Token_Cursor := First (Generate_Data, Non_Grammar => True,
Nonterminals => True);
- begin
- Create (Spec_File, Out_File, Output_File_Name);
- Set_Output (Spec_File);
- Indent := 1;
-
- Put_File_Header
- (Ada_Comment, Use_Tuple => True, Tuple =>
- (Common_Data.Generate_Algorithm, Common_Data.Output_Language,
Common_Data.Lexer, Common_Data.Interface_Kind,
- Common_Data.Text_Rep));
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
- New_Line;
-
- if not (Input_Data.Action_Count > 0 or Input_Data.Check_Count > 0) then
- Put_Line ("with WisiToken;");
- end if;
- if Input_Data.Action_Count > 0 then
- Put_Line ("with WisiToken.Syntax_Trees;");
- end if;
- if Input_Data.Check_Count > 0 then
- Put_Line ("with WisiToken.Lexer;");
- Put_Line ("with WisiToken.Semantic_Checks;");
- end if;
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Spec_Context));
- Put_Line ("package " & Package_Name & " is");
- Indent := Indent + 3;
- New_Line;
-
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Spec_Pre));
-
- Indent_Line ("Descriptor : aliased WisiToken.Descriptor :=");
- Indent_Line (" (First_Terminal =>" & WisiToken.Token_ID'Image
(Descriptor.First_Terminal) & ",");
- Indent := Indent + 3;
- Indent_Line ("Last_Terminal =>" & WisiToken.Token_ID'Image
(Descriptor.Last_Terminal) & ",");
- Indent_Line ("First_Nonterminal =>" & WisiToken.Token_ID'Image
(Descriptor.First_Nonterminal) & ",");
- Indent_Line ("Last_Nonterminal =>" & WisiToken.Token_ID'Image
(Descriptor.Last_Nonterminal) & ",");
- Indent_Line ("EOI_ID =>" & WisiToken.Token_ID'Image
(Descriptor.EOI_ID) & ",");
- Indent_Line ("Accept_ID =>" & WisiToken.Token_ID'Image
(Descriptor.Accept_ID) & ",");
- Indent_Line ("Case_Insensitive => " & Image
(Input_Data.Language_Params.Case_Insensitive) & ",");
- Indent_Line ("New_Line_ID =>" & WisiToken.Token_ID'Image
(Descriptor.New_Line_ID) & ",");
- Indent_Line ("String_1_ID =>" & WisiToken.Token_ID'Image
(Descriptor.String_1_ID) & ",");
- Indent_Line ("String_2_ID =>" & WisiToken.Token_ID'Image
(Descriptor.String_2_ID) & ",");
- Indent_Line ("Image =>");
- Indent_Start (" (");
- Indent := Indent + 3;
- loop
- exit when Is_Done (Cursor);
- if Paren_Done then
- Indent_Start ("new String'(""" & (Name (Cursor)));
- else
- Put ("new String'(""" & (Name (Cursor)));
- Paren_Done := True;
- end if;
- Next (Cursor, Nonterminals => True);
- if Is_Done (Cursor) then
- Put_Line (""")),");
- else
- Put_Line ("""),");
- end if;
- end loop;
-
- Indent := Indent - 3;
- Indent_Line ("Terminal_Image_Width =>" & Integer'Image
(Descriptor.Terminal_Image_Width) & ",");
- Indent_Line ("Image_Width =>" & Integer'Image
(Descriptor.Image_Width) & ",");
- Indent_Line ("Last_Lookahead =>" & WisiToken.Token_ID'Image
(Descriptor.Last_Lookahead) & ");");
- Indent := Indent - 3;
- New_Line;
-
- if Input_Data.Language_Params.Declare_Enums then
- Paren_Done := False;
-
- Cursor := First (Generate_Data, Non_Grammar => True, Nonterminals =>
True);
- Indent_Line ("type Token_Enum_ID is");
- Indent_Start (" (");
- Indent := Indent + 3;
- loop
- exit when Is_Done (Cursor);
- if Paren_Done then
- Indent_Start (To_Token_Ada_Name (Name (Cursor)));
- else
- Put (To_Token_Ada_Name (Name (Cursor)));
- Paren_Done := True;
- end if;
- Next (Cursor, Nonterminals => True);
- if Is_Done (Cursor) then
- Put_Line (");");
- else
- Put_Line (",");
- end if;
- end loop;
-
- Indent := Indent - 3;
- New_Line;
-
- Indent_Line ("type Token_Enum_ID_Array is array (Positive range <>)
of Token_Enum_ID;");
- Indent_Line ("use all type WisiToken.Token_ID;");
- Indent_Line ("function ""+"" (Item : in Token_Enum_ID) return
WisiToken.Token_ID");
- Indent_Line (" is (WisiToken.Token_ID'First + Token_Enum_ID'Pos
(Item));");
-
- Indent_Line ("function To_Token_Enum (Item : in WisiToken.Token_ID)
return Token_Enum_ID");
- Indent_Line (" is (Token_Enum_ID'Val (Item -
WisiToken.Token_ID'First));");
- Indent_Line ("function ""-"" (Item : in WisiToken.Token_ID) return
Token_Enum_ID renames To_Token_Enum;");
- New_Line;
-
- end if;
-
- for Name_List of Generate_Data.Action_Names.all loop
- if Name_List /= null then
- for Name of Name_List.all loop
- if Name /= null then
- Indent_Line ("procedure " & Name.all);
- Indent_Line (" (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class;");
- Indent_Line (" Tree : in out
WisiToken.Syntax_Trees.Tree;");
- Indent_Line (" Nonterm : in
WisiToken.Valid_Node_Index;");
- Indent_Line (" Tokens : in
WisiToken.Valid_Node_Index_Array);");
- end if;
- end loop;
- end if;
- end loop;
-
- for Name_List of Generate_Data.Check_Names.all loop
- if Name_List /= null then
- for Name of Name_List.all loop
- if Name /= null then
- Indent_Line ("function " & Name.all);
- Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
- Indent_Line (" Nonterm : in out
WisiToken.Recover_Token;");
- Indent_Line (" Tokens : in
WisiToken.Recover_Token_Array;");
- Indent_Line (" Recover_Active : in Boolean)");
- Indent_Line (" return
WisiToken.Semantic_Checks.Check_Status;");
- end if;
- end loop;
- end if;
- end loop;
-
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Actions_Spec_Post));
-
- Put_Line ("end " & Package_Name & ";");
- Close (Spec_File);
- Set_Output (Standard_Output);
-
- end Create_Ada_Actions_Spec;
-
- procedure Create_Ada_Main_Spec
- (Output_File_Name : in String;
- Main_Package_Name : in String;
- Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Common_Data : in Output_Ada_Common.Common_Data)
- is
- Lower_Package_Name : constant String := To_Lower (Main_Package_Name);
-
- Spec_File : File_Type;
-
- procedure LR_Process
- is begin
- Indent_Line ("procedure Create_Parser");
- if Input_Data.Language_Params.Error_Recover then
- Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
- Indent_Line (" Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;");
- Indent_Line (" Language_Matching_Begin_Tokens : in " &
-
"WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;");
- Indent_Line (" Language_String_ID_Set : in " &
-
"WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;");
- else
- Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;");
- Indent_Line (" -- no error recovery");
- end if;
- Indent_Line (" Trace : not null access
WisiToken.Trace'Class;");
- Indent_Start (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access");
-
- if Common_Data.Text_Rep then
- Put_Line (";");
- Indent_Line (" Text_Rep_File_Name : in String);");
- else
- Put_Line (");");
- end if;
- New_Line;
- end LR_Process;
-
- procedure Packrat_Process
- is begin
- Indent_Line ("function Create_Parser");
- Indent_Line (" (Trace : not null access WisiToken.Trace'Class;");
- Indent_Line (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access)");
- Indent_Line (" return WisiToken.Parse.Base_Parser'Class;");
- New_Line;
- end Packrat_Process;
-
- begin
- if Common_Data.Generate_Algorithm = External then
- raise SAL.Programmer_Error;
- end if;
-
- Create (Spec_File, Out_File, Output_File_Name);
- Set_Output (Spec_File);
- Indent := 1;
-
- Put_File_Header
- (Ada_Comment, Use_Tuple => True, Tuple =>
- (Common_Data.Generate_Algorithm, Common_Data.Output_Language,
Common_Data.Lexer, Common_Data.Interface_Kind,
- Common_Data.Text_Rep));
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
- New_Line;
-
- case Common_Data.Output_Language is
- when Ada_Lang =>
- Put_Line ("with WisiToken.Syntax_Trees;");
-
- when Ada_Emacs_Lang =>
- case Common_Data.Interface_Kind is
- when Process =>
- Put_Line ("with WisiToken.Syntax_Trees;");
-
- when Module =>
- Put_Line ("with Emacs_Module_Aux;");
- Put_Line ("with emacs_module_h;");
- Put_Line ("with Interfaces.C;");
- Put_Line ("with WisiToken.Semantic_State;");
- end case;
- end case;
-
- case Common_Data.Generate_Algorithm is
- when LR_Generate_Algorithm =>
- if Input_Data.Language_Params.Error_Recover then
- Put_Line ("with WisiToken.Parse.LR.Parser;");
- else
- Put_Line ("with WisiToken.Parse.LR.Parser_No_Recover;");
- end if;
-
- when Packrat_Generate_Algorithm =>
- Put_Line ("with WisiToken.Parse;");
-
- when External =>
- null;
- end case;
-
- Put_Line ("package " & Main_Package_Name & " is");
- Indent := Indent + 3;
- New_Line;
-
- case Common_Data.Output_Language is
- when Ada_Lang =>
- case Common_Data.Generate_Algorithm is
- when LR_Generate_Algorithm =>
- LR_Process;
- when Packrat_Generate_Algorithm =>
- Packrat_Process;
- when External =>
- null;
- end case;
-
- when Ada_Emacs_Lang =>
- case Common_Data.Interface_Kind is
- when Process =>
- case Common_Data.Generate_Algorithm is
- when LR_Generate_Algorithm =>
- LR_Process;
- when Packrat_Generate_Algorithm =>
- Packrat_Process;
- when External =>
- null;
- end case;
-
- when Module =>
- Indent_Line ("function Parse (Env :
Emacs_Module_Aux.Emacs_Env_Access) return emacs_module_h.emacs_value;");
- Indent_Line ("pragma Export (C, Parse, """ & Lower_Package_Name &
"_wisi_module_parse"");");
- Indent_Line ("function Init (Env :
Emacs_Module_Aux.Emacs_Env_Access) return Interfaces.C.int;");
- Indent_Line ("pragma Export (C, Init, """ & Lower_Package_Name &
"_wisi_module_parse_init"");");
- New_Line;
-
- end case;
- end case;
-
- Put_Line ("end " & Main_Package_Name & ";");
- Close (Spec_File);
- Set_Output (Standard_Output);
- end Create_Ada_Main_Spec;
-
- procedure Create_External_Main_Spec
- (Main_Package_Name : in String;
- Tuple : in Generate_Tuple;
- Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type)
- is
- File_Name : constant String := To_Lower (Main_Package_Name) & ".ads";
- Spec_File : File_Type;
- begin
- Create (Spec_File, Out_File, File_Name);
- Set_Output (Spec_File);
- Indent := 1;
-
- Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
- New_Line;
-
- Put_Line ("with WisiToken.Productions;");
- Put_Line ("package " & Main_Package_Name & " is");
- Indent := Indent + 3;
- New_Line;
-
- Indent_Line ("function Create_Grammar return
WisiToken.Productions.Prod_Arrays.Vector;");
-
- Indent := Indent - 3;
- Put_Line ("end " & Main_Package_Name & ";");
- Close (Spec_File);
- Set_Output (Standard_Output);
- end Create_External_Main_Spec;
-
- procedure Create_LR_Parser_Core_1
- (Common_Data : in Output_Ada_Common.Common_Data;
- Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data)
- is
- use Ada.Strings.Unbounded;
-
- subtype Nonterminal_ID is Token_ID range
- Generate_Data.Grammar.First_Index .. Generate_Data.Grammar.Last_Index;
-
- Table : WisiToken.Parse.LR.Parse_Table_Ptr renames
Generate_Data.LR_Parse_Table;
- Line : Unbounded_String;
-
- procedure Append (Item : in String)
- is begin
- Line := Line & Item;
- end Append;
-
- procedure Put (Label : in String; Item : in Token_ID_Array_Natural)
- is begin
- Indent_Line (Label & " =>");
- Indent_Start (" (");
- Indent := Indent + 3;
- Line := +"";
- for I in Item'Range loop
- Append (Trimmed_Image (Item (I)));
-
- if I = Item'Last then
- Append ("),");
-
- else
- Append (", ");
- end if;
- end loop;
- Indent_Wrap (-Line);
- Indent := Indent - 3;
- end Put;
-
- begin
- Indent_Line ("McKenzie_Param : constant McKenzie_Param_Type :=");
- Indent_Line (" (First_Terminal =>" & Token_ID'Image
(Table.McKenzie_Param.First_Terminal) & ",");
- Indent := Indent + 3;
- Indent_Line ("Last_Terminal =>" & Token_ID'Image
(Table.McKenzie_Param.Last_Terminal) & ",");
- Indent_Line ("First_Nonterminal =>" & Token_ID'Image
(Table.McKenzie_Param.First_Nonterminal) & ",");
- Indent_Line ("Last_Nonterminal =>" & Token_ID'Image
(Table.McKenzie_Param.Last_Nonterminal) & ",");
- Put ("Insert", Table.McKenzie_Param.Insert);
- Put ("Delete", Table.McKenzie_Param.Delete);
- Put ("Push_Back", Table.McKenzie_Param.Push_Back);
- Put ("Undo_Reduce", Table.McKenzie_Param.Undo_Reduce);
- Indent_Line
- ("Minimal_Complete_Cost_Delta => " & Integer'Image
(Table.McKenzie_Param.Minimal_Complete_Cost_Delta) & ",");
- Indent_Line ("Fast_Forward => " & Integer'Image
(Table.McKenzie_Param.Fast_Forward) & ",");
- Indent_Line ("Matching_Begin => " & Integer'Image
(Table.McKenzie_Param.Matching_Begin) & ",");
- Indent_Line ("Ignore_Check_Fail =>" & Integer'Image
(Table.McKenzie_Param.Ignore_Check_Fail) & ",");
- Indent_Line ("Task_Count =>" & System.Multiprocessors.CPU_Range'Image
- (Table.McKenzie_Param.Task_Count) & ",");
- Indent_Line ("Check_Limit =>" & Token_Index'Image
(Table.McKenzie_Param.Check_Limit) & ",");
- Indent_Line ("Check_Delta_Limit =>" & Integer'Image
(Table.McKenzie_Param.Check_Delta_Limit) & ",");
- Indent_Line ("Enqueue_Limit =>" & Integer'Image
(Table.McKenzie_Param.Enqueue_Limit) & ");");
- Indent := Indent - 3;
- New_Line;
-
- if Common_Data.Text_Rep then
- Indent_Line ("function Actions return
WisiToken.Parse.LR.Semantic_Action_Array_Arrays.Vector");
- Indent_Line ("is begin");
- Indent := Indent + 3;
- Indent_Line ("return Acts :
WisiToken.Parse.LR.Semantic_Action_Array_Arrays.Vector do");
- Indent := Indent + 3;
- Indent_Line
- ("Acts.Set_First_Last (" & Trimmed_Image
(Generate_Data.Grammar.First_Index) & ", " &
- Trimmed_Image (Generate_Data.Grammar.Last_Index) & ");");
-
- for I in Nonterminal_ID loop
- declare
- P : Productions.Instance renames Generate_Data.Grammar (I);
- begin
- if Generate_Data.Action_Names (P.LHS) /= null or
Generate_Data.Check_Names (P.LHS) /= null then
- Indent_Line
- ("Acts (" & Trimmed_Image (P.LHS) & ").Set_First_Last (0,"
&
- Integer'Image (P.RHSs.Last_Index) & ");");
-
- for J in P.RHSs.First_Index .. P.RHSs.Last_Index loop
- if (Generate_Data.Action_Names (P.LHS) /= null and then
- Generate_Data.Action_Names (P.LHS)(J) /= null)
- or
- (Generate_Data.Check_Names (P.LHS) /= null and then
- Generate_Data.Check_Names (P.LHS) /= null)
- then
- Indent_Wrap
- ("Acts (" & Trimmed_Image (P.LHS) & ")(" &
Trimmed_Image (J) & ") := (" &
- (if Generate_Data.Action_Names (P.LHS) = null
then "null"
- elsif Generate_Data.Action_Names (P.LHS)(J) =
null then "null"
- else Generate_Data.Action_Names (P.LHS)(J).all &
"'Access") & ", " &
- (if Generate_Data.Check_Names (P.LHS) = null then
"null"
- elsif Generate_Data.Check_Names (P.LHS)(J) =
null then "null"
- else Generate_Data.Check_Names (P.LHS)(J).all &
"'Access") & ");");
- end if;
- end loop;
- end if;
- end;
- end loop;
- Indent := Indent - 3;
- Indent_Line ("end return;");
- Indent := Indent - 3;
- Indent_Line ("end Actions;");
- New_Line;
- end if;
- end Create_LR_Parser_Core_1;
-
- procedure Create_LR_Parser_Table
- (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data)
- is
- use all type Ada.Containers.Count_Type;
- use WisiToken.Parse.LR;
- use Ada.Strings.Unbounded;
-
- Table : WisiToken.Parse.LR.Parse_Table_Ptr renames
Generate_Data.LR_Parse_Table;
- Lines_Per_Subr : constant := 1000;
- Subr_Count : Integer := 1;
- Last_Subr_Closed : Boolean := False;
- Line : Unbounded_String;
-
- procedure Append (Item : in String)
- is begin
- Line := Line & Item;
- end Append;
- begin
- -- Optimize source structure for GNAT compile time; one subroutine
- -- with thousands of "Table.States (*) := ..." takes forever to
- -- compile (apparently depending on available memory). But hundreds
- -- of subroutines, containing the same lines in chunks of 1000,
- -- compiles in acceptable time.
-
- Indent_Line ("declare");
- Indent := Indent + 3;
-
- Indent_Line ("procedure Subr_" & Trimmed_Image (Subr_Count));
- Indent_Line ("is begin");
- Indent := Indent + 3;
- Line_Count := 0;
-
- Declare_Subroutines :
- for State_Index in Table.States'Range loop
- Actions :
- declare
- use Ada.Containers;
- Base_Indent : constant Ada.Text_IO.Count := Indent;
- begin
- Indent_Line
- ("Table.States (" & Trimmed_Image (State_Index) &
").Action_List.Set_Capacity (" &
- Trimmed_Image (Table.States (State_Index).Action_List.Length)
& ");");
-
- if Duplicate_Reduce (Table.States (State_Index)) then
- if Table.States (State_Index).Action_List.Length > 0 then
- -- We only get here with Length = 0 when there's a bug in
LALR_Generate.
- declare
- Node : Action_Node renames Table.States
(State_Index).Action_List (1);
- Action : constant Reduce_Action_Rec := Node.Actions.Item;
- begin
- Set_Col (Indent);
- Line := +"Add_Action (Table.States (" & Trimmed_Image
(State_Index) & "), " &
- Symbols_Image (Table.States (State_Index)) & ", " &
- Image (Action.Production) & ", " &
- Count_Type'Image (Action.Token_Count) & ", ";
-
- Append
- ((if Generate_Data.Action_Names (Action.Production.LHS)
= null then "null"
- elsif Generate_Data.Action_Names
- (Action.Production.LHS)(Action.Production.RHS) =
null then "null"
- else Generate_Data.Action_Names
- (Action.Production.LHS)(Action.Production.RHS).all
& "'Access"));
- Append (", ");
- Append
- ((if Generate_Data.Check_Names (Action.Production.LHS)
= null then "null"
- elsif Generate_Data.Check_Names
- (Action.Production.LHS)(Action.Production.RHS) =
null then "null"
- else Generate_Data.Check_Names
- (Action.Production.LHS)(Action.Production.RHS).all
& "'Access"));
-
- Indent_Wrap (-Line & ");");
- Line_Count := Line_Count + 1;
- Indent := Base_Indent;
- end;
- end if;
-
- else
- for Node of Table.States (State_Index).Action_List loop
- Set_Col (Indent);
- declare
- Action_Node : Parse_Action_Node_Ptr := Node.Actions;
- begin
- case Action_Node.Item.Verb is
- when Shift =>
- Line := +"Add_Action (Table.States (" & Trimmed_Image
(State_Index) & "), " &
- Trimmed_Image (Node.Symbol) & ", ";
- Append (Image (Action_Node.Item.Production) & ", ");
- Append (Trimmed_Image (Action_Node.Item.State));
- Append (");");
-
- when Reduce | Accept_It =>
- Line := +"Add_Action (Table.States (" & Trimmed_Image
(State_Index) & "), " &
- Trimmed_Image (Node.Symbol);
- if Action_Node.Item.Verb = Reduce then
- Append (", Reduce");
- else
- Append (", Accept_It");
- end if;
- Append (", ");
- Append (Image (Action_Node.Item.Production) & ", ");
- Append (Count_Type'Image
(Action_Node.Item.Token_Count) & ", ");
- Append
- ((if Generate_Data.Action_Names
(Action_Node.Item.Production.LHS) = null then "null"
- elsif Generate_Data.Action_Names
-
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS) = null
- then "null"
- else Generate_Data.Action_Names
-
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
- "'Access"));
- Append (", ");
- Append
- ((if Generate_Data.Check_Names
(Action_Node.Item.Production.LHS) = null then "null"
- elsif Generate_Data.Check_Names
-
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS) = null
- then "null"
- else Generate_Data.Check_Names
-
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
- "'Access"));
- Append (");");
-
- when Parse.LR.Error =>
- raise SAL.Programmer_Error;
- end case;
- Indent_Wrap (-Line);
- Line_Count := Line_Count + 1;
-
- loop
- Action_Node := Action_Node.Next;
- exit when Action_Node = null;
- -- There is a conflict; must be Shift/{Reduce|Accept}
or Reduce/{Reduce|Accept}.
- -- The added parameters are the same in either case.
- case Action_Node.Item.Verb is
- when Reduce | Accept_It =>
- Line := +"Add_Conflict (Table.States (" &
Trimmed_Image (State_Index) & "), " &
- Trimmed_Image (Node.Symbol) & ", ";
- Append (Image (Action_Node.Item.Production) & ", ");
- Append (Count_Type'Image
(Action_Node.Item.Token_Count) & ", ");
- Append
- ((if Generate_Data.Action_Names
(Action_Node.Item.Production.LHS) = null then "null"
- elsif Generate_Data.Action_Names
-
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS) = null
- then "null"
- else Generate_Data.Action_Names
-
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
- "'Access"));
- Append (", ");
- Append
- ((if Generate_Data.Check_Names
(Action_Node.Item.Production.LHS) = null then "null"
- elsif Generate_Data.Check_Names
-
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS) = null
- then "null"
- else Generate_Data.Check_Names
-
(Action_Node.Item.Production.LHS)(Action_Node.Item.Production.RHS).all &
- "'Access"));
- Indent_Wrap (-Line & ");");
- Line_Count := Line_Count + 1;
-
- when others =>
- raise SAL.Programmer_Error with "invalid conflict
action verb: " &
- Parse.LR.Parse_Action_Verbs'Image
(Action_Node.Item.Verb);
- end case;
- end loop;
- end;
- Indent := Base_Indent;
- end loop;
- end if;
- end Actions;
-
- if Table.States (State_Index).Goto_List.Length > 0 then
- Indent_Line
- ("Table.States (" & Trimmed_Image (State_Index) &
").Goto_List.Set_Capacity (" &
- Trimmed_Image (Table.States (State_Index).Goto_List.Length) &
");");
- end if;
- Gotos :
- for Node of Table.States (State_Index).Goto_List loop
- Set_Col (Indent);
- Put ("Add_Goto (Table.States (" & Trimmed_Image (State_Index) &
"), ");
- Put_Line (Trimmed_Image (Node.Symbol) & ", " & Trimmed_Image
(Node.State) & ");");
- Line_Count := Line_Count + 1;
- end loop Gotos;
-
- if Input_Data.Language_Params.Error_Recover then
- if Table.States (State_Index).Kernel.Length > 0 then
- Indent_Wrap
- ("Table.States (" & Trimmed_Image (State_Index) & ").Kernel
:= To_Vector (" &
- Image (Table.States (State_Index).Kernel, Strict => True)
& ");");
- end if;
- if Table.States (State_Index).Minimal_Complete_Actions.Length > 0
then
- Indent_Wrap
- ("Table.States (" & Trimmed_Image (State_Index) &
").Minimal_Complete_Actions := To_Vector (" &
- Strict_Image (Table.States
(State_Index).Minimal_Complete_Actions, Strict => True) & ");");
- end if;
- end if;
-
- if Line_Count > Lines_Per_Subr then
- Line_Count := 0;
- Indent := Indent - 3;
- Indent_Line ("end Subr_" & Trimmed_Image (Subr_Count) & ";");
-
- if State_Index < Table.States'Last then
- Subr_Count := Subr_Count + 1;
- Last_Subr_Closed := False;
- Indent_Line ("procedure Subr_" & Trimmed_Image (Subr_Count));
- Indent_Line ("is begin");
- Indent := Indent + 3;
- else
- Last_Subr_Closed := True;
- end if;
- end if;
-
- end loop Declare_Subroutines;
-
- if not Last_Subr_Closed then
- Indent := Indent - 3;
- Indent_Line ("end Subr_" & Trimmed_Image (Subr_Count) & ";");
- end if;
-
- Indent := Indent - 3;
- Indent_Line ("begin");
- Indent := Indent + 3;
-
- for Subr in 1 .. Subr_Count loop
- Indent_Line ("Subr_" & Trimmed_Image (Subr) & ";");
- end loop;
- Indent_Line ("Table.Error_Action := new Parse_Action_Node'((Verb =>
Error, others => <>), null);");
- Indent := Indent - 3;
- Indent_Line ("end;");
- end Create_LR_Parser_Table;
-
- procedure LR_Create_Create_Parser
- (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Common_Data : in out Output_Ada_Common.Common_Data;
- Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data)
- is
- Table : WisiToken.Parse.LR.Parse_Table_Ptr renames
Generate_Data.LR_Parse_Table;
- begin
- Indent_Line ("procedure Create_Parser");
- case Common_Data.Interface_Kind is
- when Process =>
- if Input_Data.Language_Params.Error_Recover then
- Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
- Indent_Line (" Language_Fixes : in
WisiToken.Parse.LR.Parser.Language_Fixes_Access;");
- Indent_Line (" Language_Matching_Begin_Tokens : in " &
-
"WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;");
- Indent_Line
- (" Language_String_ID_Set : in
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;");
- else
- Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;");
- end if;
- Indent_Line (" Trace : not null access
WisiToken.Trace'Class;");
- Indent_Start (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access");
-
- when Module =>
- Indent_Line (" (Parser : out
WisiToken.Parse.LR.Parser.Parser;");
- Indent_Line (" Env : in Emacs_Env_Access;");
- Indent_Start (" Lexer_Elisp_Symbols : in
Lexers.Elisp_Array_Emacs_Value");
- end case;
-
- if Common_Data.Text_Rep then
- Put_Line (";");
- Indent_Line (" Text_Rep_File_Name : in String)");
- else
- Put_Line (")");
- end if;
-
- Indent_Line ("is");
- Indent := Indent + 3;
-
- Indent_Line ("use WisiToken.Parse.LR;");
-
- if Common_Data.Text_Rep then
- Create_LR_Parser_Core_1 (Common_Data, Generate_Data);
- Indent_Line ("Table : constant Parse_Table_Ptr := Get_Text_Rep");
- Indent_Line (" (Text_Rep_File_Name, McKenzie_Param, Actions);");
- Indent := Indent - 3;
- Indent_Line ("begin");
- Indent := Indent + 3;
-
- else
- if Input_Data.Language_Params.Error_Recover then
- Create_LR_Parser_Core_1 (Common_Data, Generate_Data);
- end if;
-
- Indent_Line ("Table : constant Parse_Table_Ptr := new Parse_Table");
- Indent_Line (" (State_First => 0,");
- Indent := Indent + 3;
- Indent_Line ("State_Last =>" & State_Index'Image
(Table.State_Last) & ",");
- Indent_Line ("First_Terminal =>" & Token_ID'Image
(Table.First_Terminal) & ",");
- Indent_Line ("Last_Terminal =>" & Token_ID'Image
(Table.Last_Terminal) & ",");
- Indent_Line ("First_Nonterminal =>" & Token_ID'Image
(Table.First_Nonterminal) & ",");
- Indent_Line ("Last_Nonterminal =>" & Token_ID'Image
(Table.Last_Nonterminal) & ");");
- Indent := Indent - 3;
-
- Indent := Indent - 3;
- Indent_Line ("begin");
- Indent := Indent + 3;
- if Input_Data.Language_Params.Error_Recover then
- Indent_Line ("Table.McKenzie_Param := McKenzie_Param;");
- end if;
- Create_LR_Parser_Table (Input_Data, Generate_Data);
- New_Line;
- end if;
-
- if Input_Data.Language_Params.Error_Recover then
- Indent_Line ("WisiToken.Parse.LR.Parser.New_Parser");
- else
- Indent_Line ("WisiToken.Parse.LR.Parser_No_Recover.New_Parser");
- end if;
- Indent_Line (" (Parser,");
- case Common_Data.Interface_Kind is
- when Process =>
- Indent_Line (" Trace,");
- Indent_Line (" Lexer.New_Lexer (Trace.Descriptor),");
- Indent_Line (" Table,");
- if Input_Data.Language_Params.Error_Recover then
- Indent_Line (" Language_Fixes,");
- Indent_Line (" Language_Matching_Begin_Tokens,");
- Indent_Line (" Language_String_ID_Set,");
- end if;
- Indent_Line (" User_Data,");
- Indent_Line (" Max_Parallel => 15,");
- Indent_Line (" Terminate_Same_State => True);");
-
- when Module =>
- Indent_Line (" Lexer.New_Lexer (Env, Lexer_Elisp_Symbols),");
- Indent_Line (" Table, Max_Parallel => 15, Terminate_Same_State =>
True);");
-
- end case;
- Indent := Indent - 3;
- Indent_Line ("end Create_Parser;");
- end LR_Create_Create_Parser;
-
- procedure Packrat_Create_Create_Parser
- (Common_Data : in out Output_Ada_Common.Common_Data;
- Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
- Packrat_Data : in WisiToken.Generate.Packrat.Data)
- is
- use Ada.Strings.Unbounded;
-
- Text : Unbounded_String;
- Need_Bar : Boolean := True;
- begin
- Indent_Line ("function Create_Parser");
- Indent_Line (" (Trace : not null access WisiToken.Trace'Class;");
- Indent_Line (" User_Data : in
WisiToken.Syntax_Trees.User_Data_Access)");
- Indent_Line (" return WisiToken.Parse.Base_Parser'Class");
-
- case Packrat_Generate_Algorithm'(Common_Data.Generate_Algorithm) is
- when Packrat_Gen =>
- Indent_Line ("is begin");
- Indent := Indent + 3;
- Indent_Line ("return Parser :
WisiToken.Parse.Packrat.Generated.Parser do");
- Indent := Indent + 3;
- Indent_Line ("Parser.Trace := Trace;");
- Indent_Line ("Parser.Lexer := Lexer.New_Lexer (Trace.Descriptor);");
- Indent_Line ("Parser.User_Data := User_Data;");
- Indent_Line ("Parser.Parse_WisiToken_Accept :=
Parse_wisitoken_accept_1'Access;");
- Indent := Indent - 3;
- Indent_Line ("end return;");
-
- when Packrat_Proc =>
- Indent_Line ("is");
- Indent := Indent + 3;
- Indent_Line ("use WisiToken;");
- Indent_Line ("use WisiToken.Productions;");
- Indent_Line ("Grammar : Prod_Arrays.Vector;");
- Indent_Line
- ("Direct_Left_Recursive : constant WisiToken.Token_ID_Set (" &
- Trimmed_Image (Generate_Data.Grammar.First_Index) & " .. " &
- Trimmed_Image (Generate_Data.Grammar.Last_Index) & ") :=");
-
- Need_Bar := False;
- if Any (Packrat_Data.Direct_Left_Recursive) then
- for I in Packrat_Data.Direct_Left_Recursive'Range loop
- if Packrat_Data.Direct_Left_Recursive (I) then
- if Need_Bar then
- Text := Text & " | ";
- else
- Need_Bar := True;
- end if;
- Text := Text & Trimmed_Image (I);
- end if;
- end loop;
- Indent_Start (" (");
- Indent := Indent + 3;
- Indent_Wrap (-Text & " => True,");
- Indent_Line ("others => False);");
- Indent := Indent - 3;
- else
- Indent_Line (" (others => False);");
- end if;
- Indent := Indent - 3;
- Indent_Line ("begin");
- Indent := Indent + 3;
- WisiToken.BNF.Generate_Grammar (Generate_Data.Grammar,
Generate_Data.Action_Names.all);
-
- Indent_Line ("return WisiToken.Parse.Packrat.Procedural.Create");
- Indent_Line
- (" (Grammar, Direct_Left_Recursive, " & Trimmed_Image
(Generate_Data.Descriptor.Accept_ID) &
- ", Trace, Lexer.New_Lexer (Trace.Descriptor), User_Data);");
- end case;
- Indent := Indent - 3;
- Indent_Line ("end Create_Parser;");
- New_Line;
- end Packrat_Create_Create_Parser;
-
- procedure External_Create_Create_Grammar
- (Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data)
- is begin
- Indent_Line ("function Create_Grammar return
WisiToken.Productions.Prod_Arrays.Vector");
- Indent_Line ("is");
- Indent_Line (" use WisiToken;");
- Indent_Line (" use WisiToken.Productions;");
- Indent_Line ("begin");
- Indent := Indent + 3;
- Indent_Line ("return Grammar : WisiToken.Productions.Prod_Arrays.Vector
do");
- Indent := Indent + 3;
- WisiToken.BNF.Generate_Grammar (Generate_Data.Grammar,
Generate_Data.Action_Names.all);
- Indent := Indent - 3;
- Indent_Line ("end return;");
- Indent := Indent - 3;
- Indent_Line ("end Create_Grammar;");
- end External_Create_Create_Grammar;
-
- procedure Create_re2c
- (Input_Data : in
WisiToken_Grammar_Runtime.User_Data_Type;
- Tuple : in Generate_Tuple;
- Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
- Output_File_Name_Root : in String)
- is
- use Ada.Strings.Fixed;
- use Generate_Utils;
- use WisiToken.BNF.Utils;
- File : File_Type;
- begin
- Create (File, Out_File, Output_File_Name_Root & ".re2c");
- Set_Output (File);
- Indent := 1;
-
- Put_File_Header (C_Comment, " -*- mode: C -*-", Use_Tuple => True, Tuple
=> Tuple);
- Put_Raw_Code (C_Comment, Input_Data.Raw_Code (Copyright_License));
- New_Line;
-
- Indent_Line ("#include <stddef.h>"); -- size_t
- Indent_Line ("#include <stdio.h>"); -- printf
- Indent_Line ("#include <stdlib.h>"); -- malloc
- New_Line;
-
- Indent_Line ("typedef struct wisi_lexer");
- Indent_Line ("{");
- Indent := Indent + 3;
- Indent_Line ("unsigned char* buffer; // input text, in utf-8
encoding");
- Indent_Line ("unsigned char* buffer_last; // last byte in buffer");
- Indent_Line ("unsigned char* cursor; // current byte");
- Indent_Line ("unsigned char* byte_token_start; // byte position at start
of current token");
- Indent_Line ("size_t char_pos; // character position of
current character");
- Indent_Line ("size_t char_token_start; // character position at
start of current token");
- Indent_Line ("int line; // 1 indexed");
- Indent_Line ("int line_token_start; // line at start of
current token");
- Indent_Line ("unsigned char* marker; // saved cursor");
- Indent_Line ("size_t marker_pos; // saved character
position");
- Indent_Line ("size_t marker_line; // saved line");
- Indent_Line ("unsigned char* context; // saved cursor");
- Indent_Line ("size_t context_pos; // saved character
position");
- Indent_Line ("int context_line; // saved line");
- Indent_Line ("int verbosity;");
- New_Line;
- Indent := Indent - 3;
- Indent_Line ("} wisi_lexer;");
- New_Line;
- Indent_Line ("#define YYCTYPE unsigned char");
- New_Line;
-
- -- Status values:
- Indent_Line ("#define NO_ERROR 0");
- Indent_Line ("#define ERROR_unrecognized_character 1");
-
- ----------
- -- new_lexer, free_lexer, reset_lexer
-
- -- It's normal to increment lexer->cursor one past the end of input,
- -- but not to read that character. To support memory mapped files, we
- -- enforce this strictly; YYPEEK returns EOT (end of text) when
- -- reading past end of buffer; that's how we recognize the end of
- -- text token.
-
- Indent_Line ("wisi_lexer* " & Output_File_Name_Root & "_new_lexer");
- Indent_Line (" (unsigned char* input, size_t length, int verbosity)");
- Indent_Line ("{");
- Indent := Indent + 3;
- Indent_Line ("wisi_lexer* result = malloc (sizeof
(wisi_lexer));");
- Indent_Line ("result->buffer = input;");
- Indent_Line ("result->buffer_last = input + length - 1;");
- Indent_Line ("result->cursor = input;");
- Indent_Line ("result->byte_token_start = input;");
- Indent_Line ("result->char_pos = 1; /* match
WisiToken.Buffer_Region */");
- Indent_Line ("result->char_token_start = 1;");
- Indent_Line ("result->line = (*result->cursor == 0x0A) ? 2
: 1;");
- Indent_Line ("result->line_token_start = result->line;");
- Indent_Line ("result->verbosity = verbosity;");
- Indent_Line ("return result;");
- Indent := Indent - 3;
- Indent_Line ("}");
- New_Line;
-
- Indent_Line ("void");
- Indent_Line (Output_File_Name_Root & "_free_lexer(wisi_lexer** lexer)");
- Indent_Line ("{");
- Indent := Indent + 3;
- Indent_Line ("free(*lexer);");
- Indent_Line ("*lexer = 0;");
- Indent := Indent - 3;
- Indent_Line ("}");
- New_Line;
-
- Indent_Line ("void");
- Indent_Line (Output_File_Name_Root & "_reset_lexer(wisi_lexer* lexer)");
- Indent_Line ("{");
- Indent := Indent + 3;
- Indent_Line ("lexer->cursor = lexer->buffer;");
- Indent_Line ("lexer->char_pos = 1;");
- Indent_Line ("lexer->line = (*lexer->cursor == 0x0A) ? 2 : 1;");
- Indent := Indent - 3;
- Indent_Line ("}");
- New_Line;
-
- ----------
- -- next_token utils
-
- Indent_Line ("static void debug(wisi_lexer* lexer, int state, unsigned
char ch)");
- Indent_Line ("{");
- Indent := Indent + 3;
- Indent_Line ("if (lexer->verbosity > 0)");
- Indent_Line (" {");
- Indent_Line (" if (ch < ' ')");
- Indent_Line (" printf (""lexer: %d, 0x%x\n"", state, ch);");
- Indent_Line (" else");
- Indent_Line (" printf (""lexer: %d, '%c' 0x%x\n"", state, ch,
ch);");
- Indent_Line (" }");
- Indent := Indent - 3;
- Indent_Line ("}");
- Indent_Line ("#define YYDEBUG(state, ch) debug(lexer, state, ch)");
-
- -- YYCURSOR is only used in calls of YYDEBUG; we can't define it as
- -- YYPEEK because it is used as '*YYCURSOR'.
- Indent_Line ("#define YYCURSOR lexer->cursor");
- New_Line;
-
- Indent_Line ("#define YYPEEK() (lexer->cursor <= lexer->buffer_last) ?
*lexer->cursor : 4");
- New_Line;
-
- Indent_Line ("static void skip(wisi_lexer* lexer)");
- Indent_Line ("{");
- Indent := Indent + 3;
- Indent_Line ("if (lexer->cursor <= lexer->buffer_last)");
- Indent_Line (" ++lexer->cursor;");
- Indent_Line ("if (lexer->cursor <= lexer->buffer_last)");
- Indent_Line ("{");
- Indent_Line (" /* UFT-8 encoding:
https://en.wikipedia.org/wiki/UTF-8#Description */");
- Indent_Line (" if (*lexer->cursor == 0x0A && lexer->cursor >
lexer->buffer && *(lexer->cursor - 1) == 0x0D)");
- Indent_Line (" {/* second byte of DOS line ending */");
- Indent_Line (" }");
- Indent_Line (" else if ((*lexer->cursor & 0x80) == 0x80 &&
(*lexer->cursor & 0xC0) != 0xC0)");
- Indent_Line (" {/* byte 2, 3 or 4 of multi-byte UTF-8 char */");
- Indent_Line (" }");
- Indent_Line (" else");
- Indent_Line (" ++lexer->char_pos;");
- Indent_Line (" if (*lexer->cursor == 0x0A) ++lexer->line;");
- Indent_Line ("}");
- Indent := Indent - 3;
- Indent_Line ("}");
- Indent_Start ("#define YYSKIP() skip(lexer)");
- New_Line;
-
- Indent_Line ("#define YYBACKUP() lexer->marker = lexer->cursor;
lexer->marker_pos = lexer->char_pos;" &
- "lexer->marker_line = lexer->line");
- Indent_Line ("#define YYRESTORE() lexer->cursor = lexer->marker;
lexer->char_pos = lexer->marker_pos;" &
- "lexer->line = lexer->marker_line");
- Indent_Line ("#define YYBACKUPCTX() lexer->context = lexer->cursor;
lexer->context_pos = lexer->char_pos;" &
- "lexer->context_line = lexer->line");
- Indent_Line ("#define YYRESTORECTX() lexer->cursor = lexer->context;
lexer->char_pos = lexer->context_pos;" &
- "lexer->line = lexer->context_line");
- New_Line;
-
- if Is_In (Input_Data.Tokens.Tokens, "delimited-text") then
- Indent_Line ("static void skip_to(wisi_lexer* lexer, char* target)");
- Indent_Line ("{");
- Indent_Line (" int i;");
- New_Line;
- Indent_Line (" while (lexer->cursor <= lexer->buffer_last)");
- Indent_Line (" {");
- Indent_Line (" if (*lexer->cursor == target[0])");
- Indent_Line (" {");
- Indent_Line (" i = 0;");
- Indent_Line (" do");
- Indent_Line (" i++;");
- Indent_Line (" while (0 != target[i] &&");
- Indent_Line (" lexer->cursor + i <= lexer->buffer_last
&&");
- Indent_Line (" *(lexer->cursor + i) == target[i]);");
- New_Line;
- Indent_Line (" if (0 == target[i])");
- Indent_Line (" {");
- Indent_Line (" for (i = 0; 0 != target[i]; i++)");
- Indent_Line (" skip(lexer);");
- Indent_Line (" break;");
- Indent_Line (" }");
- Indent_Line (" }");
- Indent_Line (" skip(lexer);");
- Indent_Line (" };");
- Indent_Line ("}");
- New_Line;
- end if;
-
- ----------
- -- next_token
- Indent_Line ("int " & Output_File_Name_Root & "_next_token");
- Indent_Line (" (wisi_lexer* lexer,");
- Indent_Line (" int* id,");
- Indent_Line (" size_t* byte_position,");
- Indent_Line (" size_t* byte_length,");
- Indent_Line (" size_t* char_position,");
- Indent_Line (" size_t* char_length,");
- Indent_Line (" int* line_start)");
- Indent_Line ("{");
- Indent := Indent + 3;
-
- Indent_Line ("int status = NO_ERROR;");
- Indent_Line ("*id = -1;"); -- Token_ID'First = 0; see dragon_4_43.wy
-
- Indent_Line ("if (lexer->cursor > lexer->buffer_last)");
- Indent_Line ("{");
- Indent := Indent + 3;
- Indent_Line ("*id =" & WisiToken.Token_ID'Image
(Generate_Data.Descriptor.EOI_ID) & ";");
- Indent_Line ("*byte_position = lexer->buffer_last - lexer->buffer + 1;");
- Indent_Line ("*byte_length = 0;");
- Indent_Line ("*char_position = lexer->char_token_start;");
- Indent_Line ("*char_length = 0;");
- Indent_Line ("*line_start = lexer->line;");
- Indent_Line ("return status;");
- Indent := Indent - 3;
- Indent_Line ("}");
- New_Line;
-
- Indent_Line ("lexer->byte_token_start = lexer->cursor;");
- Indent_Line ("lexer->char_token_start = lexer->char_pos;");
- Indent_Line ("if (*lexer->cursor == 0x0A)");
- Indent_Line (" lexer->line_token_start = lexer->line-1;");
- Indent_Line ("else");
- Indent_Line (" lexer->line_token_start = lexer->line;");
- New_Line;
-
- Indent_Line ("while (*id == -1 && status == 0)");
- Indent_Line ("{");
- Indent := Indent + 3;
-
- Put_Line ("/*!re2c");
- Indent_Line ("re2c:yyfill:enable = 0;");
- Indent_Line ("re2c:sentinel = 4;");
- New_Line;
-
- -- Regexps used in definitions
- for Pair of Input_Data.Tokens.re2c_Regexps loop
- Indent_Line (-Pair.Name & " = " & (-Pair.Value) & ";");
- end loop;
- New_Line;
-
- -- definitions
- for I in All_Tokens (Generate_Data).Iterate (Non_Grammar => True,
Nonterminals => False) loop
-
- if 0 /= Index (Source => Value (I), Pattern => "/") then
- -- trailing context syntax; forbidden in definitions
- null;
-
- elsif Kind (I) = "EOI" then
- Indent_Line (Name (I) & " = [\x04];");
-
- elsif Kind (I) = "delimited-text" then
- -- not declared in definitions
- null;
-
- elsif Kind (I) = "keyword" and
Input_Data.Language_Params.Case_Insensitive then
- -- This assumes re2c regular expression syntax, where single quote
- -- means case insensitive.
- Indent_Line (Name (I) & " = '" & Strip_Quotes (Value (I)) & "';");
-
- else
- -- Other kinds have values that are regular expressions, in re2c
syntax
- Indent_Line (Name (I) & " = " & Value (I) & ";");
- end if;
- end loop;
- New_Line;
-
- -- lexer rules
- for I in All_Tokens (Generate_Data).Iterate (Non_Grammar => True,
Nonterminals => False) loop
- declare
- Val : constant String := Value (I);
- begin
-
- if Kind (I) = "non-reporting" then
- Indent_Line (Name (I) & " { lexer->byte_token_start =
lexer->cursor;");
- Indent_Line (" lexer->char_token_start = lexer->char_pos;");
- Indent_Line (" if (*lexer->cursor == 0x0A)");
- Indent_Line (" lexer->line_token_start = lexer->line-1;");
- Indent_Line (" else");
- Indent_Line (" lexer->line_token_start = lexer->line;");
- Indent_Line (" continue; }");
-
- elsif Kind (I) = "delimited-text" then
- Indent_Line
- (Val & " {*id = " & WisiToken.Token_ID'Image (ID (I)) &
- "; skip_to(lexer, " & Repair_Image (I) & ");
continue;}");
-
- elsif 0 /= Index (Source => Val, Pattern => "/") then
- Indent_Line (Val & " {*id = " & WisiToken.Token_ID'Image (ID
(I)) & "; continue;}");
-
- else
- Indent_Line (Name (I) & " {*id = " & WisiToken.Token_ID'Image
(ID (I)) & "; continue;}");
- end if;
- end;
- end loop;
- New_Line;
-
- -- Default action.
- Indent_Line ("* {status = ERROR_unrecognized_character; continue;}");
-
- Put_Line ("*/");
- Indent := Indent - 3;
- Indent_Line ("}");
-
- Indent_Line ("/* lexer->cursor and lexer ->char_pos are one char past
end of token */");
- Indent_Line ("*byte_position = lexer->byte_token_start - lexer->buffer +
1;");
- Indent_Line ("*byte_length = lexer->cursor -
lexer->byte_token_start;");
- Indent_Line ("*char_position = lexer->char_token_start;");
- Indent_Line ("*char_length = lexer->char_pos -
lexer->char_token_start;");
- Indent_Line ("*line_start = lexer->line_token_start;");
- Indent_Line ("return status;");
- Indent_Line ("}");
- Indent := Indent - 3;
- Set_Output (Standard_Output);
- Close (File);
-
- declare
- Ada_Name : constant String := Output_File_Name_Root & "_re2c_c";
- -- Output_File_Name_Root is the file name of the grammar file -
- -- assume it is a legal Ada name.
- begin
- Create (File, Out_File, Output_File_Name_Root & "_re2c_c.ads");
- Set_Output (File);
- Indent := 1;
- Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
- New_Line;
-
- Put_Line ("with Interfaces.C;");
- Put_Line ("with WisiToken;");
- Put_Line ("with System;");
- Put_Line ("package " & Ada_Name & " is");
- Indent := Indent + 3;
- New_Line;
-
- Indent_Line ("function New_Lexer");
- Indent_Line (" (Buffer : in System.Address;");
- Indent_Line (" Length : in Interfaces.C.size_t;");
- Indent_Line (" Verbosity : in Interfaces.C.int)");
- Indent_Line (" return System.Address");
- Indent_Line ("with Import => True,");
- Indent_Line (" Convention => C,");
- Indent_Line (" External_Name => """ & Output_File_Name_Root &
"_new_lexer"";");
- Indent_Line ("-- Create the lexer object, passing it the full text
to process.");
- New_Line;
- Indent_Line ("procedure Free_Lexer (Lexer : in out System.Address)");
- Indent_Line ("with Import => True,");
- Indent_Line (" Convention => C,");
- Indent_Line (" External_Name => """ & Output_File_Name_Root &
"_free_lexer"";");
- Indent_Line ("-- Free the lexer object");
- New_Line;
-
- Indent_Line ("procedure Reset_Lexer (Lexer : in System.Address)");
- Indent_Line ("with Import => True,");
- Indent_Line (" Convention => C,");
- Indent_Line (" External_Name => """ & Output_File_Name_Root &
"_reset_lexer"";");
- New_Line;
-
- Indent_Line ("function Next_Token");
- Indent_Line (" (Lexer : in System.Address;");
- Indent_Line (" ID : out WisiToken.Token_ID;");
- Indent_Line (" Byte_Position : out Interfaces.C.size_t;");
- Indent_Line (" Byte_Length : out Interfaces.C.size_t;");
- Indent_Line (" Char_Position : out Interfaces.C.size_t;");
- Indent_Line (" Char_Length : out Interfaces.C.size_t;");
- Indent_Line (" Line_Start : out Interfaces.C.int)");
- Indent_Line (" return Interfaces.C.int");
- Indent_Line ("with Import => True,");
- Indent_Line (" Convention => C,");
- Indent_Line (" External_Name => """ & Output_File_Name_Root &
"_next_token"";");
- New_Line;
-
- Indent := Indent - 3;
- Put_Line ("end " & Ada_Name & ";");
- Set_Output (Standard_Output);
- Close (File);
- end;
- end Create_re2c;
-
- function File_Name_To_Ada (File_Name : in String) return String
- is
- Result : String := File_Name;
- begin
- Result (Result'First) := To_Upper (Result (Result'First));
- for I in Result'Range loop
- if Result (I) = '-' then
- Result (I) := '.';
- Result (I + 1) := To_Upper (Result (I + 1));
- elsif Result (I) = '_' then
- Result (I + 1) := To_Upper (Result (I + 1));
- end if;
- end loop;
- return Result;
- end File_Name_To_Ada;
-
- function Initialize
- (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Tuple : in Generate_Tuple;
- Output_File_Root : in String;
- Check_Interface : in Boolean)
- return Common_Data
- is begin
- return Data : Common_Data do
- Data.Generate_Algorithm := Tuple.Gen_Alg;
-
- Data.Output_Language := Ada_Output_Language (Tuple.Out_Lang);
-
- if Tuple.Gen_Alg = External or else Input_Data.User_Lexer in
Valid_Lexer then
- Data.Lexer := Input_Data.User_Lexer;
- else
- raise SAL.Programmer_Error with "tuple.alg " &
Generate_Algorithm'Image (Tuple.Gen_Alg) &
- " input_data.user_lexer " & Lexer_Image
(Input_Data.User_Lexer).all;
- end if;
-
- if Check_Interface then
- if Tuple.Interface_Kind in Valid_Interface then
- Data.Interface_Kind := Valid_Interface (Tuple.Interface_Kind);
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, 1, "Interface_Kind
not set"));
- end if;
- else
- Data.Interface_Kind := Process;
- end if;
-
- Data.Text_Rep := Tuple.Text_Rep;
-
- Data.Lower_File_Name_Root := +To_Lower (Output_File_Root);
- end return;
- end Initialize;
-
- function To_Token_Ada_Name (WY_Name : in String) return String
- is
- -- Convert WY_Name to a valid Ada identifier:
- --
- -- Add "_ID" to avoid collision with Ada reserved words
- --
- -- Replace '-' with '_'
- Image : String := WY_Name;
- begin
- for I in Image'Range loop
- if Image (I) = '-' then
- Image (I) := '_';
- end if;
- end loop;
- return Image & "_ID";
- end To_Token_Ada_Name;
-
-end WisiToken.BNF.Output_Ada_Common;
diff --git a/packages/wisi/wisitoken-bnf-output_ada_common.ads
b/packages/wisi/wisitoken-bnf-output_ada_common.ads
deleted file mode 100644
index 44d7a63..0000000
--- a/packages/wisi/wisitoken-bnf-output_ada_common.ads
+++ /dev/null
@@ -1,90 +0,0 @@
--- Abstract :
---
--- Types and operations shared by Ada and Ada_Emacs outputs.
---
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.BNF.Generate_Utils;
-with WisiToken.Generate.Packrat;
-with WisiToken_Grammar_Runtime;
-package WisiToken.BNF.Output_Ada_Common is
-
- function To_Token_Ada_Name (WY_Name : in String) return String;
-
- type Common_Data is limited record
- -- Validated versions of Tuple values
- Generate_Algorithm : WisiToken.BNF.Valid_Generate_Algorithm;
- Lexer : Lexer_Type; -- 'none' valid for Libadalang
- Output_Language : Ada_Output_Language;
- Interface_Kind : Valid_Interface;
- Text_Rep : Boolean;
-
- Lower_File_Name_Root : Standard.Ada.Strings.Unbounded.Unbounded_String;
- end record;
-
- function Initialize
- (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Tuple : in Generate_Tuple;
- Output_File_Root : in String;
- Check_Interface : in Boolean)
- return Common_Data;
-
- function File_Name_To_Ada (File_Name : in String) return String;
-
- procedure Create_Ada_Actions_Spec
- (Output_File_Name : in String;
- Package_Name : in String;
- Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Common_Data : in Output_Ada_Common.Common_Data;
- Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data);
-
- procedure Create_Ada_Main_Spec
- (Output_File_Name : in String;
- Main_Package_Name : in String;
- Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Common_Data : in Output_Ada_Common.Common_Data)
- with Pre => Common_Data.Generate_Algorithm /= External;
-
- procedure Create_External_Main_Spec
- (Main_Package_Name : in String;
- Tuple : in Generate_Tuple;
- Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type);
-
- procedure LR_Create_Create_Parser
- (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Common_Data : in out Output_Ada_Common.Common_Data;
- Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data);
- -- If not Common_Data.Text_Rep, includes LR parse table in generated
- -- source. Otherwise, includes call to LR.Get_Text_Rep; caller must
- -- call Put_Text_Rep to create file.
-
- procedure Packrat_Create_Create_Parser
- (Common_Data : in out Output_Ada_Common.Common_Data;
- Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
- Packrat_Data : in WisiToken.Generate.Packrat.Data);
-
- procedure External_Create_Create_Grammar
- (Generate_Data : in WisiToken.BNF.Generate_Utils.Generate_Data);
-
- procedure Create_re2c
- (Input_Data : in
WisiToken_Grammar_Runtime.User_Data_Type;
- Tuple : in Generate_Tuple;
- Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
- Output_File_Name_Root : in String);
- -- Create_re2c is called from wisitoken-bnf-generate, which does not
declare
- -- Common_Data.
-
-end WisiToken.BNF.Output_Ada_Common;
diff --git a/packages/wisi/wisitoken-bnf-output_ada_emacs.adb
b/packages/wisi/wisitoken-bnf-output_ada_emacs.adb
deleted file mode 100644
index c0e91c2..0000000
--- a/packages/wisi/wisitoken-bnf-output_ada_emacs.adb
+++ /dev/null
@@ -1,1916 +0,0 @@
--- Abstract :
---
--- Output Ada code implementing the grammar defined by input
--- parameters, and a parser for that grammar. The parser actions
--- assume the Emacs Ada mode wisi indentation engine
---
--- If run in a separate process communicating over pipes with the
--- Emacs process, the parser actions output encoded elisp actions;
--- the protocol is documented in Emacs Ada mode wisi-process-parse.el,
--- function wisi-process-parse-execute.
---
--- If run in an Emacs dynamically loaded module, the parser actions
--- call the elisp actions directly.
---
--- Copyright (C) 2012 - 2015, 2017 - 2020 Free Software Foundation, Inc.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Exceptions;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Ada.Text_IO; use Ada.Text_IO;
-with WisiToken.BNF.Generate_Packrat;
-with WisiToken.BNF.Generate_Utils;
-with WisiToken.BNF.Output_Ada_Common; use WisiToken.BNF.Output_Ada_Common;
-with WisiToken.BNF.Output_Elisp_Common; use WisiToken.BNF.Output_Elisp_Common;
-with WisiToken.Generate.Packrat;
-with WisiToken_Grammar_Runtime;
-procedure WisiToken.BNF.Output_Ada_Emacs
- (Input_Data : in WisiToken_Grammar_Runtime.User_Data_Type;
- Output_File_Name_Root : in String;
- Generate_Data : aliased in
WisiToken.BNF.Generate_Utils.Generate_Data;
- Packrat_Data : in WisiToken.Generate.Packrat.Data;
- Tuple : in Generate_Tuple;
- Test_Main : in Boolean;
- Multiple_Tuples : in Boolean;
- Language_Name : in String)
-is
- use all type Ada.Containers.Count_Type;
-
- Default_Language_Runtime_Package : constant String := "Wisi." &
Language_Name;
-
- Blank_Set : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set (" ");
- Numeric : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set ("0123456789");
-
- Common_Data : Output_Ada_Common.Common_Data :=
WisiToken.BNF.Output_Ada_Common.Initialize
- (Input_Data, Tuple, Output_File_Name_Root, Check_Interface => True);
-
- Gen_Alg_Name : constant String :=
- (if Test_Main or Multiple_Tuples
- then "_" & WisiToken.BNF.Generate_Algorithm_Image
(Common_Data.Generate_Algorithm).all
- else "");
-
- function Split_Sexp
- (Item : in String;
- Input_File_Name : in String;
- Source_Line : in WisiToken.Line_Number_Type)
- return String_Lists.List
- is
- -- Return one sexp per element. Remove comments, newlines, and outer
'(progn )'.
-
- use WisiToken.Generate;
-
- Progn_Index : constant Integer := Ada.Strings.Fixed.Index (Item,
"(progn");
-
- Item_I : Integer := Item'First;
-
- Buffer : String (Item'First .. Item'Last);
- Buffer_J : Integer := Buffer'First;
- Buffer_First : Integer := Buffer'First;
- Paren_Count : Integer := 0;
- In_Comment : Boolean := False;
- Result : String_Lists.List;
-
- Delete_Last_Paren : Boolean := False;
- begin
- -- Loop thru Item, copying chars to Buffer, ignoring comments, newlines.
-
- if 0 /= Progn_Index then
- Item_I := Progn_Index + 6;
-
- Delete_Last_Paren := True;
- end if;
-
- loop
- exit when Item_I > Item'Last;
-
- if In_Comment then
- if Item (Item_I) in ASCII.CR | ASCII.LF then
- In_Comment := False;
- end if;
- else
- if Item (Item_I) = '(' then
- if Paren_Count = 0 then
- Buffer_First := Buffer_J;
- end if;
- Paren_Count := Paren_Count + 1;
-
- Buffer (Buffer_J) := Item (Item_I);
- Buffer_J := Buffer_J + 1;
-
- elsif Item (Item_I) = ')' then
- Paren_Count := Paren_Count - 1;
- if Paren_Count = 0 then
- Buffer (Buffer_J) := Item (Item_I);
- Result.Append (Buffer (Buffer_First .. Buffer_J));
- Buffer_First := Buffer'First;
- Buffer_J := Buffer'First;
-
- elsif Paren_Count = -1 then
- if Delete_Last_Paren then
- -- all done
- return Result;
- else
- Put_Error (Error_Message (Input_File_Name, Source_Line,
"mismatched parens"));
- return String_Lists.Empty_List;
- end if;
- else
- Buffer (Buffer_J) := Item (Item_I);
- Buffer_J := Buffer_J + 1;
- end if;
-
- elsif Item (Item_I) in ASCII.CR | ASCII.LF then
- null;
-
- elsif Item (Item_I) = ';' and then Item_I < Item'Last and then
Item (Item_I + 1) = ';' then
- In_Comment := True;
-
- else
- Buffer (Buffer_J) := Item (Item_I);
- Buffer_J := Buffer_J + 1;
- end if;
- end if;
- Item_I := Item_I + 1;
- end loop;
- if Paren_Count /= 0 then
- Put_Error
- (Error_Message
- (Input_File_Name, Source_Line, "mismatched parens"));
- end if;
- return Result;
- end Split_Sexp;
-
- procedure Create_Ada_Action
- (Name : in String;
- RHS : in RHS_Type;
- Prod_ID : in WisiToken.Production_ID;
- Unsplit_Lines : in Ada.Strings.Unbounded.Unbounded_String;
- Labels : in String_Arrays.Vector;
- Check : in Boolean)
- is
- -- Create Action (if Check = False; Lines must be RHS.Action) or
- -- Check (if Check = True; Lines must be RHS.Check) subprogram named
- -- Name for RHS.
-
- use Ada.Strings;
- use Ada.Strings.Fixed;
- use Ada.Strings.Unbounded;
- use WisiToken.Generate;
-
- Sexps : constant String_Lists.List := Split_Sexp
- (-Unsplit_Lines, Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line);
-
- use all type Ada.Strings.Maps.Character_Set;
-
- Space_Paren_Set : constant Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set ("])") or Blank_Set;
-
- Navigate_Lines : String_Lists.List;
- Face_Line : Unbounded_String;
- Indent_Action_Line : Unbounded_String;
- Check_Line : Unbounded_String;
-
- Label_Needed : array (Labels.First_Index .. Labels.Last_Index) of
Boolean := (others => False);
- Nonterm_Needed : Boolean := False;
-
- function Label_Used (Label : in String) return Boolean
- is
- Found : Boolean := False;
- begin
- for Tok of RHS.Tokens loop
- if -Tok.Label = Label then
- Found := True;
- exit;
- end if;
- end loop;
-
- if not Found then
- return False;
- end if;
-
- for I in Labels.First_Index .. Labels.Last_Index loop
- if Label = Labels (I) then
- Label_Needed (I) := True;
- return True;
- end if;
- end loop;
- raise SAL.Programmer_Error;
- end Label_Used;
-
- function Count_Label_Needed return Ada.Containers.Count_Type
- is
- use Ada.Containers;
- Result : Count_Type := 0;
- begin
- for B of Label_Needed loop
- if B then Result := Result + 1; end if;
- end loop;
- return Result;
- end Count_Label_Needed;
-
- function Find_Token_Index (I : in Base_Identifier_Index) return
SAL.Base_Peek_Type
- is
- Rule_Label : constant String := -Labels (I);
- begin
- for I in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index loop
- if Length (RHS.Tokens (I).Label) > 0 and then
- -RHS.Tokens (I).Label = Rule_Label
- then
- return I;
- end if;
- end loop;
- return SAL.Base_Peek_Type'First;
- end Find_Token_Index;
-
- function Statement_Params (Params : in String) return String
- is
- -- Input looks like: [1 function 2 other ...]
- -- Numbers can be token labels.
-
- Last : Integer := Index_Non_Blank (Params); -- skip [
- First : Integer;
- Second : Integer;
- Need_Comma : Boolean := False;
- Result : Unbounded_String;
- Count : Integer := 0;
- begin
- loop
- First := Last + 1;
- Second := Index (Params, Blank_Set, First);
- exit when Second = 0;
-
- Last := Index (Params, Space_Paren_Set, Second + 1);
-
- declare
- Label : constant String := Params (First .. Second - 1);
- begin
- if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
- Count := Count + 1;
- Result := Result & (if Need_Comma then ", " else "") &
- "(" & Label & ", " &
- Elisp_Name_To_Ada (Params (Second + 1 .. Last - 1),
Append_ID => False, Trim => 0) & ")";
-
- Need_Comma := True;
- -- else skip
- end if;
- end;
- end loop;
- Nonterm_Needed := True;
- return " (Parse_Data, Tree, Nonterm, Tokens, " &
- (case Count is
- when 0 => "(1 .. 0 => (1, Motion)))",
- when 1 => "(1 => " & (-Result) & "))",
- when others => "(" & (-Result) & "))");
- end Statement_Params;
-
- function Motion_Params (Params : in String) return String
- is
- -- Input looks like: [1 [2 EXCEPTION] 3 ...]
- -- Result: (..., Motion_Param_Array'((1, Invalid_Token_ID) & (2, 3)
& (3, Invalid_Token_ID))
- use Generate_Utils;
- use Ada.Strings.Maps;
-
- Delim : constant Character_Set := To_Set ("]") or Blank_Set;
-
- Last : Integer := Index_Non_Blank (Params); -- skip [
- First : Integer;
- Vector : Boolean;
- Result : Unbounded_String;
-
- Index_First : Integer;
- Index_Last : Integer;
- ID : Unbounded_String;
- Need_Comma : Boolean := False;
- Count : Integer := 0;
- begin
- loop
- if not (Last in Params'First .. Params'Last) then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
- "Missing ']' or ')'"));
- exit;
- end if;
- Last := Index_Non_Blank (Params, Integer'Min (Params'Last, Last +
1));
-
- exit when Params (Last) = ']' or Params (Last) = ')';
-
- Vector := Params (Last) = '[';
- if Vector then
- Index_First := Last + 1;
- Last := Index (Params, Delim, Index_First);
- Index_Last := Last - 1;
- First := Last + 1;
- Last := Index (Params, Delim, First);
- begin
- ID := +Trimmed_Image (Find_Token_ID (Generate_Data, Params
(First .. Last - 1)));
- exception
- when E : Not_Found =>
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
- Ada.Exceptions.Exception_Message (E)));
- end;
-
- declare
- Label : constant String := Params (Index_First ..
Index_Last);
- begin
- if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
- Result := Result & (if Need_Comma then " & " else "") &
"(" &
- Label & ", " & ID & ")";
- Need_Comma := True;
- Count := Count + 1;
- end if;
- end;
- if Params (Last) /= ']' then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
- "too many token IDs in motion action"));
- return -Result & "))";
- end if;
-
- else
- First := Index_Non_Blank (Params, Last);
- Last := Index (Params, Delim, First);
- declare
- Label : constant String := Params (First .. Last - 1);
- begin
- if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
- Result := Result & (if Need_Comma then " & " else "") &
"(" & Label & ", Invalid_Token_ID)";
- Need_Comma := True;
- Count := Count + 1;
- end if;
- end;
- end if;
- end loop;
- if Count <= 1 then
- -- No point in calling Motion_Action with only one param.
- return "";
- else
- Nonterm_Needed := True;
- return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
- end if;
- end Motion_Params;
-
- function Face_Apply_Params (Params : in String) return String
- is
- -- Params is a vector of triples: [1 nil font-lock-keyword-face 3
nil font-lock-function-name-face ...]
- -- Each triple is <token_number> <prefix-face> <suffix-face>.
- -- The token_number can be a label; faces are "nil" or an elisp name.
- -- Result: ((1, 3, 1), (3, 3, 2), ...)
- use Ada.Strings.Maps;
- Delim : constant Character_Set := To_Set ("]") or Blank_Set;
-
- Last : Integer := Index_Non_Blank (Params); -- skip [
- First : Integer;
- Result : Unbounded_String;
- Need_Comma : Boolean := False;
- Count : Integer := 0;
-
- procedure Elisp_Param (Skip : in Boolean)
- is begin
- if Params (Last) = ']' then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"invalid wisi-face-apply argument"));
- return;
- end if;
-
- First := Index_Non_Blank (Params, Last + 1);
- Last := Index (Params, Delim, First);
- if not Skip then
- Result := Result & ',' & Integer'Image
- (Find_Elisp_ID (Input_Data.Tokens.Faces, Params (First ..
Last - 1)));
- end if;
- end Elisp_Param;
-
- begin
- loop
- Last := Index_Non_Blank (Params, Last + 1);
-
- exit when Params (Last) = ']' or Params (Last) = ')';
-
- First := Last;
- Last := Index (Params, Delim, First);
- declare
- Label : constant String := Params (First .. Last - 1);
- begin
- if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
- Count := Count + 1;
- Result := Result & (if Need_Comma then ", (" else "(") &
Label;
- Need_Comma := True;
- Elisp_Param (Skip => False);
- Elisp_Param (Skip => False);
- Result := Result & ")";
- else
- Elisp_Param (Skip => True);
- Elisp_Param (Skip => True);
- end if;
- end;
- end loop;
- if Count = 0 then
- return "";
- elsif Count = 1 then
- Nonterm_Needed := True;
- return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
- else
- Nonterm_Needed := True;
- return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
- end if;
- exception
- when E : others =>
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "invalid
syntax: " &
- Ada.Exceptions.Exception_Message (E)));
- return "";
- end Face_Apply_Params;
-
- function Face_Mark_Params (Params : in String) return String
- is
- -- Params is a vector of pairs: [1 prefix 3 suffix ...]
- -- The token_number can be a label; faces are "nil" or an elisp name.
- -- Result: ((1, Prefix), (3, Suffix), ...)
- use Ada.Strings.Maps;
- Delim : constant Character_Set := To_Set ("]") or Blank_Set;
-
- Last : Integer := Index_Non_Blank (Params); -- skip [
- First : Integer;
- Result : Unbounded_String;
- Need_Comma : Boolean := False;
- Count : Integer := 0;
- Skip : Boolean;
- begin
- loop
- Last := Index_Non_Blank (Params, Last + 1);
-
- exit when Params (Last) = ']' or Params (Last) = ')';
-
- First := Last;
- Last := Index (Params, Delim, First);
- declare
- Label : constant String := Params (First .. Last - 1);
- begin
- if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
- Count := Count + 1;
- Skip := False;
- Result := Result & (if Need_Comma then ", (" else "(") &
Label;
- else
- Skip := True;
- end if;
- end;
-
- if Params (Last) = ']' then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"invalid wisi-face-mark argument"));
- exit;
- end if;
-
- First := Index_Non_Blank (Params, Last + 1);
- Last := Index (Params, Delim, First);
- if not Skip then
- Result := Result & ", " & Elisp_Name_To_Ada (Params (First ..
Last - 1), False, 0) & ")";
- Need_Comma := True;
- end if;
- end loop;
- Nonterm_Needed := True;
- return " (Parse_Data, Tree, Nonterm, Tokens, " &
- (case Count is
- when 0 => "(1 .. 0 => (1, Prefix))",
- when 1 => "(1 => " & (-Result) & "))",
- when others => "(" & (-Result) & "))");
- exception
- when E : others =>
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "invalid
syntax: " &
- Ada.Exceptions.Exception_Message (E)));
- return "";
- end Face_Mark_Params;
-
- function Face_Remove_Params (Params : in String) return String
- is
- -- Params is a vector of token numbers: [1 3 ...]
- -- Result: (1, 3, ...)
- use Ada.Strings.Maps;
- Delim : constant Character_Set := To_Set ("]") or Blank_Set;
-
- Last : Integer := Index_Non_Blank (Params); -- skip [
- First : Integer;
- Result : Unbounded_String;
- Need_Comma : Boolean := False;
- Count : Integer := 0;
- begin
- loop
- Last := Index_Non_Blank (Params, Last + 1);
-
- exit when Params (Last) = ']' or Params (Last) = ')';
-
- Count := Count + 1;
- First := Last;
- Last := Index (Params, Delim, First);
- Result := Result & (if Need_Comma then ", " else "") & Params
(First .. Last - 1);
-
- Need_Comma := True;
- end loop;
- Nonterm_Needed := True;
- if Count = 1 then
- return " (Parse_Data, Tree, Nonterm, Tokens, (1 => " & (-Result) &
"))";
- else
- return " (Parse_Data, Tree, Nonterm, Tokens, (" & (-Result) & "))";
- end if;
- exception
- when E : others =>
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "invalid
syntax: " &
- Ada.Exceptions.Exception_Message (E)));
- return "";
- end Face_Remove_Params;
-
- function Indent_Params (Params : in String; N : in String := "") return
String
- is
- -- If N is non-empty, it is the first arg in wisi-indent-action*,
followed by ','.
- --
- -- Params is a vector, one item for each token in Tokens. Each item
is one of:
- --
- -- - an integer; copy to output
- --
- -- - a symbol; convert to Ada name syntax, except 'nil' => None
- --
- -- - a lisp function call with arbitrary args; convert to
Indent_Param type
- --
- -- - a vector with two elements [code_indent comment_indent];
convert to Indent_Pair.
- --
- -- - a cons of a token label with any of the above.
-
- use Ada.Strings.Maps;
- use Ada.Containers;
-
- Delim : constant Character_Set := To_Set ("])") or Blank_Set;
-
- subtype Digit is Character range '0' .. '9';
-
- Last : Integer := Index_Non_Blank (Params); -- skip [
- Prefix : constant String := " (Parse_Data, Tree, Nonterm,
Tokens, " & N & "(";
- Result : Unbounded_String;
- Need_Comma : Boolean := False;
- Param_Count : Count_Type := 0; -- in Params
-
- function Indent_Function (Elisp_Name : in String) return String
- is begin
- if Elisp_Name = "wisi-anchored" then return "Anchored_0";
- elsif Elisp_Name = "wisi-anchored%" then return "Anchored_1";
- elsif Elisp_Name = "wisi-anchored%-" then return "Anchored_2";
- elsif Elisp_Name = "wisi-anchored*" then return "Anchored_3";
- elsif Elisp_Name = "wisi-anchored*-" then return "Anchored_4";
- elsif Elisp_Name = "wisi-hanging" then return "Hanging_0";
- elsif Elisp_Name = "wisi-hanging-" then return "Hanging_1";
- elsif Elisp_Name = "wisi-hanging%" then return "Hanging_2";
- elsif Elisp_Name = "wisi-hanging%-" then return "Hanging_3";
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"unrecognized wisi indent function: '" &
- Elisp_Name & "'"));
- return "";
- end if;
- end Indent_Function;
-
- function Check_Cons return Integer
- is
- -- Params (Last) = '('; check for "(label .", return label'last
- Blank : constant Integer := Index (Params, " ", Last);
- begin
- if Blank = 0 then return 0; end if;
- if Params'Last > Blank + 1 and then Params (Blank + 1) = '.' then
- return Blank - 1;
- else
- return 0;
- end if;
- end Check_Cons;
-
- function Ensure_Simple_Indent (Item : in String) return String
- is begin
- -- Return an aggregate for Simple_Indent_Param. Item can be
anything
- -- Expression returns except Hanging.
-
- if Item (Item'First) = '(' then
- -- Anchored or Language
- return Item;
-
- elsif Item = "nil" then
- return "(Label => None)";
-
- else
- -- simple integer
- return "(Int, " & Item & ")";
- end if;
- end Ensure_Simple_Indent;
-
- function Expression (Param_First : in Integer) return String
- is
- -- Return a simple integer expression, or an aggregate for
- -- Simple_Indent_Param or Indent_Param.
- --
- -- Handles this syntax:
- --
- -- nil => nil
- --
- -- integer literal:
- -- 2 => 2
- -- -1 => -1
- --
- -- variable name:
- -- ada-indent => Ada_Indent
- --
- -- token_id literal:
- -- 'TYPE => 13
- --
- -- simple expression with + - * :
- -- (- ada-indent) => -Ada_Indent
- -- (- ada-indent-when ada-indent) => Ada_Indent_When - Ada_Indent
- --
- -- if expression:
- -- (if c a b) => (if c then a else b)
- --
- -- function call with expression args:
- -- (wisi-hanging (wisi-anchored% 1 ada-indent)
- -- (wisi-anchored% 1 (+ ada-indent
ada-indent-broken)))
-
- use Generate_Utils;
-
- First : Integer := Index_Non_Blank (Params, Param_First);
-
- Function_Name : Unbounded_String;
- Args : Unbounded_String;
- Arg_Count : Count_Type := 0;
- begin
- if Params (First) in Digit or Params (First) = '-' then
- Last := Index (Params, Delim, First);
- return Params (First .. Last - 1);
-
- elsif Params (First) = ''' then
- Last := Index (Params, Delim, First);
- return WisiToken.Trimmed_Image (Find_Token_ID (Generate_Data,
Params (First + 1 .. Last - 1)));
-
- elsif Params (First) = '(' then
- First := First + 1;
- Last := Index (Params, Delim, First);
- Function_Name := +Params (First .. Last - 1);
-
- if Length (Function_Name) = 1 then
- -- - + *
- Last := Index (Params, Delim, Last + 1);
- if Params (Last) = ')' then
- return Result : constant String := -Function_Name &
Expression (First + 1)
- do
- Last := Last + 1; -- get past ')'
- end return;
- else
- Args := +Expression (First + 1);
- Args := Args & ' ' & Function_Name & ' ' & Expression
(Last + 1);
-
- Last := Last + 1; -- get past ')'
- return -Args;
- end if;
-
- elsif -Function_Name = "if" then
- Args := +Expression (Last + 1);
- Args := +"(if " & Args & " then " & Expression (Last + 1);
- Args := Args & " else " & Expression (Last + 1) & ')';
-
- Last := Last + 1; -- get past ')'
- return -Args;
-
- elsif Is_Present (Input_Data.Tokens.Indents, -Function_Name)
then
- -- Language-specific function call
- Function_Name := +Value (Input_Data.Tokens.Indents,
-Function_Name);
- Arg_Count := 0;
- loop
- exit when Params (Last) = ')';
-
- First := Last + 1;
- if Arg_Count = 0 then
- Args := +Expression (First);
- else
- Args := Args & " & " & Expression (First);
- end if;
- Arg_Count := Arg_Count + 1;
- end loop;
-
- Last := Last + 1; -- get past ')'
-
- return "(Language, " & (-Function_Name) & "'Access, " &
- (if Arg_Count = 0 then "Null_Args"
- elsif Arg_Count = 1 then '+' & (-Args)
- else -Args)
- & ')';
-
- else
- -- wisi lisp function call
- Function_Name := +Indent_Function (-Function_Name);
- if Length (Function_Name) = 0 then
- -- not a recognized function
- Last := 1 + Index (Params, ")", Last);
- return "";
-
- elsif Slice (Function_Name, 1, 4) = "Hang" then
- -- Arguments are 2 Simple_Indent_Param
- Args := +Ensure_Simple_Indent (Expression (Last + 1));
- Args := Args & ", " & Ensure_Simple_Indent (Expression
(Last + 1));
- Last := Last + 1; -- get past ')'
- return "(" & (-(Function_Name & ", " & Args)) & ")";
- else
- -- Arguments are 2 simple integer expressions
- Args := +Expression (Last + 1);
- Args := Args & ", " & Expression (Last + 1);
- Last := Last + 1; -- get past ')'
- return "(" & (-(Function_Name & ", " & Args)) & ")";
- end if;
- end if;
-
- else
- -- Assume it is 'nil' or a language-specific integer indent
option,
- -- like "ada-indent", declared in Language_Runtime_Package,
which is
- -- use-visible.
- Last := Index (Params, Delim, First);
- if Params (First .. Last - 1) = "nil" then
- return "nil";
- else
- return Elisp_Name_To_Ada (Params (First .. Last - 1), False,
0);
- end if;
- end if;
- exception
- when E : others =>
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Ada.Exceptions.Exception_Message (E)));
- return "";
- end Expression;
-
- procedure Skip_Expression (Param_First : in Integer)
- is
- Junk : constant String := Expression (Param_First);
- pragma Unreferenced (Junk);
- begin
- null;
- end Skip_Expression;
-
- function Ensure_Indent_Param (Item : in String) return String
- is begin
- -- Return an aggregate for Indent_Param. Item can be anything
- -- Expression returns.
- if Item'Length = 0 then
- -- Expression could not find an indent function
- return Item;
-
- elsif Item'Length >= 5 and then Item (Item'First .. Item'First +
4) = "(Hang" then
- return Item;
-
- elsif Item (Item'First) = '(' then
- -- Anchored or Language
- return "(Simple, " & Item & ")";
-
- elsif Item = "nil" then
- return "(Simple, (Label => None))";
-
- else
- -- simple integer
- return "(Simple, (Int, " & Item & "))";
- end if;
- end Ensure_Indent_Param;
-
- procedure One_Param (Prefix : in Boolean := False; Skip : in Boolean
:= False)
- is
- procedure Comma
- is begin
- if Need_Comma then
- if not Prefix then
- Result := Result & ", ";
- end if;
- else
- Need_Comma := True;
- end if;
- end Comma;
- begin
- case Params (Last) is
- when '(' =>
- -- cons or function
- declare
- Label_Last : constant Integer := Check_Cons;
- begin
- if Label_Last > 0 then
- declare
- Label : constant String := Params (Last + 1 ..
Label_Last);
- begin
- Last := Index_Non_Blank (Params, Label_Last + 3);
- if Label_Used (Label) then
- Comma;
- Result := Result & Label & " => ";
- One_Param (Prefix => True);
- else
- -- This token is not present in this RHS; skip
this param
- One_Param (Skip => True);
- end if;
- if Params (Last) /= ')' then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name,
- RHS.Source_Line, "invalid indent syntax;
missing ')'"));
- end if;
- Last := Last + 1;
- end;
- else
- if Skip then
- Skip_Expression (Last);
- else
- Comma;
- Result := Result & "(False, " & Ensure_Indent_Param
(Expression (Last)) & ')';
- end if;
- end if;
- end;
-
- when '[' =>
- -- vector
- if Skip then
- Skip_Expression (Last + 1);
- Skip_Expression (Last + 1);
- else
- Comma;
- Result := Result & "(True, " & Ensure_Indent_Param
(Expression (Last + 1));
- Result := Result & ", " & Ensure_Indent_Param (Expression
(Last + 1)) & ')';
- end if;
- if Params (Last) /= ']' then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"indent missing ']'"));
- end if;
- Last := Last + 1;
-
- when others =>
- -- integer or symbol
- if Skip then
- Skip_Expression (Last);
- else
- Comma;
- Result := Result & "(False, " & Ensure_Indent_Param
(Expression (Last)) & ')';
- end if;
- end case;
- end One_Param;
-
- begin
- loop
- if Params (Last) /= ']' then
- Last := Index_Non_Blank (Params, Last + 1);
- if Last = 0 then
- Put_Error (Error_Message
(Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line, "indent missing ']'"));
- return -Result;
- end if;
- end if;
-
- exit when Params (Last) = ']';
-
- One_Param;
-
- Param_Count := Param_Count + 1;
- end loop;
-
- -- In translated EBNF, token counts vary in each RHS; require each
- -- parameter to be labeled if any are, both for catching errors, and
- -- becase that would produce mixed positional and named association
- -- in the Ada action subprogram.
- if Param_Count /= RHS.Tokens.Length then
- if Labels.Length = 0 then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Image (Prod_ID) &
- ": indent parameters count of" & Count_Type'Image
(Param_Count) &
- " /= production token count of" & Count_Type'Image
(RHS.Tokens.Length)));
-
- elsif Count_Label_Needed /= RHS.Tokens.Length then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Image (Prod_ID) &
- ": indent parameter(s) not labeled"));
- else
- -- all parameters labeled
- null;
- end if;
- end if;
-
- Nonterm_Needed := True;
- if Param_Count = 1 then
- Result := Prefix & "1 => " & Result;
- else
- Result := Prefix & Result;
- end if;
-
- return -(Result & "))");
- end Indent_Params;
-
- function Merge_Names_Params (Params : in String) return String
- is
- -- Input looks like "1 2)"
- First : constant Integer := Index_Non_Blank (Params);
- Second : constant Integer := Index (Params, Blank_Set,
First);
- Label_First : constant String := Params (First .. Second - 1);
- Label_Used_First : constant Boolean := 0 = Index (Label_First,
Numeric, Outside) or else
- Label_Used (Label_First);
- Label_Second : constant String := Params (Second + 1 ..
Params'Last - 1);
- Label_Used_Second : constant Boolean := 0 = Index (Label_Second,
Numeric, Outside) or else
- Label_Used (Label_Second);
- begin
- Nonterm_Needed := True;
-
- if Label_Used_First and Label_Used_Second then
- return " (Nonterm, Tokens, " & Label_First & ", " & Label_Second &
")";
-
- elsif (not Label_Used_First) and Label_Used_Second then
- -- A copied EBNF RHS; see subprograms.wy Name
- return " (Nonterm, Tokens, " & Label_Second & ")";
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"merge_names token label error"));
- return " (Nonterm, Tokens)";
- end if;
- end Merge_Names_Params;
-
- function Match_Names_Params (Params : in String) return String
- is
- -- Input looks like: 1 2)
- First : constant Integer := Index_Non_Blank (Params);
- Second : constant Integer := Index (Params, Blank_Set, First);
- begin
- return " (Lexer, Descriptor, Tokens, " &
- Params (First .. Second - 1) & ',' &
- Params (Second .. Params'Last - 1) & ", " &
- (if Length (Input_Data.Language_Params.End_Names_Optional_Option) > 0
- then -Input_Data.Language_Params.End_Names_Optional_Option
- else "False") & ")";
- end Match_Names_Params;
-
- function Language_Action_Params (Params : in String; Action_Name : in
String) return String
- is
- -- Input looks like: [1 2 ...])
- Result : Unbounded_String;
- Need_Comma : Boolean := False;
- Param_Count : Integer := 0;
- First : Integer;
- Last : Integer := Params'First; -- '['
- begin
- loop
- First := Index_Non_Blank (Params, Last + 1);
- Last := Index (Params, Space_Paren_Set, First);
- declare
- Label : constant String := Params (First .. Last - 1);
- begin
- if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
- Param_Count := Param_Count + 1;
- if Need_Comma then
- Result := Result & ", ";
- else
- Need_Comma := True;
- end if;
- Result := Result & Label;
- end if;
- exit when Params (Last) = ']';
- if Last = Params'Last then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Action_Name & " missing ']'"));
- exit;
- end if;
- end;
- end loop;
- if Param_Count = 0 then
- return "";
- elsif Param_Count = 1 then
- return "(1 => " & (-Result) & ")";
- else
- return "(" & (-Result) & ")";
- end if;
- end Language_Action_Params;
-
- procedure Translate_Sexp (Line : in String)
- is
- Last : constant Integer := Index (Line, Blank_Set);
- Elisp_Name : constant String := Line (Line'First + 1 .. (if Last = 0
then Line'Last else Last) - 1);
-
- procedure Assert_Face_Empty
- is begin
- if Length (Face_Line) > 0 then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple face actions"));
- end if;
- end Assert_Face_Empty;
-
- procedure Assert_Indent_Empty
- is begin
- if Length (Indent_Action_Line) > 0 then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple indent actions"));
- end if;
- end Assert_Indent_Empty;
-
- procedure Assert_Check_Empty
- is begin
- if Length (Check_Line) > 0 then
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"multiple check actions"));
- end if;
- end Assert_Check_Empty;
-
- begin
- -- wisi action/check functions, in same order as typically used in
- -- .wy files; Navigate, Face, Indent, Check.
- if Elisp_Name = "wisi-statement-action" then
- declare
- Params : constant String := Statement_Params (Line (Last + 1 ..
Line'Last));
- begin
- if Params'Length > 0 then
- Navigate_Lines.Append (Elisp_Name_To_Ada (Elisp_Name, False,
5) & Params & ";");
- end if;
- end;
-
- elsif Elisp_Name = "wisi-name-action" then
- declare
- First : constant Integer := Index_Non_Blank (Line, Last + 1);
- Last : constant Integer := Index (Line, Space_Paren_Set,
First);
- Label : constant String := Line (First .. Last - 1);
- begin
- if 0 = Index (Label, Numeric, Outside) or else Label_Used
(Label) then
- Nonterm_Needed := True;
- Navigate_Lines.Append
- ("Name_Action (Parse_Data, Tree, Nonterm, Tokens, " & Line
(First .. Line'Last) & ";");
- end if;
- end;
-
- elsif Elisp_Name = "wisi-motion-action" then
- declare
- Params : constant String := Motion_Params (Line (Last + 1 ..
Line'Last));
- begin
- if Params'Length > 0 then
- Navigate_Lines.Append (Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) & Params & ";");
- end if;
- end;
-
- elsif Elisp_Name = "wisi-face-apply-action" then
- Assert_Face_Empty;
- declare
- Params : constant String := Face_Apply_Params (Line (Last + 1
.. Line'Last));
- begin
- if Params'Length > 0 then
- Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim =>
5) & Params & ";";
- end if;
- end;
-
- elsif Elisp_Name = "wisi-face-apply-list-action" then
- Assert_Face_Empty;
- declare
- Params : constant String := Face_Apply_Params (Line (Last + 1
.. Line'Last));
- begin
- if Params'Length > 0 then
- Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim =>
5) & Params & ";";
- end if;
- end;
-
- elsif Elisp_Name = "wisi-face-mark-action" then
- Assert_Face_Empty;
- declare
- Params : constant String := Face_Mark_Params (Line (Last + 1 ..
Line'Last));
- begin
- if Params'Length > 0 then
- Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim =>
5) & Params & ";";
- end if;
- end;
-
- elsif Elisp_Name = "wisi-face-remove-action" then
- Assert_Face_Empty;
- declare
- Params : constant String := Face_Remove_Params (Line (Last + 1
.. Line'Last));
- begin
- if Params'Length > 0 then
- Face_Line := +Elisp_Name_To_Ada (Elisp_Name, False, Trim =>
5) & Params & ";";
- end if;
- end;
-
- elsif Elisp_Name = "wisi-indent-action" then
- Assert_Indent_Empty;
- Indent_Action_Line := +"Indent_Action_0" & Indent_Params (Line
(Last + 1 .. Line'Last)) & ";";
-
- elsif Elisp_Name = "wisi-indent-action*" then
- Assert_Indent_Empty;
- declare
- Temp : constant Integer := Index (Line, Blank_Set, Last + 1);
- begin
- Indent_Action_Line := +"Indent_Action_1" &
- Indent_Params (Line (Temp + 1 .. Line'Last), Line (Last + 1
.. Temp - 1) & ", ") & ";";
- end;
-
- elsif Elisp_Name = "wisi-propagate-name" then
- Assert_Check_Empty;
- Nonterm_Needed := True;
- Check_Line := +"return " & Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) &
- " (Nonterm, Tokens, " & Line (Last + 1 .. Line'Last) & ";";
-
- elsif Elisp_Name = "wisi-merge-names" then
- Assert_Check_Empty;
- Check_Line := +"return " & Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) &
- Merge_Names_Params (Line (Last + 1 .. Line'Last)) & ";";
-
- elsif Elisp_Name = "wisi-match-names" then
- Assert_Check_Empty;
- Check_Line := +"return " & Elisp_Name_To_Ada (Elisp_Name, False,
Trim => 5) &
- Match_Names_Params (Line (Last + 1 .. Line'Last)) & ";";
-
- elsif Elisp_Name = "wisi-terminate-partial-parse" then
- Assert_Check_Empty;
- Nonterm_Needed := True;
- Check_Line := +"return Terminate_Partial_Parse
(Partial_Parse_Active, Partial_Parse_Byte_Goal, " &
- "Recover_Active, Nonterm);";
-
- elsif Is_Present (Input_Data.Tokens.Actions, Elisp_Name) then
- -- Language-specific action (used in wisitoken grammar mode for
- -- wisi-check-parens).
- declare
- Item : Elisp_Action_Type renames Input_Data.Tokens.Actions
- (Input_Data.Tokens.Actions.Find (+Elisp_Name));
- Params : constant String := Language_Action_Params (Line (Last
+ 1 .. Line'Last), Elisp_Name);
- Code : constant String := -Item.Ada_Name &
- " (Wisi.Parse_Data_Type'Class (User_Data), Tree, Tokens, " &
Params & ");";
- begin
- if Params'Length > 0 then
- if "navigate" = -Item.Action_Label then
- Navigate_Lines.Append (Code);
-
- elsif "face" = -Item.Action_Label then
- Assert_Face_Empty;
- Face_Line := +Code;
-
- elsif "indent" = -Item.Action_Label then
- Assert_Indent_Empty;
- Indent_Action_Line := +Code;
-
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name,
RHS.Source_Line, "unrecognized action label: '" &
- (-Item.Action_Label) & "'"));
- end if;
-
- -- else skip
- end if;
- end;
- else
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
"unrecognized elisp action: '" &
- Elisp_Name & "'"));
- end if;
- end Translate_Sexp;
-
- begin
- for Sexp of Sexps loop
- begin
- Translate_Sexp (Sexp);
- exception
- when E : Not_Found =>
- Put_Error
- (Error_Message
- (Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line,
Ada.Exceptions.Exception_Message (E)));
- end;
- end loop;
-
- if Check then
- -- in a check
- Indent_Line ("function " & Name);
- Indent_Line (" (Lexer : access constant
WisiToken.Lexer.Instance'Class;");
- Indent_Line (" Nonterm : in out WisiToken.Recover_Token;");
- Indent_Line (" Tokens : in
WisiToken.Recover_Token_Array;");
- Indent_Line (" Recover_Active : in Boolean)");
- Indent_Line (" return WisiToken.Semantic_Checks.Check_Status");
- declare
- Unref_Lexer : constant Boolean := 0 = Index (Check_Line,
"Lexer");
- Unref_Nonterm : constant Boolean := 0 = Index (Check_Line,
"Nonterm");
- Unref_Tokens : constant Boolean := 0 = Index (Check_Line,
"Tokens");
- Unref_Recover : constant Boolean := 0 = Index (Check_Line,
"Recover_Active");
- Need_Comma : Boolean := False;
- begin
- if Unref_Lexer or Unref_Nonterm or Unref_Tokens or Unref_Recover or
- (for some I of Label_Needed => I)
- then
- Indent_Line ("is");
-
- Indent := Indent + 3;
- if Unref_Lexer or Unref_Nonterm or Unref_Tokens or
Unref_Recover then
- Indent_Start ("pragma Unreferenced (");
-
- if Unref_Lexer then
- Put ((if Need_Comma then ", " else "") & "Lexer");
- Need_Comma := True;
- end if;
- if Unref_Nonterm then
- Put ((if Need_Comma then ", " else "") & "Nonterm");
- Need_Comma := True;
- end if;
- if Unref_Tokens then
- Put ((if Need_Comma then ", " else "") & "Tokens");
- Need_Comma := True;
- end if;
- if Unref_Recover then
- Put ((if Need_Comma then ", " else "") &
"Recover_Active");
- Need_Comma := True;
- end if;
- Put_Line (");");
- end if;
-
- for I in Label_Needed'Range loop
- if Label_Needed (I) then
- Indent_Line
- (-Labels (I) & " : constant SAL.Peek_Type :=" &
- SAL.Peek_Type'Image (Find_Token_Index (I)) & ";");
- end if;
- end loop;
- Indent := Indent - 3;
-
- Indent_Line ("begin");
- else
- Indent_Line ("is begin");
- end if;
- end;
- Indent := Indent + 3;
- Indent_Line (-Check_Line);
- else
- -- In an action
- Indent_Line ("procedure " & Name);
- Indent_Line (" (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class;");
- Indent_Line (" Tree : in out WisiToken.Syntax_Trees.Tree;");
- Indent_Line (" Nonterm : in WisiToken.Valid_Node_Index;");
- Indent_Line (" Tokens : in
WisiToken.Valid_Node_Index_Array)");
- Indent_Line ("is");
-
- Indent := Indent + 3;
- Indent_Line ("Parse_Data : Wisi.Parse_Data_Type renames
Wisi.Parse_Data_Type (User_Data);");
-
- if not Nonterm_Needed then
- -- Language_Action may not use this
- Indent_Line ("pragma Unreferenced (Nonterm);");
- end if;
-
- for I in Label_Needed'Range loop
- if Label_Needed (I) then
- Indent_Line
- (-Labels (I) & " : constant SAL.Peek_Type :=" &
- SAL.Peek_Type'Image (Find_Token_Index (I)) & ";");
- end if;
- end loop;
-
- Indent := Indent - 3;
- Indent_Line ("begin");
- Indent := Indent + 3;
-
- Indent_Line ("case Parse_Data.Post_Parse_Action is");
- Indent_Line ("when Navigate =>");
- if Navigate_Lines.Length > 0 then
- Indent := Indent + 3;
- for Line of Navigate_Lines loop
- Indent_Wrap (Line);
- end loop;
- Indent := Indent - 3;
- else
- Indent_Line (" null;");
- end if;
-
- Indent_Line ("when Face =>");
- if Length (Face_Line) > 0 then
- Indent := Indent + 3;
- Indent_Wrap (-Face_Line);
- Indent := Indent - 3;
- else
- Indent_Line (" null;");
- end if;
-
- Indent_Line ("when Indent =>");
- if Length (Indent_Action_Line) > 0 then
- Indent := Indent + 3;
- Indent_Wrap (-Indent_Action_Line);
- Indent := Indent - 3;
- else
- Indent_Line (" null;");
- end if;
- Indent_Line ("end case;");
- end if;
-
- Indent := Indent - 3;
- Indent_Line ("end " & Name & ";");
- New_Line;
-
- end Create_Ada_Action;
-
- function Any_Motion_Actions return Boolean
- is begin
- for Rule of Input_Data.Tokens.Rules loop
- for RHS of Rule.Right_Hand_Sides loop
- for Sexp of Split_Sexp (-RHS.Action,
Input_Data.Grammar_Lexer.File_Name, RHS.Source_Line) loop
- declare
- Last : constant Integer := Ada.Strings.Fixed.Index
(Sexp, Blank_Set);
- Elisp_Name : constant String := Sexp (Sexp'First + 1 ..
Last - 1);
- begin
- if Elisp_Name = "wisi-motion-action" then
- return True;
- end if;
- end;
- end loop;
- end loop;
- end loop;
- return False;
- end Any_Motion_Actions;
-
- procedure Create_Ada_Actions_Body
- (Action_Names : not null access WisiToken.Names_Array_Array;
- Check_Names : not null access WisiToken.Names_Array_Array;
- Label_Count : in Ada.Containers.Count_Type;
- Package_Name : in String)
- is
- use Ada.Strings.Unbounded;
- use Generate_Utils;
- use WisiToken.Generate;
-
- File_Name : constant String := Output_File_Name_Root &
- (case Common_Data.Interface_Kind is
- when Process => "_process_actions",
- when Module => "_module_actions") &
- ".adb";
-
- Motion_Actions : constant Boolean := Any_Motion_Actions;
-
- Body_File : File_Type;
-
- begin
- Create (Body_File, Out_File, File_Name);
- Set_Output (Body_File);
- Indent := 1;
- Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
- New_Line;
-
- if Label_Count > 0 then
- Put_Line ("with SAL;");
- end if;
-
- Put_Line ("with Wisi; use Wisi;");
- if Input_Data.Language_Params.Use_Language_Runtime then
- declare
- Pkg : constant String :=
- (if -Input_Data.Language_Params.Language_Runtime_Name = ""
- then Default_Language_Runtime_Package
- else -Input_Data.Language_Params.Language_Runtime_Name);
- begin
- -- For language-specific names in actions, checks.
- Put_Line ("with " & Pkg & "; use " & Pkg & ";");
- end;
- end if;
-
- case Common_Data.Interface_Kind is
- when Process =>
- null;
-
- when Module =>
- Put_Line ("with Emacs_Module_Aux; use Emacs_Module_Aux;");
- Put_Line ("with Ada.Exceptions;");
- Put_Line ("with Ada.Strings.Unbounded;");
- end case;
-
- Put_Line ("package body " & Package_Name & " is");
- Indent := Indent + 3;
- New_Line;
-
- if Input_Data.Check_Count > 0 then
- Indent_Line ("use WisiToken.Semantic_Checks;");
- end if;
- if Motion_Actions then
- Indent_Line ("use all type Motion_Param_Array;");
- end if;
- New_Line;
-
- -- generate Action and Check subprograms.
-
- for Rule of Input_Data.Tokens.Rules loop
- -- No need for a Token_Cursor here, since we only need the
- -- nonterminals.
- declare
- LHS_ID : constant WisiToken.Token_ID := Find_Token_ID
(Generate_Data, -Rule.Left_Hand_Side);
- RHS_Index : Integer := 0; -- Semantic_Action
defines RHS_Index as zero-origin
- begin
- for RHS of Rule.Right_Hand_Sides loop
- if Length (RHS.Action) > 0 then
- declare
- Name : constant String := Action_Names
(LHS_ID)(RHS_Index).all;
- begin
- Create_Ada_Action (Name, RHS, (LHS_ID, RHS_Index),
RHS.Action, Rule.Labels, Check => False);
- end;
- end if;
-
- if Length (RHS.Check) > 0 then
- declare
- Name : constant String := Check_Names
(LHS_ID)(RHS_Index).all;
- begin
- Create_Ada_Action (Name, RHS, (LHS_ID, RHS_Index),
RHS.Check, Rule.Labels, Check => True);
- end;
- end if;
- RHS_Index := RHS_Index + 1;
- end loop;
- end;
- end loop;
-
- Put_Line ("end " & Package_Name & ";");
- Close (Body_File);
-
- Set_Output (Standard_Output);
-
- end Create_Ada_Actions_Body;
-
- procedure Create_Ada_Main_Body
- (Actions_Package_Name : in String;
- Main_Package_Name : in String)
- is
- use WisiToken.Generate;
-
- File_Name : constant String := To_Lower (Main_Package_Name) & ".adb";
- Body_File : File_Type;
- begin
- Create (Body_File, Out_File, File_Name);
- Set_Output (Body_File);
- Indent := 1;
- Put_File_Header (Ada_Comment, Use_Tuple => True, Tuple => Tuple);
- Put_Raw_Code (Ada_Comment, Input_Data.Raw_Code (Copyright_License));
- New_Line;
-
- if Input_Data.Action_Count > 0 or Input_Data.Check_Count > 0 then
- Put_Line ("with " & Actions_Package_Name & "; use " &
Actions_Package_Name & ";");
- end if;
-
- case Common_Data.Lexer is
- when None | Elisp_Lexer =>
- null;
-
- when re2c_Lexer =>
- Put_Line ("with WisiToken.Lexer.re2c;");
- Put_Line ("with " & Output_File_Name_Root & "_re2c_c;");
-
- end case;
-
- case Common_Data.Generate_Algorithm is
- when LR_Generate_Algorithm =>
- null;
-
- when Packrat_Generate_Algorithm =>
- Put_Line ("with WisiToken.Parse;");
-
- when External =>
- null;
- end case;
-
- Put_Line ("package body " & Main_Package_Name & " is");
- Indent := Indent + 3;
- New_Line;
-
- case Common_Data.Lexer is
- when None | Elisp_Lexer =>
- null;
-
- when re2c_Lexer =>
- Indent_Line ("package Lexer is new WisiToken.Lexer.re2c");
- Indent_Line (" (" & Output_File_Name_Root & "_re2c_c.New_Lexer,");
- Indent_Line (" " & Output_File_Name_Root & "_re2c_c.Free_Lexer,");
- Indent_Line (" " & Output_File_Name_Root & "_re2c_c.Reset_Lexer,");
- Indent_Line (" " & Output_File_Name_Root & "_re2c_c.Next_Token);");
- New_Line;
- end case;
-
- case Common_Data.Generate_Algorithm is
- when LR_Generate_Algorithm =>
- LR_Create_Create_Parser (Input_Data, Common_Data, Generate_Data);
-
- when Packrat_Gen =>
- WisiToken.BNF.Generate_Packrat (Packrat_Data, Generate_Data);
- Packrat_Create_Create_Parser (Common_Data, Generate_Data,
Packrat_Data);
-
- when Packrat_Proc =>
- Packrat_Create_Create_Parser (Common_Data, Generate_Data,
Packrat_Data);
-
- when External =>
- External_Create_Create_Grammar (Generate_Data);
- end case;
-
- case Common_Data.Interface_Kind is
- when Process =>
- null;
- when Module =>
- Indent_Line ("Parser : LR_Parser.Instance;");
- New_Line;
-
- Indent_Line ("function Parse (Env : Emacs_Env_Access) return
emacs_module_h.emacs_value");
- Indent_Line ("is begin");
- Indent := Indent + 3;
- Indent_Line ("WisiToken.Trace_Parse := To_Integer (Env, Symbol_Value
(Env, Elisp_Symbols (Wisi_Debug_ID)));");
- Indent_Line ("Wisi_Cache_Max := To_Integer (Env, Symbol_Value (Env,
Elisp_Symbols (Wisi_Cache_Max_ID)));");
- Indent_Line ("Parser.Reset;");
- Indent_Line ("Parser.Parse;");
- Indent_Line ("return Env.Qnil;");
- Indent := Indent - 3;
- Indent_Line ("exception");
- Indent_Line ("when E : WisiToken.Parse_Error | WisiToken.Syntax_Error
=>");
- Indent_Line (" return To_Emacs (Env,
Ada.Exceptions.Exception_Message (E));");
- Indent_Line ("when E : others =>");
- Indent_Line (" declare");
- Indent_Line (" use Ada.Exceptions;");
- Indent_Line (" begin");
- Indent_Line (" return To_Emacs (Env, Exception_Name (E) & "": ""
& Exception_Message (E));");
- Indent_Line (" end;");
- Indent_Line ("end Parse;");
- New_Line;
-
- Indent_Line ("function Init (Env : Emacs_Env_Access) return
Interfaces.C.int");
- Indent_Line ("is");
- Indent_Line (" Lexer_Elisp_Symbols :
Lexers.Elisp_Array_Emacs_Value;");
- Indent_Line ("begin");
- Indent_Line (" " & Main_Package_Name & ".Env := Env;");
- Indent_Line (" Emacs_Module_Aux.Init (Env);");
- Indent_Line (" for I in Token_Symbols'Range loop");
- Indent_Line (" Token_Symbols (I) := Intern_Soft (Env,
Token_Images (I).all);");
- Indent_Line (" end loop;");
- Indent_Line (" for I in Elisp_Symbols'Range loop");
- Indent_Line (" Elisp_Symbols (I) := Intern_Soft (Env, User_Names
(I).all);");
- Indent_Line (" end loop;");
- Indent_Line (" for I in Elisp_Numbers'Range loop");
- Indent_Line (" Elisp_Numbers (I) := Env.make_fixnum (Env,
emacs_module_h.int64_t (I));");
- Indent_Line (" end loop;");
- Indent_Line (" for I in Lexer_Elisp_Symbols'Range loop");
- Indent_Line (" Lexer_Elisp_Symbols (I) := Intern_Soft (Env,
Lexers.Tokens (I).all);");
- Indent_Line (" end loop;");
- Indent_Line (" Parser := Create_Parser (Env,
Lexer_Elisp_Symbols);");
- Indent_Line (" return 0;");
- Indent_Line ("exception");
- Indent_Line ("when E : others =>");
- Indent_Line
- (" Signal_Error (Env, " &
- "Ada.Exceptions.Exception_Name (E) & "": "" &
Ada.Exceptions.Exception_Message (E), Env.Qnil);");
- Indent_Line (" return 1;");
- Indent_Line ("end Init;");
- New_Line;
- end case;
-
- Put_Line ("end " & Main_Package_Name & ";");
- Close (Body_File);
-
- Set_Output (Standard_Output);
-
- end Create_Ada_Main_Body;
-
- procedure Create_Process_Elisp
- is
- use Generate_Utils;
- use WisiToken.Generate;
-
- File : File_Type;
-
- Paren_1_Done : Boolean := False;
- begin
- Create (File, Out_File, Output_File_Name_Root & "-process.el");
- Set_Output (File);
- Indent := 1;
-
- Put_Line
- (";;; " & Output_File_Name_Root & "-process.el --- Generated parser
support file -*- lexical-binding:t -*-");
- Put_Command_Line (Elisp_Comment & " ", Use_Tuple => True, Tuple =>
Tuple);
- Put_Raw_Code (Elisp_Comment, Input_Data.Raw_Code (Copyright_License));
- New_Line;
- Put_Line ("(require 'wisi-process-parse)");
- New_Line;
-
- Indent_Line ("(defconst " & Output_File_Name_Root &
"-process-token-table");
- Indent_Start (" [");
- Indent := Indent + 3;
- for Cursor in All_Tokens (Generate_Data).Iterate loop
- if Paren_1_Done then
- Indent_Line (Name (Cursor));
- else
- Paren_1_Done := True;
- Put_Line (Name (Cursor));
- end if;
-
- end loop;
- Indent_Line ("])");
- Indent := Indent - 3;
- New_Line;
-
- Output_Elisp_Common.Indent_Name_Table
- (Output_File_Name_Root, "process-face-table", Input_Data.Tokens.Faces);
-
- -- We need -repair-image for wisi-repair-error
- New_Line;
- Output_Elisp_Common.Indent_Repair_Image (Output_File_Name_Root,
"process", Input_Data.Tokens);
-
- New_Line;
- Put_Line ("(provide '" & Output_File_Name_Root & "-process)");
- Set_Output (Standard_Output);
- Close (File);
-
- end Create_Process_Elisp;
-
- procedure Create_Module_Elisp
- is
- use Ada.Strings.Unbounded;
- use Generate_Utils;
- use WisiToken.Generate;
-
- Lower_Package_Name_Root : constant String := To_Lower (File_Name_To_Ada
(Output_File_Name_Root));
-
- function To_ID_Image (Name : in Ada.Strings.Unbounded.Unbounded_String)
return String
- is begin
- -- Ada 'Val is 0 origin; Token_ID is 1 origin
- return Token_ID'Image (-1 + Find_Token_ID (Generate_Data, -Name));
- end To_ID_Image;
-
- File : File_Type;
- begin
- Create (File, Out_File, Output_File_Name_Root & "-module.el");
- Set_Output (File);
- Indent := 1;
-
- Put_Line (";; generated by WisiToken Wisi from " &
Input_Data.Grammar_Lexer.File_Name);
- Put_Command_Line (";; ", Use_Tuple => True, Tuple => Tuple);
- Put_Line (";;");
-
- -- don't need the prologue here
-
- Put_Line ("(require 'wisi-parse-common)");
- New_Line;
-
- -- Lexer tables; also contain terminals for wisi-tokens
- Indent_Keyword_Table (Output_File_Name_Root, "elisp",
Input_Data.Tokens.Keywords, To_String'Access);
- Indent_Keyword_Table (Output_File_Name_Root, "module",
Input_Data.Tokens.Keywords, To_ID_Image'Access);
- Indent_Token_Table (Output_File_Name_Root, "elisp",
Input_Data.Tokens.Tokens, To_String'Access);
- Indent_Token_Table (Output_File_Name_Root, "module",
Input_Data.Tokens.Tokens, To_ID_Image'Access);
-
- -- non-terminals. We only need the ones that actually have
- -- actions, and thus will appear in a call to To_Emacs. But
- -- Token_Symbols must be indexed by Token_ID, so we declare
- -- all of them.
- Indent_Line ("(defconst " & Output_File_Name_Root & "-module-nonterms");
- Indent_Line (" '(");
- Indent := Indent + 3;
- Indent_Line (WisiToken_Accept_Name);
- for Rule of Input_Data.Tokens.Rules loop
- Indent_Line (-Rule.Left_Hand_Side);
- end loop;
- Indent_Line ("))");
- Indent := Indent - 3;
- New_Line;
-
- Indent_Line
- ("(cl-defstruct (" & Lower_Package_Name_Root &
- "-wisi-module-parser (:include wisi-parser)))");
- New_Line;
- Indent_Line ("(defun " & Lower_Package_Name_Root &
"-wisi-module-parser-make (dll-name)");
- Indent_Line (" (module-load dll-name)");
- Indent_Line (" (make-" & Lower_Package_Name_Root &
"-wisi-module-parser))");
- New_Line;
-
- Indent_Line ("(defvar " & Lower_Package_Name_Root & "-module-lexer
nil)");
- Indent_Line
- ("(declare-function " &
- Lower_Package_Name_Root &
- "-wisi-module-parse """ &
- Lower_Package_Name_Root &
- "-wisi-module-parse.c"")");
- New_Line;
-
- Indent_Line
- ("(cl-defmethod wisi-parse-current ((parser " &
- Lower_Package_Name_Root &
- "-wisi-module-parser))");
- Indent := Indent + 2;
- Indent_Line ("(let* ((wisi-lexer " & Lower_Package_Name_Root &
"-module-lexer)");
- Indent_Line (" (result (" & Lower_Package_Name_Root &
"-wisi-module-parse)))");
- -- Result is nil for no errors, a string for some error.
- -- Ada code has already added line:column, but not file name
- Indent_Line (" (when result");
- Indent_Line (" (signal 'wisi-parse-error (format ""%s:%s""
(buffer-name) result)))))");
- New_Line;
- Indent := Indent - 2;
-
- Indent_Line ("(provide '" & Output_File_Name_Root & "-module)");
- Set_Output (Standard_Output);
- Close (File);
-
- end Create_Module_Elisp;
-
- procedure Create_Module_Aux
- is
- use WisiToken.Generate;
-
- Package_Name_Root : constant String := File_Name_To_Ada
(Output_File_Name_Root);
- Lower_Package_Name_Root : constant String := To_Lower
(Package_Name_Root);
-
- File : File_Type;
- begin
- Create (File, Out_File, Output_File_Name_Root &
"_wisi_module_parse.gpr");
- Set_Output (File);
- Indent := 1;
- Put_Line ("-- generated by WisiToken Wisi from " &
Input_Data.Grammar_Lexer.File_Name);
- Put_Command_Line ("-- ", Use_Tuple => True, Tuple => Tuple);
- Indent_Line ("with ""wisi_module_parse_common"";");
- Indent_Line ("library project " & Package_Name_Root &
"_Wisi_Module_Parse is");
- New_Line;
- Indent := Indent + 3;
- Indent_Line ("for Languages use (""Ada"");");
- Indent_Line ("for Source_Dirs use (""../.."", ""."");");
- New_Line;
- Indent_Line ("for Source_Files use");
- Indent_Line (" (");
- Indent := Indent + 3;
- Indent_Line ("""emacs_module_aux.ads"",");
- Indent_Line ("""emacs_module_aux.adb"",");
- Indent_Line ("""emacs_module_h.ads"",");
- Indent_Line ("""fasttoken-lexer-wisi_elisp.adb"",");
- Indent_Line ("""fasttoken-lexer-wisi_elisp.ads"",");
- Indent_Line ("""" & Lower_Package_Name_Root & "_module.adb"",");
- Indent_Line ("""" & Lower_Package_Name_Root & "_module.ads""");
- Indent := Indent - 3;
- Indent_Line (" );");
- New_Line;
- Indent_Line ("for Object_Dir use ""libobjsjlj"";");
- Indent_Line ("for Library_Name use """ & Lower_Package_Name_Root &
"_wisi_module_parse"";");
- Indent_Line ("for Library_Dir use ""libsjlj"";");
- -- This library is linked with *_wisi_module_parse_wrapper.c to
- -- make a dynamic library
- Indent_Line ("for Library_Kind use ""static"";");
- New_Line;
- Indent_Line ("package Compiler is");
- Indent := Indent + 3;
- Indent_Line
- ("for Default_Switches (""Ada"") use
Wisi_Module_Parse_Common.Compiler'Default_Switches (""Ada"");");
-
- -- Grammar files can get very large, so they need some special switches:
- --
- -- 'Wisi_Module_Parse_Common.Compiler'Default_Switches' includes
'gnatn', but that hangs
- Indent_Line ("case Wisi_Module_Parse_Common.Build is");
- Indent_Line ("when ""Debug"" =>");
- Indent_Line (" for Switches (""" & Lower_Package_Name_Root &
"_module.adb"") use");
- Indent_Line (" Wisi_Module_Parse_Common.Compiler.Common_Switches &");
- Indent_Line (" Wisi_Module_Parse_Common.Compiler.Standard_Style &");
- Indent_Line (" (""-O0"");");
- Indent_Line ("when ""Normal"" =>");
- Indent_Line (" for Switches (""" & Lower_Package_Name_Root &
"_module.adb"") use");
- Indent_Line (" Wisi_Module_Parse_Common.Compiler.Common_Switches &");
- Indent_Line (" Wisi_Module_Parse_Common.Compiler.Standard_Style &");
- Indent_Line (" (""-O2"");");
- Indent_Line ("end case;");
-
- Indent := Indent - 3;
- Indent_Line ("end Compiler;");
- New_Line;
- Indent_Line ("package Builder is");
- Indent_Line
- (" for Default_Switches (""Ada"") use
Wisi_Module_Parse_Common.Builder'Default_Switches (""Ada"");");
- Indent_Line ("end Builder;");
- Indent := Indent - 3;
- New_Line;
- Indent_Line ("end " & Package_Name_Root & "_Wisi_Module_Parse;");
- Set_Output (Standard_Output);
- Close (File);
-
- Create (File, Out_File, Output_File_Name_Root &
"_wisi_module_parse_agg.gpr");
- Set_Output (File);
- Indent := 1;
- Put_Line ("-- generated by WisiToken Wisi from " &
Input_Data.Grammar_Lexer.File_Name);
- Put_Command_Line ("-- ", Use_Tuple => True, Tuple => Tuple);
- Indent_Line ("aggregate project " & Package_Name_Root &
"_Wisi_Module_Parse_Agg is");
- Indent_Line (" for Project_Path use (external (""WISI_FASTTOKEN""));");
- Indent_Line (" for Project_files use (""" & Lower_Package_Name_Root &
"_wisi_module_parse.gpr"");");
- Indent_Line ("end " & Package_Name_Root & "_Wisi_Module_Parse_Agg;");
- Set_Output (Standard_Output);
- Close (File);
-
- Create (File, Out_File, Output_File_Name_Root &
"_wisi_module_parse_wrapper.c");
- Set_Output (File);
- Indent := 1;
- Put_Line ("// generated by WisiToken Wisi from " &
Input_Data.Grammar_Lexer.File_Name);
- Put_Command_Line ("// ", Use_Tuple => True, Tuple => Tuple);
- Indent_Line ("// This file is just a wrapper around the Ada code in");
- Indent_Line ("// *_wisi_module_parse.adb; it is needed to call
adainit.");
- Indent_Line ("#include <emacs_module.h>");
- Indent_Line ("int plugin_is_GPL_compatible;");
- Indent_Line ("extern void adainit(void);");
- Indent_Line ("extern int " & Lower_Package_Name_Root &
"_wisi_module_parse_init (emacs_env *env);");
- Indent_Line ("/* Parse current buffer, using parser in current module.
*/");
- Indent_Line ("extern emacs_value " & Lower_Package_Name_Root &
"_wisi_module_parse (emacs_env *env);");
- Indent_Line ("static emacs_value Fparse (emacs_env *env, int nargs,
emacs_value args[])");
- Indent_Line ("{");
- Indent_Line (" return " & Lower_Package_Name_Root & "_wisi_module_parse
(env);");
- Indent_Line ("}");
- New_Line;
- Indent_Line ("int emacs_module_init (struct emacs_runtime *ert)");
- Indent_Line ("{");
- Indent_Line (" emacs_env *env = ert->get_environment (ert);");
- Indent_Line
- (" env->bind_function (env, """ & Lower_Package_Name_Root &
- "-wisi-module-parse"", env->make_function (env, 1, 1, Fparse));");
- Indent_Line (" adainit();");
- Indent_Line (" return " & Lower_Package_Name_Root &
"_wisi_module_parse_init (env);");
- Indent_Line ("}");
- Set_Output (Standard_Output);
- Close (File);
- end Create_Module_Aux;
-
-begin
- case Common_Data.Lexer is
- when None | re2c_Lexer =>
- null;
-
- when Elisp_Lexer =>
- raise User_Error with WisiToken.Generate.Error_Message
- (Input_Data.Grammar_Lexer.File_Name, 1, "Ada_Emacs output language
does not support " &
- Lexer_Image (Common_Data.Lexer).all & " lexer");
- end case;
-
- declare
- Actions_Package_Name : constant String := File_Name_To_Ada
(Output_File_Name_Root) &
- (case Common_Data.Interface_Kind is
- when Process => "_Process_Actions",
- when Module => "_Module_Actions");
-
- Main_Package_Name : constant String := File_Name_To_Ada
(Output_File_Name_Root) &
- (case Common_Data.Interface_Kind is
- when Process => "_Process",
- when Module => "_Module") &
- Gen_Alg_Name & "_Main";
- begin
- if Input_Data.Action_Count > 0 or Input_Data.Check_Count > 0 then
- -- We typically have no actions when just getting started with a new
language.
- Create_Ada_Actions_Body
- (Generate_Data.Action_Names, Generate_Data.Check_Names,
Input_Data.Label_Count, Actions_Package_Name);
- end if;
-
- Create_Ada_Actions_Spec
- (Output_File_Name => Output_File_Name_Root &
- (case Common_Data.Interface_Kind is
- when Process => "_process_actions.ads",
- when Module => "_module_actions.ads"),
- Package_Name => Actions_Package_Name,
- Input_Data => Input_Data,
- Common_Data => Common_Data,
- Generate_Data => Generate_Data);
-
- if Tuple.Gen_Alg = External then
- Create_External_Main_Spec (Main_Package_Name, Tuple, Input_Data);
-
- Create_Ada_Main_Body (Actions_Package_Name, Main_Package_Name);
- else
- Create_Ada_Main_Body (Actions_Package_Name, Main_Package_Name);
-
- Create_Ada_Main_Spec
- (Output_File_Name => Output_File_Name_Root & "_" &
- To_Lower (Interface_Type'Image (Common_Data.Interface_Kind)) &
- To_Lower (Gen_Alg_Name) & "_main.ads",
- Main_Package_Name => Main_Package_Name,
- Common_Data => Common_Data,
- Input_Data => Input_Data);
- end if;
- end;
-
- case Common_Data.Interface_Kind is
- when Process =>
- Create_Process_Elisp;
-
- when Module =>
- Create_Module_Elisp;
- Create_Module_Aux;
- end case;
-exception
-when others =>
- Set_Output (Standard_Output);
- raise;
-end WisiToken.BNF.Output_Ada_Emacs;
diff --git a/packages/wisi/wisitoken-bnf-output_elisp_common.adb
b/packages/wisi/wisitoken-bnf-output_elisp_common.adb
deleted file mode 100644
index 2260955..0000000
--- a/packages/wisi/wisitoken-bnf-output_elisp_common.adb
+++ /dev/null
@@ -1,212 +0,0 @@
--- Abstract :
---
--- See spec
---
--- Copyright (C) 2012, 2013, 2015, 2017 - 2019 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Text_IO;
-with WisiToken.Generate;
-package body WisiToken.BNF.Output_Elisp_Common is
-
- function Find_Elisp_ID (List : in String_Lists.List; Elisp_Name : in
String) return Integer
- is
- I : Integer := 0; -- match elisp array
- begin
- for Name of List loop
- if Name = Elisp_Name then
- return I;
- end if;
- I := I + 1;
- end loop;
- raise Not_Found with "unknown elisp name: '" & Elisp_Name & "'";
- end Find_Elisp_ID;
-
- function Elisp_Name_To_Ada
- (Elisp_Name : in String;
- Append_ID : in Boolean;
- Trim : in Integer)
- return String
- is
- Result : String := Elisp_Name (Elisp_Name'First + Trim ..
Elisp_Name'Last);
- begin
- Result (Result'First) := To_Upper (Result (Result'First));
- for I in Result'Range loop
- if Result (I) = '-' then
- Result (I) := '_';
- Result (I + 1) := To_Upper (Result (I + 1));
- elsif Result (I) = '_' then
- Result (I + 1) := To_Upper (Result (I + 1));
- end if;
- end loop;
- if Append_ID then
- return Result & "_ID"; -- Some elisp names may be Ada reserved words;
- else
- return Result;
- end if;
- end Elisp_Name_To_Ada;
-
- procedure Indent_Keyword_Table
- (Output_File_Root : in String;
- Label : in String;
- Keywords : in String_Pair_Lists.List;
- Image : access function (Name : in
Ada.Strings.Unbounded.Unbounded_String) return String)
- is
- use Ada.Text_IO;
- use WisiToken.Generate;
- begin
- Indent_Line ("(defconst " & Output_File_Root & "-" & Label &
"-keyword-table-raw");
- Indent_Line (" '(");
- Indent := Indent + 3;
- for Pair of Keywords loop
- Indent_Line ("(" & (-Pair.Value) & " . " & Image (Pair.Name) & ")");
- end loop;
- Indent_Line ("))");
- Indent := Indent - 3;
- end Indent_Keyword_Table;
-
- procedure Indent_Token_Table
- (Output_File_Root : in String;
- Label : in String;
- Tokens : in Token_Lists.List;
- Image : access function (Name : in
Ada.Strings.Unbounded.Unbounded_String) return String)
- is
- use Ada.Strings.Unbounded;
- use Ada.Text_IO;
- use WisiToken.Generate;
-
- function To_Double_Quotes (Item : in String) return String
- is
- Result : String := Item;
- begin
- if Result (Result'First) = ''' then
- Result (Result'First) := '"';
- end if;
- if Result (Result'Last) = ''' then
- Result (Result'Last) := '"';
- end if;
- return Result;
- end To_Double_Quotes;
-
- begin
- Indent_Line ("(defconst " & Output_File_Root & "-" & Label &
"-token-table-raw");
- Indent_Line (" '(");
- Indent := Indent + 3;
- for Kind of Tokens loop
- if not (-Kind.Kind = "line_comment" or -Kind.Kind = "whitespace") then
- Indent_Line ("(""" & (-Kind.Kind) & """");
- Indent := Indent + 1;
- for Token of Kind.Tokens loop
- if 0 = Length (Token.Value) then
- Indent_Line ("(" & Image (Token.Name) & ")");
- else
- if -Kind.Kind = "number" then
- -- allow for (<token> <number-p> <require>)
- Indent_Line ("(" & Image (Token.Name) & " " &
(-Token.Value) & ")");
- elsif -Kind.Kind = "symbol" or
- -Kind.Kind = "string-double" or
- -Kind.Kind = "string-single"
- then
- -- value not used by elisp
- Indent_Line ("(" & Image (Token.Name) & " . """")");
- else
- Indent_Line ("(" & Image (Token.Name) & " . " &
To_Double_Quotes (-Token.Value) & ")");
- end if;
- end if;
- end loop;
- Indent_Line (")");
- Indent := Indent - 1;
- end if;
- end loop;
- Indent_Line ("))");
- Indent := Indent - 3;
- end Indent_Token_Table;
-
- procedure Indent_Name_Table
- (Output_File_Root : in String;
- Label : in String;
- Names : in String_Lists.List)
- is
- use Ada.Text_IO;
- use WisiToken.Generate;
- begin
- Indent_Line ("(defconst " & Output_File_Root & "-" & Label);
- Indent_Line (" [");
- Indent := Indent + 3;
- for Name of Names loop
- Indent_Line (Name);
- end loop;
- Indent_Line ("])");
- Indent := Indent - 3;
- end Indent_Name_Table;
-
- procedure Indent_Repair_Image
- (Output_File_Root : in String;
- Label : in String;
- Tokens : in WisiToken.BNF.Tokens)
- is
- use all type Ada.Text_IO.Count;
- use Ada.Strings.Unbounded;
- use WisiToken.Generate;
-
- function re2c_To_Elisp (Item : in String) return String
- is
- Result : String (1 .. Item'Length * 2);
- Last : Integer := Result'First - 1;
- begin
- -- Convert re2c case-insensitive string '...' to elisp string "...",
- -- with '"' escaped.
- if Item (Item'First) /= ''' then
- return Item;
- end if;
-
- for C of Item loop
- if C = ''' then
- Result (Last + 1) := '"';
- Last := Last + 1;
- elsif C = '"' then
- Result (Last + 1) := '\';
- Result (Last + 2) := '"';
- Last := Last + 2;
- else
- Result (Last + 1) := C;
- Last := Last + 1;
- end if;
- end loop;
- return Result (1 .. Last);
- end re2c_To_Elisp;
-
- begin
- Indent_Line ("(defconst " & Output_File_Root & "-" & Label &
"-repair-image");
- Indent_Line (" '(");
- Indent := Indent + 3;
- for Pair of Tokens.Keywords loop
- Indent_Line ("(" & (-Pair.Name) & " . " & (-Pair.Value) & ")");
- end loop;
- for Kind of Tokens.Tokens loop
- for Token of Kind.Tokens loop
- if Length (Token.Repair_Image) > 0 then
- Indent_Line ("(" & (-Token.Name) & " . " & re2c_To_Elisp
(-Token.Repair_Image) & ")");
- else
- Indent_Line ("(" & (-Token.Name) & " . " & (-Token.Value) &
")");
- end if;
- end loop;
- end loop;
- Indent_Line ("))");
- Indent := Indent - 3;
- end Indent_Repair_Image;
-
-end WisiToken.BNF.Output_Elisp_Common;
diff --git a/packages/wisi/wisitoken-bnf-output_elisp_common.ads
b/packages/wisi/wisitoken-bnf-output_elisp_common.ads
deleted file mode 100644
index 03a655e..0000000
--- a/packages/wisi/wisitoken-bnf-output_elisp_common.ads
+++ /dev/null
@@ -1,54 +0,0 @@
--- Abstract :
---
--- Subprograms common to Output_Elisp and Output_Ada_Emacs
---
--- Copyright (C) 2012, 2013, 2015, 2017, 2018, 2019 Free Software Foundation,
Inc.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package WisiToken.BNF.Output_Elisp_Common is
-
- function Find_Elisp_ID (List : in WisiToken.BNF.String_Lists.List;
Elisp_Name : in String) return Integer;
-
- function Elisp_Name_To_Ada
- (Elisp_Name : in String;
- Append_ID : in Boolean;
- Trim : in Integer)
- return String;
- -- Drop Trim chars from beginning of Elisp_Name, capitalize.
-
- procedure Indent_Keyword_Table
- (Output_File_Root : in String;
- Label : in String;
- Keywords : in String_Pair_Lists.List;
- Image : access function (Name : in
Ada.Strings.Unbounded.Unbounded_String) return String);
-
- procedure Indent_Token_Table
- (Output_File_Root : in String;
- Label : in String;
- Tokens : in Token_Lists.List;
- Image : access function (Name : in
Ada.Strings.Unbounded.Unbounded_String) return String);
-
- procedure Indent_Name_Table
- (Output_File_Root : in String;
- Label : in String;
- Names : in String_Lists.List);
-
- procedure Indent_Repair_Image
- (Output_File_Root : in String;
- Label : in String;
- Tokens : in WisiToken.BNF.Tokens);
-
-end WisiToken.BNF.Output_Elisp_Common;
diff --git a/packages/wisi/wisitoken-bnf-utils.adb
b/packages/wisi/wisitoken-bnf-utils.adb
deleted file mode 100644
index 71e340f..0000000
--- a/packages/wisi/wisitoken-bnf-utils.adb
+++ /dev/null
@@ -1,45 +0,0 @@
--- Abstract :
---
--- See spec
---
--- Copyright (C) 2012, 2013, 2015, 2017, 2018 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-package body WisiToken.BNF.Utils is
-
- function Strip_Quotes (Item : in String) return String
- is begin
- if Item'Length < 2 then
- return Item;
- else
- return Item
- ((if Item (Item'First) = '"' then Item'First + 1 else Item'First) ..
- (if Item (Item'Last) = '"' then Item'Last - 1 else Item'Last));
- end if;
- end Strip_Quotes;
-
- function Strip_Parens (Item : in String) return String
- is begin
- if Item'Length < 2 then
- return Item;
- else
- return Item
- ((if Item (Item'First) = '(' then Item'First + 1 else Item'First) ..
- (if Item (Item'Last) = ')' then Item'Last - 1 else Item'Last));
- end if;
- end Strip_Parens;
-
-end WisiToken.BNF.Utils;
diff --git a/packages/wisi/wisitoken-bnf-utils.ads
b/packages/wisi/wisitoken-bnf-utils.ads
deleted file mode 100644
index 6062ff9..0000000
--- a/packages/wisi/wisitoken-bnf-utils.ads
+++ /dev/null
@@ -1,29 +0,0 @@
--- Abstract :
---
--- Utilities for generating source code from BNF source files
---
--- Copyright (C) 2012, 2013, 2015, 2017, 2018 Free Software Foundation, Inc.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package WisiToken.BNF.Utils is
-
- function Strip_Quotes (Item : in String) return String;
- -- Remove leading and trailing '"', if any.
-
- function Strip_Parens (Item : in String) return String;
- -- Remove leading and trailing '()', if any.
-
-end WisiToken.BNF.Utils;
diff --git a/packages/wisi/wisitoken-bnf.adb b/packages/wisi/wisitoken-bnf.adb
deleted file mode 100644
index 29e4f60..0000000
--- a/packages/wisi/wisitoken-bnf.adb
+++ /dev/null
@@ -1,355 +0,0 @@
--- Abstract :
---
--- see spec
---
--- Copyright (C) 2012 - 2015, 2017 - 2019 Free Software Foundation, Inc.
---
--- This program is free software; you can redistribute it and/or
--- modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or (at
--- your option) any later version. This program is distributed in the
--- hope that it will be useful, but WITHOUT ANY WARRANTY; without even
--- the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
--- PURPOSE. See the GNU General Public License for more details. You
--- should have received a copy of the GNU General Public License
--- distributed with this program; see file COPYING. If not, write to
--- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
--- MA 02110-1335, USA.
-
-pragma License (GPL);
-
-with Ada.Command_Line;
-with Ada.Directories;
-with Ada.Text_IO;
-with Ada.Strings.Fixed;
-package body WisiToken.BNF is
-
- procedure Add
- (Set : in out Generate_Set_Access;
- Tuple : in Generate_Tuple)
- is
- Prev : Generate_Set_Access := Set;
- Last : constant Integer := (if Prev = null then 1 else
Prev.all'Length + 1);
- begin
- Set := new Generate_Set (1 .. Last);
- for I in 1 .. Last - 1 loop
- Set (I) := Prev (I);
- end loop;
- Set (Last) := Tuple;
- Free (Prev);
- end Add;
-
- function To_Generate_Algorithm (Item : in String) return Generate_Algorithm
- is begin
- for I in Generate_Algorithm loop
- if To_Lower (Generate_Algorithm_Image (I).all) = To_Lower (Item) then
- return I;
- end if;
- end loop;
- raise User_Error with "invalid generate algorithm name: '" & Item & "'";
- end To_Generate_Algorithm;
-
- function To_Output_Language (Item : in String) return Output_Language
- is begin
- for I in Output_Language loop
- if To_Lower (Output_Language_Image (I).all) = To_Lower (Item) then
- return I;
- end if;
- end loop;
- raise User_Error with "invalid output language name: '" & Item & "'";
- end To_Output_Language;
-
- function To_Lexer (Item : in String) return Lexer_Type
- is begin
- for I in Valid_Lexer loop
- if Lexer_Image (I).all = To_Lower (Item) then
- return I;
- end if;
- end loop;
- raise User_Error with "invalid lexer name: '" & Item & "'";
- end To_Lexer;
-
- function Split_Lines (Item : in String) return String_Lists.List
- is
- CR : Character renames ASCII.CR;
- LF : Character renames ASCII.LF;
-
- Result : WisiToken.BNF.String_Lists.List;
- I : Integer := Item'First;
- First : Integer := Item'First;
- Last_Char : Character := ' ';
- begin
- loop
- exit when I > Item'Last;
- if Item (I) = LF then
- Result.Append (Item (First .. I - (if Last_Char = CR then 2 else
1)));
- First := I + 1;
-
- elsif I = Item'Last then
- Result.Append (Item (First .. I));
- end if;
-
- Last_Char := Item (I);
-
- I := I + 1;
- end loop;
- return Result;
- end Split_Lines;
-
- function Trim (Item : in String_Lists.List; Comment_Start : in String)
return String_Lists.List
- is
- use Ada.Strings;
- use Ada.Strings.Fixed;
- Result : String_Lists.List;
- Comment : Integer;
-
- procedure Maybe_Append (Line : in String)
- is begin
- if Line'Length > 0 then
- Result.Append (Line);
- end if;
- end Maybe_Append;
-
- begin
- for Line of Item loop
- Comment := Index (Line, Comment_Start, Going => Backward);
- if Comment /= 0 then
- Maybe_Append (Trim (Line (Line'First .. Comment - 1), Both));
- else
- Maybe_Append (Trim (Line, Both));
- end if;
- end loop;
- return Result;
- end Trim;
-
- procedure Put_Raw_Code
- (Comment_Syntax : in String_2;
- Code : in String_Lists.List;
- Comment_Only : in Boolean := False)
- is
- use Ada.Text_IO;
- Real_Comment_Only : Boolean := Comment_Only;
- begin
- for Line of Code loop
- if Line'Length >= 2 and then
- ((Line (Line'First) = Line (Line'First + 1)) and
- Line (Line'First) /= ' ')
- then
- -- The line is a comment.
- Real_Comment_Only := Real_Comment_Only or Line (Line'First ..
Line'First + 1) /= Comment_Syntax;
-
- Put_Line (Comment_Syntax & Line (Line'First + 2 .. Line'Last));
-
- elsif Comment_Syntax = Elisp_Comment and (Line'Length > 0 and then
Line (Line'First) /= '(') then
- null;
-
- elsif not Comment_Only then
- Put_Line (Line);
- end if;
- end loop;
- end Put_Raw_Code;
-
- procedure Put_File_Header
- (Comment_Syntax : in String_2;
- Emacs_Mode : in String := "";
- Use_Tuple : in Boolean := False;
- Tuple : in Generate_Tuple := (others => <>))
- is
- use Ada.Text_IO;
- begin
- Put_Line (Comment_Syntax & " generated parser support file." &
Emacs_Mode);
- Put_Command_Line (Comment_Syntax & " ", Use_Tuple, Tuple);
- Put_Line (Comment_Syntax);
- end Put_File_Header;
-
- function Is_Present (List : in WisiToken.BNF.String_Pair_Lists.List; Name :
in String) return Boolean
- is
- use all type Ada.Strings.Unbounded.Unbounded_String;
- begin
- for Pair of List loop
- if Pair.Name = Name then
- return True;
- end if;
- end loop;
- return False;
- end Is_Present;
-
- function Value (List : in WisiToken.BNF.String_Pair_Lists.List; Name : in
String) return String
- is
- use all type Ada.Strings.Unbounded.Unbounded_String;
- begin
- for Pair of List loop
- if Pair.Name = Name then
- return -Pair.Value;
- end if;
- end loop;
- raise Not_Found;
- end Value;
-
- function Is_Present (List : in Elisp_Action_Maps.Map; Name : in String)
return Boolean
- is
- use Elisp_Action_Maps;
- begin
- return No_Element /= List.Find (+Name);
- end Is_Present;
-
- function Count (Tokens : in Token_Lists.List) return Integer
- is
- Result : Integer := 0;
- begin
- for Kind of Tokens loop
- Result := Result + Integer (Kind.Tokens.Length);
- end loop;
- return Result;
- end Count;
-
- procedure Add_Token
- (Tokens : in out Token_Lists.List;
- Kind : in String;
- Name : in String;
- Value : in String;
- Repair_Image : in String := "")
- is
- use type Ada.Strings.Unbounded.Unbounded_String;
- begin
- for Token_Kind of Tokens loop
- if Token_Kind.Kind = Kind then
- Token_Kind.Tokens.Append ((+Name, +Value, +Repair_Image));
- return;
- end if;
- end loop;
-
- -- Kind not found; add it
- declare
- Temp : String_Triple_Lists.List;
- begin
- Temp.Append ((+Name, +Value, +Repair_Image));
- Tokens.Append ((+Kind, Temp));
- end;
- end Add_Token;
-
- function Is_In (Tokens : in Token_Lists.List; Kind : in String) return
Boolean
- is begin
- for Token of Tokens loop
- if -Token.Kind = Kind then
- return True;
- end if;
- end loop;
- return False;
- end Is_In;
-
- function Is_In
- (Tokens : in Token_Lists.List;
- Kind : in String;
- Value : in String)
- return Boolean
- is begin
- for Token of Tokens loop
- if -Token.Kind = Kind then
- for Item of Token.Tokens loop
- if -Item.Value = Value then
- return True;
- end if;
- end loop;
- end if;
- end loop;
- return False;
- end Is_In;
-
- function Is_Present (Rules : in Rule_Lists.List; LHS : in String) return
Boolean
- is
- use Rule_Lists;
-
- Found : Boolean := False;
-
- procedure Process (Position : in Cursor)
- is begin
- if -Rules (Position).Left_Hand_Side = LHS then
- Found := True;
- end if;
- end Process;
-
- begin
- Rules.Iterate (Process'Access);
- return Found;
- end Is_Present;
-
- function "+" (List : in String_Lists.List; Item : in String) return
String_Lists.List
- is
- Result : String_Lists.List := List;
- begin
- Result.Append (Item);
- return Result;
- end "+";
-
- function String_To_String_List (Item : in String) return String_Lists.List
- is
- Result : String_Lists.List;
- begin
- Result.Append (Item);
- return Result;
- end String_To_String_List;
-
- function RHS_To_RHS_List (Item : in RHS_Type) return RHS_Lists.List
- is
- Result : RHS_Lists.List;
- begin
- Result.Append (Item);
- return Result;
- end RHS_To_RHS_List;
-
- function "+" (List : in RHS_Lists.List; Item : in RHS_Type) return
RHS_Lists.List
- is
- Result : RHS_Lists.List := List;
- begin
- Result.Append (Item);
- return Result;
- end "+";
-
- procedure Put_Command_Line
- (Comment_Prefix : in String;
- Use_Tuple : in Boolean := False;
- Tuple : in Generate_Tuple := (others => <>))
- is
- use Ada.Command_Line;
- use Ada.Text_IO;
-
- Max_Line_Length : constant := 120;
- Col : Integer := 0;
-
- procedure Put (Item : in String; Leading_Space : in Boolean)
- is begin
- if Col > 0 and Col + Item'Length + 1 > Max_Line_Length then
- New_Line;
- Col := Comment_Prefix'Length;
- Put (Comment_Prefix);
- else
- if Leading_Space then
- Put (" ");
- Col := Col + 1;
- end if;
- end if;
-
- Col := Col + Item'Length;
- Put (Item);
- end Put;
- begin
- Put (Comment_Prefix & "command line:", False);
- Put (Ada.Directories.Simple_Name (Command_Name), True);
- if Use_Tuple then
- Put (" --generate " & Generate_Algorithm'Image (Tuple.Gen_Alg) & " " &
- Output_Language_Image (Tuple.Out_Lang).all &
- (if Tuple.Lexer /= None then " " & Lexer_Image
(Tuple.Lexer).all else "") &
- (if Tuple.Interface_Kind /= None then " " &
Interface_Type'Image (Tuple.Interface_Kind) else "") &
- (if Tuple.Text_Rep then " text_rep" else "") &
- " " & Argument (Argument_Count), -- .wy file
- True);
- else
- for I in 1 .. Argument_Count loop
- Put (Argument (I), True);
- end loop;
- end if;
- New_Line;
- end Put_Command_Line;
-
-end WisiToken.BNF;
diff --git a/packages/wisi/wisitoken-bnf.ads b/packages/wisi/wisitoken-bnf.ads
deleted file mode 100644
index 5263008..0000000
--- a/packages/wisi/wisitoken-bnf.ads
+++ /dev/null
@@ -1,358 +0,0 @@
--- Abstract :
---
--- Root package for generating a parser from a BNF source file; see [2]
---
--- The input file syntax is based on BNF syntax [1] with declarations
--- and grammar actions.
---
--- The Elisp and Ada_Emacs output languages are for use with the
--- Emacs wisi package.
---
--- Reference :
---
--- [1] https://en.wikipedia.org/wiki/Backus%E2%80%93Naur_form
--- [2] http://www.nongnu.org/ada-mode/wisi/wisi-user_guide.html, (info
"(wisi-user_guide)Top")
---
--- Copyright (C) 2012 - 2015, 2017 - 2020 Free Software Foundation, Inc.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Characters.Handling;
-with Ada.Containers.Doubly_Linked_Lists;
-with Ada.Containers.Indefinite_Doubly_Linked_Lists;
-with Ada.Containers.Ordered_Maps;
-with Ada.Containers.Vectors;
-with Ada.Strings.Unbounded;
-with Ada.Unchecked_Deallocation;
-with WisiToken.Parse.LR;
-package WisiToken.BNF is
-
- -- See also WisiToken exceptions
-
- Not_Found : exception;
- -- something not found; should be handled and converted to Syntax_ or
Grammar_Error
-
- type Generate_Algorithm is (None, LALR, LR1, Packrat_Gen, Packrat_Proc,
External);
- subtype Valid_Generate_Algorithm is Generate_Algorithm range LALR ..
Generate_Algorithm'Last;
- subtype LR_Generate_Algorithm is Generate_Algorithm range LALR .. LR1;
- subtype Packrat_Generate_Algorithm is Generate_Algorithm range Packrat_Gen
.. Packrat_Proc;
-
- Generate_Algorithm_Image : constant array (Generate_Algorithm) of
String_Access_Constant :=
- (None => new String'("None"),
- LALR => new String'("LALR"),
- LR1 => new String'("LR1"),
- Packrat_Gen => new String'("Packrat_Gen"),
- Packrat_Proc => new String'("Packrat_Proc"),
- External => new String'("External"));
- -- Suitable for Ada package names.
-
- function To_Generate_Algorithm (Item : in String) return Generate_Algorithm;
- -- Raises User_Error for invalid Item
-
- type Generate_Algorithm_Set is array (Generate_Algorithm) of Boolean;
- type Generate_Algorithm_Set_Access is access Generate_Algorithm_Set;
-
- type Output_Language is (Ada_Lang, Ada_Emacs_Lang);
- subtype Ada_Output_Language is Output_Language range Ada_Lang ..
Ada_Emacs_Lang;
- -- _Lang to avoid colliding with the standard package Ada and
- -- WisiToken packages named *.Ada. In the grammar file, they
- -- are named by (case insensitive):
- Output_Language_Image : constant array (Output_Language) of
String_Access_Constant :=
- (Ada_Lang => new String'("Ada"),
- Ada_Emacs_Lang => new String'("Ada_Emacs"));
-
- function To_Output_Language (Item : in String) return Output_Language;
- -- Raises User_Error for invalid Item
-
- type Lexer_Type is (None, Elisp_Lexer, re2c_Lexer);
- subtype Valid_Lexer is Lexer_Type range Elisp_Lexer .. Lexer_Type'Last;
- -- We append "_Lexer" to these names to avoid colliding with the
- -- similarly-named WisiToken packages. In the grammar file, they
- -- are named by:
- Lexer_Image : constant array (Lexer_Type) of String_Access_Constant :=
- (None => new String'("none"),
- Elisp_Lexer => new String'("elisp"),
- re2c_Lexer => new String'("re2c"));
-
- function To_Lexer (Item : in String) return Lexer_Type;
- -- Raises User_Error for invalid Item
-
- type Lexer_Set is array (Lexer_Type) of Boolean;
-
- type Lexer_Generate_Algorithm_Set is array (Lexer_Type) of
Generate_Algorithm_Set;
- -- %if lexer change change the generated parse table
-
- type Interface_Type is (None, Process, Module);
- subtype Valid_Interface is Interface_Type range Process .. Module;
-
- type Generate_Tuple is record
- Gen_Alg : Generate_Algorithm := None;
- Out_Lang : Output_Language := Ada_Lang;
- Lexer : Lexer_Type := None;
- Interface_Kind : Interface_Type := None;
- Text_Rep : Boolean := False;
- end record;
-
- type Generate_Set is array (Natural range <>) of Generate_Tuple;
- type Generate_Set_Access is access Generate_Set;
- procedure Free is new Ada.Unchecked_Deallocation (Generate_Set,
Generate_Set_Access);
-
- procedure Add
- (Set : in out Generate_Set_Access;
- Tuple : in Generate_Tuple);
-
- package String_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists
(String);
-
- package String_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (WisiToken.Identifier_Index, Ada.Strings.Unbounded.Unbounded_String,
- Default_Element => Ada.Strings.Unbounded.Null_Unbounded_String);
-
- type Language_Param_Type is record
- -- Set by grammar file declarations or command line options. Error
- -- recover parameters are in McKenzie_Recover_Param_Type below.
- Case_Insensitive : Boolean := False;
- End_Names_Optional_Option : Ada.Strings.Unbounded.Unbounded_String;
- Use_Language_Runtime : Boolean := True;
- Language_Runtime_Name : Ada.Strings.Unbounded.Unbounded_String;
- Declare_Enums : Boolean := True;
- Error_Recover : Boolean := False;
- Start_Token : Ada.Strings.Unbounded.Unbounded_String;
- Partial_Recursion : Boolean := False;
- end record;
-
- type Raw_Code_Location is
- (Copyright_License,
- Actions_Spec_Context, Actions_Spec_Pre, Actions_Spec_Post,
- Actions_Body_Context, Actions_Body_Pre, Actions_Body_Post);
- -- So far we have not needed raw code other than license in the main
- -- package.
-
- type Raw_Code is array (Raw_Code_Location) of String_Lists.List;
-
- subtype String_2 is String (1 .. 2);
-
- Ada_Comment : constant String_2 := "--";
- C_Comment : constant String_2 := "//";
- Elisp_Comment : constant String_2 := ";;";
-
- function Split_Lines (Item : in String) return String_Lists.List;
-
- function Trim (Item : in String_Lists.List; Comment_Start : in String)
return String_Lists.List;
- -- From each element, delete trailing comments starting with
- -- Comment_Start; delete leading and trailing spaces.
-
- procedure Put_Raw_Code
- (Comment_Syntax : in String_2;
- Code : in String_Lists.List;
- Comment_Only : in Boolean := False);
- -- Output Code to Ada.Text_IO.Current_Output.
- --
- -- If first two characters of a line are the same and not ' ', it is
- -- assumed to be a comment; ensure the output line has
- -- Comment_Syntax.
- --
- -- If Comment_Only is True, or if the comment syntax used in Code
- -- does not equal Comment_Syntax, only output comment lines.
- --
- -- If Comment_Syntax is Elisp_Comment, only output lines that are
- -- valid elisp comments or forms (ie start with ';;' or '(').
- --
- -- Otherwise output all lines.
-
- procedure Put_File_Header
- (Comment_Syntax : in String_2;
- Emacs_Mode : in String := "";
- Use_Tuple : in Boolean := False;
- Tuple : in Generate_Tuple := (others => <>));
- -- Output "parser support file <emacs_mode> /n command line: " comment to
Ada.Text_IO.Current_Output.
-
- type String_Pair_Type is record
- Name : aliased Ada.Strings.Unbounded.Unbounded_String;
- Value : Ada.Strings.Unbounded.Unbounded_String;
- end record;
-
- package String_Pair_Lists is new Ada.Containers.Doubly_Linked_Lists
(String_Pair_Type);
- function Is_Present (List : in String_Pair_Lists.List; Name : in String)
return Boolean;
- function Value (List : in String_Pair_Lists.List; Name : in String) return
String;
-
- type String_Triple_Type is record
- Name : aliased Ada.Strings.Unbounded.Unbounded_String;
- Value : Ada.Strings.Unbounded.Unbounded_String;
- Repair_Image : Ada.Strings.Unbounded.Unbounded_String;
- end record;
-
- package String_Triple_Lists is new Ada.Containers.Doubly_Linked_Lists
(String_Triple_Type);
-
- type Elisp_Action_Type is record
- -- Elisp name is the key
- Action_Label : Ada.Strings.Unbounded.Unbounded_String;
- Ada_Name : Ada.Strings.Unbounded.Unbounded_String;
- end record;
-
- package Elisp_Action_Maps is new Ada.Containers.Ordered_Maps
- (Ada.Strings.Unbounded.Unbounded_String, Elisp_Action_Type,
Ada.Strings.Unbounded."<");
-
- function Is_Present (List : in Elisp_Action_Maps.Map; Name : in String)
return Boolean;
-
- type McKenzie_Recover_Param_Type is record
- Source_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
- -- Of the %mckenzie_cost_default declaration; we assume the others
- -- are near.
-
- Default_Insert : Natural := 0;
- Default_Delete_Terminal : Natural := 0;
- Default_Push_Back : Natural := 0; --
also default for undo_reduce
- Delete : String_Pair_Lists.List;
- Insert : String_Pair_Lists.List;
- Push_Back : String_Pair_Lists.List;
- Undo_Reduce : String_Pair_Lists.List;
- Minimal_Complete_Cost_Delta : Integer :=
- WisiToken.Parse.LR.Default_McKenzie_Param.Minimal_Complete_Cost_Delta;
- Fast_Forward : Integer :=
- WisiToken.Parse.LR.Default_McKenzie_Param.Fast_Forward;
- Matching_Begin : Integer :=
- WisiToken.Parse.LR.Default_McKenzie_Param.Matching_Begin;
- Ignore_Check_Fail : Natural :=
- WisiToken.Parse.LR.Default_McKenzie_Param.Ignore_Check_Fail;
- Check_Limit : WisiToken.Token_Index :=
- WisiToken.Parse.LR.Default_McKenzie_Param.Check_Limit;
- Check_Delta_Limit : Natural :=
- WisiToken.Parse.LR.Default_McKenzie_Param.Check_Delta_Limit;
- Enqueue_Limit : Natural :=
- WisiToken.Parse.LR.Default_McKenzie_Param.Enqueue_Limit;
- end record;
-
- type Token_Kind_Type is record
- Kind : Ada.Strings.Unbounded.Unbounded_String;
- Tokens : String_Triple_Lists.List;
- end record;
-
- package Token_Lists is new Ada.Containers.Doubly_Linked_Lists
(Token_Kind_Type);
-
- function Count (Tokens : in Token_Lists.List) return Integer;
- -- Count of all leaves.
-
- procedure Add_Token
- (Tokens : in out Token_Lists.List;
- Kind : in String;
- Name : in String;
- Value : in String;
- Repair_Image : in String := "");
- -- Add Name, Value, Repair_Image to Kind list in Tokens.
-
- function Is_In (Tokens : in Token_Lists.List; Kind : in String) return
Boolean;
- function Is_In
- (Tokens : in Token_Lists.List;
- Kind : in String;
- Value : in String)
- return Boolean;
-
- type Conflict is record
- Source_Line : WisiToken.Line_Number_Type;
- Action_A : Ada.Strings.Unbounded.Unbounded_String;
- LHS_A : Ada.Strings.Unbounded.Unbounded_String;
- Action_B : Ada.Strings.Unbounded.Unbounded_String;
- LHS_B : Ada.Strings.Unbounded.Unbounded_String;
- On : Ada.Strings.Unbounded.Unbounded_String;
- end record;
-
- package Conflict_Lists is new Ada.Containers.Doubly_Linked_Lists (Conflict);
-
- type Labeled_Token is record
- Label : Ada.Strings.Unbounded.Unbounded_String;
- Identifier : Ada.Strings.Unbounded.Unbounded_String;
- end record;
-
- package Labeled_Token_Arrays is new Ada.Containers.Vectors
(Positive_Index_Type, Labeled_Token);
- -- Index matches Syntax_Trees.Valid_Node_Index_Array, used for Tokens
- -- in call to post parse grammar action.
-
- type RHS_Type is record
- Tokens : Labeled_Token_Arrays.Vector;
- Action : Ada.Strings.Unbounded.Unbounded_String;
- Check : Ada.Strings.Unbounded.Unbounded_String;
- Source_Line : WisiToken.Line_Number_Type :=
WisiToken.Invalid_Line_Number;
- end record;
- package RHS_Lists is new Ada.Containers.Doubly_Linked_Lists (RHS_Type, "=");
-
- type Rule_Type is record
- Left_Hand_Side : aliased Ada.Strings.Unbounded.Unbounded_String;
- Right_Hand_Sides : RHS_Lists.List;
- Labels : String_Arrays.Vector;
- Source_Line : WisiToken.Line_Number_Type;
- end record;
-
- package Rule_Lists is new Ada.Containers.Doubly_Linked_Lists (Rule_Type);
-
- function Is_Present (Rules : in Rule_Lists.List; LHS : in String) return
Boolean;
-
- type Tokens is record
- Non_Grammar : Token_Lists.List;
- Keywords : String_Pair_Lists.List;
- Tokens : Token_Lists.List;
- Rules : Rule_Lists.List;
- -- Rules included here because they define the nonterminal tokens, as
- -- well as the productions.
-
- Virtual_Identifiers : String_Arrays.Vector;
- -- Nonterminals and terminals introduced by translating from EBNF to
- -- BNF.
-
- -- The following are specified in grammar file declarations and used
- -- in other declarations or actions. Faces, Indents only used if .wy
- -- action language is elisp and output language is not elisp.
-
- re2c_Regexps : String_Pair_Lists.List; -- %re2c_regexp
- Faces : String_Lists.List; -- %elisp_face
- Indents : String_Pair_Lists.List; -- %elisp_indent
- Actions : Elisp_Action_Maps.Map; -- %elisp_action
- end record;
-
- function "+" (Item : in String) return
Ada.Strings.Unbounded.Unbounded_String
- renames Ada.Strings.Unbounded.To_Unbounded_String;
-
- function "-" (Item : in Ada.Strings.Unbounded.Unbounded_String) return
String
- renames Ada.Strings.Unbounded.To_String;
-
- function To_Lower (Item : in String) return String
- renames Ada.Characters.Handling.To_Lower;
-
- function To_Upper (Item : in String) return String
- renames Ada.Characters.Handling.To_Upper;
-
- function To_Upper (Item : in Character) return Character
- renames Ada.Characters.Handling.To_Upper;
-
- function "+" (List : in String_Lists.List; Item : in String) return
String_Lists.List;
-
- function String_To_String_List (Item : in String) return String_Lists.List;
- function "+" (Item : in String) return String_Lists.List renames
String_To_String_List;
-
- function RHS_To_RHS_List (Item : in RHS_Type) return RHS_Lists.List;
- function "+" (Item : in RHS_Type) return RHS_Lists.List renames
RHS_To_RHS_List;
-
- function "+" (List : in RHS_Lists.List; Item : in RHS_Type) return
RHS_Lists.List;
-
- function Image (Item : in Boolean) return String
- is (if Item then "True" else "False");
- -- Match casing in Standard.
-
- procedure Put_Command_Line
- (Comment_Prefix : in String;
- Use_Tuple : in Boolean := False;
- Tuple : in Generate_Tuple := (others => <>));
- -- Put command line to current output; indicate current tuple.
-
-end WisiToken.BNF;
diff --git a/packages/wisi/wisitoken-followed_by.adb
b/packages/wisi/wisitoken-followed_by.adb
deleted file mode 100644
index e254bb6..0000000
--- a/packages/wisi/wisitoken-followed_by.adb
+++ /dev/null
@@ -1,207 +0,0 @@
--- 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-gen_token_enum.adb
b/packages/wisi/wisitoken-gen_token_enum.adb
deleted file mode 100644
index 0b17832..0000000
--- a/packages/wisi/wisitoken-gen_token_enum.adb
+++ /dev/null
@@ -1,133 +0,0 @@
--- Abstract :
---
--- See spec
---
--- Copyright (C) 2017, 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (GPL);
-
-with Ada.Characters.Handling;
-with WisiToken.Wisi_Ada;
-package body WisiToken.Gen_Token_Enum is
-
- function Token_Enum_Image return Token_ID_Array_String
- is
- use Ada.Characters.Handling;
- Result : Token_ID_Array_String (Token_ID'First .. +Last_Nonterminal);
- begin
- for I in Token_Enum_ID loop
- if I <= Last_Terminal then
- Result (+I) := new String'(Token_Enum_ID'Image (I));
- else
- Result (+I) := new String'(To_Lower (Token_Enum_ID'Image (I)));
- end if;
- end loop;
- return Result;
- end Token_Enum_Image;
-
- function To_Syntax (Item : in Enum_Syntax) return
WisiToken.Lexer.Regexp.Syntax
- is
- Result : WisiToken.Lexer.Regexp.Syntax (Token_ID'First ..
+Last_Terminal);
- begin
- for I in Result'Range loop
- Result (I) := Item (-I);
- end loop;
- return Result;
- end To_Syntax;
-
- function "&" (Left, Right : in Token_Enum_ID) return Token_ID_Arrays.Vector
- is begin
- return Result : Token_ID_Arrays.Vector do
- Result.Append (+Left);
- Result.Append (+Right);
- end return;
- end "&";
-
- function "&"
- (Left : in Token_ID_Arrays.Vector;
- Right : in Token_Enum_ID)
- return Token_ID_Arrays.Vector
- is begin
- return Result : Token_ID_Arrays.Vector := Left do
- Result.Append (+Right);
- end return;
- end "&";
-
- function "+"
- (Left : in Token_Enum_ID;
- Right : in WisiToken.Syntax_Trees.Semantic_Action)
- return WisiToken.Productions.Right_Hand_Side
- is begin
- return WisiToken.Wisi_Ada."+" (+Left, Right);
- end "+";
-
- function "<="
- (Left : in Token_Enum_ID;
- Right : in WisiToken.Productions.Right_Hand_Side)
- return WisiToken.Productions.Instance
- is begin
- return WisiToken.Wisi_Ada."<=" (+Left, Productions.RHS_Arrays.To_Vector
(Right, 1));
- end "<=";
-
- function To_Nonterminal_Array_Token_Set
- (Item : in Nonterminal_Array_Token_Set)
- return WisiToken.Token_Array_Token_Set
- is
- Result : Token_Array_Token_Set :=
- (LR1_Descriptor.First_Nonterminal .. LR1_Descriptor.Last_Nonterminal =>
- (LR1_Descriptor.First_Terminal .. LR1_Descriptor.Last_Nonterminal
=> False));
- begin
- for I in Item'Range (1) loop
- for J in Item'Range (2) loop
- Result (+I, +J) := Item (I, J);
- end loop;
- end loop;
- return Result;
- end To_Nonterminal_Array_Token_Set;
-
- function To_Nonterminal_Array_Terminal_Set
- (Item : in Nonterminal_Array_Terminal_Set)
- return WisiToken.Token_Array_Token_Set
- is
- Result : Token_Array_Token_Set :=
- (LR1_Descriptor.First_Nonterminal .. LR1_Descriptor.Last_Nonterminal =>
- (LR1_Descriptor.First_Terminal .. LR1_Descriptor.Last_Terminal =>
False));
- begin
- for I in Item'Range (1) loop
- for J in Item'Range (2) loop
- Result (+I, +J) := Item (I, J);
- end loop;
- end loop;
- return Result;
- end To_Nonterminal_Array_Terminal_Set;
-
- function "+" (Item : in Token_Array) return WisiToken.Token_ID_Set
- is
- Result : Token_ID_Set := (LR1_Descriptor.First_Terminal ..
LR1_Descriptor.Last_Terminal => False);
- begin
- for I in Item'Range loop
- Result (+Item (I)) := True;
- end loop;
- return Result;
- end "+";
-
- function "+" (Item : in Token_Enum_ID) return WisiToken.Token_ID_Set
- is begin
- return +Token_Array'(1 => Item);
- end "+";
-
-begin
- LR1_Descriptor.Image := Token_Enum_Image;
- LALR_Descriptor.Image := LR1_Descriptor.Image;
-end WisiToken.Gen_Token_Enum;
diff --git a/packages/wisi/wisitoken-gen_token_enum.ads
b/packages/wisi/wisitoken-gen_token_enum.ads
deleted file mode 100644
index 05bdb99..0000000
--- a/packages/wisi/wisitoken-gen_token_enum.ads
+++ /dev/null
@@ -1,122 +0,0 @@
--- Abstract :
---
--- Support for an enumerated token type
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (GPL);
-
-with WisiToken.Lexer.Regexp;
-with WisiToken.Productions;
-with WisiToken.Syntax_Trees;
-generic
- type Token_Enum_ID is (<>);
- First_Terminal : Token_Enum_ID;
- Last_Terminal : Token_Enum_ID;
- First_Nonterminal : Token_Enum_ID;
- Last_Nonterminal : Token_Enum_ID;
- EOF_ID : Token_Enum_ID;
- Accept_ID : Token_Enum_ID;
- Case_Insensitive : Boolean;
-package WisiToken.Gen_Token_Enum is
-
- function "+" (Item : in Token_Enum_ID) return Token_ID
- is (Token_ID'First + Token_Enum_ID'Pos (Item));
-
- function "-" (Item : in Token_ID) return Token_Enum_ID
- is (Token_Enum_ID'Val (Item - Token_ID'First));
-
- function Token_Enum_Image return Token_ID_Array_String;
-
- subtype Terminal_Enum_ID is Token_Enum_ID range First_Terminal ..
Last_Terminal;
- subtype Nonterminal_Enum_ID is Token_Enum_ID range First_Nonterminal ..
Last_Nonterminal;
-
- LR1_Descriptor : aliased WisiToken.Descriptor :=
- (First_Terminal => +First_Terminal,
- Last_Terminal => +Last_Terminal,
- First_Nonterminal => +First_Nonterminal,
- Last_Nonterminal => +Last_Nonterminal,
- EOI_ID => +EOF_ID,
- Accept_ID => +Accept_ID,
- Case_Insensitive => Case_Insensitive,
- New_Line_ID => Invalid_Token_ID,
- String_1_ID => Invalid_Token_ID,
- String_2_ID => Invalid_Token_ID,
- Image => (others => null), -- set in body elaboration
time code
- Terminal_Image_Width => Terminal_Enum_ID'Width,
- Image_Width => Token_Enum_ID'Width,
- Last_Lookahead => +Last_Terminal);
-
- LALR_Descriptor : aliased WisiToken.Descriptor :=
- (First_Terminal => +First_Terminal,
- Last_Terminal => +Last_Terminal,
- First_Nonterminal => +First_Nonterminal,
- Last_Nonterminal => +Last_Nonterminal,
- EOI_ID => +EOF_ID,
- Accept_ID => +Accept_ID,
- Case_Insensitive => Case_Insensitive,
- New_Line_ID => Invalid_Token_ID,
- String_1_ID => Invalid_Token_ID,
- String_2_ID => Invalid_Token_ID,
- Image => (others => null),
- Terminal_Image_Width => Terminal_Enum_ID'Width,
- Image_Width => Token_Enum_ID'Width,
- Last_Lookahead => +First_Nonterminal);
-
- type Enum_Syntax is array (Token_Enum_ID range Token_Enum_ID'First ..
Last_Terminal) of
- WisiToken.Lexer.Regexp.Syntax_Item;
-
- function To_Syntax (Item : in Enum_Syntax) return
WisiToken.Lexer.Regexp.Syntax;
-
- function "&" (Left, Right : in Token_Enum_ID) return Token_ID_Arrays.Vector;
-
- function "&"
- (Left : in Token_ID_Arrays.Vector;
- Right : in Token_Enum_ID)
- return Token_ID_Arrays.Vector;
-
- function "+" (Left : in Token_Enum_ID; Right : in
Syntax_Trees.Semantic_Action) return Productions.Right_Hand_Side;
-
- function "<="
- (Left : in Token_Enum_ID;
- Right : in WisiToken.Productions.Right_Hand_Side)
- return WisiToken.Productions.Instance;
-
- ----------
- -- For unit tests
-
- subtype Terminal_ID is Token_Enum_ID range First_Terminal .. Last_Terminal;
- subtype Nonterminal_ID is Token_Enum_ID range First_Nonterminal ..
Last_Nonterminal;
- subtype Grammar_ID is Token_Enum_ID range First_Terminal ..
Last_Nonterminal;
-
- type Nonterminal_Array_Token_Set is array (Nonterminal_ID, Grammar_ID) of
Boolean;
-
- function To_Nonterminal_Array_Token_Set
- (Item : in Nonterminal_Array_Token_Set)
- return WisiToken.Token_Array_Token_Set;
-
- type Nonterminal_Array_Terminal_Set is array (Nonterminal_ID, Terminal_ID)
of Boolean;
-
- function To_Nonterminal_Array_Terminal_Set
- (Item : in Nonterminal_Array_Terminal_Set)
- return WisiToken.Token_Array_Token_Set;
-
- type Nonterminal_ID_Set is array (Nonterminal_ID) of Boolean;
-
- type Token_Array is array (Positive range <>) of Token_Enum_ID;
-
- function "+" (Item : in Token_Array) return WisiToken.Token_ID_Set;
- function "+" (Item : in Token_Enum_ID) return WisiToken.Token_ID_Set;
-
-end WisiToken.Gen_Token_Enum;
diff --git a/packages/wisi/wisitoken-generate-lr-lalr_generate.adb
b/packages/wisi/wisitoken-generate-lr-lalr_generate.adb
deleted file mode 100644
index e544078..0000000
--- a/packages/wisi/wisitoken-generate-lr-lalr_generate.adb
+++ /dev/null
@@ -1,611 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2020 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-with Ada.Text_IO;
-with SAL.Gen_Definite_Doubly_Linked_Lists_Sorted;
-package body WisiToken.Generate.LR.LALR_Generate is
-
- type Item_ID is record
- State : Unknown_State_Index := Unknown_State;
- LHS : Token_ID := Invalid_Token_ID;
- RHS : Productions.RHS_Arrays.Extended_Index :=
Productions.RHS_Arrays.No_Index;
- Dot : Token_ID_Arrays.Extended_Index :=
Token_ID_Arrays.No_Index;
- end record;
-
- function Image (Item : in Item_ID) return String
- is ("(" & Item.State'Image & ", " & Trimmed_Image ((Item.LHS, Item.RHS))
& ")");
-
- function Compare (Left, Right : in Item_ID) return SAL.Compare_Result
- is (if Left.State < Right.State then SAL.Less
- elsif Left.State > Right.State then SAL.Greater
- elsif Left.LHS < Right.LHS then SAL.Less
- elsif Left.LHS > Right.LHS then SAL.Greater
- elsif Left.RHS < Right.RHS then SAL.Less
- elsif Left.RHS > Right.RHS then SAL.Greater
- elsif Left.Dot < Right.Dot then SAL.Less
- elsif Left.Dot > Right.Dot then SAL.Greater
- else SAL.Equal);
-
- package Item_ID_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists_Sorted
(Item_ID, Compare);
-
- type Item_Map is record
- From : Item_ID;
- To : Item_ID_Lists.List;
- end record;
-
- function Compare (Left, Right : in Item_Map) return SAL.Compare_Result
- is (Compare (Left.From, Right.From));
-
- package Propagation_Lists is new
SAL.Gen_Definite_Doubly_Linked_Lists_Sorted (Item_Map, Compare);
-
- function Item_Ref
- (Kernels : in out LR1_Items.Item_Set_List;
- ID : in Item_ID)
- return LR1_Items.Item_Lists.Variable_Reference_Type
- is (LR1_Items.Item_Lists.Variable_Ref
- (LR1_Items.Find (Prod => (ID.LHS, ID.RHS), Dot => ID.Dot, Set =>
Kernels (ID.State))));
-
- function Propagate_Lookahead (Descriptor : in WisiToken.Descriptor) return
Token_ID_Set_Access
- is begin
- return new Token_ID_Set'(LR1_Items.To_Lookahead
(Descriptor.Last_Lookahead, Descriptor));
- end Propagate_Lookahead;
-
- function Null_Lookahead (Descriptor : in WisiToken.Descriptor) return
Token_ID_Set_Access
- is begin
- return new Token_ID_Set'(Descriptor.First_Terminal ..
Descriptor.Last_Lookahead => False);
- end Null_Lookahead;
-
- ----------
- -- Debug output
-
- procedure Put (Propagations : in Propagation_Lists.List)
- is
- use Item_ID_Lists;
- begin
- for Map of Propagations loop
- Ada.Text_IO.Put_Line ("From " & Image (Map.From));
-
- for ID of Map.To loop
- Ada.Text_IO.Put_Line ("To " & Image (ID));
- end loop;
- end loop;
- end Put;
-
- ----------
- -- Generate utils
-
- function LALR_Goto_Transitions
- (Kernel : in LR1_Items.Item_Set;
- Symbol : in Token_ID;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set
- is
- use Token_ID_Arrays;
- use LR1_Items;
- use LR1_Items.Item_Lists;
-
- Goto_Set : Item_Set;
- begin
- for Item of Kernel.Set loop
-
- if Item.Dot /= No_Index then
-
- declare
- Dot : constant Token_ID_Arrays.Cursor :=
Productions.Constant_Ref_RHS
- (Grammar, Item.Prod).Tokens.To_Cursor (Item.Dot);
- Dot_ID : constant Token_ID := Element (Dot);
- Next_Dot : constant Token_ID_Arrays.Cursor := Next (Dot);
- begin
- -- If Symbol = EOF_Token, this is the start symbol accept
- -- production; don't need a kernel with dot after EOF.
-
- if (Dot_ID = Symbol and Symbol /= Descriptor.EOI_ID) and then
- not Has_Element (Find (Item, Goto_Set))
- then
- Goto_Set.Set.Insert
- ((Prod => Item.Prod,
- Dot => To_Index (Next_Dot),
- Lookaheads => new Token_ID_Set'(Item.Lookaheads.all)));
-
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line ("LALR_Goto_Transitions 1 " & Image
(Symbol, Descriptor));
- Put (Grammar, Descriptor, Goto_Set);
- end if;
- end if;
-
- if Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- First_Nonterm_Set (Dot_ID, Symbol)
- then
- -- Find the production(s) that create Dot_ID with first
token Symbol
- -- and put them in.
- for Prod of Grammar loop
- for RHS_2_I in Prod.RHSs.First_Index ..
Prod.RHSs.Last_Index loop
- declare
- P_ID : constant Production_ID :=
(Prod.LHS, RHS_2_I);
- Tokens : Token_ID_Arrays.Vector renames
Prod.RHSs (RHS_2_I).Tokens;
- Dot_2 : constant Token_ID_Arrays.Cursor :=
Tokens.First;
- Next_Dot_2 : constant Token_ID_Arrays.Cursor :=
Next (Dot_2);
- begin
- if (Dot_ID = Prod.LHS or First_Nonterm_Set (Dot_ID,
Prod.LHS)) and
- (Has_Element (Dot_2) and then Element (Dot_2) =
Symbol)
- then
- if not Has_Element (Find (P_ID, To_Index
(Next_Dot_2), Goto_Set)) then
- Goto_Set.Set.Insert
- ((Prod => P_ID,
- Dot => To_Index (Next_Dot_2),
- Lookaheads => Null_Lookahead
(Descriptor)));
-
- -- else already in goto set
- end if;
- end if;
- end;
- end loop;
- end loop;
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line ("LALR_Goto_Transitions 2 " & Image
(Symbol, Descriptor));
- Put (Grammar, Descriptor, Goto_Set);
- end if;
- end if;
- end;
- end if; -- item.dot /= null
- end loop;
-
- return Goto_Set;
- end LALR_Goto_Transitions;
-
- function LALR_Kernels
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set_List
- is
- use all type Ada.Containers.Count_Type;
- use LR1_Items;
-
- First_State_Index : constant State_Index := 0;
- Kernels : LR1_Items.Item_Set_List;
- Kernel_Tree : LR1_Items.Item_Set_Trees.Tree; -- for fast find
- States_To_Check : State_Index_Queues.Queue;
- Checking_State : State_Index;
- begin
- Kernels.Set_First_Last (First_State_Index, First_State_Index - 1);
-
- Add (Grammar,
- (Set => Item_Lists.To_List
- ((Prod => (Grammar.First_Index, 0),
- Dot => Grammar (Grammar.First_Index).RHSs
(0).Tokens.First_Index,
- Lookaheads => Null_Lookahead (Descriptor))),
- Goto_List => <>,
- Dot_IDs => <>,
- State => First_State_Index),
- Kernels,
- Kernel_Tree,
- Descriptor,
- Include_Lookaheads => False);
-
- States_To_Check.Put (First_State_Index);
- loop
- exit when States_To_Check.Is_Empty;
- Checking_State := States_To_Check.Get;
-
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put ("Checking ");
- Put (Grammar, Descriptor, Kernels (Checking_State));
- end if;
-
- for Symbol in Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal loop
- -- LALR_Goto_Transitions does _not_ ignore Symbol if it is not in
- -- Item_Set.Dot_IDs, so we can't iterate on that here as we do in
- -- LR1_Generate.
-
- declare
- New_Item_Set : Item_Set := LALR_Goto_Transitions
- (Kernels (Checking_State), Symbol, First_Nonterm_Set,
Grammar, Descriptor);
- Found_State : Unknown_State_Index;
- begin
- if New_Item_Set.Set.Length > 0 then
-
- Found_State := Find (New_Item_Set, Kernel_Tree,
Match_Lookaheads => False);
-
- if Found_State = Unknown_State then
- New_Item_Set.State := Kernels.Last_Index + 1;
-
- States_To_Check.Put (New_Item_Set.State);
-
- Add (Grammar, New_Item_Set, Kernels, Kernel_Tree,
Descriptor, Include_Lookaheads => False);
-
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line (" adding state" &
Unknown_State_Index'Image (Kernels.Last_Index));
-
- Ada.Text_IO.Put_Line
- (" state" & Unknown_State_Index'Image
(Checking_State) &
- " adding goto on " & Image (Symbol, Descriptor) &
" to state" &
- Unknown_State_Index'Image (Kernels.Last_Index));
- end if;
-
- Kernels (Checking_State).Goto_List.Insert ((Symbol,
Kernels.Last_Index));
- else
-
- -- If there's not already a goto entry between these two
sets, create one.
- if not Is_In ((Symbol, Found_State), Kernels
(Checking_State).Goto_List) then
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line
- (" state" & Unknown_State_Index'Image
(Checking_State) &
- " adding goto on " & Image (Symbol,
Descriptor) & " to state" &
- Unknown_State_Index'Image (Found_State));
-
- end if;
-
- Kernels (Checking_State).Goto_List.Insert ((Symbol,
Found_State));
- end if;
- end if;
- end if;
- end;
- end loop;
- end loop;
-
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.New_Line;
- end if;
-
- return Kernels;
- end LALR_Kernels;
-
- -- Add a propagation entry (if it doesn't already exist) from From in
- -- From_Set to To_Item.
- procedure Add_Propagation
- (From_Item : in LR1_Items.Item;
- From_State : in State_Index;
- To_Item : in LR1_Items.Item_Lists.Cursor;
- To_State : in State_Index;
- Propagations : in out Propagation_Lists.List)
- is
- use Propagation_Lists;
- use LR1_Items;
- use LR1_Items.Item_Lists;
- use Item_ID_Lists;
-
- To_Item_Ref : constant LR1_Items.Item_Lists.Constant_Reference_Type :=
Constant_Ref (To_Item);
-
- From_ID : constant Item_ID := (From_State, From_Item.Prod.LHS,
From_Item.Prod.RHS, From_Item.Dot);
- To_ID : constant Item_ID := (To_State, To_Item_Ref.Prod.LHS,
To_Item_Ref.Prod.RHS, To_Item_Ref.Dot);
-
- From_Match : constant Propagation_Lists.Cursor := Propagations.Find
((From_ID, Item_ID_Lists.Empty_List));
- begin
- if not Has_Element (From_Match) then
- Propagations.Insert ((From_ID, To_List (To_ID)));
-
- else
- declare
- To_Match : constant Item_ID_Lists.Cursor := Constant_Ref
(From_Match).To.Find (To_ID);
- begin
- if not Has_Element (To_Match) then
- Variable_Ref (From_Match).To.Insert (To_ID);
- end if;
- end;
- end if;
- end Add_Propagation;
-
- -- Calculate the lookaheads from Closure_Item for Source_Item.
- -- Source_Item must be one of the kernel items in Source_Set.
- -- Closure_Item must be an item in the lookahead closure of Source_Item
for #.
- --
- -- Spontaneous lookaheads are put in Source_Item.Lookahead,
- -- propagated lookaheads in Propagations.
- --
- -- Set Used_Tokens = True for all tokens in lookaheads.
- procedure Generate_Lookahead_Info
- (Source_Item : in LR1_Items.Item;
- Source_Set : in LR1_Items.Item_Set;
- Closure_Item : in LR1_Items.Item;
- Propagations : in out Propagation_Lists.List;
- Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Kernels : in out LR1_Items.Item_Set_List)
- is
- use LR1_Items;
- use LR1_Items.Item_Lists;
- use Token_ID_Arrays;
-
- Spontaneous_Count : Integer := 0;
- begin
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.Put_Line (" closure_item: ");
- LR1_Items.Put (Grammar, Descriptor, Closure_Item);
- Ada.Text_IO.New_Line;
- end if;
-
- if Closure_Item.Dot = No_Index then
- return;
- end if;
-
- declare
- Dot : constant Token_ID_Arrays.Cursor :=
Productions.Constant_Ref_RHS
- (Grammar, Closure_Item.Prod).Tokens.To_Cursor (Closure_Item.Dot);
- ID : constant Token_ID := Element (Dot);
- Next_Dot : constant Token_ID_Arrays.Cursor := Next (Dot);
- Goto_State : constant Unknown_State_Index := LR1_Items.Goto_State
(Source_Set, ID);
- begin
- if Goto_State /= Unknown_State then
- declare
- To_Item : constant Item_Lists.Cursor :=
- LR1_Items.Find (Closure_Item.Prod, To_Index (Next_Dot),
Kernels (Goto_State));
- begin
- if Closure_Item.Lookaheads (Descriptor.Last_Lookahead) then
- Add_Propagation
- (From_Item => Source_Item,
- From_State => Source_Set.State,
- To_Item => To_Item,
- To_State => Goto_State,
- Propagations => Propagations);
- end if;
-
- if Trace_Generate_Table > Outline then
- Spontaneous_Count := Spontaneous_Count + 1;
- Ada.Text_IO.Put_Line (" spontaneous: " & Lookahead_Image
(Closure_Item.Lookaheads.all, Descriptor));
- end if;
-
- LR1_Items.Include (Variable_Ref (To_Item),
Closure_Item.Lookaheads.all, Descriptor);
- end;
- end if;
- end;
- end Generate_Lookahead_Info;
-
- procedure Propagate_Lookaheads
- (Propagations : in Propagation_Lists.List;
- Kernels : in out LR1_Items.Item_Set_List;
- Descriptor : in WisiToken.Descriptor)
- is
- -- In Propagations, update all To lookaheads from From lookaheads,
- -- recursively.
- More_To_Check : Boolean := True;
- Added_One : Boolean;
- begin
- while More_To_Check loop
-
- More_To_Check := False;
- for Map of Propagations loop
- for ID of Map.To loop
- LR1_Items.Include
- (Item_Ref (Kernels, ID), Item_Ref (Kernels,
Map.From).Lookaheads.all, Added_One, Descriptor);
-
- More_To_Check := More_To_Check or Added_One;
- end loop;
- end loop;
- end loop;
- end Propagate_Lookaheads;
-
- -- Calculate the LALR(1) lookaheads for Grammar.
- -- Kernels should be the sets of LR(0) kernels on input, and will
- -- become the set of LALR(1) kernels on output.
- procedure Fill_In_Lookaheads
- (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Kernels : in out LR1_Items.Item_Set_List;
- Descriptor : in WisiToken.Descriptor)
- is
- Closure : LR1_Items.Item_Set;
- Propagations : Propagation_Lists.List;
- begin
- for Kernel of Kernels loop
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.Put ("Adding lookaheads for ");
- LR1_Items.Put (Grammar, Descriptor, Kernel);
- end if;
-
- for Kernel_Item of Kernel.Set loop
- Closure := LR1_Items.Closure
- ((Set => LR1_Items.Item_Lists.To_List
- ((Prod => Kernel_Item.Prod,
- Dot => Kernel_Item.Dot,
- Lookaheads => Propagate_Lookahead (Descriptor))),
- Goto_List => <>,
- Dot_IDs => <>,
- State => <>),
- Has_Empty_Production, First_Terminal_Sequence, Grammar,
Descriptor);
-
- for Closure_Item of Closure.Set loop
- Generate_Lookahead_Info
- (Kernel_Item, Kernel, Closure_Item, Propagations, Descriptor,
Grammar, Kernels);
- end loop;
- end loop;
- end loop;
-
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("Propagations:");
- Put (Propagations);
- Ada.Text_IO.New_Line;
- end if;
-
- Propagate_Lookaheads (Propagations, Kernels, Descriptor);
- end Fill_In_Lookaheads;
-
- -- Add actions for all Kernels to Table.
- procedure Add_Actions
- (Kernels : in LR1_Items.Item_Set_List;
- Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Conflict_Counts : out Conflict_Count_Lists.List;
- Conflicts : out Conflict_Lists.List;
- Table : in out Parse_Table;
- Descriptor : in WisiToken.Descriptor)
- is
- Closure : LR1_Items.Item_Set;
- begin
- for Kernel of Kernels loop
- -- IMPROVEME: there are three "closure" computations that could
- -- probably be refactored to save computation; in
- -- LALR_Goto_Transitions, Fill_In_Lookaheads, and here.
- Closure := LR1_Items.Closure (Kernel, Has_Empty_Production,
First_Terminal_Sequence, Grammar, Descriptor);
-
- Add_Actions
- (Closure, Table, Grammar, Has_Empty_Production, First_Nonterm_Set,
- Conflict_Counts, Conflicts, Descriptor);
- end loop;
-
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.New_Line;
- end if;
- end Add_Actions;
-
- function Generate
- (Grammar : in out WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Known_Conflicts : in Conflict_Lists.List :=
Conflict_Lists.Empty_List;
- McKenzie_Param : in McKenzie_Param_Type :=
Default_McKenzie_Param;
- Parse_Table_File_Name : in String := "";
- Include_Extra : in Boolean := False;
- Ignore_Conflicts : in Boolean := False;
- Partial_Recursion : in Boolean := True)
- return Parse_Table_Ptr
- is
- use all type Ada.Containers.Count_Type;
-
- Ignore_Unused_Tokens : constant Boolean :=
WisiToken.Trace_Generate_Table > Detail;
- Ignore_Unknown_Conflicts : constant Boolean := Ignore_Conflicts or
WisiToken.Trace_Generate_Table > Detail;
- Unused_Tokens : constant Boolean :=
WisiToken.Generate.Check_Unused_Tokens (Descriptor, Grammar);
-
- Table : Parse_Table_Ptr;
-
- Nullable : constant Token_Array_Production_ID :=
WisiToken.Generate.Nullable (Grammar);
- Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Nullable);
-
- Recursions : constant WisiToken.Generate.Recursions :=
- (if Partial_Recursion
- then WisiToken.Generate.Compute_Partial_Recursion (Grammar,
Descriptor)
- else WisiToken.Generate.Compute_Full_Recursion (Grammar, Descriptor));
- Minimal_Terminal_Sequences : constant Minimal_Sequence_Array :=
- Compute_Minimal_Terminal_Sequences (Descriptor, Grammar);
-
- Minimal_Terminal_First : constant Token_Array_Token_ID :=
- Compute_Minimal_Terminal_First (Descriptor,
Minimal_Terminal_Sequences);
-
- First_Nonterm_Set : constant Token_Array_Token_Set :=
WisiToken.Generate.First
- (Grammar, Has_Empty_Production, Descriptor.First_Terminal);
-
- First_Terminal_Sequence : constant Token_Sequence_Arrays.Vector :=
- WisiToken.Generate.To_Terminal_Sequence_Array (First_Nonterm_Set,
Descriptor);
-
- Kernels : LR1_Items.Item_Set_List := LALR_Kernels (Grammar,
First_Nonterm_Set, Descriptor);
-
- Conflict_Counts : Conflict_Count_Lists.List;
- Unknown_Conflicts : Conflict_Lists.List;
- Known_Conflicts_Edit : Conflict_Lists.List := Known_Conflicts;
-
- begin
- WisiToken.Generate.Error := False; -- necessary in unit tests; some
previous test might have encountered an error.
-
- if Trace_Generate_Table + Trace_Generate_Minimal_Complete > Outline then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("LALR_Generate");
- end if;
-
- Fill_In_Lookaheads (Grammar, Has_Empty_Production,
First_Terminal_Sequence, Kernels, Descriptor);
-
- if Unused_Tokens then
- WisiToken.Generate.Error := not Ignore_Unused_Tokens;
- Ada.Text_IO.New_Line;
- end if;
-
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("LR(1) Kernels:");
- LR1_Items.Put (Grammar, Descriptor, Kernels, Show_Lookaheads => True);
- end if;
-
- Table := new Parse_Table
- (State_First => Kernels.First_Index,
- State_Last => Kernels.Last_Index,
- First_Terminal => Descriptor.First_Terminal,
- Last_Terminal => Descriptor.Last_Terminal,
- First_Nonterminal => Descriptor.First_Nonterminal,
- Last_Nonterminal => Descriptor.Last_Nonterminal);
-
- if McKenzie_Param = Default_McKenzie_Param then
- -- Descriminants in Default are wrong
- Table.McKenzie_Param :=
- (First_Terminal => Descriptor.First_Terminal,
- Last_Terminal => Descriptor.Last_Terminal,
- First_Nonterminal => Descriptor.First_Nonterminal,
- Last_Nonterminal => Descriptor.Last_Nonterminal,
- Insert => (others => 0),
- Delete => (others => 0),
- Push_Back => (others => 0),
- Undo_Reduce => (others => 0),
- Minimal_Complete_Cost_Delta =>
Default_McKenzie_Param.Minimal_Complete_Cost_Delta,
- Fast_Forward => Default_McKenzie_Param.Fast_Forward,
- Matching_Begin =>
Default_McKenzie_Param.Matching_Begin,
- Ignore_Check_Fail =>
Default_McKenzie_Param.Ignore_Check_Fail,
- Task_Count => Default_McKenzie_Param.Task_Count,
- Check_Limit => Default_McKenzie_Param.Check_Limit,
- Check_Delta_Limit =>
Default_McKenzie_Param.Check_Delta_Limit,
- Enqueue_Limit =>
Default_McKenzie_Param.Enqueue_Limit);
- else
- Table.McKenzie_Param := McKenzie_Param;
- end if;
-
- Add_Actions
- (Kernels, Grammar, Has_Empty_Production, First_Nonterm_Set,
First_Terminal_Sequence, Conflict_Counts,
- Unknown_Conflicts, Table.all, Descriptor);
-
- for State in Table.States'Range loop
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.Put_Line ("Set_Minimal_Complete_Actions:" &
State_Index'Image (State));
- end if;
- WisiToken.Generate.LR.Set_Minimal_Complete_Actions
- (Table.States (State), Kernels (State), Descriptor, Grammar,
Nullable, Minimal_Terminal_Sequences,
- Minimal_Terminal_First);
- end loop;
-
- if Parse_Table_File_Name /= "" then
- WisiToken.Generate.LR.Put_Parse_Table
- (Table, Parse_Table_File_Name, "LALR", Grammar, Recursions,
Kernels, Conflict_Counts, Descriptor,
- Include_Extra);
- end if;
-
- Delete_Known (Unknown_Conflicts, Known_Conflicts_Edit);
-
- if Unknown_Conflicts.Length > 0 then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "unknown
conflicts:");
- Put (Unknown_Conflicts, Ada.Text_IO.Current_Error, Descriptor);
- Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
- WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
- end if;
-
- if Known_Conflicts_Edit.Length > 0 then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "excess known
conflicts:");
- Put (Known_Conflicts_Edit, Ada.Text_IO.Current_Error, Descriptor);
- Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
- WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
- end if;
-
- return Table;
- end Generate;
-
-end WisiToken.Generate.LR.LALR_Generate;
diff --git a/packages/wisi/wisitoken-generate-lr-lalr_generate.ads
b/packages/wisi/wisitoken-generate-lr-lalr_generate.ads
deleted file mode 100644
index 7527a9c..0000000
--- a/packages/wisi/wisitoken-generate-lr-lalr_generate.ads
+++ /dev/null
@@ -1,87 +0,0 @@
--- Abstract :
---
--- Generalized LALR parse table generator.
---
--- Copyright (C) 2002 - 2003, 2009 - 2010, 2013 - 2015, 2017 - 2020 Free
Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Generate.LR1_Items;
-with WisiToken.Productions;
-package WisiToken.Generate.LR.LALR_Generate is
-
- function Generate
- (Grammar : in out WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Known_Conflicts : in Conflict_Lists.List :=
Conflict_Lists.Empty_List;
- McKenzie_Param : in McKenzie_Param_Type :=
Default_McKenzie_Param;
- Parse_Table_File_Name : in String := "";
- Include_Extra : in Boolean := False;
- Ignore_Conflicts : in Boolean := False;
- Partial_Recursion : in Boolean := True)
- return Parse_Table_Ptr
- with Pre =>
- Descriptor.Last_Lookahead = Descriptor.First_Nonterminal and
- Descriptor.First_Nonterminal = Descriptor.Accept_ID;
- -- Generate a generalized LALR parse table for Grammar. The
- -- grammar start symbol is the LHS of the first production in
- -- Grammar.
- --
- -- Unless Ignore_Unused_Tokens is True, raise Grammar_Error if
- -- there are unused tokens.
- --
- -- Unless Ignore_Unknown_Conflicts is True, raise Grammar_Error if there
- -- are unknown conflicts.
-
- ----------
- -- Visible for unit tests
-
- function LALR_Goto_Transitions
- (Kernel : in LR1_Items.Item_Set;
- Symbol : in Token_ID;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set;
- -- Return the Item_Set that is the goto for Symbol from Kernel.
- -- If there is no such Item_Set, Result.Set is null.
-
- function LALR_Kernels
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set_List;
-
- procedure Fill_In_Lookaheads
- (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Kernels : in out LR1_Items.Item_Set_List;
- Descriptor : in WisiToken.Descriptor);
-
- procedure Add_Actions
- (Kernels : in LR1_Items.Item_Set_List;
- Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Conflict_Counts : out Conflict_Count_Lists.List;
- Conflicts : out Conflict_Lists.List;
- Table : in out Parse_Table;
- Descriptor : in WisiToken.Descriptor);
-
-end WisiToken.Generate.LR.LALR_Generate;
diff --git a/packages/wisi/wisitoken-generate-lr-lr1_generate.adb
b/packages/wisi/wisitoken-generate-lr-lr1_generate.adb
deleted file mode 100644
index 8f688c9..0000000
--- a/packages/wisi/wisitoken-generate-lr-lr1_generate.adb
+++ /dev/null
@@ -1,343 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-with Ada.Text_IO;
-with WisiToken.Generate;
-package body WisiToken.Generate.LR.LR1_Generate is
-
- function LR1_Goto_Transitions
- (Set : in LR1_Items.Item_Set;
- Symbol : in Token_ID;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set
- is
- use all type Ada.Containers.Count_Type;
- use Token_ID_Arrays;
- use LR1_Items;
-
- Goto_Set : Item_Set;
- begin
- for Item of Set.Set loop
- if Item.Dot /= No_Index then
- declare
- Dot : constant Token_ID_Arrays.Cursor :=
Productions.Constant_Ref_RHS
- (Grammar, Item.Prod).Tokens.To_Cursor (Item.Dot);
- begin
- if Element (Dot) = Symbol and
- -- We don't need a state with dot after EOI in the
- -- accept production. EOI should only appear in the
- -- accept production.
- Symbol /= Descriptor.EOI_ID
- then
- Goto_Set.Set.Insert
- ((Item.Prod,
- To_Index (Next (Dot)),
- new Token_ID_Set'(Item.Lookaheads.all)));
- end if;
- end;
- end if;
- end loop;
-
- if Goto_Set.Set.Length > 0 then
- return Closure (Goto_Set, Has_Empty_Production,
First_Terminal_Sequence, Grammar, Descriptor);
- else
- return Goto_Set;
- end if;
- end LR1_Goto_Transitions;
-
- function LR1_Item_Sets
- (Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set_List
- is
- use all type Ada.Containers.Count_Type;
-
- -- [dragon] algorithm 4.9 pg 231; figure 4.38 pg 232; procedure
- -- "items", with some optimizations.
-
- use LR1_Items;
-
- First_State_Index : constant State_Index := 0;
-
- C : LR1_Items.Item_Set_List; -- result
- C_Tree : LR1_Items.Item_Set_Trees.Tree; -- for fast find
- States_To_Check : State_Index_Queues.Queue;
- -- [dragon] specifies 'until no more items can be added', but we use
- -- a queue to avoid checking unecessary states. Ada LR1 has over
- -- 100,000 states, so this is a significant gain (reduced time from
- -- 600 seconds to 40).
-
- I : State_Index;
- Dot_IDs : Token_ID_Arrays.Vector;
-
- New_Item_Set : Item_Set := Closure
- ((Set => Item_Lists.To_List
- ((Prod => (Grammar.First_Index, 0),
- Dot => Grammar (Grammar.First_Index).RHSs
(0).Tokens.First_Index,
- Lookaheads => new Token_ID_Set'(To_Lookahead (Descriptor.EOI_ID,
Descriptor)))),
- Goto_List => <>,
- Dot_IDs => <>,
- State => First_State_Index),
- Has_Empty_Production, First_Terminal_Sequence, Grammar, Descriptor);
-
- Found_State : Unknown_State_Index;
-
- begin
- C.Set_First_Last (First_State_Index, First_State_Index - 1);
-
- Add (Grammar, New_Item_Set, C, C_Tree, Descriptor, Include_Lookaheads =>
True);
-
- States_To_Check.Put (First_State_Index);
- loop
- exit when States_To_Check.Is_Empty;
- I := States_To_Check.Get;
-
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.Put ("Checking ");
- Put (Grammar, Descriptor, C (I), Show_Lookaheads => True,
Show_Goto_List => True);
- end if;
-
- Dot_IDs := C (I).Dot_IDs;
- -- We can't iterate on C (I).Dot_IDs when the loop adds items to C;
- -- it might be reallocated to grow.
-
- for Symbol of Dot_IDs loop
- -- [dragon] has 'for each grammar symbol X', but
LR1_Goto_Transitions
- -- rejects Symbol that is not in Dot_IDs, so we iterate over that.
-
- New_Item_Set := LR1_Goto_Transitions
- (C (I), Symbol, Has_Empty_Production, First_Terminal_Sequence,
Grammar, Descriptor);
-
- if New_Item_Set.Set.Length > 0 then -- 'goto (I, X) not empty'
-
- Found_State := Find (New_Item_Set, C_Tree, Match_Lookaheads =>
True); -- 'not in C'
-
- if Found_State = Unknown_State then
- New_Item_Set.State := C.Last_Index + 1;
-
- States_To_Check.Put (New_Item_Set.State);
-
- Add (Grammar, New_Item_Set, C, C_Tree, Descriptor,
Include_Lookaheads => True);
-
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.Put_Line
- (" adding state" & Unknown_State_Index'Image
(C.Last_Index) & ": from state" &
- Unknown_State_Index'Image (I) & " on " & Image
(Symbol, Descriptor));
- Put (Grammar, Descriptor, New_Item_Set, Show_Lookaheads
=> True);
- end if;
-
- C (I).Goto_List.Insert ((Symbol, C.Last_Index));
- else
-
- -- If there's not already a goto entry between these two
sets, create one.
- if not Is_In ((Symbol, Found_State), Goto_List => C
(I).Goto_List) then
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.Put_Line
- (" adding goto on " & Image (Symbol, Descriptor) &
" to state" &
- Unknown_State_Index'Image (Found_State));
-
- end if;
-
- C (I).Goto_List.Insert ((Symbol, Found_State));
- end if;
- end if;
- end if;
- end loop;
- end loop;
-
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.New_Line;
- end if;
-
- return C;
- end LR1_Item_Sets;
-
- procedure Add_Actions
- (Item_Sets : in LR1_Items.Item_Set_List;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflict_Counts : out Conflict_Count_Lists.List;
- Conflicts : out Conflict_Lists.List;
- Table : in out Parse_Table;
- Descriptor : in WisiToken.Descriptor)
- is
- -- Add actions for all Item_Sets to Table.
- begin
- for Item_Set of Item_Sets loop
- Add_Actions
- (Item_Set, Table, Grammar, Has_Empty_Production, First_Nonterm_Set,
Conflict_Counts, Conflicts, Descriptor);
- end loop;
-
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.New_Line;
- end if;
- end Add_Actions;
-
- function Generate
- (Grammar : in out WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Known_Conflicts : in Conflict_Lists.List :=
Conflict_Lists.Empty_List;
- McKenzie_Param : in McKenzie_Param_Type :=
Default_McKenzie_Param;
- Parse_Table_File_Name : in String := "";
- Include_Extra : in Boolean := False;
- Ignore_Conflicts : in Boolean := False;
- Partial_Recursion : in Boolean := True)
- return Parse_Table_Ptr
- is
- use type Ada.Containers.Count_Type;
-
- Ignore_Unused_Tokens : constant Boolean :=
WisiToken.Trace_Generate_Table > Detail;
- Ignore_Unknown_Conflicts : constant Boolean := Ignore_Conflicts or
WisiToken.Trace_Generate_Table > Detail;
- Unused_Tokens : constant Boolean :=
WisiToken.Generate.Check_Unused_Tokens (Descriptor, Grammar);
-
- Table : Parse_Table_Ptr;
-
- Nullable : constant Token_Array_Production_ID :=
WisiToken.Generate.Nullable (Grammar);
- Has_Empty_Production : constant Token_ID_Set :=
WisiToken.Generate.Has_Empty_Production (Nullable);
-
- Recursions : constant WisiToken.Generate.Recursions :=
- (if Partial_Recursion
- then WisiToken.Generate.Compute_Partial_Recursion (Grammar,
Descriptor)
- else WisiToken.Generate.Compute_Full_Recursion (Grammar, Descriptor));
- Minimal_Terminal_Sequences : constant Minimal_Sequence_Array :=
- Compute_Minimal_Terminal_Sequences (Descriptor, Grammar);
-
- Minimal_Terminal_First : constant Token_Array_Token_ID :=
- Compute_Minimal_Terminal_First (Descriptor,
Minimal_Terminal_Sequences);
-
- First_Nonterm_Set : constant Token_Array_Token_Set :=
WisiToken.Generate.First
- (Grammar, Has_Empty_Production, Descriptor.First_Terminal);
-
- First_Terminal_Sequence : constant Token_Sequence_Arrays.Vector :=
- WisiToken.Generate.To_Terminal_Sequence_Array (First_Nonterm_Set,
Descriptor);
-
- Item_Sets : constant LR1_Items.Item_Set_List := LR1_Item_Sets
- (Has_Empty_Production, First_Terminal_Sequence, Grammar, Descriptor);
-
- Conflict_Counts : Conflict_Count_Lists.List;
- Unknown_Conflicts : Conflict_Lists.List;
- Known_Conflicts_Edit : Conflict_Lists.List := Known_Conflicts;
- begin
- if Trace_Generate_Table + Trace_Generate_Minimal_Complete > Outline then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("LR1_Generate:");
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.Put_Line ("Item_Sets:");
- LR1_Items.Put (Grammar, Descriptor, Item_Sets);
- end if;
- end if;
-
- Table := new Parse_Table
- (State_First => Item_Sets.First_Index,
- State_Last => Item_Sets.Last_Index,
- First_Terminal => Descriptor.First_Terminal,
- Last_Terminal => Descriptor.Last_Terminal,
- First_Nonterminal => Descriptor.First_Nonterminal,
- Last_Nonterminal => Descriptor.Last_Nonterminal);
-
- if McKenzie_Param = Default_McKenzie_Param then
- -- Descriminants in Default are wrong
- Table.McKenzie_Param :=
- (First_Terminal => Descriptor.First_Terminal,
- Last_Terminal => Descriptor.Last_Terminal,
- First_Nonterminal => Descriptor.First_Nonterminal,
- Last_Nonterminal => Descriptor.Last_Nonterminal,
- Insert => (others => 0),
- Delete => (others => 0),
- Push_Back => (others => 0),
- Undo_Reduce => (others => 0),
- Minimal_Complete_Cost_Delta =>
Default_McKenzie_Param.Minimal_Complete_Cost_Delta,
- Fast_Forward => Default_McKenzie_Param.Fast_Forward,
- Matching_Begin =>
Default_McKenzie_Param.Matching_Begin,
- Ignore_Check_Fail =>
Default_McKenzie_Param.Ignore_Check_Fail,
- Task_Count => Default_McKenzie_Param.Task_Count,
- Check_Limit => Default_McKenzie_Param.Check_Limit,
- Check_Delta_Limit =>
Default_McKenzie_Param.Check_Delta_Limit,
- Enqueue_Limit =>
Default_McKenzie_Param.Enqueue_Limit);
- else
- Table.McKenzie_Param := McKenzie_Param;
- end if;
-
- Add_Actions
- (Item_Sets, Grammar, Has_Empty_Production, First_Nonterm_Set,
- Conflict_Counts, Unknown_Conflicts, Table.all, Descriptor);
-
- for State in Table.States'Range loop
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.Put_Line ("Set_Minimal_Complete_Actions:" &
State_Index'Image (State));
- end if;
- WisiToken.Generate.LR.Set_Minimal_Complete_Actions
- (Table.States (State),
- LR1_Items.Filter (Item_Sets (State), Grammar, Descriptor,
LR1_Items.In_Kernel'Access),
- Descriptor, Grammar, Nullable, Minimal_Terminal_Sequences,
Minimal_Terminal_First);
- end loop;
-
- if Parse_Table_File_Name /= "" then
- WisiToken.Generate.LR.Put_Parse_Table
- (Table, Parse_Table_File_Name, "LR1", Grammar, Recursions,
Item_Sets, Conflict_Counts, Descriptor,
- Include_Extra);
- end if;
-
- if Trace_Generate_Table > Outline then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("Has_Empty_Production: " & Image
(Has_Empty_Production, Descriptor));
-
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("Minimal_Terminal_First:");
- for ID in Minimal_Terminal_First'Range loop
- Ada.Text_IO.Put_Line
- (Image (ID, Descriptor) & " =>" &
- (if Minimal_Terminal_First (ID) = Invalid_Token_ID
- then ""
- else ' ' & Image (Minimal_Terminal_First (ID), Descriptor)));
- end loop;
- end if;
-
- Delete_Known (Unknown_Conflicts, Known_Conflicts_Edit);
-
- if Unknown_Conflicts.Length > 0 then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "unknown
conflicts:");
- Put (Unknown_Conflicts, Ada.Text_IO.Current_Error, Descriptor);
- Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
- WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
- end if;
-
- if Known_Conflicts_Edit.Length > 0 then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "excess known
conflicts:");
- Put (Known_Conflicts_Edit, Ada.Text_IO.Current_Error, Descriptor);
- Ada.Text_IO.New_Line (Ada.Text_IO.Current_Error);
- WisiToken.Generate.Error := WisiToken.Generate.Error or not
Ignore_Unknown_Conflicts;
- end if;
-
- WisiToken.Generate.Error := WisiToken.Generate.Error or (Unused_Tokens
and not Ignore_Unused_Tokens);
-
- return Table;
- end Generate;
-
-end WisiToken.Generate.LR.LR1_Generate;
diff --git a/packages/wisi/wisitoken-generate-lr-lr1_generate.ads
b/packages/wisi/wisitoken-generate-lr-lr1_generate.ads
deleted file mode 100644
index d0f2d9f..0000000
--- a/packages/wisi/wisitoken-generate-lr-lr1_generate.ads
+++ /dev/null
@@ -1,91 +0,0 @@
--- Abstract :
---
--- LR1 (Left-to-right scanning 1 look-ahead) parser table generator.
---
--- References:
---
--- [dragon] "Compilers Principles, Techniques, and Tools" by Aho,
--- Sethi, and Ullman (aka: "The [Red] Dragon Book").
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Generate.LR1_Items;
-with WisiToken.Productions;
-package WisiToken.Generate.LR.LR1_Generate is
-
- function Generate
- (Grammar : in out WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Known_Conflicts : in Conflict_Lists.List :=
Conflict_Lists.Empty_List;
- McKenzie_Param : in McKenzie_Param_Type :=
Default_McKenzie_Param;
- Parse_Table_File_Name : in String := "";
- Include_Extra : in Boolean := False;
- Ignore_Conflicts : in Boolean := False;
- Partial_Recursion : in Boolean := True)
- return Parse_Table_Ptr
- with Pre => Descriptor.First_Nonterminal = Descriptor.Accept_ID;
- -- Generate a generalized LR1 parse table for Grammar. The
- -- grammar start symbol is the LHS of the first production in
- -- Grammar.
- --
- -- Sets Recursive components in Grammar.
- --
- -- If Trace, output debug info to Standard_Error about generation
- -- process. We don't use WisiToken.Trace here; we often want to
- -- see a trace of the parser execution without the parser
- -- generation.
- --
- -- Unless Ignore_Unused_Tokens is True, raise Grammar_Error if
- -- there are unused tokens.
- --
- -- Unless Ignore_Unknown_Conflicts is True, raise Grammar_Error if there
- -- are unknown conflicts.
-
- ----------
- -- visible for unit test
-
- function LR1_Goto_Transitions
- (Set : in LR1_Items.Item_Set;
- Symbol : in Token_ID;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set;
- -- 'goto' from [dragon] algorithm 4.9
-
- function LR1_Item_Sets
- (Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return LR1_Items.Item_Set_List;
- -- [dragon] algorithm 4.9 pg 231; figure 4.38 pg 232; procedure "items"
-
- procedure Add_Actions
- (Item_Sets : in LR1_Items.Item_Set_List;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflict_Counts : out Conflict_Count_Lists.List;
- Conflicts : out Conflict_Lists.List;
- Table : in out Parse_Table;
- Descriptor : in WisiToken.Descriptor);
-
-end WisiToken.Generate.LR.LR1_Generate;
diff --git a/packages/wisi/wisitoken-generate-lr.adb
b/packages/wisi/wisitoken-generate-lr.adb
deleted file mode 100644
index d66746d..0000000
--- a/packages/wisi/wisitoken-generate-lr.adb
+++ /dev/null
@@ -1,1510 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (GPL);
-
-with Ada.Strings.Fixed;
-with Ada.Text_IO;
-with System.Multiprocessors;
-with WisiToken.Generate;
-package body WisiToken.Generate.LR is
-
- package RHS_Set is new SAL.Gen_Unbounded_Definite_Vectors (Natural,
Boolean, Default_Element => False);
-
- type LHS_RHS_Set is array (Token_ID range <>) of RHS_Set.Vector;
-
- ----------
- -- Body subprograms, alphabetical
-
- function Min
- (Item : in RHS_Sequence_Arrays.Vector;
- RHS_Set : in LR.RHS_Set.Vector)
- return Integer
- is
- use all type Ada.Containers.Count_Type;
- Min_Length : Ada.Containers.Count_Type := Ada.Containers.Count_Type'Last;
- Min_RHS : Natural := Natural'Last;
- begin
- for RHS in Item.First_Index .. Item.Last_Index loop
- if RHS_Set (RHS) and then Min_Length > Item (RHS).Length then
- Min_Length := Item (RHS).Length;
- Min_RHS := RHS;
- end if;
- end loop;
- if Min_RHS = Natural'Last then
- raise SAL.Programmer_Error with "nonterm has no minimum terminal
sequence";
- else
- return Min_RHS;
- end if;
- end Min;
-
- function Image
- (Nonterm : in Token_ID;
- Sequences : in Minimal_Sequence_Array;
- Descriptor : in WisiToken.Descriptor)
- return String
- is begin
- return Trimmed_Image (Nonterm) & " " & Image (Nonterm, Descriptor) & "
==> (" &
- Sequences (Nonterm).Min_RHS'Image & ", " & Image (Sequences
(Nonterm).Sequence, Descriptor) & ")";
- end Image;
-
- procedure Terminal_Sequence
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- All_Sequences : in out Minimal_Sequence_Array;
- All_Seq_Set : in out Token_ID_Set;
- RHS_Seq_Set : in out LHS_RHS_Set;
- Recursing : in out Token_ID_Set;
- Nonterm : in Token_ID)
- is
- use Ada.Containers;
- use Token_ID_Arrays;
-
- subtype Terminals is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
-
- Prod : Productions.Instance renames Grammar (Nonterm);
-
- Skipped_Recursive : Boolean := False;
-
- procedure Init_All_Sequences (LHS : in Token_ID)
- is
- Prod : Productions.Instance renames Grammar (LHS);
- begin
- if All_Sequences (LHS).Sequence.Length = 0 then
- All_Sequences (LHS).Sequence.Set_First_Last
(Prod.RHSs.First_Index, Prod.RHSs.Last_Index);
- end if;
- if RHS_Seq_Set (LHS).Length = 0 then
- RHS_Seq_Set (LHS).Set_First_Last (Prod.RHSs.First_Index,
Prod.RHSs.Last_Index);
- end if;
- end Init_All_Sequences;
-
- begin
- -- We get here because All_Sequences (Nonterm) has not been fully
- -- computed yet (All_Seq_Set (Nonterm) is False). Attempt to
- -- compute All_Sequences (Nonterm); it may not succeed due to
- -- recursion. If successful, set All_Seq_Set (Nonterm).
- --
- -- In a useful grammar, all direct and indirect recursive nonterms
- -- have a non-recursive minimal terminal sequence; finding it will
- -- break the recursion, allowing this algorithm to complete. This is
- -- checked in Compute_Minimal_Terminal_Sequences.
-
- Init_All_Sequences (Nonterm);
-
- for RHS in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
- if not RHS_Seq_Set (Nonterm)(RHS) then
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.Put_Line (Trimmed_Image ((Nonterm, RHS)) & " " &
Image (Nonterm, Descriptor) & " compute");
- end if;
- if Prod.RHSs (RHS).Tokens.Length = 0 then
- RHS_Seq_Set (Nonterm)(RHS) := True;
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.Put_Line (Trimmed_Image (Production_ID'(Nonterm,
RHS)) & " => () empty");
- end if;
-
- else
- for I in Prod.RHSs (RHS).Tokens.First_Index .. Prod.RHSs
(RHS).Tokens.Last_Index loop
- declare
- ID : Token_ID renames Prod.RHSs (RHS).Tokens (I);
- begin
- if ID in Terminals then
- All_Sequences (Nonterm).Sequence (RHS).Append (ID);
-
- else
- if (for some RHS of RHS_Seq_Set (ID) => RHS) then
- -- There is a minimal sequence for ID; use it
- null;
- else
- if ID = Nonterm or Recursing (ID) then
- -- Clear partial minimal sequence; we are
starting over.
- All_Sequences (Nonterm).Sequence (RHS).Clear;
- goto Skip;
-
- else
- Recursing (ID) := True;
- Terminal_Sequence
- (Grammar, Descriptor, All_Sequences,
All_Seq_Set, RHS_Seq_Set, Recursing, ID);
- Recursing (ID) := False;
-
- if All_Seq_Set (ID) or else (for some RHS of
RHS_Seq_Set (ID) => RHS) then
- -- Found a minimal sequence for ID; use it
- null;
- else
- All_Sequences (Nonterm).Sequence (RHS).Clear;
- goto Skip;
- end if;
- end if;
- end if;
- declare
- Min_RHS : constant Integer := Min (All_Sequences
(ID).Sequence, RHS_Seq_Set (ID));
- begin
- All_Sequences (ID).Min_RHS := Min_RHS;
-
- All_Sequences (Nonterm).Sequence (RHS).Append
(All_Sequences (ID).Sequence (Min_RHS));
- end;
- end if;
- end;
- end loop;
- RHS_Seq_Set (Nonterm)(RHS) := True;
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.Put_Line
- (Trimmed_Image (Production_ID'(Nonterm, RHS)) & " => " &
- Image (All_Sequences (Nonterm).Sequence (RHS),
Descriptor));
- end if;
- end if;
- end if;
- <<Skip>>
- Skipped_Recursive := True;
- end loop;
-
- if Skipped_Recursive then
- if (for some RHS of RHS_Seq_Set (Nonterm) => not RHS) then
- -- Some RHSs are have unresolved recursion; we will
- -- eventually try again when the recursion is resolved.
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.Put_Line
- (Trimmed_Image (Nonterm) & " " & Image (Nonterm, Descriptor)
& " skipped some recursive");
- end if;
- return;
- end if;
- end if;
-
- All_Seq_Set (Nonterm) := True;
-
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.Put_Line (Image (Nonterm, All_Sequences, Descriptor));
- end if;
- end Terminal_Sequence;
-
- ----------
- -- Public subprograms, declaration order
-
- procedure Put
- (Item : in Conflict_Lists.List;
- File : in Ada.Text_IO.File_Type;
- Descriptor : in WisiToken.Descriptor)
- is begin
- for Conflict of Item loop
- Ada.Text_IO.Put_Line (File, Image (Conflict, Descriptor));
- end loop;
- end Put;
-
- procedure Add_Action
- (Symbol : in Token_ID;
- Action : in Parse_Action_Rec;
- Action_List : in out Action_Arrays.Vector;
- Closure : in LR1_Items.Item_Set;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflict_Counts : in out Conflict_Count_Lists.List;
- Conflicts : in out Conflict_Lists.List;
- Descriptor : in WisiToken.Descriptor)
- is
- Matching_Action : constant Action_Arrays.Find_Reference_Type :=
Action_List.Find (Symbol);
- begin
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put (Image (Symbol, Descriptor) & " => ");
- Put (Descriptor, Action);
- Ada.Text_IO.New_Line;
- end if;
-
- if Matching_Action.Element /= null then
- if Is_In (Action, Matching_Action.Actions) then
- -- Action is already in the list.
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line (" - already present");
- end if;
- return;
- else
- -- There is a conflict. Report it and add it, so the
- -- generalized parser can follow all paths
- declare
- -- Enforce canonical Shift/Reduce or Accept/Reduce order, to
simplify
- -- searching and code generation. There can be only one Shift
in the
- -- list of conflicting actions, so we keep it the first item
in the
- -- list; no order in the rest of the list.
- Action_A : constant Parse_Action_Rec :=
- (if Action.Verb in Shift | Accept_It then Action else
Matching_Action.Actions.Item);
-
- Action_B : constant Parse_Action_Rec :=
- (if Action.Verb in Shift | Accept_It then
Matching_Action.Actions.Item else Action);
-
- New_Conflict : constant Conflict :=
- (Action_A => Action_A.Verb,
- Action_B => Action_B.Verb,
- LHS_A => Find
- (Closure, Action_A, Symbol, Grammar, Has_Empty_Production,
First_Nonterm_Set, Descriptor),
- LHS_B => Find
- (Closure, Action_B, Symbol, Grammar, Has_Empty_Production,
First_Nonterm_Set, Descriptor),
- State_Index => Closure.State,
- On => Symbol);
-
- Counts : Conflict_Count_Lists.Cursor;
- begin
- for Cur in Conflict_Counts.Iterate loop
- if Conflict_Counts (Cur).State = Closure.State then
- Counts := Cur;
- exit;
- end if;
- end loop;
-
- if not Conflict_Count_Lists.Has_Element (Counts) then
- Conflict_Counts.Append ((Closure.State, others => 0));
- Counts := Conflict_Counts.Last;
- end if;
-
- declare
- use Conflict_Count_Lists;
- Counts_Ref : constant Reference_Type := Reference
(Conflict_Counts, Counts);
- begin
- case Action_A.Verb is
- when Shift =>
- case Action_B.Verb is
- when Shift | Accept_It | WisiToken.Parse.LR.Error =>
- raise SAL.Programmer_Error;
- when Reduce =>
- Counts_Ref.Shift_Reduce := Counts_Ref.Shift_Reduce + 1;
- end case;
- when Reduce =>
- case Action_B.Verb is
- when Shift | Accept_It | WisiToken.Parse.LR.Error =>
- raise SAL.Programmer_Error;
- when Reduce =>
- Counts_Ref.Reduce_Reduce := Counts_Ref.Reduce_Reduce +
1;
- end case;
- when Accept_It =>
- case Action_B.Verb is
- when Shift | Accept_It | WisiToken.Parse.LR.Error =>
- raise SAL.Programmer_Error;
- when Reduce =>
- Counts_Ref.Accept_Reduce := Counts_Ref.Accept_Reduce +
1;
- end case;
- when WisiToken.Parse.LR.Error =>
- raise SAL.Programmer_Error;
- end case;
- end;
-
- if not Is_Present (New_Conflict, Conflicts) then
- -- The same conflict may occur in a different
- -- item set. Only add it to conflicts once.
- Conflicts.Append (New_Conflict);
-
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line (" - conflict added: " & Image
(New_Conflict, Descriptor));
- end if;
- else
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line (" - conflict duplicate: " & Image
(New_Conflict, Descriptor));
- end if;
- end if;
-
- if Action.Verb = Shift then
- Matching_Action.Actions := new Parse_Action_Node'(Action,
Matching_Action.Actions);
- else
- Matching_Action.Actions.Next := new
Parse_Action_Node'(Action, Matching_Action.Actions.Next);
- end if;
- end;
- end if;
- else
- WisiToken.Parse.LR.Add (Action_List, Symbol, Action);
- end if;
- end Add_Action;
-
- procedure Add_Actions
- (Closure : in LR1_Items.Item_Set;
- Table : in out Parse_Table;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflict_Counts : in out Conflict_Count_Lists.List;
- Conflicts : in out Conflict_Lists.List;
- Descriptor : in WisiToken.Descriptor)
- is
- use Token_ID_Arrays;
-
- State : constant State_Index := Closure.State;
- begin
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line ("adding actions for state" & State_Index'Image
(State));
- end if;
-
- for Item of Closure.Set loop
- declare
- Dot : constant Token_ID_Arrays.Cursor :=
Productions.Constant_Ref_RHS
- (Grammar, Item.Prod).Tokens.To_Cursor (Item.Dot);
- begin
- if not Has_Element (Dot) then
- Add_Lookahead_Actions
- (Item, Table.States (State).Action_List, Grammar,
Has_Empty_Production, First_Nonterm_Set,
- Conflict_Counts, Conflicts, Closure, Descriptor);
-
- elsif Element (Dot) in
- Descriptor.First_Terminal .. Descriptor.Last_Terminal
- then
- -- Dot is before a terminal token.
- declare
- use all type Ada.Containers.Count_Type;
-
- P_ID : constant Production_ID := Item.Prod;
-
- Dot_ID : constant Token_ID := Element (Dot);
- -- ID of token after Item.Dot
-
- Goto_State : constant Unknown_State_Index :=
LR1_Items.Goto_State (Closure, Dot_ID);
- begin
- if Dot_ID = Descriptor.EOI_ID then
- -- This is the start symbol production with dot before
EOF.
- declare
- RHS : Productions.Right_Hand_Side renames Grammar
(P_ID.LHS).RHSs (P_ID.RHS);
- begin
- Add_Action
- (Dot_ID,
- (Accept_It, P_ID, RHS.Action, RHS.Check,
RHS.Tokens.Length - 1),
- -- EOF is not pushed on stack in parser, because
the action for EOF
- -- is Accept, not Shift.
- Table.States (State).Action_List, Closure,
- Grammar, Has_Empty_Production, First_Nonterm_Set,
Conflict_Counts, Conflicts, Descriptor);
- end;
- else
- if Goto_State /= Unknown_State then
- Add_Action
- (Dot_ID,
- (Shift, P_ID, Goto_State),
- Table.States (State).Action_List,
- Closure, Grammar, Has_Empty_Production,
First_Nonterm_Set,
- Conflict_Counts, Conflicts, Descriptor);
- end if;
- end if;
- end;
- else
- -- Dot is before a non-terminal token; no action.
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line (Image (Element (Dot), Descriptor) & "
=> no action");
- end if;
- end if;
- end;
- end loop;
-
- -- We don't place a default error action at the end of every state;
- -- Parse.LR.Action_For returns Table.Error_Action when Symbol is not
found.
- Table.Error_Action := new Parse_Action_Node'((Verb =>
WisiToken.Parse.LR.Error, others => <>), null);
-
- for Item of Closure.Goto_List loop
- if Item.Symbol in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal then
- -- FIXME: Goto_List has terminals; either don't need to add
those, or can use that instead of above code.
- Add_Goto (Table.States (State), Item.Symbol, Item.State); -- note
list is already sorted.
- end if;
- end loop;
- end Add_Actions;
-
- procedure Add_Lookahead_Actions
- (Item : in LR1_Items.Item;
- Action_List : in out Action_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflict_Counts : in out Conflict_Count_Lists.List;
- Conflicts : in out Conflict_Lists.List;
- Closure : in LR1_Items.Item_Set;
- Descriptor : in WisiToken.Descriptor)
- is
- Prod : Productions.Instance renames Grammar (Item.Prod.LHS);
- RHS : Productions.Right_Hand_Side renames Prod.RHSs (Item.Prod.RHS);
- Action : constant Parse_Action_Rec := (Reduce, Item.Prod, RHS.Action,
RHS.Check, RHS.Tokens.Length);
- begin
- if Trace_Generate_Table > Detail then
- Ada.Text_IO.Put_Line ("processing lookaheads");
- end if;
-
- -- We ignore propagate lookaheads here.
- for Lookahead in Item.Lookaheads'Range loop
- if Item.Lookaheads (Lookahead) then
- if Lookahead = Descriptor.First_Nonterminal then
- null;
- else
- Add_Action
- (Lookahead, Action, Action_List, Closure, Grammar,
- Has_Empty_Production, First_Nonterm_Set, Conflict_Counts,
Conflicts, Descriptor);
- end if;
- end if;
- end loop;
- end Add_Lookahead_Actions;
-
- procedure Delete_Known
- (Conflicts : in out Conflict_Lists.List;
- Known_Conflicts : in out Conflict_Lists.List)
- is
- -- Delete all elements in Conflicts that match an element in
- -- Known_Conflicts. There can be more than one Conflict that
- -- match one Known_Conflict.
- use Conflict_Lists;
- Known : Cursor := Known_Conflicts.First;
- Next_Known : Cursor;
- begin
- loop
- exit when Known = No_Element;
- Next_Known := Next (Known);
- declare
- I : Cursor := Conflicts.First;
- Next_I : Cursor;
- Used : Boolean := False;
- begin
- loop
- exit when I = No_Element;
- Next_I := Next (I);
- if Match (Element (Known), Conflicts.Constant_Reference (I))
then
- Delete (Conflicts, I);
- Used := True;
- end if;
- I := Next_I;
- end loop;
-
- if Used then
- Delete (Known_Conflicts, Known);
- end if;
- end;
- Known := Next_Known;
- end loop;
- end Delete_Known;
-
- function Find
- (Closure : in LR1_Items.Item_Set;
- Action : in Parse_Action_Rec;
- Lookahead : in Token_ID;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return Token_ID
- is
- use WisiToken.Token_ID_Arrays;
- begin
- case Action.Verb is
- when Reduce | Accept_It =>
- -- If the nonterm produced by the reduce is the LHS of the state
- -- production, use it.
- for Item of Closure.Set loop
- if LR1_Items.In_Kernel (Grammar, Descriptor, Item) and
- Action.Production.LHS = Item.Prod.LHS
- then
- return Item.Prod.LHS;
- end if;
- end loop;
-
- -- The reduce nonterm is after Dot in a state production; find which
- -- one, use that.
- for Item of Closure.Set loop
- if LR1_Items.In_Kernel (Grammar, Descriptor, Item) then
- declare
- Dot : Token_ID_Arrays.Cursor := Productions.Constant_Ref_RHS
- (Grammar, Item.Prod).Tokens.To_Cursor (Item.Dot);
- begin
- loop
- if not Has_Element (Dot) then
- if Item.Lookaheads (Lookahead) then
- return Item.Prod.LHS;
- end if;
- else
- declare
- Dot_ID : constant Token_ID := Element (Dot);
- begin
- if Dot_ID = Lookahead or
- (Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- First (Dot_ID, Lookahead))
- then
- return Item.Prod.LHS;
- end if;
- exit when Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- not Has_Empty_Production (Dot_ID);
- end;
- end if;
-
- exit when not Has_Element (Dot);
- Next (Dot);
- end loop;
- end;
- end if;
- end loop;
-
- when Shift =>
-
- for Item of Closure.Set loop
- -- Lookahead (the token shifted) is starting a nonterm in a state
- -- production; it is in First of that nonterm.
- if LR1_Items.In_Kernel (Grammar, Descriptor, Item) then
- declare
- Dot : Token_ID_Arrays.Cursor := Productions.Constant_Ref_RHS
- (Grammar, Item.Prod).Tokens.To_Cursor (Item.Dot);
- begin
- loop
- exit when not Has_Element (Dot);
- declare
- Dot_ID : constant Token_ID := Element (Dot);
- begin
- if Dot_ID = Lookahead or
- (Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- First (Dot_ID, Lookahead))
- then
- return Item.Prod.LHS;
- end if;
-
- exit when Dot_ID in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal and then
- not Has_Empty_Production (Dot_ID);
- end;
-
- Next (Dot);
- end loop;
- end;
- end if;
- end loop;
-
- when WisiToken.Parse.LR.Error =>
- raise SAL.Programmer_Error;
- end case;
-
- Ada.Text_IO.Put_Line
- ("item for " & Image (Action, Descriptor) & " on " & Image (Lookahead,
Descriptor) & " not found in");
- LR1_Items.Put (Grammar, Descriptor, Closure, Kernel_Only => True);
- raise SAL.Programmer_Error;
- end Find;
-
- function Image (Item : in Conflict; Descriptor : in WisiToken.Descriptor)
return String
- is begin
- return
- ("%conflict " &
- Conflict_Parse_Actions'Image (Item.Action_A) & "/" &
- Conflict_Parse_Actions'Image (Item.Action_B) & " in state " &
- Image (Item.LHS_A, Descriptor) & ", " &
- Image (Item.LHS_B, Descriptor) &
- " on token " & Image (Item.On, Descriptor) &
- " (" & State_Index'Image (Item.State_Index) & ")"); -- state number
last for easier delete
- end Image;
-
- function Is_Present (Item : in Conflict; Conflicts : in
Conflict_Lists.List) return Boolean
- is
- use Conflict_Lists;
- I : Cursor := Conflicts.First;
- begin
- loop
- exit when I = No_Element;
- if Match (Item, Conflicts.Constant_Reference (I)) then
- return True;
- end if;
- I := Next (I);
- end loop;
- return False;
- end Is_Present;
-
- function Match (Known : in Conflict; Item : in
Conflict_Lists.Constant_Reference_Type) return Boolean
- is begin
- -- Ignore State_Index. Actions are in canonical order; enforced
- -- in Add_Action above. For reduce/reduce, LHS_A, LHS_B are not
- -- in canonical order.
- return
- Known.Action_A = Item.Action_A and
- Known.Action_B = Item.Action_B and
- ((Known.LHS_A = Item.LHS_A and Known.LHS_B = Item.LHS_B) or
- (Known.LHS_B = Item.LHS_A and Known.LHS_A = Item.LHS_B)) and
- Known.On = Item.On;
- end Match;
-
- ----------
- -- Minimal terminal sequences.
-
- function Min_Length (Item : in RHS_Sequence_Arrays.Vector) return
Ada.Containers.Count_Type
- is
- use Ada.Containers;
- Min : Count_Type := Count_Type'Last;
- begin
- for RHS of Item loop
- if RHS.Length < Min then
- Min := RHS.Length;
- end if;
- end loop;
- return Min;
- end Min_Length;
-
- function Min (Item : in RHS_Sequence_Arrays.Vector) return
Token_ID_Arrays.Vector
- is
- use all type Ada.Containers.Count_Type;
- Min_Length : Ada.Containers.Count_Type := Ada.Containers.Count_Type'Last;
- Min_RHS : Natural := Natural'Last;
- begin
- -- This version assumes all RHS are computed.
- for RHS in Item.First_Index .. Item.Last_Index loop
- if Min_Length > Item (RHS).Length then
- Min_Length := Item (RHS).Length;
- Min_RHS := RHS;
- end if;
- end loop;
- if Min_RHS = Natural'Last then
- raise Grammar_Error with "nonterm has no minimum terminal sequence";
- else
- return Item (Min_RHS);
- end if;
- end Min;
-
- function Compute_Minimal_Terminal_Sequences
- (Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
- return Minimal_Sequence_Array
- is
- -- Result (ID).Sequence.Length = 0 is a valid result (ie the
- -- nonterminal can be empty), so we use an auxilliary array to track
- -- whether Result (ID) has been computed.
-
- All_Seq_Set : Token_ID_Set := (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal => False);
- Recursing : Token_ID_Set := (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal => False);
-
- RHS_Seq_Set : LHS_RHS_Set :=
- (Descriptor.First_Nonterminal .. Descriptor.Last_Nonterminal =>
RHS_Set.Empty_Vector);
-
- Last_Seq_Count : Integer := 0;
- This_Count : Integer;
- Pass_Count : Integer := 0;
- begin
- return Result : Minimal_Sequence_Array (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal) do
- loop
- exit when (for all B of All_Seq_Set => B);
- Pass_Count := Pass_Count + 1;
- if Trace_Generate_Minimal_Complete > Detail then
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.New_Line;
- end if;
- Ada.Text_IO.Put_Line ("Compute_Minimal_Terminal_Sequences pass"
& Integer'Image (Pass_Count));
- end if;
- for P of Grammar loop
- Terminal_Sequence (Grammar, Descriptor, Result, All_Seq_Set,
RHS_Seq_Set, Recursing, P.LHS);
- end loop;
- This_Count := Count (All_Seq_Set);
- if This_Count = Last_Seq_Count then
- Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, Image
(All_Seq_Set, Descriptor, Inverted => True));
- raise Grammar_Error with "sequences not resolved";
- end if;
- Last_Seq_Count := This_Count;
- end loop;
-
- if Trace_Generate_Minimal_Complete > Detail then
- Ada.Text_IO.Put_Line ("Minimal_Terminal_Sequences:");
- for LHS in Result'Range loop
- Ada.Text_IO.Put_Line (Image (LHS, Result, Descriptor));
- end loop;
- end if;
- end return;
- end Compute_Minimal_Terminal_Sequences;
-
- function Compute_Minimal_Terminal_First
- (Descriptor : in WisiToken.Descriptor;
- Minimal_Terminal_Sequences : in Minimal_Sequence_Array)
- return Token_Array_Token_ID
- is
- use Token_ID_Arrays;
- begin
- return Result : Token_Array_Token_ID (Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal) do
- for ID in Result'Range loop
- declare
- use all type Ada.Containers.Count_Type;
- Min_Seq : Token_ID_Arrays.Vector renames Min
(Minimal_Terminal_Sequences (ID).Sequence);
- begin
- if Min_Seq.Length = 0 then
- Result (ID) := Invalid_Token_ID;
- else
- Result (ID) := Element (Min_Seq.First);
- end if;
- end;
- end loop;
- end return;
- end Compute_Minimal_Terminal_First;
-
- procedure Set_Minimal_Complete_Actions
- (State : in out Parse_State;
- Kernel : in LR1_Items.Item_Set;
- Descriptor : in WisiToken.Descriptor;
- Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
- Nullable : in Token_Array_Production_ID;
- Minimal_Terminal_Sequences : in Minimal_Sequence_Array;
- Minimal_Terminal_First : in Token_Array_Token_ID)
- is
- use all type Ada.Containers.Count_Type;
- use LR1_Items.Item_Lists;
- use Token_ID_Arrays;
-
- subtype Terminals is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
-
- function Find_Action (List : in Action_Arrays.Vector; ID : in Token_ID)
return Minimal_Action
- is begin
- -- ID is a terminal after Dot in an item in a kernel that has List as
- -- the actions; return the appropriate action.
- for Node of List loop
- if Node.Symbol = ID then
- case Node.Actions.Item.Verb is
- when Shift =>
- return (Shift, Node.Actions.Item.Production, ID,
Node.Actions.Item.State);
- when Reduce =>
- -- Item.Dot is a nonterm that starts with a nullable
nonterm; reduce
- -- to that first. After any more such reductions, the
action will be
- -- Shift ID.
- return (Reduce, Node.Actions.Item.Production, 0);
- when Accept_It | WisiToken.Parse.LR.Error =>
- raise SAL.Programmer_Error;
- end case;
- end if;
- end loop;
- raise SAL.Programmer_Error;
- end Find_Action;
-
- function Compute_Action (ID : in Token_ID) return Minimal_Action
- is begin
- if ID in Terminals then
- return Find_Action (State.Action_List, ID);
-
- else
- if Minimal_Terminal_First (ID) = Invalid_Token_ID then
- -- Item.Dot is a nullable nonterm; include a reduce to the null
- -- nonterm, rather than a shift of the following terminal;
recover
- -- must do the reduce first.
- return (Reduce, (ID, Minimal_Terminal_Sequences (ID).Min_RHS),
Token_Count => 0);
-
- else
- return Find_Action (State.Action_List, Minimal_Terminal_First
(ID));
- end if;
- end if;
- end Compute_Action;
-
- function Length_After_Dot (Item : in LR1_Items.Item) return
Ada.Containers.Count_Type
- is
- use Ada.Containers;
- Prod : constant Production_ID := Item.Prod;
- Result : Count_Type := 0;
- Tokens : Vector renames Grammar (Prod.LHS).RHSs (Prod.RHS).Tokens;
- I : Token_ID_Arrays.Cursor := Tokens.To_Cursor (Item.Dot);
- begin
- if not Has_Element (I) then
- -- Can only compute this at runtime.
- return 0;
- end if;
-
- loop
- exit when not Has_Element (I);
-
- if Element (I) in Terminals then
- Result := Result + 1;
- else
- Result := Result + Min_Length (Minimal_Terminal_Sequences
(Tokens (I)).Sequence);
- end if;
- Next (I);
- end loop;
- return Result;
- end Length_After_Dot;
-
- begin
- if Kernel.State = 0 then
- -- State 0 has dot before all tokens, which is never needed in the
- -- Minimal_Complete_Action algorithm.
- return;
-
- elsif (for some Item of Kernel.Set =>
- Item.Prod.LHS = Descriptor.Accept_ID and
- (Item.Dot /= No_Index and then Productions.Constant_Ref_RHS
- (Grammar, Item.Prod).Tokens (Item.Dot) = Descriptor.EOI_ID))
- then
- -- No actions
- return;
- end if;
-
- -- Set State.Kernel, and delete Items from Working_Set that are known
- -- to be non-minimal.
- declare
- use Ada.Containers;
-
- function Before_Dot (Item : in LR1_Items.Item) return Token_ID
- is
- Tokens : Token_ID_Arrays.Vector renames Grammar
(Item.Prod.LHS).RHSs (Item.Prod.RHS).Tokens;
- begin
- if Item.Dot = Token_ID_Arrays.No_Index then
- return Tokens (Tokens.Last_Index);
- else
- return Tokens (Item.Dot - 1);
- end if;
- end Before_Dot;
-
- type State_Label is (Unknown, Keep_Always, Keep_If_Minimal, Drop);
- type Item_State (Label : State_Label := Unknown)
- is record
- case Label is
- when Keep_Always | Keep_If_Minimal =>
- Minimal_Action : WisiToken.Parse.LR.Minimal_Action;
- -- Minimal_Action.Production = Invalid_Production_ID (the
default) if it is unknown.
- when Unknown | Drop =>
- null;
- end case;
- end record;
-
- subtype Kernel_Index is Count_Type range 1 .. Kernel.Set.Length;
- Item_States : array (Kernel_Index) of Item_State;
- I : Kernel_Index := Kernel_Index'First;
- Min_Length : Count_Type := Count_Type'Last;
- begin
- State.Kernel.Set_First_Last (Kernel_Index'First, Kernel_Index'Last);
- for Item of Kernel.Set loop
- declare
- RHS : WisiToken.Productions.Right_Hand_Side renames
- Grammar (Item.Prod.LHS).RHSs (Item.Prod.RHS);
- Dot_ID : constant Token_ID :=
- (if Item.Dot = No_Index
- then Invalid_Token_ID
- else RHS.Tokens (Item.Dot));
-
- -- Kernel components
- Length_After_Dot : constant Count_Type :=
Set_Minimal_Complete_Actions.Length_After_Dot (Item);
- Reduce_Production : constant Production_ID :=
- (if Length_After_Dot = 0
- then (if Dot_ID in Nullable'Range then Nullable (Dot_ID)
else Item.Prod)
- else Invalid_Production_ID);
- Reduce_Count : constant Count_Type :=
- (if Reduce_Production = Invalid_Production_ID
- then 0
- else Grammar (Reduce_Production.LHS).RHSs
(Reduce_Production.RHS).Tokens.Length);
- begin
- -- Here we must compute Item_State (I).Label and
.Minimal_Action,
- -- considering recursion.
- --
- -- Insert_Minimal_Complete_Actions does not need any recursion
- -- information at runtim, because we elminate all cases where
it
- -- might here.
- --
- -- The strategy in Insert_Minimal_Complete_Actions when
- -- Item.Length_After_Dot = 0 is to compute Length_After_Dot by
doing
- -- Reduce until a Shift is encountered, and using
Length_After_Dot
- -- for that item. --
- --
- -- Consider these kernel items with possible recursion (from
- -- ada_lite_lalr.parse_table - not listed in state order here,
to
- -- group related productions). The recursion of each
production is
- -- shown after ';', if not all None.
- --
- -- State 2:
- -- 86.0:exit_statement <= EXIT ^ identifier_opt WHEN
expression_opt SEMICOLON
- -- 86.1:exit_statement <= EXIT ^ identifier_opt SEMICOLON
- --
- -- State 43:
- -- 103.2:name <= IDENTIFIER ^
- --
- -- State 30:
- -- 103.3:name <= selected_component ^ ; ( 1 => Other_Left)
- --
- -- State 47:
- -- 103.0:name <= name ^ LEFT_PAREN range_list RIGHT_PAREN
; ( 1 => Direct_Left, 3 => Other)
- -- 103.1:name <= name ^ actual_parameter_part ; ( 1 =>
Direct_Left, 2 => Other)
- -- 113.2:primary <= name ^ ; ( 1 => Other_Left)
- -- 124.0:selected_component <= name ^ DOT IDENTIFIER ; ( 1
=> Other_Left)
- --
- -- State 68:
- -- 95.1:generic_instantiation <= PROCEDURE name ^ IS NEW
name SEMICOLON
- -- 103.0:name <= name ^ LEFT_PAREN range_list RIGHT_PAREN
; ( 1 => Direct_Left, 3 => Other)
- -- 103.1:name <= name ^ actual_parameter_part ; ( 1 =>
Direct_Left, 2 => Other)
- -- 115.0:procedure_specification <= PROCEDURE name ^
parameter_profile_opt
- -- 124.0:selected_component <= name ^ DOT IDENTIFIER ; ( 1
=> Other_Left)
- --
- -- State 50:
- -- 87.1:expression <= relation_and_list ^ ; ( 1 =>
Other_Left)
- -- 119.0:relation_and_list <= relation_and_list ^ AND
relation ; ( 1 => Direct_Left, 3 => Other)
- --
- --
- -- State 77:
- -- 57.0:actual_parameter_part <= LEFT_PAREN ^
association_list RIGHT_PAREN ; ( 2 => Other)
- -- 103.0:name <= name LEFT_PAREN ^ range_list RIGHT_PAREN
; ( 1 => Direct_Left, 3 => Other)
- --
- -- State 154:
- -- 103.0:name <= name LEFT_PAREN range_list ^ RIGHT_PAREN
- -- 118.0:range_list <= range_list ^ COMMA range_g
- --
- -- State 251:
- -- 110.0:parameter_specification <= IDENTIFIER COLON
IDENTIFIER ^ COLON_EQUAL expression_opt
- -- 110.1:parameter_specification <= IDENTIFIER COLON
IDENTIFIER ^
- --
- -- From java_enum_ch19_lr1.parse_table:
- --
- -- State 8:
- -- 9.1:EnumConstantList <= EnumConstantList COMMA ^
EnumConstant ; (1 => Direct_Left, 3 => Other)
- -- 11.0:EnumBody <= LEFT_CURLY_BRACKET EnumConstantList
COMMA ^ RIGHT_CURLY_BRACKET
- --
- -- From empty_production_2_lalar.parse_table:
- --
- -- State 5:
- -- 8.0:declarations <= declarations ^ declaration
- -- 9.0:body <= IS declarations ^ BEGIN SEMICOLON
-
- -- case 0: In states 43 and 30, there is only one possible
action, so
- -- recursion is not considered. Minimal_Action is
- -- computed by Compute_Minimal_Action, Label is Keep_Always.
- --
- -- In the following, we only consider kernels where there is
more
- -- than one item.
- --
- -- case 1: In state 47 production 113.2, Length_After_Dot is
0, so
- -- recursion is not considered. We set Label to Keep_Always,
since
- -- the true Length_After_Dot must be computed at runtime.
- -- Minimal_Action is Reduce_Production.
- --
- -- Similarly in state 68 production 115.0, Length_After_Dot is 0
- -- because parameter_profile_opt is nullable, and we set Label
to
- -- Keep_Always, Minimal_Action to Reduce_Production.
- --
- -- case 2: In state 47, if LEFT_PAREN or First
- -- (actual_parameter_part) is inserted, a recursion cycle is
followed
- -- via 103.0 or 103.1; these have Direct_Left recursion, can
never be
- -- minimal, and we set Label to Drop. 113.2 breaks the
recursion; it
- -- has Length_After_Dot = 0 and is covered by case 1. 124.0 has
- -- Other_Left; since Length_After_Dot is > 0, it follows the
- -- recursion cycle and is never minimal, so it is the same as
- -- Direct_Left. Similarly, in java_enum_ch19_lr1.parse_table
state 8
- -- production 9.1, inserting EnumConstant continues the
recursion
- -- cycle; left recursion applies even when it is not just
before the
- -- parse point. On the other hand, in ada_lite state 154, both
- -- productions are left recursive; 103.0 could be preserved.
In the
- -- current algorithm, both are dropped.
- --
- -- It is possible for both case 1 and case 2 to apply; see
- -- empty_production_2_lalar.parse_table State 5 above and
- -- ada_lite_ebnf_lalr.parse_table state 46. case 1 has
precedence if
- -- Dot = No_Element.
- --
- -- case 3: In state 251, there is no recursion, and
Length_After_Dot
- -- is correct; Label is set to Keep_If_Minimal, Minimal_Action
to
- -- Compute_Minimal_Action. In State 77, Dot_ID is
association_list
- -- which has Other recursion; we say "there is recursion at
the parse
- -- point". However, Length_After_Dot is correct; it assumes the
- -- recursion-breaking case for the expansion of
association_list. So
- -- this is the same as no recursion at the parse point
- --
- -- It is possible for both case 2 and 3 to be true; see
- -- empty_production_2_lalr.parse_table state 5. Case 2 has
- -- precedence (left recursion is worse).
-
- if Item_States'Length = 1 then
- -- case 0
- Item_States (I) :=
- (Keep_Always,
- (if Length_After_Dot = 0
- then (Reduce, Reduce_Production, Reduce_Count)
- else Compute_Action (Dot_ID)));
-
- elsif Length_After_Dot = 0 then
- if Item.Dot /= No_Index and RHS.Recursion (1) in Direct_Left
| Other_Left then
- -- case 2
- Item_States (I) := (Label => Drop);
- else
- -- case 1
- Item_States (I) :=
- (Label => Keep_Always,
- Minimal_Action => (Reduce, Reduce_Production,
Reduce_Count));
- end if;
-
- elsif RHS.Recursion (1) in Direct_Left | Other_Left then
- -- case 2
- Item_States (I) := (Label => Drop);
-
- else
- -- case 3
- Item_States (I) := (Keep_If_Minimal, Compute_Action
(Dot_ID));
- end if;
-
- State.Kernel (I) :=
- (Production => Item.Prod,
- Before_Dot => Before_Dot (Item),
- Length_After_Dot => Length_After_Dot,
- Reduce_Production => Reduce_Production,
- Reduce_Count => Reduce_Count);
-
- if Item_States (I).Label = Keep_If_Minimal then
- if Length_After_Dot < Min_Length then
- Min_Length := Length_After_Dot;
- end if;
- end if;
-
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.Put_Line
- ("kernel" & I'Image & " " & Strict_Image (State.Kernel
(I)) &
- " ; " & Item_States (I).Label'Image &
- " " & State.Kernel (I).Length_After_Dot'Image);
- end if;
-
- if I < Kernel_Index'Last then
- I := I + 1;
- end if;
- end;
- end loop;
-
- -- It is tempting to Assert that if all items are dropped, there is a
- -- grammar recursion cycle with no exit. But that is not true; see
- -- java_expressions_ch19_lr1.parse_table, state 8. However, that
- -- state should never be encountered during Insert_Minimal_Complete,
- -- because it is never minimal. So we set Minimal_Actions to empty.
-
- -- Update State_Items based on Min_Length
- for I in Item_States'Range loop
-
- case Item_States (I).Label is
- when Unknown =>
- null;
-
- when Keep_Always =>
- pragma Assert (Item_States (I).Minimal_Action.Production /=
Invalid_Production_ID);
-
- when Keep_If_Minimal =>
- if State.Kernel (I).Length_After_Dot = Min_Length then
- null;
- else
- Item_States (I) := (Label => Drop);
- end if;
-
- when Drop =>
- null;
- end case;
- end loop;
-
- -- Set State.Minimal_Actions
- for Item_State of Item_States loop
- case Item_State.Label is
- when Unknown | Drop =>
- null;
-
- when Keep_Always | Keep_If_Minimal =>
- if (for some A of State.Minimal_Complete_Actions => A =
Item_State.Minimal_Action) then
- -- Duplicate action; see
three_action_conflict_lalr.parse_table state
- -- 3 or lalr_generator_bug_01_lalr.parse_table state 28
- null;
- else
- pragma Assert (Item_State.Minimal_Action.Production /=
Invalid_Production_ID);
- State.Minimal_Complete_Actions.Append
(Item_State.Minimal_Action);
- end if;
- end case;
- end loop;
-
- if Trace_Generate_Minimal_Complete > Extra then
- Ada.Text_IO.Put_Line (Image (State.Minimal_Complete_Actions,
Descriptor));
- end if;
- end;
- end Set_Minimal_Complete_Actions;
-
- ----------
- -- Parse table output
-
- procedure Put_Text_Rep
- (Table : in Parse_Table;
- File_Name : in String;
- Action_Names : in Names_Array_Array;
- Check_Names : in Names_Array_Array)
- is
- use all type SAL.Base_Peek_Type;
- use Ada.Containers;
- use Ada.Text_IO;
- File : File_Type;
- begin
- -- Only space, semicolon, newline delimit object values. Bounds of
- -- arrays output before each array, unless known from discriminants.
- -- End of lists indicated by semicolon. Action, Check subprograms are
- -- represented by True if present, False if not.
-
- Create (File, Out_File, File_Name);
-
- -- First the discriminants
- Put (File,
- Trimmed_Image (Table.State_First) & State_Index'Image
(Table.State_Last) &
- Token_ID'Image (Table.First_Terminal) & Token_ID'Image
(Table.Last_Terminal) &
- Token_ID'Image (Table.First_Nonterminal) & Token_ID'Image
(Table.Last_Nonterminal));
- New_Line (File);
-
- for State of Table.States loop
- Put (File, Trimmed_Image (State.Action_List.Length) & ' ');
- for I in State.Action_List.First_Index ..
State.Action_List.Last_Index loop
- -- Action first, for historical reasons
- declare
- Node_I : Action_Node renames State.Action_List (I);
- Node_J : Parse_Action_Node_Ptr := Node_I.Actions;
- begin
- loop
- Put (File, Node_J.Item.Verb'Image);
- Put (File, Node_J.Item.Production.LHS'Image &
Node_J.Item.Production.RHS'Image);
-
- case Node_J.Item.Verb is
- when Shift =>
- Put (File, State_Index'Image (Node_J.Item.State));
-
- when Reduce | Accept_It =>
- if Action_Names (Node_J.Item.Production.LHS) /= null and
then
- Action_Names
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS) /= null
- then
- Put (File, " true");
- else
- Put (File, " false");
- end if;
- if Check_Names (Node_J.Item.Production.LHS) /= null and
then
- Check_Names
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS) /= null
- then
- Put (File, " true");
- else
- Put (File, " false");
- end if;
-
- Put (File, Ada.Containers.Count_Type'Image
(Node_J.Item.Token_Count));
-
- when Parse.LR.Error =>
- raise SAL.Programmer_Error;
- end case;
-
- Node_J := Node_J.Next;
- exit when Node_J = null;
- Put (File, ' ');
- end loop;
- Put (File, ';');
- Put (File, Token_ID'Image (Node_I.Symbol));
- end;
- if I = State.Action_List.Last_Index then
- Put_Line (File, ";");
- else
- New_Line (File);
- end if;
- end loop;
-
- if State.Goto_List.Length > 0 then
- Put (File, Trimmed_Image (State.Goto_List.Length));
- for Node of State.Goto_List loop
- Put (File, Node.Symbol'Image & Node.State'Image);
- end loop;
- end if;
- Put (File, ';');
- New_Line (File);
-
- if State.Kernel.Length = 0 then
- -- Kernel not set for state 0
- Put_Line (File, "0 -1");
-
- else
- Put (File, Count_Type'Image (State.Kernel.First_Index));
- Put (File, Count_Type'Image (State.Kernel.Last_Index));
- for Item of State.Kernel loop
- Put (File, Token_ID'Image (Item.Production.LHS) &
Item.Production.RHS'Image);
- Put (File, Item.Before_Dot'Image);
- Put (File, Count_Type'Image (Item.Length_After_Dot));
- Put (File, Token_ID'Image (Item.Reduce_Production.LHS) &
Item.Reduce_Production.RHS'Image);
- Put (File, Item.Reduce_Count'Image);
- end loop;
- New_Line (File);
- end if;
-
- if State.Minimal_Complete_Actions.Length = 0 then
- null;
- else
- Put (File, Count_Type'Image
(State.Minimal_Complete_Actions.First_Index));
- Put (File, Count_Type'Image
(State.Minimal_Complete_Actions.Last_Index));
- for Action of State.Minimal_Complete_Actions loop
- Put (File, " ");
- Put (File, Action.Verb'Image);
- Put (File, Action.Production.LHS'Image &
Action.Production.RHS'Image);
- case Action.Verb is
- when Shift =>
- Put (File, Token_ID'Image (Action.ID) & State_Index'Image
(Action.State));
- when Reduce =>
- Put (File, Action.Token_Count'Image);
- end case;
- end loop;
- end if;
- Put_Line (File, ";");
- end loop;
- Close (File);
- end Put_Text_Rep;
-
- procedure Put (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor)
- is
- use Ada.Containers;
- use Ada.Text_IO;
- begin
- case Item.Verb is
- when Shift =>
- Put ("shift and goto state" & State_Index'Image (Item.State));
-
- when Reduce =>
- Put
- ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
- Image (Item.Production.LHS, Descriptor));
- when Accept_It =>
- Put ("accept it");
- when Parse.LR.Error =>
- Put ("ERROR");
- end case;
- end Put;
-
- procedure Put (Item : in McKenzie_Param_Type; Descriptor : in
WisiToken.Descriptor)
- is
- use Ada.Text_IO;
- begin
- Put_Line ("(Insert =>");
- for I in Item.Insert'Range loop
- Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Insert (I)));
- if I = Item.Insert'Last then
- Put_Line (")");
- else
- Put_Line (",");
- end if;
- end loop;
- Put_Line ("(Delete =>");
- for I in Item.Delete'Range loop
- Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Delete (I)));
- if I = Item.Delete'Last then
- Put_Line (")");
- else
- Put_Line (",");
- end if;
- end loop;
- Put_Line ("(Push_Back =>");
- for I in Item.Push_Back'Range loop
- Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Push_Back (I)));
- if I = Item.Push_Back'Last then
- Put_Line (")");
- else
- Put_Line (",");
- end if;
- end loop;
- Put_Line ("(Undo_Reduce =>");
- for I in Item.Undo_Reduce'Range loop
- Put (" " & Padded_Image (I, Descriptor) & " =>" & Natural'Image
(Item.Undo_Reduce (I)));
- if I = Item.Undo_Reduce'Last then
- Put_Line (")");
- else
- Put_Line (",");
- end if;
- end loop;
- Put_Line ("Minimal_Complete_Cost_Delta => " & Integer'Image
(Item.Minimal_Complete_Cost_Delta));
- Put_Line ("Fast_Forward => " & Integer'Image (Item.Fast_Forward));
- Put_Line ("Matching_Begin => " & Integer'Image (Item.Matching_Begin));
- Put_Line ("Ignore_Check_Fail =>" & Integer'Image
(Item.Ignore_Check_Fail));
- Put_Line ("Task_Count =>" &
System.Multiprocessors.CPU_Range'Image (Item.Task_Count));
- Put_Line ("Check_Limit =>" & Token_Index'Image (Item.Check_Limit));
- Put_Line ("Check_Delta_Limit =>" & Integer'Image
(Item.Check_Delta_Limit));
- Put_Line ("Enqueue_Limit =>" & Integer'Image (Item.Enqueue_Limit));
- end Put;
-
- procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Parse_Action_Rec)
- is
- use Ada.Containers;
- use Ada.Text_IO;
- begin
- case Item.Verb is
- when Shift =>
- Put ("shift and goto state" & State_Index'Image (Item.State));
- Put (" " & Trimmed_Image (Item.Production));
-
- when Reduce =>
- Put
- ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
- Image (Item.Production.LHS, Descriptor));
- Put (" " & Trimmed_Image (Item.Production));
-
- when Accept_It =>
- Put ("accept it");
- Put (" " & Trimmed_Image (Item.Production));
-
- when Parse.LR.Error =>
- Put ("ERROR");
- end case;
- end Put;
-
- procedure Put (Descriptor : in WisiToken.Descriptor; Action : in
Parse_Action_Node_Ptr)
- is
- use Ada.Text_IO;
- Ptr : Parse_Action_Node_Ptr := Action;
- Column : constant Positive_Count := Col;
- begin
- loop
- Put (Descriptor, Ptr.Item);
- Ptr := Ptr.Next;
- exit when Ptr = null;
- Put_Line (",");
- Set_Col (Column);
- end loop;
- end Put;
-
- procedure Put (Descriptor : in WisiToken.Descriptor; State : in Parse_State)
- is
- use all type Ada.Containers.Count_Type;
- use Ada.Text_IO;
- use Ada.Strings.Fixed;
- begin
- for Action of State.Action_List loop
- Put (" " & Image (Action.Symbol, Descriptor) &
- (Descriptor.Image_Width - Image (Action.Symbol,
Descriptor)'Length) * ' '
- & " => ");
- Put (Descriptor, Action.Actions);
- New_Line;
- end loop;
-
- -- The error line is redundant, but we keep it to match existing good
parse tables.
- Put_Line (" default" & (Descriptor.Image_Width - 7) * ' ' & " =>
ERROR");
-
- if State.Goto_List.Length > 0 then
- New_Line;
- end if;
-
- for Item of State.Goto_List loop
- Put_Line
- (" " & Image (Item.Symbol, Descriptor) &
- (Descriptor.Image_Width - Image (Item.Symbol,
Descriptor)'Length) * ' ' &
- " goto state" & Item.State'Image);
- end loop;
-
- New_Line;
- Put (" Minimal_Complete_Action => "); -- No trailing 's' for
compatibility with previous good parse tables.
- case State.Minimal_Complete_Actions.Length is
- when 0 =>
- null;
- when 1 =>
- -- No () here for compatibity with previous known good parse tables.
- declare
- Action : Minimal_Action renames State.Minimal_Complete_Actions
(State.Minimal_Complete_Actions.First_Index);
- begin
- case Action.Verb is
- when Shift =>
- Put (Image (Action.ID, Descriptor));
- when Reduce =>
- Put (Image (Action.Production.LHS, Descriptor));
- end case;
- Put (" " & Trimmed_Image (Action.Production));
- end;
- when others =>
- Put ("(");
- for I in State.Minimal_Complete_Actions.First_Index ..
State.Minimal_Complete_Actions.Last_Index loop
- declare
- Action : Minimal_Action renames State.Minimal_Complete_Actions
(I);
- begin
- case Action.Verb is
- when Shift =>
- Put (Image (Action.ID, Descriptor));
- when Reduce =>
- Put (Image (Action.Production.LHS, Descriptor));
- end case;
- Put (" " & Trimmed_Image (Action.Production));
- end;
- if I < State.Minimal_Complete_Actions.Last_Index then
- Put (", ");
- end if;
- end loop;
- Put (")");
- end case;
- New_Line;
- end Put;
-
- procedure Put_Parse_Table
- (Table : in Parse_Table_Ptr;
- Parse_Table_File_Name : in String;
- Title : in String;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Recursions : in Generate.Recursions;
- Kernels : in LR1_Items.Item_Set_List;
- Conflicts : in Conflict_Count_Lists.List;
- Descriptor : in WisiToken.Descriptor;
- Include_Extra : in Boolean := False)
- is
- use all type Ada.Containers.Count_Type;
- use Ada.Text_IO;
- Parse_Table_File : File_Type;
- begin
- Create (Parse_Table_File, Out_File, Parse_Table_File_Name);
- Set_Output (Parse_Table_File);
- Put_Line ("Tokens:");
- WisiToken.Put_Tokens (Descriptor);
-
- New_Line;
- Put_Line ("Productions:");
- WisiToken.Productions.Put (Grammar, Descriptor);
-
- if Include_Extra then
- New_Line;
- Put_Line ((if Recursions.Full then "Recursions:" else "Partial
recursions:"));
- for I in Recursions.Recursions.First_Index ..
Recursions.Recursions.Last_Index loop
- Put_Line (Trimmed_Image (I) & " => " & Grammar_Graphs.Image
(Recursions.Recursions (I)));
- end loop;
- end if;
-
- if Table.McKenzie_Param.Check_Limit /=
Default_McKenzie_Param.Check_Limit or
- Table.McKenzie_Param.Check_Delta_Limit /=
Default_McKenzie_Param.Check_Delta_Limit or
- Table.McKenzie_Param.Enqueue_Limit /=
Default_McKenzie_Param.Enqueue_Limit
- then
- New_Line;
- Put_Line ("McKenzie:");
- Put (Table.McKenzie_Param, Descriptor);
- end if;
-
- New_Line;
- Put_Line (Title & " Parse Table:");
-
- for State_Index in Table.States'Range loop
- Put_Line ("State" & Unknown_State_Index'Image (State_Index) & ":");
-
- declare
- use WisiToken.Generate.LR1_Items;
- begin
- for Item of Kernels (State_Index).Set loop
- if In_Kernel (Grammar, Descriptor, Item) then
- Put (" " & Image (Grammar, Descriptor, Item,
Show_Lookaheads => False));
- New_Line;
- end if;
- end loop;
- end;
- New_Line;
- Put (Descriptor, Table.States (State_Index));
-
- if State_Index /= Table.States'Last then
- New_Line;
- end if;
- end loop;
-
- if Conflicts.Length > 0 then
- declare
- use Ada.Strings.Unbounded;
- Line : Unbounded_String := +"States with conflicts:";
- Accept_Reduce : Integer := 0;
- Shift_Reduce : Integer := 0;
- Reduce_Reduce : Integer := 0;
- begin
- for Count of Conflicts loop
- Line := Line & State_Index'Image (Count.State);
- Accept_Reduce := Accept_Reduce + Count.Accept_Reduce;
- Shift_Reduce := Shift_Reduce + Count.Shift_Reduce;
- Reduce_Reduce := Reduce_Reduce + Count.Reduce_Reduce;
- end loop;
-
- New_Line;
- Indent_Wrap (-Line);
-
- New_Line;
- Put_Line
- (Integer'Image (Accept_Reduce) & " accept/reduce conflicts," &
- Integer'Image (Shift_Reduce) & " shift/reduce conflicts," &
- Integer'Image (Reduce_Reduce) & " reduce/reduce conflicts");
- end;
- else
- New_Line;
- Put_Line (" 0 accept/reduce conflicts, 0 shift/reduce conflicts, 0
reduce/reduce conflicts");
- end if;
- Set_Output (Standard_Output);
- Close (Parse_Table_File);
- end Put_Parse_Table;
-
-end WisiToken.Generate.LR;
diff --git a/packages/wisi/wisitoken-generate-lr.ads
b/packages/wisi/wisitoken-generate-lr.ads
deleted file mode 100644
index 00257fe..0000000
--- a/packages/wisi/wisitoken-generate-lr.ads
+++ /dev/null
@@ -1,214 +0,0 @@
--- Abstract :
---
--- Common utilities for LR parser table generators.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers.Doubly_Linked_Lists;
-with WisiToken.Generate.LR1_Items;
-with WisiToken.Parse.LR;
-with WisiToken.Productions;
-package WisiToken.Generate.LR is
- use WisiToken.Parse.LR;
-
- subtype Conflict_Parse_Actions is Parse_Action_Verbs range Shift ..
Accept_It;
- type Conflict is record
- -- A typical conflict is:
- --
- -- SHIFT/REDUCE in state: 11 on token IS
- --
- -- State numbers change with minor changes in the grammar, so we
- -- attempt to identify the state by the LHS of the two productions
- -- involved; this is _not_ guarranteed to be unique, but is good
- -- enough for our purposes. We also store the state number for
- -- generated conflicts (not for known conflicts from the grammar
- -- definition file), for debugging.
- Action_A : Conflict_Parse_Actions;
- LHS_A : Token_ID;
- Action_B : Conflict_Parse_Actions;
- LHS_B : Token_ID;
- State_Index : Unknown_State_Index;
- On : Token_ID;
- end record;
-
- package Conflict_Lists is new Ada.Containers.Doubly_Linked_Lists (Conflict);
-
- type Conflict_Count is record
- State : State_Index;
- Accept_Reduce : Integer := 0;
- Shift_Reduce : Integer := 0;
- Reduce_Reduce : Integer := 0;
- end record;
-
- package Conflict_Count_Lists is new Ada.Containers.Doubly_Linked_Lists
(Conflict_Count);
-
- procedure Put
- (Item : in Conflict_Lists.List;
- File : in Ada.Text_IO.File_Type;
- Descriptor : in WisiToken.Descriptor);
-
- procedure Add_Action
- (Symbol : in Token_ID;
- Action : in Parse_Action_Rec;
- Action_List : in out Action_Arrays.Vector;
- Closure : in LR1_Items.Item_Set;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflict_Counts : in out Conflict_Count_Lists.List;
- Conflicts : in out Conflict_Lists.List;
- Descriptor : in WisiToken.Descriptor);
- -- Add (Symbol, Action) to Action_List; check for conflicts
- --
- -- Closure .. Conflicts are for conflict reporting
-
- procedure Add_Actions
- (Closure : in LR1_Items.Item_Set;
- Table : in out Parse_Table;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflict_Counts : in out Conflict_Count_Lists.List;
- Conflicts : in out Conflict_Lists.List;
- Descriptor : in WisiToken.Descriptor);
- -- Add actions for Closure to Table. Has_Empty_Production, First,
- -- Conflicts used for conflict reporting.
-
- procedure Add_Lookahead_Actions
- (Item : in LR1_Items.Item;
- Action_List : in out Action_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Nonterm_Set : in Token_Array_Token_Set;
- Conflict_Counts : in out Conflict_Count_Lists.List;
- Conflicts : in out Conflict_Lists.List;
- Closure : in LR1_Items.Item_Set;
- Descriptor : in WisiToken.Descriptor);
- -- Add actions for Item.Lookaheads to Action_List
- -- Closure must be from the item set containing Item.
- -- Has_Empty_Production .. Closure used for conflict reporting.
-
- procedure Delete_Known
- (Conflicts : in out Conflict_Lists.List;
- Known_Conflicts : in out Conflict_Lists.List);
- -- Delete Known_Conflicts from Conflicts.
-
- function Find
- (Closure : in LR1_Items.Item_Set;
- Action : in Parse_Action_Rec;
- Lookahead : in Token_ID;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return Token_ID;
- -- Return the LHS of a production in kernel of Closure, for an Action
- -- conflict on Lookahead; for naming a Conflict object.
-
- function Image (Item : in Conflict; Descriptor : in WisiToken.Descriptor)
return String;
-
- function Is_Present (Item : in Conflict; Conflicts : in
Conflict_Lists.List) return Boolean;
-
- function Match (Known : in Conflict; Item : in
Conflict_Lists.Constant_Reference_Type) return Boolean;
-
- ----------
- -- Minimal terminal sequences.
-
- package RHS_Sequence_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Natural, Token_ID_Arrays.Vector, Default_Element =>
Token_ID_Arrays.Empty_Vector);
-
- function Image is new RHS_Sequence_Arrays.Gen_Image_Aux (Descriptor,
Trimmed_Image, Image_No_Assoc);
-
- function Min_Length (Item : in RHS_Sequence_Arrays.Vector) return
Ada.Containers.Count_Type;
- -- Return minimum length of elements of Item.
-
- function Min (Item : in RHS_Sequence_Arrays.Vector) return
Token_ID_Arrays.Vector;
- -- Return element of Item with minimum length;
-
- type Minimal_Sequence_Item is record
- Min_RHS : Natural := Natural'Last;
- Sequence : RHS_Sequence_Arrays.Vector;
- end record;
-
- type Minimal_Sequence_Array is array (Token_ID range <>) of
Minimal_Sequence_Item;
-
- function Compute_Minimal_Terminal_Sequences
- (Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
- return Minimal_Sequence_Array;
- -- For each production in Grammar, compute the minimal sequence of
- -- terminals that will complete it. Result is an empty sequence if
- -- the production may be empty.
-
- function Compute_Minimal_Terminal_First
- (Descriptor : in WisiToken.Descriptor;
- Minimal_Terminal_Sequences : in Minimal_Sequence_Array)
- return Token_Array_Token_ID;
- -- For each nonterminal in Grammar, return the first of the minimal
- -- sequence of terminals that will complete it; Invalid_Token_ID if
- -- the minimal sequence is empty.
-
- procedure Set_Minimal_Complete_Actions
- (State : in out Parse_State;
- Kernel : in LR1_Items.Item_Set;
- Descriptor : in WisiToken.Descriptor;
- Grammar : in
WisiToken.Productions.Prod_Arrays.Vector;
- Nullable : in Token_Array_Production_ID;
- Minimal_Terminal_Sequences : in Minimal_Sequence_Array;
- Minimal_Terminal_First : in Token_Array_Token_ID);
- -- Set State.Minimal_Complete_Actions to the set of actions that will
- -- most quickly complete the productions in Kernel (which must be for
- -- State). Useful in error correction.
- --
- -- The Minimal_Complete_Actions will be empty in a state where there
- -- is nothing useful to do; the accept state, or one where all
- -- productions are recursive.
- --
- -- Also set State.Kernels; used to resolve multiple reduce actions at
- -- runtime.
-
- ----------
- -- Parse table output
-
- procedure Put_Text_Rep
- (Table : in Parse_Table;
- File_Name : in String;
- Action_Names : in Names_Array_Array;
- Check_Names : in Names_Array_Array);
- -- Write machine-readable text format of Table.States to a file
- -- File_Name, to be read by the parser executable at startup, using
- -- WisiToken.Parse.LR.Get_Text_Rep.
-
- procedure Put (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor);
- procedure Put (Item : in McKenzie_Param_Type; Descriptor : in
WisiToken.Descriptor);
- procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Parse_Action_Rec);
- procedure Put (Descriptor : in WisiToken.Descriptor; Action : in
Parse_Action_Node_Ptr);
- procedure Put (Descriptor : in WisiToken.Descriptor; State : in
Parse_State);
- -- Put Item to Ada.Text_IO.Current_Output in parse table format.
-
- procedure Put_Parse_Table
- (Table : in Parse_Table_Ptr;
- Parse_Table_File_Name : in String;
- Title : in String;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Recursions : in Generate.Recursions;
- Kernels : in LR1_Items.Item_Set_List;
- Conflicts : in Conflict_Count_Lists.List;
- Descriptor : in WisiToken.Descriptor;
- Include_Extra : in Boolean := False);
- -- "Extra" is recursions.
-
-end WisiToken.Generate.LR;
diff --git a/packages/wisi/wisitoken-generate-lr1_items.adb
b/packages/wisi/wisitoken-generate-lr1_items.adb
deleted file mode 100644
index 37e6f0e..0000000
--- a/packages/wisi/wisitoken-generate-lr1_items.adb
+++ /dev/null
@@ -1,553 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2002, 2003, 2008, 2009, 2012 - 2015, 2017 - 2020 Free
Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Text_IO;
-with Ada.Strings.Unbounded;
-package body WisiToken.Generate.LR1_Items is
- use type Ada.Strings.Unbounded.Unbounded_String;
-
- ----------
- -- body subprograms
-
- function Get_Dot_IDs
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Set : in Item_Lists.List;
- Descriptor : in WisiToken.Descriptor)
- return Token_ID_Arrays.Vector
- is
- use Item_Lists;
- IDs : Token_ID_Set (Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal) := (others => False);
- begin
- for Item of Set loop
- declare
- use Token_ID_Arrays;
- Dot : constant Token_ID_Arrays.Cursor :=
- WisiToken.Productions.Constant_Ref_RHS (Grammar,
Item.Prod).Tokens.To_Cursor (Item.Dot);
- begin
- if Has_Element (Dot) then
- if Element (Dot) /= Descriptor.EOI_ID then
- IDs (Element (Dot)) := True;
- end if;
- end if;
- end;
- end loop;
- return To_Array (IDs);
- end Get_Dot_IDs;
-
- function Merge
- (Prod : in Production_ID;
- Dot : in Token_ID_Arrays.Extended_Index;
- Lookaheads : in Lookahead;
- Existing_Set : in out Item_Set)
- return Boolean
- is
- -- Merge item into Existing_Set. Return True if Existing_Set
- -- is modified.
-
- use Item_Lists;
-
- Found : constant Item_Lists.Cursor := Find (Prod, Dot, Existing_Set);
- Modified : Boolean := False;
- begin
- if not Has_Element (Found) then
- Existing_Set.Set.Insert ((Prod, Dot, new Token_ID_Set'(Lookaheads)));
-
- Modified := True;
- else
- Include (Variable_Ref (Found), Lookaheads, Modified);
- end if;
-
- return Modified;
- end Merge;
-
- ----------
- -- Public subprograms, declaration order
-
- function To_Lookahead (Item : in Token_ID; Descriptor : in
WisiToken.Descriptor) return Lookahead
- is begin
- return Result : Token_ID_Set := (Descriptor.First_Terminal ..
Descriptor.Last_Lookahead => False) do
- Result (Item) := True;
- end return;
- end To_Lookahead;
-
- function Lookahead_Image (Item : in Lookahead; Descriptor : in
WisiToken.Descriptor) return String
- is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := Null_Unbounded_String;
- begin
- for I in Item'Range loop
- if Item (I) then
- if Length (Result) > 0 then
- Result := Result & "/";
- end if;
- Result := Result & Image (I, Descriptor);
- end if;
- end loop;
- return To_String (Result);
- end Lookahead_Image;
-
- function Item_Compare (Left, Right : in Item) return SAL.Compare_Result
- is (if Left.Prod.LHS > Right.Prod.LHS then SAL.Greater
- elsif Left.Prod.LHS < Right.Prod.LHS then SAL.Less
- elsif Left.Prod.RHS > Right.Prod.RHS then SAL.Greater
- elsif Left.Prod.RHS < Right.Prod.RHS then SAL.Less
- elsif Left.Dot > Right.Dot then SAL.Greater
- elsif Left.Dot < Right.Dot then SAL.Less
- else SAL.Equal);
-
- procedure Include
- (Item : in out LR1_Items.Item;
- Value : in Lookahead;
- Added : out Boolean)
- is begin
- Added := False;
-
- for I in Item.Lookaheads'Range loop
- if Value (I) then
- Added := Added or not Item.Lookaheads (I);
- Item.Lookaheads (I) := True;
- end if;
- end loop;
- end Include;
-
- procedure Include
- (Item : in out LR1_Items.Item;
- Value : in Lookahead;
- Descriptor : in WisiToken.Descriptor)
- is
- Added : Boolean;
- pragma Unreferenced (Added);
- begin
- Include (Item, Value, Added, Descriptor);
- end Include;
-
- procedure Include
- (Item : in out LR1_Items.Item;
- Value : in Lookahead;
- Added : out Boolean;
- Descriptor : in WisiToken.Descriptor)
- is begin
- Added := False;
-
- for I in Item.Lookaheads'Range loop
- if I = Descriptor.Last_Lookahead then
- null;
- else
- if Value (I) then
- Added := Added or not Item.Lookaheads (I);
- Item.Lookaheads (I) := True;
- end if;
- end if;
- end loop;
- end Include;
-
- function Filter
- (Set : in Item_Set;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Include : access function
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in LR1_Items.Item)
- return Boolean)
- return Item_Set
- is begin
- return Result : Item_Set := (Set => <>, Goto_List => Set.Goto_List,
Dot_IDs => Set.Dot_IDs, State => Set.State)
- do
- for Item of Set.Set loop
- if Include (Grammar, Descriptor, Item) then
- Result.Set.Insert (Item);
- end if;
- end loop;
- end return;
- end Filter;
-
- function In_Kernel
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in LR1_Items.Item)
- return Boolean
- is
- use all type Ada.Containers.Count_Type;
- use Token_ID_Arrays;
- Prod : WisiToken.Productions.Instance renames Grammar (Item.Prod.LHS);
- RHS : WisiToken.Productions.Right_Hand_Side renames Prod.RHSs
(Item.Prod.RHS);
- begin
- return
- RHS.Tokens.Length > 0 and
- (Item.Dot = No_Index or else
- ((Prod.LHS = Descriptor.Accept_ID and
- Item.Dot = RHS.Tokens.First_Index)
- -- Start symbol production with dot before first token.
- or
- Item.Dot /= RHS.Tokens.First_Index));
- end In_Kernel;
-
- function Find
- (Item : in LR1_Items.Item;
- Set : in Item_Set)
- return Item_Lists.Cursor
- is begin
- return Find (Item.Prod, Item.Dot, Set);
- end Find;
-
- function Find
- (Prod : in Production_ID;
- Dot : in Token_ID_Arrays.Extended_Index;
- Set : in Item_Set)
- return Item_Lists.Cursor
- is begin
- return Set.Set.Find ((Prod, Dot, null));
- end Find;
-
- function To_Item_Set_Tree_Key
- (Item_Set : in LR1_Items.Item_Set;
- Include_Lookaheads : in Boolean)
- return Item_Set_Tree_Key
- is
- use Interfaces;
- use Item_Lists;
- Cur : Item_Lists.Cursor := Item_Set.Set.First;
- begin
- return Result : Item_Set_Tree_Key do
- Result.Append (Integer_16 (Item_Set.Set.Length));
- -- Int_Arrays."<" compares length, but only after everything else; we
- -- want it to compare first, since it is most likely to be different.
-
- loop
- exit when not Has_Element (Cur);
- declare
- Item_1 : Item renames Item_Set.Set (Cur);
- begin
- Result.Append (Integer_16 (Item_1.Prod.LHS));
- Result.Append (Integer_16 (Item_1.Prod.RHS));
- Result.Append (Integer_16 (Item_1.Dot));
- if Include_Lookaheads then
- for ID in Item_1.Lookaheads'Range loop
- if Item_1.Lookaheads (ID) then
- Result.Append (Integer_16 (ID));
- end if;
- end loop;
- end if;
- end;
- Next (Cur);
- end loop;
- end return;
- end To_Item_Set_Tree_Key;
-
- function Find
- (New_Item_Set : in Item_Set;
- Item_Set_Tree : in Item_Set_Trees.Tree;
- Match_Lookaheads : in Boolean)
- return Unknown_State_Index
- is
- use all type Item_Set_Trees.Cursor;
-
- Tree_It : constant Item_Set_Trees.Iterator := Item_Set_Trees.Iterate
(Item_Set_Tree);
- Key : constant Item_Set_Tree_Key := To_Item_Set_Tree_Key
- (New_Item_Set, Include_Lookaheads => Match_Lookaheads);
- Found_Tree : constant Item_Set_Trees.Cursor := Tree_It.Find (Key);
- begin
- if Found_Tree = Item_Set_Trees.No_Element then
- return Unknown_State;
- else
- return Item_Set_Tree (Found_Tree).State;
- end if;
- end Find;
-
- procedure Add
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- New_Item_Set : in Item_Set;
- Item_Set_Vector : in out Item_Set_List;
- Item_Set_Tree : in out Item_Set_Trees.Tree;
- Descriptor : in WisiToken.Descriptor;
- Include_Lookaheads : in Boolean)
- is
- use Item_Set_Trees;
- Key : constant Item_Set_Tree_Key := To_Item_Set_Tree_Key (New_Item_Set,
Include_Lookaheads);
- begin
- Item_Set_Vector.Append (New_Item_Set);
- Item_Set_Vector (Item_Set_Vector.Last_Index).Dot_IDs := Get_Dot_IDs
(Grammar, New_Item_Set.Set, Descriptor);
- Item_Set_Tree.Insert ((Key, New_Item_Set.State));
- end Add;
-
- function Is_In
- (Item : in Goto_Item;
- Goto_List : in Goto_Item_Lists.List)
- return Boolean
- is begin
- for List_Item of Goto_List loop
- if List_Item = Item then
- return True;
- end if;
- end loop;
-
- return False;
- end Is_In;
-
- function Goto_State
- (From : in Item_Set;
- Symbol : in Token_ID)
- return Unknown_State_Index
- is begin
- for Item of From.Goto_List loop
- if Item.Symbol = Symbol then
- return Item.State;
- end if;
- end loop;
-
- return Unknown_State;
- end Goto_State;
-
- function Closure
- (Set : in Item_Set;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return Item_Set
- is
- use all type Item_Lists.Cursor;
- use Token_ID_Arrays;
-
- -- [dragon] algorithm 4.9 pg 231; figure 4.38 pg 232; procedure
"closure"
- --
- -- Taken literally, the algorithm modifies its input; we make a
- -- copy instead.
-
- I : Item_Set := Set; -- The result.
-
- Item_I : Item_Lists.Cursor := I.Set.First; -- iterator 'for each
item in I'
- Added_Item : Boolean := False; -- 'until no more items can be added'
- begin
- loop
- declare
- Item : LR1_Items.Item renames I.Set (Item_I);
- Dot : constant Token_ID_Arrays.Cursor :=
- WisiToken.Productions.Constant_Ref_RHS (Grammar,
Item.Prod).Tokens.To_Cursor (Item.Dot);
- begin
- -- An item has the structure [A -> alpha Dot B Beta, a].
- --
- -- If B is a nonterminal, find its productions and place
- -- them in the set with lookaheads from FIRST(Beta a).
- if Has_Element (Dot) and then
- Element (Dot) in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal
- then
- declare
- Prod : WisiToken.Productions.Instance renames Grammar
(Element (Dot));
- begin
- For_Each_RHS :
- for J in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
- declare
- RHS : WisiToken.Productions.Right_Hand_Side renames
Prod.RHSs (J);
- P_ID : constant Production_ID := (Prod.LHS, J);
- Beta : Token_ID_Arrays.Cursor := Next (Dot); -- tokens
after nonterminal, possibly null
- begin
- -- Compute FIRST (<tail of right hand side> a); loop
- -- until find a terminal, a nonterminal that
- -- cannot be empty, or end of production, adding
- -- items on the way.
-
- First_Tail :
- loop
- if not Has_Element (Beta) then
- -- Use FIRST (a); a = Item.Lookaheads.
- -- Lookaheads are all terminals, so
- -- FIRST (a) = a.
- Added_Item := Added_Item or
- Merge (P_ID, To_Index (RHS.Tokens.First),
Item.Lookaheads.all, I);
- exit First_Tail;
-
- elsif Element (Beta) in Descriptor.First_Terminal
.. Descriptor.Last_Terminal then
- -- FIRST (Beta) = Beta
- Added_Item := Added_Item or Merge
- (P_ID, To_Index (RHS.Tokens.First),
To_Lookahead (Element (Beta), Descriptor), I);
- exit First_Tail;
-
- else
- -- Beta is a nonterminal; use FIRST (Beta)
- for Terminal of First_Terminal_Sequence (Element
(Beta)) loop
- Added_Item := Added_Item or
- Merge (P_ID, To_Index (RHS.Tokens.First),
To_Lookahead (Terminal, Descriptor), I);
- end loop;
-
- if Has_Empty_Production (Element (Beta)) then
- -- Process the next token in the tail, or "a"
- Beta := Next (Beta);
- else
- exit First_Tail;
- end if;
- end if;
- end loop First_Tail;
- end;
- end loop For_Each_RHS;
- end;
- end if; -- Dot is at non-terminal
- end;
-
- if not Has_Element (Item_Lists.Next (Item_I)) then
- exit when not Added_Item;
-
- Item_I := I.Set.First;
- Added_Item := False;
-
- if Trace_Generate_Table > Extra then
- Ada.Text_IO.Put_Line (" closure:");
- Put (Grammar, Descriptor, I);
- end if;
- else
- Item_I := Item_Lists.Next (Item_I);
- end if;
- end loop;
-
- return I;
- end Closure;
-
- function Productions (Set : in Item_Set) return Production_ID_Arrays.Vector
- is begin
- return Result : Production_ID_Arrays.Vector do
- for Item of Set.Set loop
- Result.Append (Item.Prod);
- end loop;
- end return;
- end Productions;
-
- function Image
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in LR1_Items.Item;
- Show_Lookaheads : in Boolean)
- return String
- is
- use Token_ID_Arrays;
-
- Prod : WisiToken.Productions.Instance renames Grammar (Item.Prod.LHS);
- RHS : WisiToken.Productions.Right_Hand_Side renames Prod.RHSs
(Item.Prod.RHS);
- Result : Ada.Strings.Unbounded.Unbounded_String :=
- +Padded_Image (Item.Prod, Width => Prod_ID_Image_Width) & ":" & Image
(Prod.LHS, Descriptor) & " <=";
-
- I : Cursor := RHS.Tokens.First;
- begin
- while Has_Element (I) loop
- if To_Index (I) = Item.Dot then
- Result := Result & " ^ ";
- else
- Result := Result & " ";
- end if;
- Result := Result & Image (Element (I), Descriptor);
- Next (I);
- end loop;
-
- if Item.Dot = No_Index then
- Result := Result & " ^";
- end if;
-
- if Show_Lookaheads then
- Result := Result & ", " & Lookahead_Image (Item.Lookaheads.all,
Descriptor);
- end if;
-
- return Ada.Strings.Unbounded.To_String (Result);
- end Image;
-
- procedure Put
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in LR1_Items.Item;
- Show_Lookaheads : in Boolean := True)
- is begin
- Ada.Text_IO.Put (Image (Grammar, Descriptor, Item, Show_Lookaheads =>
Show_Lookaheads));
- end Put;
-
- procedure Put
- (Descriptor : in WisiToken.Descriptor;
- List : in Goto_Item_Lists.List)
- is
- use Ada.Text_IO;
- begin
- for Item of List loop
- Put_Line
- (" on " & Image (Item.Symbol, Descriptor) &
- " => State" & Unknown_State_Index'Image (Item.State));
- end loop;
- end Put;
-
- procedure Put
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in Item_Lists.List;
- Show_Lookaheads : in Boolean := True;
- Kernel_Only : in Boolean := False)
- is begin
- for It of Item loop
- if not Kernel_Only or else
- In_Kernel (Grammar, Descriptor, It)
- then
- Ada.Text_IO.Put_Line
- (" " & Image (Grammar, Descriptor, It, Show_Lookaheads =>
Show_Lookaheads));
- end if;
- end loop;
- end Put;
-
- procedure Put
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in Item_Set;
- Show_Lookaheads : in Boolean := True;
- Kernel_Only : in Boolean := False;
- Show_Goto_List : in Boolean := False)
- is
- use Ada.Text_IO;
- begin
- if Item.State /= Unknown_State then
- Put_Line ("State" & Unknown_State_Index'Image (Item.State) & ":");
- end if;
-
- Put (Grammar, Descriptor, Item.Set, Show_Lookaheads, Kernel_Only);
-
- if Show_Goto_List then
- Put (Descriptor, Item.Goto_List);
- end if;
- end Put;
-
- procedure Put
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in Item_Set_List;
- Show_Lookaheads : in Boolean := True)
- is
- use Ada.Text_IO;
- begin
- for Set of Item loop
- Put (Grammar, Descriptor, Set, Show_Lookaheads);
- Put_Line (" Goto:");
- Put (Descriptor, Set.Goto_List);
- end loop;
- end Put;
-
-end WisiToken.Generate.LR1_Items;
diff --git a/packages/wisi/wisitoken-generate-lr1_items.ads
b/packages/wisi/wisitoken-generate-lr1_items.ads
deleted file mode 100644
index 43e2939..0000000
--- a/packages/wisi/wisitoken-generate-lr1_items.ads
+++ /dev/null
@@ -1,335 +0,0 @@
--- Abstract :
---
--- Types and operatorion for LR(1) items.
---
--- Copyright (C) 2003, 2008, 2013 - 2015, 2017 - 2020 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Interfaces;
-with SAL.Gen_Definite_Doubly_Linked_Lists_Sorted;
-with SAL.Gen_Unbounded_Definite_Red_Black_Trees;
-with SAL.Gen_Unbounded_Definite_Vectors.Gen_Comparable;
-with WisiToken.Productions;
-package WisiToken.Generate.LR1_Items is
-
- use all type Interfaces.Integer_16;
-
- subtype Lookahead is Token_ID_Set;
- -- Picking a type for Lookahead is not straight-forward. The
- -- operations required are (called numbers are for LR1 generate
- -- ada_lite):
- --
- -- to_lookahead (token_id)
- -- Requires allocating memory dynamically:
- -- an unconstrained array range (first_terminal .. last_terminal)
for (1),
- -- a smaller unconstrained array for (2), that grows as items are
added
- -- individual list elements for (3).
- --
- -- lr1_items.to_lookahead called 4_821_256 times in (2)
- -- sorted_token_id_lists.to_list called 4_821_256 times in (3)
- --
- -- for tok_id of lookaheads loop
- -- sorted_token_id_lists__iterate called 5_687 times in (3)
- --
- -- if lookaheads.contains (tok_id) then
- -- token_id_arrays__contains called 22_177_109 in (2)
- --
- -- new_item := (... , lookaheads => old_item.lookaheads)
- -- new_item := (... , lookaheads => null_lookaheads)
- -- new_item := (... , lookaheads => propagate_lookahead)
- -- token_id_arrays.adjust called 8_437_967 times in (2)
- -- sorted_token_id_lists.adjust 8_435_797 times in (3)
- --
- -- include: add tok_id to lookaheads
- --
- -- keep sorted in token_id order, so rest of algorithm is
- -- stable/faster
- --
- -- lr1_items.include called 6_818_725 times in (2)
- --
- -- lookaheads /= lookaheads
- -- if using a container, container must override "="
- --
- -- We've tried:
- --
- -- (1) Token_ID_Set (unconstrained array of boolean, allocated directly) -
fastest
- --
- -- Allocates more memory than (2), but everything else is fast,
- -- and it's not enough memory to matter.
- --
- -- Loop over lookaheads is awkward:
- -- for tok_id in lookaheads'range loop
- -- if lookaheads (tok_id) then
- -- ...
- -- But apparently it's fast enough.
- --
- -- (2) Instantiation of SAL.Gen_Unbounded_Definite_Vectors
(token_id_arrays) - slower than (1).
- --
- -- Productions RHS is also token_id_arrays, so gprof numbers are
- -- hard to sort out. Could be improved with a custom container, that
- -- does sort and insert internally. Insert is inherently slow.
- --
- -- (3) Instantiation of SAL.Gen_Definite_Doubly_Linked_Lists_Sorted -
slower than (2)
-
- type Item is record
- Prod : Production_ID;
- Dot : Token_ID_Arrays.Extended_Index := Token_ID_Arrays.No_Index;
-- token after item Dot
- Lookaheads : Token_ID_Set_Access := null;
- -- Programmer must remember to copy Item.Lookaheads.all, not
- -- Item.Lookaheads. Wrapping this in Ada.Finalization.Controlled
- -- would just slow it down.
- --
- -- We don't free Lookaheads; we assume the user is running
- -- wisi-generate, and not keeping LR1_Items around.
- end record;
-
- function To_Lookahead (Item : in Token_ID; Descriptor : in
WisiToken.Descriptor) return Lookahead;
-
- function Contains (Item : in Lookahead; ID : in Token_ID) return Boolean
- is (Item (ID));
-
- function Lookahead_Image (Item : in Lookahead; Descriptor : in
WisiToken.Descriptor) return String;
- -- Returns the format used in parse table output.
-
- function Image
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in LR1_Items.Item;
- Show_Lookaheads : in Boolean)
- return String;
-
- function Item_Compare (Left, Right : in Item) return SAL.Compare_Result;
- -- Sort Item_Lists in ascending order of Prod.Nonterm, Prod.RHS, Dot;
- -- ignores Lookaheads.
- --
- -- In an LALR kernel there can be only one Item with Prod, but that
- -- is not true in an Item_Set produced by Closure.
-
- package Item_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists_Sorted
(Item, Item_Compare);
-
- procedure Include
- (Item : in out LR1_Items.Item;
- Value : in Lookahead;
- Added : out Boolean);
- -- Add Value to Item.Lookahead, if not already present.
- --
- -- Added is True if Value was not already present.
- --
- -- Does not exclude Propagate_ID.
-
- procedure Include
- (Item : in out LR1_Items.Item;
- Value : in Lookahead;
- Descriptor : in WisiToken.Descriptor);
- -- Add Value to Item.Lookahead. Does not check if already present.
- -- Excludes Propagate_ID.
-
- procedure Include
- (Item : in out LR1_Items.Item;
- Value : in Lookahead;
- Added : out Boolean;
- Descriptor : in WisiToken.Descriptor);
- -- Add Value to Item.Lookahead.
-
- type Goto_Item is record
- Symbol : Token_ID;
- -- If Symbol is a terminal, this is a shift and goto state action.
- -- If Symbol is a non-terminal, this is a post-reduce goto state action.
- State : State_Index;
- end record;
-
- function Goto_Item_Compare (Left, Right : in Goto_Item) return
SAL.Compare_Result is
- (if Left.Symbol > Right.Symbol then SAL.Greater
- elsif Left.Symbol < Right.Symbol then SAL.Less
- else SAL.Equal);
- -- Sort Goto_Item_Lists in ascending order of Symbol.
-
- package Goto_Item_Lists is new SAL.Gen_Definite_Doubly_Linked_Lists_Sorted
- (Goto_Item, Goto_Item_Compare);
-
- type Item_Set is record
- Set : Item_Lists.List;
- Goto_List : Goto_Item_Lists.List;
- Dot_IDs : Token_ID_Arrays.Vector;
- State : Unknown_State_Index := Unknown_State;
- end record;
-
- function Filter
- (Set : in Item_Set;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Include : access function
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in LR1_Items.Item)
- return Boolean)
- return Item_Set;
- -- Return a deep copy of Set, including only items for which Include
returns True.
-
- function In_Kernel
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in LR1_Items.Item)
- return Boolean;
- -- For use with Filter; [dragon] sec 4.7 pg 240
-
- function Find
- (Item : in LR1_Items.Item;
- Set : in Item_Set)
- return Item_Lists.Cursor;
- -- Return an item from Set that matches Item.Prod, Item.Dot.
- --
- -- Return No_Element if not found.
-
- function Find
- (Prod : in Production_ID;
- Dot : in Token_ID_Arrays.Extended_Index;
- Set : in Item_Set)
- return Item_Lists.Cursor;
- -- Return an item from Set that matches Prod, Dot.
- --
- -- Return No_Element if not found.
-
- package Item_Set_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (State_Index, Item_Set, Default_Element => (others => <>));
- subtype Item_Set_List is Item_Set_Arrays.Vector;
-
- package Int_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive, Interfaces.Integer_16, Default_Element =>
Interfaces.Integer_16'Last);
- function Compare_Integer_16 (Left, Right : in Interfaces.Integer_16) return
SAL.Compare_Result is
- (if Left > Right then SAL.Greater
- elsif Left < Right then SAL.Less
- else SAL.Equal);
-
- package Int_Arrays_Comparable is new Int_Arrays.Gen_Comparable
(Compare_Integer_16);
-
- subtype Item_Set_Tree_Key is Int_Arrays_Comparable.Vector;
- -- We want a key that is fast to compare, and has enough info to
- -- significantly speed the search for an item set. So we convert all
- -- relevant data in an item into a string of integers. We need 16 bit
- -- because Ada token_ids max is 332. LR1 keys include lookaheads,
- -- LALR keys do not.
-
- type Item_Set_Tree_Node is record
- Key : Item_Set_Tree_Key;
- State : Unknown_State_Index;
- end record;
-
- function To_Item_Set_Tree_Key
- (Item_Set : in LR1_Items.Item_Set;
- Include_Lookaheads : in Boolean)
- return Item_Set_Tree_Key;
-
- function To_Item_Set_Tree_Key (Node : in Item_Set_Tree_Node) return
Item_Set_Tree_Key is
- (Node.Key);
-
- package Item_Set_Trees is new SAL.Gen_Unbounded_Definite_Red_Black_Trees
- (Element_Type => Item_Set_Tree_Node,
- Key_Type => Item_Set_Tree_Key,
- Key => To_Item_Set_Tree_Key,
- Key_Compare => Int_Arrays_Comparable.Compare);
- -- Item_Set_Arrays.Vector holds state item sets indexed by state, for
- -- iterating in state order. Item_Set_Trees.Tree holds lists of state
- -- indices sorted by LR1 item info, for fast Find in LR1_Item_Sets
- -- and LALR_Kernels.
-
- function Find
- (New_Item_Set : in Item_Set;
- Item_Set_Tree : in Item_Set_Trees.Tree;
- Match_Lookaheads : in Boolean)
- return Unknown_State_Index;
- -- Return the State of an element in Item_Set_Tree matching
- -- New_Item_Set, Unknown_State if not found.
- --
- -- Match_Lookaheads is True in LR1_Generate.
-
- procedure Add
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- New_Item_Set : in Item_Set;
- Item_Set_Vector : in out Item_Set_List;
- Item_Set_Tree : in out Item_Set_Trees.Tree;
- Descriptor : in WisiToken.Descriptor;
- Include_Lookaheads : in Boolean);
- -- Set New_Item_Set.Dot_IDs, add New_Item_Set to Item_Set_Vector,
Item_Set_Tree
-
- function Is_In
- (Item : in Goto_Item;
- Goto_List : in Goto_Item_Lists.List)
- return Boolean;
- -- Return True if a goto on Symbol to State is found in Goto_List
-
- function Goto_State
- (From : in Item_Set;
- Symbol : in Token_ID)
- return Unknown_State_Index;
- -- Return state from From.Goto_List where the goto symbol is
- -- Symbol; Unknown_State if not found.
-
- function Closure
- (Set : in Item_Set;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal_Sequence : in Token_Sequence_Arrays.Vector;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return Item_Set;
- -- Return the closure of Set over Grammar. First must be the
- -- result of First above. Makes a deep copy of Goto_List.
- -- Implements 'closure' from [dragon] algorithm 4.9 pg 232, but
- -- allows merging lookaheads into one item..
-
- function Productions (Set : in Item_Set) return Production_ID_Arrays.Vector;
-
- procedure Put
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in LR1_Items.Item;
- Show_Lookaheads : in Boolean := True);
-
- procedure Put
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in Item_Lists.List;
- Show_Lookaheads : in Boolean := True;
- Kernel_Only : in Boolean := False);
-
- procedure Put
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in Item_Set;
- Show_Lookaheads : in Boolean := True;
- Kernel_Only : in Boolean := False;
- Show_Goto_List : in Boolean := False);
-
- procedure Put
- (Descriptor : in WisiToken.Descriptor;
- List : in Goto_Item_Lists.List);
- procedure Put
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Item : in Item_Set_List;
- Show_Lookaheads : in Boolean := True);
- -- Put Item to Ada.Text_IO.Standard_Output. Does not end with New_Line.
-
-end WisiToken.Generate.LR1_Items;
diff --git a/packages/wisi/wisitoken-generate-packrat.adb
b/packages/wisi/wisitoken-generate-packrat.adb
deleted file mode 100644
index c50b1ed..0000000
--- a/packages/wisi/wisitoken-generate-packrat.adb
+++ /dev/null
@@ -1,247 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Generate.Packrat is
-
- function Potential_Direct_Right_Recursive
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Empty : in Token_ID_Set)
- return Token_ID_Set
- is
- subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
- begin
- return Result : Token_ID_Set (Nonterminal) := (others => False) do
- for Prod of Grammar loop
- RHS_Loop :
- for RHS of Prod.RHSs loop
- ID_Loop :
- for I in reverse RHS.Tokens.First_Index + 1 ..
RHS.Tokens.Last_Index loop
- declare
- ID : constant Token_ID := RHS.Tokens (I);
- begin
- if ID = Prod.LHS then
- Result (ID) := True;
- exit RHS_Loop;
- elsif not (ID in Nonterminal) then
- exit ID_Loop;
- elsif not Empty (ID) then
- exit ID_Loop;
- end if;
- end;
- end loop ID_Loop;
- end loop RHS_Loop;
- end loop;
- end return;
- end Potential_Direct_Right_Recursive;
-
- procedure Indirect_Left_Recursive (Data : in out Packrat.Data)
- is
- begin
- for Prod_I of Data.Grammar loop
- for Prod_J of Data.Grammar loop
- Data.Involved (Prod_I.LHS, Prod_J.LHS) :=
- Data.First (Prod_I.LHS, Prod_J.LHS) and
- Data.First (Prod_J.LHS, Prod_I.LHS);
- end loop;
- end loop;
- end Indirect_Left_Recursive;
-
- ----------
- -- Public subprograms
-
- function Initialize
- (Source_File_Name : in String;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Source_Line_Map : in Productions.Source_Line_Maps.Vector;
- First_Terminal : in Token_ID)
- return Packrat.Data
- is
- Empty : constant Token_ID_Set := WisiToken.Generate.Has_Empty_Production
(Grammar);
- begin
- return Result : Packrat.Data :=
- (First_Terminal => First_Terminal,
- First_Nonterminal => Grammar.First_Index,
- Last_Nonterminal => Grammar.Last_Index,
- Source_File_Name => +Source_File_Name,
- Grammar => Grammar,
- Source_Line_Map => Source_Line_Map,
- Empty => Empty,
- Direct_Left_Recursive => Potential_Direct_Left_Recursive (Grammar,
Empty),
- First => WisiToken.Generate.First (Grammar, Empty,
First_Terminal => First_Terminal),
- Involved => (others => (others => False)))
- do
- Indirect_Left_Recursive (Result);
- end return;
- end Initialize;
-
- procedure Check_Recursion (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
- is
- Right_Recursive : constant Token_ID_Set :=
Potential_Direct_Right_Recursive (Data.Grammar, Data.Empty);
- begin
- for Prod of Data.Grammar loop
- if Data.Direct_Left_Recursive (Prod.LHS) and Right_Recursive
(Prod.LHS) then
- -- We only implement the simplest left recursion solution ([warth
- -- 2008] figure 3); [tratt 2010] section 6.3 gives this condition
for
- -- that to be valid.
- -- FIXME: not quite? definite direct right recursive ok?
- -- FIXME: for indirect left recursion, need potential indirect
right recursive check?
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
- "' is both left and right recursive; not supported."));
- end if;
-
- for I in Data.Involved'Range (2) loop
- if Prod.LHS /= I and then Data.Involved (Prod.LHS, I) then
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line, "'" & Image (Prod.LHS, Descriptor) &
- "' is indirect recursive with " & Image (I, Descriptor)
& ", not supported"));
- end if;
- end loop;
- end loop;
- end Check_Recursion;
-
- procedure Check_RHS_Order (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
- is
- use all type Ada.Containers.Count_Type;
- begin
- for Prod of Data.Grammar loop
- -- Empty must be last
- for I in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index - 1 loop
- if Prod.RHSs (I).Tokens.Length = 0 then
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).RHS_Map (I),
- "right hand side" & Integer'Image (I) & " in " & Image
(Prod.LHS, Descriptor) &
- " is empty, but not last; no later right hand side will
match."));
- WisiToken.Generate.Error := True;
- end if;
- end loop;
-
- for I in Prod.RHSs.First_Index + 1 .. Prod.RHSs.Last_Index loop
- declare
- Cur : Token_ID_Arrays.Vector renames Prod.RHSs (I).Tokens;
- begin
- -- Shared prefix; longer must be first
- for J in Prod.RHSs.First_Index .. I - 1 loop
- declare
- Prev : Token_ID_Arrays.Vector renames Prod.RHSs
(J).Tokens;
- K : constant Natural := Shared_Prefix (Prev, Cur);
- begin
- if K > 0 and Prev.Length < Cur.Length then
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).RHS_Map (I),
- "right hand side" & Integer'Image (I) & " in " &
Image (Prod.LHS, Descriptor) &
- " may never match; it shares a prefix with a
shorter previous rhs" &
- Integer'Image (J) & "."));
- end if;
- end;
- end loop;
-
- -- recursion; typical LALR list is written:
- --
- -- statement_list
- -- : statement
- -- | statement_list statement
- -- ;
- -- association_list
- -- : association
- -- | association_list COMMA association
- -- ;
- --
- -- a different recursive definition:
- --
- -- name
- -- : IDENTIFIER
- -- | name LEFT_PAREN range_list RIGHT_PAREN
- -- | name actual_parameter_part
- -- ...
- -- ;
- --
- -- For packrat, the recursive RHSs must come before others:
- --
- -- statement_list
- -- : statement_list statement
- -- | statement
- -- ;
- -- association_list
- -- : association_list COMMA association
- -- | association
- -- ;
- -- name
- -- : name LEFT_PAREN range_list RIGHT_PAREN
- -- | name actual_parameter_part
- -- | IDENTIFIER
- -- ...
- -- ;
- declare
- Prev : Token_ID_Arrays.Vector renames Prod.RHSs (I -
1).Tokens;
- begin
- if Cur.Length > 0 and then Prev.Length > 0 and then
- Cur (1) = Prod.LHS and then Prev (1) /= Prod.LHS
- then
- Put_Error
- (Error_Message
- (-Data.Source_File_Name, Data.Source_Line_Map
(Prod.LHS).Line,
- "recursive right hand sides must be before
others."));
- end if;
- end;
- end;
- end loop;
- end loop;
- end Check_RHS_Order;
-
- procedure Check_All (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor)
- is begin
- Check_Recursion (Data, Descriptor);
- Check_RHS_Order (Data, Descriptor);
- end Check_All;
-
- function Potential_Direct_Left_Recursive
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Empty : in Token_ID_Set)
- return Token_ID_Set
- is
- subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
- begin
- -- FIXME: this duplicates the computation of First; if keep First,
- -- change this to use it.
- return Result : Token_ID_Set (Nonterminal) := (others => False) do
- for Prod of Grammar loop
- RHS_Loop :
- for RHS of Prod.RHSs loop
- ID_Loop :
- for ID of RHS.Tokens loop
- if ID = Prod.LHS then
- Result (ID) := True;
- exit RHS_Loop;
- elsif not (ID in Nonterminal) then
- exit ID_Loop;
- elsif not Empty (ID) then
- exit ID_Loop;
- end if;
- end loop ID_Loop;
- end loop RHS_Loop;
- end loop;
- end return;
- end Potential_Direct_Left_Recursive;
-
-end WisiToken.Generate.Packrat;
diff --git a/packages/wisi/wisitoken-generate-packrat.ads
b/packages/wisi/wisitoken-generate-packrat.ads
deleted file mode 100644
index 17bf03e..0000000
--- a/packages/wisi/wisitoken-generate-packrat.ads
+++ /dev/null
@@ -1,75 +0,0 @@
--- Abstract :
---
--- Types and operations for computing grammar properties used in
--- generating a packrat parser.
---
--- We use the terminology in [tratt 2010] for recursion in
--- productions.
---
--- References :
---
--- See wisitoken-parse-packrat.ads.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package WisiToken.Generate.Packrat is
-
- type Data (First_Terminal, First_Nonterminal, Last_Nonterminal : Token_ID)
is tagged
- record
- -- Data needed to check a grammar and generate code. Tagged to allow
- -- Object.Method syntax. Descriptor not included to avoid duplicating
- -- lots of discriminants.
- Source_File_Name : Ada.Strings.Unbounded.Unbounded_String;
- Grammar : WisiToken.Productions.Prod_Arrays.Vector;
- Source_Line_Map : Productions.Source_Line_Maps.Vector;
- Empty : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
- Direct_Left_Recursive : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
- First : Token_Array_Token_Set
- (First_Nonterminal .. Last_Nonterminal, First_Terminal ..
Last_Nonterminal);
- Involved : Token_Array_Token_Set
- (First_Nonterminal .. Last_Nonterminal, First_Nonterminal ..
Last_Nonterminal);
- end record;
-
- function Initialize
- (Source_File_Name : in String;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Source_Line_Map : in Productions.Source_Line_Maps.Vector;
- First_Terminal : in Token_ID)
- return Packrat.Data;
-
- procedure Check_Recursion (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
- -- Check that any rule recursion present is supported.
-
- procedure Check_RHS_Order (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
- -- For each production, check that right hand sides that share
- -- prefixes have the longest right hand side first, and that any
- -- empty right hand side is last.
- --
- -- Violations output a message to Ada.Text_IO.Standard_Error, and
- -- set WisiToken.Generate.Error True.
-
- procedure Check_All (Data : in Packrat.Data; Descriptor : in
WisiToken.Descriptor);
- -- Run all the above checks.
- --
- -- Note that WisiToken.Generate.Check_Consistent is run in
- -- wisi-gen_generate_utils.To_Grammar.
-
- function Potential_Direct_Left_Recursive
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Empty : in Token_ID_Set)
- return Token_ID_Set;
-
-end WisiToken.Generate.Packrat;
diff --git a/packages/wisi/wisitoken-generate.adb
b/packages/wisi/wisitoken-generate.adb
deleted file mode 100644
index c14077d..0000000
--- a/packages/wisi/wisitoken-generate.adb
+++ /dev/null
@@ -1,665 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Directories;
-with Ada.Real_Time;
-with Ada.Strings.Fixed;
-with Ada.Text_IO;
-package body WisiToken.Generate is
-
- function Error_Message
- (File_Name : in String;
- File_Line : in Line_Number_Type;
- Message : in String)
- return String
- is
- use Ada.Directories;
- use Ada.Strings.Fixed;
- use Ada.Strings;
- begin
- return Simple_Name (File_Name) & ":" &
- Trim (Line_Number_Type'Image (File_Line), Left) & ":0: " & Message;
- end Error_Message;
-
- procedure Put_Error (Message : in String)
- is begin
- Error := True;
- Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, Message);
- end Put_Error;
-
- procedure Check_Consistent
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Source_File_Name : in String)
- is begin
- if Descriptor.Accept_ID /= Descriptor.First_Nonterminal then
- Put_Error
- (Error_Message
- (Source_File_Name, Line_Number_Type'First,
- "Descriptor.Accept_ID /= Descriptor.First_Nonterminal"));
- end if;
- if Grammar.First_Index /= Descriptor.First_Nonterminal then
- Put_Error
- (Error_Message
- (Source_File_Name, Line_Number_Type'First,
- "Grammar.First_Index /= Descriptor.First_Nonterminal"));
- end if;
- if Grammar.Last_Index /= Descriptor.Last_Nonterminal then
- Put_Error
- (Error_Message
- (Source_File_Name, Line_Number_Type'First,
- "Grammar.Last_Index /= Descriptor.Last_Nonterminal"));
- end if;
-
- for Nonterm in Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal loop
- if Grammar (Nonterm).LHS /= Nonterm then
- Put_Error
- (Error_Message
- (Source_File_Name, Line_Number_Type'First,
- "Grammar (" & Image (Nonterm, Descriptor) & ").LHS = " &
- Image (Grammar (Nonterm).LHS, Descriptor) & " /= " &
- Image (Nonterm, Descriptor)));
- end if;
- end loop;
- end Check_Consistent;
-
- function Check_Unused_Tokens
- (Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
- return Boolean
- is
- subtype Terminals is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
- subtype Nonterminals is Token_ID range Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal;
-
- Used_Tokens : Token_ID_Set := (Descriptor.First_Terminal ..
Descriptor.Last_Nonterminal => False);
-
- Changed : Boolean := False;
- Abort_Generate : Boolean := False;
- Unused_Tokens : Boolean := False;
- begin
- Used_Tokens (Descriptor.Accept_ID) := True;
-
- -- First mark all nonterminals that occur in used nonterminals as
- -- used.
- loop
- for Prod of Grammar loop
- if Used_Tokens (Prod.LHS) then
- for RHS of Prod.RHSs loop
- for J of RHS.Tokens loop
- if J in Nonterminals then
- Changed := Changed or else not Used_Tokens (J);
- Used_Tokens (J) := True;
- end if;
- end loop;
- end loop;
- end if;
- end loop;
- exit when not Changed;
- Changed := False;
- end loop;
-
- -- Now mark terminals used in used nonterminals
- for Prod of Grammar loop
- if Used_Tokens (Prod.LHS) then
- for RHS of Prod.RHSs loop
- for J of RHS.Tokens loop
- if not (J in Used_Tokens'Range) then
- WisiToken.Generate.Put_Error
- ("non-grammar token " & Image (J, Descriptor) & " used
in grammar");
-
- -- This causes lots of problems with token_id not in
terminal or
- -- nonterminal range, so abort early.
- Abort_Generate := True;
- end if;
-
- if J in Terminals then
- Used_Tokens (J) := True;
- end if;
- end loop;
- end loop;
- end if;
- end loop;
-
- for I in Used_Tokens'Range loop
- if not Used_Tokens (I) then
- if not Unused_Tokens then
- WisiToken.Generate.Put_Error ("Unused tokens:");
- Unused_Tokens := True;
- end if;
- WisiToken.Generate.Put_Error (Image (I, Descriptor));
- end if;
- end loop;
-
- if Abort_Generate then
- raise Grammar_Error;
- end if;
-
- return Unused_Tokens;
- end Check_Unused_Tokens;
-
- function Nullable (Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
return Token_Array_Production_ID
- is
- use all type Ada.Containers.Count_Type;
-
- subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
-
- Result : Token_Array_Production_ID := (Nonterminal =>
Invalid_Production_ID);
- Changed : Boolean := True;
- begin
- loop
- exit when not Changed;
- Changed := False;
-
- for Prod of Grammar loop
- if Result (Prod.LHS) = Invalid_Production_ID then
- for RHS_Index in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index
loop
- declare
- RHS : WisiToken.Productions.Right_Hand_Side renames
Prod.RHSs (RHS_Index);
- begin
- if RHS.Tokens.Length = 0 or else
- (RHS.Tokens (1) in Nonterminal and then Result
(RHS.Tokens (1)) /= Invalid_Production_ID)
- then
- Result (Prod.LHS) := (Prod.LHS, RHS_Index);
- Changed := True;
- end if;
- end;
- end loop;
- end if;
- end loop;
- end loop;
- return Result;
- end Nullable;
-
- function Has_Empty_Production (Nullable : in Token_Array_Production_ID)
return Token_ID_Set
- is begin
- return Result : Token_ID_Set := (Nullable'First .. Nullable'Last =>
False) do
- for I in Result'Range loop
- Result (I) := Nullable (I) /= Invalid_Production_ID;
- end loop;
- end return;
- end Has_Empty_Production;
-
- function Has_Empty_Production (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Token_ID_Set
- is
- use all type Ada.Containers.Count_Type;
-
- subtype Nonterminal is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
-
- Result : Token_ID_Set := (Nonterminal => False);
- Changed : Boolean := True;
- begin
- loop
- exit when not Changed;
- Changed := False;
-
- for Prod of Grammar loop
- for RHS of Prod.RHSs loop
- if (RHS.Tokens.Length = 0 or else
- (RHS.Tokens (1) in Nonterminal and then Result
(RHS.Tokens (1)))) and
- not Result (Prod.LHS)
- then
- Result (Prod.LHS) := True;
- Changed := True;
- end if;
- end loop;
- end loop;
- end loop;
- return Result;
- end Has_Empty_Production;
-
- function First
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal : in Token_ID;
- Non_Terminal : in Token_ID)
- return Token_ID_Set
- is
- Search_Tokens : Token_ID_Set := (Grammar.First_Index ..
Grammar.Last_Index => False);
- begin
- Search_Tokens (Non_Terminal) := True;
-
- 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;
- Derivations := Derivations or Added_Tokens;
- Search_Tokens := Added_Nonterms;
- end;
- end loop;
- end return;
- end First;
-
- function First
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal : in Token_ID)
- return Token_Array_Token_Set
- is
- Matrix : Token_Array_Token_Set :=
- (Grammar.First_Index .. Grammar.Last_Index =>
- (First_Terminal .. Grammar.Last_Index => False));
-
- procedure Set_Slice (Matrix : in out Token_Array_Token_Set; I :
Token_ID; Value : in Token_ID_Set)
- is begin
- for J in Matrix'Range (2) loop
- Matrix (I, J) := Value (J);
- end loop;
- end Set_Slice;
-
- begin
- for NT_Index in Matrix'Range loop
- Set_Slice (Matrix, NT_Index, First (Grammar, Has_Empty_Production,
First_Terminal, NT_Index));
- end loop;
-
- return Matrix;
- end First;
-
- function To_Terminal_Sequence_Array
- (First : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return Token_Sequence_Arrays.Vector
- is
- subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
- begin
- return Result : Token_Sequence_Arrays.Vector do
- Result.Set_First_Last (First'First (1), First'Last (1));
-
- for I in First'Range (1) loop
- declare
- Row : Token_ID_Arrays.Vector renames Result (I);
- begin
- for J in First'Range (2) loop
- if First (I, J) and then J in Terminal then
- Row.Append (J);
- end if;
- end loop;
- end;
- end loop;
- end return;
- end To_Terminal_Sequence_Array;
-
- function Follow
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- First : in Token_Array_Token_Set;
- Has_Empty_Production : in Token_ID_Set)
- return Token_Array_Token_Set
- is
- subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
- subtype Nonterminal is Token_ID range Descriptor.First_Nonterminal ..
Descriptor.Last_Nonterminal;
-
- Prev_Result : Token_Array_Token_Set := (Nonterminal => (Terminal =>
False));
- Result : Token_Array_Token_Set := (Nonterminal => (Terminal =>
False));
-
- ID : Token_ID;
- begin
- -- [dragon] pgp 189:
- --
- -- Rule 1 Follow (S, EOF) = True; EOF is explicit in the
- -- start symbol production, so this is covered by Rule 2.
- --
- -- Rule 2: If A => alpha B Beta, add First (Beta) to Follow (B)
- --
- -- Rule 3; if A => alpha B, or A -> alpha B Beta and Beta
- -- can be null, add Follow (A) to Follow (B)
- --
- -- We don't assume any order in the productions list, so we
- -- have to keep applying rule 3 until nothing changes.
-
- for B in Nonterminal loop
- for Prod of Grammar loop
- for A of Prod.RHSs loop
- for I in A.Tokens.First_Index .. A.Tokens.Last_Index loop
- if A.Tokens (I) = B then
- if I < A.Tokens.Last_Index then
- -- Rule 1
- ID := A.Tokens (1 + I);
- if ID in Terminal then
- Result (B, ID) := True;
- else
- Or_Slice (Result, B, Slice (First, ID));
- end if;
- end if;
- end if;
- end loop;
- end loop;
- end loop;
- end loop;
-
- Prev_Result := Result;
- loop
- for B in Nonterminal loop
- for Prod of Grammar loop
- for A of Prod.RHSs loop
- for I in A.Tokens.First_Index .. A.Tokens.Last_Index loop
- if A.Tokens (I) = B then
- if I = A.Tokens.Last_Index or else
- (A.Tokens (1 + I) in Nonterminal and then
- Has_Empty_Production (A.Tokens (1 + I)))
- then
- -- rule 3
- Or_Slice (Result, B, Slice (Result, Prod.LHS));
- end if;
- end if;
- end loop;
- end loop;
- end loop;
- end loop;
-
- exit when Prev_Result = Result;
- Prev_Result := Result;
- end loop;
- return Result;
- end Follow;
-
- function To_Graph (Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
return Grammar_Graphs.Graph
- is
- subtype Nonterminals is Token_ID range Grammar.First_Index ..
Grammar.Last_Index;
- Graph : Grammar_Graphs.Graph;
- J : Integer := 1;
- begin
- if Trace_Generate_Minimal_Complete > Outline then
- Ada.Text_IO.Put_Line ("grammar graph:");
- end if;
-
- for LHS in Grammar.First_Index .. Grammar.Last_Index loop
- declare
- Prod : WisiToken.Productions.Instance renames Grammar (LHS);
- begin
- for RHS in Prod.RHSs.First_Index .. Prod.RHSs.Last_Index loop
- declare
- Tokens : Token_ID_Arrays.Vector renames Prod.RHSs
(RHS).Tokens;
- begin
- for I in Tokens.First_Index .. Tokens.Last_Index loop
- if Tokens (I) in Nonterminals then
- if Trace_Generate_Minimal_Complete > Detail then
- Ada.Text_IO.Put_Line
- ("(" & Trimmed_Image (LHS) & ", " & Trimmed_Image
(Tokens (I)) & "," & J'Image & ")");
- J := J + 1;
- end if;
- Graph.Add_Edge (LHS, Tokens (I), (RHS, I));
- end if;
- end loop;
- end;
- end loop;
- end;
- end loop;
-
- if Trace_Generate_Minimal_Complete > Outline then
- Ada.Text_IO.Put_Line ("..." & Graph.Count_Nodes'Image & " nodes" &
Graph.Count_Edges'Image & " edges.");
- end if;
- return Graph;
- end To_Graph;
-
- function Recursion
- (LHS : in Token_ID;
- Token_Index : in Positive;
- Tokens : in Token_ID_Arrays.Vector)
- return Recursion_Class
- is begin
- return
- (if Token_Index = Tokens.First_Index then
- (if LHS = Tokens (Tokens.First_Index)
- then Direct_Left
- else Other_Left)
- elsif Token_Index = Tokens.Last_Index then
- (if LHS = Tokens (Tokens.Last_Index)
- then Direct_Right
- else Other_Right)
- else Other);
- end Recursion;
-
- procedure Set_Grammar_Recursions
- (Recursions : in WisiToken.Generate.Recursions;
- Grammar : in out WisiToken.Productions.Prod_Arrays.Vector)
- is begin
- for LHS of Grammar loop
- for RHS of LHS.RHSs loop
- RHS.Recursion.Set_First_Last (RHS.Tokens.First_Index,
RHS.Tokens.Last_Index);
- end loop;
- end loop;
-
- for Path of Recursions.Recursions loop
- declare
- use WisiToken.Productions;
- Previous_Item_LHS : Token_ID :=
- (if Recursions.Full then Path (Path'Last).Vertex else
Token_ID'Last);
- begin
- for Item of Path loop
- for Edge of Item.Edges loop
- declare
- LHS : constant Token_ID := (if Recursions.Full then
Previous_Item_LHS else Item.Vertex);
- RHS : Right_Hand_Side renames Grammar (LHS).RHSs
(Edge.Data.RHS);
- begin
- RHS.Recursion (Edge.Data.Token_Index) := Recursion
- (LHS => LHS,
- Token_Index => Edge.Data.Token_Index,
- Tokens => RHS.Tokens);
- end;
- end loop;
- Previous_Item_LHS := Item.Vertex;
- end loop;
- end;
- end loop;
- end Set_Grammar_Recursions;
-
- function Compute_Full_Recursion
- (Grammar : in out WisiToken.Productions.Prod_Arrays.Vector;
- 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 :=
- (Full => True,
- Recursions => Graph.Find_Cycles)
- do
- Grammar_Graphs.Sort_Paths.Sort (Result.Recursions);
-
- 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:");
- WisiToken.Productions.Put (Grammar, Descriptor);
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("full recursions:");
- for I in Result.Recursions.First_Index ..
Result.Recursions.Last_Index loop
- Ada.Text_IO.Put_Line (Trimmed_Image (I) & " => " &
Grammar_Graphs.Image (Result.Recursions (I)));
- end loop;
- end if;
- end return;
- end Compute_Full_Recursion;
-
- function Compute_Partial_Recursion
- (Grammar : in out WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- 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);
- Loops : constant Vertex_Lists.List := Graph.Loops;
- begin
- return Result : Recursions do
- Result.Full := False;
- for Comp of Components loop
- declare
- Path : Recursion_Cycle (1 .. Integer (Comp.Length));
- Last : Integer := Path'First - 1;
- begin
- for V of Comp loop
- Last := Last + 1;
- Path (Last) := (V, Graph.Edges (V));
- end loop;
- Result.Recursions.Append (Path);
- end;
- end loop;
-
- declare
- Path : Recursion_Cycle (1 .. Integer (Loops.Length));
- Last : Integer := Path'First - 1;
- begin
- for V of Loops loop
- Last := Last + 1;
- Path (Last) := (V, Graph.Edges (V));
- end loop;
- Result.Recursions.Append (Path);
- end;
-
- 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:");
- WisiToken.Productions.Put (Grammar, Descriptor);
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("partial recursions:");
- for I in Result.Recursions.First_Index ..
Result.Recursions.Last_Index loop
- Ada.Text_IO.Put_Line (Trimmed_Image (I) & " => " &
Grammar_Graphs.Image (Result.Recursions (I)));
- end loop;
- end if;
- end return;
- end Compute_Partial_Recursion;
-
- ----------
- -- Indented text output
-
- procedure Indent_Line (Text : in String)
- is
- use Ada.Text_IO;
- begin
- Set_Col (Indent);
- Put_Line (Text);
- Line_Count := Line_Count + 1;
- end Indent_Line;
-
- procedure Indent_Start (Text : in String)
- is
- use Ada.Text_IO;
- begin
- Set_Col (Indent);
- Put (Text);
- end Indent_Start;
-
- procedure Indent_Wrap (Text : in String)
- is
- use all type Ada.Text_IO.Count;
- use Ada.Strings;
- use Ada.Strings.Fixed;
- I : Natural;
- First : Integer := Text'First;
- begin
- if Text'Length + Indent <= Max_Line_Length then
- Indent_Line (Text);
- else
- loop
- I := Text'Last;
- loop
- I := Index (Text (First .. Text'Last), " ", From => I, Going =>
Backward);
- exit when I - First + Integer (Indent) <= Max_Line_Length;
- I := I - 1;
- end loop;
- Indent_Line (Trim (Text (First .. I - 1), Right));
- First := I + 1;
- exit when Text'Last - First + Integer (Indent) <= Max_Line_Length;
- end loop;
- Indent_Line (Text (First .. Text'Last));
- end if;
- end Indent_Wrap;
-
- procedure Indent_Wrap_Comment (Text : in String; Comment_Syntax : in String)
- is
- use all type Ada.Text_IO.Count;
- use Ada.Strings;
- use Ada.Strings.Fixed;
- Prefix : constant String := Comment_Syntax & " ";
- I : Natural;
- First : Integer := Text'First;
- begin
- if Text'Length + Indent <= Max_Line_Length - 4 then
- Indent_Line (Prefix & Text);
- else
- loop
- I := Text'Last;
- loop
- I := Index (Text (First .. Text'Last), " ", From => I, Going =>
Backward);
- exit when I - First + Integer (Indent) <= Max_Line_Length - 4;
- I := I - 1;
- end loop;
- Indent_Line (Prefix & Text (First .. I - 1));
- First := I + 1;
- exit when Text'Last - First + Integer (Indent) <= Max_Line_Length
- 4;
- end loop;
- Indent_Line (Prefix & Text (First .. Text'Last));
- end if;
- end Indent_Wrap_Comment;
-
-end WisiToken.Generate;
diff --git a/packages/wisi/wisitoken-generate.ads
b/packages/wisi/wisitoken-generate.ads
deleted file mode 100644
index a9c4e5a..0000000
--- a/packages/wisi/wisitoken-generate.ads
+++ /dev/null
@@ -1,200 +0,0 @@
--- Abstract :
---
--- Types and operations for generating parsers, common to all parser
--- types.
---
--- The wisi* packages deal with reading *.wy files and generating
--- source code files. The wisitoken-generate* packages deal with
--- computing parser properties from the grammar. (For historical
--- reasons, not all packages follow this naming convention yet).
---
--- References :
---
--- See wisitoken.ads
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers.Doubly_Linked_Lists;
-with SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image;
-with SAL.Gen_Graphs;
-with WisiToken.Productions;
-package WisiToken.Generate is
-
- Error : Boolean := False;
- -- Set True by errors during grammar generation
-
- function Error_Message
- (File_Name : in String;
- File_Line : in WisiToken.Line_Number_Type;
- Message : in String)
- return String;
-
- procedure Put_Error (Message : in String);
- -- Set Error True, output Message to Standard_Error
-
- procedure Check_Consistent
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- Source_File_Name : in String);
- -- Check requirements on Descriptor values.
-
- function Check_Unused_Tokens
- (Descriptor : in WisiToken.Descriptor;
- Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
- return Boolean;
- -- Return False if there is a terminal or nonterminal that is not
- -- used in the grammar.
- --
- -- Raises Grammar_Error if there is a non-grammar token used in the
- -- grammar.
-
- function Nullable (Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
return Token_Array_Production_ID;
- -- If ID is nullable, Result (ID) is the production that should be
- -- reduced to produce the null. Otherwise Result (ID) is
- -- Invalid_Production_ID.
-
- function Has_Empty_Production (Nullable : in Token_Array_Production_ID)
return Token_ID_Set;
- function Has_Empty_Production (Grammar : in
WisiToken.Productions.Prod_Arrays.Vector) return Token_ID_Set;
- -- Result (ID) is True if any production for ID can be an empty
- -- production, recursively.
-
- function First
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Has_Empty_Production : in Token_ID_Set;
- First_Terminal : in Token_ID)
- return Token_Array_Token_Set;
- -- For each nonterminal in Grammar, find the set of tokens
- -- (terminal or nonterminal) that any string derived from it can
- -- start with. Together with Has_Empty_Production, implements
- -- algorithm FIRST from [dragon], augmented with nonterminals.
- --
- -- LALR, LR1 generate want First as both Token_Sequence_Arrays.Vector
- -- and Token_Array_Token_Set, Packrat wants Token_Array_Token_Set,
- -- existing tests all use Token_Array_Token_Set. So for LR1 we use
- -- To_Terminal_Sequence_Array.
-
- function To_Terminal_Sequence_Array
- (First : in Token_Array_Token_Set;
- Descriptor : in WisiToken.Descriptor)
- return Token_Sequence_Arrays.Vector;
- -- Only includes terminals.
-
- function Follow
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor;
- First : in Token_Array_Token_Set;
- Has_Empty_Production : in Token_ID_Set)
- return Token_Array_Token_Set;
- -- For each nonterminal in Grammar, find the set of terminal
- -- tokens that can follow it. Implements algorithm FOLLOW from
- -- [dragon] pg 189.
-
- ----------
- -- Recursion
-
- -- Recursion is the result of a cycle in the grammar. We can form a
- -- graph representing the grammar by taking the nonterminals as the
- -- graph vertices, and the occurrence of a nonterminal in a
- -- production right hand side as a directed edge from the left hand
- -- side of the production to that nonterminal. Then recursion is
- -- represented by a cycle in the graph.
-
- type Edge_Data is record
- -- The edge leading to this node.
- RHS : Natural := Natural'Last;
- Token_Index : Positive := Positive'Last;
- end record;
-
- function Edge_Image (Edge : in Edge_Data) return String is (Trimmed_Image
(Edge.RHS));
-
- type Base_Recursion_Index is range 0 .. Integer'Last;
- subtype Recursion_Index is Base_Recursion_Index range 1 ..
Base_Recursion_Index'Last;
- Invalid_Recursion_Index : constant Base_Recursion_Index := 0;
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Base_Recursion_Index);
-
- package Grammar_Graphs is new SAL.Gen_Graphs
- (Edge_Data => Generate.Edge_Data,
- Default_Edge_Data => (others => <>),
- Vertex_Index => Token_ID,
- Invalid_Vertex => Invalid_Token_ID,
- Path_Index => Recursion_Index,
- Edge_Image => Edge_Image);
-
- subtype Recursion_Cycle is Grammar_Graphs.Path;
- -- A recursion, with lowest numbered production first. If there is
- -- only one element, the recursion is direct; otherwise indirect.
-
- subtype Recursion_Array is Grammar_Graphs.Path_Arrays.Vector;
- -- For the collection of all cycles.
-
- type Recursions is record
- Full : Boolean;
- Recursions : Recursion_Array;
- -- If Full, elements are paths; edges at path (I) are to path (I). If
- -- not Full, elements are strongly connected components; edges at
- -- path (I) are from path (I).
- end record;
-
- package Recursion_Lists is new Ada.Containers.Doubly_Linked_Lists
(Recursion_Index);
- function Image is new SAL.Ada_Containers.Gen_Doubly_Linked_Lists_Image
- (Recursion_Index, "=", Recursion_Lists, Trimmed_Image);
-
- function To_Graph (Grammar : in WisiToken.Productions.Prod_Arrays.Vector)
return Grammar_Graphs.Graph;
-
- function Compute_Full_Recursion
- (Grammar : in out WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return Recursions;
- -- Each element of result is a cycle in the grammar. Also sets
- -- Recursive components in Grammar.
-
- function Compute_Partial_Recursion
- (Grammar : in out WisiToken.Productions.Prod_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return Recursions;
- -- Each element of the result contains all members of a non-trivial
- -- strongly connected component in the grammar, in arbitrary order.
- -- This is an approximation to the full recursion, when that is too
- -- hard to compute (ie for Java).
- --
- -- Also sets Recursive components in Grammar.
-
- ----------
- -- Indented text output. Mostly used for code generation in wisi,
- -- also used in outputing the parse_table and other debug stuff.
-
- Max_Line_Length : constant := 120;
-
- Indent : Standard.Ada.Text_IO.Positive_Count := 1;
- Line_Count : Integer;
-
- procedure Indent_Line (Text : in String);
- -- Put Text, indented to Indent, to Current_Output, with newline.
-
- procedure Indent_Start (Text : in String);
- -- Put Text indented to Indent to Current_Output, without newline.
- -- Should be followed by Put_Line, not Indent_Line.
-
- procedure Indent_Wrap (Text : in String);
- -- Put Text, indented to Indent, wrapped at Max_Line_Length, to
- -- Current_Output, ending with newline.
-
- procedure Indent_Wrap_Comment (Text : in String; Comment_Syntax : in
String);
- -- Put Text, prefixed by Comment_Syntax and two spaces, indented to
- -- Indent, wrapped at Max_Line_Length, to Current_Output, ending with
- -- newline.
-
-end WisiToken.Generate;
diff --git a/packages/wisi/wisitoken-lexer-re2c.adb
b/packages/wisi/wisitoken-lexer-re2c.adb
deleted file mode 100644
index 46cccb6..0000000
--- a/packages/wisi/wisitoken-lexer-re2c.adb
+++ /dev/null
@@ -1,307 +0,0 @@
--- Abstract:
---
--- see spec.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Directories;
-with Ada.Strings.Unbounded;
-with GNATCOLL.Mmap;
-package body WisiToken.Lexer.re2c is
-
- overriding procedure Finalize (Object : in out Instance)
- is
- use all type System.Address;
- begin
- if Object.Lexer /= System.Null_Address then
- Free_Lexer (Object.Lexer);
- Object.Lexer := System.Null_Address;
- end if;
-
- Finalize (Object.Source);
- end Finalize;
-
- type Instance_Access is access Instance; -- silence compiler warning
-
- function New_Lexer
- (Descriptor : not null access constant WisiToken.Descriptor)
- return Handle
- is begin
- return Handle (Instance_Access'(new Instance (Descriptor)));
- end New_Lexer;
-
- overriding procedure Reset_With_String
- (Lexer : in out Instance;
- Input : in String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First)
- is begin
- Finalize (Lexer);
-
- -- We assume Input is in UTF-8 encoding
- Lexer.Source :=
- (Label => String_Label,
- File_Name => +"",
- Buffer_Nominal_First_Byte => Base_Buffer_Pos (Input'First),
- Buffer_Nominal_First_Char => Begin_Char,
- Line_Nominal_First => Begin_Line,
- Buffer => new String'(Input),
- User_Buffer => False);
-
- Lexer.Lexer := New_Lexer
- (Buffer => Lexer.Source.Buffer.all'Address,
- Length => Interfaces.C.size_t (Input'Length),
- Verbosity => Interfaces.C.int (if Trace_Parse > 3 then Trace_Parse -
3 else 0));
-
- Reset (Lexer);
- end Reset_With_String;
-
- overriding procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First)
- is begin
- Finalize (Lexer);
-
- -- We assume Input is in UTF-8 encoding
- Lexer.Source :=
- (Label => String_Label,
- File_Name =>
- +(if Ada.Strings.Unbounded.Length (File_Name) = 0 then ""
- else Ada.Directories.Simple_Name (-File_Name)),
- Buffer_Nominal_First_Byte => Base_Buffer_Pos (Input'First),
- Buffer_Nominal_First_Char => Begin_Char,
- Line_Nominal_First => Begin_Line,
- Buffer => Input,
- User_Buffer => True);
-
- Lexer.Lexer := New_Lexer
- (Buffer => Lexer.Source.Buffer.all'Address,
- Length => Interfaces.C.size_t (Input'Length),
- Verbosity => Interfaces.C.int (if Trace_Parse > 3 then Trace_Parse -
3 else 0));
-
- Reset (Lexer);
- end Reset_With_String_Access;
-
- overriding procedure Reset_With_File
- (Lexer : in out Instance;
- File_Name : in String;
- Begin_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- End_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First)
- is
- use GNATCOLL.Mmap;
- Length : Buffer_Pos;
- begin
- Finalize (Lexer);
-
- -- We assume the file is in UTF-8 encoding
- Lexer.Source :=
- (File_Label, +Ada.Directories.Simple_Name (File_Name),
- Buffer_Nominal_First_Byte => Buffer_Pos'First, -- overwritten below,
- Buffer_Nominal_First_Char => Begin_Char,
- Line_Nominal_First => Line_Number_Type'First, -- overwritten
below
- File => Open_Read (File_Name),
- Region => Invalid_Mapped_Region,
- Buffer_Last => 1);
-
- if Begin_Byte_Pos = Invalid_Buffer_Pos then
- Lexer.Source.Region := Read (Lexer.Source.File);
- Length := Buffer_Pos (Last (Lexer.Source.Region));
- else
- Length := End_Byte_Pos - Begin_Byte_Pos + 1;
-
- Lexer.Source.Buffer_Nominal_First_Byte := Begin_Byte_Pos;
- Lexer.Source.Line_Nominal_First := Begin_Line;
-
- Lexer.Source.Region := Read
- (Lexer.Source.File,
- Offset => File_Size (Begin_Byte_Pos - 1), -- Offset is 0 indexed,
Begin_Byte_Pos is 1 indexed
- Length => File_Size (Length));
- end if;
-
- Lexer.Source.Buffer_Last := Last (Lexer.Source.Region);
-
- Lexer.Lexer := New_Lexer
- (Buffer => Data (Lexer.Source.Region).all'Address,
- Length => Interfaces.C.size_t (Length),
- Verbosity => Interfaces.C.int (if Trace_Parse > 3 then Trace_Parse -
3 else 0));
-
- Reset (Lexer);
- end Reset_With_File;
-
- overriding procedure Reset (Lexer : in out Instance)
- is begin
- Reset_Lexer (Lexer.Lexer);
- Lexer.Line := 1;
- Lexer.Char_Line_Start := 1;
- Lexer.ID :=
- -- First token is assumed to be first on a line.
- (if Lexer.Descriptor.New_Line_ID = Invalid_Token_ID
- then Invalid_Token_ID
- else Lexer.Descriptor.New_Line_ID);
- Lexer.Prev_ID := Invalid_Token_ID;
- end Reset;
-
- overriding function Find_Next
- (Lexer : in out Instance;
- Token : out Base_Token)
- return Boolean
- is
- use Interfaces.C;
-
- procedure Build_Token
- is begin
- Token :=
- (ID => Lexer.ID,
- Tree_Index => Invalid_Node_Index,
-
- Byte_Region =>
- (if Lexer.ID = Lexer.Descriptor.EOI_ID and then
Lexer.Byte_Position = Integer (Base_Buffer_Pos'First)
- then
- -- EOF in empty buffer
- (Lexer.Source.Buffer_Nominal_First_Byte,
- Lexer.Source.Buffer_Nominal_First_Byte - 1)
- else
- (Base_Buffer_Pos (Lexer.Byte_Position) +
Lexer.Source.Buffer_Nominal_First_Byte - Buffer_Pos'First,
- Base_Buffer_Pos (Lexer.Byte_Position + Lexer.Byte_Length -
1) +
- Lexer.Source.Buffer_Nominal_First_Byte -
Buffer_Pos'First)),
-
- Line => Lexer.Line + Lexer.Source.Line_Nominal_First -
Line_Number_Type'First,
-
- Column =>
- (if Lexer.ID = Lexer.Descriptor.New_Line_ID or
- Lexer.ID = Lexer.Descriptor.EOI_ID
- then 0
- else Ada.Text_IO.Count (Lexer.Char_Position -
Lexer.Char_Line_Start)),
-
- Char_Region =>
- (if Lexer.ID = Lexer.Descriptor.EOI_ID and then
Lexer.Byte_Position = Integer (Base_Buffer_Pos'First)
- then
- -- EOF in empty buffer
- (Lexer.Source.Buffer_Nominal_First_Byte,
- Lexer.Source.Buffer_Nominal_First_Byte - 1)
- else
- (To_Char_Pos (Lexer.Source, Lexer.Char_Position),
- To_Char_Pos (Lexer.Source, Lexer.Char_Position +
Lexer.Char_Length - 1))));
- end Build_Token;
-
- begin
- Lexer.Prev_ID := Lexer.ID;
- loop
- declare
- Status : constant int := Next_Token
- (Lexer.Lexer, Lexer.ID,
- Byte_Position => Interfaces.C.size_t (Lexer.Byte_Position),
- Byte_Length => Interfaces.C.size_t (Lexer.Byte_Length),
- Char_Position => Interfaces.C.size_t (Lexer.Char_Position),
- Char_Length => Interfaces.C.size_t (Lexer.Char_Length),
- Line_Start => Interfaces.C.int (Lexer.Line));
- begin
- case Status is
- when 0 =>
- if Lexer.ID = Lexer.Descriptor.New_Line_ID then
- Lexer.Char_Line_Start := Lexer.Char_Position + 1;
- end if;
-
- Build_Token;
- return False;
-
- when 1 =>
- -- Unrecognized character from lexer. Handle missing quotes by
- -- inserting a virtual quote at the existing quote, and
telling the
- -- lexer to skip the char.
- declare
- Buffer : constant GNATCOLL.Mmap.Str_Access :=
WisiToken.Lexer.Buffer (Lexer.Source);
- begin
- if Trace_Parse > Lexer_Debug then
- -- We don't have a visible Trace object here.
- Ada.Text_IO.Put_Line ("lexer error char " & Buffer
(Lexer.Byte_Position));
- end if;
-
- if Buffer (Lexer.Byte_Position) = ''' then
- -- Lexer has read to next new-line (or eof), then
backtracked to next
- -- char after '.
- Lexer.Errors.Append
- ((To_Char_Pos (Lexer.Source, Lexer.Char_Position),
- Invalid_Token_Index,
- (1 => ''', others => ASCII.NUL)));
-
- Lexer.ID := Lexer.Descriptor.String_1_ID;
- Build_Token;
- return True;
-
- elsif Buffer (Lexer.Byte_Position) = '"' then
- -- Lexer has read to next new-line (or eof), then
backtracked to next
- -- char after ".
- Lexer.Errors.Append
- ((To_Char_Pos (Lexer.Source, Lexer.Char_Position),
- Invalid_Token_Index,
- (1 => '"', others => ASCII.NUL)));
-
- Lexer.ID := Lexer.Descriptor.String_2_ID;
- Build_Token;
- return True;
-
- else
- -- Just skip the character; call Next_Token again.
- Lexer.Errors.Append
- ((To_Char_Pos (Lexer.Source, Lexer.Char_Position),
Invalid_Token_Index, (others => ASCII.NUL)));
- end if;
- end;
-
- when others =>
- raise Fatal_Error with " lexer returned unrecognized status
code" & int'Image (Status);
- end case;
- end;
- end loop;
- end Find_Next;
-
- overriding function First (Lexer : in Instance) return Boolean
- is begin
- return Lexer.Descriptor.New_Line_ID /= Invalid_Token_ID and then
- Lexer.Prev_ID = Lexer.Descriptor.New_Line_ID;
- end First;
-
- overriding function Buffer_Text (Lexer : in Instance; Byte_Bounds : in
Buffer_Region) return String
- is
- First : constant Integer := Integer
- (Byte_Bounds.First - Lexer.Source.Buffer_Nominal_First_Byte +
Buffer_Pos'First);
- Last : constant Integer := Integer
- (Byte_Bounds.Last - Lexer.Source.Buffer_Nominal_First_Byte +
Buffer_Pos'First);
- begin
- return String (Buffer (Lexer.Source) (First .. Last));
- end Buffer_Text;
-
- overriding function File_Name (Lexer : in Instance) return String
- is begin
- return File_Name (Lexer.Source);
- end File_Name;
-
-end WisiToken.Lexer.re2c;
diff --git a/packages/wisi/wisitoken-lexer-re2c.ads
b/packages/wisi/wisitoken-lexer-re2c.ads
deleted file mode 100644
index b871e9c..0000000
--- a/packages/wisi/wisitoken-lexer-re2c.ads
+++ /dev/null
@@ -1,144 +0,0 @@
--- Abstract:
---
--- WisiToken wrapper around the re2c lexer
---
--- References:
---
--- [1] http://re2c.org/
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-pragma License (GPL); -- GNATCOLL.Mmap
-
-pragma Warnings (Off, "license of withed unit ""GNATCOLL.Mmap"" may be
inconsistent");
-
-pragma Warnings (On);
-with Interfaces.C;
-with System;
-generic
- -- These subprograms are provided by generated source code.
-
- with function New_Lexer
- (Buffer : in System.Address;
- Length : in Interfaces.C.size_t;
- Verbosity : in Interfaces.C.int)
- return System.Address;
- -- Create the re2c lexer object, passing it the full text to process.
- -- Length is buffer length in 8 bit bytes.
- --
- -- The C lexer does not know about Buffer_Nominal_First,
- -- Line_Nominal_First; its buffer positions and lines start at 1.
-
- with procedure Free_Lexer (Lexer : in out System.Address);
- -- Destruct the re2c lexer object
-
- with procedure Reset_Lexer (Lexer : in System.Address);
- -- Restart lexing, with previous input buffer.
-
- with function Next_Token
- (Lexer : in System.Address;
- ID : out Token_ID;
- Byte_Position : out Interfaces.C.size_t;
- Byte_Length : out Interfaces.C.size_t;
- Char_Position : out Interfaces.C.size_t;
- Char_Length : out Interfaces.C.size_t;
- Line_Start : out Interfaces.C.int)
- return Interfaces.C.int;
- -- *_Position and *_Length give the position and length in bytes and
- -- characters of the token from the start of the buffer, 0 indexed.
- --
- -- Line_Start gives the line number in the source file that the first
- -- character of the token is in, 1 indexed.
- --
- -- Result values:
- --
- -- 0 - no error
- -- 1 - there is an unrecognized character at Position.
-
-package WisiToken.Lexer.re2c is
-
- Invalid_Input : exception;
-
- type Instance is new WisiToken.Lexer.Instance with private;
-
- overriding procedure Finalize (Object : in out Instance);
-
- function New_Lexer
- (Descriptor : not null access constant WisiToken.Descriptor)
- return WisiToken.Lexer.Handle;
- -- If the tokens do not include a reporting New_Line token, set
- -- New_Line_ID to Invalid_Token_ID.
-
- overriding procedure Reset_With_String
- (Lexer : in out Instance;
- Input : in String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First);
- -- Copies Input to internal buffer.
-
- overriding procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First);
-
- overriding procedure Reset_With_File
- (Lexer : in out Instance;
- File_Name : in String;
- Begin_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- End_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First);
- -- Uses memory mapped file; no copies.
-
- overriding procedure Discard_Rest_Of_Input (Lexer : in out Instance) is
null;
-
- overriding procedure Reset (Lexer : in out Instance);
-
- overriding function Buffer_Text (Lexer : in Instance; Byte_Bounds : in
Buffer_Region) return String;
-
- overriding function First (Lexer : in Instance) return Boolean;
-
- overriding
- function Find_Next
- (Lexer : in out Instance;
- Token : out Base_Token)
- return Boolean;
-
- overriding function File_Name (Lexer : in Instance) return String;
-
-private
-
- type Instance is new WisiToken.Lexer.Instance with
- record
- Lexer : System.Address := System.Null_Address;
- Source : WisiToken.Lexer.Source;
- ID : Token_ID; -- Last token read by find_next
- Byte_Position : Natural; -- We don't use Buffer_Pos here, because
Source.Buffer is indexed by Integer
- Byte_Length : Natural;
- Char_Position : Natural;
- Char_Length : Natural;
- -- Position and length in bytes and characters of last token from
- -- start of Managed.Buffer, 1 indexed.
-
- Line : Line_Number_Type; -- after last (or current) New_Line
token
- Char_Line_Start : Natural; -- Character position after last
New_Line token, lexer origin.
- Prev_ID : Token_ID; -- previous token_id
- end record;
-
-end WisiToken.Lexer.re2c;
diff --git a/packages/wisi/wisitoken-lexer-regexp.adb
b/packages/wisi/wisitoken-lexer-regexp.adb
deleted file mode 100644
index d464289..0000000
--- a/packages/wisi/wisitoken-lexer-regexp.adb
+++ /dev/null
@@ -1,259 +0,0 @@
--- Abstract:
---
--- See spec
---
--- Copyright (C) 2015, 2017 - 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Characters.Latin_1;
-with SAL;
-package body WisiToken.Lexer.Regexp is
-
- function Find_Best_Match (Lexer : in out Instance) return Boolean
- is
- -- Find the longest matching character sequence in the buffer that
- -- matches a token.
- --
- -- Return True if a token is matched, False if not.
-
- use WisiToken.Regexp;
-
- Current_Char : Integer := Lexer.Buffer_Head;
- Current_State : Match_State;
- Current_Match_Length : Integer := 0;
- Best_Match_ID : Token_ID;
- Best_Match_Length : Natural := 0;
- Still_Matching : Boolean := False;
- begin
- -- We only support Reset_With_String.
-
- if Current_Char > Lexer.Source.Buffer'Last then
- Lexer.ID := Lexer.Descriptor.EOI_ID;
- Lexer.Lexeme_Head := Lexer.Buffer_Head;
- Lexer.Lexeme_Tail := Lexer.Buffer_Head - 1;
- return True;
- end if;
-
- for I in Lexer.Syntax'Range loop
- Clear (Lexer.Syntax (I).Regexp);
- end loop;
-
- loop
- Still_Matching := False;
-
- for I in Lexer.Syntax'Range loop
- if State (Lexer.Syntax (I).Regexp) /= WisiToken.Regexp.Error then
- Current_State := Match
- (Lexer.Syntax (I).Regexp,
- Lexer.Source.Buffer (Lexer.Buffer_Head ..
Lexer.Source.Buffer'Last),
- Current_Char);
-
- case Current_State is
- when Matching =>
- Still_Matching := True;
-
- when Final =>
- Still_Matching := True;
-
- Current_Match_Length := Current_Char - Lexer.Buffer_Head + 1;
-
- if Best_Match_Length < Current_Match_Length then
- Best_Match_ID := I;
- Best_Match_Length := Current_Match_Length;
- end if;
-
- when WisiToken.Regexp.Error =>
- null;
- end case;
- end if;
- end loop;
-
- exit when (not Still_Matching) or else (Current_Char =
Lexer.Source.Buffer'Last);
-
- if Best_Match_Length = Lexer.Source.Buffer'Length then
- raise SAL.Programmer_Error with
- "token larger than buffer size of" & Integer'Image
(Lexer.Source.Buffer'Length);
- end if;
-
- Current_Char := Current_Char + 1;
- end loop;
-
- if Best_Match_Length > 0 then
- Lexer.Lexeme_Head := Lexer.Buffer_Head;
- Lexer.Lexeme_Tail := Lexer.Buffer_Head + Best_Match_Length - 1;
- Lexer.ID := Best_Match_ID;
-
- if Lexer.Lexeme_Head = Lexer.Source.Buffer'Last and
- Lexer.Source.Buffer (Lexer.Lexeme_Head) = Ada.Characters.Latin_1.EOT
- then
- -- matched EOF; repeat that next time
- null;
- else
- Lexer.Buffer_Head := Lexer.Lexeme_Tail + 1;
- end if;
- return True;
-
- elsif Current_Char = Lexer.Source.Buffer'Last then
- Lexer.ID := Lexer.Descriptor.EOI_ID;
- Lexer.Buffer_Head := Lexer.Buffer_Head + 1;
- return True;
-
- else
- return False;
- end if;
-
- end Find_Best_Match;
-
- ----------
- -- Public subprograms
-
- function Get
- (Regexp : in String;
- Case_Sensitive : in Boolean := True;
- Report : in Boolean := True)
- return Syntax_Item
- is begin
- return (WisiToken.Regexp.Compile (Regexp, Case_Sensitive), Report);
- end Get;
-
- type Instance_Access is access Instance; -- silence compiler warning
-
- function New_Lexer
- (Descriptor : not null access constant WisiToken.Descriptor;
- Syntax : in WisiToken.Lexer.Regexp.Syntax)
- return WisiToken.Lexer.Handle
- is
- New_Lexer : constant Instance_Access := new Instance (Descriptor,
Syntax'Last);
- begin
- New_Lexer.Syntax := Syntax;
-
- return Handle (New_Lexer);
- end New_Lexer;
-
- overriding procedure Finalize (Object : in out Instance)
- is begin
- Finalize (Object.Source);
- end Finalize;
-
- overriding procedure Reset_With_String
- (Lexer : in out Instance;
- Input : in String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First)
- is begin
- Finalize (Lexer);
-
- Lexer.Source :=
- (Label => String_Label,
- File_Name => +"",
- Buffer_Nominal_First_Byte => Base_Buffer_Pos (Input'First),
- Buffer_Nominal_First_Char => Begin_Char,
- Line_Nominal_First => Begin_Line,
- Buffer => new String'(Input),
- User_Buffer => False);
-
- Reset (Lexer);
- end Reset_With_String;
-
- overriding procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First)
- is begin
- Finalize (Lexer);
-
- Lexer.Source :=
- (Label => String_Label,
- File_Name => File_Name,
- Buffer_Nominal_First_Byte => Base_Buffer_Pos (Input'First),
- Buffer_Nominal_First_Char => Begin_Char,
- Line_Nominal_First => Begin_Line,
- Buffer => Input,
- User_Buffer => True);
-
- Reset (Lexer);
- end Reset_With_String_Access;
-
- overriding procedure Reset_With_File
- (Lexer : in out Instance;
- File_Name : in String;
- Begin_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- End_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First)
- is
- pragma Unreferenced (File_Name, Begin_Byte_Pos, End_Byte_Pos,
Begin_Char, Begin_Line);
- begin
- Finalize (Lexer);
-
- raise SAL.Not_Implemented;
- end Reset_With_File;
-
- overriding procedure Reset
- (Lexer : in out Instance)
- is begin
- Lexer.Lexeme_Head := Lexer.Source.Buffer'First;
- Lexer.Lexeme_Tail := Lexer.Source.Buffer'First - 1;
- Lexer.ID := Invalid_Token_ID;
- Lexer.Buffer_Head := Lexer.Source.Buffer'First;
- end Reset;
-
- overriding function Find_Next
- (Lexer : in out Instance;
- Token : out Base_Token)
- return Boolean
- is begin
- loop
- if not Find_Best_Match (Lexer) then
- if Lexer.Buffer_Head > Lexer.Source.Buffer'Last then
- raise Syntax_Error with "Unrecognized EOF";
- else
- raise Syntax_Error with "Unrecognized character '" &
Lexer.Source.Buffer (Lexer.Buffer_Head) & "'";
- end if;
- end if;
-
- exit when Lexer.Syntax (Lexer.ID).Report;
-
- end loop;
-
- Token :=
- (ID => Lexer.ID,
- Tree_Index => Invalid_Node_Index,
- Byte_Region => (Buffer_Pos (Lexer.Lexeme_Head), Buffer_Pos
(Lexer.Lexeme_Tail)),
- Line => Invalid_Line_Number,
- Column => Ada.Text_IO.Count (Lexer.Lexeme_Head),
- Char_Region => (Buffer_Pos (Lexer.Lexeme_Head), Buffer_Pos
(Lexer.Lexeme_Tail)));
-
- return False;
- end Find_Next;
-
- overriding function Buffer_Text (Lexer : in Instance; Byte_Region : in
Buffer_Region) return String
- is begin
- return Lexer.Source.Buffer (Integer (Byte_Region.First) .. Integer
(Byte_Region.Last));
- end Buffer_Text;
-
-end WisiToken.Lexer.Regexp;
diff --git a/packages/wisi/wisitoken-lexer-regexp.ads
b/packages/wisi/wisitoken-lexer-regexp.ads
deleted file mode 100644
index da55448..0000000
--- a/packages/wisi/wisitoken-lexer-regexp.ads
+++ /dev/null
@@ -1,114 +0,0 @@
--- Abstract:
---
--- WisiToken lexer using compiled regular expressions interpreted at runtime.
---
--- This is slower, but easier to use, than the Aflex lexer; it is
--- used in most of the WisiToken unit tests. Since it uses regexp, it
--- is easy to convert to an Aflex lexer.
---
--- Copyright (C) 2015, 2017 - 2019 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Unchecked_Deallocation;
-with WisiToken.Regexp;
-package WisiToken.Lexer.Regexp is
-
- type Syntax_Item is record
- Regexp : WisiToken.Regexp.Regexp;
- Report : Boolean;
- end record;
-
- function Get
- (Regexp : in String;
- Case_Sensitive : in Boolean := True;
- Report : in Boolean := True)
- return Syntax_Item;
- -- Compiles Regexp with Case_Sensitive.
-
- type Syntax is array (Token_ID range <>) of Syntax_Item;
-
- type Instance
- (Descriptor : not null access constant WisiToken.Descriptor;
- Last_Terminal : Token_ID)
- is new WisiToken.Lexer.Instance with private;
-
- function New_Lexer
- (Descriptor : not null access constant WisiToken.Descriptor;
- Syntax : in WisiToken.Lexer.Regexp.Syntax)
- return WisiToken.Lexer.Handle;
-
- overriding procedure Finalize (Object : in out Instance);
- overriding procedure Reset_With_String
- (Lexer : in out Instance;
- Input : in String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First);
- overriding procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First);
- overriding procedure Reset_With_File
- (Lexer : in out Instance;
- File_Name : in String;
- Begin_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- End_Byte_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First);
- overriding procedure Reset (Lexer : in out Instance);
-
- overriding procedure Discard_Rest_Of_Input (Lexer : in out Instance) is
null;
-
- overriding function Find_Next
- (Lexer : in out Instance;
- Token : out Base_Token)
- return Boolean;
-
- overriding function Buffer_Text (Lexer : in Instance; Byte_Region : in
Buffer_Region) return String;
-
- overriding function First (Lexer : in Instance) return Boolean is (False);
-
- overriding function File_Name (Lexer : in Instance) return String is ("");
-
-private
-
- type String_Access is access String;
- procedure Free is new Ada.Unchecked_Deallocation (String, String_Access);
-
- type Instance
- (Descriptor : not null access constant WisiToken.Descriptor;
- Last_Terminal : Token_ID)
- is new WisiToken.Lexer.Instance (Descriptor => Descriptor) with
- record
- ID : Token_ID; -- last token read by find_next
- Syntax : WisiToken.Lexer.Regexp.Syntax (Token_ID'First ..
Last_Terminal);
- Source : Lexer.Source;
- Buffer_Head : Integer;
- Lexeme_Head : Integer;
- Lexeme_Tail : Integer;
- end record;
-
-end WisiToken.Lexer.Regexp;
diff --git a/packages/wisi/wisitoken-lexer.adb
b/packages/wisi/wisitoken-lexer.adb
deleted file mode 100644
index f73d517..0000000
--- a/packages/wisi/wisitoken-lexer.adb
+++ /dev/null
@@ -1,61 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with GNAT.Strings;
-package body WisiToken.Lexer is
-
- procedure Finalize (Object : in out Source)
- is begin
- case Object.Label is
- when String_Label =>
- if not Object.User_Buffer then
- Ada.Strings.Unbounded.Free (Object.Buffer);
- end if;
-
- when File_Label =>
- GNATCOLL.Mmap.Free (Object.Region);
- GNATCOLL.Mmap.Close (Object.File);
- end case;
- end Finalize;
-
- function Buffer (Source : in Lexer.Source) return GNATCOLL.Mmap.Str_Access
- is
- use GNATCOLL.Mmap;
- begin
- case Source.Label is
- when String_Label =>
- return Short.To_Str_Access (GNAT.Strings.String_Access
(Source.Buffer));
-
- when File_Label =>
- return Data (Source.Region);
- end case;
-
- end Buffer;
-
- function File_Name (Source : in Lexer.Source) return String
- is begin
- return -Source.File_Name;
- end File_Name;
-
- function To_Char_Pos (Source : in Lexer.Source; Lexer_Char_Pos : in
Integer) return Base_Buffer_Pos
- is begin
- return Base_Buffer_Pos (Lexer_Char_Pos) +
Source.Buffer_Nominal_First_Char - Buffer_Pos'First;
- end To_Char_Pos;
-
-end WisiToken.Lexer;
diff --git a/packages/wisi/wisitoken-lexer.ads
b/packages/wisi/wisitoken-lexer.ads
deleted file mode 100644
index 3de31c7..0000000
--- a/packages/wisi/wisitoken-lexer.ads
+++ /dev/null
@@ -1,187 +0,0 @@
--- Abstract :
---
--- An abstract lexer interface.
---
--- Copyright (C) 2014 - 2015, 2017 - 2019 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-pragma Warnings (Off, "license of withed unit ""GNATCOLL.Mmap"" may be
inconsistent");
-
-with Ada.Containers.Doubly_Linked_Lists;
-with Ada.Finalization;
-with Ada.Strings.Unbounded;
-with GNATCOLL.Mmap;
-package WisiToken.Lexer is
-
- type Error is record
- Char_Pos : Buffer_Pos := Invalid_Buffer_Pos;
- -- Character at that position is not recognized as part of a token.
-
- Recover_Token : Base_Token_Index := Invalid_Token_Index;
- -- If the error was corrected by inserting a missing quote, the token
- -- (in shared parser Terminals) that was returned.
-
- Recover_Char : String (1 .. 4) := (others => ASCII.NUL);
- -- If the error was corrected, the character (in UTF-8 encoding) that
- -- was inserted; unused trailing bytes set to ASCII.NUL. Otherwise,
- -- all ASCII.Nul.
- end record;
-
- package Error_Lists is new Ada.Containers.Doubly_Linked_Lists (Error);
-
- type Instance (Descriptor : not null access constant WisiToken.Descriptor)
- is abstract new Ada.Finalization.Limited_Controlled with record
- Errors : Error_Lists.List;
- end record;
-
- subtype Class is Instance'Class;
-
- type Handle is access all Class;
-
- procedure Reset_With_String
- (Lexer : in out Instance;
- Input : in String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First)
- is abstract;
- -- Reset Lexer to start a new parse, reading from Input.
-
- procedure Reset_With_String_Access
- (Lexer : in out Instance;
- Input : in Ada.Strings.Unbounded.String_Access;
- File_Name : in Ada.Strings.Unbounded.Unbounded_String;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First)
- is abstract;
- -- Reset Lexer to start a new parse, reading from Input. File_Name is
- -- used for error messages.
-
- procedure Reset_With_File
- (Lexer : in out Instance;
- File_Name : in String;
- Begin_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- End_Pos : in Buffer_Pos := Invalid_Buffer_Pos;
- Begin_Char : in Buffer_Pos := Buffer_Pos'First;
- Begin_Line : in Line_Number_Type := Line_Number_Type'First)
- is abstract;
- -- Reset Lexer to start a new parse, reading from File_Name. If
- -- Begin_Pos, End_Pos /= Invalid_Buffer_Pos, only parse that portion
- -- of the file.
- --
- -- Raises Ada.IO_Exceptions.Name_Error if File_Name cannot be opened.
-
- procedure Reset (Lexer : in out Instance) is abstract;
- -- Reset Lexer, read from previous source.
-
- procedure Discard_Rest_Of_Input (Lexer : in out Instance) is abstract;
- -- If reading input from a stream, abort reading (or force it to
- -- complete); Find_Next will not be called before another Reset.
-
- function Buffer_Text (Lexer : in Instance; Byte_Region : in Buffer_Region)
return String is abstract;
- -- Return text from internal buffer, given region in byte position.
-
- function First (Lexer : in Instance) return Boolean is abstract;
- -- True if most recent token is first on a line.
-
- function Find_Next
- (Lexer : in out Instance;
- Token : out Base_Token)
- return Boolean is abstract;
- -- Set Token to the next token from the input stream.
- --
- -- If there is a recovered error, adds an entry to Lexer.Errors (with
- -- Recover_Token invalid). Unrecognized characters are skipped;
- -- missing quotes are inserted at the found quote. There can be more
- -- than one error entry for one call to Find_Next, if several
- -- unrecognized characters are skipped. If the recovery inserted a
- -- missing quote, it is the last entry in Errors, the returned token
- -- is an empty string literal, and Find_Next returns True.
- --
- -- If there is a non-recoverable error, raises Fatal_Error with an
- -- appropriate message.
- --
- -- Otherwise returns False.
- --
- -- Token.Char_Region, Token.Byte_Region are the character and byte
- -- position of the start and end of token, in the internal buffer,
- -- 1-indexed. Char_Region and Byte_Region differ when text is UTF-8
- -- or other multi-byte encoding, and when line endings are two byte.
- --
- -- Token.Line is the line number in which recent token starts.
- -- If the underlying text feeder does not support the notion of
- -- 'line', returns Invalid_Line_Number.
- --
- -- Token.Column is the column number of the start of the token, 1
- -- indexed. If the underlying text feeder does not support the notion
- -- of 'line', returns byte position in internal buffer.
-
- function File_Name (Lexer : in Instance) return String is abstract;
- -- Return input file name; empty string if there is no file.
-
-private
-
- type Source_Labels is (String_Label, File_Label);
-
- type Source (Label : Source_Labels := Source_Labels'First) is record
- File_Name : Ada.Strings.Unbounded.Unbounded_String;
- -- Not saved in Mapped_File, may be empty for String_Label
-
- Buffer_Nominal_First_Byte : Buffer_Pos;
- Buffer_Nominal_First_Char : Buffer_Pos;
- Line_Nominal_First : Line_Number_Type;
-
- case Label is
- when String_Label =>
- Buffer : Ada.Strings.Unbounded.String_Access;
- User_Buffer : Boolean := False;
- -- If User_Buffer is True, user provided buffer and will deallocate
- -- it. Otherwise we must deallocate it.
-
- -- Buffer_Nominal_First, Line_Nominal_First are 1.
- when File_Label =>
-
- -- The input is memory mapped from the following, which must be
closed:
- File : GNATCOLL.Mmap.Mapped_File;
- Region : GNATCOLL.Mmap.Mapped_Region;
- Buffer_Last : Positive;
- -- Region always has first character at offset 0.
-
- -- Buffer_Nominal_First is Begin_Pos. Line_Nominal_First is
- -- Begin_Line.
- end case;
- end record;
-
- procedure Finalize (Object : in out Source);
-
- function Buffer (Source : in Lexer.Source) return GNATCOLL.Mmap.Str_Access;
- -- The bounds on the result are not present; 'First, 'Last are not
- -- reliable. If Source_Label is String_label, actual bounds are
- -- Source.Buffer'First, 'Last. Otherwise, actual bounds are 1 ..
- -- Source.Buffer_Last. Indexing is reliable.
-
- function File_Name (Source : in Lexer.Source) return String;
- function To_Char_Pos (Source : in Lexer.Source; Lexer_Char_Pos : in
Integer) return Base_Buffer_Pos;
-
-end WisiToken.Lexer;
diff --git a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-base.adb
b/packages/wisi/wisitoken-parse-lr-mckenzie_recover-base.adb
deleted file mode 100644
index 344461b..0000000
--- a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-base.adb
+++ /dev/null
@@ -1,451 +0,0 @@
--- Abstract :
---
--- Base utilities for McKenzie_Recover
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with GNAT.Traceback.Symbolic;
-package body WisiToken.Parse.LR.McKenzie_Recover.Base is
-
- function Get_Barrier
- (Parsers : not null access Parser_Lists.List;
- Parser_Status : in Parser_Status_Array;
- Min_Success_Check_Count : in Natural;
- Total_Enqueue_Count : in Natural;
- Check_Delta_Limit : in Natural;
- Enqueue_Limit : in Natural)
- return Boolean
- is
- Done_Count : SAL.Base_Peek_Type := 0;
- Skip : Boolean;
- begin
- -- Return True if all parsers are done, or if any parser has a config
- -- available to check.
- for P_Status of Parser_Status loop
- Skip := False;
-
- case P_Status.Recover_State is
- when Active | Ready =>
- if P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
- if P_Status.Parser_State.Recover.Check_Count -
Check_Delta_Limit >= Min_Success_Check_Count then
- -- fail; another parser succeeded, this one taking too long.
- Done_Count := Done_Count + 1;
- Skip := True;
-
- elsif Total_Enqueue_Count +
P_Status.Parser_State.Recover.Config_Full_Count >= Enqueue_Limit then
- -- fail
- Done_Count := Done_Count + 1;
- Skip := True;
- end if;
- end if;
-
- if not Skip then
- case P_Status.Recover_State is
- when Active =>
- if P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
- -- Still working
- return True;
- else
- if P_Status.Active_Workers = 0 then
- -- fail; no configs left to check.
- Done_Count := Done_Count + 1;
- end if;
- end if;
-
- when Ready =>
- if P_Status.Parser_State.Recover.Config_Heap.Count > 0 and
then
- P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
P_Status.Parser_State.Recover.Results.Min_Key
- then
- -- Still more to check.
- return True;
-
- elsif P_Status.Active_Workers = 0 then
- Done_Count := Done_Count + 1;
- end if;
-
- when others =>
- null;
- end case;
- end if;
-
- when Success | Fail =>
- Done_Count := Done_Count + 1;
- end case;
- end loop;
-
- return Done_Count = Parsers.Count;
- end Get_Barrier;
-
- protected body Supervisor is
-
- procedure Initialize
- (Parsers : not null access Parser_Lists.List;
- Terminals : not null access constant Base_Token_Arrays.Vector)
- is
- Index : SAL.Peek_Type := 1;
- begin
- Supervisor.Parsers := Parsers;
- Supervisor.Terminals := Terminals;
- All_Parsers_Done := False;
- Success_Counter := 0;
- Min_Success_Check_Count := Natural'Last;
- Total_Enqueue_Count := 0;
- Fatal_Called := False;
- Result := Recover_Status'First;
- Error_ID := Ada.Exceptions.Null_Id;
-
- for I in Parsers.Iterate loop
- if Parsers.Reference (I).Recover_Insert_Delete_Current /=
Recover_Op_Arrays.No_Index then
- -- Previous error recovery resume not finished; this is
supposed to
- -- be checked in Parser.
- raise SAL.Programmer_Error;
- end if;
-
- Parser_Status (Index) :=
- (Recover_State => Active,
- Parser_State => Parser_Lists.Persistent_State_Ref (I),
- Fail_Mode => Success,
- Active_Workers => 0);
-
- declare
- Data : McKenzie_Data renames Parsers.Reference (I).Recover;
- begin
- Data.Config_Heap.Clear;
- Data.Results.Clear;
- Data.Enqueue_Count := 0;
- Data.Check_Count := 0;
- Data.Success := False;
- end;
-
- Index := Index + 1;
- end loop;
- end Initialize;
-
- entry Get
- (Parser_Index : out SAL.Base_Peek_Type;
- Config : out Configuration;
- Status : out Config_Status)
- when (Fatal_Called or All_Parsers_Done) or else Get_Barrier
- (Parsers, Parser_Status, Min_Success_Check_Count,
Total_Enqueue_Count, Check_Delta_Limit, Enqueue_Limit)
- is
- Done_Count : SAL.Base_Peek_Type := 0;
- Skip : Boolean;
- Min_Cost : Integer := Integer'Last;
- Min_Cost_Index : SAL.Base_Peek_Type;
-
- procedure Set_Outputs (I : in SAL.Peek_Type)
- is begin
- Parser_Index := I;
- Config := Parser_Status
(I).Parser_State.Recover.Config_Heap.Remove;
- Status := Valid;
-
- Parser_Status (I).Parser_State.Recover.Check_Count :=
- Parser_Status (I).Parser_State.Recover.Check_Count + 1;
-
- Parser_Status (I).Active_Workers := Parser_Status
(I).Active_Workers + 1;
- end Set_Outputs;
-
- procedure Set_All_Done
- is begin
- Parser_Index := SAL.Base_Peek_Type'First;
- Config := (others => <>);
- Status := All_Done;
- end Set_All_Done;
-
- begin
- if Fatal_Called or All_Parsers_Done then
- Set_All_Done;
- return;
- end if;
-
- -- Same logic as in Get_Barrier, but different actions.
- --
- -- No task_id in outline trace messages, because they may appear in
- -- .parse_good
- for I in Parser_Status'Range loop
- Skip := False;
-
- declare
- P_Status : Base.Parser_Status renames Parser_Status (I);
- begin
- case P_Status.Recover_State is
- when Active | Ready =>
- if P_Status.Parser_State.Recover.Config_Heap.Count > 0 then
- if P_Status.Parser_State.Recover.Check_Count -
Check_Delta_Limit >= Min_Success_Check_Count then
- if Trace_McKenzie > Outline then
- Put_Line
- (Trace.all,
- P_Status.Parser_State.Label, "fail; check delta
(limit" &
- Integer'Image (Min_Success_Check_Count +
Check_Delta_Limit) & ")",
- Task_ID => False);
- end if;
- P_Status.Recover_State := Fail;
- P_Status.Fail_Mode := Fail_Check_Delta;
-
- Done_Count := Done_Count + 1;
- Skip := True;
-
- elsif Total_Enqueue_Count +
P_Status.Parser_State.Recover.Config_Full_Count >= Enqueue_Limit then
- if Trace_McKenzie > Outline then
- Put_Line
- (Trace.all,
- P_Status.Parser_State.Label, "fail; total
enqueue limit (" &
- Enqueue_Limit'Image & " cost" &
-
P_Status.Parser_State.Recover.Config_Heap.Min_Key'Image & ")",
- Task_ID => False);
- end if;
- P_Status.Recover_State := Fail;
- P_Status.Fail_Mode := Fail_Enqueue_Limit;
-
- Done_Count := Done_Count + 1;
- Skip := True;
- end if;
- end if;
-
- if not Skip then
- case P_Status.Recover_State is
- when Active =>
- if P_Status.Parser_State.Recover.Config_Heap.Count > 0
then
- if
P_Status.Parser_State.Recover.Config_Heap.Min_Key < Min_Cost then
- Min_Cost :=
P_Status.Parser_State.Recover.Config_Heap.Min_Key;
- Min_Cost_Index := I;
- -- not done
- end if;
- else
- if P_Status.Active_Workers = 0 then
- -- No configs left to check (rarely happens
with real languages).
- if Trace_McKenzie > Outline then
- Put_Line
- (Trace.all, P_Status.Parser_State.Label,
"fail; no configs left", Task_ID => False);
- end if;
- P_Status.Recover_State := Fail;
- P_Status.Fail_Mode := Fail_No_Configs_Left;
-
- Done_Count := Done_Count + 1;
- end if;
- end if;
-
- when Ready =>
- if P_Status.Parser_State.Recover.Config_Heap.Count > 0
and then
- P_Status.Parser_State.Recover.Config_Heap.Min_Key <=
- P_Status.Parser_State.Recover.Results.Min_Key
- then
- -- Still more to check. We don't check Min_Cost
here so this parser
- -- can finish quickly.
- Set_Outputs (I);
- return;
-
- elsif P_Status.Active_Workers = 0 then
- P_Status.Recover_State := Success;
- Done_Count := Done_Count + 1;
- end if;
- when others =>
- null;
- end case;
- end if;
-
- when Success | Fail =>
- Done_Count := Done_Count + 1;
- end case;
- end;
- end loop;
-
- if Min_Cost /= Integer'Last then
- Set_Outputs (Min_Cost_Index);
-
- elsif Done_Count = Parsers.Count then
- if Trace_McKenzie > Extra then
- Trace.Put_Line ("Supervisor: done, " & (if Success_Counter > 0
then "succeed" else "fail"));
- end if;
-
- Set_All_Done;
- All_Parsers_Done := True;
- else
- raise SAL.Programmer_Error with "Get_Barrier and Get logic do not
match";
- end if;
- end Get;
-
- procedure Success
- (Parser_Index : in SAL.Peek_Type;
- Config : in Configuration;
- Configs : in out Config_Heaps.Heap_Type)
- is
- Data : McKenzie_Data renames Parser_Status
(Parser_Index).Parser_State.Recover;
- begin
- Put (Parser_Index, Configs); -- Decrements Active_Worker_Count.
-
- if Trace_McKenzie > Detail then
- Put
- ("succeed: enqueue" & Integer'Image (Data.Enqueue_Count) & ",
check " & Integer'Image (Data.Check_Count),
- Trace.all, Parser_Status (Parser_Index).Parser_State.Label,
Terminals.all, Config);
- end if;
-
- if Force_Full_Explore then
- return;
- end if;
-
- Success_Counter := Success_Counter + 1;
- Result := Success;
-
- Data.Success := True;
-
- if Data.Check_Count < Min_Success_Check_Count then
- Min_Success_Check_Count := Data.Check_Count;
- end if;
-
- if Force_High_Cost_Solutions then
- Data.Results.Add (Config);
- if Data.Results.Count > 3 then
- Parser_Status (Parser_Index).Recover_State := Ready;
- end if;
- else
- if Data.Results.Count = 0 then
- Data.Results.Add (Config);
-
- Parser_Status (Parser_Index).Recover_State := Ready;
-
- elsif Config.Cost < Data.Results.Min_Key then
- -- delete higher cost configs from Results
- loop
- Data.Results.Drop;
- exit when Data.Results.Count = 0 or else
- Config.Cost >= Data.Results.Min_Key;
- end loop;
-
- Data.Results.Add (Config);
-
- elsif Config.Cost = Data.Results.Min_Key then
- Data.Results.Add (Config);
-
- else
- -- Config.Cost > Results.Min_Key
- null;
- end if;
- end if;
- end Success;
-
- procedure Put (Parser_Index : in SAL.Peek_Type; Configs : in out
Config_Heaps.Heap_Type)
- is
- Configs_Count : constant SAL.Base_Peek_Type := Configs.Count; --
Before it is emptied, for Trace.
-
- P_Status : Base.Parser_Status renames Parser_Status (Parser_Index);
- Data : McKenzie_Data renames P_Status.Parser_State.Recover;
- begin
- P_Status.Active_Workers := P_Status.Active_Workers - 1;
-
- Total_Enqueue_Count := Total_Enqueue_Count + Integer (Configs_Count);
- Data.Enqueue_Count := Data.Enqueue_Count + Integer (Configs_Count);
- loop
- exit when Configs.Count = 0;
-
- -- [1] has a check for duplicate configs here; that only happens
with
- -- higher costs, which take too long for our application.
- Data.Config_Heap.Add (Configs.Remove);
- end loop;
-
- if Trace_McKenzie > Detail then
- Put_Line
- (Trace.all, P_Status.Parser_State.Label,
- "enqueue:" & SAL.Base_Peek_Type'Image (Configs_Count) &
- "/" & SAL.Base_Peek_Type'Image (Data.Config_Heap.Count) &
- "/" & Trimmed_Image (Total_Enqueue_Count) &
- "/" & Trimmed_Image (Data.Check_Count) &
- ", min cost:" &
- (if Data.Config_Heap.Count > 0
- then Integer'Image (Data.Config_Heap.Min_Key)
- else " ? ") &
- ", active workers:" & Integer'Image
(P_Status.Active_Workers));
- end if;
- end Put;
-
- procedure Config_Full (Prefix : in String; Parser_Index : in
SAL.Peek_Type)
- is
- P_Status : Base.Parser_Status renames Parser_Status (Parser_Index);
- Data : McKenzie_Data renames P_Status.Parser_State.Recover;
- begin
- Data.Config_Full_Count := Data.Config_Full_Count + 1;
- if Trace_McKenzie > Outline then
- Put_Line (Trace.all, Label (Parser_Index), Prefix & ": config.ops
is full; " &
- Data.Config_Full_Count'Image);
- end if;
- end Config_Full;
-
- function Recover_Result return Recover_Status
- is
- Temp : Recover_Status := Result;
- begin
- if Result = Success then
- return Success;
- else
- for S of Parser_Status loop
- Temp := Recover_Status'Max (Result, S.Fail_Mode);
- end loop;
- return Temp;
- end if;
- end Recover_Result;
-
- procedure Fatal (E : in Ada.Exceptions.Exception_Occurrence)
- is
- use Ada.Exceptions;
- begin
- if Trace_McKenzie > Outline then
- Trace.Put_Line ("task " & Task_Attributes.Value'Image & "
Supervisor: Error");
- end if;
- Fatal_Called := True;
- Error_ID := Exception_Identity (E);
- Error_Message := +Exception_Message (E);
- if Debug_Mode then
- Trace.Put_Line (Exception_Name (E) & ": " & Exception_Message (E));
- Trace.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
-- includes Prefix
- end if;
- end Fatal;
-
- entry Done (Error_ID : out Ada.Exceptions.Exception_Id; Message : out
Ada.Strings.Unbounded.Unbounded_String)
- when All_Parsers_Done or Fatal_Called
- is begin
- Error_ID := Supervisor.Error_ID;
- Message := Error_Message;
- if Trace_McKenzie > Detail then
- Trace.New_Line;
- Trace.Put_Line ("Supervisor: Done");
- end if;
- end Done;
-
- function Parser_State (Parser_Index : in SAL.Peek_Type) return
Parser_Lists.Constant_Reference_Type
- is begin
- return (Element => Parser_Status (Parser_Index).Parser_State);
- end Parser_State;
-
- function Label (Parser_Index : in SAL.Peek_Type) return Natural
- is begin
- return Parser_Status (Parser_Index).Parser_State.Label;
- end Label;
-
- end Supervisor;
-
- procedure Put
- (Message : in String;
- Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Config : in Configuration;
- Task_ID : in Boolean := True)
- is begin
- Put (Message, Super.Trace.all, Super.Parser_State (Parser_Index).Label,
- Shared.Terminals.all, Config, Task_ID);
- end Put;
-
-end WisiToken.Parse.LR.McKenzie_Recover.Base;
diff --git a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-base.ads
b/packages/wisi/wisitoken-parse-lr-mckenzie_recover-base.ads
deleted file mode 100644
index f67df90..0000000
--- a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-base.ads
+++ /dev/null
@@ -1,185 +0,0 @@
--- Abstract :
---
--- Base utilities for McKenzie_Recover
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Exceptions;
-with WisiToken.Parse.LR.Parser;
-with WisiToken.Parse.LR.Parser_Lists;
-private package WisiToken.Parse.LR.McKenzie_Recover.Base is
-
- ----------
- -- Protected object specs.
- --
- -- Tasking design requirements:
- --
- -- 1) For each parse_state, find all solutions of the same lowest
- -- cost.
- --
- -- 2) use as many CPUs as available as fully as possible.
- --
- -- 3) avoid
- -- a) busy waits
- -- b) race conditions
- -- c) deadlocks.
- --
- -- For 2), we use worker_tasks to perform the check computations on
- -- each configuration. We allocate N - 1 worker_tasks, where N is the
- -- number of available CPUs, saving one CPU for Supervisor and the
- -- foreground IDE.
- --
- -- For 1), worker_tasks always get the lowest cost configuration
- -- available. However, some active worker_task may have a lower cost
- -- configuration that it has not yet delivered to Supervisor.
- -- Therefore we always wait until all current active worker_tasks
- -- deliver their results before deciding we are done.
- --
- -- For 3a) we have one Supervisor protected object that controls
- -- access to all Parse_States and configurations, and a Shared object
- -- that provides appropriate access to the Shared_Parser components.
- --
- -- It is tempting to try to reduce contention for Supervisor by
- -- having one protected object per parser, but that requires the
- -- worker tasks to busy loop checking all the parsers.
- --
- -- There is still a race condition on Success; the solutions can be
- -- delivered in different orders on different runs. This matters
- -- because each solution results in a successful parse, possibly with
- -- different actions (different indentation computed, for example).
- -- Which solution finally succeeds depends on which are terminated
- -- due to identical parser stacks, which in turn depends on the order
- -- they were delivered. See ada-mode/tests/ada_mode-interactive_2.adb
- -- for an example.
- --
- -- There is also a race condition on how many failed or higher cost
- -- configurations are checked, before the final solutions are found.
-
- type Config_Status is (Valid, All_Done);
- type Recover_State is (Active, Ready, Success, Fail);
-
- type Parser_Status is record
- Recover_State : Base.Recover_State;
- Parser_State : Parser_Lists.State_Access;
- Fail_Mode : Recover_Status;
-
- Active_Workers : Natural;
- -- Count of Worker_Tasks that have done Get but not Put or Success.
- end record;
-
- type Parser_Status_Array is array (SAL.Peek_Type range <>) of Parser_Status;
-
- protected type Supervisor
- (Trace : not null access WisiToken.Trace'Class;
- Check_Delta_Limit : Natural;
- Enqueue_Limit : Natural;
- Parser_Count : SAL.Peek_Type)
- is
- -- There is only one object of this type, declared in Recover.
-
- procedure Initialize
- (Parsers : not null access Parser_Lists.List;
- Terminals : not null access constant Base_Token_Arrays.Vector);
-
- entry Get
- (Parser_Index : out SAL.Base_Peek_Type;
- Config : out Configuration;
- Status : out Config_Status);
- -- Get a new configuration to check. Available when there is a
- -- configuration to get, or when all configs have been checked.
- --
- -- Increments active worker count.
- --
- -- Status values mean:
- --
- -- Valid - Parser_Index, Config are valid, should be checked.
- --
- -- All_Done - Parser_Index, Config are not valid.
-
- procedure Success
- (Parser_Index : in SAL.Peek_Type;
- Config : in Configuration;
- Configs : in out Config_Heaps.Heap_Type);
- -- Report that Configuration succeeds for Parser_Label, and enqueue
- -- Configs.
- --
- -- Decrements active worker count.
-
- procedure Put (Parser_Index : in SAL.Peek_Type; Configs : in out
Config_Heaps.Heap_Type);
- -- Add Configs to the McKenzie_Data Config_Heap for Parser_Label
- --
- -- Decrements active worker count.
-
- procedure Config_Full (Prefix : in String; Parser_Index : in
SAL.Peek_Type);
- -- Report that a config.ops was full when trying to add another op.
- -- This is counted towards the enqueue limit.
-
- function Recover_Result return Recover_Status;
-
- procedure Fatal (E : in Ada.Exceptions.Exception_Occurrence);
- -- Report a fatal error; abort all processing, make Done
- -- available.
-
- entry Done (Error_ID : out Ada.Exceptions.Exception_Id; Message : out
Ada.Strings.Unbounded.Unbounded_String);
- -- Available when all parsers have failed or succeeded, or an error
- -- occured.
- --
- -- If Error_ID is not Null_Id, an error occured.
-
- function Parser_State (Parser_Index : in SAL.Peek_Type) return
Parser_Lists.Constant_Reference_Type;
- function Label (Parser_Index : in SAL.Peek_Type) return Natural;
-
- private
- Parsers : access Parser_Lists.List;
- Terminals : access constant Base_Token_Arrays.Vector;
-
- All_Parsers_Done : Boolean;
- Success_Counter : Natural;
- Min_Success_Check_Count : Natural;
- Total_Enqueue_Count : Natural;
- Fatal_Called : Boolean;
- Result : Recover_Status;
- Error_ID : Ada.Exceptions.Exception_Id;
- Error_Message : Ada.Strings.Unbounded.Unbounded_String;
- Parser_Status : Parser_Status_Array (1 .. Parser_Count);
- end Supervisor;
-
- type Shared
- (Trace : not null access WisiToken.Trace'Class;
- Lexer : not null access constant
WisiToken.Lexer.Instance'Class;
- Table : not null access constant Parse_Table;
- Language_Fixes :
WisiToken.Parse.LR.Parser.Language_Fixes_Access;
- Language_Matching_Begin_Tokens :
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set :
WisiToken.Parse.LR.Parser.Language_String_ID_Set_Access;
- Terminals : not null access constant
Base_Token_Arrays.Vector;
- Line_Begin_Token : not null access constant
Line_Begin_Token_Vectors.Vector)
- is null record;
- -- There is only one object of this type, declared in Recover. It
- -- provides appropriate access to Shared_Parser components.
- --
- -- Since all the accessible objects are read-only (except Trace),
- -- there are no protected operations, and this is not a protected
- -- type.
-
- procedure Put
- (Message : in String;
- Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Config : in Configuration;
- Task_ID : in Boolean := True);
-
-end WisiToken.Parse.LR.McKenzie_Recover.Base;
diff --git a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-explore.adb
b/packages/wisi/wisitoken-parse-lr-mckenzie_recover-explore.adb
deleted file mode 100644
index 2741dff..0000000
--- a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-explore.adb
+++ /dev/null
@@ -1,1875 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Exceptions;
-with SAL.Gen_Bounded_Definite_Queues;
-with WisiToken.Parse.LR.McKenzie_Recover.Parse;
-with WisiToken.Parse.LR.Parser;
-package body WisiToken.Parse.LR.McKenzie_Recover.Explore is
-
- procedure Do_Shift
- (Label : in String;
- Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Config : in out Configuration;
- State : in State_Index;
- ID : in Token_ID;
- Cost_Delta : in Integer;
- Strategy : in Strategies)
- is
- use Config_Op_Arrays;
- McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
-
- Op : constant Config_Op := (Insert, ID, Config.Current_Shared_Token);
- begin
- Config.Strategy_Counts (Strategy) := Config.Strategy_Counts (Strategy) +
1;
-
- if Is_Full (Config.Ops) then
- Super.Config_Full ("do_shift ops", Parser_Index);
- raise Bad_Config;
- else
- Append (Config.Ops, Op);
- end if;
-
- if Cost_Delta = 0 then
- Config.Cost := Config.Cost + McKenzie_Param.Insert (ID);
- else
- -- Cost_Delta /= 0 comes from Insert_Minimal_Complete_Actions. That
- -- doesn't mean it is better than any other solution, so don't let
- -- cost be 0.
- --
- -- We don't just eliminate all cost for Minimal_Complete_Actions;
- -- that leads to using it far too much at the expense of better
- -- solutions.
- Config.Cost := Integer'Max (1, Config.Cost + McKenzie_Param.Insert
(ID) + Cost_Delta);
- end if;
-
- Config.Error_Token.ID := Invalid_Token_ID;
- Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
-
- if Config.Stack.Is_Full then
- Super.Config_Full ("do_shift stack", Parser_Index);
- raise Bad_Config;
- else
- Config.Stack.Push ((State, Invalid_Node_Index, (ID, Virtual => True,
others => <>)));
- end if;
- if Trace_McKenzie > Detail then
- Base.Put
- ((if Label'Length > 0 then Label & ": " else "") & "insert " &
Image (ID, Super.Trace.Descriptor.all),
- Super, Shared, Parser_Index, Config);
- end if;
-
- Local_Config_Heap.Add (Config);
- end Do_Shift;
-
- procedure Do_Reduce_1
- (Label : in String;
- Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Config : in out Configuration;
- Action : in Reduce_Action_Rec;
- Do_Language_Fixes : in Boolean := True)
- is
- use all type Semantic_Checks.Check_Status_Label;
- use all type WisiToken.Parse.LR.Parser.Language_Fixes_Access;
-
- Prev_State : constant Unknown_State_Index := Config.Stack.Peek.State;
-
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- Table : Parse_Table renames Shared.Table.all;
- Nonterm : Recover_Token;
- New_State : Unknown_State_Index;
- begin
- Config.Check_Status := Parse.Reduce_Stack (Shared, Config.Stack, Action,
Nonterm, Default_Virtual => True);
- case Config.Check_Status.Label is
- when Ok =>
- null;
-
- when Semantic_Checks.Error =>
- Config.Error_Token := Nonterm;
- Config.Check_Token_Count := Action.Token_Count;
-
- if Do_Language_Fixes then
- if Shared.Language_Fixes /= null then
- Shared.Language_Fixes
- (Super.Trace.all, Shared.Lexer, Super.Label (Parser_Index),
Shared.Table.all, Shared.Terminals.all,
- Super.Parser_State (Parser_Index).Tree, Local_Config_Heap,
- Config);
- end if;
- end if;
-
- -- Finish the reduce; ignore the check fail.
- if Config.Stack.Depth < SAL.Base_Peek_Type (Config.Check_Token_Count)
then
- raise SAL.Programmer_Error;
- else
- Config.Stack.Pop (SAL.Base_Peek_Type (Config.Check_Token_Count));
- end if;
- Config.Error_Token.ID := Invalid_Token_ID;
- Config.Check_Status := (Label => Ok);
- end case;
-
- if Config.Stack.Depth = 0 or else Config.Stack.Peek.State =
Unknown_State then
- raise Bad_Config;
- end if;
-
- New_State := Goto_For (Table, Config.Stack.Peek.State,
Action.Production.LHS);
-
- if New_State = Unknown_State then
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), Label &
- ": Do_Reduce_1: unknown_State " &
Config.Stack.Peek.State'Image & " " &
- Image (Action.Production.LHS, Descriptor));
- end if;
- raise Bad_Config;
- end if;
-
- Config.Stack.Push ((New_State, Invalid_Node_Index, Nonterm));
-
- if Trace_McKenzie > Extra and Label'Length > 0 then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), Label &
- ": state" & State_Index'Image (Prev_State) & " reduce" &
- Ada.Containers.Count_Type'Image (Action.Token_Count) & " to " &
- Image (Action.Production.LHS, Descriptor) & ", goto" &
- State_Index'Image (New_State) & " via" & State_Index'Image
(Config.Stack.Peek (2).State));
- end if;
- end Do_Reduce_1;
-
- procedure Do_Reduce_2
- (Label : in String;
- Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Config : in out Configuration;
- Inserted_ID : in Token_ID;
- Cost_Delta : in Integer;
- Strategy : in Strategies)
- is
- -- Perform reduce actions until shift Inserted_ID; if all succeed,
- -- add the final configuration to the heap, return True. If a conflict
is
- -- encountered, process the other action the same way. If a semantic
- -- check fails, enqueue possible solutions. For parse table error
- -- actions, or exception Bad_Config, return False.
-
- Orig_Config : Configuration;
- Table : Parse_Table renames Shared.Table.all;
- Next_Action : Parse_Action_Node_Ptr := Action_For (Table,
Config.Stack.Peek.State, Inserted_ID);
- begin
- if Next_Action.Next /= null then
- Orig_Config := Config;
- end if;
-
- case Next_Action.Item.Verb is
- when Shift =>
- Do_Shift
- (Label, Super, Shared, Parser_Index, Local_Config_Heap, Config,
Next_Action.Item.State, Inserted_ID,
- Cost_Delta, Strategy);
-
- when Reduce =>
- Do_Reduce_1 (Label, Super, Shared, Parser_Index, Local_Config_Heap,
Config, Next_Action.Item);
- Do_Reduce_2
- (Label, Super, Shared, Parser_Index, Local_Config_Heap, Config,
Inserted_ID, Cost_Delta, Strategy);
-
- when Accept_It =>
- raise SAL.Programmer_Error with "found test case for Do_Reduce
Accept_It";
-
- when Error =>
- if Trace_McKenzie > Extra and Label'Length > 0 then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), Label & ": error
on " &
- Image (Inserted_ID, Super.Trace.Descriptor.all) &
- " in state" & State_Index'Image (Config.Stack.Peek.State));
- end if;
- end case;
-
- loop
- exit when Next_Action.Next = null;
- -- There is a conflict; create a new config to shift or reduce.
- declare
- New_Config : Configuration := Orig_Config;
- Action : Parse_Action_Rec renames Next_Action.Next.Item;
- begin
- case Action.Verb is
- when Shift =>
- Do_Shift
- (Label, Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Action.State, Inserted_ID,
- Cost_Delta, Strategy);
-
- when Reduce =>
- Do_Reduce_1 (Label, Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action);
- Do_Reduce_2
- (Label, Super, Shared, Parser_Index, Local_Config_Heap,
New_Config, Inserted_ID,
- Cost_Delta, Strategy);
-
- when Accept_It =>
- raise SAL.Programmer_Error with "found test case for Do_Reduce
Accept_It conflict";
-
- when Error =>
- null;
- end case;
- end;
-
- Next_Action := Next_Action.Next;
- end loop;
- exception
- when Bad_Config =>
- if Debug_Mode then
- raise;
- end if;
- end Do_Reduce_2;
-
- function Edit_Point_Matches_Ops (Config : in Configuration) return Boolean
- is
- use Config_Op_Arrays, Config_Op_Array_Refs;
- pragma Assert (Length (Config.Ops) > 0);
- Op : Config_Op renames Constant_Ref (Config.Ops, Last_Index
(Config.Ops));
- begin
- return Config.Current_Shared_Token =
- (case Op.Op is
- when Fast_Forward => Op.FF_Token_Index,
- when Undo_Reduce => Invalid_Token_Index, -- ie, "we don't know", so
return False.
- when Push_Back => Op.PB_Token_Index,
- when Insert => Op.Ins_Token_Index,
- when Delete => Op.Del_Token_Index + 1);
- end Edit_Point_Matches_Ops;
-
- procedure Fast_Forward
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Config : in Configuration)
- is
- -- Apply the ops in Config; they were inserted by some fix.
- -- Leaves Config.Error_Token, Config.Check_Status set.
- -- If there are conflicts, all are parsed; if more than one succeed.
- -- All configs are enqueued in Local_Config_Heap.
-
- use Parse.Parse_Item_Arrays;
- use Config_Op_Arrays;
-
- Parse_Items : aliased Parse.Parse_Item_Arrays.Vector;
-
- Dummy : Boolean := Parse.Parse
- (Super, Shared, Parser_Index, Parse_Items, Config,
- Shared_Token_Goal => Invalid_Token_Index,
- All_Conflicts => True,
- Trace_Prefix => "fast_forward");
- begin
- -- This solution is from Language_Fixes (see gate on call site
- -- below); any cost increase is done there.
- --
- -- We used to handle the Parse_Items.Length = 1 case specially, and
- -- return Continue. Maintaining that requires too much code
- -- duplication.
-
- for I in First_Index (Parse_Items) .. Last_Index (Parse_Items) loop
- declare
- Item : Parse.Parse_Item renames
Parse.Parse_Item_Array_Refs.Variable_Ref (Parse_Items, I);
- begin
- if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
- -- Item.Config.Error_Token.ID, Check_Status are correct.
-
- if not Edit_Point_Matches_Ops (Item.Config) then
-
- if Is_Full (Item.Config.Ops) then
- Super.Config_Full ("fast_forward 1", Parser_Index);
- raise Bad_Config;
- else
- Append (Item.Config.Ops, (Fast_Forward,
Item.Config.Current_Shared_Token));
- end if;
- end if;
-
- Item.Config.Minimal_Complete_State := None;
- Item.Config.Matching_Begin_Done := False;
- Local_Config_Heap.Add (Item.Config);
-
- if Trace_McKenzie > Detail then
- Base.Put ("fast forward enqueue", Super, Shared,
Parser_Index, Item.Config);
- end if;
- end if;
- exception
- when Bad_Config =>
- null;
- end;
- end loop;
- end Fast_Forward;
-
- function Check
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- return Check_Status
- is
- use Config_Op_Arrays, Config_Op_Array_Refs;
- use Parse.Parse_Item_Arrays;
- use all type Semantic_Checks.Check_Status_Label;
-
- Parse_Items : aliased Parse.Parse_Item_Arrays.Vector;
- Result : Check_Status := Continue;
- begin
- if Length (Config.Ops) > 0 then
- declare
- Op : Config_Op renames Constant_Ref (Config.Ops, Last_Index
(Config.Ops));
- begin
- case Op.Op is
- when Push_Back =>
- -- Check would undo the Push_Back, leading to
- -- duplicate results. See test_mckenzie_recover.adb
Do_Delete_First and
- -- three_action_conflict_lalr.parse_good for examples.
- return Continue;
-
- when Undo_Reduce =>
- if Config.Check_Status.Label /= Ok then
- -- This is the "ignore error" solution for a check fail;
check it.
- Config.Check_Status := (Label => Ok);
- Config.Error_Token.ID := Invalid_Token_ID;
-
- else
- -- Check would undo the Undo_Reduce, leading to
- -- duplicate results.
- return Continue;
- end if;
- when others =>
- -- Check it
- null;
- end case;
- end;
- end if;
-
- if Parse.Parse
- (Super, Shared, Parser_Index, Parse_Items, Config,
Config.Resume_Token_Goal,
- All_Conflicts => False,
- Trace_Prefix => "check")
- then
- Config.Error_Token.ID := Invalid_Token_ID;
- -- FIXME: if there were conflicts, enqueue them; they might yield a
- -- cheaper or same cost solution?
- if Trace_McKenzie > Extra then
- Put_Line (Super.Trace.all, Super.Label (Parser_Index), "check
result: SUCCESS");
- end if;
- return Success;
- end if;
-
- -- Set Config.error to reflect failure, if it is at current token, so
- -- Use_Minimal_Complete_Actions can see it.
- declare
- Item : Parse.Parse_Item renames
Parse.Parse_Item_Array_Refs.Constant_Ref
- (Parse_Items, First_Index (Parse_Items));
- begin
- if Item.Config.Check_Status.Label /= Ok then
- Config.Check_Status := Item.Config.Check_Status;
- Config.Error_Token := Item.Config.Error_Token;
-
- -- Explore cannot fix a check fail; only Language_Fixes can. The
- -- "ignore error" case is handled immediately on return from
- -- Language_Fixes in Process_One, below.
- Result := Abandon;
-
- elsif Item.Config.Error_Token.ID /= Invalid_Token_ID then
-
- if Item.Shift_Count = 0 then
- Config.Error_Token := Item.Config.Error_Token;
- Config.Check_Status := (Label => Ok);
- else
- -- Error is not at current token, but Explore might find
something
- -- that will help (see test_mckenzie_recover.adb Extra_Begin).
On the
- -- other hand, this can lead to lots of bogus configs (see
- -- If_In_Handler).
- Config.Error_Token.ID := Invalid_Token_ID;
- Config.Check_Status := (Label => Ok);
- end if;
- end if;
- end;
-
- -- All Parse_Items either failed or were not parsed; if they failed
- -- and made progress, enqueue them.
- for I in First_Index (Parse_Items) .. Last_Index (Parse_Items) loop
- declare
- Item : Parse.Parse_Item renames
Parse.Parse_Item_Array_Refs.Variable_Ref (Parse_Items, I);
- begin
- -- When Parse starts above, Config.Current_Shared_Token matches
- -- Config.Ops. So if Item.Config.Current_Shared_Token >
- -- Config.Current_Shared_Token, it made some progress. Append or
- -- update a Fast_Forward to indicate the changed edit point.
- if Item.Config.Error_Token.ID /= Invalid_Token_ID and
- Item.Config.Current_Shared_Token > Config.Current_Shared_Token
- then
- Item.Config.Minimal_Complete_State := None;
- Item.Config.Matching_Begin_Done := False;
-
- if Constant_Ref (Item.Config.Ops, Last_Index
(Item.Config.Ops)).Op = Fast_Forward then
- -- Update the trailing Fast_Forward.
- Variable_Ref (Item.Config.Ops, Last_Index
(Item.Config.Ops)).FF_Token_Index :=
- Item.Config.Current_Shared_Token;
- else
- if Is_Full (Item.Config.Ops) then
- Super.Config_Full ("check 1", Parser_Index);
- raise Bad_Config;
- else
- Append (Item.Config.Ops, (Fast_Forward,
Item.Config.Current_Shared_Token));
- end if;
- end if;
- Local_Config_Heap.Add (Item.Config);
- if Trace_McKenzie > Detail then
- Base.Put ("new error point ", Super, Shared, Parser_Index,
Item.Config);
- end if;
- end if;
- end;
- end loop;
-
- if Trace_McKenzie > Extra then
- Put_Line (Super.Trace.all, Super.Label (Parser_Index), "check result:
" & Result'Image);
- end if;
- return Result;
- exception
- when Bad_Config =>
- return Abandon;
- end Check;
-
- function Check_Reduce_To_Start
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Orig_Config : in Configuration)
- return Boolean
- -- Returns True if Config reduces to the start nonterm.
- is
- Table : Parse_Table renames Shared.Table.all;
-
- function To_Reduce_Action (Item : in Minimal_Action) return
Reduce_Action_Rec
- is begin
- return (Reduce, Item.Production, null, null, Item.Token_Count);
- end To_Reduce_Action;
-
- Local_Config_Heap : Config_Heaps.Heap_Type; -- never used, because
Do_Language_Fixes is False.
-
- Config : Configuration := Orig_Config;
- Actions : Minimal_Action_Arrays.Vector := Table.States
(Config.Stack.Peek.State).Minimal_Complete_Actions;
- begin
- loop
- case Actions.Length is
- when 0 =>
- if (for some Item of Table.States (Config.Stack.Peek.State).Kernel
=>
- Item.Production.LHS = Super.Trace.Descriptor.Accept_ID)
- then
- return True;
- else
- return False;
- end if;
-
- when 1 =>
- case Actions (Actions.First_Index).Verb is
- when Shift =>
- return False;
-
- when Reduce =>
- Do_Reduce_1
- ("", Super, Shared, Parser_Index, Local_Config_Heap, Config,
- To_Reduce_Action (Actions (Actions.First_Index)),
- Do_Language_Fixes => False);
-
- Actions := Table.States
(Config.Stack.Peek.State).Minimal_Complete_Actions;
- end case;
-
- when others =>
- return False;
- end case;
-
- -- loop only exits via returns above
- end loop;
- exception
- when Bad_Config =>
- -- From Do_Reduce_1
- return False;
- end Check_Reduce_To_Start;
-
- procedure Try_Push_Back
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
- McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
- Prev_Recover : constant WisiToken.Base_Token_Index :=
Super.Parser_State (Parser_Index).Resume_Token_Goal;
-
- Token : constant Recover_Token := Config.Stack.Peek.Token;
- begin
- -- Try pushing back the stack top, to allow insert and other
- -- operations at that point.
- --
- -- Since we are not actually changing the source text, it is tempting
- -- to give this operation zero cost. But then we keep doing push_back
- -- forever, making no progress. So we give it a cost.
-
- if Token.Min_Terminal_Index /= Invalid_Token_Index and
- -- No point in pushing back an empty nonterm; that leads to duplicate
- -- solutions with Undo_Reduce; see test_mckenzie_recover.adb Error_2.
-
- (Prev_Recover = Invalid_Token_Index or else Prev_Recover <
Token.Min_Terminal_Index)
- -- Don't push back past previous error recover (that would require
- -- keeping track of previous inserts/deletes, and would not be useful
- -- in most cases).
- then
- declare
- use Config_Op_Arrays;
- New_Config : Configuration := Config;
- begin
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- New_Config.Stack.Pop;
-
- if Is_Full (New_Config.Ops) then
- Super.Config_Full ("push_back 1", Parser_Index);
- raise Bad_Config;
- else
- if Token.Min_Terminal_Index = Invalid_Token_Index then
- -- Token is empty; Config.current_shared_token does not
change, no
- -- cost increase.
- Append (New_Config.Ops, (Push_Back, Token.ID,
New_Config.Current_Shared_Token));
- else
- New_Config.Cost := New_Config.Cost +
McKenzie_Param.Push_Back (Token.ID);
- Append (New_Config.Ops, (Push_Back, Token.ID,
Token.Min_Terminal_Index));
- New_Config.Current_Shared_Token := Token.Min_Terminal_Index;
- end if;
- end if;
- New_Config.Strategy_Counts (Push_Back) :=
New_Config.Strategy_Counts (Push_Back) + 1;
-
- Local_Config_Heap.Add (New_Config);
-
- if Trace_McKenzie > Detail then
- Base.Put ("push_back " & Image (Token.ID,
Trace.Descriptor.all), Super, Shared,
- Parser_Index, New_Config);
- end if;
- end;
- end if;
- end Try_Push_Back;
-
- function Just_Pushed_Back_Or_Deleted (Config : in Configuration; ID : in
Token_ID) return Boolean
- is
- use Config_Op_Arrays, Config_Op_Array_Refs;
- Last_Token_Index : WisiToken.Token_Index := Config.Current_Shared_Token;
- -- Index of token in last op checked.
- begin
- -- This function is called when considering whether to insert ID before
- -- Config.Current_Shared_Token.
- --
- -- We need to consider more than one recent op here; see
test_mckenzie_recover.adb
- -- Check_Multiple_Delete_For_Insert. Checking only one op allows this
solution there:
- --
- -- ... (DELETE, END, 7), (DELETE, SEMICOLON, 8), (INSERT, END, 9),
(INSERT, SEMICOLON, 9)
- --
- for I in reverse First_Index (Config.Ops) .. Last_Index (Config.Ops) loop
- declare
- Op : Config_Op renames Constant_Ref (Config.Ops, I);
- begin
- case Op.Op is
- when Push_Back =>
- -- The case we are preventing for Push_Back is typically one
of:
- -- (PUSH_BACK, Identifier, 2), (INSERT, Identifier, 2)
- -- (PUSH_BACK, Identifier, 2), (PUSH_BACK, END, 3), (INSERT,
Identifier, 3), (INSERT, END, 3),
- if Op.PB_Token_Index = Last_Token_Index then
- if Op.PB_ID = ID then
- return True;
- else
- if Op.PB_Token_Index = WisiToken.Token_Index'First then
- return False;
- else
- Last_Token_Index := Op.PB_Token_Index - 1;
- end if;
- end if;
- else
- -- Op is at a different edit point.
- return False;
- end if;
-
- when Delete =>
- if Op.Del_Token_Index = Last_Token_Index - 1 then
- if Op.Del_ID = ID then
- return True;
- else
- Last_Token_Index := Op.Del_Token_Index;
- end if;
- else
- -- Op is at a different edit point.
- return False;
- end if;
-
- when Fast_Forward | Insert | Undo_Reduce =>
- return False;
- end case;
- end;
- end loop;
- return False;
- end Just_Pushed_Back_Or_Deleted;
-
- procedure Try_Undo_Reduce
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- use Config_Op_Arrays;
-
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
- McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
- Token : constant Recover_Token := Config.Stack.Peek.Token;
- New_Config : Configuration := Config;
- Token_Count : Ada.Containers.Count_Type;
- begin
- -- Try expanding the nonterm on the stack top, to allow pushing_back
- -- its components, or insert and other operations at that point.
-
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
-
- Token_Count := Undo_Reduce (New_Config.Stack, Super.Parser_State
(Parser_Index).Tree);
-
- if Token.Min_Terminal_Index /= Invalid_Token_Index then
- -- If Token is empty no cost increase.
- New_Config.Cost := New_Config.Cost + McKenzie_Param.Undo_Reduce
(Token.ID);
- end if;
-
- if Is_Full (New_Config.Ops) then
- Super.Config_Full ("undo_reduce 1", Parser_Index);
- raise Bad_Config;
- else
- Append (New_Config.Ops, (Undo_Reduce, Token.ID, Token_Count));
- end if;
- New_Config.Strategy_Counts (Undo_Reduce) := New_Config.Strategy_Counts
(Undo_Reduce) + 1;
-
- Local_Config_Heap.Add (New_Config);
-
- if Trace_McKenzie > Detail then
- Base.Put ("undo_reduce " & Image (Token.ID, Trace.Descriptor.all),
Super, Shared,
- Parser_Index, New_Config);
- end if;
- end Try_Undo_Reduce;
-
- procedure Insert_From_Action_List
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in Configuration;
- Minimal_Insert : in Token_ID_Arrays.Vector;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- Table : Parse_Table renames Shared.Table.all;
- EOF_ID : Token_ID renames Super.Trace.Descriptor.EOI_ID;
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
-
- -- Find terminal insertions from the current state's action_list to try.
- --
- -- We perform any needed reductions and one shift, so the config is
- -- in a consistent state, and enqueue the result. If there are any
- -- conflicts or semantic check fails encountered, they create other
- -- configs to enqueue.
-
- Current_Token : constant Token_ID := Current_Token_ID_Peek
- (Shared.Terminals.all, Config.Current_Shared_Token,
Config.Insert_Delete, Config.Current_Insert_Delete);
-
- Cached_Config : Configuration;
- Cached_Action : Reduce_Action_Rec;
- -- Most of the time, all the reductions in a state are the same. So
- -- we cache the first result. This includes one reduction; if an
- -- associated semantic check failed, this does not include the fixes.
-
- I : Parse_Action_Node_Ptr;
- begin
- for Node of Table.States (Config.Stack.Peek.State).Action_List loop
- I := Node.Actions;
- loop
- exit when I = null;
- declare
- ID : constant Token_ID := Node.Symbol;
- Action : Parse_Action_Rec renames I.Item;
- begin
- if ID /= EOF_ID and then -- can't insert eof
- ID /= Invalid_Token_ID -- invalid when Verb = Error
- then
- if Just_Pushed_Back_Or_Deleted (Config, ID) then
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Insert: abandon " & Image (ID, Descriptor) &
- ": undo push_back");
- end if;
- elsif ID = Current_Token then
- -- This is needed because we allow explore when the
error is not at
- -- the explore point; it prevents inserting useless
tokens (ie
- -- 'identifier ;' in ada_lite).
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Insert: abandon " & Image (ID, Descriptor) &
- ": current token");
- end if;
-
- elsif (for some Minimal of Minimal_Insert => ID = Minimal)
then
- -- Was inserted by Insert_Minimal_Complete_Actions
- null;
-
- else
- case Action.Verb is
- when Shift =>
- declare
- New_Config : Configuration := Config;
- begin
- Do_Shift
- ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action.State, ID,
- Cost_Delta => 0,
- Strategy => Insert);
- end;
-
- when Reduce =>
- if not Equal (Action, Cached_Action) then
- declare
- New_Config : Configuration := Config;
- begin
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- Do_Reduce_1
- ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, Action);
- Cached_Config := New_Config;
- Cached_Action := Action;
-
- Do_Reduce_2
- ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
- Cost_Delta => 0,
- Strategy => Insert);
- end;
-
- else
- declare
- New_Config : Configuration := Cached_Config;
- begin
- Do_Reduce_2
- ("Insert", Super, Shared, Parser_Index,
Local_Config_Heap, New_Config, ID,
- Cost_Delta => 0,
- Strategy => Insert);
- end;
- end if;
-
- when Accept_It =>
- raise SAL.Programmer_Error with "found test case for
Process_One Accept_It";
-
- when Error =>
- null;
- end case;
- end if;
- end if;
- end;
- I := I.Next;
- end loop;
- end loop;
- end Insert_From_Action_List;
-
- function Insert_Minimal_Complete_Actions
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Orig_Config : in out Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- return Token_ID_Arrays.Vector
- -- Return tokens inserted (empty if none).
- is
- use Ada.Containers;
-
- Table : Parse_Table renames Shared.Table.all;
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- Inserted : Token_ID_Array (1 .. 10) := (others => Invalid_Token_ID);
- Inserted_Last : Integer := Inserted'First - 1;
-
- type Work_Item is record
- Action : Minimal_Action;
- Cost_Delta : Integer;
- Config : Configuration;
- end record;
-
- package Item_Queues is new SAL.Gen_Bounded_Definite_Queues (Work_Item);
- use Item_Queues;
-
- Work : Queue_Type (10);
- -- The required queue size depends on the number of multiple-item
- -- Minimal_Complete_Actions encountered. That is limited by compound
- -- statement nesting, and by the frequency of such actions.
-
- procedure Safe_Add_Work (Label : in String; Item : in Work_Item)
- is begin
- if Is_Full (Work) then
- Super.Config_Full ("Minimal_Complete_Actions " & Label,
Parser_Index);
- raise Bad_Config;
- else
- Add (Work, Item);
- end if;
- end Safe_Add_Work;
-
- function To_Reduce_Action (Action : in Minimal_Action) return
Reduce_Action_Rec
- is (Reduce, Action.Production, null, null, Action.Token_Count);
-
- procedure Minimal_Do_Shift
- (Action : in Minimal_Action;
- Cost_Delta : in Integer;
- Config : in out Configuration)
- is begin
- if Just_Pushed_Back_Or_Deleted (Config, Action.ID) then
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
- "Minimal_Complete_Actions: abandon " & Image (Action.ID,
Descriptor) & ": undo push back");
- end if;
- else
- Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
- Config.Minimal_Complete_State := Active;
- Inserted_Last := Inserted_Last + 1;
- if Inserted_Last <= Inserted'Last then
- Inserted (Inserted_Last) := Action.ID;
- else
- Super.Config_Full ("minimal_do_shift Inserted", Parser_Index);
- raise Bad_Config;
- end if;
-
- Do_Shift
- ("Minimal_Complete_Actions", Super, Shared, Parser_Index,
Local_Config_Heap, Config,
- Action.State, Action.ID, Cost_Delta,
- Strategy => Minimal_Complete);
- end if;
- end Minimal_Do_Shift;
-
- procedure Enqueue_Min_Actions
- (Label : in String;
- Actions : in Minimal_Action_Arrays.Vector;
- Config : in Configuration)
- is
- use SAL;
- Length : array (Actions.First_Index .. Actions.Last_Index) of
Count_Type := (others => Count_Type'Last);
-
- Min_Length : Count_Type := Count_Type'Last;
- begin
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: " & Label &
- Image (Actions, Descriptor));
- end if;
-
- if Actions.Length = 0 then
- return;
- elsif Actions.Length = 1 then
- Safe_Add_Work
- ("1", (Actions (Actions.First_Index),
Table.McKenzie_Param.Minimal_Complete_Cost_Delta, Config));
- return;
- end if;
-
- -- More than one minimal action in State; try to use next states and
- -- recursion to pick one.
- Actions_Loop :
- for I in Actions.First_Index .. Actions.Last_Index loop
- declare
- function Matches (Item : in Kernel_Info; Action : in
Minimal_Action) return Boolean
- is begin
- case Action.Verb is
- when Shift =>
- return Item.Before_Dot = Action.ID;
- when Reduce =>
- return Item.Before_Dot = Action.Production.LHS;
- end case;
- end Matches;
-
- function Length_After_Dot
- (Item : in Kernel_Info;
- Action : in Minimal_Action;
- Stack : in Recover_Stacks.Stack)
- return Ada.Containers.Count_Type
- is
- Match_ID : Token_ID;
- New_Stack : Recover_Stacks.Stack := Stack;
- Next_State : Unknown_State_Index;
- Result : Ada.Containers.Count_Type;
- Min_Result : Ada.Containers.Count_Type :=
Ada.Containers.Count_Type'Last;
- begin
- case Action.Verb is
- when Shift =>
- New_Stack.Push
- ((Action.State, Invalid_Node_Index, (ID => Action.ID,
others => <>)));
- Next_State := Action.State;
- Match_ID := Action.ID;
-
- when Reduce =>
- New_Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
- Next_State := Goto_For (Shared.Table.all,
New_Stack.Peek.State, Action.Production.LHS);
- if Next_State = Unknown_State then
- -- We get here when Insert_From_Action_Table started
us down a bad path
- raise Bad_Config;
- end if;
-
- New_Stack.Push
- ((Next_State, Invalid_Node_Index, (ID =>
Action.Production.LHS, others => <>)));
- Match_ID := Action.Production.LHS;
- end case;
-
- if Trace_McKenzie > Extra then
- Super.Trace.Put (Next_State'Image & " " & Trimmed_Image
(Item.Production));
- end if;
-
- for Item of Shared.Table.States (Next_State).Kernel loop
- if Item.Before_Dot = Match_ID then
- if Item.Length_After_Dot = 0 then
- Result := Length_After_Dot
- (Item, (Reduce, Item.Reduce_Production,
Item.Reduce_Count), New_Stack);
- else
- Result := Item.Length_After_Dot;
- end if;
- end if;
-
- if Result < Min_Result then
- Min_Result := Result;
- end if;
- end loop;
- return Min_Result;
- end Length_After_Dot;
-
- Action : constant Minimal_Action := Actions (I);
- Next_State : constant State_Index :=
- (case Action.Verb is
- when Shift => Action.State,
- when Reduce => Goto_For
- (Shared.Table.all,
- Config.Stack.Peek (Base_Peek_Type (Action.Token_Count) +
1).State,
- Action.Production.LHS));
- begin
- if Trace_McKenzie > Extra then
- Super.Trace.Put
- ("task" & Task_Attributes.Value'Image &
- Super.Label (Parser_Index)'Image & ":
Minimal_Complete_Actions: " &
- Image (Action, Descriptor));
- end if;
-
- for Item of Shared.Table.States (Next_State).Kernel loop
-
- if Matches (Item, Action) then
- -- For Action.Verb = Reduce, more than one item may match
- if Item.Length_After_Dot = 0 then
- -- Set Length from a non-zero-length non-recursive
item.
- Length (I) := Length_After_Dot (Item, Action,
Config.Stack);
-
- elsif Item.Length_After_Dot < Length (I) then
- if Trace_McKenzie > Extra then
- -- Length_After_Dot outputs this in other branch
- Super.Trace.Put (Next_State'Image & " " &
Trimmed_Image (Item.Production));
- end if;
- Length (I) := Item.Length_After_Dot;
-
- end if;
-
- if Trace_McKenzie > Extra then
- Super.Trace.Put (" length" & Length (I)'Image);
- end if;
- if Length (I) < Min_Length then
- Min_Length := Length (I);
- end if;
- end if;
- end loop;
- if Trace_McKenzie > Extra then
- Super.Trace.New_Line;
- end if;
- end;
- end loop Actions_Loop;
-
- for I in Length'Range loop
- if Length (I) = Min_Length then
- Safe_Add_Work ("2", (Actions (I),
Table.McKenzie_Param.Minimal_Complete_Cost_Delta, Config));
-
- elsif Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: drop " &
- Image (Actions (I), Descriptor) & " not minimal or
recursive");
- end if;
- end loop;
- end Enqueue_Min_Actions;
-
- begin
- if Orig_Config.Stack.Depth = 1 then
- -- Get here with an empty source file, or a syntax error on the first
- -- token.
- return Token_ID_Arrays.Empty_Vector;
-
- elsif Orig_Config.Minimal_Complete_State = Done then
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: done");
- end if;
- return Token_ID_Arrays.Empty_Vector;
- end if;
-
- Enqueue_Min_Actions ("", Table.States
(Orig_Config.Stack.Peek.State).Minimal_Complete_Actions, Orig_Config);
-
- loop
- exit when Is_Empty (Work);
-
- declare
- Item : Work_Item := Get (Work);
- begin
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"Minimal_Complete_Actions: dequeue work item " &
- Image (Item.Action, Descriptor));
- end if;
-
- case Item.Action.Verb is
- when Reduce =>
- -- Do a reduce, look at resulting state. Keep reducing until
we can't
- -- anymore.
- declare
- Reduce_Action : Reduce_Action_Rec := To_Reduce_Action
(Item.Action);
- Actions : Minimal_Action_Arrays.Vector;
- begin
- loop
- Do_Reduce_1
- ("Minimal_Complete_Actions", Super, Shared,
Parser_Index, Local_Config_Heap, Item.Config,
- Reduce_Action,
- Do_Language_Fixes => False);
-
- Actions := Table.States
(Item.Config.Stack.Peek.State).Minimal_Complete_Actions;
-
- case Actions.Length is
- when 0 =>
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
- "Minimal_Complete_Actions abandoned: no
actions");
- end if;
- exit;
- when 1 =>
- case Actions (Actions.First_Index).Verb is
- when Shift =>
- Minimal_Do_Shift (Actions (Actions.First_Index),
Item.Cost_Delta, Item.Config);
- exit;
- when Reduce =>
- Reduce_Action := To_Reduce_Action (Actions
(Actions.First_Index));
- end case;
-
- when others =>
- Enqueue_Min_Actions ("multiple actions ", Actions,
Item.Config);
- exit;
- end case;
- end loop;
- end;
-
- when Shift =>
- Minimal_Do_Shift (Item.Action, Item.Cost_Delta, Item.Config);
- end case;
- end;
- end loop;
-
- if Inserted_Last = Inserted'First - 1 then
- -- Nothing inserted this round.
- if Orig_Config.Minimal_Complete_State = Active then
- Orig_Config.Minimal_Complete_State := Done;
- end if;
- end if;
-
- return To_Vector (Inserted (1 .. Inserted_Last));
- exception
- when Bad_Config =>
- return Token_ID_Arrays.Empty_Vector;
- end Insert_Minimal_Complete_Actions;
-
- procedure Insert_Matching_Begin
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Matching_Begin_Tokens : in Token_ID_Arrays.Vector)
- is
- Table : Parse_Table renames Shared.Table.all;
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- begin
- -- We don't check for insert = current token; that's either ok or a
- -- severe bug in Shared.Language_Matching_Begin_Tokens.
-
- if Config.Matching_Begin_Done then
- if Trace_McKenzie > Extra then
- Put_Line (Super.Trace.all, Super.Label (Parser_Index),
"Matching_Begin abandoned: done");
- end if;
- return;
- end if;
-
- if Just_Pushed_Back_Or_Deleted (Config, Matching_Begin_Tokens
(Matching_Begin_Tokens.First_Index)) then
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), "Matching_Begin
abandoned " &
- Image (Matching_Begin_Tokens
(Matching_Begin_Tokens.First_Index), Descriptor) & ": undo push_back");
- end if;
- return;
- end if;
-
- declare
- New_Config : Configuration := Config;
- begin
- for ID of Matching_Begin_Tokens loop
- Insert (New_Config, ID);
- end loop;
-
- declare
- use Parse.Parse_Item_Arrays;
- Parse_Items : aliased Parse.Parse_Item_Arrays.Vector;
- Dummy : constant Boolean := Parse.Parse
- (Super, Shared, Parser_Index, Parse_Items, New_Config,
- Shared_Token_Goal => Invalid_Token_Index,
- All_Conflicts => True,
- Trace_Prefix => "parse Matching_Begin");
- begin
- for I in First_Index (Parse_Items) .. Last_Index (Parse_Items) loop
- declare
- Item : Parse.Parse_Item renames
Parse.Parse_Item_Array_Refs.Variable_Ref (Parse_Items, I);
- begin
- if Item.Parsed and Item.Config.Current_Insert_Delete =
No_Insert_Delete then
- Item.Config.Matching_Begin_Done := True;
- Item.Config.Cost := Item.Config.Cost +
Table.McKenzie_Param.Matching_Begin;
- Item.Config.Strategy_Counts (Matching_Begin) :=
Item.Config.Strategy_Counts (Matching_Begin) + 1;
- Item.Config.Error_Token.ID := Invalid_Token_ID;
- Item.Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- if Trace_McKenzie > Detail then
- Base.Put
- ("Matching_Begin: insert " & Image
(Matching_Begin_Tokens, Descriptor),
- Super, Shared, Parser_Index, Item.Config);
- end if;
- Local_Config_Heap.Add (Item.Config);
- else
- if Trace_McKenzie > Detail then
- Base.Put
- ("Matching_Begin: abandon " & Image
(Matching_Begin_Tokens, Descriptor) & ": parse fail",
- Super, Shared, Parser_Index, Item.Config);
- end if;
- end if;
- end;
- end loop;
- end;
- end;
- exception
- when SAL.Container_Full =>
- -- From config_ops_sorted
- Super.Config_Full ("Minimal_Complete_Actions 3", Parser_Index);
- end Insert_Matching_Begin;
-
- procedure Try_Insert_Terminal
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- use all type
WisiToken.Parse.LR.Parser.Language_Matching_Begin_Tokens_Access;
- Tokens : Token_ID_Array_1_3;
- Matching_Begin_Tokens : Token_ID_Arrays.Vector;
- Forbid_Minimal_Insert : Boolean := False;
-
- Minimal_Inserted : Token_ID_Arrays.Vector;
- begin
- if Shared.Language_Matching_Begin_Tokens /= null then
- Current_Token_ID_Peek_3
- (Shared.Terminals.all, Config.Current_Shared_Token,
Config.Insert_Delete, Config.Current_Insert_Delete,
- Tokens);
-
- Shared.Language_Matching_Begin_Tokens (Tokens, Config,
Matching_Begin_Tokens, Forbid_Minimal_Insert);
- end if;
-
- if not Forbid_Minimal_Insert then
- -- See test_mckenzie_recover.adb Forbid_Minimal_Insert for rationale.
- Minimal_Inserted := Insert_Minimal_Complete_Actions
- (Super, Shared, Parser_Index, Config, Local_Config_Heap);
- end if;
-
- if Matching_Begin_Tokens.Length > 0 then
- Insert_Matching_Begin (Super, Shared, Parser_Index, Config,
Local_Config_Heap, Matching_Begin_Tokens);
- end if;
-
- -- We always do all three; Insert_Minimal_Complete (unless
- -- Forbid_Minimal_Insert), Insert_Matching_Begin,
- -- Insert_From_Action_List; in general it's not possible to tell when
- -- one will be better (see test_mckenzie_recover.adb
- -- Always_Minimal_Complete, Always_Matching_Begin).
- -- Insert_From_Action_List does not insert the Minimal_Inserted tokens,
- -- and it will never insert the Matching_Begin_Tokens, so there is no
- -- duplication. Insert_From_Action_List will normally be more
- -- expensive.
- Insert_From_Action_List (Super, Shared, Parser_Index, Config,
Minimal_Inserted, Local_Config_Heap);
-
- -- It is tempting to use the Goto_List to find nonterms to insert.
- -- But that can easily lead to error states, and it turns out to be
- -- not useful, especially if the grammar has been relaxed so most
- -- expressions and lists can be empty.
-
- exception
- when Bad_Config =>
- null;
- end Try_Insert_Terminal;
-
- procedure Try_Insert_Quote
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in out Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- use Config_Op_Arrays;
- use all type Parser.Language_String_ID_Set_Access;
-
- Descriptor : WisiToken.Descriptor renames Shared.Trace.Descriptor.all;
- Check_Limit : WisiToken.Token_Index renames
Shared.Table.McKenzie_Param.Check_Limit;
-
- Current_Line : constant Line_Number_Type :=
Shared.Terminals.all (Config.Current_Shared_Token).Line;
- Lexer_Error_Token : Base_Token;
-
- function Recovered_Lexer_Error (Line : in Line_Number_Type) return
Base_Token_Index
- is begin
- -- We are assuming the list of lexer errors is short, so binary
- -- search would not be significantly faster.
- for Err of reverse Shared.Lexer.Errors loop
- if Err.Recover_Token /= Invalid_Token_Index and then
- Shared.Terminals.all (Err.Recover_Token).Line = Line
- then
- return Err.Recover_Token;
- end if;
- end loop;
- return Invalid_Token_Index;
- end Recovered_Lexer_Error;
-
- Lexer_Error_Token_Index : constant Base_Token_Index :=
Recovered_Lexer_Error (Current_Line);
-
- function String_ID_Set (String_ID : in Token_ID) return Token_ID_Set
- is begin
- if Shared.Language_String_ID_Set = null then
- return (String_ID .. String_ID => True);
- else
- return Shared.Language_String_ID_Set (Descriptor, String_ID);
- end if;
- end String_ID_Set;
-
- procedure String_Literal_In_Stack
- (Label : in String;
- New_Config : in out Configuration;
- Matching : in SAL.Peek_Type;
- String_Literal_ID : in Token_ID)
- is
- Saved_Shared_Token : constant WisiToken.Token_Index :=
New_Config.Current_Shared_Token;
-
- Tok : Recover_Token;
- J : WisiToken.Token_Index;
- Parse_Items : aliased Parse.Parse_Item_Arrays.Vector;
- begin
- -- Matching is the index of a token on New_Config.Stack containing a
string
- -- literal. Push back thru that token, then delete all tokens after
- -- the string literal to Saved_Shared_Token.
- if not Has_Space (New_Config.Ops, Ada.Containers.Count_Type
(Matching)) then
- Super.Config_Full ("insert quote 1 " & Label, Parser_Index);
- raise Bad_Config;
- end if;
- for I in 1 .. Matching loop
- if Push_Back_Valid (New_Config) then
- Tok := New_Config.Stack.Pop.Token;
- Append (New_Config.Ops, (Push_Back, Tok.ID,
Tok.Min_Terminal_Index));
- else
- -- Probably pushing back thru a previously inserted token
- raise Bad_Config;
- end if;
- end loop;
-
- New_Config.Current_Shared_Token := Tok.Min_Terminal_Index;
-
- -- Find last string literal in pushed back terminals.
- J := Saved_Shared_Token - 1;
- loop
- exit when Shared.Terminals.all (J).ID = String_Literal_ID;
- J := J - 1;
- end loop;
-
- begin
- if Parse.Parse
- (Super, Shared, Parser_Index, Parse_Items, New_Config,
- Shared_Token_Goal => J,
- All_Conflicts => False,
- Trace_Prefix => "insert quote parse pushback " & Label)
- then
- -- The non-deleted tokens parsed without error. We don't care
if any
- -- conflicts were encountered; we are not using the parse
result.
- New_Config := Parse.Parse_Item_Array_Refs.Constant_Ref
(Parse_Items, 1).Config;
- Append (New_Config.Ops, (Fast_Forward,
New_Config.Current_Shared_Token));
- else
- raise SAL.Programmer_Error;
- end if;
- exception
- when Bad_Config =>
- raise SAL.Programmer_Error;
- end;
-
- if New_Config.Current_Shared_Token < Saved_Shared_Token - 1 and then
- (not Has_Space
- (New_Config.Ops, Ada.Containers.Count_Type (Saved_Shared_Token -
1 - New_Config.Current_Shared_Token)))
- then
- Super.Config_Full ("insert quote 2 " & Label, Parser_Index);
- raise Bad_Config;
- end if;
-
- for J in New_Config.Current_Shared_Token .. Saved_Shared_Token - 1
loop
- Append (New_Config.Ops, (Delete, Shared.Terminals.all (J).ID, J));
- end loop;
-
- New_Config.Current_Shared_Token := Saved_Shared_Token;
-
- end String_Literal_In_Stack;
-
- procedure Push_Back_Tokens
- (Full_Label : in String;
- New_Config : in out Configuration;
- Min_Pushed_Back_Index : out Base_Token_Index)
- is
- Item : Recover_Stack_Item;
- begin
- loop
- Item := New_Config.Stack.Peek;
- if Item.Token.Virtual then
- -- Don't push back an inserted token
- exit;
-
- elsif Item.Token.Byte_Region = Null_Buffer_Region then
- -- Don't need push_back for an empty token
- New_Config.Stack.Pop;
-
- elsif Item.Tree_Index = Invalid_Node_Index then
- -- Item was pushed on stack during recovery, and we do not know
- -- its Line. To avoid crossing a line boundary, we stop
push_backs
- -- here.
- exit;
-
- else
- if Shared.Terminals.all
- (Super.Parser_State (Parser_Index).Tree.First_Shared_Terminal
(Item.Tree_Index)).Line = Current_Line
- -- Don't let push_back cross a line boundary.
- then
- if Is_Full (New_Config.Ops) then
- Super.Config_Full (Full_Label, Parser_Index);
- raise Bad_Config;
- else
- New_Config.Stack.Pop;
- Append (New_Config.Ops, (Push_Back, Item.Token.ID,
Item.Token.Min_Terminal_Index));
- end if;
- end if;
-
- exit;
- end if;
- end loop;
- Min_Pushed_Back_Index := Item.Token.Min_Terminal_Index;
- end Push_Back_Tokens;
-
- procedure Finish
- (Label : in String;
- New_Config : in out Configuration;
- First, Last : in Base_Token_Index)
- is
- Adj_First : constant Base_Token_Index := (if First =
Invalid_Token_Index then Last else First);
- Adj_Last : constant Base_Token_Index := (if Last =
Invalid_Token_Index then First else Last);
- begin
- -- Delete tokens First .. Last; either First - 1 or Last + 1 should
- -- be a String_Literal. Leave Current_Shared_Token at Last + 1.
-
- if Adj_Last = Invalid_Token_Index or Adj_First = Invalid_Token_Index
then
- pragma Assert (False);
- raise Bad_Config;
- end if;
-
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label => WisiToken.Semantic_Checks.Ok);
-
- -- This is a guess, so we give it a nominal cost
- New_Config.Cost := New_Config.Cost + 1;
-
- if not Has_Space (New_Config.Ops, Ada.Containers.Count_Type (Last -
First)) then
- Super.Config_Full ("insert quote 3 " & Label, Parser_Index);
- raise Bad_Config;
- end if;
-
- for I in Adj_First .. Adj_Last loop
- Append (New_Config.Ops, (Delete, Shared.Terminals.all (I).ID, I));
- end loop;
- New_Config.Current_Shared_Token := Last + 1;
-
- -- Let explore do insert after these deletes.
- Append (New_Config.Ops, (Fast_Forward,
New_Config.Current_Shared_Token));
-
- if New_Config.Resume_Token_Goal - Check_Limit <
New_Config.Current_Shared_Token then
- New_Config.Resume_Token_Goal := New_Config.Current_Shared_Token +
Check_Limit;
- if Trace_McKenzie > Extra then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
"resume_token_goal:" & WisiToken.Token_Index'Image
- (New_Config.Resume_Token_Goal));
- end if;
- end if;
-
- New_Config.Strategy_Counts (String_Quote) :=
New_Config.Strategy_Counts (String_Quote) + 1;
-
- if Trace_McKenzie > Detail then
- Base.Put ("insert quote " & Label & " ", Super, Shared,
Parser_Index, New_Config);
- end if;
- end Finish;
-
- begin
- -- When the lexer finds an unbalanced quote, it inserts a virtual
- -- balancing quote at the same character position as the unbalanced
- -- quote, returning an empty string literal token there. The parser
- -- does not see that as an error; it encounters a syntax error
- -- before, at, or after that string literal.
- --
- -- Here we assume the parse error in Config.Error_Token is due to
- -- putting the balancing quote in the wrong place (although we do
- -- check that; see test_mckenzie_recover.adb String_Quote_6), and
- -- attempt to find a better place to put the balancing quote. Then
- -- all tokens from the balancing quote to the unbalanced quote are
- -- now part of a string literal, so delete them, leaving just the
- -- string literal created by Lexer error recovery.
-
- -- First we check to see if there is an unbalanced quote in the
- -- current line; if not, just return. Some lexer errors are for other
- -- unrecognized characters; see ada_mode-recover_bad_char.adb.
- --
- -- An alternate strategy is to treat the lexer error as a parse error
- -- immediately, but that complicates the parse logic.
-
- Config.String_Quote_Checked := Current_Line;
-
- if Lexer_Error_Token_Index = Invalid_Token_Index then
- return;
- end if;
-
- Lexer_Error_Token := Shared.Terminals.all (Lexer_Error_Token_Index);
-
- -- It is not possible to tell where the best place to put the
- -- balancing quote is, so we always try all reasonable places.
-
- if Lexer_Error_Token.Byte_Region.First =
Config.Error_Token.Byte_Region.First then
- -- The parse error token is the string literal at the lexer error.
- --
- -- case a: Insert the balancing quote somewhere before the error
- -- point. There is no way to tell how far back to put the balancing
- -- quote, so we just do one non-empty token. See
- -- test_mckenzie_recover.adb String_Quote_0. So far we have not found
- -- a test case for more than one token.
- declare
- New_Config : Configuration := Config;
- Min_Pushed_Back_Index : Base_Token_Index;
- begin
- Push_Back_Tokens ("insert quote 4 a", New_Config,
Min_Pushed_Back_Index);
- Finish ("a", New_Config, Min_Pushed_Back_Index,
Config.Current_Shared_Token - 1);
- Local_Config_Heap.Add (New_Config);
- end;
-
- -- Note that it is not reasonable to insert a quote after the error
- -- in this case. If that were the right solution, the parser error
- -- token would not be the lexer repaired string literal, since a
- -- string literal would be legal here.
-
- elsif Lexer_Error_Token.Byte_Region.First <
Config.Error_Token.Byte_Region.First then
- -- The unbalanced quote is before the parse error token; see
- -- test_mckenzie_recover.adb String_Quote_2.
- --
- -- The missing quote belongs after the parse error token, before or
- -- at the end of the current line; try inserting it at the end of
- -- the current line.
- --
- -- The lexer repaired string literal may be in a reduced token on the
- -- stack.
-
- declare
- Matching : SAL.Peek_Type := 1;
- begin
- Find_Descendant_ID
- (Super.Parser_State (Parser_Index).Tree, Config,
Lexer_Error_Token.ID,
- String_ID_Set (Lexer_Error_Token.ID), Matching);
-
- if Matching = Config.Stack.Depth then
- -- String literal is in a virtual nonterm; give up. So far
this only
- -- happens in a high cost non critical config.
- if Trace_McKenzie > Detail then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index), "insert
quote b abandon; string literal in virtual");
- end if;
- return;
- end if;
-
- declare
- New_Config : Configuration := Config;
- begin
- String_Literal_In_Stack ("b", New_Config, Matching,
Lexer_Error_Token.ID);
-
- Finish
- ("b", New_Config, Config.Current_Shared_Token,
Shared.Line_Begin_Token.all (Current_Line + 1) - 1);
- Local_Config_Heap.Add (New_Config);
- end;
- end;
-
- else
- -- The unbalanced quote is after the parse error token.
-
- -- case c: Assume a missing quote belongs immediately before the
current token.
- -- See test_mckenzie_recover.adb String_Quote_3.
- declare
- New_Config : Configuration := Config;
- begin
- Finish ("c", New_Config, Config.Current_Shared_Token,
Lexer_Error_Token_Index - 1);
- Local_Config_Heap.Add (New_Config);
- exception
- when Bad_Config =>
- null;
- end;
-
- -- case d: Assume a missing quote belongs somewhere farther before
- -- the current token; try one non-empty (as in case a above). See
- -- test_mckenzie_recover.adb String_Quote_4, String_Quote_6.
- declare
- New_Config : Configuration := Config;
- Min_Pushed_Back_Index : Base_Token_Index;
- begin
- Push_Back_Tokens ("insert quote 5 d", New_Config,
Min_Pushed_Back_Index);
- Finish ("d", New_Config, Min_Pushed_Back_Index,
Lexer_Error_Token_Index - 1);
- Local_Config_Heap.Add (New_Config);
- exception
- when SAL.Container_Empty =>
- -- From Stack.Pop
- null;
- when Bad_Config =>
- null;
- end;
-
- -- case e: Assume the actual error is an extra quote that terminates
- -- an intended string literal early, in which case there is a token
- -- on the stack containing the string literal that should be extended
- -- to the found quote. See test_mckenzie_recover.adb String_Quote_1.
- declare
- Matching : SAL.Peek_Type := 1;
- begin
- -- Lexer_Error_Token is a string literal; find a matching one.
- Find_Descendant_ID
- (Super.Parser_State (Parser_Index).Tree, Config,
Lexer_Error_Token.ID, String_ID_Set
- (Lexer_Error_Token.ID), Matching);
-
- if Matching = Config.Stack.Depth then
- -- No matching string literal, so this case does not apply.
- null;
- else
- declare
- New_Config : Configuration := Config;
- begin
- String_Literal_In_Stack ("e", New_Config, Matching,
Lexer_Error_Token.ID);
-
- Finish ("e", New_Config, Config.Current_Shared_Token,
Lexer_Error_Token_Index);
- Local_Config_Heap.Add (New_Config);
- end;
- end if;
- end;
- end if;
- exception
- when Bad_Config =>
- null;
- end Try_Insert_Quote;
-
- procedure Try_Delete_Input
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Base_Peek_Type;
- Config : in Configuration;
- Local_Config_Heap : in out Config_Heaps.Heap_Type)
- is
- -- Try deleting (= skipping) the current shared input token.
-
- use Config_Op_Arrays, Config_Op_Array_Refs;
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
- EOF_ID : Token_ID renames Trace.Descriptor.EOI_ID;
- Check_Limit : WisiToken.Token_Index renames
Shared.Table.McKenzie_Param.Check_Limit;
-
- McKenzie_Param : McKenzie_Param_Type renames Shared.Table.McKenzie_Param;
-
- ID : constant Token_ID := Shared.Terminals.all
(Config.Current_Shared_Token).ID;
- begin
- if ID /= EOF_ID and then
- -- can't delete EOF
- (Length (Config.Ops) = 0 or else
- -- Don't delete an ID we just inserted; waste of time
- (not Equal (Constant_Ref (Config.Ops, Last_Index (Config.Ops)),
- (Insert, ID, Config.Current_Shared_Token))))
- then
- declare
- New_Config : Configuration := Config;
-
- function Matching_Push_Back return Boolean
- is begin
- for I in reverse First_Index (New_Config.Ops) .. Last_Index
(New_Config.Ops) loop
- declare
- Op : Config_Op renames Config_Op_Array_Refs.Variable_Ref
(New_Config.Ops, I).Element.all;
- begin
- exit when not (Op.Op in Undo_Reduce | Push_Back | Delete);
- if Op = (Push_Back, ID, New_Config.Current_Shared_Token)
then
- return True;
- end if;
- end;
- end loop;
- return False;
- end Matching_Push_Back;
- begin
- New_Config.Error_Token.ID := Invalid_Token_ID;
- New_Config.Check_Status := (Label =>
WisiToken.Semantic_Checks.Ok);
-
- New_Config.Cost := New_Config.Cost + McKenzie_Param.Delete (ID);
- New_Config.Strategy_Counts (Delete) := Config.Strategy_Counts
(Delete) + 1;
-
- if Matching_Push_Back then
- -- We are deleting a push_back; cancel the push_back cost, to
make
- -- this the same as plain deleting.
- New_Config.Cost := Natural'Max (Natural'First, New_Config.Cost
- McKenzie_Param.Push_Back (ID));
- end if;
-
- if Is_Full (New_Config.Ops) then
- Super.Config_Full ("delete", Parser_Index);
- raise Bad_Config;
- else
- Append (New_Config.Ops, (Delete, ID,
Config.Current_Shared_Token));
- end if;
- New_Config.Current_Shared_Token := New_Config.Current_Shared_Token
+ 1;
-
- if New_Config.Resume_Token_Goal - Check_Limit <
New_Config.Current_Shared_Token then
- New_Config.Resume_Token_Goal := New_Config.Current_Shared_Token
+ Check_Limit;
- end if;
-
- Local_Config_Heap.Add (New_Config);
-
- if Trace_McKenzie > Detail then
- Base.Put
- ("delete " & Image (ID, Trace.Descriptor.all), Super, Shared,
Parser_Index, New_Config);
- end if;
- end;
- end if;
- end Try_Delete_Input;
-
- procedure Process_One
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Config_Status : out Base.Config_Status)
- is
- -- Get one config from Super, check to see if it is a viable
- -- solution. If not, enqueue variations to check.
-
- use all type Base.Config_Status;
- use all type Parser.Language_Fixes_Access;
- use all type Semantic_Checks.Check_Status_Label;
-
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- Table : Parse_Table renames Shared.Table.all;
-
- Parser_Index : SAL.Base_Peek_Type;
- Config : Configuration;
-
- Local_Config_Heap : Config_Heaps.Heap_Type;
- -- We collect all the variants to enqueue, then deliver them all at
- -- once to Super, to minimizes task interactions.
- begin
- Super.Get (Parser_Index, Config, Config_Status);
-
- if Config_Status = All_Done then
- return;
- end if;
-
- if Trace_McKenzie > Detail then
- Base.Put ("dequeue", Super, Shared, Parser_Index, Config);
- if Trace_McKenzie > Extra then
- Put_Line (Trace, Super.Label (Parser_Index), "stack: " & Image
(Config.Stack, Trace.Descriptor.all));
- end if;
- end if;
-
- -- Fast_Forward; parse Insert, Delete in Config.Ops that have not
- -- been parsed yet. 'parse' here means adjusting Config.Stack and
- -- Current_Terminal_Index. Code in this file always parses when
- -- adding ops to Config (except as noted); Language_Fixes should use
- -- McKenzie_Recover.Insert, Delete instead.
- if Config.Current_Insert_Delete = 1 then
- -- Config is from Language_Fixes.
-
- Fast_Forward (Super, Shared, Parser_Index, Local_Config_Heap, Config);
- Super.Put (Parser_Index, Local_Config_Heap);
- return;
- end if;
-
- pragma Assert (Config.Current_Insert_Delete = 0);
- -- Config.Current_Insert_Delete > 1 is a programming error.
-
- if Config.Error_Token.ID /= Invalid_Token_ID then
- if Shared.Language_Fixes = null then
- null;
- else
- Shared.Language_Fixes
- (Trace, Shared.Lexer, Super.Label (Parser_Index),
Shared.Table.all,
- Shared.Terminals.all, Super.Parser_State (Parser_Index).Tree,
Local_Config_Heap,
- Config);
-
- -- The solutions enqueued by Language_Fixes should be lower cost
than
- -- others (typically 0), so they will be checked first.
- end if;
-
- if Config.Check_Status.Label = Ok then
- -- Parse table Error action.
- --
- -- We don't clear Config.Error_Token here, because
- -- Language_Use_Minimal_Complete_Actions needs it. We only clear
it
- -- when a parse results in no error (or a different error), or a
- -- push_back moves the Current_Token.
- null;
-
- else
- -- Assume "ignore check error" is a viable solution. But give it a
- -- cost, so a solution provided by Language_Fixes is preferred.
-
- declare
- New_State : Unknown_State_Index;
- begin
- Config.Cost := Config.Cost +
Table.McKenzie_Param.Ignore_Check_Fail;
- Config.Strategy_Counts (Ignore_Error) := Config.Strategy_Counts
(Ignore_Error) + 1;
-
- -- finish reduce.
- Config.Stack.Pop (SAL.Base_Peek_Type
(Config.Check_Token_Count));
-
- New_State := Goto_For (Table, Config.Stack.Peek.State,
Config.Error_Token.ID);
-
- if New_State = Unknown_State then
- if Config.Stack.Depth = 1 then
- -- Stack is empty, and we did not get Accept; really bad
syntax got
- -- us here; abandon this config. See
ada_mode-recover_bad_char.adb.
- Super.Put (Parser_Index, Local_Config_Heap);
- return;
- else
- raise SAL.Programmer_Error with
- "process_one found test case for new_state = Unknown;
old state " &
- Trimmed_Image (Config.Stack.Peek.State) & " nonterm " &
Image
- (Config.Error_Token.ID, Trace.Descriptor.all);
- end if;
- end if;
-
- Config.Stack.Push ((New_State, Invalid_Node_Index,
Config.Error_Token));
-
- -- We _don't_ clear Check_Status and Error_Token here; Check
needs
- -- them, and sets them as appropriate.
- end;
- end if;
- end if;
-
- -- Call Check to see if this config succeeds.
- case Check (Super, Shared, Parser_Index, Config, Local_Config_Heap) is
- when Success =>
- Super.Success (Parser_Index, Config, Local_Config_Heap);
- return;
-
- when Abandon =>
- Super.Put (Parser_Index, Local_Config_Heap);
- return;
-
- when Continue =>
- null;
-
- end case;
-
- if Trace_McKenzie > Detail then
- Base.Put ("continuing", Super, Shared, Parser_Index, Config);
- if Trace_McKenzie > Extra then
- Put_Line (Trace, Super.Label (Parser_Index), "stack: " & Image
(Config.Stack, Trace.Descriptor.all));
- end if;
- end if;
-
- -- Grouping these operations (push_back, delete, insert) ensures that
- -- there are no duplicate solutions found. We reset the grouping
- -- after each fast_forward.
- --
- -- We do delete before insert so Insert_Matching_Begin can operate on
- -- the new next token, before Fast_Forwarding past it.
- --
- -- All possible permutations will be explored.
-
- pragma Assert (Config.Stack.Depth > 0);
-
- Try_Insert_Terminal (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
-
- if Push_Back_Valid (Config) and then
- (not Check_Reduce_To_Start (Super, Shared, Parser_Index, Config))
- -- If Config reduces to the start nonterm, there's no point in
Push_Back or Undo_Reduce.
- then
- Try_Push_Back (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
-
- if Undo_Reduce_Valid (Config.Stack, Super.Parser_State
(Parser_Index).Tree) then
- Try_Undo_Reduce (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
- end if;
- end if;
-
- if None_Since_FF (Config.Ops, Insert) then
- Try_Delete_Input (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
- end if;
-
- -- This is run once per input line, independent of what other ops
- -- have been done.
- if Config.Check_Status.Label = Ok and
- (Descriptor.String_1_ID /= Invalid_Token_ID or Descriptor.String_2_ID
/= Invalid_Token_ID) and
- (Config.String_Quote_Checked = Invalid_Line_Number or else
- Config.String_Quote_Checked < Shared.Terminals.all
(Config.Current_Shared_Token).Line)
- then
- -- See if there is a mismatched quote. The solution is to delete
- -- tokens, nominally replacing them with an expanded string literal.
- -- So we try this when it is ok to try delete.
- if None_Since_FF (Config.Ops, Insert) then
- Try_Insert_Quote (Super, Shared, Parser_Index, Config,
Local_Config_Heap);
- end if;
- end if;
-
- Super.Put (Parser_Index, Local_Config_Heap);
- exception
- when Bad_Config =>
- -- Just abandon this config; tell Super we are done.
- Super.Put (Parser_Index, Local_Config_Heap);
-
- when E : others =>
- Super.Put (Parser_Index, Local_Config_Heap);
- if Debug_Mode then
- raise;
- elsif Trace_McKenzie > Outline then
- Put_Line
- (Super.Trace.all, Super.Label (Parser_Index),
- "Process_One: unhandled exception " &
Ada.Exceptions.Exception_Name (E) & ": " &
- Ada.Exceptions.Exception_Message (E));
- end if;
- end Process_One;
-
-end WisiToken.Parse.LR.McKenzie_Recover.Explore;
diff --git a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-explore.ads
b/packages/wisi/wisitoken-parse-lr-mckenzie_recover-explore.ads
deleted file mode 100644
index b80124a..0000000
--- a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-explore.ads
+++ /dev/null
@@ -1,28 +0,0 @@
--- Abstract :
---
--- Code to explore parse table, enqueuing new configs to check.
---
--- Copyright (C) 2018 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Parse.LR.McKenzie_Recover.Base;
-private package WisiToken.Parse.LR.McKenzie_Recover.Explore is
-
- procedure Process_One
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Config_Status : out Base.Config_Status);
-
-end WisiToken.Parse.LR.McKenzie_Recover.Explore;
diff --git a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-parse.adb
b/packages/wisi/wisitoken-parse-lr-mckenzie_recover-parse.adb
deleted file mode 100644
index b56bba6..0000000
--- a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-parse.adb
+++ /dev/null
@@ -1,327 +0,0 @@
--- Abstract :
---
--- See spec
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Parse.LR.McKenzie_Recover.Parse is
-
- procedure Compute_Nonterm
- (ID : in Token_ID;
- Stack : in Recover_Stacks.Stack;
- Tokens : in out Recover_Token_Array;
- Nonterm : out Recover_Token;
- Default_Virtual : in Boolean)
- is
- Min_Terminal_Index_Set : Boolean := False;
- begin
- Nonterm :=
- (ID => ID,
- Virtual => (if Tokens'Length = 0 then Default_Virtual else False),
- others => <>);
-
- for I in Tokens'Range loop
- Tokens (I) := Stack.Peek (Tokens'Last - I + 1).Token;
- end loop;
-
- for T of Tokens loop
- Nonterm.Virtual := Nonterm.Virtual or T.Virtual;
-
- if Nonterm.Byte_Region.First > T.Byte_Region.First then
- Nonterm.Byte_Region.First := T.Byte_Region.First;
- end if;
-
- if Nonterm.Byte_Region.Last < T.Byte_Region.Last then
- Nonterm.Byte_Region.Last := T.Byte_Region.Last;
- end if;
-
- if not Min_Terminal_Index_Set then
- if T.Min_Terminal_Index /= Invalid_Token_Index then
- Min_Terminal_Index_Set := True;
- Nonterm.Min_Terminal_Index := T.Min_Terminal_Index;
- end if;
- end if;
- end loop;
- end Compute_Nonterm;
-
- function Reduce_Stack
- (Shared : not null access Base.Shared;
- Stack : in out Recover_Stacks.Stack;
- Action : in Reduce_Action_Rec;
- Nonterm : out Recover_Token;
- Default_Virtual : in Boolean)
- return Semantic_Checks.Check_Status
- is
- use all type Semantic_Checks.Semantic_Check;
- use all type Semantic_Checks.Check_Status_Label;
-
- Last : constant SAL.Base_Peek_Type := SAL.Base_Peek_Type
(Action.Token_Count);
- Tokens : Recover_Token_Array (1 .. Last);
- begin
- pragma Assert (Stack.Depth > Last);
- Compute_Nonterm (Action.Production.LHS, Stack, Tokens, Nonterm,
Default_Virtual);
-
- if Action.Check = null then
- -- Now we can pop the stack.
- Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
- return (Label => Ok);
- else
- return Status : constant Semantic_Checks.Check_Status :=
- Action.Check (Shared.Lexer, Nonterm, Tokens, Recover_Active => True)
- do
- if Status.Label = Ok then
- Stack.Pop (SAL.Base_Peek_Type (Action.Token_Count));
- end if;
- end return;
- end if;
- end Reduce_Stack;
-
- function Parse_One_Item
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Parse_Items : aliased in out Parse_Item_Arrays.Vector;
- Parse_Item_Index : in Positive;
- Shared_Token_Goal : in Base_Token_Index;
- Trace_Prefix : in String)
- return Boolean
- is
- -- Perform parse actions on Parse_Items (Parse_Item_Index), until one
- -- fails (return False) or Shared_Token_Goal is shifted (return
- -- True).
- --
- -- We return Boolean, not Check_Status, because Abandon and Continue
- -- are up to the caller.
- --
- -- If any actions have conflicts, append the conflict configs and
actions to
- -- Parse_Items.
-
- use Parse_Item_Arrays;
- use Config_Op_Arrays;
- use all type Semantic_Checks.Check_Status_Label;
-
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
- Descriptor : WisiToken.Descriptor renames Super.Trace.Descriptor.all;
- Table : Parse_Table renames Shared.Table.all;
-
- Item : Parse_Item renames Parse_Item_Array_Refs.Variable_Ref
(Parse_Items, Parse_Item_Index).Element.all;
- Config : Configuration renames Item.Config;
- Action : Parse_Action_Node_Ptr renames Item.Action;
-
- Conflict : Parse_Action_Node_Ptr;
-
- Restore_Terminals_Current : Base_Token_Index;
- Current_Token : Base_Token := McKenzie_Recover.Current_Token
- (Terminals => Shared.Terminals.all,
- Terminals_Current => Config.Current_Shared_Token,
- Restore_Terminals_Current => Restore_Terminals_Current,
- Insert_Delete => Config.Insert_Delete,
- Current_Insert_Delete => Config.Current_Insert_Delete);
-
- New_State : Unknown_State_Index;
- Success : Boolean := True;
-
- begin
- if Trace_McKenzie > Detail then
- if Trace_McKenzie > Extra then
- if Config.Current_Insert_Delete /= No_Insert_Delete then
- Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
Insert_Delete: " &
- Image (Config.Insert_Delete, Trace.Descriptor.all));
- end if;
- end if;
-
- Base.Put (Trace_Prefix & ": " & Image (Current_Token, Descriptor),
Super, Shared, Parser_Index, Config);
- if Shared_Token_Goal /= Invalid_Token_Index then
- Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
Shared_Token_Goal :" &
- WisiToken.Token_Index'Image (Shared_Token_Goal));
- end if;
- end if;
-
- Item.Parsed := True;
-
- if Action = null then
- Action := Action_For (Table, Config.Stack.Peek.State,
Current_Token.ID);
- end if;
-
- loop
- Conflict := Action.Next;
- loop
- exit when Conflict = null;
- if Is_Full (Parse_Items) then
- if Trace_McKenzie > Outline then
- Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix &
": too many conflicts; abandoning");
- end if;
- else
- declare
- New_Config : Configuration := Config;
- begin
- New_Config.Current_Shared_Token := Restore_Terminals_Current;
-
- if Trace_McKenzie > Detail then
- Put_Line
- (Trace, Super.Label (Parser_Index), Trace_Prefix & ":"
& State_Index'Image
- (New_Config.Stack.Peek.State) & ": add conflict " &
- Image (Conflict.Item, Descriptor));
- end if;
-
- Append (Parse_Items, (New_Config, Conflict, Parsed => False,
Shift_Count => Item.Shift_Count));
- end;
- end if;
- Conflict := Conflict.Next;
- end loop;
-
- if Trace_McKenzie > Extra then
- Put_Line
- (Trace, Super.Label (Parser_Index), Trace_Prefix & ":" &
State_Index'Image (Config.Stack.Peek.State) &
- " :" & WisiToken.Token_Index'Image
(Config.Current_Shared_Token) &
- ":" & Image (Current_Token, Descriptor) &
- " : " & Image (Action.Item, Descriptor) &
- (if Action.Item.Verb = Reduce
- then " via" & Config.Stack.Peek (SAL.Peek_Type
(Action.Item.Token_Count + 1)).State'Image
- else ""));
- end if;
-
- case Action.Item.Verb is
- when Shift =>
- Item.Shift_Count := Item.Shift_Count + 1;
-
- Config.Stack.Push
- ((Action.Item.State,
- Invalid_Node_Index,
- (Current_Token.ID,
- Byte_Region => Current_Token.Byte_Region,
- Min_Terminal_Index =>
- (if Config.Current_Insert_Delete = No_Insert_Delete
- then Config.Current_Shared_Token
- else Invalid_Token_Index),
- Name => Null_Buffer_Region,
- Virtual => Config.Current_Insert_Delete /=
No_Insert_Delete)));
-
- Current_Token := Next_Token
- (Terminals => Shared.Terminals.all,
- Terminals_Current => Config.Current_Shared_Token,
- Restore_Terminals_Current => Restore_Terminals_Current,
- Insert_Delete => Config.Insert_Delete,
- Current_Insert_Delete => Config.Current_Insert_Delete);
-
- when Reduce =>
- declare
- Nonterm : Recover_Token;
- begin
- Config.Check_Status := Reduce_Stack
- (Shared, Config.Stack, Action.Item, Nonterm,
- Default_Virtual => Config.Current_Insert_Delete /=
No_Insert_Delete);
-
- case Config.Check_Status.Label is
- when Ok =>
- New_State := Config.Stack.Peek.State;
- New_State := Goto_For (Table, New_State,
Action.Item.Production.LHS);
-
- if New_State = Unknown_State then
- -- Most likely from an inappropriate language fix.
- if Trace_McKenzie > Outline then
- Base.Put (Trace_Prefix & ": Unknown_State: ", Super,
Shared, Parser_Index, Config);
- Put_Line (Trace, Trace_Prefix & ": stack: " & Image
(Config.Stack, Descriptor));
- end if;
-
- -- We can't just return False here; user must abandon
this config.
- raise Bad_Config;
- end if;
-
- Config.Stack.Push ((New_State, Invalid_Node_Index, Nonterm));
-
- when Semantic_Checks.Error =>
- Config.Error_Token := Nonterm;
- Config.Check_Token_Count := Action.Item.Token_Count;
- Success := False;
- end case;
- end;
-
- when Error =>
-
- Config.Error_Token :=
- (ID => Current_Token.ID,
- Byte_Region => Current_Token.Byte_Region,
- others => <>);
- Success := False;
-
- when Accept_It =>
- null;
- end case;
-
- exit when not Success or
- Action.Item.Verb = Accept_It or
- (if Shared_Token_Goal = Invalid_Token_Index
- then Length (Config.Insert_Delete) = 0
- else Config.Current_Shared_Token > Shared_Token_Goal);
-
- Action := Action_For (Table, Config.Stack.Peek.State,
Current_Token.ID);
- end loop;
-
- Config.Current_Shared_Token := Restore_Terminals_Current;
-
- return Success;
- end Parse_One_Item;
-
- function Parse
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Parse_Items : aliased out Parse_Item_Arrays.Vector;
- Config : in Configuration;
- Shared_Token_Goal : in Base_Token_Index;
- All_Conflicts : in Boolean;
- Trace_Prefix : in String)
- return Boolean
- is
- use Parse_Item_Arrays;
- Trace : WisiToken.Trace'Class renames Super.Trace.all;
-
- Last_Parsed : Natural;
- Success : Boolean;
- begin
- Clear (Parse_Items);
- Append (Parse_Items, (Config, Action => null, Parsed => False,
Shift_Count => 0));
-
- -- Clear any errors; so they reflect the parse result.
- declare
- Config : Configuration renames Parse_Item_Array_Refs.Variable_Ref
- (Parse_Items, First_Index (Parse_Items)).Config;
- begin
- Config.Error_Token.ID := Invalid_Token_ID;
- Config.Check_Status := (Label => Semantic_Checks.Ok);
- end;
-
- Last_Parsed := First_Index (Parse_Items);
- loop
- -- Loop over initial config and any conflicts.
- Success := Parse_One_Item
- (Super, Shared, Parser_Index, Parse_Items, Last_Parsed,
Shared_Token_Goal, Trace_Prefix);
-
- exit when Last_Index (Parse_Items) = Last_Parsed;
-
- exit when Success and not All_Conflicts;
-
- Last_Parsed := Last_Parsed + 1;
- if Trace_McKenzie > Detail then
- Put_Line (Trace, Super.Label (Parser_Index), Trace_Prefix & ":
parse conflict");
- end if;
- end loop;
-
- return Success;
- end Parse;
-
-end WisiToken.Parse.LR.McKenzie_Recover.Parse;
diff --git a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-parse.ads
b/packages/wisi/wisitoken-parse-lr-mckenzie_recover-parse.ads
deleted file mode 100644
index abd8946..0000000
--- a/packages/wisi/wisitoken-parse-lr-mckenzie_recover-parse.ads
+++ /dev/null
@@ -1,83 +0,0 @@
--- Abstract :
---
--- Config parsing subprograms.
---
--- Copyright (C) 2018 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with SAL.Gen_Bounded_Definite_Vectors.Gen_Refs;
-with WisiToken.Parse.LR.McKenzie_Recover.Base;
-private package WisiToken.Parse.LR.McKenzie_Recover.Parse is
-
- function Reduce_Stack
- (Shared : not null access Base.Shared;
- Stack : in out Recover_Stacks.Stack;
- Action : in Reduce_Action_Rec;
- Nonterm : out Recover_Token;
- Default_Virtual : in Boolean)
- return Semantic_Checks.Check_Status;
- -- Reduce Stack according to Action, setting Nonterm. If
- -- Action.Token_Count = 0, set Nonterm.Virtual := Default_Virtual.
-
- type Parse_Item is record
- Config : Configuration;
- Action : Parse_Action_Node_Ptr;
- Parsed : Boolean;
- Shift_Count : Natural := 0;
-
- -- On return from Parse, if Parsed = False, this item was queued by a
- -- conflict, but not parsed; it should be ignored.
- --
- -- Otherwise, if Config.Error_Token.ID = Invalid_Token_ID and
- -- Config.Check_Status.Label = Ok, Config was parsed successfully to
- -- the goal.
- --
- -- Otherwise, the parser failed a semantic check, or encountered an
- -- Error action. Action gives the last action processed. Shift_Count
- -- gives the number of shifts performed. If Check_Status.Label is
- -- Error, Action.Item.Verb must be Reduce, and Config is in the
- -- pre-reduce state.
- end record;
-
- package Parse_Item_Arrays is new SAL.Gen_Bounded_Definite_Vectors
(Positive, Parse_Item, Capacity => 10);
- -- Parse_Item_Arrays.Capacity sets maximum conflicts in one call to Parse
-
- package Parse_Item_Array_Refs is new Parse_Item_Arrays.Gen_Refs;
-
- function Parse
- (Super : not null access Base.Supervisor;
- Shared : not null access Base.Shared;
- Parser_Index : in SAL.Peek_Type;
- Parse_Items : aliased out Parse_Item_Arrays.Vector;
- Config : in Configuration;
- Shared_Token_Goal : in Base_Token_Index;
- All_Conflicts : in Boolean;
- Trace_Prefix : in String)
- return Boolean;
- -- Attempt to parse Config and any conflict configs. If not
- -- All_Conflicts, return when Config.Insert_Delete is all processed,
- -- and either Shared_Token_Goal = Invalid_Token_Index or
- -- Shared_Token_Goal is shifted. If All_Conflicts, return when all
- -- conflict configs have been parsed.
- --
- -- Parsed configs are in Parse_Items; there is more than one if a
- -- conflict is encountered. Parse returns True if at least one
- -- Parse_Item parsed successfully to the goal. In that case, the
- -- other items are either not parsed or failed. See comment in
- -- Parse_Item for more detail.
- --
- -- Raises Bad_Config if parse encounters Unknown_State.
-
-end WisiToken.Parse.LR.McKenzie_Recover.Parse;
diff --git a/packages/wisi/wisitoken-parse-lr-mckenzie_recover.adb
b/packages/wisi/wisitoken-parse-lr-mckenzie_recover.adb
deleted file mode 100644
index 3287fb4..0000000
--- a/packages/wisi/wisitoken-parse-lr-mckenzie_recover.adb
+++ /dev/null
@@ -1,1306 +0,0 @@
--- Abstract :
---
--- See spec
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Characters.Handling;
-with Ada.Exceptions;
-with Ada.Unchecked_Deallocation;
-with System.Multiprocessors;
-with WisiToken.Parse.LR.McKenzie_Recover.Base;
-with WisiToken.Parse.LR.McKenzie_Recover.Explore;
-with WisiToken.Parse.LR.Parser_Lists;
-package body WisiToken.Parse.LR.McKenzie_Recover is
- use all type System.Multiprocessors.CPU_Range;
-
- type Supervisor_Access is access all Base.Supervisor;
- type Shared_Access is access all Base.Shared;
-
- task type Worker_Task is
- entry Start
- (ID : in Integer;
- Super : in Supervisor_Access;
- Shared : in Shared_Access);
- -- Start getting parser/configs to check from Config_Store. Stop when
- -- Super reports All_Done;
-
- entry Done;
- -- Available after Super has reported All_Done.
- end Worker_Task;
-
- type Worker_Access is access Worker_Task;
- procedure Free is new Ada.Unchecked_Deallocation (Worker_Task,
Worker_Access);
-
- task body Worker_Task
- is
- use all type Base.Config_Status;
- Super : Supervisor_Access;
- Shared : Shared_Access;
-
- Status : Base.Config_Status := Valid;
- begin
- loop
- select
- accept Start
- (ID : in Integer;
- Super : in Supervisor_Access;
- Shared : in Shared_Access)
-
- do
- Task_Attributes.Set_Value (ID);
- Worker_Task.Super := Super;
- Worker_Task.Shared := Shared;
- end Start;
- or
- terminate;
- end select;
-
- loop
- Explore.Process_One (Super, Shared, Status);
- exit when Status = All_Done;
- end loop;
-
- accept Done;
-
- Super := null;
- Shared := null;
- end loop;
-
- exception
- when E : others =>
- Super.Fatal (E);
- end Worker_Task;
-
- Worker_Tasks : array (1 .. System.Multiprocessors.CPU_Range'Max (1,
System.Multiprocessors.Number_Of_CPUs - 1)) of
- Worker_Access;
- -- Declaring an array of tasks directly causes a circular elaboration
- -- problem, and would mean a task that terminates due to an exception
- -- is never restarted.
-
- procedure To_Recover
- (Parser_Stack : in Parser_Lists.Parser_Stacks.Stack;
- Tree : in Syntax_Trees.Tree;
- Stack : in out Recover_Stacks.Stack)
- is
- Depth : constant SAL.Peek_Type := Parser_Stack.Depth;
- begin
- pragma Assert (Stack.Depth = 0);
- if Stack.Size < Depth then
- raise SAL.Programmer_Error with "recover stack needs more space;" &
Depth'Image;
- end if;
- for I in reverse 1 .. Depth loop
- declare
- Item : Parser_Lists.Parser_Stack_Item renames Parser_Stack (I);
- Token : constant Recover_Token := (if I = Depth then (others =>
<>) else Tree.Recover_Token (Item.Token));
- begin
- Stack.Push ((Item.State, Item.Token, Token));
- end;
- end loop;
- end To_Recover;
-
- procedure Recover_Init
- (Shared_Parser : in out LR.Parser.Parser;
- Parser_State : in out Parser_Lists.Parser_State)
- is
- use all type WisiToken.Parse.LR.Parser.Language_Fixes_Access;
-
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
- Config : Configuration;
- Error : Parse_Error renames Parser_State.Errors
(Parser_State.Errors.Last);
- begin
- Parser_State.Recover.Enqueue_Count := Parser_State.Recover.Enqueue_Count
+ 1;
-
- Config.Resume_Token_Goal := Parser_State.Shared_Token +
Shared_Parser.Table.McKenzie_Param.Check_Limit;
-
- if Trace_McKenzie > Outline then
- Trace.New_Line;
- Trace.Put_Line
- ("parser" & Integer'Image (Parser_State.Label) &
- ": State" & State_Index'Image (Parser_State.Stack (1).State) &
- " Current_Token " & Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) &
- " Resume_Token_Goal" & WisiToken.Token_Index'Image
(Config.Resume_Token_Goal));
- Trace.Put_Line
- ((case Error.Label is
- when Action => "Action",
- when Check => "Check, " & Semantic_Checks.Image
(Error.Check_Status, Trace.Descriptor.all),
- when Message => raise SAL.Programmer_Error));
- if Trace_McKenzie > Extra then
- Put_Line
- (Trace, Parser_State.Label, "stack: " & Parser_Lists.Image
- (Parser_State.Stack, Trace.Descriptor.all,
Parser_State.Tree));
- end if;
- end if;
-
- -- Additional initialization of Parser_State.Recover is done in
- -- Supervisor.Initialize.
-
- To_Recover (Parser_State.Stack, Parser_State.Tree, Config.Stack);
-
- -- Parser_State.Recover_Insert_Delete must be empty (else we would not
get
- -- here). Therefore Parser_State current token is in
- -- Shared_Parser.Shared_Token.
-
- Config.Current_Shared_Token := Parser_State.Shared_Token;
-
- case Error.Label is
- when Action =>
- Config.Error_Token := Parser_State.Tree.Recover_Token
(Error.Error_Token);
- if Trace_McKenzie > Detail then
- Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config,
- Task_ID => False);
- end if;
-
- when Check =>
- if Shared_Parser.Language_Fixes = null then
- -- The only fix is to ignore the error.
- if Trace_McKenzie > Detail then
- Config.Strategy_Counts (Ignore_Error) := 1;
- Put ("enqueue", Trace, Parser_State.Label,
Shared_Parser.Terminals, Config,
- Task_ID => False);
- end if;
-
- else
- -- Undo the reduction that encountered the error, let Process_One
- -- enqueue possible solutions. We leave the cost at 0, since this
is
- -- the root config. Later logic will enqueue the 'ignore error'
- -- solution; see McKenzie_Recover.Explore Process_One.
-
- Config.Check_Status := Error.Check_Status;
- Config.Error_Token := Config.Stack.Peek.Token;
- Config.Check_Token_Count := Undo_Reduce (Config.Stack,
Parser_State.Tree);
-
- Config_Op_Arrays.Append (Config.Ops, (Undo_Reduce,
Config.Error_Token.ID, Config.Check_Token_Count));
-
- if Trace_McKenzie > Detail then
- Put ("undo_reduce " & Image
- (Config.Error_Token.ID, Trace.Descriptor.all), Trace,
Parser_State.Label,
- Shared_Parser.Terminals, Config, Task_ID => False);
- end if;
- end if;
-
- when Message =>
- -- Last error entry should be the failure that caused us to enter
- -- recovery.
- raise SAL.Programmer_Error;
- end case;
-
- Parser_State.Recover.Config_Heap.Add (Config);
- end Recover_Init;
-
- function Recover (Shared_Parser : in out LR.Parser.Parser) return
Recover_Status
- is
- use all type Parser.Post_Recover_Access;
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
-
- Parsers : Parser_Lists.List renames Shared_Parser.Parsers;
-
- Skip_Next : Boolean := False;
-
- Super : aliased Base.Supervisor
- (Trace'Access,
- Check_Delta_Limit =>
Shared_Parser.Table.McKenzie_Param.Check_Delta_Limit,
- Enqueue_Limit => Shared_Parser.Table.McKenzie_Param.Enqueue_Limit,
- Parser_Count => Parsers.Count);
-
- Shared : aliased Base.Shared
- (Shared_Parser.Trace,
- Shared_Parser.Lexer.all'Access,
- Shared_Parser.Table,
- Shared_Parser.Language_Fixes,
- Shared_Parser.Language_Matching_Begin_Tokens,
- Shared_Parser.Language_String_ID_Set,
- Shared_Parser.Terminals'Access,
- Shared_Parser.Line_Begin_Token'Access);
-
- Task_Count : constant System.Multiprocessors.CPU_Range :=
- (if Shared_Parser.Table.McKenzie_Param.Task_Count = 0
- then Worker_Tasks'Last
- -- Keep one CPU free for this main task, and the user.
- else Shared_Parser.Table.McKenzie_Param.Task_Count);
-
- begin
- if Trace_McKenzie > Outline then
- Trace.New_Line;
- Trace.Put_Line (" McKenzie error recovery");
- end if;
-
- Super.Initialize (Parsers'Unrestricted_Access,
Shared_Parser.Terminals'Unrestricted_Access);
-
- for Parser_State of Parsers loop
- Recover_Init (Shared_Parser, Parser_State);
- end loop;
-
- if Trace_McKenzie > Outline then
- Trace.New_Line;
- Trace.Put_Line (Task_Count'Image & " parallel tasks");
- end if;
-
- for I in Worker_Tasks'First .. Task_Count loop
- if Worker_Tasks (I) = null then
- Worker_Tasks (I) := new Worker_Task;
- if Debug_Mode then
- Trace.Put_Line ("new Worker_Task" &
System.Multiprocessors.CPU_Range'Image (I));
- end if;
-
- elsif Worker_Tasks (I)'Terminated then
- Free (Worker_Tasks (I));
- Worker_Tasks (I) := new Worker_Task;
- if Debug_Mode then
- Trace.Put_Line ("recreated Worker_Task" &
System.Multiprocessors.CPU_Range'Image (I));
- end if;
- end if;
-
- Worker_Tasks (I).Start (Integer (I), Super'Unchecked_Access,
Shared'Unchecked_Access);
- end loop;
-
- declare
- use Ada.Exceptions;
- ID : Exception_Id;
- Message : Ada.Strings.Unbounded.Unbounded_String;
- begin
- Super.Done (ID, Message); -- Wait for all parsers to fail or succeed
-
- -- Ensure all worker tasks stop getting configs before proceeding;
- -- otherwise local variables disappear while the task is still trying
- -- to access them.
- for I in Worker_Tasks'First .. Task_Count loop
- if not Worker_Tasks (I)'Terminated then
- Worker_Tasks (I).Done;
- end if;
- end loop;
-
- if ID /= Null_Id then
- Raise_Exception (ID, -Message);
- end if;
- end;
-
- -- Spawn new parsers for multiple solutions.
- --
- -- One option here would be to keep only the parser with the least
- -- cost fix. However, the normal reason for having multiple parsers
- -- is to resolve a grammar ambiguity; the least cost fix might
- -- resolve the ambiguity the wrong way. As could any other fix, of
- -- course.
- --
- -- We could try to check here for redundant solutions; configs for a
- -- parser that have the same or "equivalent" ops. But those will be
- -- caught in the main parse by the check for duplicate state; doing
- -- the same check here is premature optimization.
- declare
- use Parser_Lists;
-
- Cur : Cursor := Parsers.First;
- Solutions : SAL.Base_Peek_Type := 0;
- Spawn_Limit : SAL.Base_Peek_Type := Shared_Parser.Max_Parallel; --
per parser
- begin
- for Parser of Parsers loop
- if Parser.Recover.Success then
- Solutions := Solutions + Parser.Recover.Results.Count;
- end if;
- end loop;
-
- if Solutions > Shared_Parser.Max_Parallel and Trace_McKenzie >
Outline then
- Trace.Put_Line ("too many parallel parsers required in recover;
dropping some solutions");
- Spawn_Limit := Shared_Parser.Max_Parallel / Parsers.Count;
- end if;
-
- loop
- declare
- Data : McKenzie_Data renames State_Ref (Cur).Recover;
- begin
- if Data.Success then
- if Trace_McKenzie > Outline then
- Trace.Put_Line
- (Integer'Image (Label (Cur)) &
- ": succeed" & SAL.Base_Peek_Type'Image
(Data.Results.Count) &
- ", enqueue" & Integer'Image (Data.Enqueue_Count) &
- ", check " & Integer'Image (Data.Check_Count) &
- ", cost: " & Integer'Image (Data.Results.Min_Key));
- end if;
-
- if Data.Results.Count > 1 then
- for I in 1 .. SAL.Base_Peek_Type'Min (Spawn_Limit,
Data.Results.Count - 1) loop
- Parsers.Prepend_Copy (Cur); -- does not copy recover
- if Trace_McKenzie > Outline or Trace_Parse > Outline
then
- Trace.Put_Line
- ("spawn parser" & Integer'Image
(Parsers.First.Label) & " from " &
- Trimmed_Image (Cur.Label) & " (" &
Trimmed_Image (Integer (Parsers.Count)) &
- " active)");
- Put ("", Trace, Parsers.First.Label,
Shared_Parser.Terminals,
- Data.Results.Peek, Task_ID => False, Strategy
=> True);
- end if;
-
- State_Ref (Parsers.First).Recover.Results.Add
(Data.Results.Remove);
- State_Ref (Parsers.First).Recover.Success := True;
- end loop;
- end if;
-
- if Trace_McKenzie > Outline or Trace_Parse > Outline then
- Put ("", Trace, Cur.State_Ref.Label,
Shared_Parser.Terminals, Data.Results.Peek,
- Task_ID => False, Strategy => True);
- end if;
- else
- if Trace_McKenzie > Outline then
- Trace.Put_Line
- (Integer'Image (Cur.Label) &
- ": fail, enqueue" & Integer'Image
(Data.Enqueue_Count) &
- (if Data.Config_Full_Count > 0 then ", config_full"
& Data.Config_Full_Count'Image else "") &
- ", check " & Integer'Image (Data.Check_Count) &
- ", max shared_token " & WisiToken.Token_Index'Image
(Shared_Parser.Terminals.Last_Index));
- end if;
- end if;
-
- end;
- Next (Cur);
- exit when Is_Done (Cur);
- end loop;
- end;
-
- -- Edit Parser_State to apply solutions.
-
- -- We don't use 'for Parser_State of Parsers loop' here,
- -- because we might need to terminate a parser.
- declare
- Current_Parser : Parser_Lists.Cursor := Parsers.First;
- begin
- loop
- exit when Current_Parser.Is_Done;
-
- if Current_Parser.State_Ref.Recover.Success then
- begin
- -- Can't have active 'renames State_Ref' when terminate a
parser
- declare
- use Parser_Lists;
- use Config_Op_Arrays, Config_Op_Array_Refs;
-
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
-
- Descriptor : WisiToken.Descriptor renames
Shared_Parser.Trace.Descriptor.all;
- Stack : Parser_Stacks.Stack renames
Parser_State.Stack;
- Tree : Syntax_Trees.Tree renames Parser_State.Tree;
- Data : McKenzie_Data renames Parser_State.Recover;
- Result : Configuration renames Data.Results.Peek;
-
- Stack_Matches_Ops : Boolean := True;
- Shared_Token_Changed : Boolean := False;
- Current_Token_Virtual : Boolean := False;
- First_Insert : Boolean := True;
- begin
- -- The verb will be reset by the main parser; just
indicate the
- -- parser recovered from the error.
- Parser_State.Set_Verb (Shift);
-
- Parser_State.Errors (Parser_State.Errors.Last).Recover :=
Result;
-
- Parser_State.Resume_Token_Goal :=
Result.Resume_Token_Goal;
-
- if Trace_McKenzie > Extra then
- Put_Line (Trace, Parser_State.Label, "before Ops
applied:", Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "stack " & Image (Stack,
Descriptor, Tree),
- Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "Shared_Token " & Image
- (Parser_State.Shared_Token,
Shared_Parser.Terminals, Descriptor),
- Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "Current_Token " &
Parser_State.Tree.Image
- (Parser_State.Current_Token, Descriptor),
- Task_ID => False);
- end if;
-
- -- We don't apply all Ops to the parser stack here,
because there can
- -- be other input tokens between the inserts and
deletes, and there
- -- can be conflicts; we let the main parser handle that.
We can apply
- -- all ops up to the first insert.
- --
- -- Other than Add_Terminal, there's no need to modify
- -- Parser_State.Tree. Any tree nodes created by the
failed parse that
- -- are pushed back are useful for error repair, and will
just be
- -- ignored in future parsing. This also avoids enlarging
a
- -- non-flushed branched tree, which saves time and space.
- --
- -- Language_Fixes may abuse the rules about adding Ops,
so we check
- -- that as much as is reasonable here. We use Assert to
get an
- -- immediate error in a debug build, and raise
Bad_Config to avoid
- -- further corruption in a release build.
-
- for I in First_Index (Result.Ops) .. Last_Index
(Result.Ops) loop
- declare
- Op : Config_Op renames Constant_Ref (Result.Ops, I);
- begin
- case Op.Op is
- when Fast_Forward =>
- -- The parser would do shifts and reduces for
the tokens we are
- -- skipping here
- Stack_Matches_Ops := False;
-
- when Undo_Reduce =>
- -- If Stack_Matches_Ops, we must do the
Stack.Pop and Pushes, and we
- -- can use Stack.Peek to check if the
Undo_Reduce is valid.
- --
- -- If not Stack_Matches_Ops, we have to assume
Undo_Reduce is valid.
- --
- -- See test_mckenzie_recover.adb Extra_Begin
for an example of Undo_Reduce
- -- after other ops.
- if Stack_Matches_Ops then
- if not (Tree.Is_Nonterm (Stack.Peek.Token) and
- (I = First_Index (Result.Ops) or
else
- Push_Back_Valid
- (Tree.First_Shared_Terminal
(Stack.Peek.Token), Result.Ops, I - 1)))
- then
- pragma Assert (False);
- if Trace_McKenzie > Outline then
- Put_Line
- (Trace, Parser_State.Label, "invalid
Undo_Reduce in apply config",
- Task_ID => False);
- end if;
- raise Bad_Config;
- end if;
-
- for C of Tree.Children (Stack.Pop.Token) loop
- Stack.Push ((Tree.State (C), C));
- end loop;
- end if;
-
- when Push_Back =>
- -- If Stack_Matches_Ops, we must do the
Stack.Pop, and can use that
- -- to check if the Push_Back is valid.
- --
- -- If not Stack_Matches_Ops, we have to assume
Op.PB_Token_Index is
- -- correct, and we do not do Stack.Pop. We can
still check the target
- -- token index against the previous ops.
- --
- -- See test_mckenzie_recover.adb Erorr_2 for an
example of Push_Back
- -- after other ops.
- if not
- (I = First_Index (Result.Ops) or else
- Push_Back_Valid
- (Target_Token_Index =>
- (if Stack_Matches_Ops
- then Tree.First_Shared_Terminal
(Stack.Peek.Token)
- else Op.PB_Token_Index),
- Ops => Result.Ops,
- Prev_Op => I - 1))
- then
- if Trace_McKenzie > Outline then
- Put_Line
- (Trace, Parser_State.Label, "invalid
Push_Back in apply config op" & I'Image,
- Task_ID => False);
- end if;
- pragma Assert (False);
- raise Bad_Config;
- end if;
-
- if Stack_Matches_Ops then
- Stack.Pop;
-
- if Op.PB_Token_Index /= Invalid_Token_Index
then
- -- Pushing back an empty nonterm has no
effect on the input stream.
- Parser_State.Shared_Token :=
Op.PB_Token_Index;
- Shared_Token_Changed := True;
- end if;
- end if;
-
- when Insert =>
- Recover_Op_Arrays.Append
- (Parser_State.Recover_Insert_Delete,
- (Op => Insert,
- Ins_ID => Op.Ins_ID,
- Ins_Token_Index => Op.Ins_Token_Index,
- Ins_Tree_Node => Invalid_Node_Index));
-
- if Parser_State.Recover_Insert_Delete_Current =
No_Index then
- Parser_State.Recover_Insert_Delete_Current :=
- Recover_Op_Arrays.Last_Index
(Parser_State.Recover_Insert_Delete);
- end if;
-
- if First_Insert and Op.Ins_Token_Index =
Parser_State.Shared_Token then
- -- We need First_Insert here, not just
Stack_Matches_Ops, when the
- -- first insert is preceeded only by
Push_Back and Undo_Reduce, with
- -- at least one Undo_Reduce (so
Stack_Matches_Ops is False when we
- -- get here). See test_mckenzie_recover.adb
Missing_Name_3
-
- First_Insert := False;
-
- -- Normally Insert is completed by
Stack.Push; we let the main parser
- -- do that.
- Stack_Matches_Ops := False;
-
- -- Add_Terminal is normally done in the
lexer phase, so we do this here.
- Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
- (Op.Ins_ID, Op.Ins_Token_Index);
- Recover_Op_Array_Refs.Variable_Ref
- (Parser_State.Recover_Insert_Delete,
- Recover_Op_Arrays.Last_Index
(Parser_State.Recover_Insert_Delete)).Ins_Tree_Node :=
- Parser_State.Current_Token;
-
- Current_Token_Virtual :=
True;
- Parser_State.Recover_Insert_Delete_Current :=
No_Index;
- else
- -- Let main parser handle it
- null;
- end if;
-
- when Delete =>
- Recover_Op_Arrays.Append
- (Parser_State.Recover_Insert_Delete,
- (Op => Delete,
- Del_ID => Op.Del_ID,
- Del_Token_Index => Op.Del_Token_Index));
-
- if Stack_Matches_Ops and Op.Del_Token_Index =
Parser_State.Shared_Token then
- -- Delete has no effect on Stack, so we can
apply multiple deletes.
- Parser_State.Shared_Token :=
Op.Del_Token_Index + 1;
- Shared_Token_Changed := True;
-
- Parser_State.Recover_Insert_Delete_Current :=
No_Index;
- else
- if Parser_State.Recover_Insert_Delete_Current
= No_Index then
- Parser_State.Recover_Insert_Delete_Current
:=
- Recover_Op_Arrays.Last_Index
(Parser_State.Recover_Insert_Delete);
- end if;
-
- end if;
-
- end case;
- end;
- end loop;
-
- -- If not Shared_Token_Changed, Shared_Token is the
error token,
- -- which is the next token to read. If
Shared_Token_Changed, we have
- -- set Shared_Token consistent with that; it is the next
token to
- -- read. If Current_Token_Virtual, then after all the
virtual tokens
- -- are inserted, the main parser would normally increment
- -- Parser_State.Shared_Token to get the next token, but
we don't want
- -- that now. We could set Shared_Token to 1 less, but
this way the
- -- debug messages all show the expected Shared_Terminal.
-
- Parser_State.Inc_Shared_Token := not
Current_Token_Virtual;
-
- -- The main parser always sets Current_Token to be the
syntax tree
- -- node containing Shared_Token; ensure that is true
here (virtual
- -- tokens where handled above).
-
- if (not Current_Token_Virtual) and Shared_Token_Changed
then
- Parser_State.Current_Token := Shared_Parser.Terminals
- (Parser_State.Shared_Token).Tree_Index;
- end if;
-
- if Trace_McKenzie > Extra then
- Put_Line (Trace, Parser_State.Label, "after Ops
applied:", Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "stack " &
Parser_Lists.Image
- (Stack, Descriptor, Tree),
- Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "Shared_Token " & Image
- (Parser_State.Shared_Token,
Shared_Parser.Terminals, Descriptor), Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "Current_Token " &
Parser_State.Tree.Image
- (Parser_State.Current_Token, Descriptor), Task_ID
=> False);
- Put_Line
- (Trace, Parser_State.Label, "recover_insert_delete" &
- Parser_State.Recover_Insert_Delete_Current'Image
& ":" &
- Image (Parser_State.Recover_Insert_Delete,
Descriptor), Task_ID => False);
- Put_Line
- (Trace, Parser_State.Label, "inc_shared_token " &
- Boolean'Image (Parser_State.Inc_Shared_Token),
- Task_ID => False);
- end if;
- end;
- exception
- when Bad_Config =>
- if Parsers.Count = 1 then
- -- Oops. just give up
- return Fail_Programmer_Error;
- end if;
- Parsers.Terminate_Parser (Current_Parser, "bad config in
recover", Trace, Shared_Parser.Terminals);
- -- Terminate advances Current_Parser
- Skip_Next := True;
- end;
- end if;
- if Skip_Next then
- Skip_Next := False;
- else
- Current_Parser.Next;
- end if;
- end loop;
- end;
- if Shared_Parser.Post_Recover /= null then
- Shared_Parser.Post_Recover.all;
- end if;
-
- return Super.Recover_Result;
-
- exception
- when E : others =>
- if Debug_Mode then
- Trace.Put (Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E), Prefix => True);
- Trace.New_Line;
- raise;
- else
- return Fail_Programmer_Error;
- end if;
- end Recover;
-
- ----------
- -- Spec private subprograms; for language-specific
- -- child packages.
-
- procedure Check (ID : Token_ID; Expected_ID : in Token_ID)
- is begin
- pragma Assert (ID = Expected_ID, Token_ID'Image (ID) & " /=" &
Token_ID'Image (Expected_ID));
- end Check;
-
- function Current_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out WisiToken.Base_Token_Index;
- Restore_Terminals_Current : out WisiToken.Base_Token_Index;
- Insert_Delete : aliased in out Config_Op_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type)
- return Base_Token
- is
- use Config_Op_Arrays;
- use Config_Op_Array_Refs;
-
- procedure Inc_I_D
- is begin
- Current_Insert_Delete := Current_Insert_Delete + 1;
- if Current_Insert_Delete > Last_Index (Insert_Delete) then
- Current_Insert_Delete := No_Insert_Delete;
- Clear (Insert_Delete);
- end if;
- end Inc_I_D;
-
- begin
- if Terminals_Current = Invalid_Token_Index then
- -- Happens with really bad syntax; see test_mckenzie_recover.adb
Error_4.
- raise Bad_Config;
- end if;
-
- loop
- if Current_Insert_Delete = No_Insert_Delete then
- Restore_Terminals_Current := Terminals_Current;
- return Terminals (Terminals_Current);
-
- elsif Token_Index (Constant_Ref (Insert_Delete,
Current_Insert_Delete)) = Terminals_Current then
- declare
- Op : Insert_Delete_Op renames Constant_Ref (Insert_Delete,
Current_Insert_Delete);
- begin
- case Insert_Delete_Op_Label (Op.Op) is
- when Insert =>
- -- Decrement Terminals_Current so Next_Token knows it
should always
- -- increment it. Save the initial value, to restore in case
of error.
- Restore_Terminals_Current := Terminals_Current;
- Terminals_Current := Terminals_Current - 1;
- return (ID => ID (Op), others => <>);
-
- when Delete =>
- Terminals_Current := Terminals_Current + 1;
- Restore_Terminals_Current := Terminals_Current;
- Inc_I_D;
- end case;
- end;
- else
- return Terminals (Terminals_Current);
- end if;
- end loop;
- end Current_Token;
-
- function Current_Token_ID_Peek
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in Base_Token_Index;
- Insert_Delete : aliased in Config_Op_Arrays.Vector;
- Current_Insert_Delete : in SAL.Base_Peek_Type)
- return Token_ID
- is
- use Config_Op_Array_Refs;
-
- Result : Token_ID;
- begin
- if Terminals_Current = Base_Token_Index'First then
- -- Happens with really bad syntax.
- raise Bad_Config;
- end if;
-
- -- First set Result from Terminals; may be overridden by
- -- Insert_Delete below.
- Result := Terminals (Terminals_Current).ID;
-
- if Current_Insert_Delete = No_Insert_Delete then
- null;
-
- elsif Token_Index (Constant_Ref (Insert_Delete, Current_Insert_Delete))
= Terminals_Current then
- declare
- Op : Insert_Delete_Op renames Constant_Ref (Insert_Delete,
Current_Insert_Delete);
- begin
- case Insert_Delete_Op_Label (Op.Op) is
- when Insert =>
- Result := Op.Ins_ID;
-
- when Delete =>
- -- This should have been handled in Check
- raise SAL.Programmer_Error;
- end case;
- end;
- end if;
- return Result;
- end Current_Token_ID_Peek;
-
- procedure Current_Token_ID_Peek_3
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in Base_Token_Index;
- Insert_Delete : aliased in Config_Op_Arrays.Vector;
- Current_Insert_Delete : in SAL.Base_Peek_Type;
- Tokens : out Token_ID_Array_1_3)
- is
- Terminals_Next : WisiToken.Token_Index := Terminals_Current + 1;
- begin
- if Terminals_Current = Base_Token_Index'First then
- -- Happens with really bad syntax; see test_mckenzie_recover.adb
Error_4.
- raise Bad_Config;
- end if;
-
- -- First set Tokens from Terminals; may be overridden by
- -- Insert_Delete below.
- Tokens (1) := Terminals (Terminals_Current).ID;
- if Terminals_Next <= Terminals.Last_Index then
- Tokens (2) := Terminals (Terminals_Next).ID;
- Terminals_Next := Terminals_Next + 1;
- if Terminals_Next <= Terminals.Last_Index then
- Tokens (3) := Terminals (Terminals_Next).ID;
- else
- Tokens (3) := Invalid_Token_ID;
- end if;
- else
- Tokens (2) := Invalid_Token_ID;
- Tokens (3) := Invalid_Token_ID;
- end if;
-
- if Current_Insert_Delete = No_Insert_Delete then
- null;
- else
- for I in Tokens'Range loop
- declare
- use Config_Op_Arrays, Config_Op_Array_Refs;
- J : constant SAL.Base_Peek_Type := Current_Insert_Delete +
SAL.Peek_Type (I) - 1;
- begin
- if (J in First_Index (Insert_Delete) .. Last_Index
(Insert_Delete)) and then
- Token_Index (Constant_Ref (Insert_Delete, J)) =
Terminals_Current
- then
- declare
- Op : Insert_Delete_Op renames Constant_Ref
(Insert_Delete, J);
- begin
- case Insert_Delete_Op_Label (Op.Op) is
- when Insert =>
- Tokens (I) := Op.Ins_ID;
-
- when Delete =>
- -- This should have been handled in Check
- raise SAL.Programmer_Error;
- end case;
- end;
- end if;
- end;
- end loop;
- end if;
- end Current_Token_ID_Peek_3;
-
- procedure Delete_Check
- (Terminals : in Base_Token_Arrays.Vector;
- Config : in out Configuration;
- ID : in Token_ID)
- is
- use Config_Op_Arrays;
- Op : constant Config_Op := (Delete, ID, Config.Current_Shared_Token);
- begin
- Check (Terminals (Config.Current_Shared_Token).ID, ID);
- if Is_Full (Config.Ops) or Is_Full (Config.Insert_Delete) then
- raise Bad_Config;
- end if;
- Append (Config.Ops, Op);
- Append (Config.Insert_Delete, Op);
- Config.Current_Insert_Delete := 1;
- end Delete_Check;
-
- procedure Delete_Check
- (Terminals : in Base_Token_Arrays.Vector;
- Config : in out Configuration;
- Index : in out WisiToken.Token_Index;
- ID : in Token_ID)
- is begin
- Check (Terminals (Index).ID, ID);
- Delete (Terminals, Config, Index);
- end Delete_Check;
-
- procedure Delete
- (Terminals : in Base_Token_Arrays.Vector;
- Config : in out Configuration;
- Index : in out WisiToken.Token_Index)
- is
- use Config_Op_Arrays;
- Op : constant Config_Op := (Delete, Terminals (Index).ID, Index);
- begin
- if Is_Full (Config.Ops) or Is_Full (Config.Insert_Delete) then
- raise Bad_Config;
- end if;
- Append (Config.Ops, Op);
- Append (Config.Insert_Delete, Op);
- Config.Current_Insert_Delete := 1;
- Index := Index + 1;
- end Delete;
-
- function Find_ID
- (Config : in Configuration;
- ID : in Token_ID)
- return Boolean
- is begin
- for I in 1 .. Config.Stack.Depth - 1 loop
- -- Depth has Invalid_Token_ID
- if ID = Config.Stack.Peek (I).Token.ID then
- return True;
- end if;
- end loop;
- return False;
- end Find_ID;
-
- procedure Find_ID
- (Config : in Configuration;
- ID : in Token_ID;
- Matching_Index : in out SAL.Peek_Type)
- is begin
- loop
- exit when Matching_Index = Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- declare
- Stack_ID : Token_ID renames Config.Stack.Peek
(Matching_Index).Token.ID;
- begin
- exit when Stack_ID = ID;
- end;
- Matching_Index := Matching_Index + 1;
- end loop;
- end Find_ID;
-
- procedure Find_ID
- (Config : in Configuration;
- IDs : in Token_ID_Set;
- Matching_Index : in out SAL.Peek_Type)
- is begin
- loop
- exit when Matching_Index >= Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- declare
- ID : Token_ID renames Config.Stack.Peek (Matching_Index).Token.ID;
- begin
- exit when ID in IDs'First .. IDs'Last and then IDs (ID);
- end;
- Matching_Index := Matching_Index + 1;
- end loop;
- end Find_ID;
-
- procedure Find_Descendant_ID
- (Tree : in Syntax_Trees.Tree;
- Config : in Configuration;
- ID : in Token_ID;
- ID_Set : in Token_ID_Set;
- Matching_Index : in out SAL.Peek_Type)
- is
- use Syntax_Trees;
- begin
- loop
- exit when Matching_Index >= Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- exit when Config.Stack.Peek (Matching_Index).Token.ID in ID_Set'Range
and then
- (ID_Set (Config.Stack.Peek (Matching_Index).Token.ID) and
- (Config.Stack.Peek (Matching_Index).Tree_Index /=
Invalid_Node_Index and then
- Tree.Find_Descendant (Config.Stack.Peek
(Matching_Index).Tree_Index, ID) /= Invalid_Node_Index));
-
- Matching_Index := Matching_Index + 1;
- end loop;
- end Find_Descendant_ID;
-
- procedure Find_Matching_Name
- (Config : in Configuration;
- Lexer : access constant WisiToken.Lexer.Instance'Class;
- Name : in String;
- Matching_Name_Index : in out SAL.Peek_Type;
- Case_Insensitive : in Boolean)
- is
- use Ada.Characters.Handling;
- Match_Name : constant String := (if Case_Insensitive then To_Lower
(Name) else Name);
- begin
- loop
- exit when Matching_Name_Index >= Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- declare
- Token : Recover_Token renames Config.Stack.Peek
(Matching_Name_Index).Token;
- Name_Region : constant Buffer_Region :=
- (if Token.Name = Null_Buffer_Region
- then Token.Byte_Region
- else Token.Name);
- begin
- exit when Name_Region /= Null_Buffer_Region and then
- Match_Name =
- (if Case_Insensitive
- then To_Lower (Lexer.Buffer_Text (Name_Region))
- else Lexer.Buffer_Text (Name_Region));
-
- Matching_Name_Index := Matching_Name_Index + 1;
- end;
- end loop;
- end Find_Matching_Name;
-
- procedure Find_Matching_Name
- (Config : in Configuration;
- Lexer : access constant WisiToken.Lexer.Instance'Class;
- Name : in String;
- Matching_Name_Index : in out SAL.Peek_Type;
- Other_ID : in Token_ID;
- Other_Count : out Integer;
- Case_Insensitive : in Boolean)
- is
- use Ada.Characters.Handling;
- Match_Name : constant String := (if Case_Insensitive then To_Lower
(Name) else Name);
- begin
- Other_Count := 0;
-
- loop
- exit when Matching_Name_Index >= Config.Stack.Depth; -- Depth has
Invalid_Token_ID
- declare
- Token : Recover_Token renames Config.Stack.Peek
(Matching_Name_Index).Token;
- Name_Region : constant Buffer_Region :=
- (if Token.Name = Null_Buffer_Region
- then Token.Byte_Region
- else Token.Name);
- begin
- exit when Name_Region /= Null_Buffer_Region and then
- Match_Name =
- (if Case_Insensitive
- then To_Lower (Lexer.Buffer_Text (Name_Region))
- else Lexer.Buffer_Text (Name_Region));
-
- if Other_ID = Token.ID then
- Other_Count := Other_Count + 1;
- end if;
-
- Matching_Name_Index := Matching_Name_Index + 1;
- end;
- end loop;
- end Find_Matching_Name;
-
- procedure Insert (Config : in out Configuration; ID : in Token_ID)
- is begin
- Insert (Config, Config.Current_Shared_Token, ID);
- end Insert;
-
- procedure Insert (Config : in out Configuration; IDs : in Token_ID_Array)
- is begin
- for ID of IDs loop
- Insert (Config, ID);
- end loop;
- end Insert;
-
- procedure Insert (Config : in out Configuration; Index : in
WisiToken.Token_Index; ID : in Token_ID)
- is
- use Config_Op_Arrays;
- Op : constant Config_Op := (Insert, ID, Index);
- begin
- if Is_Full (Config.Ops) or Is_Full (Config.Insert_Delete) then
- raise Bad_Config;
- end if;
- Append (Config.Ops, Op);
- Append (Config.Insert_Delete, Op);
- Config.Current_Insert_Delete := 1;
- end Insert;
-
- function Next_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out Base_Token_Index;
- Restore_Terminals_Current : in out WisiToken.Base_Token_Index;
- Insert_Delete : aliased in out Config_Op_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type)
- return Base_Token
- is
- use Config_Op_Arrays, Config_Op_Array_Refs;
-
- function Next_Terminal return Base_Token
- is begin
- Terminals_Current := Terminals_Current + 1;
- Restore_Terminals_Current := Terminals_Current;
- return Terminals (Terminals_Current);
- end Next_Terminal;
-
- begin
- loop
- if Last_Index (Insert_Delete) > 0 and then Current_Insert_Delete =
Last_Index (Insert_Delete) then
- Current_Insert_Delete := No_Insert_Delete;
- Clear (Insert_Delete);
- return Next_Terminal;
-
- elsif Current_Insert_Delete = No_Insert_Delete then
- return Next_Terminal;
-
- elsif Token_Index (Constant_Ref (Insert_Delete, Current_Insert_Delete
+ 1)) = Terminals_Current + 1 then
- Current_Insert_Delete := Current_Insert_Delete + 1;
- declare
- Op : Insert_Delete_Op renames Constant_Ref (Insert_Delete,
Current_Insert_Delete);
- begin
- case Insert_Delete_Op_Label'(Op.Op) is
- when Insert =>
- return (ID => Op.Ins_ID, others => <>);
-
- when Delete =>
- Terminals_Current := Terminals_Current + 1;
- Restore_Terminals_Current := Terminals_Current;
- end case;
- end;
-
- else
- return Next_Terminal;
- end if;
- end loop;
- end Next_Token;
-
- function Push_Back_Valid
- (Target_Token_Index : in WisiToken.Base_Token_Index;
- Ops : in Config_Op_Arrays.Vector;
- Prev_Op : in Positive_Index_Type)
- return Boolean
- is
- use Config_Op_Arrays;
- Fast_Forward_Seen : Boolean := False;
- begin
- -- We require a Fast_Forward after Insert or Delete, to eliminate
- -- duplicate results from push_back before and after a
- -- delete (see test_mckenzie_recover.adb Extra_Begin).
- --
- -- If Target_Token_Index is greater than the new current terminal
- -- implied by Prev_Op, the Push_Back is valid. Otherwise, it is
- -- invalid (it should have been done first); we only need to look at
- -- one op other than Fast_Forward.
- for I in reverse First_Index (Ops) .. Prev_Op loop
- declare
- Op : Config_Op renames Element (Ops, I);
- begin
- case Op.Op is
- when Fast_Forward =>
- -- We need to see the op before the Fast_Forward to tell if
Push_Back
- -- to Target_Token_Index is ok.
- Fast_Forward_Seen := True;
-
- when Undo_Reduce =>
- -- We don't know what the new terminal is from this op. We'll
just
- -- have to trust the programmers.
- return True;
-
- when Push_Back =>
- -- If neither the proposed Push_Back nor Op is for an empty
token,
- -- successive Push_Backs have decreasing targets; see
- -- test_mckenzie_recover.adb Missing_Name_0.
- --
- -- However, if there is a Fast_Forward between two Push_Backs,
- -- Target_Token_Index must be >= Op.PB_Token_Index. See
- -- ada-mode-recover_27.adb.
- --
- -- If called from Undo_Reduce_Valid where the Undo_Reduce
token is
- -- empty, we get Target_Token_Index = Op.PB_Token_Index.
- return Target_Token_Index = Invalid_Token_Index or else
- Op.PB_Token_Index = Invalid_Token_Index or else
- (if Fast_Forward_Seen
- then Target_Token_Index > Op.PB_Token_Index
- else Target_Token_Index <= Op.PB_Token_Index);
-
- when Insert =>
- -- If Target_Token_Index = Op.Ins_Token_Index, we want the edit
- -- point to be at the same token as before; that's ok.
- --
- -- If Target_Token_Index > Ins_Token_Index, the Push_Back is
partway
- -- into a Fast_Forward.
- return Fast_Forward_Seen and
- (Target_Token_Index = Invalid_Token_Index or else
- Target_Token_Index >= Op.Ins_Token_Index);
-
- when Delete =>
- -- As for Insert
- return Fast_Forward_Seen and
- (Target_Token_Index = Invalid_Token_Index or else
- Target_Token_Index >= Op.Del_Token_Index);
- end case;
- end;
- end loop;
- -- We can only get here if the only ops in Ops are Fast_Forward,
- -- which is a programming error.
- pragma Assert (False);
- raise Bad_Config;
- end Push_Back_Valid;
-
- procedure Push_Back (Config : in out Configuration)
- is
- use Config_Op_Arrays, Config_Op_Array_Refs;
-
- Item : constant Recover_Stack_Item := Config.Stack.Pop;
- Token_Index : constant Base_Token_Index :=
Item.Token.Min_Terminal_Index;
-
- function Compare (Left : in Base_Token_Index; Right : in Config_Op)
return Boolean
- is (case Right.Op is
- when Fast_Forward => False,
- when Undo_Reduce => False,
- when Push_Back => False,
- when Insert => Left < Right.Ins_Token_Index,
- when Delete => Left < Right.Del_Token_Index);
- -- If Left = Right.Token_Index, we assume the Right ops go _after_
- -- the Left, so the Left do not need to be repeated.
- begin
- if Token_Index /= Invalid_Token_Index then
- Config.Current_Shared_Token := Token_Index;
- for I in First_Index (Config.Ops) .. Last_Index (Config.Ops) loop
- if Compare (Token_Index, Constant_Ref (Config.Ops, I)) then
- if Is_Full (Config.Insert_Delete) then
- raise Bad_Config;
- end if;
- Append (Config.Insert_Delete, Constant_Ref (Config.Ops, I));
- end if;
- end loop;
- end if;
-
- if Is_Full (Config.Ops) then
- raise Bad_Config;
- end if;
- Append (Config.Ops, (Push_Back, Item.Token.ID,
Config.Current_Shared_Token));
- end Push_Back;
-
- procedure Push_Back_Check (Config : in out Configuration; Expected_ID : in
Token_ID)
- is begin
- Check (Config.Stack.Peek (1).Token.ID, Expected_ID);
- Push_Back (Config);
- end Push_Back_Check;
-
- procedure Push_Back_Check (Config : in out Configuration; Expected : in
Token_ID_Array)
- is begin
- for ID of Expected loop
- if Push_Back_Valid (Config) then
- Push_Back_Check (Config, ID);
- else
- raise Bad_Config;
- end if;
- end loop;
- end Push_Back_Check;
-
- procedure Put
- (Message : in String;
- Trace : in out WisiToken.Trace'Class;
- Parser_Label : in Natural;
- Terminals : in Base_Token_Arrays.Vector;
- Config : in Configuration;
- Task_ID : in Boolean := True;
- Strategy : in Boolean := False)
- is
- -- For debugging output
-
- -- Build a string, call trace.put_line once, so output from multiple
- -- tasks is not interleaved (mostly).
- use Config_Op_Array_Refs;
- use all type Ada.Strings.Unbounded.Unbounded_String;
- use all type WisiToken.Semantic_Checks.Check_Status_Label;
-
- Descriptor : WisiToken.Descriptor renames Trace.Descriptor.all;
-
- Result : Ada.Strings.Unbounded.Unbounded_String :=
- (if Task_ID then +"task" & Task_Attributes.Value'Image else +"") &
- Integer'Image (Parser_Label) & ": " &
- (if Message'Length > 0 then Message & ":" else "");
- begin
- Result := Result & Natural'Image (Config.Cost);
- if Strategy or Trace_McKenzie > Extra then
- Result := Result & ", (";
- for C of Config.Strategy_Counts loop
- Result := Result & Integer'Image (C);
- end loop;
- Result := Result & "), ";
- else
- Result := Result & ", ";
- end if;
- if Config.Check_Status.Label /= Ok then
- Result := Result & Semantic_Checks.Check_Status_Label'Image
(Config.Check_Status.Label) & " ";
- elsif Config.Error_Token.ID /= Invalid_Token_ID then
- Result := Result & "Error " & Image (Config.Error_Token, Descriptor)
& " ";
- end if;
- Result := Result & Image (Config.Stack, Descriptor, Depth => 1);
-
- if Config.Current_Insert_Delete = No_Insert_Delete then
- Result := Result & "|" & Image (Config.Current_Shared_Token,
Terminals, Descriptor) & "|";
- else
- Result := Result & "/" & Trimmed_Image (Config.Current_Insert_Delete)
& ":" &
- Image (Constant_Ref (Config.Insert_Delete,
Config.Current_Insert_Delete), Descriptor) & "/";
- end if;
-
- Result := Result & Image (Config.Ops, Descriptor);
- if Config.Minimal_Complete_State /= None then
- Result := Result & " minimal_complete " &
Config.Minimal_Complete_State'Image;
- end if;
- Trace.Put_Line (-Result);
- end Put;
-
- procedure Put_Line
- (Trace : in out WisiToken.Trace'Class;
- Parser_Label : in Natural;
- Message : in String;
- Task_ID : in Boolean := True)
- is begin
- Trace.Put_Line
- ((if Task_ID then "task" & Task_Attributes.Value'Image else "") &
- Integer'Image (Parser_Label) & ": " & Message);
- end Put_Line;
-
- function Undo_Reduce
- (Stack : in out Recover_Stacks.Stack;
- Tree : in Syntax_Trees.Tree)
- return Ada.Containers.Count_Type
- is
- Nonterm_Item : constant Recover_Stack_Item := Recover_Stacks.Pop (Stack);
- begin
- declare
- Children : constant Valid_Node_Index_Array := Tree.Children
(Nonterm_Item.Tree_Index);
- begin
- for C of Children loop
- Stack.Push ((Tree.State (C), C, Tree.Recover_Token (C)));
- end loop;
- return Children'Length;
- end;
- end Undo_Reduce;
-
- procedure Undo_Reduce_Check
- (Config : in out Configuration;
- Tree : in Syntax_Trees.Tree;
- Expected : in Token_ID)
- is begin
- pragma Assert (Config.Stack.Depth > 1);
- Check (Config.Stack.Peek (1).Token.ID, Expected);
- Config_Op_Arrays.Append (Config.Ops, (Undo_Reduce, Expected, Undo_Reduce
(Config.Stack, Tree)));
- exception
- when SAL.Container_Full =>
- raise Bad_Config;
- end Undo_Reduce_Check;
-
- procedure Undo_Reduce_Check
- (Config : in out Configuration;
- Tree : in Syntax_Trees.Tree;
- Expected : in Token_ID_Array)
- is begin
- for ID of Expected loop
- Undo_Reduce_Check (Config, Tree, ID);
- end loop;
- end Undo_Reduce_Check;
-
-end WisiToken.Parse.LR.McKenzie_Recover;
diff --git a/packages/wisi/wisitoken-parse-lr-mckenzie_recover.ads
b/packages/wisi/wisitoken-parse-lr-mckenzie_recover.ads
deleted file mode 100644
index 2f33cd2..0000000
--- a/packages/wisi/wisitoken-parse-lr-mckenzie_recover.ads
+++ /dev/null
@@ -1,310 +0,0 @@
--- Abstract :
---
--- Implement [McKenzie] error recovery, extended to parallel parsers.
---
--- References:
---
--- [McKenzie] McKenzie, Bruce J., Yeatman, Corey, and De Vere,
--- Lorraine. Error repair in shift reduce parsers. ACM Trans. Prog.
--- Lang. Syst., 17(4):672-689, July 1995. Described in [Grune 2008] ref 321.
---
--- [Grune 2008] Parsing Techniques, A Practical Guide, Second
--- Edition. Dick Grune, Ceriel J.H. Jacobs.
---
--- Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Task_Attributes;
-with WisiToken.Parse.LR.Parser;
-with WisiToken.Lexer;
-package WisiToken.Parse.LR.McKenzie_Recover is
- use all type Ada.Containers.Count_Type;
-
- Bad_Config : exception;
- -- Raised when a config is determined to violate some programming
- -- convention; abandon it.
-
- type Recover_Status is (Fail_Check_Delta, Fail_Enqueue_Limit,
Fail_No_Configs_Left, Fail_Programmer_Error, Success);
-
- function Recover (Shared_Parser : in out WisiToken.Parse.LR.Parser.Parser)
return Recover_Status;
- -- Attempt to modify Parser.Parsers state and Parser.Lookahead to
- -- allow recovering from an error state.
-
- Force_Full_Explore : Boolean := False;
- -- Sometimes recover throws an exception in a race condition case
- -- that is hard to reproduce. Setting this True ignores all Success,
- -- so all configs are checked.
-
- Force_High_Cost_Solutions : Boolean := False;
- -- Similarly, setting this true keeps all solutions that are found,
- -- and forces at least three.
-
-private
-
- ----------
- -- Visible for language-specific child packages. Alphabetical.
-
- procedure Check (ID : Token_ID; Expected_ID : in Token_ID)
- with Inline => True;
- -- Check that ID = Expected_ID; raise Assertion_Error if not.
- -- Implemented using 'pragma Assert'.
-
- function Current_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out Base_Token_Index;
- Restore_Terminals_Current : out WisiToken.Base_Token_Index;
- Insert_Delete : aliased in out Config_Op_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type)
- return Base_Token;
- -- Return the current token, from either Terminals or Insert_Delete;
- -- set up for Next_Token.
- --
- -- See Next_Token for more info.
-
- function Current_Token_ID_Peek
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in Base_Token_Index;
- Insert_Delete : aliased in Config_Op_Arrays.Vector;
- Current_Insert_Delete : in SAL.Base_Peek_Type)
- return Token_ID;
- -- Return the current token from either Terminals or
- -- Insert_Delete, without setting up for Next_Token.
-
- procedure Current_Token_ID_Peek_3
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in Base_Token_Index;
- Insert_Delete : aliased in Config_Op_Arrays.Vector;
- Current_Insert_Delete : in SAL.Base_Peek_Type;
- Tokens : out Token_ID_Array_1_3);
- -- Return the current token (in Tokens (1)) from either Terminals or
- -- Insert_Delete, without setting up for Next_Token. Return the two
- -- following tokens in Tokens (2 .. 3).
-
- procedure Delete_Check
- (Terminals : in Base_Token_Arrays.Vector;
- Config : in out Configuration;
- ID : in Token_ID);
- -- Check that Terminals (Config.Current_Shared_Token) = ID. Append a
- -- Delete op to Config.Ops, and insert it in Config.Insert_Delete in
- -- token_index order.
- --
- -- This or the next routine must be used instead of Config.Ops.Append
- -- (Delete...) unless the code also takes care of changing
- -- Config.Current_Shared_Token. Note that this routine does _not_
- -- increment Config.Current_Shared_Token, so it can only be used to
- -- delete one token.
-
- procedure Delete_Check
- (Terminals : in Base_Token_Arrays.Vector;
- Config : in out Configuration;
- Index : in out WisiToken.Token_Index;
- ID : in Token_ID);
- -- Check that Terminals (Index) = ID. Append a Delete op to
- -- Config.Ops, and insert it in Config.Insert_Delete in token_index
- -- order. Increments Index, for convenience when deleting several
- -- tokens.
-
- procedure Delete
- (Terminals : in Base_Token_Arrays.Vector;
- Config : in out Configuration;
- Index : in out WisiToken.Token_Index);
- -- Same as Delete_Check, without the check.
-
- function Find_ID
- (Config : in Configuration;
- ID : in Token_ID)
- return Boolean;
- -- Search Config.Stack for a token with ID, starting at
- -- stack top. Return True if found, False if not.
-
- procedure Find_ID
- (Config : in Configuration;
- ID : in Token_ID;
- Matching_Index : in out SAL.Peek_Type);
- -- Search Config.Stack for a token with ID, starting at
- -- Matching_Index. If found, Matching_Index points to it.
- -- If not found, Matching_Index = Config.Stack.Depth.
-
- procedure Find_ID
- (Config : in Configuration;
- IDs : in Token_ID_Set;
- Matching_Index : in out SAL.Peek_Type);
- -- Search Config.Stack for a token with ID in IDs, starting at
- -- Matching_Index. If found, Matching_Index points to it.
- -- If not found, Matching_Index = Config.Stack.Depth.
-
- procedure Find_Descendant_ID
- (Tree : in Syntax_Trees.Tree;
- Config : in Configuration;
- ID : in Token_ID;
- ID_Set : in Token_ID_Set;
- Matching_Index : in out SAL.Peek_Type);
- -- Search Config.Stack for a token with id in ID_Set, with a
- -- descendant with id = ID, starting at Matching_Index. If found,
- -- Matching_Index points to it. If not found, Matching_Index =
- -- Config.Stack.Depth.
-
- procedure Find_Matching_Name
- (Config : in Configuration;
- Lexer : access constant WisiToken.Lexer.Instance'Class;
- Name : in String;
- Matching_Name_Index : in out SAL.Peek_Type;
- Case_Insensitive : in Boolean);
- -- Search Config.Stack for a token matching Name, starting at
- -- Matching_Name_Index. If found, Matching_Name_Index points to it.
- -- If not found, Matching_Name_Index = Config.Stack.Depth.
-
- procedure Find_Matching_Name
- (Config : in Configuration;
- Lexer : access constant WisiToken.Lexer.Instance'Class;
- Name : in String;
- Matching_Name_Index : in out SAL.Peek_Type;
- Other_ID : in Token_ID;
- Other_Count : out Integer;
- Case_Insensitive : in Boolean);
- -- Search Config.Stack for a token matching Name, starting at
- -- Matching_Name_Index. If found, Matching_Name_Index points to it.
- -- If not found, Matching_Name_Index = Config.Stack.Depth.
- --
- -- Also count tokens with ID = Other_ID.
-
- procedure Insert (Config : in out Configuration; ID : in Token_ID);
- -- Append an Insert op at Config.Current_Shared_Token, to Config.Ops,
- -- and insert it in Config.Insert_Deleted in token_index order.
-
- procedure Insert (Config : in out Configuration; IDs : in Token_ID_Array);
- -- Call Insert for each item in IDs.
-
- procedure Insert (Config : in out Configuration; Index : in
WisiToken.Token_Index; ID : in Token_ID);
- -- Same as Insert, but at Index, not Config.Current_Shared_Token.
-
- function Next_Token
- (Terminals : in Base_Token_Arrays.Vector;
- Terminals_Current : in out Base_Token_Index;
- Restore_Terminals_Current : in out Base_Token_Index;
- Insert_Delete : aliased in out Config_Op_Arrays.Vector;
- Current_Insert_Delete : in out SAL.Base_Peek_Type)
- return Base_Token;
- -- Return the next token, from either Terminals or Insert_Delete;
- -- update Terminals_Current or Current_Insert_Delete.
- --
- -- If result is Insert_Delete.Last_Index, Current_Insert_Delete =
- -- Last_Index; Insert_Delete is cleared and Current_Insert_Delete
- -- reset on next call.
- --
- -- When done parsing, caller must reset actual Terminals_Current to
- -- Restore_Terminals_Current.
- --
- -- Insert_Delete contains only Insert and Delete ops, in token_index
- -- order. Those ops are applied when Terminals_Current =
- -- op.token_index.
-
- function Push_Back_Valid
- (Target_Token_Index : in WisiToken.Base_Token_Index;
- Ops : in Config_Op_Arrays.Vector;
- Prev_Op : in Positive_Index_Type)
- return Boolean;
-
- function Push_Back_Valid (Config : in Configuration) return Boolean
- is (Config.Stack.Depth > 1 and then
- (not Config.Stack.Peek.Token.Virtual and
- -- If Virtual, this is from earlier in this recover session; no
point
- -- in trying to redo it.
- (Config_Op_Arrays.Length (Config.Ops) = 0 or else
- Push_Back_Valid
- (Config.Stack.Peek.Token.Min_Terminal_Index,
- Config.Ops,
- Config_Op_Arrays.Last_Index (Config.Ops)))));
-
- procedure Push_Back (Config : in out Configuration)
- with Pre => Push_Back_Valid (Config);
- -- Pop the top Config.Stack item, set Config.Current_Shared_Token to
- -- the first terminal in that item. If the item is empty,
- -- Config.Current_Shared_Token is unchanged.
-
- procedure Push_Back_Check (Config : in out Configuration; Expected_ID : in
Token_ID)
- with Pre => Push_Back_Valid (Config);
- -- In effect, call Check and Push_Back.
-
- procedure Push_Back_Check (Config : in out Configuration; Expected : in
Token_ID_Array);
- -- Call Push_Back_Check for each item in Expected.
- --
- -- Raises Bad_Config if any of the push_backs is invalid.
-
- procedure Put
- (Message : in String;
- Trace : in out WisiToken.Trace'Class;
- Parser_Label : in Natural;
- Terminals : in Base_Token_Arrays.Vector;
- Config : in Configuration;
- Task_ID : in Boolean := True;
- Strategy : in Boolean := False);
- -- Put Message and an image of Config to Trace.
-
- procedure Put_Line
- (Trace : in out WisiToken.Trace'Class;
- Parser_Label : in Natural;
- Message : in String;
- Task_ID : in Boolean := True);
- -- Put message to Trace, with parser and task info.
-
- function Undo_Reduce_Valid
- (Stack : in Recover_Stacks.Stack;
- Tree : in Syntax_Trees.Tree)
- return Boolean
- -- Check if Undo_Reduce is valid when there is no previous Config_Op.
- --
- -- Undo_Reduce needs to know what tokens the nonterm contains, to
- -- push them on the stack. Thus we need a valid Tree index. It is
- -- tempting to also allow an empty nonterm when Tree_Index is
- -- invalid, but that fails when the real Undo_Reduce results in
- -- another empty nonterm on the stack; see test_mckenzie_recover.adb
- -- Error_During_Resume_3.
- is (Stack.Depth > 1 and then
- Stack.Peek.Tree_Index /= Invalid_Node_Index and then
- Tree.Is_Nonterm (Stack.Peek.Tree_Index));
-
- function Undo_Reduce_Valid
- (Stack : in Recover_Stacks.Stack;
- Tree : in Syntax_Trees.Tree;
- Ops : in Config_Op_Arrays.Vector;
- Prev_Op : in Positive_Index_Type)
- return Boolean
- is (Undo_Reduce_Valid (Stack, Tree) and then Push_Back_Valid
(Stack.Peek.Token.Min_Terminal_Index, Ops, Prev_Op));
-
- function Undo_Reduce
- (Stack : in out Recover_Stacks.Stack;
- Tree : in Syntax_Trees.Tree)
- return Ada.Containers.Count_Type
- with Pre => Undo_Reduce_Valid (Stack, Tree);
- -- Undo the reduction that produced the top stack item, return the
- -- token count for that reduction.
-
- procedure Undo_Reduce_Check
- (Config : in out Configuration;
- Tree : in Syntax_Trees.Tree;
- Expected : in Token_ID)
- with Inline => True;
- -- Call Check, Undo_Reduce.
-
- procedure Undo_Reduce_Check
- (Config : in out Configuration;
- Tree : in Syntax_Trees.Tree;
- Expected : in Token_ID_Array);
- -- Call Undo_Reduce_Check for each item in Expected.
-
- package Task_Attributes is new Ada.Task_Attributes (Integer, 0);
-
-end WisiToken.Parse.LR.McKenzie_Recover;
diff --git a/packages/wisi/wisitoken-parse-lr-parser.adb
b/packages/wisi/wisitoken-parse-lr-parser.adb
deleted file mode 100644
index 04b6f6b..0000000
--- a/packages/wisi/wisitoken-parse-lr-parser.adb
+++ /dev/null
@@ -1,1256 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2020 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Calendar.Formatting;
-with Ada.Exceptions;
-with GNAT.Traceback.Symbolic;
-with WisiToken.Parse.LR.McKenzie_Recover;
-package body WisiToken.Parse.LR.Parser is
-
- function Reduce_Stack_1
- (Current_Parser : in Parser_Lists.Cursor;
- Action : in Reduce_Action_Rec;
- Nonterm : out WisiToken.Valid_Node_Index;
- Lexer : in WisiToken.Lexer.Handle;
- Trace : in out WisiToken.Trace'Class)
- return WisiToken.Semantic_Checks.Check_Status_Label
- is
- -- We treat semantic check errors as parse errors here, to allow
- -- error recovery to take better advantage of them. One recovery
- -- strategy is to fix things so the semantic check passes.
-
- use all type Semantic_Checks.Check_Status_Label;
- use all type Semantic_Checks.Semantic_Check;
-
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
- Children_Tree : Valid_Node_Index_Array (1 .. SAL.Base_Peek_Type
(Action.Token_Count));
- begin
- for I in reverse Children_Tree'Range loop
- Children_Tree (I) := Parser_State.Stack.Pop.Token;
- end loop;
-
- Nonterm := Parser_State.Tree.Add_Nonterm
- (Action.Production, Children_Tree, Action.Action,
- Default_Virtual => Parser_State.Tree.Is_Virtual
(Parser_State.Current_Token));
- -- Computes Nonterm.Byte_Region, Virtual
-
- if Trace_Parse > Detail then
- Trace.Put_Line (Parser_State.Tree.Image (Nonterm,
Trace.Descriptor.all, Include_Children => True));
- end if;
-
- if Action.Check = null then
- return Ok;
-
- else
- declare
- Nonterm_Token : Recover_Token :=
Parser_State.Tree.Recover_Token (Nonterm);
- Children_Token : constant Recover_Token_Array :=
Parser_State.Tree.Recover_Token_Array (Children_Tree);
- Status : Semantic_Checks.Check_Status;
- begin
- Status := Action.Check (Lexer, Nonterm_Token, Children_Token,
Recover_Active => False);
-
- if Nonterm_Token.Name /= Null_Buffer_Region then
- Parser_State.Tree.Set_Name_Region (Nonterm, Nonterm_Token.Name);
- end if;
-
- if Trace_Parse > Detail then
- Trace.Put_Line ("semantic check " & Semantic_Checks.Image
(Status, Trace.Descriptor.all));
- end if;
-
- case Status.Label is
- when Ok =>
- return Ok;
-
- when Semantic_Checks.Error =>
- if Parser_State.Resume_Active then
- -- Ignore this error; that's how McKenzie_Recover decided
to fix it
- return Ok;
-
- else
- Parser_State.Errors.Append
- ((Label => Check,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Check_Status => Status,
- Recover => (others => <>)));
- return Status.Label;
- end if;
- end case;
- exception
- when Partial_Parse =>
- -- From Action.Check
- Parser_State.Tree.Set_Root (Nonterm);
- raise;
- end;
- end if;
- end Reduce_Stack_1;
-
- procedure Do_Action
- (Action : in Parse_Action_Rec;
- Current_Parser : in Parser_Lists.Cursor;
- Shared_Parser : in LR.Parser.Parser)
- is
- use all type Semantic_Checks.Check_Status_Label;
-
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
- Nonterm : WisiToken.Valid_Node_Index;
- Status : Semantic_Checks.Check_Status_Label;
- begin
- if Trace_Parse > Detail then
- Trace.Put
- (Integer'Image (Current_Parser.Label) & ": " &
- Trimmed_Image (Parser_State.Stack.Peek.State) & ": " &
- Parser_State.Tree.Image (Parser_State.Current_Token,
Trace.Descriptor.all) & " : ");
- Put (Trace, Action);
- Trace.New_Line;
- end if;
-
- case Action.Verb is
- when Shift =>
- Current_Parser.Set_Verb (Shift);
- Parser_State.Stack.Push ((Action.State, Parser_State.Current_Token));
- Parser_State.Tree.Set_State (Parser_State.Current_Token,
Action.State);
-
- when Reduce =>
- declare
- New_State : constant Unknown_State_Index := Goto_For
- (Table => Shared_Parser.Table.all,
- State => Parser_State.Stack (SAL.Base_Peek_Type
(Action.Token_Count) + 1).State,
- ID => Action.Production.LHS);
- begin
- if New_State = Unknown_State then
- -- This is due to a bug in the LALR parser generator (see
- -- lalr_generator_bug_01.wy); we treat it as a syntax error.
- Current_Parser.Set_Verb (Error);
- if Trace_Parse > Detail then
- Trace.Put_Line (" ... error");
- end if;
-
- else
- Status := Reduce_Stack_1 (Current_Parser, Action, Nonterm,
Shared_Parser.Lexer, Trace);
-
- -- Even when Reduce_Stack_1 returns Error, it did reduce the
stack, so
- -- push Nonterm.
- Parser_State.Stack.Push ((New_State, Nonterm));
-
- Parser_State.Tree.Set_State (Nonterm, New_State);
-
- case Status is
- when Ok =>
- Current_Parser.Set_Verb (Reduce);
-
- if Trace_Parse > Detail then
- Trace.Put_Line (" ... goto state " & Trimmed_Image
(New_State));
- end if;
-
- when Semantic_Checks.Error =>
- Current_Parser.Set_Verb (Error);
- Parser_State.Zombie_Token_Count := 1;
- end case;
- end if;
- end;
-
- when Accept_It =>
- case Reduce_Stack_1
- (Current_Parser,
- (Reduce, Action.Production, Action.Action, Action.Check,
Action.Token_Count),
- Nonterm, Shared_Parser.Lexer, Trace)
- is
- when Ok =>
- Current_Parser.Set_Verb (Action.Verb);
-
- Parser_State.Tree.Set_Root (Nonterm);
-
- when Semantic_Checks.Error =>
- Current_Parser.Set_Verb (Error);
- Parser_State.Zombie_Token_Count := 1;
- end case;
-
- when Error =>
- Current_Parser.Set_Verb (Action.Verb);
-
- Parser_State.Zombie_Token_Count := 1;
-
- declare
- Expecting : constant Token_ID_Set := LR.Expecting
- (Shared_Parser.Table.all, Parser_State.Stack.Peek.State);
- begin
- Parser_State.Errors.Append
- ((Label => LR.Action,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Error_Token => Parser_State.Current_Token,
- Expecting => Expecting,
- Recover => (others => <>)));
-
- if Trace_Parse > Outline then
- Put
- (Trace,
- Integer'Image (Current_Parser.Label) & ":" &
- Unknown_State_Index'Image (Parser_State.Stack.Peek.State)
& ": expecting: " &
- Image (Expecting, Trace.Descriptor.all));
- Trace.New_Line;
- end if;
- end;
- end case;
- end Do_Action;
-
- procedure Do_Deletes
- (Shared_Parser : in out LR.Parser.Parser;
- Parser_State : in out Parser_Lists.Parser_State)
- is
- use Recover_Op_Arrays, Recover_Op_Array_Refs;
- Ins_Del : Vector renames Parser_State.Recover_Insert_Delete;
- Ins_Del_Cur : Extended_Index renames
Parser_State.Recover_Insert_Delete_Current;
- begin
- if Trace_Parse > Extra then
- Shared_Parser.Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ": shared_token:" &
- WisiToken.Token_Index'Image (Parser_State.Shared_Token) &
- " inc_shared_token: " & Boolean'Image
(Parser_State.Inc_Shared_Token) &
- " recover_insert_delete:" &
- (if Parser_State.Recover_Insert_Delete_Current = No_Index
- then ""
- else Parser_State.Recover_Insert_Delete_Current'Image & " " &
- Image
- (Constant_Ref (Parser_State.Recover_Insert_Delete,
Parser_State.Recover_Insert_Delete_Current),
- Shared_Parser.Trace.Descriptor.all)));
- end if;
-
- loop
- exit when Ins_Del_Cur = Recover_Op_Arrays.No_Index;
- declare
- Op : Recover_Op renames Constant_Ref (Ins_Del, Ins_Del_Cur);
- begin
- if Op.Op = Delete and then
- Op.Del_Token_Index =
- (if Parser_State.Inc_Shared_Token
- then Parser_State.Shared_Token + 1
- else Parser_State.Shared_Token)
- then
- Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
- -- We don't reset Inc_Shared_Token here; only after the next
token is
- -- actually used.
- Ins_Del_Cur := Ins_Del_Cur + 1;
- if Ins_Del_Cur > Last_Index (Ins_Del) then
- Ins_Del_Cur := No_Index;
- end if;
- else
- exit;
- end if;
- end;
- end loop;
- end Do_Deletes;
-
- -- Verb: the type of parser cycle to execute;
- --
- -- Accept : all Parsers.Verb return Accept - done parsing.
- --
- -- Shift : some Parsers.Verb return Shift, all with the same current
- -- token in Shared_Parser.Terminals.
- --
- -- Pause : Resume is active, and this parser has reached Resume_Goal,
- -- so it is waiting for the others to catch up.
- --
- -- Reduce : some Parsers.Verb return Reduce.
- --
- -- Error : all Parsers.Verb return Error.
- --
- -- Zombie_Count: count of parsers in Error state
- procedure Parse_Verb
- (Shared_Parser : in out LR.Parser.Parser;
- Verb : out All_Parse_Action_Verbs;
- Zombie_Count : out SAL.Base_Peek_Type)
- is
- Shift_Count : SAL.Base_Peek_Type := 0;
- Accept_Count : SAL.Base_Peek_Type := 0;
- Error_Count : SAL.Base_Peek_Type := 0;
- Resume_Active : Boolean := False;
- begin
- Zombie_Count := 0;
-
- for Parser_State of Shared_Parser.Parsers loop
- case Parser_State.Verb is
- when Pause | Shift =>
- Do_Deletes (Shared_Parser, Parser_State);
-
- Shift_Count := Shift_Count + 1;
- Parser_State.Set_Verb (Shift);
-
- if Parser_State.Resume_Active then
- -- There may still be ops left in Recover_Insert_Delete after
we get
- -- to Resume_Token_Goal, probably from a Language_Fix or
string quote
- -- fix that deletes a lot of tokens.
- if Parser_State.Resume_Token_Goal <= Parser_State.Shared_Token
and
- Parser_State.Recover_Insert_Delete_Current =
Recover_Op_Arrays.No_Index
- then
- Parser_State.Resume_Active := False;
- if Trace_Parse > Detail then
- Shared_Parser.Trace.Put_Line (Integer'Image
(Parser_State.Label) & ": resume_active: False");
- end if;
- else
- Resume_Active := True;
- end if;
- end if;
-
- when Reduce =>
- Verb := Reduce;
- return;
-
- when Accept_It =>
- Accept_Count := Accept_Count + 1;
-
- when Error =>
- if Shared_Parser.Enable_McKenzie_Recover then
- -- This parser is waiting for others to error; they can
continue
- -- parsing.
- Zombie_Count := Zombie_Count + 1;
- else
- Error_Count := Error_Count + 1;
- end if;
- end case;
- end loop;
-
- if Accept_Count > 0 and Shared_Parser.Parsers.Count = Accept_Count +
Zombie_Count then
- Verb := Accept_It;
-
- elsif Shared_Parser.Parsers.Count = Error_Count + Zombie_Count then
- Verb := Error;
-
- elsif Shift_Count > 0 then
- Verb := Shift;
-
- else
- raise SAL.Programmer_Error;
- end if;
-
- if Resume_Active then
- for Parser_State of Shared_Parser.Parsers loop
- if Parser_State.Verb = Shift and not Parser_State.Resume_Active
then
- Parser_State.Set_Verb (Pause);
- end if;
- end loop;
- end if;
- end Parse_Verb;
-
- ----------
- -- Public subprograms, declaration order
-
- overriding procedure Finalize (Object : in out LR.Parser.Parser)
- is begin
- Free_Table (Object.Table);
- end Finalize;
-
- procedure New_Parser
- (Parser : out LR.Parser.Parser;
- Trace : not null access WisiToken.Trace'Class;
- Lexer : in WisiToken.Lexer.Handle;
- Table : in Parse_Table_Ptr;
- Language_Fixes : in Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
Language_String_ID_Set_Access;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
- Max_Parallel : in SAL.Base_Peek_Type :=
Default_Max_Parallel;
- Terminate_Same_State : in Boolean :=
True)
- is
- use all type Syntax_Trees.User_Data_Access;
- begin
- Parser.Lexer := Lexer;
- Parser.Trace := Trace;
- Parser.User_Data := User_Data;
-
- -- Terminals, Line_Begin_Token are initialized to empty arrays.
-
- Parser.Table := Table;
- Parser.Language_Fixes := Language_Fixes;
- Parser.Language_Matching_Begin_Tokens := Language_Matching_Begin_Tokens;
- Parser.Language_String_ID_Set := Language_String_ID_Set;
-
- Parser.Enable_McKenzie_Recover := not McKenzie_Defaulted (Table.all);
-
- Parser.Max_Parallel := Max_Parallel;
- Parser.Terminate_Same_State := Terminate_Same_State;
-
- if User_Data /= null then
- User_Data.Set_Lexer_Terminals (Lexer,
Parser.Terminals'Unchecked_Access);
- end if;
- end New_Parser;
-
- overriding procedure Parse (Shared_Parser : aliased in out LR.Parser.Parser)
- is
- use all type Ada.Strings.Unbounded.Unbounded_String;
- use all type Syntax_Trees.User_Data_Access;
- use all type Ada.Containers.Count_Type;
-
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
-
- Current_Verb : All_Parse_Action_Verbs;
- Action : Parse_Action_Node_Ptr;
- Zombie_Count : SAL.Base_Peek_Type;
-
- procedure Check_Error (Check_Parser : in out Parser_Lists.Cursor)
- is
- procedure Report_Error
- is begin
- Shared_Parser.Parsers.First_State_Ref.Errors.Append
- ((Label => LR.Message,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Recover => <>,
- Msg => +"error during resume"));
- if Debug_Mode then
- raise SAL.Programmer_Error with Check_Parser.Label'Image & ":
error during resume";
- else
- raise Syntax_Error;
- end if;
- end Report_Error;
-
- begin
- if Check_Parser.Verb = Error then
- -- This parser errored on last input. This is how grammar
conflicts
- -- are resolved when the input text is valid, in which case we
should
- -- just terminate this parser. However, this may be due to invalid
- -- input text, so we keep the parser alive but suspended for a few
- -- tokens, to see if the other parsers also error, in which case
they
- -- all participate in error recovery.
-
- -- We do not create zombie parsers during resume.
- if not Check_Parser.State_Ref.Resume_Active then
- -- Parser is now a zombie
- if Trace_Parse > Detail then
- Trace.Put_Line (Integer'Image (Check_Parser.Label) & ":
zombie");
- end if;
- Check_Parser.Next;
-
- else
- if Shared_Parser.Parsers.Count = 1 then
- Report_Error;
-
- else
- -- This is ok if a conflict occured during resume - we
assume this is
- -- a branch that failed during recover as well. Otherwise
it's a
- -- programmer error.
- if Check_Parser.State_Ref.Conflict_During_Resume then
- Shared_Parser.Parsers.Terminate_Parser
- (Check_Parser, "error in conflict during resume",
Shared_Parser.Trace.all,
- Shared_Parser.Terminals);
- else
- Report_Error;
- end if;
- end if;
- end if;
- else
- Check_Parser.Next;
- end if;
- end Check_Error;
-
- begin
- if Debug_Mode then
- Trace.Put_Clock ("start");
- end if;
-
- if Shared_Parser.User_Data /= null then
- Shared_Parser.User_Data.Reset;
- end if;
-
- Shared_Parser.String_Quote_Checked := Invalid_Line_Number;
- Shared_Parser.Shared_Tree.Clear;
- Shared_Parser.Parsers := Parser_Lists.New_List
- (Shared_Tree => Shared_Parser.Shared_Tree'Unchecked_Access);
-
- Shared_Parser.Lex_All;
-
- Shared_Parser.Parsers.First.State_Ref.Stack.Push
((Shared_Parser.Table.State_First, others => <>));
-
- Main_Loop :
- loop
- -- exit on Accept_It action or syntax error.
-
- Parse_Verb (Shared_Parser, Current_Verb, Zombie_Count);
-
- if Trace_Parse > Extra then
- Trace.Put_Line ("cycle start; current_verb: " &
Parse_Action_Verbs'Image (Current_Verb));
- end if;
-
- case Current_Verb is
- when Pause =>
- null;
-
- when Shift =>
- -- We just shifted a token; get the next token from
- -- Shared_Parser.Terminals.
-
- for Parser_State of Shared_Parser.Parsers loop
- if Parser_State.Verb = Error then
- if Shared_Parser.Enable_McKenzie_Recover then
- Parser_State.Zombie_Token_Count :=
Parser_State.Zombie_Token_Count + 1;
- if Trace_Parse > Extra then
- Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ": zombie (" &
- WisiToken.Token_Index'Image
- (Shared_Parser.Table.McKenzie_Param.Check_Limit
- Parser_State.Zombie_Token_Count) &
- " tokens remaining)");
- end if;
- end if;
-
- elsif Parser_State.Verb = Shift then
- declare
- function Insert_Virtual return Boolean
- is
- use Recover_Op_Arrays, Recover_Op_Array_Refs;
- Ins_Del : Vector renames
Parser_State.Recover_Insert_Delete;
- Ins_Del_Cur : Extended_Index renames
Parser_State.Recover_Insert_Delete_Current;
- Result : Boolean := False;
- begin
- if Ins_Del_Cur /= No_Index then
- declare
- Op : Recover_Op renames Variable_Ref (Ins_Del,
Ins_Del_Cur);
- begin
- if Op.Op = Insert and then
- Op.Ins_Token_Index =
- (if Parser_State.Inc_Shared_Token
- then Parser_State.Shared_Token + 1
- else Parser_State.Shared_Token)
- then
- Result := True;
-
- Parser_State.Current_Token :=
Parser_State.Tree.Add_Terminal
- (Op.Ins_ID, Before => Op.Ins_Token_Index);
-
- Op.Ins_Tree_Node :=
Parser_State.Current_Token;
-
- Ins_Del_Cur := Ins_Del_Cur + 1;
- if Ins_Del_Cur > Last_Index (Ins_Del) then
- Ins_Del_Cur := No_Index;
- end if;
- end if;
- end;
- end if;
- return Result;
- end Insert_Virtual;
- begin
- if Insert_Virtual then
- null;
-
- elsif (if Parser_State.Inc_Shared_Token
- then Parser_State.Shared_Token + 1
- else Parser_State.Shared_Token) <=
Shared_Parser.Terminals.Last_Index
- then
- if Parser_State.Inc_Shared_Token then
- -- Inc_Shared_Token is only set False by
McKenzie_Recover; see there
- -- for when/why. Don't increment past wisi_eoi
(happens when input
- -- buffer is empty; test_mckenzie_recover.adb
Empty_Comments).
- Parser_State.Shared_Token :=
Parser_State.Shared_Token + 1;
- else
- Parser_State.Inc_Shared_Token := True;
- end if;
-
- Parser_State.Current_Token := Shared_Parser.Terminals
- (Parser_State.Shared_Token).Tree_Index;
-
- end if;
- end;
-
- if Trace_Parse > Extra then
- Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ": current_token"
& Parser_State.Tree.Image
- (Parser_State.Current_Token, Trace.Descriptor.all));
- end if;
- end if;
- end loop;
-
- when Accept_It =>
- -- All parsers accepted or are zombies.
- declare
- Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
- Current_Parser : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
- begin
- if Count = 1 then
- -- Nothing more to do
- exit Main_Loop;
-
- elsif Zombie_Count + 1 = Count then
- -- All but one are zombies
- loop
- if Current_Parser.Verb = Accept_It then
- Current_Parser.Next;
- else
- declare
- Temp : Parser_Lists.Cursor := Current_Parser;
- begin
- Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser
- (Temp, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end;
- end if;
- exit when Current_Parser.Is_Done;
- end loop;
-
- exit Main_Loop;
-
- else
- -- More than one parser is active.
- declare
- use all type Parser_Lists.Cursor;
- Error_Parser_Count : Integer := (if
Shared_Parser.Lexer.Errors.Length > 0 then 1 else 0);
-
- Recover_Cost : Integer;
- Min_Recover_Cost : Integer :=
Integer'Last;
- Recover_Ops_Length : Ada.Containers.Count_Type;
- Min_Recover_Ops_Length : Ada.Containers.Count_Type :=
Ada.Containers.Count_Type'Last;
- Recover_Cur : Parser_Lists.Cursor :=
Current_Parser;
- begin
- Current_Parser := Shared_Parser.Parsers.First;
- loop
- if Current_Parser.Verb = Accept_It then
- if Current_Parser.State_Ref.Errors.Length > 0 then
- Error_Parser_Count := Error_Parser_Count + 1;
- end if;
- Current_Parser.Next;
- else
- declare
- Temp : Parser_Lists.Cursor := Current_Parser;
- begin
- Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser
- (Temp, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end;
- end if;
- exit when Current_Parser.Is_Done;
- end loop;
-
- if Error_Parser_Count > 0 then
- -- There was at least one error. We assume that
caused the ambiguous
- -- parse, and we pick the parser with the minimum
cost and minimum
- -- recover ops length (consistent with
Duplicate_State) to allow the
- -- parse to succeed. We terminate the other parsers
so the remaining
- -- parser can do Execute_Actions.
- --
- -- If there are multiple errors, this metric is not
very meaningful.
- --
- -- Note all surviving parsers must have the same
error count.
- Current_Parser := Shared_Parser.Parsers.First;
- loop
- Recover_Cost := Current_Parser.Min_Recover_Cost;
- if Recover_Cost < Min_Recover_Cost then
- Min_Recover_Cost := Recover_Cost;
- Min_Recover_Ops_Length :=
Current_Parser.Max_Recover_Ops_Length;
- Recover_Cur := Current_Parser;
-
- elsif Recover_Cost = Min_Recover_Cost then
- Recover_Ops_Length :=
Current_Parser.Max_Recover_Ops_Length;
- if Recover_Ops_Length < Min_Recover_Ops_Length
then
- Min_Recover_Ops_Length := Recover_Ops_Length;
- Recover_Cur := Current_Parser;
- end if;
- end if;
- Current_Parser.Next;
- exit when Current_Parser.Is_Done;
- end loop;
-
- Current_Parser := Shared_Parser.Parsers.First;
- loop
- if Current_Parser = Recover_Cur then
- Current_Parser.Next;
- else
- declare
- Temp : Parser_Lists.Cursor := Current_Parser;
- begin
- Current_Parser.Next;
- Shared_Parser.Parsers.Terminate_Parser
- (Temp,
- (if Recover_Cost = Min_Recover_Cost and
then
- Recover_Ops_Length =
Min_Recover_Ops_Length
- then "random"
- else "recover cost/length"),
- Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end;
- end if;
- exit when Current_Parser.Is_Done;
- end loop;
-
- exit Main_Loop;
-
- else
- -- There were no previous errors. We allow the parse
to fail, on the
- -- assumption that an otherwise correct input should
not yield an
- -- ambiguous parse.
- declare
- Token : Base_Token renames Shared_Parser.Terminals
(Shared_Parser.Terminals.Last_Index);
- begin
- raise WisiToken.Parse_Error with Error_Message
- (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
- "Ambiguous parse:" & SAL.Base_Peek_Type'Image
(Count) & " parsers active.");
- end;
- end if;
- end;
- end if;
- end;
-
- when Reduce =>
- null;
-
- when Error =>
- -- All parsers errored; attempt recovery
- declare
- use all type McKenzie_Recover.Recover_Status;
-
- Recover_Result : McKenzie_Recover.Recover_Status :=
McKenzie_Recover.Recover_Status'First;
-
- Pre_Recover_Parser_Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
- Start : Ada.Calendar.Time;
- begin
- -- Recover algorithms expect current token at
- -- Parsers(*).Current_Token, will set
- -- Parsers(*).Recover_Insert_Delete with new input tokens and
- -- deletions, adjust Parsers(*).Stack, and set
- -- Parsers(*).Current_Token and Parsers(*).Verb.
-
- if Shared_Parser.Enable_McKenzie_Recover then
- if Debug_Mode then
- Trace.Put_Clock ("pre-recover" &
Shared_Parser.Parsers.Count'Img & " active");
- Start := Ada.Calendar.Clock;
- end if;
- Recover_Result := McKenzie_Recover.Recover (Shared_Parser);
- if Debug_Mode then
- declare
- use Ada.Calendar;
- Recover_Duration : constant Duration := Clock - Start;
- begin
- Trace.Put_Clock
- ("post-recover" & Shared_Parser.Parsers.Count'Img &
" active," & Recover_Duration'Image);
- end;
- end if;
-
- if Trace_Parse > Outline then
- if Recover_Result = Success then
- Trace.Put_Line
- ("recover: succeed, parser count" &
SAL.Base_Peek_Type'Image (Shared_Parser.Parsers.Count));
- else
- Trace.Put_Line
- ("recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result) &
- ", parser count" & SAL.Base_Peek_Type'Image
(Shared_Parser.Parsers.Count));
- end if;
- end if;
-
- if Ada.Text_IO.Is_Open (Shared_Parser.Recover_Log_File) then
- declare
- use Ada.Text_IO;
- begin
- Put
- (Shared_Parser.Recover_Log_File,
- Ada.Calendar.Formatting.Image (Ada.Calendar.Clock)
& " " &
- Shared_Parser.Partial_Parse_Active'Image & " " &
- Recover_Result'Image & " " &
- Pre_Recover_Parser_Count'Image & " '" &
- Shared_Parser.Lexer.File_Name & "'");
-
- Put (Shared_Parser.Recover_Log_File, '(');
- for Parser of Shared_Parser.Parsers loop
- Put (Shared_Parser.Recover_Log_File, Image
(Parser.Recover.Results.Peek.Strategy_Counts));
- Put
- (Shared_Parser.Recover_Log_File,
- Integer'Image (Parser.Recover.Enqueue_Count) &
- Integer'Image (Parser.Recover.Check_Count) & "
" &
- Boolean'Image (Parser.Recover.Success));
- end loop;
- Put (Shared_Parser.Recover_Log_File, ')');
-
- New_Line (Shared_Parser.Recover_Log_File);
- Flush (Shared_Parser.Recover_Log_File);
- end;
- end if;
- else
- if Trace_Parse > Outline or Trace_McKenzie > Outline then
- Trace.Put_Line ("recover disabled");
- end if;
- end if;
-
- if Recover_Result = Success then
- for Parser_State of Shared_Parser.Parsers loop
- Parser_State.Resume_Active := True;
- Parser_State.Conflict_During_Resume := False;
-
- if Trace_Parse > Outline then
- Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ":
Current_Token " &
- Parser_State.Tree.Image
(Parser_State.Current_Token, Trace.Descriptor.all) &
- " Shared_Token " & Image
- (Parser_State.Shared_Token,
Shared_Parser.Terminals, Trace.Descriptor.all));
-
- if Trace_Parse > Detail then
- Shared_Parser.Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ":
resume_active: True, token goal" &
- WisiToken.Token_Index'Image
(Parser_State.Resume_Token_Goal));
- end if;
- end if;
-
- Parser_State.Zombie_Token_Count := 0;
-
- case Parser_State.Verb is
- when Reduce =>
- null;
-
- when Error =>
- -- Force this parser to be terminated.
- if Shared_Parser.Enable_McKenzie_Recover then
- Parser_State.Zombie_Token_Count :=
Shared_Parser.Table.McKenzie_Param.Check_Limit + 1;
- end if;
-
- when Shift =>
- null;
-
- when Pause | Accept_It =>
- raise SAL.Programmer_Error;
- end case;
- end loop;
-
- else
- -- Terminate with error. Parser_State has all the required
info on
- -- the original error (recorded by Error in Do_Action);
report reason
- -- recover failed.
- for Parser_State of Shared_Parser.Parsers loop
- Parser_State.Errors.Append
- ((Label => LR.Message,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Recover => <>,
- Msg =>
- (if Shared_Parser.Enable_McKenzie_Recover
- then +"recover: fail " &
McKenzie_Recover.Recover_Status'Image (Recover_Result)
- else +"recover disabled")));
- end loop;
- raise WisiToken.Syntax_Error;
- end if;
-
- -- Recover sets Parser.Verb to Shift for all active parsers, to
- -- indicate it no longer has an error. Set Current_Verb to
reflect
- -- that.
- Current_Verb := Shift;
- end;
- end case;
-
- -- We don't use 'for Parser_State of Parsers loop' here,
- -- because terminate on error and spawn on conflict require
- -- changing the parser list.
- declare
- Current_Parser : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
- begin
- Action_Loop :
- loop
- exit Action_Loop when Current_Parser.Is_Done;
-
- -- We don't check duplicate state during resume, because the
tokens
- -- inserted/deleted by error recover may cause initially
duplicate
- -- states to diverge.
- if not Current_Parser.State_Ref.Resume_Active and
- Shared_Parser.Terminate_Same_State and
- Current_Verb = Shift
- then
- Shared_Parser.Parsers.Duplicate_State
- (Current_Parser, Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- -- If Duplicate_State terminated Current_Parser,
Current_Parser now
- -- points to the next parser. Otherwise it is unchanged.
- end if;
-
- exit Action_Loop when Current_Parser.Is_Done;
-
- if Trace_Parse > Extra then
- Trace.Put_Line
- ("current_verb: " & Parse_Action_Verbs'Image
(Current_Verb) &
- "," & Integer'Image (Current_Parser.Label) &
- ".verb: " & Parse_Action_Verbs'Image
(Current_Parser.Verb));
- end if;
-
- -- Each branch of the following 'if' calls either
Current_Parser.Free
- -- (which advances to the next parser) or Current_Parser.Next.
-
- if Current_Parser.Verb = Error then
- -- This parser is a zombie; see Check_Error above.
- --
- -- Check to see if it is time to terminate it
- if Shared_Parser.Enable_McKenzie_Recover and then
- Current_Parser.State_Ref.Zombie_Token_Count <=
Shared_Parser.Table.McKenzie_Param.Check_Limit
- then
- if Trace_Parse > Detail then
- Trace.Put_Line (Integer'Image (Current_Parser.Label) &
": zombie");
- end if;
-
- Current_Parser.Next;
- else
- Shared_Parser.Parsers.Terminate_Parser
- (Current_Parser, "zombie", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end if;
-
- elsif Current_Parser.Verb = Current_Verb then
-
- if Trace_Parse > Extra then
- Parser_Lists.Put_Top_10 (Trace, Current_Parser);
- end if;
-
- declare
- State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
- begin
- Action := Action_For
- (Table => Shared_Parser.Table.all,
- State => State.Stack.Peek.State,
- ID => State.Tree.ID (State.Current_Token));
- end;
-
- declare
- Conflict : Parse_Action_Node_Ptr := Action.Next;
- begin
- loop
- exit when Conflict = null;
- -- Spawn a new parser (before modifying
Current_Parser stack).
-
- Current_Parser.State_Ref.Conflict_During_Resume :=
Current_Parser.State_Ref.Resume_Active;
-
- if Shared_Parser.Parsers.Count =
Shared_Parser.Max_Parallel then
- -- If errors were recovered, terminate a parser
that used the
- -- highest cost solution.
- declare
- use all type
WisiToken.Parse.LR.Parser_Lists.Cursor;
- Max_Recover_Cost : Integer := 0;
- Cur : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
- Max_Parser : Parser_Lists.Cursor := Cur;
- begin
- loop
- exit when Cur.Is_Done;
- if Cur.Total_Recover_Cost > Max_Recover_Cost
then
- Max_Parser := Cur;
- Max_Recover_Cost := Cur.Total_Recover_Cost;
- end if;
- Cur.Next;
- end loop;
-
- if Max_Recover_Cost > 0 then
- if Max_Parser = Current_Parser then
- Current_Parser.Next;
-
- Shared_Parser.Parsers.Terminate_Parser
- (Max_Parser, "too many parsers; max
error repair cost", Trace,
- Shared_Parser.Terminals);
-
- -- We changed Current_Parser, so start
over
- goto Continue_Action_Loop;
- else
- Shared_Parser.Parsers.Terminate_Parser
- (Max_Parser, "too many parsers; max
error repair cost", Trace,
- Shared_Parser.Terminals);
- end if;
- end if;
- end;
- end if;
-
- if Shared_Parser.Parsers.Count =
Shared_Parser.Max_Parallel then
- declare
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
- Token : Base_Token renames
Shared_Parser.Terminals (Parser_State.Shared_Token);
- begin
- raise WisiToken.Parse_Error with Error_Message
- (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
- "too many parallel parsers required in
grammar state" &
- State_Index'Image
(Parser_State.Stack.Peek.State) &
- "; simplify grammar, or increase
max-parallel (" &
- SAL.Base_Peek_Type'Image
(Shared_Parser.Max_Parallel) & ")");
- end;
-
- else
- if Trace_Parse > Outline then
- declare
- Parser_State : Parser_Lists.Parser_State
renames Current_Parser.State_Ref;
- begin
- Trace.Put_Line
- (Integer'Image (Current_Parser.Label) & ":
" &
- Trimmed_Image
(Parser_State.Stack.Peek.State) & ": " &
- Parser_State.Tree.Image
- (Parser_State.Current_Token,
Trace.Descriptor.all) & " : " &
- "spawn" & Integer'Image
(Shared_Parser.Parsers.Last_Label + 1) & ", (" &
- Trimmed_Image (1 + Integer
(Shared_Parser.Parsers.Count)) & " active)");
- end;
- end if;
-
- Shared_Parser.Parsers.Prepend_Copy (Current_Parser);
- Do_Action (Conflict.Item,
Shared_Parser.Parsers.First, Shared_Parser);
-
- -- We must terminate error parsers immediately in
order to avoid
- -- zombie parsers during recovery.
- declare
- Temp : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
- begin
- Check_Error (Temp);
- end;
- end if;
-
- Conflict := Conflict.Next;
- end loop;
- end;
- Do_Action (Action.Item, Current_Parser, Shared_Parser);
- Check_Error (Current_Parser);
-
- else
- -- Current parser is waiting for others to catch up
- Current_Parser.Next;
- end if;
- <<Continue_Action_Loop>>
- end loop Action_Loop;
- end;
- end loop Main_Loop;
-
- if Trace_Parse > Outline then
- Trace.Put_Line (Shared_Parser.Parsers.First.Label'Image & ":
succeed");
- end if;
-
- if Debug_Mode then
- Trace.Put_Clock ("finish parse");
- end if;
-
- -- We don't raise Syntax_Error for lexer errors, since they are all
- -- recovered, either by inserting a quote, or by ignoring the
- -- character.
- exception
- when Syntax_Error | WisiToken.Parse_Error | Partial_Parse =>
- if Debug_Mode then
- Trace.Put_Clock ("finish - error");
- end if;
- raise;
-
- when E : others =>
- declare
- Msg : constant String := Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E);
- begin
- if Shared_Parser.Parsers.Count > 0 then
- -- Emacs displays errors in the *syntax-errors* buffer
- Shared_Parser.Parsers.First_State_Ref.Errors.Append
- ((Label => LR.Message,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Recover => <>,
- Msg => +Msg));
- end if;
-
- if Debug_Mode then
- Trace.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
-- includes Prefix
- Trace.New_Line;
- end if;
-
- -- Emacs displays the exception message in the echo area; easy to
miss
- raise WisiToken.Parse_Error with Msg;
- end;
- end Parse;
-
- overriding function Tree (Shared_Parser : in Parser) return
Syntax_Trees.Tree
- is begin
- if Shared_Parser.Parsers.Count > 1 then
- raise WisiToken.Parse_Error with "ambigous parse";
- else
- return Shared_Parser.Parsers.First_State_Ref.Tree;
- end if;
- end Tree;
-
- overriding function Tree_Var_Ref (Shared_Parser : aliased in out Parser)
return Syntax_Trees.Tree_Variable_Reference
- is begin
- if Shared_Parser.Parsers.Count > 1 then
- raise WisiToken.Parse_Error with "ambigous parse";
- else
- return (Element => Shared_Parser.Parsers.First_State_Ref.Tree'Access);
- end if;
- end Tree_Var_Ref;
-
- overriding
- procedure Execute_Actions
- (Parser : in out LR.Parser.Parser;
- Image_Augmented : in Syntax_Trees.Image_Augmented := null)
- is
- use all type Syntax_Trees.User_Data_Access;
- use all type WisiToken.Syntax_Trees.Semantic_Action;
-
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- procedure Process_Node
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- is
- use all type Syntax_Trees.Node_Label;
- begin
- if Tree.Label (Node) /= Nonterm then
- return;
- end if;
-
- declare
- Tree_Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
- begin
- Parser.User_Data.Reduce (Tree, Node, Tree_Children);
- if Tree.Action (Node) /= null then
- begin
- Tree.Action (Node) (Parser.User_Data.all, Tree, Node,
Tree_Children);
- exception
- when E : others =>
- declare
- 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, Line, Column,
- "action raised exception " &
Ada.Exceptions.Exception_Name (E) & ": " &
- Ada.Exceptions.Exception_Message (E));
- end;
- end;
- end if;
- end;
- end Process_Node;
-
- begin
- if Parser.User_Data /= null then
- if Parser.Parsers.Count > 1 then
- raise Syntax_Error with "ambiguous parse; can't execute actions";
- end if;
-
- declare
- use Recover_Op_Arrays, Recover_Op_Array_Refs;
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_State_Ref;
- begin
- pragma Assert (Parser_State.Tree.Flushed);
-
- Parser_State.Tree.Set_Parents;
-
- if Trace_Action > Outline then
- if Trace_Action > Extra then
- Parser_State.Tree.Print_Tree (Descriptor,
Parser_State.Tree.Root, Image_Augmented);
- Parser.Trace.New_Line;
- end if;
- Parser.Trace.Put_Line
- (Integer'Image (Parser_State.Label) & ": root node: " &
Parser_State.Tree.Image
- (Parser_State.Tree.Root, Descriptor));
- end if;
-
- for I in First_Index (Parser_State.Recover_Insert_Delete) ..
- Last_Index (Parser_State.Recover_Insert_Delete)
- loop
- declare
- Op : Recover_Op renames Constant_Ref
(Parser_State.Recover_Insert_Delete, I);
- begin
- case Op.Op is
- when Insert =>
- Parser.User_Data.Insert_Token (Parser_State.Tree,
Op.Ins_Tree_Node);
- when Delete =>
- Parser.User_Data.Delete_Token (Parser_State.Tree,
Op.Del_Token_Index);
- end case;
- end;
- end loop;
-
- Parser.User_Data.Initialize_Actions (Parser_State.Tree);
- Parser_State.Tree.Process_Tree (Process_Node'Access);
- end;
- end if;
- end Execute_Actions;
-
- overriding function Any_Errors (Parser : in LR.Parser.Parser) return Boolean
- is
- use all type Ada.Containers.Count_Type;
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
- begin
- pragma Assert (Parser_State.Tree.Flushed);
- return Parser.Parsers.Count > 1 or Parser_State.Errors.Length > 0 or
Parser.Lexer.Errors.Length > 0;
- end Any_Errors;
-
- overriding procedure Put_Errors (Parser : in LR.Parser.Parser)
- is
- use Ada.Text_IO;
-
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
- begin
- for Item of Parser.Lexer.Errors loop
- Put_Line
- (Current_Error,
- Parser.Lexer.File_Name & ":0:0: lexer unrecognized character at" &
Buffer_Pos'Image (Item.Char_Pos));
- end loop;
-
- for Item of Parser_State.Errors loop
- case Item.Label is
- when Action =>
- declare
- Index : constant Base_Token_Index :=
Parser_State.Tree.First_Shared_Terminal (Item.Error_Token);
- begin
- if Index = Invalid_Token_Index then
- -- Error_Token is virtual
- Put_Line
- (Current_Error,
- Error_Message
- (Parser.Lexer.File_Name, 1, 0,
- "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
- ", found " & Image (Parser_State.Tree.ID
(Item.Error_Token), Descriptor)));
- else
- declare
- Token : Base_Token renames Parser.Terminals (Index);
- begin
- Put_Line
- (Current_Error,
- Error_Message
- (Parser.Lexer.File_Name, Token.Line, Token.Column,
- "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
- ", found '" & Parser.Lexer.Buffer_Text
(Token.Byte_Region) & "'"));
- end;
- end if;
- end;
- when Check =>
- Put_Line
- (Current_Error,
- Parser.Lexer.File_Name & ":0:0: semantic check error: " &
- Semantic_Checks.Image (Item.Check_Status, Descriptor));
- when Message =>
- Put_Line (Current_Error, -Item.Msg);
- end case;
-
- if Item.Recover.Stack.Depth /= 0 then
- Put_Line (Current_Error, " recovered: " & Image
(Item.Recover.Ops, Descriptor));
- end if;
- end loop;
- end Put_Errors;
-
-end WisiToken.Parse.LR.Parser;
diff --git a/packages/wisi/wisitoken-parse-lr-parser.ads
b/packages/wisi/wisitoken-parse-lr-parser.ads
deleted file mode 100644
index 46626fd..0000000
--- a/packages/wisi/wisitoken-parse-lr-parser.ads
+++ /dev/null
@@ -1,162 +0,0 @@
--- Abstract :
---
--- A generalized LR parser.
---
--- In a child package of Parser.LR partly for historical reasons,
--- partly to allow McKenzie_Recover to be in a sibling package.
---
--- Copyright (C) 2002, 2003, 2009, 2010, 2013-2015, 2017 - 2020 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Parse.LR.Parser_Lists;
-with WisiToken.Lexer;
-with WisiToken.Parse;
-with WisiToken.Syntax_Trees;
-package WisiToken.Parse.LR.Parser is
-
- Default_Max_Parallel : constant := 15;
-
- type Language_Fixes_Access is access procedure
- (Trace : in out WisiToken.Trace'Class;
- Lexer : access constant WisiToken.Lexer.Instance'Class;
- Parser_Label : in Natural;
- Parse_Table : in WisiToken.Parse.LR.Parse_Table;
- Terminals : in Base_Token_Arrays.Vector;
- Tree : in Syntax_Trees.Tree;
- Local_Config_Heap : in out Config_Heaps.Heap_Type;
- Config : in Configuration);
- -- Config encountered a parse table Error action, or failed a
- -- semantic check; attempt to provide a language-specific fix,
- -- enqueuing new configs on Local_Config_Heap.
- --
- -- For a failed semantic check, Config.Stack is in the pre-reduce
- -- state, Config.Error_Token gives the nonterm token,
- -- Config.Check_Token_Count the token count for the reduce. May be
- -- called with Nonterm.Virtual = True or Tree.Valid_Indices (stack
- -- top token_count items) false.
- --
- -- For an Error action, Config.Error_Token gives the terminal that
- -- caused the error.
-
- type Language_Matching_Begin_Tokens_Access is access procedure
- (Tokens : in Token_ID_Array_1_3;
- Config : in Configuration;
- Matching_Tokens : out Token_ID_Arrays.Vector;
- Forbid_Minimal_Complete : out Boolean);
- -- Tokens (1) caused a parse error; Tokens (2 .. 3) are the following
- -- tokens (Invalid_Token_ID if none). Set Matching_Tokens to a token
- -- sequence that starts a production matching Tokens. If
- -- Minimal_Complete would produce a bad solution at this error point,
- -- set Forbid_Minimal_Complete True.
- --
- -- For example, if Tokens is a block end, return tokens that are the
- -- corresponding block begin. If the error point is inside a
- -- multi-token 'end' (ie 'end if;', or 'end <name>;'), set
- -- Forbid_Minimal_Complete True.
-
- type Language_String_ID_Set_Access is access function
- (Descriptor : in WisiToken.Descriptor;
- String_Literal_ID : in Token_ID)
- return Token_ID_Set;
- -- Return a Token_ID_Set containing String_Literal_ID and
- -- nonterminals that can contain String_Literal_ID as part of an
- -- expression. Used in placing a missing string quote.
-
- type Post_Recover_Access is access procedure;
-
- type Parser is new WisiToken.Parse.Base_Parser with record
- Table : Parse_Table_Ptr;
- Language_Fixes : Language_Fixes_Access;
- Language_Matching_Begin_Tokens : Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : Language_String_ID_Set_Access;
-
- String_Quote_Checked : Line_Number_Type := Invalid_Line_Number;
- -- Max line checked for missing string quote.
-
- Post_Recover : Post_Recover_Access;
- -- Gather data for tests.
-
- Shared_Tree : aliased Syntax_Trees.Base_Tree;
- -- Each parser (normal and recover) has its own branched syntax tree,
- -- all branched from this tree. Terminals are added to the tree when
- -- they become the current token.
- --
- -- It is never the case that terminals are added to this shared tree
- -- when there is more than one task active, so we don't need a
- -- protected tree.
- --
- -- See WisiToken.LR.Parser_Lists Parser_State for more discussion of
- -- Shared_Tree.
-
- Parsers : aliased Parser_Lists.List;
-
- Max_Parallel : SAL.Base_Peek_Type;
- Terminate_Same_State : Boolean;
- Enable_McKenzie_Recover : Boolean;
- Recover_Log_File : Ada.Text_IO.File_Type;
- Partial_Parse_Active : Boolean := False;
- -- Partial_Parse_Active is only used in recover log messages.
- end record;
-
- overriding procedure Finalize (Object : in out LR.Parser.Parser);
- -- Deep free Object.Table.
-
- procedure New_Parser
- (Parser : out LR.Parser.Parser;
- Trace : not null access WisiToken.Trace'Class;
- Lexer : in WisiToken.Lexer.Handle;
- Table : in Parse_Table_Ptr;
- Language_Fixes : in Language_Fixes_Access;
- Language_Matching_Begin_Tokens : in
Language_Matching_Begin_Tokens_Access;
- Language_String_ID_Set : in
Language_String_ID_Set_Access;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
- Max_Parallel : in SAL.Base_Peek_Type :=
Default_Max_Parallel;
- Terminate_Same_State : in Boolean :=
True);
-
- overriding procedure Parse (Shared_Parser : aliased in out
LR.Parser.Parser);
- -- Attempt a parse. Calls Parser.Lexer.Reset, runs lexer to end of
- -- input setting Shared_Parser.Terminals, then parses tokens.
- --
- -- If an error is encountered, Parser.Lexer_Errors and
- -- Parsers(*).Errors contain information about the errors. If a
- -- recover strategy succeeds, no exception is raised. If recover does
- -- not succeed, raises Syntax_Error.
- --
- -- For errors where no recovery is possible, raises Parse_Error with
- -- an appropriate error message.
-
- overriding function Tree (Shared_Parser : in Parser) return
Syntax_Trees.Tree;
- overriding function Tree_Var_Ref (Shared_Parser : aliased in out Parser)
return Syntax_Trees.Tree_Variable_Reference;
- -- If there is one parser in Parsers, return its tree. Otherwise,
- -- raise Parse_Error for an ambiguous parse.
-
- overriding procedure Execute_Actions
- (Parser : in out LR.Parser.Parser;
- Image_Augmented : in Syntax_Trees.Image_Augmented := null);
- -- Call User_Data.Delete_Token on any tokens deleted by error
- -- recovery, then User_Data.Reduce and the grammar semantic actions
- -- on all nonterms in the syntax tree.
-
- overriding function Any_Errors (Parser : in LR.Parser.Parser) return
Boolean;
- -- Return True if any errors where encountered, recovered or not.
-
- overriding procedure Put_Errors (Parser : in LR.Parser.Parser);
- -- Put user-friendly error messages from the parse to
- -- Ada.Text_IO.Current_Error.
-
-end WisiToken.Parse.LR.Parser;
diff --git a/packages/wisi/wisitoken-parse-lr-parser_lists.adb
b/packages/wisi/wisitoken-parse-lr-parser_lists.adb
deleted file mode 100644
index 553f772..0000000
--- a/packages/wisi/wisitoken-parse-lr-parser_lists.adb
+++ /dev/null
@@ -1,416 +0,0 @@
--- Abstract :
---
--- see spec
---
--- Copyright (C) 2014 - 2020 All Rights Reserved.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Parse.LR.Parser_Lists is
-
- function Parser_Stack_Image
- (Stack : in Parser_Stacks.Stack;
- Descriptor : in WisiToken.Descriptor;
- Tree : in Syntax_Trees.Tree;
- Depth : in SAL.Base_Peek_Type := 0)
- return String
- is
- use Ada.Strings.Unbounded;
-
- Last : constant SAL.Base_Peek_Type :=
- (if Depth = 0
- then Stack.Depth
- else SAL.Base_Peek_Type'Min (Depth, Stack.Depth));
-
- Result : Unbounded_String := +"(";
- begin
- for I in 1 .. Last loop
- declare
- Item : Parser_Stack_Item renames Stack.Peek (I);
- begin
- Result := Result &
- ((if Item.State = Unknown_State then " " else Trimmed_Image
(Item.State)) & " :" &
- (if I = Stack.Depth
- then ""
- else
- (if Item.Token = Invalid_Node_Index -- From recover
fast-forward
- then ""
- else Tree.Image (Item.Token, Descriptor) & ", ")));
- end;
- end loop;
- return To_String (Result & ")");
- end Parser_Stack_Image;
-
- function New_List (Shared_Tree : in Syntax_Trees.Base_Tree_Access) return
List
- is
- First_Parser_Label : constant := 0;
- Parser : Parser_State := (Label => First_Parser_Label, others => <>);
- begin
- Parser.Tree.Initialize (Shared_Tree, Flush => True);
-
- return Result : List
- do
- Result.Parser_Label := First_Parser_Label;
-
- Result.Elements.Append (Parser);
- end return;
- end New_List;
-
- function Last_Label (List : in Parser_Lists.List) return Natural
- is begin
- return List.Parser_Label;
- end Last_Label;
-
- function Count (List : in Parser_Lists.List) return SAL.Base_Peek_Type
- is begin
- return List.Elements.Length;
- end Count;
-
- function First (List : aliased in out Parser_Lists.List'Class) return Cursor
- is begin
- return (Elements => List.Elements'Access, Ptr => List.Elements.First);
- end First;
-
- procedure Next (Cursor : in out Parser_Lists.Cursor)
- is begin
- Parser_State_Lists.Next (Cursor.Ptr);
- end Next;
-
- function Is_Done (Cursor : in Parser_Lists.Cursor) return Boolean
- is
- use Parser_State_Lists;
- begin
- return Cursor.Ptr = No_Element;
- end Is_Done;
-
- function Label (Cursor : in Parser_Lists.Cursor) return Natural
- is begin
- return Parser_State_Lists.Constant_Ref (Cursor.Ptr).Label;
- end Label;
-
- function Total_Recover_Cost (Cursor : in Parser_Lists.Cursor) return Integer
- is
- Result : Integer := 0;
- begin
- for Error of Parser_State_Lists.Constant_Ref (Cursor.Ptr).Errors loop
- Result := Error.Recover.Cost;
- end loop;
- return Result;
- end Total_Recover_Cost;
-
- function Max_Recover_Ops_Length (Cursor : in Parser_Lists.Cursor) return
Ada.Containers.Count_Type
- is
- use Ada.Containers;
- use Config_Op_Arrays;
- Result : Count_Type := 0;
- Errors : Parse_Error_Lists.List renames Parser_State_Lists.Constant_Ref
(Cursor.Ptr).Errors;
- begin
- for Error of Errors loop
- if Length (Error.Recover.Ops) > Result then
- Result := Length (Error.Recover.Ops);
- end if;
- end loop;
- return Result;
- end Max_Recover_Ops_Length;
-
- function Min_Recover_Cost (Cursor : in Parser_Lists.Cursor) return Integer
- is
- Result : Integer := Integer'Last;
- Errors : Parse_Error_Lists.List renames Parser_State_Lists.Constant_Ref
(Cursor.Ptr).Errors;
- begin
- for Error of Errors loop
- if Error.Recover.Cost < Result then
- Result := Error.Recover.Cost;
- end if;
- end loop;
- return Result;
- end Min_Recover_Cost;
-
- procedure Set_Verb (Cursor : in Parser_Lists.Cursor; Verb : in
All_Parse_Action_Verbs)
- is begin
- Parser_State_Lists.Variable_Ref (Cursor.Ptr).Verb := Verb;
- end Set_Verb;
-
- function Verb (Cursor : in Parser_Lists.Cursor) return
All_Parse_Action_Verbs
- is begin
- return Parser_State_Lists.Constant_Ref (Cursor.Ptr).Verb;
- end Verb;
-
- procedure Terminate_Parser
- (Parsers : in out List;
- Current : in out Cursor'Class;
- Message : in String;
- Trace : in out WisiToken.Trace'Class;
- Terminals : in Base_Token_Arrays.Vector)
- is
- State : Parser_State renames Parser_State_Lists.Constant_Ref
(Current.Ptr).Element.all;
-
- procedure Free (Cursor : in out Parser_Lists.Cursor'Class)
- is
- Temp : Parser_State_Lists.Cursor := Cursor.Ptr;
- begin
- Parser_State_Lists.Next (Cursor.Ptr);
- Parser_State_Lists.Delete (Cursor.Elements.all, Temp);
- end Free;
- begin
- if Trace_Parse > Outline then
- Trace.Put_Line
- (Integer'Image (Current.Label) & ": terminate (" &
- Trimmed_Image (Integer (Parsers.Count) - 1) & " active)" &
- ": " & Message & Image
- (State.Tree.First_Shared_Terminal (State.Current_Token),
- Terminals, Trace.Descriptor.all));
- end if;
-
- Free (Current);
-
- if Parsers.Count = 1 then
- Parsers.First.State_Ref.Tree.Flush;
- end if;
- end Terminate_Parser;
-
- procedure Duplicate_State
- (Parsers : in out List;
- Current : in out Cursor'Class;
- Trace : in out WisiToken.Trace'Class;
- Terminals : in Base_Token_Arrays.Vector)
- is
- use all type Ada.Containers.Count_Type;
-
- function Compare
- (Stack_1 : in Parser_Stacks.Stack;
- Tree_1 : in Syntax_Trees.Tree;
- Stack_2 : in Parser_Stacks.Stack;
- Tree_2 : in Syntax_Trees.Tree)
- return Boolean
- is
- begin
- if Stack_1.Depth /= Stack_2.Depth then
- return False;
- else
- for I in reverse 1 .. Stack_1.Depth - 1 loop
- -- Assume they differ near the top; no point in comparing
bottom
- -- item. The syntax trees will differ even if the tokens on
the stack
- -- are the same, so compare the tokens.
- declare
- Item_1 : Parser_Stack_Item renames Stack_1 (I);
- Item_2 : Parser_Stack_Item renames Stack_2 (I);
- begin
- if Item_1.State /= Item_2.State then
- return False;
- else
- if not Syntax_Trees.Same_Token (Tree_1, Item_1.Token,
Tree_2, Item_2.Token) then
- return False;
- end if;
- end if;
- end;
- end loop;
- return True;
- end if;
- end Compare;
-
- Other : Cursor := Parsers.First;
- begin
- loop
- exit when Other.Is_Done;
- declare
- Other_Parser : Parser_State renames Other.State_Ref;
- begin
- if Other.Label /= Current.Label and then
- Other.Verb /= Error and then
- Compare
- (Other_Parser.Stack, Other_Parser.Tree,
Current.State_Ref.Stack, Current.State_Ref.Tree)
- then
- exit;
- end if;
- end;
- Other.Next;
- end loop;
-
- if not Other.Is_Done then
- -- Both have the same number of errors, otherwise one would have been
- -- terminated earlier.
- if Other.Total_Recover_Cost = Current.Total_Recover_Cost then
- if Other.Max_Recover_Ops_Length = Current.Max_Recover_Ops_Length
then
- Parsers.Terminate_Parser (Other, "duplicate state: random",
Trace, Terminals);
- else
- -- Keep the minimum ops length
- if Other.Max_Recover_Ops_Length >
Current.Max_Recover_Ops_Length then
- null;
- else
- Other := Cursor (Current);
- Current.Next;
- end if;
- Parsers.Terminate_Parser (Other, "duplicate state: ops length",
Trace, Terminals);
- end if;
- else
- if Other.Total_Recover_Cost > Current.Total_Recover_Cost then
- null;
- else
- Other := Cursor (Current);
- Current.Next;
- end if;
- Parsers.Terminate_Parser (Other, "duplicate state: cost", Trace,
Terminals);
- end if;
- end if;
- end Duplicate_State;
-
- function State_Ref (Position : in Cursor) return State_Reference
- is begin
- return (Element => Parser_State_Lists.Constant_Ref
(Position.Ptr).Element);
- end State_Ref;
-
- function First_State_Ref (List : in Parser_Lists.List'Class) return
State_Reference
- is begin
- return (Element => Parser_State_Lists.Constant_Ref
(List.Elements.First).Element);
- end First_State_Ref;
-
- function First_Constant_State_Ref (List : in Parser_Lists.List'Class)
return Constant_State_Reference
- is begin
- return (Element => Parser_State_Lists.Constant_Ref
(List.Elements.First).Element);
- end First_Constant_State_Ref;
-
- procedure Put_Top_10 (Trace : in out WisiToken.Trace'Class; Cursor : in
Parser_Lists.Cursor)
- is
- Parser_State : Parser_Lists.Parser_State renames
Parser_State_Lists.Constant_Ref (Cursor.Ptr);
- begin
- Trace.Put (Natural'Image (Parser_State.Label) & " stack: ");
- Trace.Put_Line (Image (Parser_State.Stack, Trace.Descriptor.all,
Parser_State.Tree, Depth => 10));
- end Put_Top_10;
-
- procedure Prepend_Copy
- (List : in out Parser_Lists.List;
- Cursor : in Parser_Lists.Cursor'Class)
- is
- New_Item : Parser_State;
- begin
- List.Parser_Label := List.Parser_Label + 1;
- declare
- Item : Parser_State renames Parser_State_Lists.Variable_Ref
(Cursor.Ptr);
- -- We can't do 'Prepend' in the scope of this 'renames';
- -- that would be tampering with cursors.
- begin
- Item.Tree.Set_Flush_False;
-
- -- We specify all items individually, rather copy Item and then
- -- override a few, to avoid copying large items like Recover.
- -- We copy Recover.Enqueue_Count .. Check_Count for unit tests.
- New_Item :=
- (Shared_Token => Item.Shared_Token,
- Recover_Insert_Delete => Item.Recover_Insert_Delete,
- Recover_Insert_Delete_Current =>
Item.Recover_Insert_Delete_Current,
- Current_Token => Item.Current_Token,
- Inc_Shared_Token => Item.Inc_Shared_Token,
- Stack => Item.Stack,
- Tree => Item.Tree,
- Recover =>
- (Enqueue_Count => Item.Recover.Enqueue_Count,
- Config_Full_Count => Item.Recover.Config_Full_Count,
- Check_Count => Item.Recover.Check_Count,
- others => <>),
- Resume_Active => Item.Resume_Active,
- Resume_Token_Goal => Item.Resume_Token_Goal,
- Conflict_During_Resume => Item.Conflict_During_Resume,
- Zombie_Token_Count => 0,
- Errors => Item.Errors,
- Label => List.Parser_Label,
- Verb => Item.Verb);
- end;
- List.Elements.Prepend (New_Item);
- end Prepend_Copy;
-
- ----------
- -- stuff for iterators
-
- function To_Cursor (Ptr : in Parser_Node_Access) return Cursor
- is begin
- return (Ptr.Elements, Ptr.Ptr);
- end To_Cursor;
-
- function Constant_Reference
- (Container : aliased in List'Class;
- Position : in Parser_Node_Access)
- return Constant_Reference_Type
- is
- pragma Unreferenced (Container);
- begin
- return (Element => Parser_State_Lists.Constant_Ref
(Position.Ptr).Element);
- end Constant_Reference;
-
- function Reference
- (Container : aliased in out List'Class;
- Position : in Parser_Node_Access)
- return State_Reference
- is
- pragma Unreferenced (Container);
- begin
- return (Element => Parser_State_Lists.Variable_Ref
(Position.Ptr).Element);
- end Reference;
-
- function Persistent_State_Ref (Position : in Parser_Node_Access) return
State_Access
- is begin
- return State_Access (Parser_State_Lists.Persistent_Ref (Position.Ptr));
- end Persistent_State_Ref;
-
- type Iterator (Elements : access Parser_State_Lists.List) is new
Iterator_Interfaces.Forward_Iterator
- with null record;
-
- overriding function First (Object : Iterator) return Parser_Node_Access;
- overriding function Next
- (Object : in Iterator;
- Position : in Parser_Node_Access)
- return Parser_Node_Access;
-
- overriding function First (Object : Iterator) return Parser_Node_Access
- is begin
- return (Elements => Object.Elements, Ptr => Object.Elements.First);
- end First;
-
- overriding function Next
- (Object : in Iterator;
- Position : in Parser_Node_Access)
- return Parser_Node_Access
- is
- pragma Unreferenced (Object);
- begin
- return (Position.Elements, Parser_State_Lists.Next (Position.Ptr));
- end Next;
-
- function Iterate (Container : aliased in out List) return
Iterator_Interfaces.Forward_Iterator'Class
- is begin
- return Iterator'(Elements => Container.Elements'Access);
- end Iterate;
-
- function Has_Element (Iterator : in Parser_Node_Access) return Boolean
- is begin
- return Parser_State_Lists.Has_Element (Iterator.Ptr);
- end Has_Element;
-
- function Label (Iterator : in Parser_State) return Natural
- is begin
- return Iterator.Label;
- end Label;
-
- function Verb (Iterator : in Parser_State) return All_Parse_Action_Verbs
- is begin
- return Iterator.Verb;
- end Verb;
-
- procedure Set_Verb (Iterator : in out Parser_State; Verb : in
All_Parse_Action_Verbs)
- is begin
- Iterator.Verb := Verb;
- end Set_Verb;
-
-end WisiToken.Parse.LR.Parser_Lists;
diff --git a/packages/wisi/wisitoken-parse-lr-parser_lists.ads
b/packages/wisi/wisitoken-parse-lr-parser_lists.ads
deleted file mode 100644
index 6a77e6c..0000000
--- a/packages/wisi/wisitoken-parse-lr-parser_lists.ads
+++ /dev/null
@@ -1,274 +0,0 @@
--- Abstract :
---
--- Generalized LR parser state.
---
--- Copyright (C) 2014-2015, 2017 - 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Iterator_Interfaces;
-with SAL.Gen_Indefinite_Doubly_Linked_Lists;
-with SAL.Gen_Unbounded_Definite_Stacks;
-with WisiToken.Syntax_Trees;
-package WisiToken.Parse.LR.Parser_Lists is
-
- type Parser_Stack_Item is record
- State : Unknown_State_Index := Unknown_State;
- Token : Node_Index := Invalid_Node_Index;
- end record;
-
- package Parser_Stacks is new SAL.Gen_Unbounded_Definite_Stacks
(Parser_Stack_Item);
-
- function Parser_Stack_Image
- (Stack : in Parser_Stacks.Stack;
- Descriptor : in WisiToken.Descriptor;
- Tree : in Syntax_Trees.Tree;
- Depth : in SAL.Base_Peek_Type := 0)
- return String;
- -- If Depth = 0, put all of Stack. Otherwise put Min (Depth,
- -- Stack.Depth) items.
- --
- -- Unique name for calling from debugger
-
- function Image
- (Stack : in Parser_Stacks.Stack;
- Descriptor : in WisiToken.Descriptor;
- Tree : in Syntax_Trees.Tree;
- Depth : in SAL.Base_Peek_Type := 0)
- return String renames Parser_Stack_Image;
-
- type Base_Parser_State is tagged
- record
- -- Visible components for direct access
-
- Shared_Token : Base_Token_Index := Invalid_Token_Index;
- -- Last token read from Shared_Parser.Terminals.
-
- Recover_Insert_Delete : aliased Recover_Op_Arrays.Vector;
- -- Tokens that were inserted or deleted during error recovery.
- -- Contains only Insert and Delete ops. Filled by error recover, used
- -- by main parse and Execute_Actions.
- --
- -- Not emptied between error recovery sessions, so Execute_Actions
- -- knows about all insert/delete.
-
- Recover_Insert_Delete_Current : Recover_Op_Arrays.Extended_Index :=
Recover_Op_Arrays.No_Index;
- -- Next item in Recover_Insert_Delete to be processed by main parse;
- -- No_Index if all done.
-
- Current_Token : Node_Index := Invalid_Node_Index;
- -- Current terminal, in Tree
-
- Inc_Shared_Token : Boolean := True;
-
- Stack : Parser_Stacks.Stack;
- -- There is no need to use a branched stack; max stack length is
- -- proportional to source text nesting depth, not source text length.
-
- Tree : aliased Syntax_Trees.Tree;
- -- We use a branched tree to avoid copying large trees for each
- -- spawned parser; tree size is proportional to source text size. In
- -- normal parsing, parallel parsers are short-lived; they each process
- -- a few tokens, to resolve a grammar conflict.
- --
- -- When there is only one parser, tree nodes are written directly to
- -- the shared tree (via the branched tree, with Flush => True).
- --
- -- When there is more than one, tree nodes are written to the
- -- branched tree. Then when all but one parsers are terminated, the
- -- remaining branched tree is flushed into the shared tree.
-
- Recover : aliased LR.McKenzie_Data := (others => <>);
-
- Zombie_Token_Count : Base_Token_Index := 0;
- -- If Zombie_Token_Count > 0, this parser has errored, but is waiting
- -- to see if other parsers do also.
-
- Resume_Active : Boolean := False;
- Resume_Token_Goal : Base_Token_Index := Invalid_Token_Index;
- Conflict_During_Resume : Boolean := False;
- -- Resume is complete for this parser Shared_Token reaches this
- -- Resume_Token_Goal.
-
- Errors : Parse_Error_Lists.List;
- end record;
-
- type Parser_State is new Base_Parser_State with private;
- type State_Access is access all Parser_State;
-
- type List is tagged private
- with
- Constant_Indexing => Constant_Reference,
- Variable_Indexing => Reference,
- Default_Iterator => Iterate,
- Iterator_Element => Parser_State;
-
- function New_List (Shared_Tree : in Syntax_Trees.Base_Tree_Access) return
List;
-
- function Last_Label (List : in Parser_Lists.List) return Natural;
-
- function Count (List : in Parser_Lists.List) return SAL.Base_Peek_Type;
-
- type Cursor (<>) is tagged private;
-
- function First (List : aliased in out Parser_Lists.List'Class) return
Cursor;
- procedure Next (Cursor : in out Parser_Lists.Cursor);
- function Is_Done (Cursor : in Parser_Lists.Cursor) return Boolean;
- function Has_Element (Cursor : in Parser_Lists.Cursor) return Boolean is
(not Is_Done (Cursor));
- function Label (Cursor : in Parser_Lists.Cursor) return Natural;
- function Total_Recover_Cost (Cursor : in Parser_Lists.Cursor) return
Integer;
- function Max_Recover_Ops_Length (Cursor : in Parser_Lists.Cursor) return
Ada.Containers.Count_Type;
- function Min_Recover_Cost (Cursor : in Parser_Lists.Cursor) return Integer;
-
- procedure Set_Verb (Cursor : in Parser_Lists.Cursor; Verb : in
All_Parse_Action_Verbs);
- function Verb (Cursor : in Parser_Lists.Cursor) return
All_Parse_Action_Verbs;
-
- procedure Terminate_Parser
- (Parsers : in out List;
- Current : in out Cursor'Class;
- Message : in String;
- Trace : in out WisiToken.Trace'Class;
- Terminals : in Base_Token_Arrays.Vector);
- -- Terminate Current. Current is set to no element.
- --
- -- Terminals is used to report the current token in the message.
-
- procedure Duplicate_State
- (Parsers : in out List;
- Current : in out Cursor'Class;
- Trace : in out WisiToken.Trace'Class;
- Terminals : in Base_Token_Arrays.Vector);
- -- If any other parser in Parsers has a stack equivalent to Current,
- -- Terminate one of them. Current is either unchanged, or advanced to
- -- the next parser.
- --
- -- Terminals is used to report the current token in the message.
-
- type State_Reference (Element : not null access Parser_State) is null record
- with Implicit_Dereference => Element;
-
- function State_Ref (Position : in Cursor) return State_Reference
- with Pre => Has_Element (Position);
- -- Direct access to visible components of Parser_State
-
- function First_State_Ref (List : in Parser_Lists.List'Class) return
State_Reference
- with Pre => List.Count > 0;
- -- Direct access to visible components of first parser's Parser_State
-
- type Constant_State_Reference (Element : not null access constant
Parser_State) is null record
- with Implicit_Dereference => Element;
-
- function First_Constant_State_Ref (List : in Parser_Lists.List'Class)
return Constant_State_Reference
- with Pre => List.Count > 0;
- -- Direct access to visible components of first parser's Parser_State
-
- procedure Put_Top_10 (Trace : in out WisiToken.Trace'Class; Cursor : in
Parser_Lists.Cursor);
- -- Put image of top 10 stack items to Trace.
-
- procedure Prepend_Copy (List : in out Parser_Lists.List; Cursor : in
Parser_Lists.Cursor'Class);
- -- Copy parser at Cursor, prepend to current list. New copy will not
- -- appear in Cursor.Next ...; it is accessible as First (List).
- --
- -- Copy.Recover is set to default.
-
- ----------
- -- Stuff for iterators, to allow
- -- 'for Parser of Parsers loop'
- -- 'for I in Parsers.Iterate loop'
- --
- -- requires Parser_State to be not an incomplete type.
-
- -- We'd like to use Cursor here, but we want that to be tagged, to
- -- allow 'Cursor.operation' syntax, and the requirements of
- -- iterators prevent a tagged iterator type (two tagged types on
- -- First in this package body). So we use Parser_Node_Access as
- -- the iterator type for Iterators, and typical usage is:
- --
- -- for I in Parsers.Iterate loop
- -- declare
- -- Cursor : Parser_Lists.Cursor renames To_Cursor (Parsers, I);
- -- begin
- -- Cursor.<cursor operation>
- --
- -- ... Parsers (I).<visible parser_state component> ...
- -- end;
- -- end loop;
- --
- -- or:
- -- for Current_Parser of Parsers loop
- -- ... Current_Parser.<visible parser_state component> ...
- -- end loop;
-
- type Parser_Node_Access (<>) is private;
-
- function To_Cursor (Ptr : in Parser_Node_Access) return Cursor;
-
- type Constant_Reference_Type (Element : not null access constant
Parser_State) is null record
- with Implicit_Dereference => Element;
-
- function Constant_Reference
- (Container : aliased in List'Class;
- Position : in Parser_Node_Access)
- return Constant_Reference_Type;
- pragma Inline (Constant_Reference);
-
- function Reference
- (Container : aliased in out List'Class;
- Position : in Parser_Node_Access)
- return State_Reference;
- pragma Inline (Reference);
-
- function Persistent_State_Ref (Position : in Parser_Node_Access) return
State_Access;
-
- function Has_Element (Iterator : in Parser_Node_Access) return Boolean;
-
- package Iterator_Interfaces is new Ada.Iterator_Interfaces
(Parser_Node_Access, Has_Element);
-
- function Iterate (Container : aliased in out List) return
Iterator_Interfaces.Forward_Iterator'Class;
-
- -- Access to some private Parser_State components
-
- function Label (Iterator : in Parser_State) return Natural;
- procedure Set_Verb (Iterator : in out Parser_State; Verb : in
All_Parse_Action_Verbs);
- function Verb (Iterator : in Parser_State) return All_Parse_Action_Verbs;
-
-private
-
- type Parser_State is new Base_Parser_State with record
- Label : Natural; -- for debugging/verbosity
-
- Verb : All_Parse_Action_Verbs := Shift; -- current action to perform
- end record;
-
- package Parser_State_Lists is new SAL.Gen_Indefinite_Doubly_Linked_Lists
(Parser_State);
-
- type List is tagged record
- Elements : aliased Parser_State_Lists.List;
- Parser_Label : Natural; -- label of last added parser.
- end record;
-
- type Cursor (Elements : access Parser_State_Lists.List) is tagged
- record
- Ptr : Parser_State_Lists.Cursor;
- end record;
-
- type Parser_Node_Access (Elements : access Parser_State_Lists.List) is
- record
- Ptr : Parser_State_Lists.Cursor;
- end record;
-
-end WisiToken.Parse.LR.Parser_Lists;
diff --git a/packages/wisi/wisitoken-parse-lr-parser_no_recover.adb
b/packages/wisi/wisitoken-parse-lr-parser_no_recover.adb
deleted file mode 100644
index 6fd2b80..0000000
--- a/packages/wisi/wisitoken-parse-lr-parser_no_recover.adb
+++ /dev/null
@@ -1,574 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2002 - 2005, 2008 - 2015, 2017 - 2020 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Exceptions;
-package body WisiToken.Parse.LR.Parser_No_Recover is
-
- procedure Reduce_Stack_1
- (Current_Parser : in Parser_Lists.Cursor;
- Action : in Reduce_Action_Rec;
- Nonterm : out Valid_Node_Index;
- Trace : in out WisiToken.Trace'Class)
- is
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
- Children_Tree : Valid_Node_Index_Array (1 .. SAL.Base_Peek_Type
(Action.Token_Count));
- -- for Set_Children.
- begin
- for I in reverse Children_Tree'Range loop
- Children_Tree (I) := Parser_State.Stack.Pop.Token;
- end loop;
-
- Nonterm := Parser_State.Tree.Add_Nonterm
- (Action.Production, Children_Tree, Action.Action, Default_Virtual =>
False);
- -- Computes Nonterm.Byte_Region
-
- if Trace_Parse > Detail then
- Trace.Put_Line (Parser_State.Tree.Image (Nonterm,
Trace.Descriptor.all, Include_Children => True));
- end if;
- end Reduce_Stack_1;
-
- procedure Do_Action
- (Action : in Parse_Action_Rec;
- Current_Parser : in Parser_Lists.Cursor;
- Shared_Parser : in Parser)
- is
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
- Nonterm : Valid_Node_Index;
- begin
- if Trace_Parse > Detail then
- Trace.Put
- (Integer'Image (Current_Parser.Label) & ": " &
- Trimmed_Image (Parser_State.Stack.Peek.State) & ": " &
- Parser_State.Tree.Image (Parser_State.Current_Token,
Trace.Descriptor.all) & " : ");
- Put (Trace, Action);
- Trace.New_Line;
- end if;
-
- case Action.Verb is
- when Shift =>
- Current_Parser.Set_Verb (Shift);
- Parser_State.Stack.Push ((Action.State, Parser_State.Current_Token));
- Parser_State.Tree.Set_State (Parser_State.Current_Token,
Action.State);
-
- when Reduce =>
- Current_Parser.Set_Verb (Reduce);
-
- declare
- New_State : constant Unknown_State_Index := Goto_For
- (Table => Shared_Parser.Table.all,
- State => Parser_State.Stack (SAL.Base_Peek_Type
(Action.Token_Count) + 1).State,
- ID => Action.Production.LHS);
- begin
- if New_State = Unknown_State then
- -- This is due to a bug in the LALR parser generator (see
- -- lalr_generator_bug_01.wy); we treat it as a syntax error.
- Current_Parser.Set_Verb (Error);
- if Trace_Parse > Detail then
- Trace.Put_Line (" ... error");
- end if;
- else
- Reduce_Stack_1 (Current_Parser, Action, Nonterm, Trace);
- Parser_State.Stack.Push ((New_State, Nonterm));
- Parser_State.Tree.Set_State (Nonterm, New_State);
-
- if Trace_Parse > Detail then
- Trace.Put_Line (" ... goto state " & Trimmed_Image
(New_State));
- end if;
- end if;
- end;
-
- when Accept_It =>
- Current_Parser.Set_Verb (Accept_It);
- Reduce_Stack_1
- (Current_Parser,
- (Reduce, Action.Production, Action.Action, Action.Check,
Action.Token_Count),
- Nonterm, Trace);
-
- Parser_State.Tree.Set_Root (Nonterm);
-
- when Error =>
- Current_Parser.Set_Verb (Action.Verb);
-
- -- We don't raise Syntax_Error here; another parser may be able to
- -- continue.
-
- declare
- Expecting : constant Token_ID_Set := LR.Expecting
- (Shared_Parser.Table.all,
Current_Parser.State_Ref.Stack.Peek.State);
- begin
- Parser_State.Errors.Append
- ((Label => LR.Action,
- First_Terminal => Trace.Descriptor.First_Terminal,
- Last_Terminal => Trace.Descriptor.Last_Terminal,
- Error_Token => Parser_State.Current_Token,
- Expecting => Expecting,
- Recover => (others => <>)));
-
- if Trace_Parse > Outline then
- Put
- (Trace,
- Integer'Image (Current_Parser.Label) & ": expecting: " &
- Image (Expecting, Trace.Descriptor.all));
- Trace.New_Line;
- end if;
- end;
- end case;
- end Do_Action;
-
- -- Return the type of parser cycle to execute.
- --
- -- Accept : all Parsers.Verb return Accept - done parsing.
- --
- -- Shift : some Parsers.Verb return Shift.
- --
- -- Reduce : some Parsers.Verb return Reduce.
- --
- -- Error : all Parsers.Verb return Error.
- procedure Parse_Verb
- (Shared_Parser : in out Parser;
- Verb : out All_Parse_Action_Verbs)
- is
- Shift_Count : SAL.Base_Peek_Type := 0;
- Accept_Count : SAL.Base_Peek_Type := 0;
- Error_Count : SAL.Base_Peek_Type := 0;
- begin
- for Parser_State of Shared_Parser.Parsers loop
- case Parser_State.Verb is
- when Shift =>
- Shift_Count := Shift_Count + 1;
-
- when Reduce =>
- Verb := Reduce;
- return;
-
- when Accept_It =>
- Accept_Count := Accept_Count + 1;
-
- when Error =>
- Error_Count := Error_Count + 1;
-
- when Pause =>
- -- This is parser_no_recover
- raise SAL.Programmer_Error;
- end case;
- end loop;
-
- if Shared_Parser.Parsers.Count = Accept_Count then
- Verb := Accept_It;
-
- elsif Shared_Parser.Parsers.Count = Error_Count then
- Verb := Error;
-
- elsif Shift_Count > 0 then
- Verb := Shift;
-
- else
- raise SAL.Programmer_Error;
- end if;
- end Parse_Verb;
-
- ----------
- -- Public subprograms, declaration order
-
- overriding procedure Finalize (Object : in out Parser)
- is begin
- Free_Table (Object.Table);
- end Finalize;
-
- procedure New_Parser
- (Parser : out LR.Parser_No_Recover.Parser;
- Trace : not null access WisiToken.Trace'Class;
- Lexer : in WisiToken.Lexer.Handle;
- Table : in Parse_Table_Ptr;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access;
- Max_Parallel : in SAL.Base_Peek_Type :=
Default_Max_Parallel;
- First_Parser_Label : in Integer := 1;
- Terminate_Same_State : in Boolean := True)
- is
- use all type Syntax_Trees.User_Data_Access;
- begin
- Parser.Lexer := Lexer;
- Parser.Trace := Trace;
- Parser.Table := Table;
- Parser.User_Data := User_Data;
- Parser.Max_Parallel := Max_Parallel;
- Parser.First_Parser_Label := First_Parser_Label;
- Parser.Terminate_Same_State := Terminate_Same_State;
-
- if User_Data /= null then
- User_Data.Set_Lexer_Terminals (Lexer,
Parser.Terminals'Unchecked_Access);
- end if;
- end New_Parser;
-
- overriding procedure Parse (Shared_Parser : aliased in out Parser)
- is
- use all type Syntax_Trees.User_Data_Access;
-
- Trace : WisiToken.Trace'Class renames Shared_Parser.Trace.all;
-
- Current_Verb : All_Parse_Action_Verbs;
- Action : Parse_Action_Node_Ptr;
-
- procedure Check_Error (Check_Parser : in out Parser_Lists.Cursor)
- is begin
- if Check_Parser.Verb = Error then
- -- This parser errored on last input. This is how grammar
conflicts
- -- are resolved when the input text is valid, so we terminate this
- -- parser.
-
- if Shared_Parser.Parsers.Count = 1 then
- raise Syntax_Error;
- else
- Shared_Parser.Parsers.Terminate_Parser
- (Check_Parser, "", Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- end if;
- else
- Check_Parser.Next;
- end if;
- end Check_Error;
-
- begin
- if Shared_Parser.User_Data /= null then
- Shared_Parser.User_Data.Reset;
- end if;
-
- Shared_Parser.Shared_Tree.Clear;
-
- Shared_Parser.Parsers := Parser_Lists.New_List
- (Shared_Tree => Shared_Parser.Shared_Tree'Unchecked_Access);
-
- Shared_Parser.Lex_All;
-
- Shared_Parser.Parsers.First.State_Ref.Stack.Push
((Shared_Parser.Table.State_First, others => <>));
-
- Main_Loop :
- loop
- -- exit on Accept_It action or syntax error.
-
- Parse_Verb (Shared_Parser, Current_Verb);
-
- case Current_Verb is
- when Shift =>
- -- All parsers just shifted a token; get the next token
-
- for Parser_State of Shared_Parser.Parsers loop
- Parser_State.Shared_Token := Parser_State.Shared_Token + 1;
- Parser_State.Current_Token := Shared_Parser.Terminals
- (Parser_State.Shared_Token).Tree_Index;
- end loop;
-
- when Accept_It =>
- -- All parsers accepted.
- declare
- Count : constant SAL.Base_Peek_Type :=
Shared_Parser.Parsers.Count;
- begin
- if Count = 1 then
- -- Nothing more to do
- if Trace_Parse > Outline then
- Trace.Put_Line (Integer'Image
(Shared_Parser.Parsers.First.Label) & ": succeed");
- end if;
- exit Main_Loop;
-
- else
- -- More than one parser is active; ambiguous parse.
- declare
- Token : Base_Token renames Shared_Parser.Terminals
(Shared_Parser.Terminals.Last_Index);
- begin
- raise WisiToken.Parse_Error with Error_Message
- (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
- "Ambiguous parse:" & SAL.Base_Peek_Type'Image (Count)
& " parsers active.");
- end;
- end if;
- end;
-
- when Reduce =>
- null;
-
- when Error =>
- -- All parsers errored; terminate with error. Semantic_State has
all
- -- the required info (recorded by Error in Do_Action), so we just
- -- raise the exception.
- raise Syntax_Error;
-
- when Pause =>
- -- This is parser_no_recover
- raise SAL.Programmer_Error;
- end case;
-
- -- We don't use 'for Parser_State of Parsers loop' here,
- -- because terminate on error and spawn on conflict require
- -- changing the parser list.
- declare
- Current_Parser : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
- begin
- loop
- exit when Current_Parser.Is_Done;
-
- if Shared_Parser.Terminate_Same_State and
- Current_Verb = Shift
- then
- Shared_Parser.Parsers.Duplicate_State
- (Current_Parser, Shared_Parser.Trace.all,
Shared_Parser.Terminals);
- -- If Duplicate_State terminated Current_Parser,
Current_Parser now
- -- points to the next parser. Otherwise it is unchanged.
- end if;
-
- exit when Current_Parser.Is_Done;
-
- if Trace_Parse > Extra then
- Trace.Put_Line
- ("current_verb: " & Parse_Action_Verbs'Image
(Current_Verb) &
- "," & Integer'Image (Current_Parser.Label) &
- ".verb: " & Parse_Action_Verbs'Image
(Current_Parser.Verb));
- end if;
-
- -- Each branch of the following 'if' calls either
Current_Parser.Free
- -- (which advances to the next parser) or Current_Parser.Next.
-
- if Current_Parser.Verb = Current_Verb then
- if Trace_Parse > Extra then
- Parser_Lists.Put_Top_10 (Trace, Current_Parser);
- end if;
-
- declare
- State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref.Element.all;
- begin
- Action := Action_For
- (Table => Shared_Parser.Table.all,
- State => State.Stack.Peek.State,
- ID => State.Tree.ID (State.Current_Token));
- end;
-
- declare
- Conflict : Parse_Action_Node_Ptr := Action.Next;
- begin
- loop
- exit when Conflict = null;
- -- Spawn a new parser (before modifying
Current_Parser stack).
-
- if Shared_Parser.Parsers.Count =
Shared_Parser.Max_Parallel then
- declare
- Parser_State : Parser_Lists.Parser_State renames
Current_Parser.State_Ref;
- Token : Base_Token renames
Shared_Parser.Terminals (Parser_State.Shared_Token);
- begin
- raise WisiToken.Parse_Error with Error_Message
- (Shared_Parser.Lexer.File_Name, Token.Line,
Token.Column,
- ": too many parallel parsers required in
grammar state" &
- State_Index'Image
(Parser_State.Stack.Peek.State) &
- "; simplify grammar, or increase
max-parallel (" &
- SAL.Base_Peek_Type'Image
(Shared_Parser.Max_Parallel) & ")");
- end;
- else
- if Trace_Parse > Outline then
- declare
- Parser_State : Parser_Lists.Parser_State
renames Current_Parser.State_Ref;
- begin
- Trace.Put_Line
- (Integer'Image (Current_Parser.Label) & ":
" &
- Trimmed_Image
(Parser_State.Stack.Peek.State) & ": " &
- Parser_State.Tree.Image
- (Parser_State.Current_Token,
Trace.Descriptor.all) & " : " &
- "spawn" & Integer'Image
(Shared_Parser.Parsers.Last_Label + 1) & ", (" &
- Trimmed_Image (1 + Integer
(Shared_Parser.Parsers.Count)) & " active)");
- end;
- end if;
-
- Shared_Parser.Parsers.Prepend_Copy (Current_Parser);
- Do_Action (Conflict.Item,
Shared_Parser.Parsers.First, Shared_Parser);
-
- declare
- Temp : Parser_Lists.Cursor :=
Shared_Parser.Parsers.First;
- begin
- Check_Error (Temp);
- end;
- end if;
-
- Conflict := Conflict.Next;
- end loop;
- end;
-
- Do_Action (Action.Item, Current_Parser, Shared_Parser);
- Check_Error (Current_Parser);
-
- else
- -- Current parser is waiting for others to catch up
- Current_Parser.Next;
- end if;
- end loop;
- end;
- end loop Main_Loop;
-
- -- We don't raise Syntax_Error for lexer errors, since they are all
- -- recovered, either by inserting a quote, or by ignoring the
- -- character.
- end Parse;
-
- overriding procedure Execute_Actions
- (Parser : in out LR.Parser_No_Recover.Parser;
- Image_Augmented : in Syntax_Trees.Image_Augmented := null)
- is
- pragma Unreferenced (Image_Augmented);
- use all type Syntax_Trees.User_Data_Access;
-
- procedure Process_Node
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- is
- use all type Syntax_Trees.Node_Label;
- begin
- if Tree.Label (Node) /= Nonterm then
- return;
- end if;
-
- declare
- use all type Syntax_Trees.Semantic_Action;
- Tree_Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
- begin
- Parser.User_Data.Reduce (Tree, Node, Tree_Children);
-
- if Tree.Action (Node) /= null then
- begin
- Tree.Action (Node) (Parser.User_Data.all, Tree, Node,
Tree_Children);
- exception
- when E : others =>
- declare
- 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, Line, Column,
- "action raised exception " &
Ada.Exceptions.Exception_Name (E) & ": " &
- Ada.Exceptions.Exception_Message (E));
- end;
- end;
- end if;
- end;
- end Process_Node;
-
- begin
- if Parser.User_Data /= null then
- if Parser.Parsers.Count > 1 then
- raise Syntax_Error with "ambiguous parse; can't execute actions";
- end if;
-
- declare
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_State_Ref.Element.all;
- begin
- Parser_State.Tree.Set_Parents;
- Parser.User_Data.Initialize_Actions (Parser_State.Tree);
- Parser_State.Tree.Process_Tree (Process_Node'Access);
- end;
- end if;
- end Execute_Actions;
-
- overriding function Tree (Parser : in LR.Parser_No_Recover.Parser) return
Syntax_Trees.Tree
- is begin
- if Parser.Parsers.Count > 1 then
- raise WisiToken.Parse_Error with "ambigous parse";
- else
- return Parser.Parsers.First_State_Ref.Tree;
- end if;
- end Tree;
-
- overriding
- function Tree_Var_Ref
- (Parser : aliased in out LR.Parser_No_Recover.Parser)
- return Syntax_Trees.Tree_Variable_Reference
- is begin
- if Parser.Parsers.Count > 1 then
- raise WisiToken.Parse_Error with "ambigous parse";
- else
- return (Element => Parser.Parsers.First_State_Ref.Tree'Access);
- end if;
- end Tree_Var_Ref;
-
- overriding function Any_Errors (Parser : in LR.Parser_No_Recover.Parser)
return Boolean
- is
- use all type Ada.Containers.Count_Type;
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
- begin
- pragma Assert (Parser_State.Tree.Flushed);
- return Parser.Parsers.Count > 1 or Parser_State.Errors.Length > 0 or
Parser.Lexer.Errors.Length > 0;
- end Any_Errors;
-
- overriding procedure Put_Errors (Parser : in LR.Parser_No_Recover.Parser)
- is
- use Ada.Text_IO;
-
- Parser_State : Parser_Lists.Parser_State renames
Parser.Parsers.First_Constant_State_Ref;
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
- begin
- for Item of Parser.Lexer.Errors loop
- Put_Line
- (Current_Error,
- Parser.Lexer.File_Name & ":0:0: lexer unrecognized character at" &
Buffer_Pos'Image (Item.Char_Pos));
- end loop;
-
- for Item of Parser_State.Errors loop
- case Item.Label is
- when Action =>
- declare
- Token : Base_Token renames Parser.Terminals
(Parser_State.Tree.First_Shared_Terminal (Item.Error_Token));
- begin
- Put_Line
- (Current_Error,
- Error_Message
- (Parser.Lexer.File_Name, Token.Line, Token.Column,
- "syntax error: expecting " & Image (Item.Expecting,
Descriptor) &
- ", found '" & Parser.Lexer.Buffer_Text
(Token.Byte_Region) & "'"));
- end;
-
- when Check =>
- null;
-
- when Message =>
- Put_Line (Current_Error, -Item.Msg);
- end case;
-
- end loop;
- end Put_Errors;
-
-end WisiToken.Parse.LR.Parser_No_Recover;
diff --git a/packages/wisi/wisitoken-parse-lr-parser_no_recover.ads
b/packages/wisi/wisitoken-parse-lr-parser_no_recover.ads
deleted file mode 100644
index 5e630d2..0000000
--- a/packages/wisi/wisitoken-parse-lr-parser_no_recover.ads
+++ /dev/null
@@ -1,92 +0,0 @@
--- Abstract :
---
--- A generalized LR parser, with no error recovery, no semantic checks.
---
--- This allows wisi-generate (which uses the generated wisi_grammar)
--- to not depend on wisitoken-lr-mckenzie_recover, so editing that
--- does not cause everything to be regenerated/compiled.
---
--- Copyright (C) 2002, 2003, 2009, 2010, 2013 - 2015, 2017 - 2020 Free
Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Lexer;
-with WisiToken.Parse.LR.Parser_Lists;
-with WisiToken.Syntax_Trees;
-package WisiToken.Parse.LR.Parser_No_Recover is
-
- Default_Max_Parallel : constant := 15;
-
- type Parser is new WisiToken.Parse.Base_Parser with record
- Table : Parse_Table_Ptr;
- Shared_Tree : aliased Syntax_Trees.Base_Tree;
- -- Each parser has its own branched syntax tree, all branched from
- -- this tree.
- --
- -- See WisiToken.LR.Parser_Lists Parser_State for more discussion of
- -- Shared_Tree.
-
- Parsers : aliased Parser_Lists.List;
-
- Max_Parallel : SAL.Base_Peek_Type;
- First_Parser_Label : Integer;
- Terminate_Same_State : Boolean;
- end record;
-
- overriding procedure Finalize (Object : in out LR.Parser_No_Recover.Parser);
- -- Deep free Object.Table.
-
- procedure New_Parser
- (Parser : out LR.Parser_No_Recover.Parser;
- Trace : not null access WisiToken.Trace'Class;
- Lexer : in WisiToken.Lexer.Handle;
- Table : in Parse_Table_Ptr;
- User_Data : in Syntax_Trees.User_Data_Access;
- Max_Parallel : in SAL.Base_Peek_Type :=
Default_Max_Parallel;
- First_Parser_Label : in Integer := 1;
- Terminate_Same_State : in Boolean := True);
-
- overriding procedure Parse (Shared_Parser : aliased in out
LR.Parser_No_Recover.Parser);
- -- Attempt a parse. Calls Parser.Lexer.Reset, runs lexer to end of
- -- input setting Shared_Parser.Terminals, then parses tokens.
- --
- -- If a parse error is encountered, raises Syntax_Error.
- -- Parser.Lexer_Errors and Parsers(*).Errors contain information
- -- about the errors.
- --
- -- For other errors, raises Parse_Error with an appropriate error
- -- message.
-
- overriding function Tree (Parser : in LR.Parser_No_Recover.Parser) return
Syntax_Trees.Tree;
-
- overriding
- function Tree_Var_Ref
- (Parser : aliased in out LR.Parser_No_Recover.Parser)
- return Syntax_Trees.Tree_Variable_Reference;
-
- overriding function Any_Errors (Parser : in LR.Parser_No_Recover.Parser)
return Boolean;
-
- overriding procedure Put_Errors (Parser : in LR.Parser_No_Recover.Parser);
- -- Put user-friendly error messages from the parse to
- -- Ada.Text_IO.Current_Error.
-
- overriding procedure Execute_Actions
- (Parser : in out LR.Parser_No_Recover.Parser;
- Image_Augmented : in Syntax_Trees.Image_Augmented := null);
- -- Execute the grammar actions in Parser.
-
-end WisiToken.Parse.LR.Parser_No_Recover;
diff --git a/packages/wisi/wisitoken-parse-lr.adb
b/packages/wisi/wisitoken-parse-lr.adb
deleted file mode 100644
index 27fe85d..0000000
--- a/packages/wisi/wisitoken-parse-lr.adb
+++ /dev/null
@@ -1,767 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2013-2015, 2017 - 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (GPL);
-
-with Ada.Exceptions;
-with Ada.Strings.Maps;
-with Ada.Strings.Fixed;
-with Ada.Text_IO;
-with GNATCOLL.Mmap;
-package body WisiToken.Parse.LR is
-
- ----------
- -- Public subprograms, declaration order
-
- function Image (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor) return String
- is
- use Ada.Containers;
- begin
- case Item.Verb is
- when Shift =>
- return "(Shift," & State_Index'Image (Item.State) & ")";
-
- when Reduce =>
- return "(Reduce," & Count_Type'Image (Item.Token_Count) & ", " &
- Image (Item.Production.LHS, Descriptor) & "," & Trimmed_Image
(Item.Production.RHS) & ")";
- when Accept_It =>
- return "(Accept It)";
- when Error =>
- return "(Error)";
- end case;
- end Image;
-
- procedure Put (Trace : in out WisiToken.Trace'Class; Item : in
Parse_Action_Rec)
- is
- use Ada.Containers;
- begin
- case Item.Verb is
- when Shift =>
- Trace.Put ("shift and goto state" & State_Index'Image (Item.State),
Prefix => False);
-
- when Reduce =>
- Trace.Put
- ("reduce" & Count_Type'Image (Item.Token_Count) & " tokens to " &
- Image (Item.Production.LHS, Trace.Descriptor.all),
- Prefix => False);
- when Accept_It =>
- Trace.Put ("accept it", Prefix => False);
- when Error =>
- Trace.Put ("ERROR", Prefix => False);
- end case;
- end Put;
-
- function Equal (Left, Right : in Parse_Action_Rec) return Boolean
- is
- use all type Ada.Containers.Count_Type;
- begin
- if Left.Verb = Right.Verb then
- case Left.Verb is
- when Shift =>
- return Left.State = Right.State;
-
- when Reduce | Accept_It =>
- return Left.Production.LHS = Right.Production.LHS and
Left.Token_Count = Right.Token_Count;
-
- when Error =>
- return True;
- end case;
- else
- return False;
- end if;
- end Equal;
-
- function Is_In (Item : in Parse_Action_Rec; List : in
Parse_Action_Node_Ptr) return Boolean
- is
- Node : Parse_Action_Node_Ptr := List;
- begin
- loop
- exit when Node = null;
- if Equal (Item, Node.Item) then
- return True;
- end if;
- Node := Node.Next;
- end loop;
- return False;
- end Is_In;
-
- function Compare (Left, Right : in Token_ID) return SAL.Compare_Result
- is begin
- if Left < Right then
- return SAL.Less;
- elsif Left = Right then
- return SAL.Equal;
- else
- return SAL.Greater;
- end if;
- end Compare;
-
- procedure Add
- (List : in out Action_Arrays.Vector;
- Symbol : in Token_ID;
- Action : in Parse_Action_Rec)
- is begin
- declare
- Node : constant Action_Arrays.Find_Reference_Type := List.Find
(Symbol);
- begin
- if Node.Element /= null then
- declare
- I : Parse_Action_Node_Ptr := Node.Element.Actions;
- begin
- loop
- exit when I.Next = null;
- I := I.Next;
- end loop;
- I.Next := new Parse_Action_Node'(Action, null);
- return;
- end;
- end if;
- end;
- List.Insert ((Symbol, new Parse_Action_Node'(Action, null)));
- end Add;
-
- function To_Vector (Item : in Kernel_Info_Array) return
Kernel_Info_Arrays.Vector
- is begin
- return Result : Kernel_Info_Arrays.Vector do
- Result.Set_First_Last (Item'First, Item'Last);
- for I in Item'Range loop
- Result (I) := Item (I);
- end loop;
- end return;
- end To_Vector;
-
- function Strict_Image (Item : in Kernel_Info) return String
- is begin
- return "(" & Image (Item.Production) & ", " &
- Item.Before_Dot'Image & ", " &
- Item.Length_After_Dot'Image & ", " &
- Image (Item.Reduce_Production) & ", " &
- Item.Reduce_Count'Image & ")";
- end Strict_Image;
-
- function Strict_Image (Item : in Minimal_Action) return String
- is begin
- case Item.Verb is
- when Shift =>
- return "(Shift, " & Image (Item.Production) & ", " &
- Token_ID'Image (Item.ID) & "," & State_Index'Image (Item.State) &
")";
-
- when Reduce =>
- return "(Reduce, " & Image (Item.Production) & ", " &
- Ada.Containers.Count_Type'Image (Item.Token_Count) & ")";
- end case;
- end Strict_Image;
-
- function Image (Item : in Minimal_Action; Descriptor : in
WisiToken.Descriptor) return String
- is begin
- case Item.Verb is
- when Shift =>
- return "Shift " & Image (Item.ID, Descriptor);
- when Reduce =>
- return "Reduce to " & Image (Item.Production.LHS, Descriptor);
- end case;
- end Image;
-
- function To_Vector (Item : in Minimal_Action_Array) return
Minimal_Action_Arrays.Vector
- is begin
- return Result : Minimal_Action_Arrays.Vector do
- Result.Set_First_Last (Item'First, Item'Last);
- for I in Item'Range loop
- Result.Replace_Element (I, Item (I));
- end loop;
- end return;
- end To_Vector;
-
- procedure Add_Action
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- Production : in Production_ID;
- State_Index : in WisiToken.State_Index)
- is begin
- Add (State.Action_List, Symbol, (Shift, Production, State_Index));
- end Add_Action;
-
- procedure Add_Action
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- Verb : in LR.Parse_Action_Verbs;
- Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in Semantic_Checks.Semantic_Check)
- is
- Action : constant Parse_Action_Rec :=
- (case Verb is
- when Reduce => (Reduce, Production, Semantic_Action,
Semantic_Check, RHS_Token_Count),
- when Accept_It => (Accept_It, Production, Semantic_Action,
Semantic_Check, RHS_Token_Count),
- when others => raise SAL.Programmer_Error);
- begin
- Add (State.Action_List, Symbol, Action);
- end Add_Action;
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbols : in Token_ID_Array;
- Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check)
- is begin
- -- We assume WisiToken.BNF.Output_Ada_Common.Duplicate_Reduce is True
- -- for this state; no conflicts, all the same action, Recursive.
- for Symbol of Symbols loop
- Add_Action
- (State, Symbol, Reduce, Production, RHS_Token_Count,
- Semantic_Action, Semantic_Check);
- end loop;
- end Add_Action;
-
- procedure Add_Conflict
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- Reduce_Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in Semantic_Checks.Semantic_Check)
- is
- Conflict : constant Parse_Action_Rec :=
- (Reduce, Reduce_Production, Semantic_Action, Semantic_Check,
RHS_Token_Count);
-
- Ref : constant Action_Arrays.Find_Reference_Constant_Type :=
State.Action_List.Find_Constant (Symbol);
-
- Node : Parse_Action_Node_Ptr := Ref.Actions;
- begin
- loop
- exit when Node.Next = null;
- Node := Node.Next;
- end loop;
- Node.Next := new Parse_Action_Node'(Conflict, null);
- end Add_Conflict;
-
- procedure Add_Goto
- (State : in out LR.Parse_State;
- Symbol : in Token_ID;
- To_State : in State_Index)
- is begin
- State.Goto_List.Insert ((Symbol, To_State));
- end Add_Goto;
-
- function Goto_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Unknown_State_Index
- is
- Ref : constant Goto_Arrays.Find_Reference_Constant_Type := Table.States
(State).Goto_List.Find_Constant (ID);
- begin
- if Ref.Element = null then
- -- We can only get here during error recovery.
- return Unknown_State;
- else
- return Ref.State;
- end if;
- end Goto_For;
-
- function Action_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Parse_Action_Node_Ptr
- is
- Ref : constant Action_Arrays.Find_Reference_Constant_Type :=
Table.States (State).Action_List.Find_Constant (ID);
- begin
- if Ref.Element = null then
- return Table.Error_Action;
- end if;
-
- return Ref.Actions;
- end Action_For;
-
- function Expecting (Table : in Parse_Table; State : in State_Index) return
Token_ID_Set
- is
- Result : Token_ID_Set := (Table.First_Terminal .. Table.Last_Terminal =>
False);
- begin
- for Action of Table.States (State).Action_List loop
- Result (Action.Symbol) := True;
- end loop;
- return Result;
- end Expecting;
-
- procedure Free_Table (Table : in out Parse_Table_Ptr)
- is
- procedure Free is new Ada.Unchecked_Deallocation (Parse_Table,
Parse_Table_Ptr);
- Parse_Action : Parse_Action_Node_Ptr;
- Temp_Parse_Action : Parse_Action_Node_Ptr;
- begin
- if Table = null then
- return;
- end if;
-
- for State of Table.States loop
- for Action of State.Action_List loop
- Parse_Action := Action.Actions;
- loop
- exit when Parse_Action = null;
- Temp_Parse_Action := Parse_Action;
- Parse_Action := Parse_Action.Next;
- Free (Temp_Parse_Action);
- end loop;
- end loop;
- end loop;
-
- Free (Table);
- end Free_Table;
-
- function Get_Text_Rep
- (File_Name : in String;
- McKenzie_Param : in McKenzie_Param_Type;
- Actions : in Semantic_Action_Array_Arrays.Vector)
- return Parse_Table_Ptr
- is
- use Ada.Text_IO;
-
- File : GNATCOLL.Mmap.Mapped_File;
- Region : GNATCOLL.Mmap.Mapped_Region;
- Buffer : GNATCOLL.Mmap.Str_Access;
- Buffer_Abs_Last : Integer; -- Buffer'Last, except Buffer has no bounds
- Buffer_Last : Integer := 0; -- Last char read from Buffer
-
- Delimiters : constant Ada.Strings.Maps.Character_Set :=
Ada.Strings.Maps.To_Set (" ;" & ASCII.LF);
-
- function Check_Semicolon return Boolean
- is begin
- if Buffer (Buffer_Last) = ';' then
- -- There is a space, newline, or newline and space after ';'.
Leave
- -- Buffer_Last on newline for Check_New_Line.
- Buffer_Last := Buffer_Last + 1;
- return True;
- else
- return False;
- end if;
- end Check_Semicolon;
-
- procedure Check_Semicolon
- is begin
- if Buffer (Buffer_Last) = ';' then
- -- There is a space, newline, or newline and space after ';'.
Leave
- -- Buffer_Last on newline for Check_New_Line.
- Buffer_Last := Buffer_Last + 1;
- else
- raise SAL.Programmer_Error with Error_Message
- (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
- "expecting semicolon, found '" & Buffer (Buffer_Last) & "'");
- end if;
- end Check_Semicolon;
-
- function Check_EOI return Boolean
- is begin
- return Buffer_Last >= Buffer_Abs_Last;
- end Check_EOI;
-
- procedure Check_New_Line
- is
- use Ada.Strings.Maps;
- begin
- if Buffer (Buffer_Last) = ASCII.LF then
- -- There is a space or semicolon after some newlines.
- if Is_In (Buffer (Buffer_Last + 1), Delimiters) then
- Buffer_Last := Buffer_Last + 1;
- end if;
- else
- raise SAL.Programmer_Error with Error_Message
- (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
- "expecting new_line, found '" & Buffer (Buffer_Last) & "'");
- end if;
- end Check_New_Line;
-
- type Buffer_Region is record
- First : Integer;
- Last : Integer;
- end record;
-
- function Next_Value return Buffer_Region;
- pragma Inline (Next_Value);
-
- function Next_Value return Buffer_Region
- is
- use Ada.Strings.Fixed;
- First : constant Integer := Buffer_Last + 1;
- begin
- Buffer_Last := Index (Buffer.all, Delimiters, First);
- return (First, Buffer_Last - 1);
- end Next_Value;
-
- procedure Raise_Gen_Next_Value_Constraint_Error (Name : String; Region :
Buffer_Region);
- pragma No_Return (Raise_Gen_Next_Value_Constraint_Error);
-
- procedure Raise_Gen_Next_Value_Constraint_Error (Name : String; Region :
Buffer_Region)
- is begin
- -- Factored out from Gen_Next_Value to make Inline efficient.
- raise SAL.Programmer_Error with Error_Message
- (File_Name, 1, Ada.Text_IO.Count (Region.First),
- "expecting " & Name & ", found '" & Buffer (Region.First ..
Region.Last) & "'");
- end Raise_Gen_Next_Value_Constraint_Error;
-
- generic
- type Value_Type is (<>);
- Name : in String;
- function Gen_Next_Value return Value_Type;
- pragma Inline (Gen_Next_Value);
-
- function Gen_Next_Value return Value_Type
- is
- Region : constant Buffer_Region := Next_Value;
- begin
- return Value_Type'Value (Buffer (Region.First .. Region.Last));
- exception
- when Constraint_Error =>
- Raise_Gen_Next_Value_Constraint_Error (Name, Region);
- end Gen_Next_Value;
-
- function Next_State_Index is new Gen_Next_Value (State_Index,
"State_Index");
- function Next_Token_ID is new Gen_Next_Value (Token_ID, "Token_ID");
- function Next_Integer is new Gen_Next_Value (Integer, "Integer");
- function Next_Parse_Action_Verbs is new Gen_Next_Value
(Parse_Action_Verbs, "Parse_Action_Verbs");
- function Next_Boolean is new Gen_Next_Value (Boolean, "Boolean");
- function Next_Count_Type is new Gen_Next_Value
(Ada.Containers.Count_Type, "Count_Type");
- begin
- File := GNATCOLL.Mmap.Open_Read (File_Name);
- Region := GNATCOLL.Mmap.Read (File);
- Buffer := GNATCOLL.Mmap.Data (Region);
- Buffer_Abs_Last := GNATCOLL.Mmap.Last (Region);
-
- declare
- use Ada.Containers;
-
- -- We don't read the discriminants in the aggregate, because
- -- aggregate evaluation order is not guaranteed.
- State_First : constant State_Index := Next_State_Index;
- State_Last : constant State_Index := Next_State_Index;
- First_Terminal : constant Token_ID := Next_Token_ID;
- Last_Terminal : constant Token_ID := Next_Token_ID;
- First_Nonterminal : constant Token_ID := Next_Token_ID;
- Last_Nonterminal : constant Token_ID := Next_Token_ID;
-
- Table : constant Parse_Table_Ptr := new Parse_Table
- (State_First, State_Last, First_Terminal, Last_Terminal,
First_Nonterminal, Last_Nonterminal);
- begin
- Check_New_Line;
-
- Table.McKenzie_Param := McKenzie_Param;
-
- for State of Table.States loop
- declare
- Actions_Done : Boolean := False;
- begin
- State.Action_List.Set_Capacity (Next_Count_Type);
-
- loop
- declare
- Node_I : Action_Node;
- Node_J : Parse_Action_Node_Ptr := new
Parse_Action_Node;
- Action_Done : Boolean := False;
- Verb : Parse_Action_Verbs;
- begin
- Node_I.Actions := Node_J;
- loop
- Verb := Next_Parse_Action_Verbs;
- Node_J.Item :=
- (case Verb is
- when Shift => (Verb => Shift, others => <>),
- when Reduce => (Verb => Reduce, others => <>),
- when Accept_It => (Verb => Accept_It, others => <>),
- when Error => (Verb => Error, others => <>));
-
- Node_J.Item.Production.LHS := Next_Token_ID;
- Node_J.Item.Production.RHS := Next_Integer;
-
- case Verb is
- when Shift =>
- Node_J.Item.State := Next_State_Index;
-
- when Reduce | Accept_It =>
- if Next_Boolean then
- Node_J.Item.Action := Actions
-
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS).Action;
- else
- Node_J.Item.Action := null;
- end if;
- if Next_Boolean then
- Node_J.Item.Check := Actions
-
(Node_J.Item.Production.LHS)(Node_J.Item.Production.RHS).Check;
- else
- Node_J.Item.Check := null;
- end if;
- Node_J.Item.Token_Count := Next_Count_Type;
-
- when Error =>
- raise SAL.Programmer_Error;
- end case;
-
- if Check_Semicolon then
- Action_Done := True;
-
- Node_I.Symbol := Next_Token_ID;
-
- if Check_Semicolon then
- Actions_Done := True;
- end if;
- end if;
-
- exit when Action_Done;
-
- Node_J.Next := new Parse_Action_Node;
- Node_J := Node_J.Next;
- end loop;
-
- Check_New_Line;
- State.Action_List.Insert (Node_I);
- end;
-
- exit when Actions_Done;
- end loop;
- end;
-
- if Check_Semicolon then
- -- No Gotos
- null;
- else
- State.Goto_List.Set_Capacity (Next_Count_Type);
- declare
- Node : Goto_Node;
- begin
- loop
- Node.Symbol := Next_Token_ID;
- Node.State := Next_State_Index;
- State.Goto_List.Insert (Node);
- exit when Check_Semicolon;
- end loop;
- end;
- end if;
- Check_New_Line;
-
- declare
- First : constant Count_Type := Next_Count_Type;
- Last : constant Integer := Next_Integer;
- begin
- if Last = -1 then
- -- State.Kernel not set for state 0
- null;
- else
- State.Kernel.Set_First_Last (First, Count_Type (Last));
-
- for I in State.Kernel.First_Index .. State.Kernel.Last_Index
loop
- State.Kernel (I).Production.LHS := Next_Token_ID;
- State.Kernel (I).Production.RHS := Next_Integer;
- State.Kernel (I).Before_Dot := Next_Token_ID;
- State.Kernel (I).Length_After_Dot := Next_Count_Type;
- State.Kernel (I).Reduce_Production.LHS := Next_Token_ID;
- State.Kernel (I).Reduce_Production.RHS := Next_Integer;
- State.Kernel (I).Reduce_Count := Next_Count_Type;
- end loop;
- end if;
- end;
- Check_New_Line;
-
- if Check_Semicolon then
- -- No minimal action
- null;
- else
- declare
- First : constant Count_Type := Next_Count_Type;
- Last : constant Count_Type := Next_Count_Type;
- begin
- State.Minimal_Complete_Actions.Set_First_Last (First, Last);
- end;
- for I in State.Minimal_Complete_Actions.First_Index ..
State.Minimal_Complete_Actions.Last_Index loop
- declare
- Verb : constant Minimal_Verbs :=
Next_Parse_Action_Verbs;
- LHS : Token_ID;
- RHS : Integer;
- ID : Token_ID;
- Action_State : State_Index;
- Count : Ada.Containers.Count_Type;
- begin
- LHS := Next_Token_ID;
- RHS := Next_Integer;
- case Verb is
- when Shift =>
- ID := Next_Token_ID;
- Action_State := Next_State_Index;
- State.Minimal_Complete_Actions.Replace_Element (I,
(Shift, (LHS, RHS), ID, Action_State));
- when Reduce =>
- Count := Next_Count_Type;
- State.Minimal_Complete_Actions.Replace_Element (I,
(Reduce, (LHS, RHS), Count));
- end case;
- end;
- end loop;
- Check_Semicolon;
- end if;
- Check_New_Line;
-
- exit when Check_EOI;
- end loop;
-
- Table.Error_Action := new Parse_Action_Node'((Verb => Error, others
=> <>), null);
-
- return Table;
- end;
- exception
- when Name_Error =>
- raise User_Error with "parser table text file '" & File_Name & "' not
found.";
-
- when SAL.Programmer_Error =>
- raise;
-
- when E : others =>
- raise SAL.Programmer_Error with Error_Message
- (File_Name, 1, Ada.Text_IO.Count (Buffer_Last),
- Ada.Exceptions.Exception_Name (E) & ": " &
Ada.Exceptions.Exception_Message (E));
- end Get_Text_Rep;
-
- function Compare (Left, Right : in Insert_Delete_Op) return
SAL.Compare_Result
- is
- Left_Token_Index : constant WisiToken.Token_Index :=
- (case Insert_Delete_Op_Label'(Left.Op) is
- when Insert => Left.Ins_Token_Index,
- when Delete => Left.Del_Token_Index);
- Right_Token_Index : constant WisiToken.Token_Index :=
- (case Insert_Delete_Op_Label'(Right.Op) is
- when Insert => Right.Ins_Token_Index,
- when Delete => Right.Del_Token_Index);
- begin
- if Left_Token_Index < Right_Token_Index then
- return SAL.Less;
- elsif Left_Token_Index = Right_Token_Index then
- return SAL.Equal;
- else
- return SAL.Greater;
- end if;
- end Compare;
-
- function Equal (Left : in Config_Op; Right : in Insert_Op) return Boolean
- is begin
- return Left.Op = Insert and then
- Left.Ins_ID = Right.Ins_ID and then
- Left.Ins_Token_Index = Right.Ins_Token_Index;
- end Equal;
-
- function None (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
- is
- use Config_Op_Arrays, Config_Op_Array_Refs;
- begin
- for I in First_Index (Ops) .. Last_Index (Ops) loop
- if Constant_Ref (Ops, I).Op = Op then
- return False;
- end if;
- end loop;
- return True;
- end None;
-
- function None_Since_FF (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
- is
- use Config_Op_Arrays, Config_Op_Array_Refs;
- begin
- for I in reverse First_Index (Ops) .. Last_Index (Ops) loop
- declare
- O : Config_Op renames Constant_Ref (Ops, I);
- begin
- exit when O.Op = Fast_Forward;
- if O.Op = Op then
- return False;
- end if;
- end;
- end loop;
- return True;
- end None_Since_FF;
-
- function Only_Since_FF (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
- is
- use Config_Op_Arrays, Config_Op_Array_Refs;
- use all type Ada.Containers.Count_Type;
- begin
- if Length (Ops) = 0 or else Constant_Ref (Ops, Last_Index (Ops)).Op /=
Op then
- return False;
- else
- for I in reverse First_Index (Ops) .. Last_Index (Ops) loop
- declare
- O : Config_Op renames Constant_Ref (Ops, I);
- begin
- exit when O.Op = Fast_Forward;
- if O.Op /= Op then
- return False;
- end if;
- end;
- end loop;
- return True;
- end if;
- end Only_Since_FF;
-
- function Any (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean
- is
- use Config_Op_Arrays, Config_Op_Array_Refs;
- begin
- for I in First_Index (Ops) .. Last_Index (Ops) loop
- declare
- O : Config_Op renames Constant_Ref (Ops, I);
- begin
- if O.Op = Op then
- return True;
- end if;
- end;
- end loop;
- return False;
- end Any;
-
- function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean
- is begin
- for I in 1 .. Depth loop
- if Stack.Peek (I).Tree_Index = Invalid_Node_Index then
- return False;
- end if;
- end loop;
- return True;
- end Valid_Tree_Indices;
-
- procedure Set_Key (Item : in out Configuration; Key : in Integer)
- is begin
- Item.Cost := Key;
- end Set_Key;
-
- procedure Accumulate (Data : in McKenzie_Data; Counts : in out
Strategy_Counts)
- is
- procedure Proc (Config : in Configuration)
- is begin
- for I in Config.Strategy_Counts'Range loop
- Counts (I) := Counts (I) + Config.Strategy_Counts (I);
- end loop;
- end Proc;
- begin
- Data.Results.Process (Proc'Unrestricted_Access);
- end Accumulate;
-
-end WisiToken.Parse.LR;
diff --git a/packages/wisi/wisitoken-parse-lr.ads
b/packages/wisi/wisitoken-parse-lr.ads
deleted file mode 100644
index da30920..0000000
--- a/packages/wisi/wisitoken-parse-lr.ads
+++ /dev/null
@@ -1,698 +0,0 @@
--- Abstract :
---
--- Root package of an implementation of an LR (Left-to-right scanning
--- Rightmost-deriving) parser. Includes operations for building the
--- parse table at runtime. See the child packages .Parse and
--- .Parse_No_Recover for running the parser.
---
--- References :
---
--- See wisitoken.ads
---
--- Copyright (C) 2002, 2003, 2009, 2010, 2013 - 2015, 2017 - 2020 Free
Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers.Indefinite_Doubly_Linked_Lists;
-with Ada.Unchecked_Deallocation;
-with SAL.Gen_Array_Image;
-with SAL.Gen_Bounded_Definite_Stacks.Gen_Image_Aux;
-with SAL.Gen_Bounded_Definite_Vectors.Gen_Image_Aux;
-with SAL.Gen_Bounded_Definite_Vectors.Gen_Refs;
-with SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci;
-with SAL.Gen_Unbounded_Definite_Vectors_Sorted;
-with System.Multiprocessors;
-with WisiToken.Semantic_Checks;
-with WisiToken.Syntax_Trees;
-package WisiToken.Parse.LR is
- use all type SAL.Base_Peek_Type;
-
- type All_Parse_Action_Verbs is (Pause, Shift, Reduce, Accept_It, Error);
- subtype Parse_Action_Verbs is All_Parse_Action_Verbs range Shift .. Error;
- subtype Minimal_Verbs is All_Parse_Action_Verbs range Shift .. Reduce;
- -- Pause is only used for error recovery, to allow parallel parsers
- -- to re-sync on the same input terminal.
-
- subtype Token_ID_Array_1_3 is Token_ID_Array (1 .. 3);
- -- For Language_Matching_Begin_Tokens.
-
- type Parse_Action_Rec (Verb : Parse_Action_Verbs := Shift) is
- record
- Production : Production_ID;
- -- The production that produced this action. Used to find kernel
- -- items during error recovery.
-
- case Verb is
- when Shift =>
- State : State_Index := State_Index'Last;
-
- when Reduce | Accept_It =>
- -- Production.LHS is the result nonterm
- Action : WisiToken.Syntax_Trees.Semantic_Action := null;
- Check : WisiToken.Semantic_Checks.Semantic_Check := null;
- Token_Count : Ada.Containers.Count_Type := 0;
-
- when Error =>
- null;
- end case;
- end record;
- subtype Shift_Action_Rec is Parse_Action_Rec (Shift);
- subtype Reduce_Action_Rec is Parse_Action_Rec (Reduce);
-
- function Image (Item : in Parse_Action_Rec; Descriptor : in
WisiToken.Descriptor) return String;
- -- Ada aggregate syntax, leaving out Action, Check in reduce; for debug
output
-
- procedure Put (Trace : in out WisiToken.Trace'Class; Item : in
Parse_Action_Rec);
- -- Put a line for Item in parse trace format, with no prefix.
-
- function Equal (Left, Right : in Parse_Action_Rec) return Boolean;
- -- Ignore items not used by the canonical shift-reduce algorithm.
-
- type Parse_Action_Node;
- type Parse_Action_Node_Ptr is access Parse_Action_Node;
-
- type Parse_Action_Node is record
- Item : Parse_Action_Rec;
- Next : Parse_Action_Node_Ptr; -- non-null only for conflicts
- end record;
- procedure Free is new Ada.Unchecked_Deallocation (Parse_Action_Node,
Parse_Action_Node_Ptr);
-
- function Is_In (Item : in Parse_Action_Rec; List : in
Parse_Action_Node_Ptr) return Boolean;
- -- True if Item is Equal to any element of List.
-
- type Action_Node is record
- Symbol : Token_ID := Invalid_Token_ID; -- ignored if Action is Error
- Actions : Parse_Action_Node_Ptr;
- end record;
-
- function To_Key (Item : in Action_Node) return Token_ID is (Item.Symbol);
-
- function Compare (Left, Right : in Token_ID) return SAL.Compare_Result;
-
- package Action_Arrays is new SAL.Gen_Unbounded_Definite_Vectors_Sorted
- (Action_Node, Token_ID, To_Key, Compare);
-
- procedure Add
- (List : in out Action_Arrays.Vector;
- Symbol : in Token_ID;
- Action : in Parse_Action_Rec);
- -- Add action to List, sorted on ascending Symbol.
-
- type Goto_Node is record
- Symbol : Token_ID;
- State : State_Index;
- end record;
-
- function To_Key (Item : in Goto_Node) return Token_ID is (Item.Symbol);
-
- package Goto_Arrays is new SAL.Gen_Unbounded_Definite_Vectors_Sorted
- (Goto_Node, Token_ID, To_Key, Compare);
-
- type Kernel_Info is record
- Production : Production_ID;
- Before_Dot : Token_ID := Token_ID'First;
- Length_After_Dot : Ada.Containers.Count_Type := 0;
-
- Reduce_Production : Production_ID;
- Reduce_Count : Ada.Containers.Count_Type := 0;
- -- The reduction that error recovery should do for this item if
- -- Length_After_Dot = 0. Reduce_Production /= Production when item
- -- after dot is nullable.
- --
- -- It is tempting to make Length_After_Dot a discriminant to
- -- eliminate Reduce_* when they are not needed, but we don't have a
- -- static value of Length_After_Dot when it is non-zero.
- end record;
-
- function Strict_Image (Item : in Kernel_Info) return String;
-
- type Kernel_Info_Array is array (Ada.Containers.Count_Type range <>) of
Kernel_Info;
- package Kernel_Info_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Ada.Containers.Count_Type, Kernel_Info, (others => <>));
-
- function To_Vector (Item : in Kernel_Info_Array) return
Kernel_Info_Arrays.Vector;
-
- function Image is new Kernel_Info_Arrays.Gen_Image (Strict_Image);
-
- type Minimal_Action (Verb : Minimal_Verbs := Shift) is
- record
- Production : Production_ID := Invalid_Production_ID;
-
- case Verb is
- when Shift =>
- ID : Token_ID := Invalid_Token_ID;
- State : State_Index := State_Index'Last;
-
- when Reduce =>
- Token_Count : Ada.Containers.Count_Type;
- end case;
- end record;
-
- function Strict_Image (Item : in Minimal_Action) return String;
- -- Strict Ada aggregate syntax, for generated code.
-
- function Image (Item : in Minimal_Action; Descriptor : in
WisiToken.Descriptor) return String;
- -- For debugging
-
- type Minimal_Action_Array is array (Ada.Containers.Count_Type range <>) of
Minimal_Action;
- package Minimal_Action_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Ada.Containers.Count_Type, Minimal_Action, (others => <>));
-
- function To_Vector (Item : in Minimal_Action_Array) return
Minimal_Action_Arrays.Vector;
-
- function Image is new Minimal_Action_Arrays.Gen_Image_Aux (Descriptor,
Trimmed_Image, Image);
- function Strict_Image is new Minimal_Action_Arrays.Gen_Image (Strict_Image);
-
- type Parse_State is record
- Action_List : Action_Arrays.Vector;
- Goto_List : Goto_Arrays.Vector;
-
- -- The following are used in error recovery.
- Kernel : Kernel_Info_Arrays.Vector;
- Minimal_Complete_Actions : Minimal_Action_Arrays.Vector;
- -- Parse actions that will most quickly complete a production in this
- -- state. Kernel is used to reduce the number of actions.
- end record;
-
- type Parse_State_Array is array (State_Index range <>) of Parse_State;
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbol : in Token_ID;
- Production : in Production_ID;
- State_Index : in WisiToken.State_Index);
- -- Add a Shift action to tail of State action list.
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbol : in Token_ID;
- Verb : in Parse_Action_Verbs;
- Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
- -- Add a Reduce or Accept_It action to tail of State action list.
-
- procedure Add_Action
- (State : in out Parse_State;
- Symbols : in Token_ID_Array;
- Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
- -- Add duplicate Reduce actions, and final Error action, to tail of
- -- State action list.
-
- procedure Add_Conflict
- (State : in out Parse_State;
- Symbol : in Token_ID;
- Reduce_Production : in Production_ID;
- RHS_Token_Count : in Ada.Containers.Count_Type;
- Semantic_Action : in WisiToken.Syntax_Trees.Semantic_Action;
- Semantic_Check : in WisiToken.Semantic_Checks.Semantic_Check);
- -- Add a Reduce conflict to State.
-
- procedure Add_Goto
- (State : in out Parse_State;
- Symbol : in Token_ID;
- To_State : in State_Index);
- -- Add a goto item to State goto list; keep goto list sorted in ascending
order on Symbol.
-
- type McKenzie_Param_Type
- (First_Terminal : Token_ID;
- Last_Terminal : Token_ID;
- First_Nonterminal : Token_ID;
- Last_Nonterminal : Token_ID)
- is record
- Insert : Token_ID_Array_Natural (First_Terminal .. Last_Terminal);
- Delete : Token_ID_Array_Natural (First_Terminal .. Last_Terminal);
- Push_Back : Token_ID_Array_Natural (First_Terminal ..
Last_Nonterminal);
- Undo_Reduce : Token_ID_Array_Natural (First_Nonterminal ..
Last_Nonterminal);
- -- Cost of operations on config stack, input.
-
- Minimal_Complete_Cost_Delta : Integer;
- -- Reduction in cost due to using Minimal_Complete_Action.
-
- Matching_Begin : Integer;
- -- Cost of Matching_Begin strategy (applied once, independent of
- -- token count).
-
- Fast_Forward : Integer;
- -- Cost of moving the edit point forward over input tokens.
-
- Ignore_Check_Fail : Natural;
- -- Cost of ignoring a semantic check failure. Should be at least the
- -- cost of a typical fix for such a failure.
-
- Task_Count : System.Multiprocessors.CPU_Range;
- -- Number of parallel tasks during recovery. If 0, use
- -- System.Multiprocessors.Number_Of_CPUs - 1.
-
- Check_Limit : Token_Index; -- max tokens to parse ahead when
checking a configuration.
- Check_Delta_Limit : Natural; -- max configs checked, delta over
successful parser.
- Enqueue_Limit : Natural; -- max configs enqueued.
- end record;
-
- Default_McKenzie_Param : constant McKenzie_Param_Type :=
- (First_Terminal => Token_ID'Last,
- Last_Terminal => Token_ID'First,
- First_Nonterminal => Token_ID'Last,
- Last_Nonterminal => Token_ID'First,
- Insert => (others => 0),
- Delete => (others => 0),
- Push_Back => (others => 0),
- Undo_Reduce => (others => 0),
- Minimal_Complete_Cost_Delta => -1,
- Fast_Forward => 0,
- Matching_Begin => 0,
- Ignore_Check_Fail => 0,
- Task_Count => System.Multiprocessors.CPU_Range'Last,
- Check_Limit => 4,
- Check_Delta_Limit => Natural'Last,
- Enqueue_Limit => Natural'Last);
-
- type Parse_Table
- (State_First : State_Index;
- State_Last : State_Index;
- First_Terminal : Token_ID;
- Last_Terminal : Token_ID;
- First_Nonterminal : Token_ID;
- Last_Nonterminal : Token_ID)
- is tagged
- record
- States : Parse_State_Array (State_First .. State_Last);
- Error_Action : Parse_Action_Node_Ptr;
- McKenzie_Param : McKenzie_Param_Type (First_Terminal, Last_Terminal,
First_Nonterminal, Last_Nonterminal);
- end record;
-
- function Goto_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Unknown_State_Index;
- -- Return next state after reducing stack by nonterminal ID;
- -- Unknown_State if none (only possible during error recovery).
- -- Second form allows retrieving Production.
-
- function Action_For
- (Table : in Parse_Table;
- State : in State_Index;
- ID : in Token_ID)
- return Parse_Action_Node_Ptr
- with Post => Action_For'Result /= null;
- -- Return the action for State, terminal ID.
-
- function Expecting (Table : in Parse_Table; State : in State_Index) return
Token_ID_Set;
-
- function McKenzie_Defaulted (Table : in Parse_Table) return Boolean is
- -- We can't use Table.McKenzie_Param = Default_McKenzie_Param here,
- -- because the discriminants are different.
- (Table.McKenzie_Param.Check_Limit = Default_McKenzie_Param.Check_Limit and
- Table.McKenzie_Param.Check_Delta_Limit =
Default_McKenzie_Param.Check_Delta_Limit and
- Table.McKenzie_Param.Enqueue_Limit =
Default_McKenzie_Param.Enqueue_Limit);
-
- type Parse_Table_Ptr is access Parse_Table;
- procedure Free_Table (Table : in out Parse_Table_Ptr);
-
- type Semantic_Action is record
- Action : WisiToken.Syntax_Trees.Semantic_Action := null;
- Check : WisiToken.Semantic_Checks.Semantic_Check := null;
- end record;
-
- package Semantic_Action_Arrays is new SAL.Gen_Unbounded_Definite_vectors
(Natural, Semantic_Action, (others => <>));
- package Semantic_Action_Array_Arrays is new
SAL.Gen_Unbounded_Definite_Vectors
- (Token_ID, Semantic_Action_Arrays.Vector,
Semantic_Action_Arrays.Empty_Vector);
-
- function Get_Text_Rep
- (File_Name : in String;
- McKenzie_Param : in McKenzie_Param_Type;
- Actions : in Semantic_Action_Array_Arrays.Vector)
- return Parse_Table_Ptr;
- -- Read machine-readable text format of states (as output by
- -- WisiToken.Generate.LR.Put_Text_Rep) from file File_Name. Result
- -- has actions, checks from Productions.
-
- ----------
- -- For McKenzie_Recover. Declared here because Parser_Lists needs
- -- these, Mckenzie_Recover needs Parser_Lists.
- --
- -- We don't maintain a syntax tree during recover; it's too slow, and
- -- not needed for any operations. The parser syntax tree is used for
- -- Undo_Reduce, which is only done on nonterms reduced by the main
- -- parser, not virtual nonterms produced by recover.
-
- package Fast_Token_ID_Arrays is new SAL.Gen_Bounded_Definite_Vectors
- (SAL.Peek_Type, Token_ID, Capacity => 20);
-
- No_Insert_Delete : constant SAL.Base_Peek_Type := 0;
-
- function Image
- (Index : in SAL.Peek_Type;
- Tokens : in Fast_Token_ID_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return String
- is (SAL.Peek_Type'Image (Index) & ":" & SAL.Peek_Type'Image
(Fast_Token_ID_Arrays.Last_Index (Tokens)) & ":" &
- Image (Fast_Token_ID_Arrays.Element (Tokens, Index), Descriptor));
-
- type Config_Op_Label is (Fast_Forward, Undo_Reduce, Push_Back, Insert,
Delete);
- subtype Insert_Delete_Op_Label is Config_Op_Label range Insert .. Delete;
- -- Fast_Forward is a placeholder to mark a fast_forward parse; that
- -- resets what operations are allowed to be done on a config.
- --
- -- Undo_Reduce is the inverse of Reduce.
- --
- -- Push_Back pops the top stack item, and moves the input stream
- -- pointer back to the first shared_terminal contained by that item.
- --
- -- Insert inserts a new token in the token input stream, before the
- -- given point in Terminals.
- --
- -- Delete deletes one item from the token input stream, at the given
- -- point.
-
- type Config_Op (Op : Config_Op_Label := Fast_Forward) is record
- -- We store enough information to perform the operation on the main
- -- parser stack and input stream when the config is the result
- -- of a successful recover.
-
- case Op is
- when Fast_Forward =>
- FF_Token_Index : WisiToken.Token_Index;
- -- Config.Current_Shared_Token after the operation is done; the last
- -- token shifted.
-
- when Undo_Reduce =>
- Nonterm : Token_ID;
- -- The nonterminal popped off the stack.
-
- Token_Count : Ada.Containers.Count_Type;
- -- The number of tokens pushed on the stack.
-
- when Push_Back =>
- PB_ID : Token_ID;
- -- The nonterm ID popped off the stack.
-
- PB_Token_Index : WisiToken.Base_Token_Index;
- -- Config.Current_Shared_Token after
- -- the operation is done. If the token is empty, Token_Index is
- -- Invalid_Token_Index.
-
- when Insert =>
- Ins_ID : Token_ID;
- -- The token ID inserted.
-
- Ins_Token_Index : WisiToken.Base_Token_Index;
- -- Ins_ID is inserted before Token_Index.
-
- when Delete =>
- Del_ID : Token_ID;
- -- The token ID deleted.
-
- Del_Token_Index : WisiToken.Base_Token_Index;
- -- Token at Token_Index is deleted.
-
- end case;
- end record;
- subtype Insert_Delete_Op is Config_Op with Dynamic_Predicate =>
(Insert_Delete_Op.Op in Insert_Delete_Op_Label);
- subtype Insert_Op is Config_Op with Dynamic_Predicate => (Insert_Op.Op =
Insert);
-
- function Token_Index (Op : in Insert_Delete_Op) return WisiToken.Token_Index
- is (case Insert_Delete_Op_Label'(Op.Op) is
- when Insert => Op.Ins_Token_Index,
- when Delete => Op.Del_Token_Index);
-
- function ID (Op : in Insert_Delete_Op) return WisiToken.Token_ID
- is (case Insert_Delete_Op_Label'(Op.Op) is
- when Insert => Op.Ins_ID,
- when Delete => Op.Del_ID);
-
- function Compare (Left, Right : in Insert_Delete_Op) return
SAL.Compare_Result;
- -- Compare token_index.
-
- function Equal (Left : in Config_Op; Right : in Insert_Op) return Boolean;
- -- Ignore state, stack_depth
-
- package Config_Op_Arrays is new SAL.Gen_Bounded_Definite_Vectors
- (Positive_Index_Type, Config_Op, Capacity => 80);
- -- Using a fixed size vector significantly speeds up
- -- McKenzie_Recover. The capacity is determined by the maximum number
- -- of repair operations, which is limited by the cost_limit McKenzie
- -- parameter plus an arbitrary number from the language-specific
- -- repairs; in practice, a capacity of 80 is enough so far. If a
- -- config does hit that limit, it is abandoned; some other config is
- -- likely to be cheaper.
-
- package Config_Op_Array_Refs is new Config_Op_Arrays.Gen_Refs;
-
- function Config_Op_Image (Item : in Config_Op; Descriptor : in
WisiToken.Descriptor) return String
- is ("(" & Config_Op_Label'Image (Item.Op) & ", " &
- (case Item.Op is
- when Fast_Forward => WisiToken.Token_Index'Image
(Item.FF_Token_Index),
- when Undo_Reduce => Image (Item.Nonterm, Descriptor) & "," &
- Ada.Containers.Count_Type'Image (Item.Token_Count),
- when Push_Back => Image (Item.PB_ID, Descriptor) & "," &
- WisiToken.Token_Index'Image (Item.PB_Token_Index),
- when Insert => Image (Item.Ins_ID, Descriptor) & "," &
- WisiToken.Token_Index'Image (Item.Ins_Token_Index),
- when Delete => Image (Item.Del_ID, Descriptor) & "," &
- WisiToken.Token_Index'Image (Item.Del_Token_Index))
- & ")");
-
- function Image (Item : in Config_Op; Descriptor : in WisiToken.Descriptor)
return String
- renames Config_Op_Image;
-
- function Config_Op_Array_Image is new Config_Op_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
- function Image (Item : in Config_Op_Arrays.Vector; Descriptor : in
WisiToken.Descriptor) return String
- renames Config_Op_Array_Image;
-
- function None (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
- -- True if Ops contains no Op.
-
- function None_Since_FF (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
- -- True if Ops contains no Op after the last Fast_Forward (or ops.first, if
- -- no Fast_Forward).
-
- function Only_Since_FF (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
- -- True if Ops contains only Op (at least one) after the last Fast_Forward
(or ops.first, if
- -- no Fast_Forward).
-
- function Any (Ops : aliased in Config_Op_Arrays.Vector; Op : in
Config_Op_Label) return Boolean;
- -- True if Ops contains at least one Op.
-
- type Recover_Op (Op : Insert_Delete_Op_Label := Insert) is record
- -- Add Ins_Tree_Node to Config_Op info, set when item is
- -- parsed; used to create user augmented token.
-
- case Op is
- when Insert =>
- Ins_ID : Token_ID := Invalid_Token_ID;
- -- The token ID inserted.
-
- Ins_Token_Index : Base_Token_Index := Invalid_Token_Index;
- -- Ins_ID is inserted before Token_Index.
-
- Ins_Tree_Node : Node_Index := Invalid_Node_Index;
-
- when Delete =>
- Del_ID : Token_ID;
- -- The token ID deleted.
-
- Del_Token_Index : Base_Token_Index;
- -- Token at Token_Index is deleted.
-
- end case;
- end record;
-
- package Recover_Op_Arrays is new SAL.Gen_Bounded_Definite_Vectors
- (Positive_Index_Type, Recover_Op, Capacity => 80);
-
- package Recover_Op_Array_Refs is new Recover_Op_Arrays.Gen_Refs;
-
- function Image (Item : in Recover_Op; Descriptor : in WisiToken.Descriptor)
return String
- is ("(" & Item.Op'Image & ", " &
- (case Item.Op is
- when Insert => Image (Item.Ins_ID, Descriptor) & "," &
- Item.Ins_Token_Index'Image & "," &
- Item.Ins_Tree_Node'Image,
- when Delete => Image (Item.Del_ID, Descriptor) & "," &
- Item.Del_Token_Index'Image)
- & ")");
-
- function Image is new Recover_Op_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Image);
-
- type Recover_Stack_Item is record
- State : Unknown_State_Index := Unknown_State;
-
- Tree_Index : Node_Index := Invalid_Node_Index;
- -- Valid if copied at recover initialize, Invalid if pushed during
- -- recover.
-
- Token : Recover_Token;
- -- Virtual is False if token is from input text; True if inserted
- -- during recover.
- end record;
-
- package Recover_Stacks is new SAL.Gen_Bounded_Definite_Stacks
(Recover_Stack_Item);
-
- function Image (Item : in Recover_Stack_Item; Descriptor : in
WisiToken.Descriptor) return String
- is ((if Item.State = Unknown_State then " " else Trimmed_Image
(Item.State)) & " : " &
- Image (Item.Token, Descriptor));
-
- function Recover_Stack_Image is new Recover_Stacks.Gen_Image_Aux
(WisiToken.Descriptor, Image);
- -- Unique name for calling from debugger
-
- function Image
- (Stack : in Recover_Stacks.Stack;
- Descriptor : in WisiToken.Descriptor;
- Depth : in SAL.Base_Peek_Type := 0)
- return String
- renames Recover_Stack_Image;
-
- function Valid_Tree_Indices (Stack : in Recover_Stacks.Stack; Depth : in
SAL.Base_Peek_Type) return Boolean with
- Pre => Stack.Depth >= Depth;
- -- Return True if Stack top Depth items have valid Tree_Indices,
- -- which is true if they were copied from the parser stack, and not
- -- pushed by recover.
-
- type Strategies is
- (Ignore_Error, Language_Fix, Minimal_Complete, Matching_Begin,
- Push_Back, Undo_Reduce, Insert, Delete, String_Quote);
-
- type Strategy_Counts is array (Strategies) of Natural;
- function Image is new SAL.Gen_Array_Image (Strategies, Natural,
Strategy_Counts, Trimmed_Image);
-
- type Minimal_Complete_State is (None, Active, Done);
-
- type Configuration is record
- Stack : Recover_Stacks.Stack (70);
- -- Initially built from the parser stack, then the stack after the
- -- Ops below have been performed.
- --
- -- Required size is determined by source code structure nesting;
- -- larger size slows down recover due to memory cache thrashing and
- -- allocation.
- --
- -- Emacs Ada mode wisi.adb needs > 50
-
- Resume_Token_Goal : WisiToken.Token_Index := WisiToken.Token_Index'Last;
- -- A successful solution shifts this token. Per-config because it
- -- increases with Delete; we increase Shared_Parser.Resume_Token_Goal
- -- only from successful configs.
-
- Current_Shared_Token : Base_Token_Index := WisiToken.Token_Index'Last;
- -- Index into Shared_Parser.Terminals for current input token, after
- -- all of Inserted is input. Initially the error token.
-
- String_Quote_Checked : Line_Number_Type := Invalid_Line_Number;
- -- Max line checked for missing string quote.
-
- Insert_Delete : aliased Config_Op_Arrays.Vector;
- -- Edits to the input stream that are not yet parsed; contains only
- -- Insert and Delete ops, in token_index order.
-
- Current_Insert_Delete : SAL.Base_Peek_Type := No_Insert_Delete;
- -- Index of the next op in Insert_Delete. If No_Insert_Delete, use
- -- Current_Shared_Token.
-
- Error_Token : Recover_Token;
- Check_Token_Count : Ada.Containers.Count_Type;
- Check_Status : Semantic_Checks.Check_Status;
- -- If parsing this config ended with a parse error, Error_Token is
- -- the token that failed to shift, Check_Status.Label is Ok.
- --
- -- If parsing this config ended with a semantic check fail,
- -- Error_Token is the nonterm created by the reduction,
- -- Check_Token_Count the number of tokens in the right hand side, and
- -- Check_Status is the error.
- --
- -- Error_Token is set to Invalid_Token_ID when Config is parsed
- -- successfully, or modified so the error is no longer meaningful (ie
- -- in explore when adding an op, or in language_fixes when adding a
- -- fix).
-
- Ops : aliased Config_Op_Arrays.Vector;
- -- Record of operations applied to this Config, in application order.
- -- Insert and Delete ops that are not yet parsed are reflected in
- -- Insert_Delete, in token_index order.
-
- Cost : Natural := 0;
-
- Strategy_Counts : LR.Strategy_Counts := (others => 0);
- -- Count of strategies that produced Ops.
-
- Minimal_Complete_State : LR.Minimal_Complete_State := None;
- Matching_Begin_Done : Boolean := False;
- end record;
-
- function Key (A : in Configuration) return Integer is (A.Cost);
-
- procedure Set_Key (Item : in out Configuration; Key : in Integer);
-
- package Config_Heaps is new SAL.Gen_Unbounded_Definite_Min_Heaps_Fibonacci
- (Element_Type => Configuration,
- Key_Type => Integer,
- Key => Key,
- Set_Key => Set_Key);
-
- type Check_Status is (Success, Abandon, Continue);
- subtype Non_Success_Status is Check_Status range Abandon .. Continue;
-
- type McKenzie_Data is tagged record
- Config_Heap : Config_Heaps.Heap_Type;
- Enqueue_Count : Integer := 0;
- Config_Full_Count : Integer := 0;
- Check_Count : Integer := 0;
- Results : Config_Heaps.Heap_Type;
- Success : Boolean := False;
- end record;
- type McKenzie_Access is access all McKenzie_Data;
-
- procedure Accumulate (Data : in McKenzie_Data; Counts : in out
Strategy_Counts);
- -- Sum Results.Strategy_Counts.
-
- type Parse_Error_Label is (Action, Check, Message);
-
- type Parse_Error
- (Label : Parse_Error_Label;
- First_Terminal : Token_ID;
- Last_Terminal : Token_ID)
- is record
- Recover : Configuration;
-
- case Label is
- when Action =>
- Error_Token : Valid_Node_Index; -- index into Parser.Tree
- Expecting : Token_ID_Set (First_Terminal .. Last_Terminal);
-
- when Check =>
- Check_Status : Semantic_Checks.Check_Status;
-
- when Message =>
- Msg : Ada.Strings.Unbounded.Unbounded_String;
- end case;
- end record;
-
- package Parse_Error_Lists is new
Ada.Containers.Indefinite_Doubly_Linked_Lists (Parse_Error);
-
-end WisiToken.Parse.LR;
diff --git a/packages/wisi/wisitoken-parse-packrat-generated.adb
b/packages/wisi/wisitoken-parse-packrat-generated.adb
deleted file mode 100644
index 7d73f34..0000000
--- a/packages/wisi/wisitoken-parse-packrat-generated.adb
+++ /dev/null
@@ -1,96 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Parse.Packrat.Generated is
-
- overriding procedure Parse (Parser : aliased in out Generated.Parser)
- is
- -- 'aliased' required for Base_Tree'Access. WORKAROUND: that was
- -- enough when Parser type was declared in generated Main; now that
- -- it's a derived type, it doesn't work. So we use Unchecked_Access.
-
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- Junk : WisiToken.Valid_Node_Index;
- pragma Unreferenced (Junk);
-
- Result : Memo_Entry;
- begin
- Parser.Base_Tree.Clear;
- Parser.Tree.Initialize (Parser.Base_Tree'Unchecked_Access, Flush =>
True);
- Parser.Lex_All;
- Parser.Derivs.Set_First_Last (Descriptor.First_Nonterminal,
Descriptor.Last_Nonterminal);
-
- for Nonterm in Descriptor.First_Nonterminal ..
Parser.Trace.Descriptor.Last_Nonterminal loop
- Parser.Derivs (Nonterm).Clear;
- Parser.Derivs (Nonterm).Set_First_Last (Parser.Terminals.First_Index,
Parser.Terminals.Last_Index);
- end loop;
-
- for Token_Index in Parser.Terminals.First_Index ..
Parser.Terminals.Last_Index loop
- Junk := Parser.Tree.Add_Terminal (Token_Index, Parser.Terminals);
- -- FIXME: move this into Lex_All, delete Terminals, just use
Syntax_Tree
- end loop;
-
- Result := Parser.Parse_WisiToken_Accept (Parser,
Parser.Terminals.First_Index - 1);
-
- if Result.State /= Success then
- if Trace_Parse > Outline then
- Parser.Trace.Put_Line ("parse failed");
- end if;
-
- raise Syntax_Error with "parse failed"; -- FIXME: need better error
message!
- else
- Parser.Tree.Set_Root (Result.Result);
- end if;
-
- end Parse;
-
- overriding function Tree (Parser : in Generated.Parser) return
Syntax_Trees.Tree
- is begin
- return Parser.Tree;
- end Tree;
-
- overriding function Tree_Var_Ref
- (Parser : aliased in out Generated.Parser)
- return Syntax_Trees.Tree_Variable_Reference
- is begin
- return (Element => Parser.Tree'Access);
- end Tree_Var_Ref;
-
- overriding function Any_Errors (Parser : in Generated.Parser) return Boolean
- is
- use all type Ada.Containers.Count_Type;
- begin
- return Parser.Lexer.Errors.Length > 0;
- end Any_Errors;
-
- overriding procedure Put_Errors (Parser : in Generated.Parser)
- is
- use Ada.Text_IO;
- begin
- for Item of Parser.Lexer.Errors loop
- Put_Line
- (Current_Error,
- Parser.Lexer.File_Name & ":0:0: lexer unrecognized character at" &
Buffer_Pos'Image (Item.Char_Pos));
- end loop;
-
- -- FIXME: Packrat parser does not report errors yet.
- end Put_Errors;
-
-end WisiToken.Parse.Packrat.Generated;
diff --git a/packages/wisi/wisitoken-parse-packrat-generated.ads
b/packages/wisi/wisitoken-parse-packrat-generated.ads
deleted file mode 100644
index 4932465..0000000
--- a/packages/wisi/wisitoken-parse-packrat-generated.ads
+++ /dev/null
@@ -1,76 +0,0 @@
--- Abstract :
---
--- Types and operations for a packrat parser runtime, with nonterm
--- parsing subprograms generated by wisi-generate.
---
--- References:
---
--- see parent.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-with WisiToken.Syntax_Trees;
-package WisiToken.Parse.Packrat.Generated is
-
- Recursive : exception; -- FIXME: delete
-
- type Memo_State is (No_Result, Failure, Success);
- subtype Result_States is Memo_State range Failure .. Success;
-
- type Memo_Entry (State : Memo_State := No_Result) is record
-
- case State is
- when No_Result =>
- Recursive : Boolean := False; -- FIXME: delete
-
- when Failure =>
- null;
-
- when Success =>
- Result : aliased Valid_Node_Index;
-
- Last_Token : Base_Token_Index; -- FIXME: change to Last_Pos
-
- end case;
- end record;
-
- package Memos is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_Index, Memo_Entry, Default_Element => (others => <>));
-
- subtype Result_Type is Memo_Entry
- with Dynamic_Predicate => Result_Type.State in Result_States;
-
- package Derivs is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_ID, Memos.Vector, Default_Element => Memos.Empty_Vector);
-
- type Parse_WisiToken_Accept is access
- -- WORKAROUND: using Packrat.Parser'Class here hits a GNAT Bug box in
GPL 2018.
- function (Parser : in out Base_Parser'Class; Last_Pos : in
Base_Token_Index) return Result_Type;
-
- type Parser is new Packrat.Parser with record
- Derivs : Generated.Derivs.Vector; -- FIXME: use discriminated array, as
in procedural
-
- Parse_WisiToken_Accept : Generated.Parse_WisiToken_Accept;
- end record;
-
- overriding procedure Parse (Parser : aliased in out Generated.Parser);
- overriding function Tree (Parser : in Generated.Parser) return
Syntax_Trees.Tree;
- overriding function Tree_Var_Ref
- (Parser : aliased in out Generated.Parser)
- return Syntax_Trees.Tree_Variable_Reference;
- overriding function Any_Errors (Parser : in Generated.Parser) return
Boolean;
- overriding procedure Put_Errors (Parser : in Generated.Parser);
-
-end WisiToken.Parse.Packrat.Generated;
diff --git a/packages/wisi/wisitoken-parse-packrat-procedural.adb
b/packages/wisi/wisitoken-parse-packrat-procedural.adb
deleted file mode 100644
index 887794e..0000000
--- a/packages/wisi/wisitoken-parse-packrat-procedural.adb
+++ /dev/null
@@ -1,267 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Parse.Packrat.Procedural is
-
- function Apply_Rule
- (Parser : in out Procedural.Parser;
- R : in Token_ID;
- Last_Pos : in Base_Token_Index)
- return Memo_Entry
- with Post => Apply_Rule'Result.State in Failure .. Success;
-
- function Eval
- (Parser : in out Procedural.Parser;
- R : in Token_ID;
- Last_Pos : in Base_Token_Index)
- return Memo_Entry
- with Post => Eval'Result.State in Failure .. Success;
-
- ----------
- -- bodies
-
- function Eval
- (Parser : in out Procedural.Parser;
- R : in Token_ID;
- Last_Pos : in Base_Token_Index)
- return Memo_Entry
- is
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- subtype Terminal is Token_ID range Descriptor.First_Terminal ..
Descriptor.Last_Terminal;
-
- Pos : Base_Token_Index := Last_Pos; -- last token parsed.
- begin
- for RHS_Index in Parser.Grammar (R).RHSs.First_Index .. Parser.Grammar
(R).RHSs.Last_Index loop
- declare
- use all type Ada.Containers.Count_Type;
- RHS : WisiToken.Productions.Right_Hand_Side renames
Parser.Grammar (R).RHSs (RHS_Index);
- Memo : Memo_Entry; -- for temporary or intermediate results
- begin
- if RHS.Tokens.Length = 0 then
- return
- (State => Success,
- Result => Parser.Tree.Add_Nonterm
- (Production => (R, RHS_Index),
- Action => RHS.Action,
- Children => (1 .. 0 => Invalid_Node_Index),
- Default_Virtual => False),
- Last_Pos => Pos);
- else
- declare
- Children : Valid_Node_Index_Array
- (SAL.Base_Peek_Type (RHS.Tokens.First_Index) ..
SAL.Base_Peek_Type (RHS.Tokens.Last_Index));
- begin
- for I in RHS.Tokens.First_Index .. RHS.Tokens.Last_Index loop
- if RHS.Tokens (I) in Terminal then
- if Pos = Parser.Terminals.Last_Index then
- goto Fail_RHS;
-
- elsif Parser.Terminals (Pos + 1).ID = RHS.Tokens (I)
then
- Pos := Pos + 1;
- Children (SAL.Base_Peek_Type (I)) := Tree_Index
(Pos);
- else
- goto Fail_RHS;
- end if;
- else
- Memo := Apply_Rule (Parser, RHS.Tokens (I), Pos);
- case Memo.State is
- when Success =>
- Children (SAL.Base_Peek_Type (I)) := Memo.Result;
- Pos := Memo.Last_Pos;
-
- when Failure =>
- goto Fail_RHS;
- when No_Result =>
- raise SAL.Programmer_Error;
- end case;
- end if;
- end loop;
-
- return
- (State => Success,
- Result => Parser.Tree.Add_Nonterm
- (Production => (R, RHS_Index),
- Action => RHS.Action,
- Children => Children,
- Default_Virtual => False),
- Last_Pos => Pos);
-
- <<Fail_RHS>>
- Pos := Last_Pos;
- end;
- end if;
- end;
- end loop;
- -- get here when all RHSs fail
-
- return (State => Failure);
- end Eval;
-
- function Apply_Rule
- (Parser : in out Procedural.Parser;
- R : in Token_ID;
- Last_Pos : in Base_Token_Index)
- return Memo_Entry
- is
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- Pos : Base_Token_Index := Last_Pos; -- last token parsed.
- Start_Pos : constant Token_Index := Last_Pos + 1; -- first token in
current nonterm
- Memo : Memo_Entry := Parser.Derivs (R)(Start_Pos);
-
- Pos_Recurse_Last : Base_Token_Index := Last_Pos;
- Result_Recurse : Memo_Entry;
- begin
- case Memo.State is
- when Success =>
- return Memo;
-
- when Failure =>
- return (State => Failure);
-
- when No_Result =>
- if Parser.Direct_Left_Recursive (R) then
- Parser.Derivs (R).Replace_Element (Start_Pos, (State => Failure));
- else
- Memo := Eval (Parser, R, Last_Pos);
- if (Trace_Parse > Detail and 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;
- end if;
- end case;
-
- loop
- Pos := Last_Pos;
-
- if Pos > Parser.Terminals.Last_Index then -- FIXME: this can't pass
here; Last_Pos never > last_index
- -- There might be an empty nonterm after the last token
- return (State => Failure);
- end if;
-
- Result_Recurse := Eval (Parser, R, Pos);
-
- if Result_Recurse.State = Success then
- if Result_Recurse.Last_Pos > Pos_Recurse_Last then
- Parser.Derivs (R).Replace_Element (Start_Pos, Result_Recurse);
- Pos := Result_Recurse.Last_Pos;
- Pos_Recurse_Last := Pos;
-
- if WisiToken.Trace_Parse > Detail then
- Parser.Trace.Put_Line
- (Parser.Tree.Image (Result_Recurse.Result, Descriptor,
Include_Children => True));
- end if;
- -- continue looping
-
- elsif Result_Recurse.Last_Pos = Pos_Recurse_Last then
- if Parser.Tree.Buffer_Region_Is_Empty (Result_Recurse.Result)
then
- Parser.Derivs (R).Replace_Element (Start_Pos,
Result_Recurse);
- end if;
- exit;
- else
- -- Result_Recurse.Last_Pos < Pos_Recurse_Last
- exit;
- end if;
- else
- exit;
- end if;
- end loop;
- return Parser.Derivs (R)(Start_Pos);
- end Apply_Rule;
-
- ----------
- -- Public subprograms
-
- function Create
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Direct_Left_Recursive : in Token_ID_Set;
- Start_ID : in Token_ID;
- Trace : access WisiToken.Trace'Class;
- Lexer : WisiToken.Lexer.Handle;
- User_Data : WisiToken.Syntax_Trees.User_Data_Access)
- return Procedural.Parser
- is begin
- return Parser : Procedural.Parser (Grammar.First_Index,
Grammar.Last_Index) do
- Parser.Trace := Trace;
- Parser.Lexer := Lexer;
- Parser.User_Data := User_Data;
- Parser.Grammar := Grammar;
- Parser.Start_ID := Start_ID;
- Parser.Direct_Left_Recursive := Direct_Left_Recursive;
- end return;
- end Create;
-
- overriding procedure Parse (Parser : aliased in out Procedural.Parser)
- is
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- Junk : Valid_Node_Index;
- pragma Unreferenced (Junk);
-
- Result : Memo_Entry;
- begin
- Parser.Base_Tree.Clear;
- Parser.Tree.Initialize (Parser.Base_Tree'Unchecked_Access, Flush =>
True);
- Parser.Lex_All;
-
- for Nonterm in Descriptor.First_Nonterminal ..
Parser.Trace.Descriptor.Last_Nonterminal loop
- Parser.Derivs (Nonterm).Clear;
- Parser.Derivs (Nonterm).Set_First_Last (Parser.Terminals.First_Index,
Parser.Terminals.Last_Index + 1);
- -- There might be an empty nonterm after the last token
- end loop;
-
- for Token_Index in Parser.Terminals.First_Index ..
Parser.Terminals.Last_Index loop
- Junk := Parser.Tree.Add_Terminal (Token_Index, Parser.Terminals);
- end loop;
-
- Result := Apply_Rule (Parser, Parser.Start_ID,
Parser.Terminals.First_Index - 1);
-
- if Result.State /= Success then
- if Trace_Parse > Outline then
- Parser.Trace.Put_Line ("parse failed");
- end if;
-
- raise Syntax_Error with "parse failed"; -- FIXME: need better error
message!
- else
- Parser.Tree.Set_Root (Result.Result);
- end if;
- end Parse;
-
- overriding function Tree (Parser : in Procedural.Parser) return
Syntax_Trees.Tree
- is begin
- return Parser.Tree;
- end Tree;
-
- overriding function Tree_Var_Ref
- (Parser : aliased in out Procedural.Parser)
- return Syntax_Trees.Tree_Variable_Reference
- is begin
- return (Element => Parser.Tree'Access);
- end Tree_Var_Ref;
-
-end WisiToken.Parse.Packrat.Procedural;
diff --git a/packages/wisi/wisitoken-parse-packrat-procedural.ads
b/packages/wisi/wisitoken-parse-packrat-procedural.ads
deleted file mode 100644
index ff04837..0000000
--- a/packages/wisi/wisitoken-parse-packrat-procedural.ads
+++ /dev/null
@@ -1,86 +0,0 @@
--- Abstract :
---
--- Procedural packrat parser, supporting only direct left recursion.
---
--- Coding style, algorithm is the same as generated by
--- wisi-generate_packrat, but in procedural form.
---
--- References:
---
--- See parent.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Productions;
-package WisiToken.Parse.Packrat.Procedural is
-
- -- These types duplicate Packrat.Generated. We keep them separate so
- -- we can experiment with ways of implementing indirect left
- -- recursion.
-
- type Memo_State is (No_Result, Failure, Success);
- subtype Result_States is Memo_State range Failure .. Success;
-
- type Memo_Entry (State : Memo_State := No_Result) is record
- case State is
- when No_Result =>
- null;
-
- when Failure =>
- null;
-
- when Success =>
- Result : WisiToken.Valid_Node_Index;
- Last_Pos : Base_Token_Index;
-
- end case;
- end record;
-
- package Memos is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_Index, Memo_Entry, Default_Element => (others => <>));
- type Derivs is array (Token_ID range <>) of Memos.Vector;
-
- type Parser (First_Nonterminal, Last_Nonterminal : Token_ID) is new
Packrat.Parser with
- record
- Grammar : WisiToken.Productions.Prod_Arrays.Vector;
- Start_ID : Token_ID;
- Direct_Left_Recursive : Token_ID_Set (First_Nonterminal ..
Last_Nonterminal);
- Derivs : Procedural.Derivs (First_Nonterminal ..
Last_Nonterminal);
- end record;
-
- function Create
- (Grammar : in WisiToken.Productions.Prod_Arrays.Vector;
- Direct_Left_Recursive : in Token_ID_Set;
- Start_ID : in Token_ID;
- Trace : access WisiToken.Trace'Class;
- Lexer : WisiToken.Lexer.Handle;
- User_Data : WisiToken.Syntax_Trees.User_Data_Access)
- return Procedural.Parser;
-
- overriding procedure Parse (Parser : aliased in out Procedural.Parser);
- overriding function Tree (Parser : in Procedural.Parser) return
Syntax_Trees.Tree;
- overriding function Tree_Var_Ref
- (Parser : aliased in out Procedural.Parser)
- return Syntax_Trees.Tree_Variable_Reference;
-
- overriding function Any_Errors (Parser : in Procedural.Parser) return
Boolean
- is (False);
- -- All errors are reported by Parse raising Syntax_Error.
-
- overriding procedure Put_Errors (Parser : in Procedural.Parser)
- is null;
-
-end WisiToken.Parse.Packrat.Procedural;
diff --git a/packages/wisi/wisitoken-parse-packrat.adb
b/packages/wisi/wisitoken-parse-packrat.adb
deleted file mode 100644
index 46ea1e9..0000000
--- a/packages/wisi/wisitoken-parse-packrat.adb
+++ /dev/null
@@ -1,63 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018, 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Parse.Packrat is
-
- overriding
- procedure Execute_Actions
- (Parser : in out Packrat.Parser;
- Image_Augmented : in Syntax_Trees.Image_Augmented := null)
- is
- Descriptor : WisiToken.Descriptor renames Parser.Trace.Descriptor.all;
-
- procedure Process_Node
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- is
- use all type Syntax_Trees.Node_Label;
- begin
- if Tree.Label (Node) /= Nonterm then
- return;
- end if;
-
- declare
- use all type Syntax_Trees.Semantic_Action;
- Tree_Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
- begin
- Parser.User_Data.Reduce (Tree, Node, Tree_Children);
-
- if Tree.Action (Node) /= null then
- Tree.Action (Node) (Parser.User_Data.all, Tree, Node,
Tree_Children);
- end if;
- end;
- end Process_Node;
-
- begin
- if Trace_Action > Outline then
- if Trace_Action > Extra then
- Parser.Tree.Print_Tree (Descriptor, Parser.Tree.Root,
Image_Augmented);
- Parser.Trace.New_Line;
- end if;
- Parser.Trace.Put_Line ("root node: " & Parser.Tree.Image
(Parser.Tree.Root, Descriptor));
- end if;
-
- Parser.Tree.Process_Tree (Process_Node'Access);
- end Execute_Actions;
-
-end WisiToken.Parse.Packrat;
diff --git a/packages/wisi/wisitoken-parse-packrat.ads
b/packages/wisi/wisitoken-parse-packrat.ads
deleted file mode 100644
index 9c0421f..0000000
--- a/packages/wisi/wisitoken-parse-packrat.ads
+++ /dev/null
@@ -1,75 +0,0 @@
--- Abstract :
---
--- Types and operations for a packrat parser runtime.
---
--- References:
---
--- [ford thesis] Bryan Ford thesis http://bford.info/pub/lang/thesis
---
--- [langkit] AdaCore langkit https://github.com/adacore/langkit
---
--- [tratt 2010] http://tratt.net/laurie/research/pubs/papers/
--- tratt__direct_left_recursive_parsing_expression_grammars.pdf
---
--- [warth 2008] Warth, A., Douglass, J.R. and Millstein, T.D., 2008. Packrat
--- parsers can support left recursion. PEPM, 8, pp.103-110.
---
--- Copyright (C) 2018, 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
--- Design:
---
--- [ford thesis] uses Haskell lazy evaluation, and does not use a
--- lexer. We use a lexer to reduce the memory requirement. Although
--- eliminating the lexer would make it easier to support additional
--- syntax for a preprocessor or template generator.
---
--- [langkit] uses a lexer, and implements lazy evaluation via
--- Memo_State, Memo_Entry as we do here, except that their result
--- type is a specific AST type provided by a generic parameter; we
--- use the general purpose Syntax_Tree.Tree type.
---
--- [langkit] also applies a memory optimization; it only saves the
--- last 16 results for each nonterminal. We don't do that yet, so we
--- can get some data on how well that works.
-
-pragma License (Modified_GPL);
-with WisiToken.Syntax_Trees;
-package WisiToken.Parse.Packrat is
-
- function Tree_Index (Terminal_Index : in Token_Index) return
Valid_Node_Index
- is (Valid_Node_Index (Terminal_Index));
- -- All tokens are read and entered into the syntax tree before any
- -- nonterms are reduced, so the mapping from Terminals token_index to
- -- Tree node_index is identity.
- -- FIXME: use Terminals (Terminal_Index).Tree_Index
-
- type Parser is abstract new Base_Parser with record
- -- Dynamic parsing data
-
- Base_Tree : aliased WisiToken.Syntax_Trees.Base_Tree;
- Tree : aliased WisiToken.Syntax_Trees.Tree;
- -- FIXME: Current we only need Base_Tree for Execute_Actions, except
- -- that Syntax_Trees only declares the needed operations on Tree. But
- -- we may need more trees for error recovery; if not, fix
- -- Syntax_Trees, move Base_Tree and Execute_Actions up to
- -- base_parser.
-
- end record;
-
- overriding
- procedure Execute_Actions
- (Parser : in out Packrat.Parser;
- Image_Augmented : in Syntax_Trees.Image_Augmented := null);
-
-end WisiToken.Parse.Packrat;
diff --git a/packages/wisi/wisitoken-parse.adb
b/packages/wisi/wisitoken-parse.adb
deleted file mode 100644
index 535c423..0000000
--- a/packages/wisi/wisitoken-parse.adb
+++ /dev/null
@@ -1,108 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Parse is
-
- function Next_Grammar_Token (Parser : in out Base_Parser'Class) return
Token_ID
- is
- use all type Ada.Containers.Count_Type;
- use all type Syntax_Trees.User_Data_Access;
-
- Token : Base_Token;
- Error : Boolean;
- begin
- loop
- Error := Parser.Lexer.Find_Next (Token);
-
- -- We don't handle Error until later; we assume it was recovered.
-
- if Token.Line /= Invalid_Line_Number then
- -- Some lexers don't support line numbers.
- if Parser.Lexer.First then
- if Parser.Line_Begin_Token.Length = 0 then
- Parser.Line_Begin_Token.Set_First_Last (Token.Line,
Token.Line);
- else
- Parser.Line_Begin_Token.Set_First_Last
(Parser.Line_Begin_Token.First_Index, Token.Line);
- end if;
- Parser.Line_Begin_Token (Token.Line) :=
Parser.Terminals.Last_Index +
- (if Token.ID >= Parser.Trace.Descriptor.First_Terminal then 1
else 0);
-
- elsif Token.ID = Parser.Trace.Descriptor.EOI_ID then
- Parser.Line_Begin_Token.Set_First_Last
(Parser.Line_Begin_Token.First_Index, Token.Line + 1);
- Parser.Line_Begin_Token (Token.Line + 1) :=
Parser.Terminals.Last_Index + 1;
- end if;
- end if;
-
- if Trace_Parse > Lexer_Debug then
- Parser.Trace.Put_Line (Image (Token, Parser.Trace.Descriptor.all));
- end if;
-
- if Token.ID >= Parser.Trace.Descriptor.First_Terminal then
-
- Parser.Terminals.Append (Token);
-
- -- We create the syntax tree node here, so Lexer_To_Augmented can
- -- store augmented data in it.
- Parser.Terminals (Parser.Terminals.Last_Index).Tree_Index :=
Parser.Tree_Var_Ref.Add_Terminal
- (Parser.Terminals.Last_Index, Parser.Terminals);
-
- if Parser.User_Data /= null then
- Parser.User_Data.Lexer_To_Augmented
- (Parser.Tree_Var_Ref, Parser.Terminals
(Parser.Terminals.Last_Index), Parser.Lexer);
- end if;
-
- exit;
- else
- -- non-grammar; not in syntax tree
- if Parser.User_Data /= null then
- Parser.User_Data.Lexer_To_Augmented (Parser.Tree_Var_Ref,
Token, Parser.Lexer);
- end if;
- end if;
- end loop;
-
- if Error then
- declare
- Error : WisiToken.Lexer.Error renames
Parser.Lexer.Errors.Reference (Parser.Lexer.Errors.Last);
- begin
- if Error.Recover_Char (1) /= ASCII.NUL then
- Error.Recover_Token := Parser.Terminals.Last_Index;
- end if;
- end;
- end if;
-
- return Token.ID;
- end Next_Grammar_Token;
-
- procedure Lex_All (Parser : in out Base_Parser'Class)
- is
- EOF_ID : constant Token_ID := Parser.Trace.Descriptor.EOI_ID;
- begin
- Parser.Lexer.Errors.Clear;
- Parser.Terminals.Clear;
- Parser.Line_Begin_Token.Clear;
- loop
- exit when EOF_ID = Next_Grammar_Token (Parser);
- end loop;
- if Trace_Parse > Outline then
- Parser.Trace.Put_Line (Token_Index'Image
(Parser.Terminals.Last_Index) & " tokens lexed");
- end if;
-
- end Lex_All;
-
-end WisiToken.Parse;
diff --git a/packages/wisi/wisitoken-parse.ads
b/packages/wisi/wisitoken-parse.ads
deleted file mode 100644
index 1493658..0000000
--- a/packages/wisi/wisitoken-parse.ads
+++ /dev/null
@@ -1,84 +0,0 @@
--- Abstract :
---
--- Subprograms common to more than one parser, higher-level than in
wisitoken.ads
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with WisiToken.Lexer;
-with WisiToken.Syntax_Trees;
-package WisiToken.Parse is
-
- type Base_Parser is abstract new Ada.Finalization.Limited_Controlled with
record
- Trace : access WisiToken.Trace'Class;
- Lexer : WisiToken.Lexer.Handle;
- User_Data : WisiToken.Syntax_Trees.User_Data_Access;
- Terminals : aliased WisiToken.Base_Token_Arrays.Vector;
-
- Line_Begin_Token : aliased WisiToken.Line_Begin_Token_Vectors.Vector;
- -- Line_Begin_Token (I) is the index into Terminals of the first
- -- grammar token on line I. Line_Begin_Token.First_Index is the first
- -- line containing a grammar token (after leading comments). However,
- -- if the only token on line I is a non_grammar token (ie a comment,
- -- or a newline for a blank line), Line_Begin_Token (I) is the last
- -- grammar token on the previous non-blank line. If Line (I) is a
- -- non-first line in a multi-line terminal token, Line_Begin_Token
- -- (I) is Invalid_Token_Index.
- end record;
- -- Common to all parsers. Finalize should free any allocated objects.
-
- function Next_Grammar_Token (Parser : in out Base_Parser'Class) return
Token_ID;
- -- Get next token from Lexer, call User_Data.Lexer_To_Augmented. If
- -- it is a grammar token, store in Terminals and return its id.
- -- Otherwise, repeat.
- --
- -- Propagates Fatal_Error from Lexer.
-
- procedure Lex_All (Parser : in out Base_Parser'Class);
- -- Clear Terminals, Line_Begin_Token; reset User_Data. Then call
- -- Next_Grammar_Token repeatedly until EOF_ID is returned.
- --
- -- The user must first call Lexer.Reset_* to set the input text.
-
- procedure Parse (Parser : aliased in out Base_Parser) is abstract;
- -- Call Lex_All, then execute parse algorithm to parse the tokens,
- -- storing the result in Parser for Execute_Actions.
- --
- -- If a parse error is encountered, raises Syntax_Error.
- -- Parser.Lexer_Errors and Parser contain information about the
- -- errors.
- --
- -- For other errors, raises Parse_Error with an appropriate error
- -- message.
-
- function Tree (Parser : in Base_Parser) return Syntax_Trees.Tree is
abstract;
- -- Return the syntax tree resulting from the parse.
-
- function Tree_Var_Ref (Parser : aliased in out Base_Parser) return
Syntax_Trees.Tree_Variable_Reference is abstract;
- -- Return a writable reference to the syntax tree resulting from the parse.
-
- function Any_Errors (Parser : in Base_Parser) return Boolean is abstract;
-
- procedure Put_Errors (Parser : in Base_Parser) is abstract;
- -- Output error messages to Ada.Text_IO.Current_Error.
-
- procedure Execute_Actions
- (Parser : in out Base_Parser;
- Image_Augmented : in Syntax_Trees.Image_Augmented := null)
- is abstract;
- -- Execute all actions in Parser.Tree.
-
-end WisiToken.Parse;
diff --git a/packages/wisi/wisitoken-parse_table-mode.el
b/packages/wisi/wisitoken-parse_table-mode.el
deleted file mode 100644
index e864ab0..0000000
--- a/packages/wisi/wisitoken-parse_table-mode.el
+++ /dev/null
@@ -1,95 +0,0 @@
-;; wisitoken-parse_table-mode.el --- For navigating in a parse table as output
by wisitoken-bnf-generate. -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2017 - 2020 Free Software Foundation, Inc.
-;;
-;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
-;; Keywords: parser
-;; Version: 1.0
-;; package-requires: ((emacs "25.1"))
-;; URL: http://www.nongnu.org/ada-mode/wisi/wisi.html
-;;
-;; This file is part of GNU Emacs.
-;;
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-(require 'xref)
-
-(defun wisitoken-parse_table--xref-backend () 'wisitoken-parse_table)
-
-(cl-defgeneric xref-backend-identifier-completion-table ((_backend (eql
wisitoken-parse_table)))
- ;; could complete on nonterms, find productions
- nil)
-
-(cl-defmethod xref-backend-identifier-at-point ((_backend (eql
wisitoken-parse_table)))
- ;; if we are on one of:
- ;; - ’goto state nnn’ in a state action
- ;; => return nnn state
- ;;
- ;; or
- ;; - foo <= bar baz
- ;; => return nonterminal name at point
- ;;
- ;; - 'reduce n tokens to <nonterminal> <prod_id>'
- ;; => return 'prod_id: name'
- (cond
- ((save-excursion
- (beginning-of-line)
- ;; "go to" for bison output
- (search-forward-regexp "go ?to state \\([0-9]+\\)" (line-end-position)
t))
- (match-string 1))
-
- ((save-excursion
- (beginning-of-line)
- (search-forward-regexp "reduce [0-9]+ tokens to \\([[:alnum:]_]+\\)
\\([0-9.]+\\)" (line-end-position) t))
- (concat (match-string 2) ": " (match-string 1)))
-
- (t
- (thing-at-point 'symbol))))
-
-(cl-defgeneric xref-backend-definitions ((_backend (eql
wisitoken-parse_table)) identifier)
- ;; IDENTIFIER is from xref-back-identifier-at-point; a state number or a
nonterminal
- (let ((state-p (string-match "\\`[0-9]+\\'" identifier))
- (prod_id-p (string-match "\\`[0-9.]+: " identifier)))
- (save-excursion
- (goto-char (point-min))
- (cond
- (state-p
- (search-forward-regexp (concat "^State " identifier ":$")))
-
- (prod_id-p
- (search-forward-regexp (concat identifier " <=")))
-
- (t
- (search-forward-regexp (concat "^[0-9.]+: " identifier " <=")))
- )
- (list (xref-make identifier (xref-make-buffer-location (current-buffer)
(match-beginning 0))))
- )))
-
-;;;###autoload
-(define-minor-mode wisitoken-parse_table-mode
- "Provides navigation in wisi-generate parse table output."
- nil ":parse_table" nil
- (add-hook 'xref-backend-functions #'wisitoken-parse_table--xref-backend nil
t)
-
- (if wisitoken-parse_table-mode
- (read-only-mode 0)
- (read-only-mode 1)
- ))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.parse_table.*\\'" .
wisitoken-parse_table-mode))
-
-(provide 'wisitoken-parse_table-mode)
-;; end of file
diff --git a/packages/wisi/wisitoken-productions.adb
b/packages/wisi/wisitoken-productions.adb
deleted file mode 100644
index 2f1892f..0000000
--- a/packages/wisi/wisitoken-productions.adb
+++ /dev/null
@@ -1,83 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018, 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Text_IO;
-package body WisiToken.Productions is
-
- function Image (Item : in Recursion_Arrays.Vector) return String
- is
- use Ada.Strings.Unbounded;
- Result : Ada.Strings.Unbounded.Unbounded_String := +"(";
- Need_Comma : Boolean := False;
- begin
- -- We assume most are None, so we use named association
- for I in Item.First_Index .. Item.Last_Index loop
- if Item (I) /= None then
- Result := Result & (if Need_Comma then ", " else "") &
Trimmed_Image (I) & " => " & Image (Item (I));
- Need_Comma := True;
- end if;
- end loop;
- Result := Result & ")";
- return -Result;
- end Image;
-
- function Constant_Ref_RHS
- (Grammar : in Prod_Arrays.Vector;
- ID : in Production_ID)
- return RHS_Arrays.Constant_Reference_Type
- is begin
- return RHS_Arrays.Constant_Ref (Grammar (ID.LHS).RHSs, ID.RHS);
- end Constant_Ref_RHS;
-
- function Image
- (LHS : in Token_ID;
- RHS_Index : in Natural;
- RHS : in Token_ID_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return String
- is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := +Trimmed_Image ((LHS, RHS_Index)) & ": " &
Image (LHS, Descriptor) & " <=";
- begin
- for ID of RHS loop
- Result := Result & ' ' & Image (ID, Descriptor);
- end loop;
- return To_String (Result);
- end Image;
-
- procedure Put (Grammar : Prod_Arrays.Vector; Descriptor : in
WisiToken.Descriptor)
- is
- use Ada.Text_IO;
- begin
- for P of Grammar loop
- for R in P.RHSs.First_Index .. P.RHSs.Last_Index loop
- Put (Image (P.LHS, R, P.RHSs (R).Tokens, Descriptor));
- if (for all Item of Grammar (P.LHS).RHSs (R).Recursion => Item =
None) then
- New_Line;
- else
- Put_Line (" ; " & Image (Grammar (P.LHS).RHSs (R).Recursion));
- end if;
- end loop;
- end loop;
- end Put;
-
-end WisiToken.Productions;
diff --git a/packages/wisi/wisitoken-productions.ads
b/packages/wisi/wisitoken-productions.ads
deleted file mode 100644
index 8b8c8f8..0000000
--- a/packages/wisi/wisitoken-productions.ads
+++ /dev/null
@@ -1,88 +0,0 @@
--- Abstract :
---
--- Type and operations for building grammar productions.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under terms of the GNU General Public License as
--- published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. This library is distributed in
--- the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--- even the implied warranty of MERCHAN- TABILITY or FITNESS FOR A
--- PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with SAL.Gen_Unbounded_Definite_Vectors;
-with WisiToken.Semantic_Checks;
-with WisiToken.Syntax_Trees;
-package WisiToken.Productions is
- use all type Ada.Containers.Count_Type;
-
- package Recursion_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive, Recursion_Class, Default_Element => None);
-
- function Image (Item : in Recursion_Arrays.Vector) return String;
- -- For parse_table
-
- type Right_Hand_Side is record
- Tokens : Token_ID_Arrays.Vector;
- Recursion : Recursion_Arrays.Vector;
- -- Recursion for each token. There may be more than one recursion cycle
for any token,
- -- but we don't track that.
-
- Action : WisiToken.Syntax_Trees.Semantic_Action;
- Check : WisiToken.Semantic_Checks.Semantic_Check;
- end record
- with Dynamic_Predicate =>
- (Tokens.Length = 0 or Tokens.First_Index = 1) and
- (Recursion.Length = 0 or
- (Recursion.First_Index = Tokens.First_Index and Recursion.Last_Index =
Tokens.Last_Index));
-
- package RHS_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Natural, Right_Hand_Side, Default_Element => (others => <>));
-
- type Instance is record
- LHS : Token_ID := Invalid_Token_ID;
- RHSs : RHS_Arrays.Vector;
- end record;
-
- package Prod_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_ID, Instance, Default_Element => (others => <>));
-
- function Constant_Ref_RHS
- (Grammar : in Prod_Arrays.Vector;
- ID : in Production_ID)
- return RHS_Arrays.Constant_Reference_Type;
-
- function Image
- (LHS : in Token_ID;
- RHS_Index : in Natural;
- RHS : in Token_ID_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return String;
- -- For comments in generated code, diagnostic messages.
-
- procedure Put (Grammar : Prod_Arrays.Vector; Descriptor : in
WisiToken.Descriptor);
- -- Put Image of each production to Ada.Text_IO.Current_Output, for
parse_table.
-
- package Line_Number_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Natural, Line_Number_Type, Default_Element => Invalid_Line_Number);
-
- type Prod_Source_Line_Map is record
- Line : Line_Number_Type := Invalid_Line_Number;
- RHS_Map : Line_Number_Arrays.Vector;
- end record;
-
- package Source_Line_Maps is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_ID, Prod_Source_Line_Map, Default_Element => (others => <>));
- -- For line numbers of productions in source files.
-
-end WisiToken.Productions;
diff --git a/packages/wisi/wisitoken-semantic_checks.adb
b/packages/wisi/wisitoken-semantic_checks.adb
deleted file mode 100644
index d69ac77..0000000
--- a/packages/wisi/wisitoken-semantic_checks.adb
+++ /dev/null
@@ -1,152 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Characters.Handling;
-package body WisiToken.Semantic_Checks is
-
- function Image (Item : in Check_Status; Descriptor : in
WisiToken.Descriptor) return String
- is begin
- case Item.Label is
- when Ok =>
- return Check_Status_Label'Image (Item.Label);
- when Error =>
- return '(' & Check_Status_Label'Image (Item.Label) & ", " &
- Image (Item.Begin_Name, Descriptor) & ',' &
- Image (Item.End_Name, Descriptor) & ')';
- end case;
- end Image;
-
- function Match_Names
- (Lexer : access constant WisiToken.Lexer.Instance'Class;
- Descriptor : in WisiToken.Descriptor;
- Tokens : in Recover_Token_Array;
- Start_Index : in Positive_Index_Type;
- End_Index : in Positive_Index_Type;
- End_Optional : in Boolean)
- return Check_Status
- is
- Start_Name_Region : constant Buffer_Region :=
- (if Tokens (Start_Index).Name = Null_Buffer_Region
- then Tokens (Start_Index).Byte_Region
- else Tokens (Start_Index).Name);
- End_Name_Region : constant Buffer_Region :=
- (if Tokens (End_Index).Name = Null_Buffer_Region
- then Tokens (End_Index).Byte_Region
- else Tokens (End_Index).Name);
-
- function Equal return Boolean
- is
- use Ada.Characters.Handling;
- begin
- if Descriptor.Case_Insensitive then
- return To_Lower (Lexer.Buffer_Text (Start_Name_Region)) =
- To_Lower (Lexer.Buffer_Text (End_Name_Region));
- else
- return Lexer.Buffer_Text (Start_Name_Region) = Lexer.Buffer_Text
(End_Name_Region);
- end if;
- end Equal;
-
- begin
- if Tokens (Start_Index).Virtual or Tokens (End_Index).Virtual then
- return (Label => Ok);
-
- elsif End_Optional then
- if End_Name_Region = Null_Buffer_Region then
- return (Label => Ok);
- elsif Start_Name_Region = Null_Buffer_Region then
- return (Extra_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
- else
- if Equal then
- return (Label => Ok);
- else
- return (Match_Names_Error, Tokens (Start_Index), Tokens
(End_Index));
- end if;
- end if;
-
- else
- if Start_Name_Region = Null_Buffer_Region then
- if End_Name_Region = Null_Buffer_Region then
- return (Label => Ok);
- else
- return (Extra_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
- end if;
-
- elsif End_Name_Region = Null_Buffer_Region then
- return (Missing_Name_Error, Tokens (Start_Index), Tokens
(End_Index));
-
- else
- if Equal then
- return (Label => Ok);
- else
- return (Match_Names_Error, Tokens (Start_Index), Tokens
(End_Index));
- end if;
- end if;
- end if;
- end Match_Names;
-
- function Propagate_Name
- (Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- Name_Index : in Positive_Index_Type)
- return Check_Status
- is begin
- if Tokens (Name_Index).Name = Null_Buffer_Region then
- Nonterm.Name := Tokens (Name_Index).Byte_Region;
- else
- Nonterm.Name := Tokens (Name_Index).Name;
- end if;
- return (Label => Ok);
- end Propagate_Name;
-
- function Merge_Names
- (Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- First_Index : in Positive_Index_Type;
- Last_Index : in Positive_Index_Type)
- return Check_Status
- is
- First_Name : Buffer_Region renames Tokens (First_Index).Name;
- Last_Name : Buffer_Region renames Tokens (Last_Index).Name;
- begin
- Nonterm.Name :=
- First_Name and
- (if Last_Name = Null_Buffer_Region
- then Tokens (Last_Index).Byte_Region
- else Last_Name);
- return (Label => Ok);
- end Merge_Names;
-
- function Terminate_Partial_Parse
- (Partial_Parse_Active : in Boolean;
- Partial_Parse_Byte_Goal : in Buffer_Pos;
- Recover_Active : in Boolean;
- Nonterm : in Recover_Token)
- return Check_Status
- is begin
- if Partial_Parse_Active and then
- (not Recover_Active) and then
- Nonterm.Byte_Region.Last >= Partial_Parse_Byte_Goal
- then
- raise WisiToken.Partial_Parse;
- else
- return (Label => Ok);
- end if;
- end Terminate_Partial_Parse;
-
-end WisiToken.Semantic_Checks;
diff --git a/packages/wisi/wisitoken-semantic_checks.ads
b/packages/wisi/wisitoken-semantic_checks.ads
deleted file mode 100644
index c55371e..0000000
--- a/packages/wisi/wisitoken-semantic_checks.ads
+++ /dev/null
@@ -1,106 +0,0 @@
--- Abstract :
---
--- Grammar semantic check routines.
---
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Lexer;
-package WisiToken.Semantic_Checks is
-
- type Check_Status_Label is
- (Ok,
- Missing_Name_Error, -- block start has name, required block end name
missing
- Extra_Name_Error, -- block start has no name, end has one
- Match_Names_Error); -- both names present, but don't match
-
- subtype Error is Check_Status_Label range Check_Status_Label'Succ (Ok) ..
Check_Status_Label'Last;
-
- type Check_Status (Label : Check_Status_Label := Ok) is record
- case Label is
- when Ok =>
- null;
-
- when Error =>
- Begin_Name : Recover_Token;
- End_Name : Recover_Token;
- end case;
- end record;
-
- subtype Error_Check_Status is Check_Status
- with Dynamic_Predicate => Error_Check_Status.Label /= Ok;
-
- function Image (Item : in Check_Status; Descriptor : WisiToken.Descriptor)
return String;
-
- type Semantic_Check is access function
- (Lexer : access constant WisiToken.Lexer.Instance'Class;
- Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- Recover_Active : in Boolean)
- return Check_Status;
- -- Called during parsing and error recovery to implement higher level
- -- checks, such as block name matching in Ada.
-
- Null_Check : constant Semantic_Check := null;
-
- function Match_Names
- (Lexer : access constant WisiToken.Lexer.Instance'Class;
- Descriptor : in WisiToken.Descriptor;
- Tokens : in Recover_Token_Array;
- Start_Index : in Positive_Index_Type;
- End_Index : in Positive_Index_Type;
- End_Optional : in Boolean)
- return Check_Status;
- -- Check that buffer text at Tokens (Start_Index).Name matches buffer
- -- text at Tokens (End_Index).Name. Comparison is controlled by
- -- Descriptor.Case_Insensitive.
-
- function Propagate_Name
- (Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- Name_Index : in Positive_Index_Type)
- return Check_Status;
- function Merge_Names
- (Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- Name_Index : in Positive_Index_Type)
- return Check_Status
- renames Propagate_Name;
- -- Set Nonterm.Name to Tokens (Name_Index).Name, or .Byte_Region, if
- -- .Name is Null_Buffer_Region. Return Ok.
-
- function Merge_Names
- (Nonterm : in out Recover_Token;
- Tokens : in Recover_Token_Array;
- First_Index : in Positive_Index_Type;
- Last_Index : in Positive_Index_Type)
- return Check_Status;
- -- Then set Nonterm.Name to the merger of Tokens (First_Index ..
- -- Last_Index).Name, return Ok.
- --
- -- If Tokens (Last_Index).Name is Null_Buffer_Region, use Tokens
- -- (Last_Index).Byte_Region instead.
-
- function Terminate_Partial_Parse
- (Partial_Parse_Active : in Boolean;
- Partial_Parse_Byte_Goal : in Buffer_Pos;
- Recover_Active : in Boolean;
- Nonterm : in Recover_Token)
- return Check_Status;
- pragma Inline (Terminate_Partial_Parse);
- -- If partial parse is complete, raise Wisitoken.Partial_Parse;
- -- otherwise return Ok.
-
-end WisiToken.Semantic_Checks;
diff --git a/packages/wisi/wisitoken-syntax_trees-lr_utils.adb
b/packages/wisi/wisitoken-syntax_trees-lr_utils.adb
deleted file mode 100644
index cf04a80..0000000
--- a/packages/wisi/wisitoken-syntax_trees-lr_utils.adb
+++ /dev/null
@@ -1,939 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2019, 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.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-package body WisiToken.Syntax_Trees.LR_Utils is
-
- procedure Raise_Programmer_Error
- (Label : in String;
- Descriptor : in WisiToken.Descriptor;
- Lexer : in WisiToken.Lexer.Handle;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Terminals : in WisiToken.Base_Token_Arrays.Vector;
- Node : in Node_Index)
- is
- Terminal_Index : constant Base_Token_Index := Tree.First_Shared_Terminal
(Node);
- begin
- raise SAL.Programmer_Error with Error_Message
- (Lexer.File_Name,
- -- 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 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;
-
- function Contains (Container : in Constant_List; Node : in
Valid_Node_Index) return Boolean
- is begin
- return (for some N of Container => N = Node);
- end Contains;
-
- function To_Cursor (Container : in Constant_List; Node : in
Valid_Node_Index) return Cursor
- is
- pragma Unreferenced (Container);
- begin
- 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;
-
- function Last (Container : in Constant_List) return Cursor
- is begin
- 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 : Node_Index do
- declare
- -- Tree is one of:
- --
- -- case a: first element, no next
- -- rhs
- -- | rhs_item_list
- -- | | rhs_item: Element
- -- | action
- --
- -- case b: first element, next
- -- rhs_item_list
- -- | rhs_item_list
- -- | | rhs_item: Element
- -- | rhs_item: next element
- --
- -- case c: non-first element, no next
- -- rhs
- -- | rhs_item_list : Grand_Parent
- -- | | rhs_item_list
- -- | | | rhs_item:
- -- | | rhs_item: Element
- -- | action : Aunt
- --
- -- case d: non-first element, next
- -- rhs_item_list
- -- | rhs_item_list : Grand_Parent
- -- | | rhs_item_list
- -- | | | rhs_item:
- -- | | rhs_item: Element
- -- | rhs_item: next element : Aunt
-
- Grand_Parent : constant 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 Grand_Parent = Invalid_Node_Index or else Tree.ID
(Grand_Parent) /= List_ID then
- -- No next
- Result := Invalid_Node_Index;
- else
- 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;
-
- if Last_List_Child = 1 then
- -- No next
- Result := Invalid_Node_Index;
- else
- Result := Aunts (Last_List_Child);
- end if;
- end if;
- end;
- end return;
- end if;
- end Next;
-
- 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 = Invalid_Node_Index then
- return Position;
- else
- return Result : Node_Index do
- -- Tree is one of:
- --
- -- case a: first element, no prev
- -- ?
- -- | rhs_item_list
- -- | | rhs_item: Element
- --
- -- case b: second element
- -- ?
- -- | rhs_item_list
- -- | | rhs_item: prev item
- -- | rhs_item: Element
- --
- -- case c: nth element
- -- ?
- -- | rhs_item_list
- -- | | rhs_item_list
- -- | | | rhs_item:
- -- | | rhs_item: prev element
- -- | rhs_item: Element
- declare
- Parent : constant Valid_Node_Index := Tree.Parent (Position);
- begin
- if Position = Tree.Child (Parent, 1) then
- -- No prev
- Result := Invalid_Node_Index;
-
- else
- declare
- Prev_Children : constant Valid_Node_Index_Array :=
Tree.Children
- (Tree.Child (Parent, 1));
- begin
- Result := Prev_Children (Prev_Children'Last);
- end;
- end if;
- end;
- end return;
- end if;
- end Previous;
-
- overriding function Previous (Iter : Iterator; Position : Cursor) return
Cursor
- is begin
- 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
- pragma Unreferenced (Container);
- begin
- 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 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
deleted file mode 100644
index 6f0403c..0000000
--- a/packages/wisi/wisitoken-syntax_trees-lr_utils.ads
+++ /dev/null
@@ -1,475 +0,0 @@
--- Abstract :
---
--- 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
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Iterator_Interfaces;
-with SAL.Gen_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;
- Descriptor : in WisiToken.Descriptor;
- Lexer : in WisiToken.Lexer.Handle;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Terminals : in WisiToken.Base_Token_Arrays.Vector;
- Node : in WisiToken.Node_Index);
- pragma No_Return (Raise_Programmer_Error);
-
- ----------
- -- List functions
- --
- -- A list has one of the following grammar forms:
- --
- -- list : list element | element ;
- -- list : element | list element ;
- --
- -- list : list separator element | element ;
- -- list : element | list separator element ;
- --
- -- 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 (Container : not null access constant Constant_List'Class) is
- new Iterator_Interfaces.Reversible_Iterator
- with null record;
-
- function First (Container : in Constant_List) return Cursor;
- function Last (Container : in Constant_List) 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;
-
- function List_Constant_Ref
- (Container : aliased in Constant_List'Class;
- Position : in Cursor)
- return Valid_Node_Index;
-
- type Constant_Iterator (Container : not null access constant Constant_List)
is new
- Iterator_Interfaces.Reversible_Iterator
- with null record;
-
- 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;
-
- 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;
-
- 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
deleted file mode 100644
index 0a38ae7..0000000
--- a/packages/wisi/wisitoken-syntax_trees.adb
+++ /dev/null
@@ -1,2111 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-with Ada.Text_IO;
-with SAL.Generic_Decimal_Image;
-package body WisiToken.Syntax_Trees is
-
- -- Body specs, alphabetical, as needed
-
- 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;
- Node_Numbers : in Boolean := False)
- return String;
-
- procedure Move_Branch_Point (Tree : in out Syntax_Trees.Tree; Required_Node
: in Valid_Node_Index);
-
- type Visit_Parent_Mode is (Before, After);
-
- function Process_Tree
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Visit_Parent : in Visit_Parent_Mode;
- Process_Node : access function
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Boolean)
- return Boolean;
- -- Call Process_Node on nodes in tree rooted at Node. Return when
- -- Process_Node returns False (Process_Tree returns False), or when
- -- all nodes have been processed (Process_Tree returns True).
-
- procedure Set_Children
- (Tree : in out Syntax_Trees.Tree;
- Parent : in Valid_Node_Index;
- Children : in Valid_Node_Index_Array);
-
- ----------
- -- Public and body operations, alphabetical
-
- function Action
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Semantic_Action
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).Action
- else Tree.Branched_Nodes (Node).Action);
- end Action;
-
- procedure Add_Child
- (Tree : in out Syntax_Trees.Tree;
- Parent : in Valid_Node_Index;
- Child : in Valid_Node_Index)
- is
- Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Parent);
- begin
- Node.Children.Append (Child);
- Tree.Shared_Tree.Nodes (Child).Parent := Parent;
- end Add_Child;
-
- function Add_Identifier
- (Tree : in out Syntax_Trees.Tree;
- ID : in Token_ID;
- Identifier : in Identifier_Index;
- Byte_Region : in WisiToken.Buffer_Region)
- return Valid_Node_Index
- is begin
- Tree.Shared_Tree.Nodes.Append
- ((Label => Virtual_Identifier,
- Byte_Region => Byte_Region,
- ID => ID,
- Identifier => Identifier,
- others => <>));
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- return Tree.Last_Shared_Node;
- end Add_Identifier;
-
- function Add_Nonterm
- (Tree : in out Syntax_Trees.Tree;
- Production : in WisiToken.Production_ID;
- Children : in Valid_Node_Index_Array;
- Action : in Semantic_Action := null;
- Default_Virtual : in Boolean := False)
- return Valid_Node_Index
- is
- Nonterm_Node : Valid_Node_Index;
- begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes.Append
- ((Label => Syntax_Trees.Nonterm,
- ID => Production.LHS,
- Action => Action,
- RHS_Index => Production.RHS,
- Virtual => (if Children'Length = 0 then Default_Virtual else
False),
- others => <>));
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- Nonterm_Node := Tree.Last_Shared_Node;
- else
- Tree.Branched_Nodes.Append
- ((Label => Syntax_Trees.Nonterm,
- ID => Production.LHS,
- Action => Action,
- RHS_Index => Production.RHS,
- Virtual => (if Children'Length = 0 then Default_Virtual else
False),
- others => <>));
- Nonterm_Node := Tree.Branched_Nodes.Last_Index;
- end if;
-
- if Children'Length = 0 then
- return Nonterm_Node;
- end if;
-
- Set_Children (Tree, Nonterm_Node, Children);
-
- return Nonterm_Node;
- end Add_Nonterm;
-
- function Add_Terminal
- (Tree : in out Syntax_Trees.Tree;
- Terminal : in Token_Index;
- Terminals : in Base_Token_Arrays.Vector)
- return Valid_Node_Index
- is begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes.Append
- ((Label => Shared_Terminal,
- ID => Terminals (Terminal).ID,
- Byte_Region => Terminals (Terminal).Byte_Region,
- Terminal => Terminal,
- others => <>));
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- return Tree.Last_Shared_Node;
- else
- Tree.Branched_Nodes.Append
- ((Label => Shared_Terminal,
- ID => Terminals (Terminal).ID,
- Byte_Region => Terminals (Terminal).Byte_Region,
- Terminal => Terminal,
- others => <>));
- return Tree.Branched_Nodes.Last_Index;
- end if;
- end Add_Terminal;
-
- function Add_Terminal
- (Tree : in out Syntax_Trees.Tree;
- Terminal : in Token_ID;
- Before : in Base_Token_Index := Invalid_Token_Index)
- return Valid_Node_Index
- is begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes.Append
- ((Label => Virtual_Terminal,
- ID => Terminal,
- Before => Before,
- others => <>));
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- return Tree.Last_Shared_Node;
- else
- Tree.Branched_Nodes.Append
- ((Label => Virtual_Terminal,
- ID => Terminal,
- Before => Before,
- others => <>));
- return Tree.Branched_Nodes.Last_Index;
- end if;
- end Add_Terminal;
-
- function Before
- (Tree : in Syntax_Trees.Tree;
- Virtual_Terminal : in Valid_Node_Index)
- return Base_Token_Index
- is begin
- if Tree.Flush then
- return Tree.Shared_Tree.Nodes (Virtual_Terminal).Before;
- else
- return Tree.Branched_Nodes (Virtual_Terminal).Before;
- end if;
- end Before;
-
- function Augmented
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Base_Token_Class_Access
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Augmented;
- else
- return Tree.Branched_Nodes (Node).Augmented;
- end if;
- end Augmented;
-
- function Augmented_Const
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Base_Token_Class_Access_Constant
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Base_Token_Class_Access_Constant (Tree.Shared_Tree.Nodes
(Node).Augmented);
- else
- return Base_Token_Class_Access_Constant (Tree.Branched_Nodes
(Node).Augmented);
- 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)
- return WisiToken.Buffer_Region
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).Byte_Region
- else Tree.Branched_Nodes (Node).Byte_Region);
- end Byte_Region;
-
- function Child
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Child_Index : in Positive_Index_Type)
- return Node_Index
- is
- function Compute (N : in Syntax_Trees.Node) return Node_Index
- is begin
- if N.Label /= Nonterm then
- return Invalid_Node_Index;
-
- elsif Child_Index in N.Children.First_Index .. N.Children.Last_Index
then
- return N.Children (Child_Index);
- else
- return Invalid_Node_Index;
- end if;
- end Compute;
- begin
- if Node <= Tree.Last_Shared_Node then
- return Compute (Tree.Shared_Tree.Nodes (Node));
- else
- return Compute (Tree.Branched_Nodes (Node));
- end if;
- end 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
- return (1 .. 0 => <>);
- else
- return Result : Valid_Node_Index_Array (N.Children.First_Index ..
N.Children.Last_Index) do
- for I in Result'Range loop
- Result (I) := N.Children (I);
- end loop;
- end return;
- end if;
- end Children;
-
- function Children (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Valid_Node_Index_Array
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Children (Tree.Shared_Tree.Nodes (Node));
- else
- return Children (Tree.Branched_Nodes (Node));
- end if;
- end Children;
-
- procedure Clear (Tree : in out Syntax_Trees.Base_Tree)
- is begin
- Tree.Finalize;
- end Clear;
-
- procedure Clear (Tree : in out Syntax_Trees.Tree)
- is begin
- if Tree.Shared_Tree.Augmented_Present then
- for Node of Tree.Branched_Nodes loop
- if Node.Label = Nonterm then
- Free (Node.Augmented);
- end if;
- end loop;
- end if;
- Tree.Shared_Tree.Finalize;
- Tree.Last_Shared_Node := Invalid_Node_Index;
- Tree.Branched_Nodes.Clear;
- end Clear;
-
- function Copy_Subtree
- (Tree : in out Syntax_Trees.Tree;
- Root : in Valid_Node_Index)
- return Valid_Node_Index
- is
- function Copy_Node
- (Tree : in out Syntax_Trees.Tree;
- Index : in Valid_Node_Index;
- Parent : in Node_Index)
- return Valid_Node_Index
- is begin
- case Tree.Shared_Tree.Nodes (Index).Label is
- when Shared_Terminal =>
- declare
- Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Index);
- begin
- Tree.Shared_Tree.Nodes.Append
- ((Label => Shared_Terminal,
- ID => Node.ID,
- Byte_Region => Node.Byte_Region,
- Parent => Parent,
- State => Unknown_State,
- Augmented => Node.Augmented,
- Terminal => Node.Terminal));
- end;
-
- when Virtual_Terminal =>
- declare
- Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Index);
- begin
- Tree.Shared_Tree.Nodes.Append
- ((Label => Virtual_Terminal,
- ID => Node.ID,
- Byte_Region => Node.Byte_Region,
- Parent => Parent,
- State => Unknown_State,
- Augmented => Node.Augmented,
- Before => Node.Before));
- end;
-
- when Virtual_Identifier =>
- declare
- Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Index);
- begin
- Tree.Shared_Tree.Nodes.Append
- ((Label => Virtual_Identifier,
- ID => Node.ID,
- Byte_Region => Node.Byte_Region,
- Parent => Parent,
- State => Unknown_State,
- Augmented => Node.Augmented,
- Identifier => Node.Identifier));
- end;
-
- when Nonterm =>
- declare
- Children : constant Valid_Node_Index_Array := Tree.Children
(Index);
- Parent : Node_Index :=
Invalid_Node_Index;
- New_Children : Valid_Node_Index_Arrays.Vector;
- begin
- if Children'Length > 0 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;
- end if;
-
- declare
- Node : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes
(Index);
- begin
- Tree.Shared_Tree.Nodes.Append
- ((Label => Nonterm,
- ID => Node.ID,
- Byte_Region => Node.Byte_Region,
- Parent => Parent,
- State => Unknown_State,
- Augmented => Node.Augmented,
- Virtual => Node.Virtual,
- RHS_Index => Node.RHS_Index,
- Action => Node.Action,
- Name => Node.Name,
- Children => New_Children,
- Min_Terminal_Index => Node.Min_Terminal_Index));
- end;
-
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- Parent := Tree.Last_Shared_Node;
- for I in New_Children.First_Index .. New_Children.Last_Index
loop
- Tree.Shared_Tree.Nodes (New_Children (I)).Parent := Parent;
- end loop;
-
- return Parent;
- end;
- end case;
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- return Tree.Last_Shared_Node;
- end Copy_Node;
-
- begin
- return Copy_Node (Tree, Root, Invalid_Node_Index);
- end Copy_Subtree;
-
- function Count_IDs
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return SAL.Base_Peek_Type
- is
- function Compute (N : in Syntax_Trees.Node) return SAL.Base_Peek_Type
- is
- use all type SAL.Base_Peek_Type;
- begin
- return Result : SAL.Base_Peek_Type := 0 do
- if N.ID = ID then
- Result := 1;
- end if;
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- 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;
- end return;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Count_IDs;
-
- function Count_Terminals
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Integer
- -- Count_Terminals must return Integer for Get_Terminals,
- -- Positive_Index_Type for Get_Terminal_IDs.
- is
- function Compute (N : in Syntax_Trees.Node) return Integer
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- return 1;
-
- when Nonterm =>
- return Result : Integer := 0 do
- 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;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Count_Terminals;
-
- 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;
- Tree.Parents_Set := False;
- if Tree.Augmented_Present then
- for Node of Tree.Nodes loop
- if Node.Label = Nonterm then
- Free (Node.Augmented);
- end if;
- end loop;
- Tree.Augmented_Present := False;
- end if;
- Tree.Nodes.Finalize;
- end Finalize;
-
- overriding procedure Finalize (Tree : in out Syntax_Trees.Tree)
- is begin
- if Tree.Last_Shared_Node /= Invalid_Node_Index then
- -- Tree.Branched_Nodes Augmented are shallow copies of
- -- Tree.Shared_Tree.Nodes Augmented, so we don't free them there;
- -- they are freed in Base_Tree.Finalize above.
- Tree.Branched_Nodes.Finalize;
- Tree.Last_Shared_Node := Invalid_Node_Index;
- Tree.Shared_Tree := null;
- end if;
- end Finalize;
-
- function Insert_After
- (User_Data : in out User_Data_Type;
- Tree : in Syntax_Trees.Tree'Class;
- Token : in Valid_Node_Index;
- Insert_On_Blank_Line : in Boolean)
- return Boolean
- is
- pragma Unreferenced (User_Data, Tree, Token, Insert_On_Blank_Line);
- begin
- return False;
- end Insert_After;
-
- function Find_Ancestor
- (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;
- Last_Parent : Node_Index := Invalid_Node_Index;
- begin
- loop
- N :=
- (if N <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (N).Parent
- else Tree.Branched_Nodes (N).Parent);
-
- exit when N = Invalid_Node_Index;
- 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 (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;
- Max_Parent : in Boolean := False)
- return Node_Index
- is
- N : Node_Index := Node;
- Last_Parent : Node_Index := Invalid_Node_Index;
- begin
- loop
- N :=
- (if N <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (N).Parent
- else Tree.Branched_Nodes (N).Parent);
-
- exit when N = Invalid_Node_Index;
- 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 (if Max_Parent then Last_Parent else N);
- end Find_Ancestor;
-
- function Find_Child
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- is
- function Compute (N : in Syntax_Trees.Node) return Node_Index
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- return Invalid_Node_Index;
- when Nonterm =>
- for C of N.Children loop
- 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;
- end case;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Find_Child;
-
- function Find_Descendant
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- is
- Found : Node_Index := Invalid_Node_Index;
-
- function Process (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is
- Node_ID : constant Token_ID :=
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).ID
- else Tree.Branched_Nodes (Node).ID);
- begin
- if Node_ID = ID then
- Found := Node;
- return False;
- else
- return True;
- end if;
- end Process;
-
- Junk : constant Boolean := Process_Tree (Tree, Node, Before,
Process'Access);
- pragma Unreferenced (Junk);
- begin
- return Found;
- end Find_Descendant;
-
- function Find_Descendant
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Predicate : access function (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean)
- return Node_Index
- is
- Found : Node_Index := Invalid_Node_Index;
-
- function Process (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is begin
- if Predicate (Tree, Node) then
- Found := Node;
- return False;
- else
- return True;
- end if;
- end Process;
-
- Junk : constant Boolean := Process_Tree (Tree, Node, Before,
Process'Access);
- pragma Unreferenced (Junk);
- begin
- return Found;
- end Find_Descendant;
-
- function Find_Sibling
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- is
- function Compute_2 (N : in Syntax_Trees.Node) return Node_Index
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- return Invalid_Node_Index;
-
- when Nonterm =>
- for C of N.Children loop
- 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;
- end case;
- end Compute_2;
-
- function Compute_1 (Parent : in Node_Index) return Node_Index
- is begin
- if Parent = Invalid_Node_Index then
- return Invalid_Node_Index;
-
- else
- return Compute_2
- ((if Parent <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Parent)
- else Tree.Branched_Nodes (Parent)));
- end if;
- end Compute_1;
- begin
- return Compute_1
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).Parent
- else Tree.Branched_Nodes (Node).Parent));
- end Find_Sibling;
-
- function First_Index (Tree : in Syntax_Trees.Tree) return Node_Index
- is begin
- return Tree.Shared_Tree.Nodes.First_Index;
- end First_Index;
-
- procedure Flush (Tree : in out Syntax_Trees.Tree)
- is begin
- -- This is the opposite of Move_Branch_Point
- Tree.Shared_Tree.Nodes.Merge (Tree.Branched_Nodes);
- Tree.Last_Shared_Node := Tree.Shared_Tree.Nodes.Last_Index;
- Tree.Flush := True;
- end Flush;
-
- function Flushed (Tree : in Syntax_Trees.Tree) return Boolean
- is begin
- return Tree.Flush;
- end Flushed;
-
- procedure Get_IDs
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID;
- Result : in out Valid_Node_Index_Array;
- Last : in out SAL.Base_Peek_Type)
- is
- use all type SAL.Base_Peek_Type;
-
- procedure Compute (N : in Syntax_Trees.Node)
- is begin
- if N.ID = ID then
- Last := Last + 1;
- Result (Last) := Node;
- end if;
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- 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;
- end Compute;
- begin
- Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Get_IDs;
-
- function Get_IDs
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Valid_Node_Index_Array
- is
- Last : SAL.Base_Peek_Type := 0;
- begin
- Tree.Shared_Tree.Traversing := True;
- return Result : Valid_Node_Index_Array (1 .. Count_IDs (Tree, Node, ID))
do
- Get_IDs (Tree, Node, ID, Result, Last);
- Tree.Shared_Tree.Traversing := False;
- end return;
- end Get_IDs;
-
- procedure Get_Terminals
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Result : in out Valid_Node_Index_Array;
- Last : in out SAL.Base_Peek_Type)
- is
- use all type SAL.Base_Peek_Type;
-
- procedure Compute (N : in Syntax_Trees.Node)
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- Last := Last + 1;
- Result (Last) := Node;
-
- when Nonterm =>
- 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;
- begin
- Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Get_Terminals;
-
- function Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index_Array
- is
- Last : SAL.Base_Peek_Type := 0;
- begin
- Tree.Shared_Tree.Traversing := True;
- return Result : Valid_Node_Index_Array (1 .. SAL.Base_Peek_Type
(Count_Terminals (Tree, Node))) do
- Get_Terminals (Tree, Node, Result, Last);
- Tree.Shared_Tree.Traversing := False;
- end return;
- end Get_Terminals;
-
- function First_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Node_Index
- is
- function Compute (Index : in Valid_Node_Index; N : in Syntax_Trees.Node)
return Node_Index
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- 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
- if Term /= Invalid_Node_Index then
- return Term;
- end if;
- end;
- end loop;
- return Invalid_Node_Index;
- end case;
- end Compute;
- begin
- return Compute
- (Node,
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end First_Terminal;
-
- procedure Get_Terminal_IDs
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Result : in out Token_ID_Array;
- Last : in out SAL.Base_Peek_Type)
- is
- procedure Compute (N : in Syntax_Trees.Node)
- is
- use all type SAL.Base_Peek_Type;
- begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- Last := Last + 1;
- Result (Integer (Last)) := N.ID;
-
- 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;
- end Compute;
- begin
- Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Get_Terminal_IDs;
-
- function Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID_Array
- is
- Last : SAL.Base_Peek_Type := 0;
- begin
- Tree.Shared_Tree.Traversing := True;
- return Result : Token_ID_Array (1 .. Count_Terminals (Tree, Node)) do
- Get_Terminal_IDs (Tree, Node, Result, Last);
- Tree.Shared_Tree.Traversing := False;
- end return;
- end Get_Terminal_IDs;
-
- function First_Shared_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index
- is
- function Compute (N : in Syntax_Trees.Node) return Base_Token_Index
- is begin
- return
- (case N.Label is
- when Shared_Terminal => N.Terminal,
- when Virtual_Terminal |
- Virtual_Identifier => Invalid_Token_Index,
- when Nonterm => N.Min_Terminal_Index);
- end Compute;
-
- begin
- if Node <= Tree.Last_Shared_Node then
- return Compute (Tree.Shared_Tree.Nodes (Node));
- else
- return Compute (Tree.Branched_Nodes (Node));
- end if;
- end First_Shared_Terminal;
-
- function First_Terminal_ID (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID
- is
- function Compute (N : in Syntax_Trees.Node) return Token_ID
- is begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- return N.ID;
-
- 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
- if ID /= Invalid_Token_ID then
- return ID;
- end if;
- end;
- end loop;
- return Invalid_Token_ID;
- end case;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end First_Terminal_ID;
-
- function Has_Branched_Nodes (Tree : in Syntax_Trees.Tree) return Boolean
- is begin
- 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
- return Tree.Shared_Tree.Nodes (Node).Children.Length > 0;
- else
- return Tree.Branched_Nodes (Node).Children.Length > 0;
- end if;
- end Has_Children;
-
- function Has_Parent (Tree : in Syntax_Trees.Tree; Child : in
Valid_Node_Index) return Boolean
- is begin
- return
- (if Child <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Child).Parent /= Invalid_Node_Index
- else Tree.Branched_Nodes (Child).Parent /= Invalid_Node_Index);
- end Has_Parent;
-
- function Has_Parent (Tree : in Syntax_Trees.Tree; Children : in
Valid_Node_Index_Array) return Boolean
- is begin
- return
- (for some Child of Children =>
- (if Child <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Child).Parent /= Invalid_Node_Index
- else Tree.Branched_Nodes (Child).Parent /= Invalid_Node_Index));
- end Has_Parent;
-
- function ID
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Token_ID
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).ID
- else Tree.Branched_Nodes (Node).ID);
- end ID;
-
- function Identifier (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Identifier_Index
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).Identifier
- else Tree.Branched_Nodes (Node).Identifier);
- end Identifier;
-
- function Image
- (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;
- Result : Unbounded_String := +"(";
- Need_Comma : Boolean := False;
- begin
- for I of Children loop
- Result := Result & (if Need_Comma then ", " else "") &
- (if I = Deleted_Child
- then "-"
- else Tree.Image (I, Descriptor, Include_Children => False,
Node_Numbers => Node_Numbers));
- Need_Comma := True;
- end loop;
- Result := Result & ")";
- return -Result;
- end Image;
-
- 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;
- Node_Numbers : in Boolean := False)
- return String
- is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := +(if Node_Numbers then Image (Node_Index) &
":" else "");
- begin
- case N.Label is
- when Shared_Terminal =>
- Result := Result & Trimmed_Image (N.Terminal) & ":";
-
- when Virtual_Identifier =>
- Result := Result & Trimmed_Image (N.Identifier) & ";";
-
- when others =>
- null;
- end case;
-
- Result := Result & "(" & Image (N.ID, Descriptor) &
- (if Include_RHS_Index and N.Label = Nonterm then "_" & Trimmed_Image
(N.RHS_Index) else "") &
- (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,
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;
- 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)),
- Node, Descriptor, Include_Children, Include_RHS_Index, Node_Numbers);
- end Image;
-
- function Image
- (Tree : in Syntax_Trees.Tree;
- Nodes : in Valid_Node_Index_Array;
- Descriptor : in WisiToken.Descriptor)
- return String
- is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String := +"(";
- Need_Comma : Boolean := False;
- begin
- for I in Nodes'Range loop
- Result := Result & (if Need_Comma then ", " else "") &
- Tree.Image (Nodes (I), Descriptor);
- Need_Comma := True;
- end loop;
- Result := Result & ")";
- return -Result;
- end Image;
-
- function Image
- (Item : in Node_Sets.Vector;
- Inverted : in Boolean := False)
- return String
- is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String;
- begin
- for I in Item.First_Index .. Item.Last_Index loop
- if (if Inverted then not Item (I) else Item (I)) then
- Result := Result & Node_Index'Image (I);
- end if;
- end loop;
- return -Result;
- end Image;
-
- procedure Initialize
- (Branched_Tree : in out Syntax_Trees.Tree;
- Shared_Tree : in Base_Tree_Access;
- Flush : in Boolean;
- Set_Parents : in Boolean := False)
- is begin
- Branched_Tree :=
- (Ada.Finalization.Controlled with
- Shared_Tree => Shared_Tree,
- Last_Shared_Node => Shared_Tree.Nodes.Last_Index,
- Branched_Nodes => <>,
- Flush => Flush,
- Root => <>);
-
- Branched_Tree.Shared_Tree.Parents_Set := Set_Parents;
- end Initialize;
-
- 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
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Label = Nonterm;
- else
- return Tree.Branched_Nodes (Node).Label = Nonterm;
- end if;
- end Is_Nonterm;
-
- function Is_Shared_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Label = Shared_Terminal;
- else
- return Tree.Branched_Nodes (Node).Label = Shared_Terminal;
- end if;
- end Is_Shared_Terminal;
-
- function Is_Virtual_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Label = Virtual_Terminal;
- else
- return Tree.Branched_Nodes (Node).Label = Virtual_Terminal;
- end if;
- end Is_Virtual_Terminal;
-
- function Is_Virtual (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is
- function Compute (N : in Syntax_Trees.Node) return Boolean
- is begin
- return N.Label = Virtual_Terminal or (N.Label = Nonterm and then
N.Virtual);
- end Compute;
- begin
- if Node <= Tree.Last_Shared_Node then
- return Compute (Tree.Shared_Tree.Nodes (Node));
- else
- return Compute (Tree.Branched_Nodes (Node));
- end if;
- end Is_Virtual;
-
- function Is_Virtual_Identifier (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).Label = Virtual_Identifier
- else Tree.Branched_Nodes (Node).Label = Virtual_Identifier);
- end Is_Virtual_Identifier;
-
- function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Label
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).Label;
- else
- return Tree.Branched_Nodes (Node).Label;
- end if;
- end Label;
-
- function Last_Index (Tree : in Syntax_Trees.Tree) return Node_Index
- is begin
- return
- (if Tree.Flush
- then Tree.Shared_Tree.Nodes.Last_Index
- else Tree.Branched_Nodes.Last_Index);
- end Last_Index;
-
- function Last_Shared_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index
- is
- -- Max_Terminal_Index is not cached, because it is not needed in
recover.
-
- function Compute (N : in Syntax_Trees.Node) return Base_Token_Index
- is begin
- case N.Label is
- when Shared_Terminal =>
- return N.Terminal;
-
- when Virtual_Terminal | Virtual_Identifier =>
- return Invalid_Token_Index;
-
- 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
- if Last_Term /= Invalid_Token_Index then
- return Last_Term;
- end if;
- end;
- end loop;
- return Invalid_Token_Index;
- end case;
- end Compute;
-
- begin
- if Node <= Tree.Last_Shared_Node then
- return Compute (Tree.Shared_Tree.Nodes (Node));
- else
- return Compute (Tree.Branched_Nodes (Node));
- end if;
- end Last_Shared_Terminal;
-
- function Last_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Node_Index
- is
- N : constant Node_Const_Ref := Tree.Get_Node_Const_Ref (Node);
- begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- 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
- if Term /= Invalid_Node_Index then
- return Term;
- end if;
- end;
- end loop;
- return Invalid_Node_Index;
- end case;
- end Last_Terminal;
-
- function Min_Descendant (Nodes : in Node_Arrays.Vector; Node : in
Valid_Node_Index) return Valid_Node_Index
- is
- N : Syntax_Trees.Node renames Nodes (Node);
- begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- return Node;
-
- when Nonterm =>
- declare
- 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;
- end;
- end case;
- end Min_Descendant;
-
- procedure Move_Branch_Point (Tree : in out Syntax_Trees.Tree; Required_Node
: in Valid_Node_Index)
- is begin
- -- Note that this preserves all stored indices in Branched_Nodes.
- Tree.Branched_Nodes.Prepend (Tree.Shared_Tree.Nodes, Required_Node,
Tree.Last_Shared_Node);
- Tree.Last_Shared_Node := Required_Node - 1;
- end Move_Branch_Point;
-
- function Next_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Node_Index
- is
- use Valid_Node_Index_Arrays;
- use all type SAL.Base_Peek_Type;
-
- function First_Child (Node : in Valid_Node_Index) return Node_Index
- is
- N : Node_Const_Ref renames Tree.Get_Node_Const_Ref (Node);
- begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- return Node;
- 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
- if Result /= Invalid_Node_Index then
- return Result;
- end if;
- end;
- end loop;
- -- All Children are empty
- return Invalid_Node_Index;
- end case;
- end First_Child;
-
- function Next_Child (Child : in Valid_Node_Index; Node : in Node_Index)
return Node_Index
- is begin
- -- Node is Parent of Child; return node immediately after Child.
- if Node = Invalid_Node_Index then
- return Invalid_Node_Index;
- else
- declare
- N : Node_Const_Ref renames Tree.Get_Node_Const_Ref (Node);
- 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
- declare
- Result : constant Node_Index := First_Child
(N.Children (J));
- begin
- if Result /= Invalid_Node_Index then
- return Result;
- end if;
- end;
- end loop;
- -- All next Children are empty
- return Next_Child (Node, N.Parent);
- end if;
- end loop;
- raise SAL.Programmer_Error;
- end;
- end if;
- end Next_Child;
-
- N : Node_Const_Ref renames Get_Node_Const_Ref (Tree, Node);
- begin
- return Next_Child (Node, N.Parent);
- end Next_Terminal;
-
- function Parent
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Count : in Positive := 1)
- return Node_Index
- is
- Result : Node_Index := Node;
- N : Natural := 0;
- begin
- loop
- if Result <= Tree.Last_Shared_Node then
- Result := Tree.Shared_Tree.Nodes (Result).Parent;
- else
- Result := Tree.Branched_Nodes (Result).Parent;
- end if;
- N := N + 1;
- exit when N = Count or Result = Invalid_Node_Index;
- end loop;
- return Result;
- end Parent;
-
- function Prev_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Node_Index
- is
- use Valid_Node_Index_Arrays;
- use all type SAL.Base_Peek_Type;
-
- function Last_Child (Node : in Valid_Node_Index) return Node_Index
- is
- N : Node_Const_Ref renames Tree.Get_Node_Const_Ref (Node);
- begin
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- return Node;
- 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
- if Result /= Invalid_Node_Index then
- return Result;
- end if;
- end;
- end loop;
- -- All Children are empty
- return Invalid_Node_Index;
- end case;
- end Last_Child;
-
- function Prev_Child (Child : in Valid_Node_Index; Node : in Node_Index)
return Node_Index
- is begin
- -- Node is Parent of Child; return node immediately previous to
Child.
- if Node = Invalid_Node_Index then
- return Invalid_Node_Index;
- else
- declare
- N : Node_Const_Ref renames Tree.Get_Node_Const_Ref (Node);
- 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
- declare
- Result : constant Node_Index := Last_Child
(N.Children (J));
- begin
- if Result /= Invalid_Node_Index then
- return Result;
- end if;
- end;
- end loop;
- -- All previous Children are empty
- return Prev_Child (Node, N.Parent);
- end if;
- end loop;
- raise SAL.Programmer_Error;
- end;
- end if;
- end Prev_Child;
-
- N : Node_Const_Ref renames Get_Node_Const_Ref (Tree, Node);
- begin
- return Prev_Child (Node, N.Parent);
- end Prev_Terminal;
-
- 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_Action : in Syntax_Trees.Image_Action := null)
- is
- use Ada.Text_IO;
-
- Node_Printed : Node_Sets.Vector;
-
- procedure Print_Node (Node : in Valid_Node_Index; Level : in Integer)
- is
- function Image is new SAL.Generic_Decimal_Image (Node_Index);
-
- N : Syntax_Trees.Node renames Tree.Shared_Tree.Nodes (Node);
- begin
- 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; loop:"
& Node_Index'Image (Node);
- else
- Node_Printed (Node) := True;
- end if;
-
- Put (Image (Node, Width => 4) & ": ");
- for I in 1 .. Level loop
- Put ("| ");
- end loop;
- 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
- 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);
- 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
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Visit_Parent : in Visit_Parent_Mode;
- Process_Node : access function
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Boolean)
- return Boolean
- is
- function Compute (N : in Syntax_Trees.Node) return Boolean
- is begin
- if Visit_Parent = Before then
- if not Process_Node (Tree, Node) then
- return False;
- end if;
- end if;
-
- if N.Label = Nonterm then
- for Child of N.Children loop
- if 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;
-
- if Visit_Parent = After then
- return Process_Node (Tree, Node);
- else
- return True;
- end if;
- end Compute;
- begin
- if Node <= Tree.Last_Shared_Node then
- return Compute (Tree.Shared_Tree.Nodes (Node));
- else
- return Compute (Tree.Branched_Nodes (Node));
- end if;
- end Process_Tree;
-
- procedure Process_Tree
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Process_Node : access procedure
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index))
- is
- procedure Compute (N : in Syntax_Trees.Node)
- is begin
- if N.Label = Nonterm then
- for Child of N.Children loop
- if Child /= Deleted_Child then
- Process_Tree (Tree, Child, Process_Node);
- end if;
- end loop;
- end if;
-
- Process_Node (Tree, Node);
- end Compute;
- begin
- if Node <= Tree.Last_Shared_Node then
- Compute (Tree.Shared_Tree.Nodes (Node));
- else
- Compute (Tree.Branched_Nodes (Node));
- end if;
- end Process_Tree;
-
- procedure Process_Tree
- (Tree : in out Syntax_Trees.Tree;
- Process_Node : access procedure
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index);
- Root : in Node_Index := Invalid_Node_Index)
- is begin
- 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;
- exception
- when others =>
- Tree.Shared_Tree.Traversing := False;
- raise;
- end Process_Tree;
-
- function Production_ID
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Production_ID
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then (Tree.Shared_Tree.Nodes (Node).ID, Tree.Shared_Tree.Nodes
(Node).RHS_Index)
- 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)
- return Natural
- is begin
- return
- (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node).RHS_Index
- 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;
- ID : in Token_ID;
- Identifier : in Identifier_Index)
- 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,
- ID => ID,
- Identifier => Identifier,
- Byte_Region => Current.Byte_Region,
- Parent => Current.Parent,
- State => Unknown_State,
- Augmented => null));
- end Set_Node_Identifier;
-
- procedure Set_Parents (Tree : in out Syntax_Trees.Tree)
- is
- procedure Set_Parents
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Parent : in Node_Index)
- is
- N : Node_Var_Ref renames Tree.Get_Node_Var_Ref (Node);
- begin
- N.Parent := Parent;
- case N.Label is
- when Shared_Terminal | Virtual_Terminal | Virtual_Identifier =>
- null;
-
- 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;
- end Set_Parents;
- begin
- Set_Parents (Tree, Root (Tree), Invalid_Node_Index);
- Tree.Shared_Tree.Parents_Set := True;
- end Set_Parents;
-
- procedure Set_Root (Tree : in out Syntax_Trees.Tree; Root : in
Valid_Node_Index)
- is begin
- Tree.Root := Root;
- end Set_Root;
-
- function Same_Token
- (Tree_1 : in Syntax_Trees.Tree'Class;
- Index_1 : in Valid_Node_Index;
- Tree_2 : in Syntax_Trees.Tree'Class;
- Index_2 : in Valid_Node_Index)
- return Boolean
- is
- function Compute (N_1, N_2 : in Syntax_Trees.Node) return Boolean
- is begin
- return N_1.Label = N_2.Label and
- N_1.ID = N_2.ID and
- N_1.Byte_Region = N_2.Byte_Region;
- end Compute;
- begin
- return Compute
- ((if Index_1 <= Tree_1.Last_Shared_Node
- then Tree_1.Shared_Tree.Nodes (Index_1)
- else Tree_1.Branched_Nodes (Index_1)),
- (if Index_2 <= Tree_2.Last_Shared_Node
- then Tree_2.Shared_Tree.Nodes (Index_2)
- else Tree_2.Branched_Nodes (Index_2)));
- end Same_Token;
-
- procedure Set_Augmented
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Value : in Base_Token_Class_Access)
- is begin
- if Node <= Tree.Last_Shared_Node then
- Tree.Shared_Tree.Nodes (Node).Augmented := Value;
- else
- Tree.Branched_Nodes (Node).Augmented := Value;
- end if;
- Tree.Shared_Tree.Augmented_Present := True;
- end Set_Augmented;
-
- procedure Set_Children
- (Tree : in out Syntax_Trees.Tree;
- Parent : in Valid_Node_Index;
- Children : in Valid_Node_Index_Array)
- is
- 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
- declare
- Child_Node : Node renames Tree.Shared_Tree.Nodes (Children (I));
- begin
- 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;
- end if;
-
- declare
- K : Node_Const_Ref renames Tree.Get_Node_Const_Ref (Children (I));
- begin
- N.Virtual := N.Virtual or
- (case K.Label is
- when Shared_Terminal => False,
- when Virtual_Terminal | Virtual_Identifier => True,
- when Nonterm => K.Virtual);
-
- if N.Byte_Region.First > K.Byte_Region.First then
- N.Byte_Region.First := K.Byte_Region.First;
- end if;
-
- if N.Byte_Region.Last < K.Byte_Region.Last then
- N.Byte_Region.Last := K.Byte_Region.Last;
- end if;
-
- if not Min_Terminal_Index_Set then
- case K.Label is
- when Shared_Terminal =>
- Min_Terminal_Index_Set := True;
- N.Min_Terminal_Index := K.Terminal;
-
- when Virtual_Terminal | Virtual_Identifier =>
- null;
-
- when Nonterm =>
- if K.Min_Terminal_Index /= Invalid_Token_Index then
- -- not an empty nonterm
- Min_Terminal_Index_Set := True;
- N.Min_Terminal_Index := K.Min_Terminal_Index;
- end if;
- end case;
- end if;
- end;
- end loop;
- end Set_Children;
-
- procedure Set_Children
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- New_ID : in WisiToken.Production_ID;
- Children : in Valid_Node_Index_Array)
- is
- 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;
-
- Set_Children (Tree, Node, Children);
- end Set_Children;
-
- procedure Set_State
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- State : in State_Index)
- is begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes (Node).State := State;
- else
- if Node <= Tree.Last_Shared_Node then
- Tree.Shared_Tree.Nodes (Node).State := State;
- else
- Tree.Branched_Nodes (Node).State := State;
- end if;
- end if;
- end Set_State;
-
- procedure Set_Flush_False (Tree : in out Syntax_Trees.Tree)
- is begin
- if Tree.Flush then
- Tree.Flush := False;
- Tree.Branched_Nodes.Set_First_Last (Tree.Last_Shared_Node + 1,
Tree.Last_Shared_Node);
- end if;
- end Set_Flush_False;
-
- procedure Set_Name_Region
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Region : in Buffer_Region)
- is begin
- if Tree.Flush then
- Tree.Shared_Tree.Nodes (Node).Name := Region;
-
- else
- if Node <= Tree.Last_Shared_Node then
- Move_Branch_Point (Tree, Node);
- end if;
-
- Tree.Branched_Nodes (Node).Name := Region;
- end if;
- end Set_Name_Region;
-
- function 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
- return Tree.Shared_Tree.Nodes (Node).Terminal;
- else
- return Tree.Branched_Nodes (Node).Terminal;
- end if;
- end Terminal;
-
- function Traversing (Tree : in Syntax_Trees.Tree) return Boolean
- is begin
- return Tree.Shared_Tree.Traversing;
- end Traversing;
-
- function Recover_Token
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Recover_Token
- is
- function Compute (N : Syntax_Trees.Node) return WisiToken.Recover_Token
- is begin
- case N.Label is
- when Shared_Terminal =>
- return
- (ID => N.ID,
- Byte_Region => N.Byte_Region,
- Min_Terminal_Index => N.Terminal,
- Name => Null_Buffer_Region,
- Virtual => False);
-
- when Virtual_Terminal | Virtual_Identifier =>
- return
- (ID => N.ID,
- Byte_Region => Null_Buffer_Region,
- Min_Terminal_Index => Invalid_Token_Index,
- Name => Null_Buffer_Region,
- Virtual => True);
-
- when Nonterm =>
- return
- (ID => N.ID,
- Byte_Region => N.Byte_Region,
- Min_Terminal_Index => N.Min_Terminal_Index,
- Name => N.Name,
- Virtual => N.Virtual);
- end case;
- end Compute;
- begin
- return Compute
- ((if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes (Node)
- else Tree.Branched_Nodes (Node)));
- end Recover_Token;
-
- function Recover_Token_Array
- (Tree : in Syntax_Trees.Tree;
- Nodes : in Valid_Node_Index_Array)
- return WisiToken.Recover_Token_Array
- is begin
- return Result : WisiToken.Recover_Token_Array (Nodes'First ..
Nodes'Last) do
- for I in Result'Range loop
- Result (I) := Tree.Recover_Token (Nodes (I));
- end loop;
- end return;
- end Recover_Token_Array;
-
- function State (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Unknown_State_Index
- is begin
- if Node <= Tree.Last_Shared_Node then
- return Tree.Shared_Tree.Nodes (Node).State;
- else
- return Tree.Branched_Nodes (Node).State;
- end if;
- end State;
-
- 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
deleted file mode 100644
index db29bac..0000000
--- a/packages/wisi/wisitoken-syntax_trees.ads
+++ /dev/null
@@ -1,805 +0,0 @@
--- Abstract :
---
--- Syntax tree type and operations.
---
--- Design :
---
--- There is one syntax tree for each parallel parser. There is one
--- shared Terminals array (provided by the master parser), matching
--- the actual input text.
---
--- Node contains a Parent component, to make it easy to traverse the
--- tree in any direction. However, we do not set the Parent nodes
--- while parsing, to simplify branching the syntax tree for parallel
--- parsing. When a new nonterm is added to a branched tree, if it set
--- the parent component of its children, it would first have to move
--- those children, and all intervening nodes, into the branched tree.
--- Since Shared_Terminals nodes are created before all other nodes
--- (when the lexer is run, to allow Lexer_To_Augmented to store info
--- in the node), that would mean every branched tree is a practically
--- complete copy of the entire tree, significantly slowing down
--- parsing (by a factor of 250 on ada-mode wisi.adb when we did this
--- by mistake!).
---
--- 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. 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
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Finalization;
-with SAL.Gen_Unbounded_Definite_Vectors;
-with WisiToken.Lexer;
-package WisiToken.Syntax_Trees is
-
- type Base_Tree is new Ada.Finalization.Controlled with private;
-
- type Base_Tree_Access is access all Base_Tree;
-
- overriding procedure Finalize (Tree : in out Base_Tree);
- -- Free any allocated storage.
-
- function Is_Empty (Tree : in Base_Tree) return Boolean;
-
- type Tree is new Ada.Finalization.Controlled with private;
-
- 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;
- 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);
- -- Free any allocated storage.
-
- type Node_Label is
- (Shared_Terminal, -- text is user input, accessed via Parser.Terminals
- Virtual_Terminal, -- no text; inserted during error recovery
- Virtual_Identifier, -- text in user data, created during tree rewrite
- Nonterm -- contains terminals/nonterminals/identifiers
- );
-
- type User_Data_Type is tagged limited null record;
- -- Many test languages don't need this, so we default the procedures
- -- to null.
-
- type User_Data_Access is access all User_Data_Type'Class;
-
- procedure Set_Lexer_Terminals
- (User_Data : in out User_Data_Type;
- Lexer : in WisiToken.Lexer.Handle;
- Terminals : in Base_Token_Array_Access_Constant)
- is null;
-
- procedure Reset (User_Data : in out User_Data_Type) is null;
- -- Reset to start a new parse.
-
- procedure Initialize_Actions
- (User_Data : in out User_Data_Type;
- Tree : in Syntax_Trees.Tree'Class)
- is null;
- -- Called by Execute_Actions, before processing the tree.
-
- procedure Lexer_To_Augmented
- (User_Data : in out User_Data_Type;
- Tree : in out Syntax_Trees.Tree'Class;
- Token : in Base_Token;
- Lexer : not null access WisiToken.Lexer.Instance'Class)
- is null;
- -- Read auxiliary data from Lexer, do something useful with it.
- -- Called before parsing, once for each token in the input stream. If
- -- Token is a grammar token, client can use Tree.Set_Augmented
- -- (Token.Tree_Node).
-
- function Insert_After
- (User_Data : in out User_Data_Type;
- Tree : in Syntax_Trees.Tree'Class;
- Token : in Valid_Node_Index;
- Insert_On_Blank_Line : in Boolean)
- return Boolean;
- -- Return True if ID should be treated as if inserted after the
- -- previous shared terminal, rather than before the next (which is
- -- the default). This can affect which line it appears on, which
- -- affects indentation. Called from Insert_Token.
- --
- -- The default implementation always returns False.
-
- procedure Insert_Token
- (User_Data : in out User_Data_Type;
- Tree : in out Syntax_Trees.Tree'Class;
- Token : in Valid_Node_Index)
- is null;
- -- Token was inserted in error recovery; update other tokens and Tree
- -- as needed. Called from Execute_Actions for each inserted token,
- -- before processing the syntax tree.
-
- procedure Delete_Token
- (User_Data : in out User_Data_Type;
- Tree : in out Syntax_Trees.Tree'Class;
- Token_Index : in WisiToken.Token_Index)
- is null;
- -- Token at Token_Index was deleted in error recovery; update
- -- remaining tokens as needed. Called from Execute_Actions for each
- -- deleted token, before processing the syntax tree.
-
- procedure Reduce
- (User_Data : in out User_Data_Type;
- Tree : in out Syntax_Trees.Tree'Class;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array)
- is null;
- -- Reduce Tokens to Nonterm. Nonterm.Byte_Region is computed by
- -- caller.
-
- type Semantic_Action is access procedure
- (User_Data : in out User_Data_Type'Class;
- Tree : in out Syntax_Trees.Tree;
- Nonterm : in Valid_Node_Index;
- Tokens : in Valid_Node_Index_Array);
- -- Routines of this type are called by
- -- WisiToken.LR.Parser.Execute_Actions when it processes a Nonterm
- -- node in the syntax tree. Tokens are the children of Nonterm.
-
- Null_Action : constant Semantic_Action := null;
-
- procedure Clear (Tree : in out Syntax_Trees.Base_Tree);
- procedure Clear (Tree : in out Syntax_Trees.Tree);
- -- Delete all Elements and free associated memory; keep results of
- -- Initialize.
-
- procedure Flush (Tree : in out Syntax_Trees.Tree);
- -- Move all nodes in branched part to shared tree, set Flush mode
- -- True.
-
- procedure Set_Flush_False (Tree : in out Syntax_Trees.Tree);
- -- Set Flush mode False; use Flush to set True.
-
- function Flushed (Tree : in Syntax_Trees.Tree) return Boolean;
-
- function Copy_Subtree
- (Tree : in out Syntax_Trees.Tree;
- 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. 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, Action).
-
- function Add_Nonterm
- (Tree : in out Syntax_Trees.Tree;
- Production : in Production_ID;
- Children : in Valid_Node_Index_Array;
- Action : in Semantic_Action := null;
- Default_Virtual : in Boolean := False)
- return Valid_Node_Index
- 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;
- Terminal : in Token_Index;
- Terminals : in Base_Token_Arrays.Vector)
- return Valid_Node_Index
- with Pre => not Tree.Traversing;
- -- Add a new Terminal node. Terminal must be an index into Terminals.
- -- Result points to the added node.
-
- function Add_Terminal
- (Tree : in out Syntax_Trees.Tree;
- Terminal : in Token_ID;
- Before : in Base_Token_Index := Invalid_Token_Index)
- return Valid_Node_Index
- with Pre => not Tree.Traversing;
- -- 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.
- -- Result points to the added node.
-
- function Before
- (Tree : in Syntax_Trees.Tree;
- Virtual_Terminal : in Valid_Node_Index)
- return Base_Token_Index
- with Pre => Tree.Is_Virtual_Terminal (Virtual_Terminal);
-
- function Add_Identifier
- (Tree : in out Syntax_Trees.Tree;
- ID : in Token_ID;
- Identifier : in Identifier_Index;
- Byte_Region : in WisiToken.Buffer_Region)
- return Valid_Node_Index
- with Pre => Tree.Flushed and (not Tree.Traversing);
- -- Add a new Virtual_Identifier node with no parent. Byte_Region
- -- should point to an area in the source buffer related to the new
- -- identifier, to aid debugging. Result points to the added node.
-
- procedure Add_Child
- (Tree : in out Syntax_Trees.Tree;
- Parent : in Valid_Node_Index;
- Child : in Valid_Node_Index)
- with
- Pre => Tree.Flushed and Tree.Parents_Set and (not Tree.Traversing) and
- Tree.Is_Nonterm (Parent);
- -- 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;
- Node : in Valid_Node_Index;
- 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) 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.
- --
- -- 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 Tree.Parents_Set and (not Tree.Traversing) and
- Tree.Is_Nonterm (Node);
- -- 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;
- Node : in Valid_Node_Index;
- State : in State_Index);
-
- function State (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Unknown_State_Index;
-
- function Label (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Node_Label;
-
- function 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;
- Node : in Valid_Node_Index;
- Child_Index : in Positive_Index_Type)
- return Node_Index
- 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
- 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 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;
-
- function Is_Virtual (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
- -- Virtual_Terminal, Virtual_Identifier, or Nonterm that contains some
Virtual tokens.
-
- function Is_Virtual_Identifier (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean;
- function Traversing (Tree : in Syntax_Trees.Tree) return Boolean;
-
- function Parents_Set (Tree : in Syntax_Trees.Tree) return Boolean;
- procedure Set_Parents (Tree : in out Syntax_Trees.Tree)
- with Pre => Tree.Flushed and Tree.Root /= Invalid_Node_Index;
-
- function Parent
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Count : in Positive := 1)
- return Node_Index
- with Pre => Tree.Parents_Set;
- -- Return Count parent of Node.
-
- procedure Set_Name_Region
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Region : in Buffer_Region)
- with Pre => Tree.Is_Nonterm (Node);
-
- function ID
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Token_ID;
-
- function Production_ID
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Production_ID
- with Pre => Tree.Is_Nonterm (Node);
-
- function Byte_Region
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Buffer_Region;
-
- function RHS_Index
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Natural
- with Pre => Tree.Is_Nonterm (Node);
-
- function Same_Token
- (Tree_1 : in Syntax_Trees.Tree'Class;
- Index_1 : in Valid_Node_Index;
- Tree_2 : in Syntax_Trees.Tree'Class;
- Index_2 : in Valid_Node_Index)
- return Boolean;
- -- True if the two tokens have the same ID and Byte_Region.
-
- function Recover_Token
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return WisiToken.Recover_Token;
-
- function Recover_Token_Array
- (Tree : in Syntax_Trees.Tree;
- Nodes : in Valid_Node_Index_Array)
- return WisiToken.Recover_Token_Array;
-
- procedure Set_Augmented
- (Tree : in out Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Value : in Base_Token_Class_Access);
- -- Value will be deallocated when Tree is finalized.
-
- function Augmented
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Base_Token_Class_Access;
- -- Returns result of Set_Augmented.
-
- function Augmented_Const
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Base_Token_Class_Access_Constant;
-
- function Action
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Semantic_Action
- with Pre => Tree.Is_Nonterm (Node);
-
- function Find_Ancestor
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID;
- 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;
- Max_Parent : in Boolean := False)
- return Node_Index
- with Pre => Tree.Parents_Set;
- -- 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;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- with Pre => Tree.Parents_Set and then Tree.Has_Parent (Node);
- -- Return the sibling of Node that contains ID, or Invalid_Node_Index if
- -- none match.
-
- function Find_Child
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index
- with Pre => Tree.Is_Nonterm (Node);
- -- Return the child of Node whose ID is ID, or Invalid_Node_Index if
- -- none match.
-
- function Find_Descendant
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Node_Index;
- -- Return the descendant of Node (may be Node) whose ID is ID, or
- -- Invalid_Node_Index if none match.
-
- function Find_Descendant
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- Predicate : access function (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Boolean)
- return Node_Index;
- -- Return the descendant of Node (may be Node) for which Predicate
- -- returns True, or Invalid_Node_Index if none do.
-
- function 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.
- -- 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)
- 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.
-
- function Identifier (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Identifier_Index
- with Pre => Tree.Is_Virtual_Identifier (Node);
-
- function Terminal (Tree : in Syntax_Trees.Tree; Node : in Valid_Node_Index)
return Base_Token_Index
- with Pre => Tree.Is_Shared_Terminal (Node);
-
- function First_Shared_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index;
- -- Returns first shared terminal in subtree under Node
- -- (ignoring virtual terminals). If result is Invalid_Token_Index,
- -- all terminals are virtual, or a nonterm is empty.
-
- function Last_Shared_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Base_Token_Index;
- -- Returns last shared terminal in subtree under Node (ignoring
- -- virtual terminals). If result is Invalid_Token_Index, all
- -- terminals are virtual, or a nonterm is empty.
-
- function Get_Terminals (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Valid_Node_Index_Array;
- -- Return sequence of terminals in Node.
- --
- -- "Terminals" can be Shared_Terminal, Virtual_Terminal,
- -- Virtual_Identifier.
-
- function First_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Node_Index;
- -- First of Get_Terminals. Invalid_Node_Index if Node is an empty
nonterminal.
-
- function Last_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Node_Index;
- -- Last of Get_Terminals. Invalid_Node_Index if Node is an empty
nonterminal.
-
- function Prev_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Node_Index
- with Pre => Tree.Parents_Set and Tree.Label (Node) in Shared_Terminal |
Virtual_Terminal | Virtual_Identifier;
- -- Return the terminal that is immediately before Node in Tree;
- -- Invalid_Node_Index if Node is the first terminal in Tree.
-
- function Next_Terminal (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Node_Index
- with Pre => Tree.Parents_Set and Tree.Label (Node) in Shared_Terminal |
Virtual_Terminal | Virtual_Identifier;
- -- Return the terminal that is immediately after Node in Tree;
- -- Invalid_Node_Index if Node is the last terminal in Tree.
-
- function Get_Terminal_IDs (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID_Array;
- -- Same as Get_Terminals, but return the IDs.
-
- function First_Terminal_ID (Tree : in Syntax_Trees.Tree; Node : in
Valid_Node_Index) return Token_ID;
- -- First of Get_Terminal_IDs; Invalid_Token_ID if Node is empty.
-
- function Get_IDs
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index;
- ID : in Token_ID)
- return Valid_Node_Index_Array;
- -- 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;
- Include_RHS_Index : in Boolean := False;
- Node_Numbers : in Boolean := False)
- return String;
- function Image
- (Tree : in Syntax_Trees.Tree;
- Nodes : in Valid_Node_Index_Array;
- Descriptor : in WisiToken.Descriptor)
- return String;
- -- For debug and error messages.
-
- function First_Index (Tree : in Syntax_Trees.Tree) return Node_Index;
- function Last_Index (Tree : in Syntax_Trees.Tree) return Node_Index;
-
- package Node_Sets is new SAL.Gen_Unbounded_Definite_Vectors
(Valid_Node_Index, Boolean, Default_Element => False);
-
- function Image
- (Item : in Node_Sets.Vector;
- Inverted : in Boolean := False)
- 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_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,
- -- Image_Augmented is called if it is not null and node.augmented is
- -- not null.
-
-private
- use all type Ada.Containers.Count_Type;
-
- type Node (Label : Node_Label := Virtual_Terminal) is
- -- Label has a default to allow changing the label during tree editing.
- record
- ID : WisiToken.Token_ID := Invalid_Token_ID;
-
- Byte_Region : Buffer_Region := Null_Buffer_Region;
- -- Computed by Set_Children, used in Semantic_Check actions and debug
- -- messages.
-
- Parent : Node_Index := Invalid_Node_Index;
-
- State : Unknown_State_Index := Unknown_State;
- -- Parse state that was on stack with this token, to allow undoing a
- -- reduce.
-
- Augmented : Base_Token_Class_Access := null;
-
- case Label is
- when Shared_Terminal =>
- Terminal : Token_Index; -- into Parser.Terminals
-
- when Virtual_Terminal =>
- Before : Base_Token_Index := Invalid_Token_Index; -- into
Parser.Terminals
-
- when Virtual_Identifier =>
- Identifier : Identifier_Index; -- into user data
-
- when Nonterm =>
- Virtual : Boolean := False;
- -- True if any child node is Virtual_Terminal or Nonterm with Virtual
- -- set. Used by Semantic_Check actions.
-
- RHS_Index : Natural;
- -- With ID, index into Productions.
- -- Used for debug output, keep for future use.
-
- Action : Semantic_Action := null;
-
- Name : Buffer_Region := Null_Buffer_Region;
- -- Name is set and checked by Semantic_Check actions.
-
- Children : Valid_Node_Index_Arrays.Vector;
-
- Min_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
- -- Cached for push_back of nonterminals during recovery
- end case;
- end record;
-
- subtype Nonterm_Node is Node (Nonterm);
-
- package Node_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Valid_Node_Index, Node, Default_Element => (others => <>));
-
- type Base_Tree is new Ada.Finalization.Controlled with record
- Nodes : Node_Arrays.Vector;
- -- During normal parsing, tokens are added to Nodes by "parallel"
- -- LALR parsers, but they are all run from one Ada task, so there's
- -- no need for Nodes to be Protected. Packrat parsing also has a
- -- single Ada task.
- --
- -- During McKenzie_Recover, which has multiple Ada tasks, the syntax
- -- tree is read but not modified.
-
- Augmented_Present : Boolean := False;
- -- True if Set_Augmented has been called on any node. Declared in
- -- Base_Tree so it can be checked by Finalize (Base_Tree) and
- -- Finalize (Tree).
-
- Traversing : Boolean := False;
- -- True while traversing tree in Process_Tree.
- -- Declared in Base_Tree so it is cleared by Finalize.
-
- Parents_Set : Boolean := False;
- -- We don't set Node.Parent until after parse is done; see Design
- -- 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
- -- branch point instead, unless Flush = True.
-
- Last_Shared_Node : Node_Index := Invalid_Node_Index;
- Branched_Nodes : Node_Arrays.Vector;
- Flush : Boolean := False;
- -- If Flush is True, all nodes are in Shared_Tree. Otherwise, all
- -- greater than Last_Shared_Node are in Branched_Nodes.
- --
- -- We maintain Last_Shared_Node when Flush is True or False, so
- -- subprograms that have no reason to check Flush can rely on
- -- Last_Shared_Node.
-
- Root : Node_Index := Invalid_Node_Index;
- end record with
- Type_Invariant =>
- (Shared_Tree = null or else
- (if Tree.Flush
- then Last_Shared_Node = Shared_Tree.Nodes.Last_Index and
- Branched_Nodes.Length = 0
- else Last_Shared_Node <= Shared_Tree.Nodes.Last_Index and
- Last_Shared_Node < Branched_Nodes.First_Index));
-
- subtype Node_Const_Ref is Node_Arrays.Constant_Reference_Type;
- subtype Node_Var_Ref is Node_Arrays.Variable_Reference_Type;
-
- function Get_Node_Const_Ref
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Node_Const_Ref
- is (if Node <= Tree.Last_Shared_Node
- then Tree.Shared_Tree.Nodes.Constant_Ref (Node)
- else Tree.Branched_Nodes.Constant_Ref (Node));
-
- function Get_Node_Var_Ref
- (Tree : in Syntax_Trees.Tree;
- Node : in Valid_Node_Index)
- return Node_Var_Ref
- is (if Node <= Tree.Last_Shared_Node
- 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);
-
-end WisiToken.Syntax_Trees;
diff --git a/packages/wisi/wisitoken-text_io_trace.adb
b/packages/wisi/wisitoken-text_io_trace.adb
deleted file mode 100644
index 77fb331..0000000
--- a/packages/wisi/wisitoken-text_io_trace.adb
+++ /dev/null
@@ -1,113 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2017, 2019 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Calendar.Formatting;
-with Ada.Strings.Fixed;
-package body WisiToken.Text_IO_Trace is
-
- function Insert_Prefix_At_Newlines (Trace : in Text_IO_Trace.Trace; Item :
in String) return String
- is
- use Ada.Strings.Fixed;
- use Ada.Strings.Unbounded;
- Result : Unbounded_String;
- First : Integer := Item'First;
- Last : Integer;
- begin
- loop
- Last := Index (Pattern => "" & ASCII.LF, Source => Item (First ..
Item'Last));
- exit when Last = 0;
- Result := Result & Item (First .. Last) & Trace.Prefix;
- First := Last + 1;
- end loop;
- Result := Result & Item (First .. Item'Last);
- return -Result;
- end Insert_Prefix_At_Newlines;
-
- ----------
- -- Public subprograms, declaration order
-
- overriding
- procedure Set_Prefix (Trace : in out Text_IO_Trace.Trace; Prefix : in
String)
- is begin
- Trace.Prefix := +Prefix;
- end Set_Prefix;
-
- overriding
- procedure Put (Trace : in out Text_IO_Trace.Trace; Item : in String; Prefix
: in Boolean := True)
- is
- use Ada.Text_IO;
- begin
- if Trace.File /= null and then Is_Open (Trace.File.all) then
- Ada.Text_IO.Put (Trace.File.all, (if Prefix then -Trace.Prefix else
"") & Item);
- else
- Ada.Text_IO.Put ((if Prefix then -Trace.Prefix else "") & Item);
- end if;
- end Put;
-
- overriding
- procedure Put_Line (Trace : in out Text_IO_Trace.Trace; Item : in String)
- is
- use Ada.Strings.Fixed;
- use Ada.Text_IO;
- Temp : constant String :=
- (if 0 /= Index (Item, "" & ASCII.LF)
- then Insert_Prefix_At_Newlines (Trace, Item)
- else Item);
- begin
-
- if Trace.File /= null and then Is_Open (Trace.File.all) then
- Ada.Text_IO.Put_Line (Trace.File.all, -Trace.Prefix & Temp);
- Ada.Text_IO.Flush (Trace.File.all);
- else
- Ada.Text_IO.Put_Line (-Trace.Prefix & Temp);
- Ada.Text_IO.Flush;
- end if;
- end Put_Line;
-
- overriding
- procedure New_Line (Trace : in out Text_IO_Trace.Trace)
- is
- use Ada.Text_IO;
- begin
- if Trace.File /= null and then Is_Open (Trace.File.all) then
- Ada.Text_IO.New_Line (Trace.File.all);
- else
- Ada.Text_IO.New_Line;
- end if;
- end New_Line;
-
- overriding
- procedure Put_Clock (Trace : in out Text_IO_Trace.Trace; Label : in String)
- is begin
- Trace.Put_Line
- (Ada.Calendar.Formatting.Image
- (Ada.Calendar.Clock, Include_Time_Fraction => True) & " " & Label);
- end Put_Clock;
-
- procedure Set_File (Trace : in out Text_IO_Trace.Trace; File : in
Ada.Text_IO.File_Access)
- is begin
- Trace.File := File;
- end Set_File;
-
- procedure Clear_File (Trace : in out Text_IO_Trace.Trace)
- is begin
- Trace.File := null;
- end Clear_File;
-
-end WisiToken.Text_IO_Trace;
diff --git a/packages/wisi/wisitoken-text_io_trace.ads
b/packages/wisi/wisitoken-text_io_trace.ads
deleted file mode 100644
index b400c23..0000000
--- a/packages/wisi/wisitoken-text_io_trace.ads
+++ /dev/null
@@ -1,53 +0,0 @@
--- Abstract :
---
--- Trace output to Ada.Text_IO
---
--- Copyright (C) 2017, 2019, 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Text_IO;
-package WisiToken.Text_IO_Trace is
-
- type Trace is limited new WisiToken.Trace with private;
- -- Defaults to Ada.Text_IO.Standard_Output
-
- overriding
- procedure Set_Prefix (Trace : in out Text_IO_Trace.Trace; Prefix : in
String);
-
- overriding
- procedure Put (Trace : in out Text_IO_Trace.Trace; Item : in String; Prefix
: in Boolean := True);
-
- overriding
- procedure Put_Line (Trace : in out Text_IO_Trace.Trace; Item : in String);
- -- If Item contains ASCII.LF, Prefix is output after each one.
-
- overriding
- procedure New_Line (Trace : in out Text_IO_Trace.Trace);
-
- overriding
- procedure Put_Clock (Trace : in out Text_IO_Trace.Trace; Label : in String);
-
- procedure Set_File (Trace : in out Text_IO_Trace.Trace; File : in
Ada.Text_IO.File_Access);
- -- Set file for trace output. Default is Text_IO.Current_Output.
-
- procedure Clear_File (Trace : in out Text_IO_Trace.Trace);
- -- Clear internal file; output to Text_IO.Current_Output.
-
-private
- type Trace is limited new WisiToken.Trace with record
- File : Ada.Text_IO.File_Access;
- Prefix : Ada.Strings.Unbounded.Unbounded_String;
- end record;
-end WisiToken.Text_IO_Trace;
diff --git a/packages/wisi/wisitoken-to_tree_sitter.adb
b/packages/wisi/wisitoken-to_tree_sitter.adb
deleted file mode 100644
index 2213414..0000000
--- a/packages/wisi/wisitoken-to_tree_sitter.adb
+++ /dev/null
@@ -1,528 +0,0 @@
--- 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
deleted file mode 100644
index 7bbdb1b..0000000
--- a/packages/wisi/wisitoken-user_guide.info
+++ /dev/null
@@ -1,611 +0,0 @@
-This is wisitoken-user_guide.info, produced by makeinfo version 6.7 from
-wisitoken-user_guide.texinfo.
-
-Copyright (C) 2014-2015, 2017, 2018, 2020 Stephen Leake.
-
- Permission is granted to copy, distribute and/or modify this
- document under the terms of the GNU Free Documentation License,
- Version 1.3 or any later version published by the Free Software
- Foundation; with no Invariant Sections, no Front-Cover Texts and no
- Back-Cover Texts. A copy of the license is included in the section
- entitled "GNU Free Documentation License".
-INFO-DIR-SECTION Parser generators
-START-INFO-DIR-ENTRY
-* wisitoken-bnf-generate: (wisitoken-bnf-generate). Ada and Elisp
parser generator
-END-INFO-DIR-ENTRY
-
-
-File: wisitoken-user_guide.info, Node: Top, Next: Overview, Up: (dir)
-
-WisiToken User Guide
-********************
-
-Copyright (C) 2014-2015, 2017, 2018, 2020 Stephen Leake.
-
- Permission is granted to copy, distribute and/or modify this
- document under the terms of the GNU Free Documentation License,
- Version 1.3 or any later version published by the Free Software
- Foundation; with no Invariant Sections, no Front-Cover Texts and no
- Back-Cover Texts. A copy of the license is included in the section
- entitled "GNU Free Documentation License".
-
-* Menu:
-
-* Overview::
-* Common grammar problems::
-* Grammar File Syntax::
-
-
-File: wisitoken-user_guide.info, Node: Overview, Next: Common grammar
problems, Prev: Top, Up: Top
-
-1 Overview
-**********
-
-WisiToken is a parser and parser generator toolkit, supporting
-generalized LR (both LALR and LR1) and packrat parsers; the LR parser
-provides robust error recovery. The grammar can be expressed as either
-Ada source code statements, or in an EBNF file. The parser generator
-generates Ada, either plain or assuming the Emacs wisi package.
-
- At one point, "wisi" was short for "Wisent Indentation engine"; the
-Emacs 'wisi' package implements an indentation engine that used to be
-based on the Emacs wisent parser. However, that parser has now been
-replaced by the WisiToken parser, so "wisi" is just a name.
-
-* Menu:
-
-* Install::
-
-
-File: wisitoken-user_guide.info, Node: Install, Up: Overview
-
-1.1 Install
-===========
-
-WisiToken is available as source code only, although a subset is
-available in the GNU ELPA package 'wisi'.
-
- You will also need to install a lexer generator. WisiToken supports
-re2c, and other lexers can be added.
-
- re2c is available from <http://re2c.org/>; it is also packaged in
-Mingw64 and Debian. WisiToken requires at least version 1.3. WisiToken
-assumes the executable 're2c' is in '$PATH'.
-
-
-File: wisitoken-user_guide.info, Node: Common grammar problems, Next:
Grammar File Syntax, Prev: Overview, Up: Top
-
-2 Common grammar problems
-*************************
-
-LALR grammars are tricky. Here we describe some common problems people
-run into.
-
-* Menu:
-
-* Empty choice in list::
-
-
-File: wisitoken-user_guide.info, Node: Empty choice in list, Up: Common
grammar problems
-
-2.1 Empty choice in list
-========================
-
-Many programming languages have lists in the grammar. For example, Ada
-has lists of declarations:
-
- package_body
- : PACKAGE name IS declaration_list BEGIN statement_list END SEMICOLON
- ;
-
- declaration_list
- : declaration
- | declaration_list declaration
- ;
-
- declaration
- : object_declaration
- | subprogram_declaration
- ;; ...
- ;
-
- Note that the above grammar fragment does not allow an empty
-declaration_list. But Ada does, so the question is how can we add that
-to the grammar.
-
- There are four choices:
-
- 1. Add an empty declaration choice to declaration_list:
-
- declaration_list
- : ;; empty list
- | declaration
- | declaration_list declaration
- ;
- This is now redundant; since declaration_list can be empty, the
- second choice is not needed:
- declaration_list
- : ;; empty list
- | declaration_list declaration
- ;
-
- 2. Add an empty declaration choice to declaration:
-
- declaration
- : ;; empty declaration
- | object_declaration
- | subprogram_declaration
- ;; ...
- ;
-
- 3. Add another rule with the empty production:
-
- package_body
- : PACKAGE name IS declarative_part BEGIN statement_list END
SEMICOLON
- ;
-
- declarative_part
- : ;; empty
- | declaration_list
- ;
-
- declaration_list
- : declaration
- | declaration_list declaration
- ;
-
- declaration
- : object_declaration
- | subprogram_declaration
- ;; ...
- ;
-
- 4. Add another choice in package_body that leaves out
- declaration_list:
- package_body
- : PACKAGE name IS declaration_list BEGIN statement_list END
SEMICOLON
- | PACKAGE name IS BEGIN statement_list END SEMICOLON
- ;
-
- Choice 1 is redundant, giving parse errors at parse time. Consider
-the following statements, where "<empty>" is used to indicate an empty
-declaration:
-
- 1) package One is <empty> begin end ; 2) package One is package One
-is <empty> begin end ; begin end ; 3) package One is <empty> package One
-is <empty declaration> begin end ; begin end ;
-
- In parsing 3), the second 'package' causes a shift/reduce conflict;
-shift to start the nested declaration (as in 2), reduce to the empty
-declaration. Both are correct according to the grammar.
-
- Choice 2 leads to a shift/reduce conflict in the production for
-package_body; implementing the wisi parser as a generalized LALR parser
-allows it to handle this option.
-
- Choice 2 is the preferred choice for Ada, since it involves the least
-modifications to the original Ada grammar in the Ada reference manual.
-
-
-File: wisitoken-user_guide.info, Node: Grammar File Syntax, Prev: Common
grammar problems, Up: Top
-
-3 Grammar File Syntax
-*********************
-
-The grammar file syntax is based on Gnu bison syntax with some additions
-and deletions (*note Bison: (bison)Top.).
-
- (The grammar is specified in the WisiToken grammar file
-'wisitoken_grammar.wy').
-
- The top level file structure is a list of declarations and
-nonterminals.
-
- Comments are started by ';;' and terminated by end of line.
-
-* Menu:
-
-* Declarations::
-* Nonterminals::
-* Conditional code::
-
-
-File: wisitoken-user_guide.info, Node: Declarations, Next: Nonterminals,
Up: Grammar File Syntax
-
-3.1 Declarations
-================
-
-Declarations declare terminal tokens, conflicts, and other parser
-parameters.
-
-* Menu:
-
-* Raw Code::
-* Keywords::
-* Tokens::
-* Error recovery::
-* Other declarations::
-
-
-File: wisitoken-user_guide.info, Node: Raw Code, Next: Keywords, Up:
Declarations
-
-3.1.1 Raw 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
-is output.
-
-
-File: wisitoken-user_guide.info, Node: Keywords, Next: Tokens, Prev: Raw
Code, Up: Declarations
-
-3.1.2 Keywords
---------------
-
-%keyword <name> <string>
-
- example:
-%keyword SEMICOLON ";"
-
- "Keywords" are reserved words or symbols in the target language; the
-lexers recognize them by the given string.
-
-
-File: wisitoken-user_guide.info, Node: Tokens, Next: Error recovery, Prev:
Keywords, Up: Declarations
-
-3.1.3 Tokens
-------------
-
-%token < kind > name regexp
-
- example:
-%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'
-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 %[ ... ]%
- A string of characters that have string syntax, with double quote
- delimiters.
-
-'<string-single>'
- %token <string-single> CHARACTER_LITERAL %[ ... ]%
- A string of characters that have string syntax, with single quote
- delimiters.
-
-'<new-line>'
- %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] ]%
- A token that is recognized by the lexer, but not returned to the
- parser.
-
-'<delimited-text>'
- %token <delimited-text> RAW_CODE "%{" "}%"
- A token that contains arbitrary text, delimited by the two strings.
-
-
-File: wisitoken-user_guide.info, Node: Error recovery, Next: Other
declarations, Prev: Tokens, Up: Declarations
-
-3.1.4 Error recovery
---------------------
-
-The parser uses an error recovery algorithm when it encounters a syntax
-error; if a solution is found, the parse continues.
-
- Error recovery uses multiple tasks to take advantage of multiple CPU
-cores. Unfortunately, this means there is a race condition; the
-solutions found can be delivered in different orders on different runs.
-This matters because each solution results in a successful parse,
-possibly with different actions (different indentation computed, for
-example). Which solution finally succeeds depends on which are
-terminated due to identical parser stacks, which in turn depends on the
-order they were delivered.
-
- Once the syntax errors are fixed, only ambiguities in the grammar
-itself can cause a similar problem.
-
- Several grammar file declarations set parameters for the error
-recovery. If none of these parameters are present in the grammar file,
-the generated parser does not do error recovery.
-
- The error recovery algorithm generates possible solutions based on
-the parse state preceding the error point, by inserting, deleting, or
-pushing back tokens. Each possible solution is given a cost, and
-enqueued to be checked later. Solutions are checked in cost order
-(lowest first).
-
-'%mckenzie_check_limit <limit>'
- The number of tokens past the error point that must be parsed
- successfully for a solution to be deemed successful. Smaller
- values give faster recovery; larger values give better solutions.
- Too large a value risks encountering another user error, making a
- solution impossible. 3 or 4 works well in practice.
-
-'mckenzie_check_delta_limit <limit>'
- When error recovery is entered with multiple parsers active, once a
- solution has been found for one parser, the other parsers are
- allowed to check only 'mckenzie_check_delta_limit' possible
- solutions before they fail. This prevents long recovery times.
-
-'%mckenzie_cost_default <insert> <delete> <push back> <ignore check fail>'
- McKenzie error recovery default costs for insert, delete, push back
- single tokens, and for ignoring a semantic check failure; four
- floating point numbers.
-
- "Push back" means undo parsing; remove tokens from the parse stack
- and put them back into the input stream. This moves the
- insert/delete point, allowing better solutions. The push back
- default cost is also the undo reduce default cost.
-
- If not specified, costs are zero. Costs can be negative; they all
- add linearly.
-
-'%mckenzie_cost_delete <token> <cost>'
- McKenzie error recovery delete cost for a specific token.
-
-'%mckenzie_cost_fast_forward <cost>'
- McKenzie error recovery cost for parsing ahead after fixing one
- error, moving to the next error location.
-
-'%mckenzie_cost_insert <token> <cost>'
- McKenzie error recovery insert cost for a specific token.
-
-'%mckenzie_cost_fast_forward <cost>'
- McKenzie error recovery cost for using the 'matching_begin'
- strategy.
-
-'%mckenzie_cost_push_back <token> <cost>'
- McKenzie error recovery push back cost for a specific token.
-
-'%mckenzie_cost_undo_reduce <token> <cost>'
- McKenzie error recovery undo reduce cost for a specific token.
-
-'%mckenzie_enqueue_limit <integer>'
- McKenzie error recovery limit on possible solutions enqueued (to be
- checked); default max integer.
-
-'%mckenzie_minimal_complete_cost_delta <cost>'
- McKenzie error recovery cost added to the cost of an inserted token
- when the insert is done by the minimal complete strategy; this cost
- is normally negative.
-
-
-File: wisitoken-user_guide.info, Node: Other declarations, Prev: Error
recovery, Up: Declarations
-
-3.1.5 Other declarations
-------------------------
-
-'%case_insensitive'
- If present, keywords are case insensitive in the lexer.
-
-'%conflict <conflict description>'
- Declare a known conflict.
-
- Example conflict declaration:
- %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
- the conflict, the description can be copied into the grammar source
- file, so it will be ignored next time around.
-
- Resolving conflicts in the grammar can be difficult, but leaving
- them in can increase parse time and cause ambiguous parses.
-
-'%elisp_face <name>'
- Declare a name for an elisp face constant.
-
- When generating Ada code for Emacs, the elisp faces applied by
- 'wisi-face-apply' actions must be declared, so the elisp and Ada
- code aggree on what they mean.
-
-'%elisp_indent <elisp name> <Ada name>'
- Declare elisp and Ada names for an indent variable.
-
- When generating Ada code for Emacs, the elisp indent variables used
- in 'wisi-indent' actions must be declared, so the elisp and Ada
- code aggree on what they mean.
-
-'%elisp_action <elisp name> <Ada name>'
- Declare elisp and Ada names for a custom action subprogram written
- in Ada.
-
- The term "elisp" here is historical; the name is not actually used
- by elisp in the current implementation.
-
-'end_names_optional_option <name>'
- When generating Ada code for Emacs, the name of the Ada variable
- determining whether end block names are optional.
-
- In the Ada language, block names can be repeated at the end; for
- example:
-
- 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
- names to isolate the error.
-
-'generate <generate_algorithm> <output_language> [text_rep]'
-
- '<generate_algorithm>' is one of 'LALR | LR1 | Packrat_Gen |
- Packrat_Proc | External'
-
- '<output_language>' is one of 'Ada | Ada_Emacs'
-
- The algorithm/output_language pair declares one output source set.
- Multiple sets can be declared; they are all generated together.
-
- 'text_rep' determines how the parse table is represented; if
- present, it is in a text file that is loaded at parser run time.
- If absent, it is in the code. For very large parse tables, such as
- for an LR1 parser for a large language like Ada, the text
- representation may be needed, because the Ada compiler can't handle
- the very large number of statements that represent the parser table
- in the code. The text file can take a long time to read at parser
- startup (a few seconds for the Ada language).
-
-'%language_runtime'
- Specify an alternate name for the language runtime package; the
- default is 'Wisi.<language_name>'.
-
-'%meta_syntax [BNF | EBNF]'
- Declares the syntax used by the grammar file. BNF is a minor
- extension of standard Backus Naur Form; EBNF is a large extension.
- The default is BNF.
-
-'%no_enum'
- By default, the generated Ada code includes an enumeration type
- declaring each token. This makes the language-specific runtime
- easier to write (without this type, tokens are identified by
- integers).
-
- '%no_enum' causes the generated code to not include the token
- enumeration type.
-
-'%no_language_runtime'
- When generating Ada code for Emacs, '%no_language_runtime' causes
- the generated code to not include the runtime. Some grammars may
- need no runtime, particularly if they are small grammars intendend
- to test some generator feature.
-
-'%partial_recursion'
- The error recovery algorithm requires computing the recursion
- present in the language grammar. For some grammars (such as Java),
- this is too hard; '%partial_recursion' tells WisiToken to use a
- simpler approximate calculation. This will affect the quality of
- the error recovery, but it will still be robust.
-
-'%start'
- The start token for the grammar.
-
-'re2c_regexp <name> <value>'
- Declare a named regular expression with re2c name and syntax. The
- name may then occur in another re2c regular expression.
-
-
-File: wisitoken-user_guide.info, Node: Nonterminals, Next: Conditional code,
Prev: Declarations, Up: Grammar File Syntax
-
-3.2 Nonterminals
-================
-
-A nonterminal statement declares a nonterminal token, and the associated
-production rules and actions.
-
- The syntax of a nonterminal statement is:
-
-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
-
-3.3 Conditional code
-====================
-
-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
-
- The lines between '%if' and '%end if' are ignored if the current
-lexer or parser is not the one specified in the '%if' condition.
-
- '%if ... %end if' cannot be nested.
-
-
-
-Tag Table:
-Node: Top727
-Node: Overview1378
-Node: Install2140
-Node: Common grammar problems2637
-Node: Empty choice in list2930
-Node: Grammar File Syntax5912
-Node: Declarations6469
-Node: Raw Code6775
-Node: Keywords7156
-Node: Tokens7468
-Node: Error recovery8803
-Node: Other declarations12525
-Node: Nonterminals17017
-Node: Conditional code19038
-
-End Tag Table
-
-
-Local Variables:
-coding: utf-8
-End:
diff --git a/packages/wisi/wisitoken-wisi_ada.adb
b/packages/wisi/wisitoken-wisi_ada.adb
deleted file mode 100644
index dd5e072..0000000
--- a/packages/wisi/wisitoken-wisi_ada.adb
+++ /dev/null
@@ -1,160 +0,0 @@
--- Abstract :
---
--- see spec
---
--- Copyright (C) 2013, 2014, 2015, 2017 - 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-package body WisiToken.Wisi_Ada is
- use WisiToken.Productions;
-
- function Only (Item : in Token_ID) return WisiToken.Token_ID_Arrays.Vector
- is begin
- return Result : WisiToken.Token_ID_Arrays.Vector do
- Result.Append (Item);
- end return;
- end Only;
-
- function "&" (Left : in Token_ID; Right : in Token_ID) return
WisiToken.Token_ID_Arrays.Vector
- is begin
- return Result : WisiToken.Token_ID_Arrays.Vector do
- Result.Append (Left);
- Result.Append (Right);
- end return;
- end "&";
-
- function "+" (Tokens : in Token_ID_Arrays.Vector; Action : in
Syntax_Trees.Semantic_Action) return Right_Hand_Side
- is begin
- return (Tokens, Recursion => <>, Action => Action, Check => null);
- end "+";
-
- function "+" (Tokens : in Token_ID; Action : in
Syntax_Trees.Semantic_Action) return Right_Hand_Side
- is begin
- return (Only (Tokens), Recursion => <>, Action => Action, Check => null);
- end "+";
-
- function "+" (Action : in Syntax_Trees.Semantic_Action) return
Right_Hand_Side
- is begin
- return (Tokens => <>, Recursion => <>, Action => Action, Check => null);
- end "+";
-
- function Only (Item : in WisiToken.Productions.Right_Hand_Side) return
WisiToken.Productions.RHS_Arrays.Vector
- is begin
- return Result : WisiToken.Productions.RHS_Arrays.Vector do
- Result.Append (Item);
- end return;
- end Only;
-
- function "or"
- (Left : in WisiToken.Productions.Instance;
- Right : in WisiToken.Productions.Right_Hand_Side)
- return WisiToken.Productions.Instance
- is begin
- return Result : WisiToken.Productions.Instance := Left do
- Result.RHSs.Append (Right);
- end return;
- end "or";
-
- function "<=" (LHS : in Token_ID; RHSs : in
WisiToken.Productions.RHS_Arrays.Vector) return Instance
- is begin
- return (LHS, RHSs);
- end "<=";
-
- function Only (Subject : in Instance) return Prod_Arrays.Vector
- is begin
- return Result : Prod_Arrays.Vector do
- Result.Set_First_Last (Subject.LHS, Subject.LHS);
- Result (Subject.LHS) := Subject;
- end return;
- end Only;
-
- function Merge (Left, Right : in Instance) return Instance
- is
- Index : Integer := Left.RHSs.Last_Index + 1;
- begin
- return Result : Instance := Left do
- Result.RHSs.Set_First_Last (Result.RHSs.First_Index,
Left.RHSs.Last_Index + Integer (Right.RHSs.Length));
- for RHS of Right.RHSs loop
- Result.RHSs (Index) := RHS;
- Index := Index + 1;
- end loop;
- end return;
- end Merge;
-
- function "and" (Left : in Instance; Right : in Instance) return
Prod_Arrays.Vector
- is begin
- return Result : Prod_Arrays.Vector do
- Result.Set_First_Last (Token_ID'Min (Left.LHS, Right.LHS),
Token_ID'Max (Left.LHS, Right.LHS));
- if Left.LHS = Right.LHS then
- Result (Left.LHS) := Merge (Left, Right);
- else
- Result (Left.LHS) := Left;
- Result (Right.LHS) := Right;
- end if;
- end return;
- end "and";
-
- function "and" (Left : in Prod_Arrays.Vector; Right : in Instance) return
Prod_Arrays.Vector
- is begin
- return Result : Prod_Arrays.Vector := Left do
- if Right.LHS < Result.First_Index then
- Result.Set_First_Last (Right.LHS, Result.Last_Index);
- elsif Right.LHS > Result.Last_Index then
- Result.Set_First_Last (Result.First_Index, Right.LHS);
- end if;
-
- if Result (Right.LHS).LHS = Invalid_Token_ID then
- Result (Right.LHS) := Right;
- else
- Result (Right.LHS) := Merge (Result (Right.LHS), Right);
- end if;
- end return;
- end "and";
-
- function "and" (Left : in Prod_Arrays.Vector; Right : in
Prod_Arrays.Vector) return Prod_Arrays.Vector
- is begin
- return Result : Prod_Arrays.Vector := Left do
- if Right.First_Index < Result.First_Index then
- Result.Set_First_Last (Right.First_Index, Result.Last_Index);
- elsif Right.First_Index > Result.Last_Index then
- Result.Set_First_Last (Result.First_Index, Right.First_Index);
- end if;
- if Right.Last_Index < Result.First_Index then
- Result.Set_First_Last (Right.Last_Index, Result.Last_Index);
- elsif Right.Last_Index > Result.Last_Index then
- Result.Set_First_Last (Result.First_Index, Right.Last_Index);
- end if;
-
- for P of Right loop
- if Result (P.LHS).LHS = Invalid_Token_ID then
- Result (P.LHS) := P;
- else
- Result (P.LHS) := Merge (Result (P.LHS), P);
- end if;
- end loop;
- end return;
- end "and";
-
-end WisiToken.Wisi_Ada;
diff --git a/packages/wisi/wisitoken-wisi_ada.ads
b/packages/wisi/wisitoken-wisi_ada.ads
deleted file mode 100644
index a78643f..0000000
--- a/packages/wisi/wisitoken-wisi_ada.ads
+++ /dev/null
@@ -1,81 +0,0 @@
--- Abstract :
---
--- Type and operations for building a grammar directly in Ada source.
---
--- Copyright (C) 2003, 2013 - 2015, 2017, 2018 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
-
-pragma License (Modified_GPL);
-
-with WisiToken.Productions;
-with WisiToken.Syntax_Trees;
-package WisiToken.Wisi_Ada is
-
- function Only (Item : in Token_ID) return WisiToken.Token_ID_Arrays.Vector;
- function "&" (Left : in Token_ID; Right : in Token_ID) return
WisiToken.Token_ID_Arrays.Vector;
-
- function "+"
- (Tokens : in WisiToken.Token_ID_Arrays.Vector;
- Action : in WisiToken.Syntax_Trees.Semantic_Action)
- return WisiToken.Productions.Right_Hand_Side;
- function "+"
- (Tokens : in Token_ID;
- Action : in WisiToken.Syntax_Trees.Semantic_Action)
- return WisiToken.Productions.Right_Hand_Side;
- function "+" (Action : in WisiToken.Syntax_Trees.Semantic_Action) return
WisiToken.Productions.Right_Hand_Side;
- -- Create the right hand side of a production.
-
- function Only (Item : in WisiToken.Productions.Right_Hand_Side) return
WisiToken.Productions.RHS_Arrays.Vector;
- function "+" (Item : in WisiToken.Productions.Right_Hand_Side) return
WisiToken.Productions.RHS_Arrays.Vector
- renames Only;
-
- function "or"
- (Left : in WisiToken.Productions.Instance;
- Right : in WisiToken.Productions.Right_Hand_Side)
- return WisiToken.Productions.Instance;
-
- function "<="
- (LHS : in Token_ID;
- RHSs : in WisiToken.Productions.RHS_Arrays.Vector)
- return WisiToken.Productions.Instance;
-
- function Only (Subject : in WisiToken.Productions.Instance) return
WisiToken.Productions.Prod_Arrays.Vector;
- function "+" (Subject : in WisiToken.Productions.Instance) return
WisiToken.Productions.Prod_Arrays.Vector
- renames Only;
- -- First production in a grammar.
-
- function "and"
- (Left : in WisiToken.Productions.Instance;
- Right : in WisiToken.Productions.Instance)
- return WisiToken.Productions.Prod_Arrays.Vector;
- function "and"
- (Left : in WisiToken.Productions.Prod_Arrays.Vector;
- Right : in WisiToken.Productions.Instance)
- return WisiToken.Productions.Prod_Arrays.Vector;
- function "and"
- (Left : in WisiToken.Productions.Prod_Arrays.Vector;
- Right : in WisiToken.Productions.Prod_Arrays.Vector)
- return WisiToken.Productions.Prod_Arrays.Vector;
- -- Create a grammar
-
-end WisiToken.Wisi_Ada;
diff --git a/packages/wisi/wisitoken.adb b/packages/wisi/wisitoken.adb
deleted file mode 100644
index 9efeb18..0000000
--- a/packages/wisi/wisitoken.adb
+++ /dev/null
@@ -1,367 +0,0 @@
--- Abstract:
---
--- See spec
---
--- Copyright (C) 2009, 2014-2015, 2017 - 2020 Free Software Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- The WisiToken package is free software; you can redistribute it
--- and/or modify it under the terms of the GNU General Public License
--- as published by the Free Software Foundation; either version 3, or
--- (at your option) any later version. The WisiToken package is
--- distributed in the hope that it will be useful, but WITHOUT ANY
--- WARRANTY; without even the implied warranty of MERCHANTABILITY or
--- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
--- License for more details. You should have received a copy of the
--- GNU General Public License distributed with the WisiToken package;
--- see file GPL.txt. If not, write to the Free Software Foundation,
--- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
---
--- As a special exception, if other files instantiate generics from
--- this unit, or you link this unit with other files to produce an
--- executable, this unit does not by itself cause the resulting
--- executable to be covered by the GNU General Public License. This
--- exception does not however invalidate any other reasons why the
--- executable file might be covered by the GNU Public License.
--------------------------------------------------------------------------------
-
-with Ada.Strings.Fixed;
-package body WisiToken is
-
- function Padded_Image (Item : in Token_ID; Desc : in Descriptor) return
String
- is begin
- return Ada.Strings.Fixed.Head
- (Desc.Image (Item).all,
- (if Item in Desc.First_Terminal .. Desc.Last_Terminal
- then Desc.Terminal_Image_Width
- else Desc.Image_Width));
- end Padded_Image;
-
- function Image (Item : in Token_ID; Desc : in Descriptor) return String
- is begin
- return (if Item = Invalid_Token_ID then "-" else Desc.Image (Item).all);
- end Image;
-
- procedure Put_Tokens (Descriptor : in WisiToken.Descriptor)
- is
- use Ada.Text_IO;
- begin
- for I in Token_ID'First .. Descriptor.Last_Nonterminal loop
- Put_Line (Token_ID'Image (I) & " => " & Descriptor.Image (I).all);
- end loop;
- end Put_Tokens;
-
- function Find_ID (Descriptor : in WisiToken.Descriptor; Name : in String)
return Token_ID
- is begin
- for I in Descriptor.Image'Range loop
- if Descriptor.Image (I).all = Name then
- return I;
- end if;
- end loop;
- raise SAL.Programmer_Error with "token name '" & Name & "' not found in
descriptor.image";
- end Find_ID;
-
- procedure To_Vector (Item : in Token_ID_Array; Vector : in out
Token_ID_Arrays.Vector)
- is
- J : Integer := Vector.First_Index;
- begin
- for ID of Item loop
- Vector.Replace_Element (J, ID);
- J := J + 1;
- end loop;
- end To_Vector;
-
- function To_Vector (Item : in Token_ID_Array) return Token_ID_Arrays.Vector
- is begin
- return Result : Token_ID_Arrays.Vector do
- Result.Set_First_Last (Item'First, Item'Last);
- for I in Item'Range loop
- Result (I) := Item (I);
- end loop;
- end return;
- end To_Vector;
-
- function Shared_Prefix (A, B : in Token_ID_Arrays.Vector) return Natural
- is
- use all type Ada.Containers.Count_Type;
- I : Natural := A.First_Index;
- J : Natural := B.First_Index;
- begin
- if A.Length = 0 or B.Length = 0 then
- return 0;
- end if;
-
- loop
- exit when A (I) /= B (I) or I = A.Last_Index or J = B.Last_Index;
- I := I + 1;
- J := J + 1;
- end loop;
- return I - 1;
- end Shared_Prefix;
-
- function "&" (Left : in Token_ID_Set; Right : in Token_ID) return
Token_ID_Set
- is begin
- return Result : Token_ID_Set := Left do
- Result (Right) := True;
- end return;
- end "&";
-
- function To_Token_ID_Set (First, Last : in Token_ID; Item : in
Token_ID_Array) return Token_ID_Set
- is begin
- return Result : Token_ID_Set := (First .. Last => False)
- do
- for ID of Item loop
- Result (ID) := True;
- end loop;
- end return;
- end To_Token_ID_Set;
-
- procedure To_Set (Item : in Token_ID_Arrays.Vector; Set : out Token_ID_Set)
- is begin
- for ID of Item loop
- Set (ID) := True;
- end loop;
- end To_Set;
-
- function To_Array (Item : in Token_ID_Set) return Token_ID_Arrays.Vector
- is begin
- return Result : Token_ID_Arrays.Vector do
- for ID in Item'Range loop
- if Item (ID) then
- Result.Append (ID);
- end if;
- end loop;
- end return;
- end To_Array;
-
- function Any (Item : in Token_ID_Set) return Boolean
- is begin
- for I in Item'Range loop
- if Item (I) then
- return True;
- end if;
- end loop;
- return False;
- end Any;
-
- function Count (Item : in Token_ID_Set) return Integer
- is
- Result : Integer := 0;
- begin
- for I in Item'Range loop
- if Item (I) then
- Result := Result + 1;
- end if;
- end loop;
- return Result;
- end Count;
-
- function Image
- (Item : in Token_ID_Set;
- Desc : in Descriptor;
- Max_Count : in Integer := Integer'Last;
- Inverted : in Boolean := False)
- return String
- is
- use Ada.Strings.Unbounded;
- Result : Unbounded_String;
- Need_Comma : Boolean := False;
- Count : Integer := 0;
-
- function Include (Item : in Boolean) return Boolean
- is begin
- if not Inverted then
- return Item;
-
- else
- return not Item;
- end if;
- end Include;
-
- begin
- for I in Item'Range loop
- if Include (Item (I)) then
- if Need_Comma then
- Result := Result & ", ";
- end if;
- Result := Result & Image (I, Desc);
- Need_Comma := True;
- Count := Count + 1;
- if Count = Max_Count then
- return To_String (Result);
- end if;
- end if;
- end loop;
- return To_String (Result);
- end Image;
-
- function Image (Item : in Production_ID) return String
- is begin
- return '(' & Trimmed_Image (Item.LHS) & ',' & Natural'Image (Item.RHS) &
')';
- end Image;
-
- function Trimmed_Image (Item : in Production_ID) return String
- is begin
- return Trimmed_Image (Item.LHS) & '.' & Trimmed_Image (Item.RHS);
- end Trimmed_Image;
-
- function Padded_Image (Item : in Production_ID; Width : in Integer) return
String
- is
- use Ada.Strings.Fixed;
- begin
- return Result : String (1 .. Width) do
- Move (Trimmed_Image (Item), Result, Justify => Ada.Strings.Right);
- end return;
- end Padded_Image;
-
- function To_Vector (Item : in Production_ID_Array) return
Production_ID_Arrays.Vector
- is begin
- return Result : Production_ID_Arrays.Vector do
- for I of Item loop
- Result.Append (I);
- end loop;
- end return;
- end To_Vector;
-
- function Slice (Item : in Token_Array_Token_Set; I : in Token_ID) return
Token_ID_Set
- is
- Result : Token_ID_Set := (Item'First (2) .. Item'Last (2) => False);
- begin
- for J in Result'Range loop
- Result (J) := Item (I, J);
- end loop;
- return Result;
- end Slice;
-
- function Any (Item : in Token_Array_Token_Set; I : in Token_ID) return
Boolean
- is begin
- for J in Item'Range (2) loop
- if Item (I, J) then
- return True;
- end if;
- end loop;
- return False;
- end Any;
-
- function Any (Item : in Token_Array_Token_Set) return Boolean
- is begin
- for I in Item'Range (1) loop
- for J in Item'Range (2) loop
- if Item (I, J) then
- return True;
- end if;
- end loop;
- end loop;
- return False;
- end Any;
-
- procedure Or_Slice (Item : in out Token_Array_Token_Set; I : in Token_ID;
Value : in Token_ID_Set)
- is begin
- for J in Item'Range (2) loop
- Item (I, J) := Item (I, J) or Value (J);
- end loop;
- end Or_Slice;
-
- procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Token_Array_Token_Set)
- is
- use Ada.Text_IO;
- Paren_Done : Boolean := False;
- begin
- if not Any (Item) then
- Put_Line ("(others => (others => False))");
- else
- Put ("(");
- for I in Item'Range (1) loop
- if Any (Item, I) then
- Put_Line (" " & Image (I, Descriptor) & " =>");
- Put (" (");
- Paren_Done := False;
- for J in Item'Range (2) loop
- if Item (I, J) then
- if Paren_Done then
- Put_Line (" |");
- Put (" " & Image (J, Descriptor));
- else
- Paren_Done := True;
- Put (Image (J, Descriptor));
- end if;
- end if;
- end loop;
- if Paren_Done then
- Put_Line (" => True,");
- Put_Line (" others => False)");
- else
- Put_Line (" others => False),");
- end if;
- end if;
- end loop;
- Put_Line ((if Paren_Done then " " else "") & "others => (others =>
False))");
- end if;
- end Put;
-
- function Error_Message
- (File_Name : in String;
- Line : in Line_Number_Type;
- Column : in Ada.Text_IO.Count;
- Message : in String)
- return String
- is begin
- return File_Name & ":" &
- Trimmed_Image (if Line = Invalid_Line_Number then Integer'(0) else
Integer (Line)) & ":" &
- Trimmed_Image (Integer (Column)) & ": " &
- Message;
- end Error_Message;
-
- function Image (Item : in Buffer_Region) return String
- is begin
- return "(" & Trimmed_Image (Integer (Item.First)) & " ." &
Buffer_Pos'Image (Item.Last) & ")";
- end Image;
-
- function "and" (Left, Right : in Buffer_Region) return Buffer_Region
- is begin
- return (Buffer_Pos'Min (Left.First, Right.First), Buffer_Pos'Max
(Left.Last, Right.Last));
- end "and";
-
- function Image
- (Item : in Base_Token;
- Descriptor : in WisiToken.Descriptor)
- return String
- is
- ID_Image : constant String := WisiToken.Image (Item.ID, Descriptor);
- begin
- if Item.Char_Region = Null_Buffer_Region then
- return "(" & ID_Image & ")";
-
- else
- return "(" & ID_Image & ", " & Image (Item.Char_Region) & ")";
- end if;
- end Image;
-
- function Image
- (Token : in Base_Token_Index;
- Terminals : in Base_Token_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return String
- is begin
- if Token = Invalid_Token_Index then
- return "<invalid_token_index>";
- else
- return Token_Index'Image (Token) & ":" & Image (Terminals (Token),
Descriptor);
- end if;
- end Image;
-
- function Image
- (Item : in Recover_Token;
- Descriptor : in WisiToken.Descriptor)
- return String
- is begin
- return
- (if Item.Min_Terminal_Index = Invalid_Token_Index
- then ""
- else Trimmed_Image (Item.Min_Terminal_Index) & ":") &
- "(" & Image (Item.ID, Descriptor) &
- (if Item.Byte_Region = Null_Buffer_Region then "" else ", " & Image
(Item.Byte_Region)) & ")";
- end Image;
-
-end WisiToken;
diff --git a/packages/wisi/wisitoken.ads b/packages/wisi/wisitoken.ads
deleted file mode 100644
index 2c7a11b..0000000
--- a/packages/wisi/wisitoken.ads
+++ /dev/null
@@ -1,508 +0,0 @@
--- Abstract:
---
--- Root of WisiToken lexer/parser generator and exector.
---
--- The token type is an integer subtype, not an enumeration type, to
--- avoid making this package generic, which would make all other
--- packages generic.
---
--- Additional information about a token can be stored in the
--- 'augmented' field of the syntax tree; see
--- wisitoken-syntax_trees.ads.
---
--- References:
---
--- [dragon] "Compilers Principles, Techniques, and Tools" by Aho,
--- Sethi, and Ullman (aka: "The [Red] Dragon Book" due to the dragon
--- on the cover).
---
--- Copyright (C) 2009, 2010, 2013 - 2015, 2017 - 2020 Free Software
Foundation, Inc.
---
--- This file is part of the WisiToken package.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
---
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
---
--- This software was originally developed with the name OpenToken by
--- the following company, and was released as open-source software as
--- a service to the community:
---
--- FlightSafety International Simulation Systems Division
--- Broken Arrow, OK USA 918-259-4000
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-with Ada.Strings.Unbounded;
-with Ada.Text_IO;
-with Ada.Unchecked_Deallocation;
-with SAL.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.
-
- Syntax_Error : exception; -- no recovery for a syntax error was found
-
- Parse_Error : exception; -- a non-recoverable non-fatal error was
encountered; editing the input can fix the error.
-
- Fatal_Error : exception; -- Error in code or grammar; editing input cannot
fix error.
-
- Grammar_Error : exception;
- -- Grammar file has bad syntax, or grammar is not consistent (ie
- -- unused tokens, missing productions, invalid actions)
-
- User_Error : exception; -- other user error (ie command line parameter)
-
- -- SAL.Programmer_Error : exception; -- a programming convention has been
violated
-
- subtype Positive_Index_Type is SAL.Peek_Type;
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (SAL.Base_Peek_Type);
-
- type Unknown_State_Index is new Integer range -1 .. Integer'Last;
- subtype State_Index is Unknown_State_Index range 0 ..
Unknown_State_Index'Last;
- Unknown_State : constant Unknown_State_Index := -1;
-
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Unknown_State_Index);
-
- package State_Index_Queues is new SAL.Gen_Unbounded_Definite_Queues
(State_Index);
- package State_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive, State_Index, Default_Element => State_Index'Last);
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Integer);
- function Image is new State_Index_Arrays.Gen_Image (Trimmed_Image);
-
- ----------
- -- Token IDs
-
- type Token_ID is range 0 .. Integer'Last; -- 0 origin to match elisp array
-
- Invalid_Token_ID : constant Token_ID := Token_ID'Last;
-
- type String_Access_Constant is access constant String;
- type Token_ID_Array_String is array (Token_ID range <>) of
String_Access_Constant;
- type Token_ID_Array_Natural is array (Token_ID range <>) of Natural;
-
- type Descriptor
- (First_Terminal : Token_ID;
- Last_Terminal : Token_ID;
- First_Nonterminal : Token_ID;
- Last_Nonterminal : Token_ID;
- EOI_ID : Token_ID;
- Accept_ID : Token_ID)
- is record
- -- Tokens in the range Token_ID'First .. First_Terminal - 1 are
- -- non-reporting (comments, whitespace), and thus are not used in
- -- generating parse tables.
- --
- -- Tokens in the range Last_Terminal + 1 .. Last_Nonterminal are
- -- the nonterminals of a grammar.
- --
- -- Components are discriminants if they can be specified statically.
-
- Case_Insensitive : Boolean; -- keywords and names
- New_Line_ID : Token_ID;
-
- String_1_ID : Token_ID;
- String_2_ID : Token_ID;
- -- String_1 delimited by '; String_2 by ".
- --
- -- Used by missing quote error recovery. If the language does not
- -- have two kinds of string literals, set one or both of these to
- -- Invalid_Token_ID.
-
- Image : Token_ID_Array_String (Token_ID'First .. Last_Nonterminal);
- -- User names for tokens.
-
- Terminal_Image_Width : Integer;
- Image_Width : Integer; -- max width of Image
-
- Last_Lookahead : Token_ID;
- -- LALR generate needs a 'Propagate_ID' lookahead that is distinct
- -- from all terminals. Since lookaheads are Token_ID_Set, we need to
- -- allocate First_Terminal .. Last_Terminal for LR1 generate, and
- -- First_Terminal .. Propagate_ID for LALR generate, so we define
- -- Last_Lookahead. After the LR table is generated, Last_Lookahead is
- -- no longer used.
- end record;
- type Descriptor_Access is access Descriptor;
- type Descriptor_Access_Constant is access constant Descriptor;
-
- function Padded_Image (Item : in Token_ID; Desc : in Descriptor) return
String;
- -- Return Desc.Image (Item), padded to Terminal_Image_Width (if Item
- -- is a terminal) or to Image_Width.
-
- function Image (Item : in Token_ID; Desc : in Descriptor) return String;
- -- Return Desc.Image (Item), or "-" for Invalid_Token_ID.
-
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Token_ID);
-
- procedure Put_Tokens (Descriptor : in WisiToken.Descriptor);
- -- Put user readable token list (token_id'first ..
- -- descriptor.last_nonterminal) to Ada.Text_IO.Current_Output
-
- function Find_ID (Descriptor : in WisiToken.Descriptor; Name : in String)
return Token_ID;
- -- Return index of Name in Descriptor.Image. If not found, raise
Programmer_Error.
-
- type Token_ID_Array is array (Positive range <>) of Token_ID;
- -- Index is not Positive_Index_Type, mostly for historical reasons.
-
- package Token_ID_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive, Token_ID, Default_Element => Invalid_Token_ID);
-
- function Image is new Token_ID_Arrays.Gen_Image_Aux (Descriptor,
Trimmed_Image, Image);
- function Image_No_Assoc (Item : in Token_ID_Arrays.Vector; Aux : in
Descriptor) return String
- is (Image (Item, Aux, Association => False));
-
- function Trimmed_Image is new Token_ID_Arrays.Gen_Image (Trimmed_Image);
-
- procedure To_Vector (Item : in Token_ID_Array; Vector : in out
Token_ID_Arrays.Vector);
- function To_Vector (Item : in Token_ID_Array) return Token_ID_Arrays.Vector;
-
- function Shared_Prefix (A, B : in Token_ID_Arrays.Vector) return Natural;
- -- Return last index in A of a prefix shared between A, B; 0 if none.
-
- type Token_ID_Set is array (Token_ID range <>) of Boolean;
- type Token_ID_Set_Access is access Token_ID_Set;
-
- function "&" (Left : in Token_ID_Set; Right : in Token_ID) return
Token_ID_Set;
- -- Include Left and Right in result.
-
- function To_Token_ID_Set (First, Last : in Token_ID; Item : in
Token_ID_Array) return Token_ID_Set;
- -- First, Last determine size of result.
- -- For each element in Item, set result (element) True.
-
- procedure To_Set (Item : in Token_ID_Arrays.Vector; Set : out Token_ID_Set);
- -- For each element of Item, set Set (element) True.
-
- function To_Array (Item : in Token_ID_Set) return Token_ID_Arrays.Vector;
-
- function Any (Item : in Token_ID_Set) return Boolean;
-
- function Count (Item : in Token_ID_Set) return Integer;
- -- Count of True elements.
-
- function Image
- (Item : in Token_ID_Set;
- Desc : in Descriptor;
- Max_Count : in Integer := Integer'Last;
- Inverted : in Boolean := False)
- return String;
- -- For diagnostics; not Ada syntax.
-
- type Token_Array_Token_Set is array (Token_ID range <>, Token_ID range <>)
of Boolean;
-
- function Slice (Item : in Token_Array_Token_Set; I : in Token_ID) return
Token_ID_Set;
- function Any (Item : in Token_Array_Token_Set; I : in Token_ID) return
Boolean;
- function Any (Item : in Token_Array_Token_Set) return Boolean;
- procedure Or_Slice (Item : in out Token_Array_Token_Set; I : in Token_ID;
Value : in Token_ID_Set);
-
- procedure Put (Descriptor : in WisiToken.Descriptor; Item : in
Token_Array_Token_Set);
- -- Put Item to Ada.Text_IO.Current_Output, using valid Ada aggregate
- -- syntax.
-
- type Token_Array_Token_ID is array (Token_ID range <>) of Token_ID;
-
- package Token_Sequence_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_ID, Token_ID_Arrays.Vector, Default_Element =>
Token_ID_Arrays.Empty_Vector);
-
- ----------
- -- Production IDs; see wisitoken-productions.ads for more
-
- type Production_ID is record
- LHS : Token_ID := Invalid_Token_ID;
- RHS : Natural := 0;
- -- Index into the production table.
- end record;
-
- Invalid_Production_ID : constant Production_ID := (others => <>);
-
- function Image (Item : in Production_ID) return String;
- -- Ada positional aggregate syntax, for code generation.
-
- function Trimmed_Image (Item : in Production_ID) return String;
- -- Nonterm.rhs_index, both integers, no leading or trailing space;
- -- for parse table output and diagnostics.
-
- Prod_ID_Image_Width : constant Integer := 7;
- -- Max width of Trimmed_Image
-
- function Padded_Image (Item : in Production_ID; Width : in Integer) return
String;
- -- Trimmed_Image padded with leading spaces to Width
-
- package Production_ID_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Positive, Production_ID, Default_Element => Invalid_Production_ID);
- function Image is new Production_ID_Arrays.Gen_Image (Image);
- function Trimmed_Image is new Production_ID_Arrays.Gen_Image
(Trimmed_Image);
-
- type Production_ID_Array is array (Natural range <>) of Production_ID;
-
- function To_Vector (Item : in Production_ID_Array) return
Production_ID_Arrays.Vector;
- function "+" (Item : in Production_ID_Array) return
Production_ID_Arrays.Vector renames To_Vector;
- function "+" (Item : in Production_ID) return Production_ID_Arrays.Vector
is (To_Vector ((1 => Item)));
-
- type Token_Array_Production_ID is array (Token_ID range <>) of
Production_ID;
-
- type Recursion_Class is (None, Direct_Left, Other_Left, Other, Other_Right,
Direct_Right);
- function Image (Item : in Recursion_Class) return String
- is (case Item is
- when None => "None",
- when Direct_Left => "Direct_Left",
- when Other_Left => "Other_Left",
- when Other => "Other",
- when Other_Right => "Other_Right",
- when Direct_Right => "Direct_Right");
-
- ----------
- -- Tokens
-
- type Base_Buffer_Pos is range 0 .. Integer'Last;
- subtype Buffer_Pos is Base_Buffer_Pos range 1 .. Base_Buffer_Pos'Last; --
match Emacs buffer origin.
- type Buffer_Region is record
- First : Buffer_Pos;
- Last : Base_Buffer_Pos; -- allow representing null range.
- end record;
-
- Invalid_Buffer_Pos : constant Buffer_Pos := Buffer_Pos'Last;
- Null_Buffer_Region : constant Buffer_Region := (Buffer_Pos'Last,
Buffer_Pos'First);
-
- function Length (Region : in Buffer_Region) return Natural is (Natural
(Region.Last - Region.First + 1));
-
- function Inside (Pos : in Buffer_Pos; Region : in Buffer_Region) return
Boolean
- is (Region.First <= Pos and Pos <= Region.Last);
-
- function Image (Item : in Buffer_Region) return String;
-
- function "and" (Left, Right : in Buffer_Region) return Buffer_Region;
- -- Return region enclosing both Left and Right.
-
- type Line_Number_Type is range 1 .. Natural'Last; -- Match Emacs buffer
line numbers.
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Line_Number_Type);
-
- Invalid_Line_Number : constant Line_Number_Type := Line_Number_Type'Last;
-
- -- 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'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_Index;
- -- semantic checks need Byte_Region to compare names. Line, Col, and
- -- Char_Region are included for error messages.
-
- ID : Token_ID := Invalid_Token_ID;
- Tree_Index : Node_Index := Invalid_Node_Index;
-
- Byte_Region : Buffer_Region := Null_Buffer_Region;
- -- Index into the Lexer buffer for the token text.
-
- Line : Line_Number_Type := Invalid_Line_Number;
- Column : Ada.Text_IO.Count := 0;
- -- At start of token.
-
- Char_Region : Buffer_Region := Null_Buffer_Region;
- -- Character position, useful for finding the token location in Emacs
- -- buffers.
- end record;
-
- type Base_Token_Class_Access is access all Base_Token'Class;
- type Base_Token_Class_Access_Constant is access constant Base_Token'Class;
-
- function Image
- (Item : in Base_Token;
- Descriptor : in WisiToken.Descriptor)
- return String;
- -- For debug/test messages.
-
- procedure Free is new Ada.Unchecked_Deallocation (Base_Token'Class,
Base_Token_Class_Access);
-
- Invalid_Token : constant Base_Token := (others => <>);
-
- type Base_Token_Index is range 0 .. Integer'Last;
- subtype Token_Index is Base_Token_Index range 1 .. Base_Token_Index'Last;
-
- Invalid_Token_Index : constant Base_Token_Index := Base_Token_Index'First;
-
- function Trimmed_Image is new SAL.Gen_Trimmed_Image (Base_Token_Index);
-
- type Token_Index_Array is array (Natural range <>) of Token_Index;
-
- package Recover_Token_Index_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Natural, Base_Token_Index, Default_Element => Invalid_Token_Index);
-
- type Base_Token_Array is array (Positive_Index_Type range <>) of Base_Token;
-
- package Base_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_Index, Base_Token, Default_Element => (others => <>));
- type Base_Token_Array_Access is access all Base_Token_Arrays.Vector;
- 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);
-
- function Image
- (Token : in Base_Token_Index;
- Terminals : in Base_Token_Arrays.Vector;
- Descriptor : in WisiToken.Descriptor)
- return String;
-
- package Line_Begin_Token_Vectors is new SAL.Gen_Unbounded_Definite_Vectors
- (Line_Number_Type, Base_Token_Index, Default_Element =>
Invalid_Token_Index);
-
- type Recover_Token is record
- -- Maintaining a syntax tree during error recovery is too slow, so we
- -- store enough information in the recover stack to perform
- -- Semantic_Checks, Language_Fixes, and Push_Back operations. and to
- -- apply the solution to the main parser state. We make thousands of
- -- copies of the parse stack during recover, so minimizing size and
- -- compute time for this is critical.
- ID : Token_ID := Invalid_Token_ID;
-
- Byte_Region : Buffer_Region := Null_Buffer_Region;
- -- Byte_Region is used to detect empty tokens, for cost and other
issues.
-
- Min_Terminal_Index : Base_Token_Index := Invalid_Token_Index;
- -- For terminals, index of this token in Shared_Parser.Terminals. For
- -- nonterminals, minimum of contained tokens (Invalid_Token_Index if
- -- empty). For virtuals, Invalid_Token_Index. Used for push_back of
- -- nonterminals.
-
- Name : Buffer_Region := Null_Buffer_Region;
- -- Set and used by semantic_checks.
-
- Virtual : Boolean := True;
- -- For terminals, True if inserted by recover. For nonterminals, True
- -- if any contained token has Virtual = True.
- end record;
-
- function Image
- (Item : in Recover_Token;
- Descriptor : in WisiToken.Descriptor)
- return String;
-
- type Recover_Token_Array is array (Positive_Index_Type range <>) of
Recover_Token;
-
- package Recover_Token_Arrays is new SAL.Gen_Unbounded_Definite_Vectors
- (Token_Index, Recover_Token, Default_Element => (others => <>));
-
- function Image is new Recover_Token_Arrays.Gen_Image_Aux
(WisiToken.Descriptor, Trimmed_Image, Image);
-
- type Base_Identifier_Index is range 0 .. Integer'Last;
- subtype Identifier_Index is Base_Identifier_Index range 1 ..
Base_Identifier_Index'Last;
- -- For virtual identifiers created during syntax tree rewrite.
-
- 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
-
- Trace_Parse : Integer := 0;
- -- If Trace_Parse > 0, Parse prints messages helpful for debugging
- -- the grammar and/or the parser; higher value prints more.
- --
- -- Trace_Parse levels; output info if Trace_Parse > than:
- --
- Outline : constant := 0; -- spawn/terminate parallel parsers, error
recovery enter/exit
- Detail : constant := 1; -- add each parser cycle
- Extra : constant := 2; -- add pending semantic state operations
- Lexer_Debug : constant := 3; -- add lexer debug
-
- Trace_McKenzie : Integer := 0;
- -- If Trace_McKenzie > 0, Parse prints messages helpful for debugging
error recovery.
- --
- -- Outline - error recovery enter/exit
- -- Detail - add each error recovery configuration
- -- Extra - add error recovery parse actions
-
- Trace_Action : Integer := 0;
- -- Output during Execute_Action, and unit tests.
-
- Trace_Generate_EBNF : Integer := 0;
- Trace_Generate_Table : Integer := 0;
- 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.
-
- type Trace (Descriptor : not null access constant WisiToken.Descriptor) is
abstract tagged limited null record;
- -- Output for tests/debugging. Descriptor included here because many
- -- uses of Trace will use Image (Item, Descriptor);
-
- procedure Set_Prefix (Trace : in out WisiToken.Trace; Prefix : in String)
is abstract;
- -- Prepend Prefix to all subsequent messages. Usefull for adding
- -- comment syntax.
-
- procedure Put (Trace : in out WisiToken.Trace; Item : in String; Prefix :
in Boolean := True) is abstract;
- -- Put Item to the Trace display. If Prefix is True, prepend the stored
prefix.
-
- procedure Put_Line (Trace : in out WisiToken.Trace; Item : in String) is
abstract;
- -- Put Item to the Trace display, followed by a newline.
-
- procedure New_Line (Trace : in out WisiToken.Trace) is abstract;
- -- Put a newline to the Trace display.
-
- procedure Put_Clock (Trace : in out WisiToken.Trace; Label : in String) is
abstract;
- -- Put Ada.Calendar.Clock to Trace.
-
- ----------
- -- Misc
-
- function "+" (Item : in String) return
Ada.Strings.Unbounded.Unbounded_String
- renames Ada.Strings.Unbounded.To_Unbounded_String;
-
- function "-" (Item : in Ada.Strings.Unbounded.Unbounded_String) return
String
- renames Ada.Strings.Unbounded.To_String;
-
- function Trimmed_Image is new SAL.Gen_Trimmed_Image
(Ada.Containers.Count_Type);
-
- function Error_Message
- (File_Name : in String;
- Line : in Line_Number_Type;
- Column : in Ada.Text_IO.Count;
- Message : in String)
- return String;
- -- Return Gnu-formatted error message.
-
- type Names_Array is array (Integer range <>) of String_Access_Constant;
- type Names_Array_Access is access Names_Array;
- type Names_Array_Array is array (WisiToken.Token_ID range <>) of
Names_Array_Access;
- type Names_Array_Array_Access is access Names_Array_Array;
-
-end WisiToken;
diff --git a/packages/wisi/wisitoken_grammar_actions.adb
b/packages/wisi/wisitoken_grammar_actions.adb
deleted file mode 100644
index 8819828..0000000
--- a/packages/wisi/wisitoken_grammar_actions.adb
+++ /dev/null
@@ -1,182 +0,0 @@
--- generated parser support file.
--- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
---
-
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- Author: Stephen Leake <stephe-leake@stephe-leake.org>
---
--- This file is part of GNU Emacs.
---
--- GNU Emacs is free software: you can redistribute it and/or modify
--- it under the terms of the GNU General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- (at your option) any later version.
---
--- GNU Emacs is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU General Public License for more details.
---
--- You should have received a copy of the GNU General Public License
--- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-with WisiToken_Grammar_Runtime; use WisiToken_Grammar_Runtime;
-
-package body Wisitoken_Grammar_Actions is
-
- procedure declaration_0
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- pragma Unreferenced (Nonterm);
- begin
- Add_Declaration (User_Data, Tree, Tokens);
- end declaration_0;
-
- procedure declaration_1
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- pragma Unreferenced (Nonterm);
- begin
- Add_Declaration (User_Data, Tree, Tokens);
- end declaration_1;
-
- procedure declaration_2
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- pragma Unreferenced (Nonterm);
- begin
- Add_Declaration (User_Data, Tree, Tokens);
- end declaration_2;
-
- procedure declaration_3
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- pragma Unreferenced (Nonterm);
- begin
- Add_Declaration (User_Data, Tree, Tokens);
- end declaration_3;
-
- procedure declaration_4
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- pragma Unreferenced (Nonterm);
- begin
- Start_If (User_Data, Tree, Tokens);
- end declaration_4;
-
- procedure declaration_5
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- pragma Unreferenced (Tree, Nonterm, Tokens);
- begin
- End_If (User_Data);
- end declaration_5;
-
- procedure nonterminal_0
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- pragma Unreferenced (Nonterm);
- begin
- Add_Nonterminal (User_Data, Tree, Tokens);
- end nonterminal_0;
-
- procedure nonterminal_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;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- pragma Unreferenced (Nonterm);
- begin
- Add_Nonterminal (User_Data, Tree, Tokens);
- end nonterminal_1;
-
- procedure rhs_item_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;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- pragma Unreferenced (Nonterm);
- begin
- Check_EBNF (User_Data, Tree, Tokens, 1);
- end rhs_item_1;
-
- procedure rhs_item_2
- (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)
- is
- pragma Unreferenced (Nonterm);
- begin
- Check_EBNF (User_Data, Tree, Tokens, 1);
- end rhs_item_2;
-
- procedure rhs_item_3
- (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)
- is
- pragma Unreferenced (Nonterm);
- begin
- Check_EBNF (User_Data, Tree, Tokens, 1);
- end rhs_item_3;
-
- procedure rhs_item_4
- (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)
- is
- pragma Unreferenced (Nonterm);
- begin
- Check_EBNF (User_Data, Tree, Tokens, 1);
- end rhs_item_4;
-
- procedure rhs_item_5
- (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)
- is
- pragma Unreferenced (Nonterm);
- begin
- Check_EBNF (User_Data, Tree, Tokens, 1);
- end rhs_item_5;
-
- procedure rhs_optional_item_3
- (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)
- is
- pragma Unreferenced (Nonterm);
- begin
- Check_EBNF (User_Data, Tree, Tokens, 1);
- end rhs_optional_item_3;
-
-end Wisitoken_Grammar_Actions;
diff --git a/packages/wisi/wisitoken_grammar_actions.ads
b/packages/wisi/wisitoken_grammar_actions.ads
deleted file mode 100644
index 1308267..0000000
--- a/packages/wisi/wisitoken_grammar_actions.ads
+++ /dev/null
@@ -1,237 +0,0 @@
--- generated parser support file.
--- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c PROCESS
wisitoken_grammar.wy
---
-
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- Author: Stephen Leake <stephe-leake@stephe-leake.org>
---
--- This file is part of GNU Emacs.
---
--- GNU Emacs is free software: you can redistribute it and/or modify
--- it under the terms of the GNU General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- (at your option) any later version.
---
--- GNU Emacs is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU General Public License for more details.
---
--- You should have received a copy of the GNU General Public License
--- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-with WisiToken.Syntax_Trees;
-package Wisitoken_Grammar_Actions is
-
- Descriptor : aliased WisiToken.Descriptor :=
- (First_Terminal => 3,
- Last_Terminal => 36,
- First_Nonterminal => 37,
- Last_Nonterminal => 56,
- EOI_ID => 36,
- Accept_ID => 37,
- Case_Insensitive => False,
- New_Line_ID => 1,
- String_1_ID => 35,
- String_2_ID => 34,
- Image =>
- (new String'("WHITESPACE"),
- new String'("NEW_LINE"),
- new String'("COMMENT"),
- new String'("CODE"),
- new String'("END"),
- new String'("IF"),
- new String'("KEYWORD"),
- new String'("NON_GRAMMAR"),
- new String'("TOKEN"),
- new String'("RAW_CODE"),
- new String'("REGEXP"),
- new String'("ACTION"),
- new String'("BAR"),
- new String'("COLON"),
- new String'("COLON_COLON_EQUAL"),
- new String'("COMMA"),
- new String'("EQUAL"),
- new String'("GREATER"),
- new String'("LEFT_BRACE"),
- new String'("LEFT_BRACKET"),
- new String'("LEFT_PAREN"),
- new String'("LESS"),
- new String'("MINUS"),
- new String'("PERCENT"),
- new String'("PLUS"),
- new String'("QUESTION"),
- new String'("RIGHT_BRACE"),
- new String'("RIGHT_BRACKET"),
- new String'("RIGHT_PAREN"),
- new String'("SEMICOLON"),
- new String'("SLASH"),
- new String'("STAR"),
- new String'("NUMERIC_LITERAL"),
- new String'("IDENTIFIER"),
- new String'("STRING_LITERAL_1"),
- new String'("STRING_LITERAL_2"),
- new String'("Wisi_EOI"),
- new String'("wisitoken_accept"),
- new String'("declaration"),
- new String'("token_keyword_non_grammar"),
- new String'("identifier_list"),
- new String'("declaration_item_list"),
- new String'("declaration_item"),
- new String'("nonterminal"),
- new String'("semicolon_opt"),
- new String'("rhs_list"),
- new String'("rhs"),
- new String'("rhs_attribute"),
- new String'("rhs_element"),
- new String'("rhs_item_list"),
- new String'("rhs_item"),
- new String'("rhs_group_item"),
- new String'("rhs_optional_item"),
- new String'("rhs_multiple_item"),
- new String'("rhs_alternative_list"),
- new String'("compilation_unit"),
- new String'("compilation_unit_list")),
- Terminal_Image_Width => 17,
- Image_Width => 25,
- Last_Lookahead => 37);
-
- type Token_Enum_ID is
- (WHITESPACE_ID,
- NEW_LINE_ID,
- COMMENT_ID,
- CODE_ID,
- END_ID,
- IF_ID,
- KEYWORD_ID,
- NON_GRAMMAR_ID,
- TOKEN_ID,
- RAW_CODE_ID,
- REGEXP_ID,
- ACTION_ID,
- BAR_ID,
- COLON_ID,
- COLON_COLON_EQUAL_ID,
- COMMA_ID,
- EQUAL_ID,
- GREATER_ID,
- LEFT_BRACE_ID,
- LEFT_BRACKET_ID,
- LEFT_PAREN_ID,
- LESS_ID,
- MINUS_ID,
- PERCENT_ID,
- PLUS_ID,
- QUESTION_ID,
- RIGHT_BRACE_ID,
- RIGHT_BRACKET_ID,
- RIGHT_PAREN_ID,
- SEMICOLON_ID,
- SLASH_ID,
- STAR_ID,
- NUMERIC_LITERAL_ID,
- IDENTIFIER_ID,
- STRING_LITERAL_1_ID,
- STRING_LITERAL_2_ID,
- Wisi_EOI_ID,
- wisitoken_accept_ID,
- declaration_ID,
- token_keyword_non_grammar_ID,
- identifier_list_ID,
- declaration_item_list_ID,
- declaration_item_ID,
- nonterminal_ID,
- semicolon_opt_ID,
- rhs_list_ID,
- rhs_ID,
- rhs_attribute_ID,
- rhs_element_ID,
- rhs_item_list_ID,
- rhs_item_ID,
- rhs_group_item_ID,
- rhs_optional_item_ID,
- rhs_multiple_item_ID,
- rhs_alternative_list_ID,
- compilation_unit_ID,
- compilation_unit_list_ID);
-
- type Token_Enum_ID_Array is array (Positive range <>) of Token_Enum_ID;
- use all type WisiToken.Token_ID;
- function "+" (Item : in Token_Enum_ID) return WisiToken.Token_ID
- is (WisiToken.Token_ID'First + Token_Enum_ID'Pos (Item));
- function To_Token_Enum (Item : in WisiToken.Token_ID) return Token_Enum_ID
- is (Token_Enum_ID'Val (Item - WisiToken.Token_ID'First));
- function "-" (Item : in WisiToken.Token_ID) return Token_Enum_ID renames
To_Token_Enum;
-
- procedure declaration_0
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure declaration_1
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure declaration_2
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure declaration_3
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure declaration_4
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure declaration_5
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure nonterminal_0
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in out WisiToken.Syntax_Trees.Tree;
- Nonterm : in WisiToken.Valid_Node_Index;
- Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure nonterminal_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;
- Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure rhs_item_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;
- Tokens : in WisiToken.Valid_Node_Index_Array);
- procedure rhs_item_2
- (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 rhs_item_3
- (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 rhs_item_4
- (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 rhs_item_5
- (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 rhs_optional_item_3
- (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);
-end Wisitoken_Grammar_Actions;
diff --git a/packages/wisi/wisitoken_grammar_main.adb
b/packages/wisi/wisitoken_grammar_main.adb
deleted file mode 100644
index cb91adf..0000000
--- a/packages/wisi/wisitoken_grammar_main.adb
+++ /dev/null
@@ -1,662 +0,0 @@
--- generated parser support file.
--- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
---
-
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- Author: Stephen Leake <stephe-leake@stephe-leake.org>
---
--- This file is part of GNU Emacs.
---
--- GNU Emacs is free software: you can redistribute it and/or modify
--- it under the terms of the GNU General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- (at your option) any later version.
---
--- GNU Emacs is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU General Public License for more details.
---
--- You should have received a copy of the GNU General Public License
--- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-with Wisitoken_Grammar_Actions; use Wisitoken_Grammar_Actions;
-with WisiToken.Lexer.re2c;
-with wisitoken_grammar_re2c_c;
-package body Wisitoken_Grammar_Main is
-
- package Lexer is new WisiToken.Lexer.re2c
- (wisitoken_grammar_re2c_c.New_Lexer,
- wisitoken_grammar_re2c_c.Free_Lexer,
- wisitoken_grammar_re2c_c.Reset_Lexer,
- wisitoken_grammar_re2c_c.Next_Token);
-
- procedure Create_Parser
- (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;
- Trace : not null access WisiToken.Trace'Class;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access)
- is
- use WisiToken.Parse.LR;
- Table : constant Parse_Table_Ptr := new Parse_Table
- (State_First => 0,
- State_Last => 102,
- First_Terminal => 3,
- Last_Terminal => 36,
- First_Nonterminal => 37,
- Last_Nonterminal => 56);
- begin
- declare
- procedure Subr_1
- is begin
- Table.States (0).Action_List.Set_Capacity (2);
- Add_Action (Table.States (0), 23, (38, 0), 1);
- Add_Action (Table.States (0), 33, (43, 0), 2);
- Table.States (0).Goto_List.Set_Capacity (4);
- Add_Goto (Table.States (0), 38, 3);
- Add_Goto (Table.States (0), 43, 4);
- Add_Goto (Table.States (0), 55, 5);
- Add_Goto (Table.States (0), 56, 6);
- Table.States (1).Action_List.Set_Capacity (7);
- Add_Action (Table.States (1), 3, (38, 1), 7);
- Add_Action (Table.States (1), 4, (38, 5), 8);
- Add_Action (Table.States (1), 5, (38, 4), 9);
- Add_Action (Table.States (1), 6, (39, 0), 10);
- Add_Action (Table.States (1), 7, (39, 1), 11);
- Add_Action (Table.States (1), 8, (39, 2), 12);
- Add_Action (Table.States (1), 33, (38, 2), 13);
- Table.States (1).Goto_List.Set_Capacity (1);
- Add_Goto (Table.States (1), 39, 14);
- Table.States (2).Action_List.Set_Capacity (2);
- Add_Action (Table.States (2), 13, (43, 0), 15);
- Add_Action (Table.States (2), 14, (43, 1), 16);
- Table.States (3).Action_List.Set_Capacity (3);
- Add_Action (Table.States (3), (23, 33, 36), (55, 0), 1, null,
null);
- Table.States (4).Action_List.Set_Capacity (3);
- Add_Action (Table.States (4), (23, 33, 36), (55, 1), 1, null,
null);
- Table.States (5).Action_List.Set_Capacity (3);
- Add_Action (Table.States (5), (23, 33, 36), (56, 0), 1, null,
null);
- Table.States (6).Action_List.Set_Capacity (3);
- Add_Action (Table.States (6), 23, (38, 0), 1);
- Add_Action (Table.States (6), 33, (43, 0), 2);
- Add_Action (Table.States (6), 36, Accept_It, (37, 0), 1, null,
null);
- Table.States (6).Goto_List.Set_Capacity (3);
- Add_Goto (Table.States (6), 38, 3);
- Add_Goto (Table.States (6), 43, 4);
- Add_Goto (Table.States (6), 55, 17);
- Table.States (7).Action_List.Set_Capacity (1);
- Add_Action (Table.States (7), 33, (40, 0), 18);
- Table.States (7).Goto_List.Set_Capacity (1);
- Add_Goto (Table.States (7), 40, 19);
- Table.States (8).Action_List.Set_Capacity (1);
- Add_Action (Table.States (8), 5, (38, 5), 20);
- Table.States (9).Action_List.Set_Capacity (1);
- Add_Action (Table.States (9), 33, (38, 4), 21);
- Table.States (10).Action_List.Set_Capacity (1);
- Add_Action (Table.States (10), (1 => 33), (39, 0), 1, null,
null);
- Table.States (11).Action_List.Set_Capacity (1);
- Add_Action (Table.States (11), 21, (39, 1), 22);
- Table.States (12).Action_List.Set_Capacity (1);
- Add_Action (Table.States (12), 21, (39, 2), 23);
- Table.States (13).Action_List.Set_Capacity (13);
- Add_Action (Table.States (13), 8, (42, 10), 24);
- Add_Action (Table.States (13), 10, (42, 5), 25);
- Add_Action (Table.States (13), 15, (42, 0), 26);
- Add_Action (Table.States (13), 16, (42, 2), 27);
- Add_Action (Table.States (13), 20, (42, 3), 28);
- Add_Action (Table.States (13), 23, Reduce, (38, 3), 2,
declaration_3'Access, null);
- Add_Action (Table.States (13), 28, (42, 6), 29);
- Add_Action (Table.States (13), 30, (42, 7), 30);
- Add_Action (Table.States (13), 32, (42, 4), 31);
- Add_Action (Table.States (13), 33, (42, 1), 32);
- Add_Conflict (Table.States (13), 33, (38, 3), 2,
declaration_3'Access, null);
- Add_Action (Table.States (13), 34, (42, 8), 33);
- Add_Action (Table.States (13), 35, (42, 9), 34);
- Add_Action (Table.States (13), 36, Reduce, (38, 3), 2,
declaration_3'Access, null);
- Table.States (13).Goto_List.Set_Capacity (2);
- Add_Goto (Table.States (13), 41, 35);
- Add_Goto (Table.States (13), 42, 36);
- Table.States (14).Action_List.Set_Capacity (1);
- Add_Action (Table.States (14), 33, (38, 0), 37);
- Table.States (15).Action_List.Set_Capacity (10);
- Add_Action (Table.States (15), 12, Reduce, (46, 0), 0, null,
null);
- Add_Action (Table.States (15), 18, (53, 0), 38);
- Add_Action (Table.States (15), 19, (52, 0), 39);
- Add_Action (Table.States (15), 20, (51, 0), 40);
- Add_Action (Table.States (15), 21, (47, 0), 41);
- Add_Action (Table.States (15), 23, Reduce, (46, 0), 0, null,
null);
- Add_Action (Table.States (15), 29, Reduce, (46, 0), 0, null,
null);
- Add_Action (Table.States (15), 33, (48, 1), 42);
- Add_Conflict (Table.States (15), 33, (46, 0), 0, null, null);
- Add_Action (Table.States (15), 35, (50, 1), 43);
- Add_Action (Table.States (15), 36, Reduce, (46, 0), 0, null,
null);
- Table.States (15).Goto_List.Set_Capacity (9);
- Add_Goto (Table.States (15), 45, 44);
- Add_Goto (Table.States (15), 46, 45);
- Add_Goto (Table.States (15), 47, 46);
- Add_Goto (Table.States (15), 48, 47);
- Add_Goto (Table.States (15), 49, 48);
- Add_Goto (Table.States (15), 50, 49);
- Add_Goto (Table.States (15), 51, 50);
- Add_Goto (Table.States (15), 52, 51);
- Add_Goto (Table.States (15), 53, 52);
- Table.States (16).Action_List.Set_Capacity (10);
- Add_Action (Table.States (16), 12, Reduce, (46, 0), 0, null,
null);
- Add_Action (Table.States (16), 18, (53, 0), 38);
- Add_Action (Table.States (16), 19, (52, 0), 39);
- Add_Action (Table.States (16), 20, (51, 0), 40);
- Add_Action (Table.States (16), 21, (47, 0), 41);
- Add_Action (Table.States (16), 23, Reduce, (46, 0), 0, null,
null);
- Add_Action (Table.States (16), 29, Reduce, (46, 0), 0, null,
null);
- Add_Action (Table.States (16), 33, (48, 1), 42);
- Add_Conflict (Table.States (16), 33, (46, 0), 0, null, null);
- Add_Action (Table.States (16), 35, (50, 1), 43);
- Add_Action (Table.States (16), 36, Reduce, (46, 0), 0, null,
null);
- Table.States (16).Goto_List.Set_Capacity (9);
- Add_Goto (Table.States (16), 45, 53);
- Add_Goto (Table.States (16), 46, 45);
- Add_Goto (Table.States (16), 47, 46);
- Add_Goto (Table.States (16), 48, 47);
- Add_Goto (Table.States (16), 49, 48);
- Add_Goto (Table.States (16), 50, 49);
- Add_Goto (Table.States (16), 51, 50);
- Add_Goto (Table.States (16), 52, 51);
- Add_Goto (Table.States (16), 53, 52);
- Table.States (17).Action_List.Set_Capacity (3);
- Add_Action (Table.States (17), (23, 33, 36), (56, 1), 2, null,
null);
- Table.States (18).Action_List.Set_Capacity (2);
- Add_Action (Table.States (18), (9, 33), (40, 0), 1, null, null);
- Table.States (19).Action_List.Set_Capacity (2);
- Add_Action (Table.States (19), 9, (38, 1), 54);
- Add_Action (Table.States (19), 33, (40, 1), 55);
- Table.States (20).Action_List.Set_Capacity (3);
- Add_Action (Table.States (20), (23, 33, 36), (38, 5), 3,
declaration_5'Access, null);
- Table.States (21).Action_List.Set_Capacity (1);
- Add_Action (Table.States (21), 16, (38, 4), 56);
- Table.States (22).Action_List.Set_Capacity (1);
- Add_Action (Table.States (22), 33, (39, 1), 57);
- Table.States (23).Action_List.Set_Capacity (1);
- Add_Action (Table.States (23), 33, (39, 2), 58);
- Table.States (24).Action_List.Set_Capacity (13);
- Add_Action (Table.States (24), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 10), 1, null,
- null);
- Table.States (25).Action_List.Set_Capacity (13);
- Add_Action (Table.States (25), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 5), 1, null,
- null);
- Table.States (26).Action_List.Set_Capacity (13);
- Add_Action (Table.States (26), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 0), 1, null,
- null);
- Table.States (27).Action_List.Set_Capacity (13);
- Add_Action (Table.States (27), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 2), 1, null,
- null);
- Table.States (28).Action_List.Set_Capacity (13);
- Add_Action (Table.States (28), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 3), 1, null,
- null);
- Table.States (29).Action_List.Set_Capacity (13);
- Add_Action (Table.States (29), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 6), 1, null,
- null);
- Table.States (30).Action_List.Set_Capacity (13);
- Add_Action (Table.States (30), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 7), 1, null,
- null);
- Table.States (31).Action_List.Set_Capacity (13);
- Add_Action (Table.States (31), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 4), 1, null,
- null);
- Table.States (32).Action_List.Set_Capacity (13);
- Add_Action (Table.States (32), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 1), 1, null,
- null);
- Table.States (33).Action_List.Set_Capacity (13);
- Add_Action (Table.States (33), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 8), 1, null,
- null);
- Table.States (34).Action_List.Set_Capacity (13);
- Add_Action (Table.States (34), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (42, 9), 1, null,
- null);
- Table.States (35).Action_List.Set_Capacity (13);
- Add_Action (Table.States (35), 8, (42, 10), 24);
- Add_Action (Table.States (35), 10, (42, 5), 25);
- Add_Action (Table.States (35), 15, (42, 0), 26);
- Add_Action (Table.States (35), 16, (42, 2), 27);
- Add_Action (Table.States (35), 20, (42, 3), 28);
- Add_Action (Table.States (35), 23, Reduce, (38, 2), 3,
declaration_2'Access, null);
- Add_Action (Table.States (35), 28, (42, 6), 29);
- Add_Action (Table.States (35), 30, (42, 7), 30);
- Add_Action (Table.States (35), 32, (42, 4), 31);
- Add_Action (Table.States (35), 33, (42, 1), 32);
- Add_Conflict (Table.States (35), 33, (38, 2), 3,
declaration_2'Access, null);
- Add_Action (Table.States (35), 34, (42, 8), 33);
- Add_Action (Table.States (35), 35, (42, 9), 34);
- Add_Action (Table.States (35), 36, Reduce, (38, 2), 3,
declaration_2'Access, null);
- Table.States (35).Goto_List.Set_Capacity (1);
- Add_Goto (Table.States (35), 42, 59);
- Table.States (36).Action_List.Set_Capacity (13);
- Add_Action (Table.States (36), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (41, 0), 1, null,
- null);
- Table.States (37).Action_List.Set_Capacity (11);
- Add_Action (Table.States (37), 8, (42, 10), 24);
- Add_Action (Table.States (37), 10, (42, 5), 25);
- Add_Action (Table.States (37), 15, (42, 0), 26);
- Add_Action (Table.States (37), 16, (42, 2), 27);
- Add_Action (Table.States (37), 20, (42, 3), 28);
- Add_Action (Table.States (37), 28, (42, 6), 29);
- Add_Action (Table.States (37), 30, (42, 7), 30);
- Add_Action (Table.States (37), 32, (42, 4), 31);
- Add_Action (Table.States (37), 33, (42, 1), 32);
- Add_Action (Table.States (37), 34, (42, 8), 33);
- Add_Action (Table.States (37), 35, (42, 9), 34);
- Table.States (37).Goto_List.Set_Capacity (2);
- Add_Goto (Table.States (37), 41, 60);
- Add_Goto (Table.States (37), 42, 36);
- Table.States (38).Action_List.Set_Capacity (6);
- Add_Action (Table.States (38), 18, (53, 0), 38);
- Add_Action (Table.States (38), 19, (52, 0), 39);
- Add_Action (Table.States (38), 20, (51, 0), 40);
- Add_Action (Table.States (38), 21, (47, 0), 41);
- Add_Action (Table.States (38), 33, (48, 1), 42);
- Add_Action (Table.States (38), 35, (50, 1), 43);
- Table.States (38).Goto_List.Set_Capacity (8);
- Add_Goto (Table.States (38), 47, 46);
- Add_Goto (Table.States (38), 48, 47);
- Add_Goto (Table.States (38), 49, 61);
- Add_Goto (Table.States (38), 50, 49);
- Add_Goto (Table.States (38), 51, 50);
- Add_Goto (Table.States (38), 52, 51);
- Add_Goto (Table.States (38), 53, 52);
- Add_Goto (Table.States (38), 54, 62);
- Table.States (39).Action_List.Set_Capacity (6);
- Add_Action (Table.States (39), 18, (53, 0), 38);
- Add_Action (Table.States (39), 19, (52, 0), 39);
- Add_Action (Table.States (39), 20, (51, 0), 40);
- Add_Action (Table.States (39), 21, (47, 0), 41);
- Add_Action (Table.States (39), 33, (48, 1), 42);
- Add_Action (Table.States (39), 35, (50, 1), 43);
- Table.States (39).Goto_List.Set_Capacity (8);
- Add_Goto (Table.States (39), 47, 46);
- Add_Goto (Table.States (39), 48, 47);
- Add_Goto (Table.States (39), 49, 61);
- Add_Goto (Table.States (39), 50, 49);
- Add_Goto (Table.States (39), 51, 50);
- Add_Goto (Table.States (39), 52, 51);
- Add_Goto (Table.States (39), 53, 52);
- Add_Goto (Table.States (39), 54, 63);
- Table.States (40).Action_List.Set_Capacity (6);
- Add_Action (Table.States (40), 18, (53, 0), 38);
- Add_Action (Table.States (40), 19, (52, 0), 39);
- Add_Action (Table.States (40), 20, (51, 0), 40);
- Add_Action (Table.States (40), 21, (47, 0), 41);
- Add_Action (Table.States (40), 33, (48, 1), 42);
- Add_Action (Table.States (40), 35, (50, 1), 43);
- Table.States (40).Goto_List.Set_Capacity (8);
- Add_Goto (Table.States (40), 47, 46);
- Add_Goto (Table.States (40), 48, 47);
- Add_Goto (Table.States (40), 49, 61);
- Add_Goto (Table.States (40), 50, 49);
- Add_Goto (Table.States (40), 51, 50);
- Add_Goto (Table.States (40), 52, 51);
- Add_Goto (Table.States (40), 53, 52);
- Add_Goto (Table.States (40), 54, 64);
- Table.States (41).Action_List.Set_Capacity (1);
- Add_Action (Table.States (41), 33, (47, 0), 65);
- Table.States (42).Action_List.Set_Capacity (18);
- Add_Action (Table.States (42), 11, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 12, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 16, (48, 1), 66);
- Add_Action (Table.States (42), 18, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 19, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 20, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 21, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 23, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 24, (53, 4), 67);
- Add_Action (Table.States (42), 25, (52, 2), 68);
- Add_Action (Table.States (42), 26, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 27, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 28, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 29, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 31, (53, 5), 69);
- Add_Action (Table.States (42), 33, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 35, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (42), 36, Reduce, (50, 0), 1, null,
null);
- Table.States (43).Action_List.Set_Capacity (15);
- Add_Action (Table.States (43), 11, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 12, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 18, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 19, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 20, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 21, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 23, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 25, (52, 3), 70);
- Add_Action (Table.States (43), 26, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 27, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 28, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 29, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 33, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 35, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Add_Action (Table.States (43), 36, Reduce, (50, 1), 1,
rhs_item_1'Access, null);
- Table.States (44).Action_List.Set_Capacity (5);
- Add_Action (Table.States (44), 12, (45, 1), 71);
- Add_Action (Table.States (44), 23, (45, 2), 72);
- Add_Conflict (Table.States (44), 23, (44, 1), 0, null, null);
- Add_Action (Table.States (44), 29, (44, 0), 73);
- Add_Action (Table.States (44), 33, Reduce, (44, 1), 0, null,
null);
- Add_Action (Table.States (44), 36, Reduce, (44, 1), 0, null,
null);
- Table.States (44).Goto_List.Set_Capacity (1);
- Add_Goto (Table.States (44), 44, 74);
- Table.States (45).Action_List.Set_Capacity (5);
- Add_Action (Table.States (45), (12, 23, 29, 33, 36), (45, 0), 1,
null, null);
- Table.States (46).Action_List.Set_Capacity (14);
- Add_Action (Table.States (46), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 2), 1,
- rhs_item_2'Access, null);
- Table.States (47).Action_List.Set_Capacity (14);
- Add_Action (Table.States (47), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (49, 0), 1, null,
- null);
- Table.States (48).Action_List.Set_Capacity (11);
- Add_Action (Table.States (48), 11, (46, 2), 75);
- Add_Action (Table.States (48), 12, Reduce, (46, 1), 1, null,
null);
- Add_Action (Table.States (48), 18, (53, 0), 38);
- Add_Action (Table.States (48), 19, (52, 0), 39);
- Add_Action (Table.States (48), 20, (51, 0), 40);
- Add_Action (Table.States (48), 21, (47, 0), 41);
- Add_Action (Table.States (48), 23, Reduce, (46, 1), 1, null,
null);
- Add_Action (Table.States (48), 29, Reduce, (46, 1), 1, null,
null);
- Add_Action (Table.States (48), 33, (48, 1), 42);
- Add_Conflict (Table.States (48), 33, (46, 1), 1, null, null);
- Add_Action (Table.States (48), 35, (50, 1), 43);
- Add_Action (Table.States (48), 36, Reduce, (46, 1), 1, null,
null);
- Table.States (48).Goto_List.Set_Capacity (6);
- Add_Goto (Table.States (48), 47, 46);
- Add_Goto (Table.States (48), 48, 76);
- Add_Goto (Table.States (48), 50, 49);
- Add_Goto (Table.States (48), 51, 50);
- Add_Goto (Table.States (48), 52, 51);
- Add_Goto (Table.States (48), 53, 52);
- Table.States (49).Action_List.Set_Capacity (14);
- Add_Action (Table.States (49), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (48, 0), 1, null,
- null);
- Table.States (50).Action_List.Set_Capacity (14);
- Add_Action (Table.States (50), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 5), 1,
- rhs_item_5'Access, null);
- Table.States (51).Action_List.Set_Capacity (14);
- Add_Action (Table.States (51), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 3), 1,
- rhs_item_3'Access, null);
- Table.States (52).Action_List.Set_Capacity (14);
- Add_Action (Table.States (52), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (50, 4), 1,
- rhs_item_4'Access, null);
- Table.States (53).Action_List.Set_Capacity (5);
- Add_Action (Table.States (53), 12, (45, 1), 71);
- Add_Action (Table.States (53), 23, (45, 2), 72);
- Add_Conflict (Table.States (53), 23, (44, 1), 0, null, null);
- Add_Action (Table.States (53), 29, (44, 0), 73);
- Add_Action (Table.States (53), 33, Reduce, (44, 1), 0, null,
null);
- Add_Action (Table.States (53), 36, Reduce, (44, 1), 0, null,
null);
- Table.States (53).Goto_List.Set_Capacity (1);
- Add_Goto (Table.States (53), 44, 77);
- Table.States (54).Action_List.Set_Capacity (3);
- Add_Action (Table.States (54), (23, 33, 36), (38, 1), 4,
declaration_1'Access, null);
- Table.States (55).Action_List.Set_Capacity (2);
- Add_Action (Table.States (55), (9, 33), (40, 1), 2, null, null);
- Table.States (56).Action_List.Set_Capacity (1);
- Add_Action (Table.States (56), 33, (38, 4), 78);
- Table.States (57).Action_List.Set_Capacity (1);
- Add_Action (Table.States (57), 17, (39, 1), 79);
- Table.States (58).Action_List.Set_Capacity (1);
- Add_Action (Table.States (58), 17, (39, 2), 80);
- Table.States (59).Action_List.Set_Capacity (13);
- Add_Action (Table.States (59), (8, 10, 15, 16, 20, 23, 28, 30, 32,
33, 34, 35, 36), (41, 1), 2, null,
- null);
- Table.States (60).Action_List.Set_Capacity (13);
- Add_Action (Table.States (60), 8, (42, 10), 24);
- Add_Action (Table.States (60), 10, (42, 5), 25);
- Add_Action (Table.States (60), 15, (42, 0), 26);
- Add_Action (Table.States (60), 16, (42, 2), 27);
- Add_Action (Table.States (60), 20, (42, 3), 28);
- Add_Action (Table.States (60), 23, Reduce, (38, 0), 4,
declaration_0'Access, null);
- Add_Action (Table.States (60), 28, (42, 6), 29);
- Add_Action (Table.States (60), 30, (42, 7), 30);
- Add_Action (Table.States (60), 32, (42, 4), 31);
- Add_Action (Table.States (60), 33, (42, 1), 32);
- Add_Conflict (Table.States (60), 33, (38, 0), 4,
declaration_0'Access, null);
- Add_Action (Table.States (60), 34, (42, 8), 33);
- Add_Action (Table.States (60), 35, (42, 9), 34);
- Add_Action (Table.States (60), 36, Reduce, (38, 0), 4,
declaration_0'Access, null);
- Table.States (60).Goto_List.Set_Capacity (1);
- Add_Goto (Table.States (60), 42, 59);
- Table.States (61).Action_List.Set_Capacity (10);
- Add_Action (Table.States (61), 12, Reduce, (54, 0), 1, null,
null);
- Add_Action (Table.States (61), 18, (53, 0), 38);
- Add_Action (Table.States (61), 19, (52, 0), 39);
- Add_Action (Table.States (61), 20, (51, 0), 40);
- Add_Action (Table.States (61), 21, (47, 0), 41);
- Add_Action (Table.States (61), 26, Reduce, (54, 0), 1, null,
null);
- Add_Action (Table.States (61), 27, Reduce, (54, 0), 1, null,
null);
- Add_Action (Table.States (61), 28, Reduce, (54, 0), 1, null,
null);
- Add_Action (Table.States (61), 33, (48, 1), 42);
- Add_Action (Table.States (61), 35, (50, 1), 43);
- Table.States (61).Goto_List.Set_Capacity (6);
- Add_Goto (Table.States (61), 47, 46);
- Add_Goto (Table.States (61), 48, 76);
- Add_Goto (Table.States (61), 50, 49);
- Add_Goto (Table.States (61), 51, 50);
- Add_Goto (Table.States (61), 52, 51);
- Add_Goto (Table.States (61), 53, 52);
- Table.States (62).Action_List.Set_Capacity (2);
- Add_Action (Table.States (62), 12, (54, 1), 81);
- Add_Action (Table.States (62), 26, (53, 0), 82);
- Table.States (63).Action_List.Set_Capacity (2);
- Add_Action (Table.States (63), 12, (54, 1), 81);
- Add_Action (Table.States (63), 27, (52, 0), 83);
- Table.States (64).Action_List.Set_Capacity (2);
- Add_Action (Table.States (64), 12, (54, 1), 81);
- Add_Action (Table.States (64), 28, (51, 0), 84);
- Table.States (65).Action_List.Set_Capacity (1);
- Add_Action (Table.States (65), 16, (47, 0), 85);
- Table.States (66).Action_List.Set_Capacity (6);
- Add_Action (Table.States (66), 18, (53, 0), 38);
- Add_Action (Table.States (66), 19, (52, 0), 39);
- Add_Action (Table.States (66), 20, (51, 0), 40);
- Add_Action (Table.States (66), 21, (47, 0), 41);
- Add_Action (Table.States (66), 33, (50, 0), 86);
- Add_Action (Table.States (66), 35, (50, 1), 43);
- Table.States (66).Goto_List.Set_Capacity (5);
- Add_Goto (Table.States (66), 47, 46);
- Add_Goto (Table.States (66), 50, 87);
- Add_Goto (Table.States (66), 51, 50);
- Add_Goto (Table.States (66), 52, 51);
- Add_Goto (Table.States (66), 53, 52);
- Table.States (67).Action_List.Set_Capacity (14);
- Add_Action (Table.States (67), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 4), 2, null,
- null);
- Table.States (68).Action_List.Set_Capacity (14);
- Add_Action (Table.States (68), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 2), 2, null,
- null);
- Table.States (69).Action_List.Set_Capacity (14);
- Add_Action (Table.States (69), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 5), 2, null,
- null);
- Table.States (70).Action_List.Set_Capacity (14);
- Add_Action (Table.States (70), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 3), 2,
- rhs_optional_item_3'Access, null);
- Table.States (71).Action_List.Set_Capacity (10);
- Add_Action (Table.States (71), 12, Reduce, (46, 0), 0, null,
null);
- Add_Action (Table.States (71), 18, (53, 0), 38);
- Add_Action (Table.States (71), 19, (52, 0), 39);
- Add_Action (Table.States (71), 20, (51, 0), 40);
- Add_Action (Table.States (71), 21, (47, 0), 41);
- Add_Action (Table.States (71), 23, Reduce, (46, 0), 0, null,
null);
- Add_Action (Table.States (71), 29, Reduce, (46, 0), 0, null,
null);
- Add_Action (Table.States (71), 33, (48, 1), 42);
- Add_Conflict (Table.States (71), 33, (46, 0), 0, null, null);
- Add_Action (Table.States (71), 35, (50, 1), 43);
- Add_Action (Table.States (71), 36, Reduce, (46, 0), 0, null,
null);
- Table.States (71).Goto_List.Set_Capacity (8);
- Add_Goto (Table.States (71), 46, 88);
- Add_Goto (Table.States (71), 47, 46);
- Add_Goto (Table.States (71), 48, 47);
- Add_Goto (Table.States (71), 49, 48);
- Add_Goto (Table.States (71), 50, 49);
- Add_Goto (Table.States (71), 51, 50);
- Add_Goto (Table.States (71), 52, 51);
- Add_Goto (Table.States (71), 53, 52);
- Table.States (72).Action_List.Set_Capacity (2);
- Add_Action (Table.States (72), 4, (45, 3), 89);
- Add_Action (Table.States (72), 5, (45, 2), 90);
- Table.States (73).Action_List.Set_Capacity (3);
- Add_Action (Table.States (73), (23, 33, 36), (44, 0), 1, null,
null);
- Table.States (74).Action_List.Set_Capacity (3);
- Add_Action (Table.States (74), (23, 33, 36), (43, 0), 4,
nonterminal_0'Access, null);
- Table.States (75).Action_List.Set_Capacity (6);
- Add_Action (Table.States (75), 11, (46, 3), 91);
- Add_Action (Table.States (75), 12, Reduce, (46, 2), 2, null,
null);
- Add_Action (Table.States (75), 23, Reduce, (46, 2), 2, null,
null);
- Add_Action (Table.States (75), 29, Reduce, (46, 2), 2, null,
null);
- Add_Action (Table.States (75), 33, Reduce, (46, 2), 2, null,
null);
- Add_Action (Table.States (75), 36, Reduce, (46, 2), 2, null,
null);
- Table.States (76).Action_List.Set_Capacity (14);
- Add_Action (Table.States (76), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (49, 1), 2, null,
- null);
- Table.States (77).Action_List.Set_Capacity (3);
- Add_Action (Table.States (77), (23, 33, 36), (43, 1), 4,
nonterminal_1'Access, null);
- Table.States (78).Action_List.Set_Capacity (3);
- Add_Action (Table.States (78), (23, 33, 36), (38, 4), 5,
declaration_4'Access, null);
- Table.States (79).Action_List.Set_Capacity (1);
- Add_Action (Table.States (79), (1 => 33), (39, 1), 4, null,
null);
- Table.States (80).Action_List.Set_Capacity (1);
- Add_Action (Table.States (80), (1 => 33), (39, 2), 4, null,
null);
- Table.States (81).Action_List.Set_Capacity (6);
- Add_Action (Table.States (81), 18, (53, 0), 38);
- Add_Action (Table.States (81), 19, (52, 0), 39);
- Add_Action (Table.States (81), 20, (51, 0), 40);
- Add_Action (Table.States (81), 21, (47, 0), 41);
- Add_Action (Table.States (81), 33, (48, 1), 42);
- Add_Action (Table.States (81), 35, (50, 1), 43);
- Table.States (81).Goto_List.Set_Capacity (7);
- Add_Goto (Table.States (81), 47, 46);
- Add_Goto (Table.States (81), 48, 47);
- Add_Goto (Table.States (81), 49, 92);
- Add_Goto (Table.States (81), 50, 49);
- Add_Goto (Table.States (81), 51, 50);
- Add_Goto (Table.States (81), 52, 51);
- Add_Goto (Table.States (81), 53, 52);
- Table.States (82).Action_List.Set_Capacity (15);
- Add_Action (Table.States (82), 11, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 12, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 18, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 19, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 20, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 21, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 22, (53, 1), 93);
- Add_Action (Table.States (82), 23, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 26, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 27, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 28, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 29, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 33, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 35, Reduce, (53, 0), 3, null,
null);
- Add_Action (Table.States (82), 36, Reduce, (53, 0), 3, null,
null);
- Table.States (83).Action_List.Set_Capacity (14);
- Add_Action (Table.States (83), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 0), 3, null,
- null);
- Table.States (84).Action_List.Set_Capacity (17);
- Add_Action (Table.States (84), 11, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 12, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 18, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 19, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 20, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 21, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 23, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 24, (53, 2), 94);
- Add_Action (Table.States (84), 25, (52, 1), 95);
- Add_Action (Table.States (84), 26, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 27, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 28, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 29, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 31, (53, 3), 96);
- Add_Action (Table.States (84), 33, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 35, Reduce, (51, 0), 3, null,
null);
- Add_Action (Table.States (84), 36, Reduce, (51, 0), 3, null,
null);
- Table.States (85).Action_List.Set_Capacity (1);
- Add_Action (Table.States (85), 33, (47, 0), 97);
- Table.States (86).Action_List.Set_Capacity (17);
- Add_Action (Table.States (86), 11, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 12, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 18, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 19, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 20, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 21, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 23, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 24, (53, 4), 67);
- Add_Action (Table.States (86), 25, (52, 2), 68);
- Add_Action (Table.States (86), 26, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 27, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 28, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 29, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 31, (53, 5), 69);
- Add_Action (Table.States (86), 33, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 35, Reduce, (50, 0), 1, null,
null);
- Add_Action (Table.States (86), 36, Reduce, (50, 0), 1, null,
null);
- Table.States (87).Action_List.Set_Capacity (14);
- Add_Action (Table.States (87), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (48, 1), 3, null,
- null);
- Table.States (88).Action_List.Set_Capacity (5);
- Add_Action (Table.States (88), (12, 23, 29, 33, 36), (45, 1), 3,
null, null);
- Table.States (89).Action_List.Set_Capacity (1);
- Add_Action (Table.States (89), 5, (45, 3), 98);
- Table.States (90).Action_List.Set_Capacity (1);
- Add_Action (Table.States (90), 33, (45, 2), 99);
- Table.States (91).Action_List.Set_Capacity (5);
- Add_Action (Table.States (91), (12, 23, 29, 33, 36), (46, 3), 3,
null, null);
- Table.States (92).Action_List.Set_Capacity (10);
- Add_Action (Table.States (92), 12, Reduce, (54, 1), 3, null,
null);
- Add_Action (Table.States (92), 18, (53, 0), 38);
- Add_Action (Table.States (92), 19, (52, 0), 39);
- Add_Action (Table.States (92), 20, (51, 0), 40);
- Add_Action (Table.States (92), 21, (47, 0), 41);
- Add_Action (Table.States (92), 26, Reduce, (54, 1), 3, null,
null);
- Add_Action (Table.States (92), 27, Reduce, (54, 1), 3, null,
null);
- Add_Action (Table.States (92), 28, Reduce, (54, 1), 3, null,
null);
- Add_Action (Table.States (92), 33, (48, 1), 42);
- Add_Action (Table.States (92), 35, (50, 1), 43);
- Table.States (92).Goto_List.Set_Capacity (6);
- Add_Goto (Table.States (92), 47, 46);
- Add_Goto (Table.States (92), 48, 76);
- Add_Goto (Table.States (92), 50, 49);
- Add_Goto (Table.States (92), 51, 50);
- Add_Goto (Table.States (92), 52, 51);
- Add_Goto (Table.States (92), 53, 52);
- Table.States (93).Action_List.Set_Capacity (14);
- Add_Action (Table.States (93), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 1), 4, null,
- null);
- Table.States (94).Action_List.Set_Capacity (14);
- Add_Action (Table.States (94), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 2), 4, null,
- null);
- Table.States (95).Action_List.Set_Capacity (14);
- Add_Action (Table.States (95), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (52, 1), 4, null,
- null);
- Table.States (96).Action_List.Set_Capacity (14);
- Add_Action (Table.States (96), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (53, 3), 4, null,
- null);
- Table.States (97).Action_List.Set_Capacity (1);
- Add_Action (Table.States (97), 17, (47, 0), 100);
- Table.States (98).Action_List.Set_Capacity (5);
- Add_Action (Table.States (98), (12, 23, 29, 33, 36), (45, 3), 4,
null, null);
- Table.States (99).Action_List.Set_Capacity (1);
- Add_Action (Table.States (99), 16, (45, 2), 101);
- Table.States (100).Action_List.Set_Capacity (14);
- Add_Action (Table.States (100), (11, 12, 18, 19, 20, 21, 23, 26,
27, 28, 29, 33, 35, 36), (47, 0), 5,
- null, null);
- Table.States (101).Action_List.Set_Capacity (1);
- Add_Action (Table.States (101), 33, (45, 2), 102);
- Table.States (102).Action_List.Set_Capacity (5);
- Add_Action (Table.States (102), (12, 23, 29, 33, 36), (45, 2), 6,
null, null);
- end Subr_1;
- begin
- Subr_1;
- Table.Error_Action := new Parse_Action_Node'((Verb => Error, others
=> <>), null);
- end;
-
- WisiToken.Parse.LR.Parser_No_Recover.New_Parser
- (Parser,
- Trace,
- Lexer.New_Lexer (Trace.Descriptor),
- Table,
- User_Data,
- Max_Parallel => 15,
- Terminate_Same_State => True);
- end Create_Parser;
-end Wisitoken_Grammar_Main;
diff --git a/packages/wisi/wisitoken_grammar_main.ads
b/packages/wisi/wisitoken_grammar_main.ads
deleted file mode 100644
index 35a5e9e..0000000
--- a/packages/wisi/wisitoken_grammar_main.ads
+++ /dev/null
@@ -1,34 +0,0 @@
--- generated parser support file.
--- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c PROCESS
wisitoken_grammar.wy
---
-
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- Author: Stephen Leake <stephe-leake@stephe-leake.org>
---
--- This file is part of GNU Emacs.
---
--- GNU Emacs is free software: you can redistribute it and/or modify
--- it under the terms of the GNU General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- (at your option) any later version.
---
--- GNU Emacs is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU General Public License for more details.
---
--- You should have received a copy of the GNU General Public License
--- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-with WisiToken.Syntax_Trees;
-with WisiToken.Parse.LR.Parser_No_Recover;
-package Wisitoken_Grammar_Main is
-
- procedure Create_Parser
- (Parser : out
WisiToken.Parse.LR.Parser_No_Recover.Parser;
- -- no error recovery
- Trace : not null access WisiToken.Trace'Class;
- User_Data : in
WisiToken.Syntax_Trees.User_Data_Access);
-
-end Wisitoken_Grammar_Main;
diff --git a/packages/wisi/wisitoken_grammar_re2c.c
b/packages/wisi/wisitoken_grammar_re2c.c
deleted file mode 100644
index b58f1d0..0000000
--- a/packages/wisi/wisitoken_grammar_re2c.c
+++ /dev/null
@@ -1,4303 +0,0 @@
-/* Generated by re2c 1.3 */
-#line 1 "../wisitoken_grammar.re2c"
-// generated parser support file. -*- mode: C -*-
-// command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
-//
-
-// Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
-//
-// Author: Stephen Leake <stephe-leake@stephe-leake.org>
-//
-// This file is part of GNU Emacs.
-//
-// GNU Emacs is free software: you can redistribute it and/or modify
-// it under the terms of the GNU General Public License as published by
-// the Free Software Foundation, either version 3 of the License, or
-// (at your option) any later version.
-//
-// GNU Emacs is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-//
-// You should have received a copy of the GNU General Public License
-// along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-#include <stddef.h>
-#include <stdio.h>
-#include <stdlib.h>
-
-typedef struct wisi_lexer
-{
- unsigned char* buffer; // input text, in utf-8 encoding
- unsigned char* buffer_last; // last byte in buffer
- unsigned char* cursor; // current byte
- unsigned char* byte_token_start; // byte position at start of current token
- size_t char_pos; // character position of current character
- size_t char_token_start; // character position at start of current
token
- int line; // 1 indexed
- int line_token_start; // line at start of current token
- unsigned char* marker; // saved cursor
- size_t marker_pos; // saved character position
- size_t marker_line; // saved line
- unsigned char* context; // saved cursor
- size_t context_pos; // saved character position
- int context_line; // saved line
- int verbosity;
-
-} wisi_lexer;
-
-#define YYCTYPE unsigned char
-
-#define NO_ERROR 0
-#define ERROR_unrecognized_character 1
-wisi_lexer* wisitoken_grammar_new_lexer
- (unsigned char* input, size_t length, int verbosity)
-{
- wisi_lexer* result = malloc (sizeof (wisi_lexer));
- result->buffer = input;
- result->buffer_last = input + length - 1;
- result->cursor = input;
- result->byte_token_start = input;
- result->char_pos = 1; /* match WisiToken.Buffer_Region */
- result->char_token_start = 1;
- result->line = (*result->cursor == 0x0A) ? 2 : 1;
- result->line_token_start = result->line;
- result->verbosity = verbosity;
- return result;
-}
-
-void
-wisitoken_grammar_free_lexer(wisi_lexer** lexer)
-{
- free(*lexer);
- *lexer = 0;
-}
-
-void
-wisitoken_grammar_reset_lexer(wisi_lexer* lexer)
-{
- lexer->cursor = lexer->buffer;
- lexer->char_pos = 1;
- lexer->line = (*lexer->cursor == 0x0A) ? 2 : 1;
-}
-
-static void debug(wisi_lexer* lexer, int state, unsigned char ch)
-{
- if (lexer->verbosity > 0)
- {
- if (ch < ' ')
- printf ("lexer: %d, 0x%x\n", state, ch);
- else
- printf ("lexer: %d, '%c' 0x%x\n", state, ch, ch);
- }
-}
-#define YYDEBUG(state, ch) debug(lexer, state, ch)
-#define YYCURSOR lexer->cursor
-
-#define YYPEEK() (lexer->cursor <= lexer->buffer_last) ? *lexer->cursor : 4
-
-static void skip(wisi_lexer* lexer)
-{
- if (lexer->cursor <= lexer->buffer_last)
- ++lexer->cursor;
- if (lexer->cursor <= lexer->buffer_last)
- {
- /* UFT-8 encoding: https://en.wikipedia.org/wiki/UTF-8#Description */
- if (*lexer->cursor == 0x0A && lexer->cursor > lexer->buffer &&
*(lexer->cursor - 1) == 0x0D)
- {/* second byte of DOS line ending */
- }
- else if ((*lexer->cursor & 0x80) == 0x80 && (*lexer->cursor & 0xC0) !=
0xC0)
- {/* byte 2, 3 or 4 of multi-byte UTF-8 char */
- }
- else
- ++lexer->char_pos;
- if (*lexer->cursor == 0x0A) ++lexer->line;
- }
-}
-#define YYSKIP() skip(lexer)
-#define YYBACKUP() lexer->marker = lexer->cursor; lexer->marker_pos =
lexer->char_pos;lexer->marker_line = lexer->line
-#define YYRESTORE() lexer->cursor = lexer->marker; lexer->char_pos =
lexer->marker_pos;lexer->line = lexer->marker_line
-#define YYBACKUPCTX() lexer->context = lexer->cursor; lexer->context_pos =
lexer->char_pos;lexer->context_line = lexer->line
-#define YYRESTORECTX() lexer->cursor = lexer->context; lexer->char_pos =
lexer->context_pos;lexer->line = lexer->context_line
-
-static void skip_to(wisi_lexer* lexer, char* target)
-{
- int i;
-
- while (lexer->cursor <= lexer->buffer_last)
- {
- if (*lexer->cursor == target[0])
- {
- i = 0;
- do
- i++;
- while (0 != target[i] &&
- lexer->cursor + i <= lexer->buffer_last &&
- *(lexer->cursor + i) == target[i]);
-
- if (0 == target[i])
- {
- for (i = 0; 0 != target[i]; i++)
- skip(lexer);
- break;
- }
- }
- skip(lexer);
- };
-}
-
-int wisitoken_grammar_next_token
- (wisi_lexer* lexer,
- int* id,
- size_t* byte_position,
- size_t* byte_length,
- size_t* char_position,
- size_t* char_length,
- int* line_start)
-{
- int status = NO_ERROR;
- *id = -1;
- if (lexer->cursor > lexer->buffer_last)
- {
- *id = 36;
- *byte_position = lexer->buffer_last - lexer->buffer + 1;
- *byte_length = 0;
- *char_position = lexer->char_token_start;
- *char_length = 0;
- *line_start = lexer->line;
- return status;
- }
-
- lexer->byte_token_start = lexer->cursor;
- lexer->char_token_start = lexer->char_pos;
- if (*lexer->cursor == 0x0A)
- lexer->line_token_start = lexer->line-1;
- else
- lexer->line_token_start = lexer->line;
-
- while (*id == -1 && status == 0)
- {
-
-#line 183 "../wisitoken_grammar_re2c.c"
-{
- YYCTYPE yych;
- unsigned int yyaccept = 0;
- YYDEBUG(0, *YYCURSOR);
- yych = YYPEEK ();
- switch (yych) {
- case 0x04: goto yy4;
- case '\t':
- case ' ': goto yy6;
- case '\n': goto yy8;
- case '\r': goto yy10;
- case '"': goto yy11;
- case '%': goto yy12;
- case '\'': goto yy14;
- case '(': goto yy15;
- case ')': goto yy17;
- case '*': goto yy19;
- case '+': goto yy21;
- case ',': goto yy23;
- case '-': goto yy25;
- case '/': goto yy27;
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9': goto yy29;
- case ':': goto yy32;
- case ';': goto yy34;
- case '<': goto yy36;
- case '=': goto yy38;
- case '>': goto yy40;
- case '?': goto yy42;
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case 'a':
- case 'b':
- case 'd':
- case 'f':
- case 'g':
- case 'h':
- case 'j':
- case 'l':
- case 'm':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z': goto yy44;
- case '[': goto yy47;
- case ']': goto yy49;
- case 'c': goto yy51;
- case 'e': goto yy52;
- case 'i': goto yy53;
- case 'k': goto yy54;
- case 'n': goto yy55;
- case 't': goto yy56;
- case '{': goto yy57;
- case '|': goto yy59;
- case '}': goto yy61;
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF: goto yy63;
- case 0xE0: goto yy64;
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF: goto yy65;
- case 0xF0: goto yy66;
- case 0xF1:
- case 0xF2:
- case 0xF3: goto yy67;
- case 0xF4: goto yy68;
- default: goto yy2;
- }
-yy2:
- YYDEBUG(2, YYPEEK ());
- YYSKIP ();
-yy3:
- YYDEBUG(3, YYPEEK ());
-#line 262 "../wisitoken_grammar.re2c"
- {status = ERROR_unrecognized_character; continue;}
-#line 338 "../wisitoken_grammar_re2c.c"
-yy4:
- YYDEBUG(4, YYPEEK ());
- YYSKIP ();
- YYDEBUG(5, YYPEEK ());
-#line 260 "../wisitoken_grammar.re2c"
- {*id = 36; continue;}
-#line 345 "../wisitoken_grammar_re2c.c"
-yy6:
- YYDEBUG(6, YYPEEK ());
- YYSKIP ();
- YYDEBUG(7, YYPEEK ());
-#line 218 "../wisitoken_grammar.re2c"
- { lexer->byte_token_start = lexer->cursor;
- lexer->char_token_start = lexer->char_pos;
- if (*lexer->cursor == 0x0A)
- lexer->line_token_start = lexer->line-1;
- else
- lexer->line_token_start = lexer->line;
- continue; }
-#line 358 "../wisitoken_grammar_re2c.c"
-yy8:
- YYDEBUG(8, YYPEEK ());
- YYSKIP ();
- YYDEBUG(9, YYPEEK ());
-#line 225 "../wisitoken_grammar.re2c"
- {*id = 1; continue;}
-#line 365 "../wisitoken_grammar_re2c.c"
-yy10:
- YYDEBUG(10, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case '\n': goto yy8;
- default: goto yy3;
- }
-yy11:
- YYDEBUG(11, YYPEEK ());
- yyaccept = 0;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case ' ':
- case '!':
- case '"':
- case '#':
- case '$':
- case '%':
- case '&':
- case '\'':
- case '(':
- case ')':
- case '*':
- case '+':
- case ',':
- case '-':
- case '.':
- case '/':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case ':':
- case ';':
- case '<':
- case '=':
- case '>':
- case '?':
- case '@':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '[':
- case '\\':
- case ']':
- case '^':
- case '_':
- case '`':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case '{':
- case '|':
- case '}':
- case '~':
- case 0x7F:
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF:
- case 0xE0:
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF:
- case 0xF0:
- case 0xF1:
- case 0xF2:
- case 0xF3:
- case 0xF4: goto yy70;
- default: goto yy3;
- }
-yy12:
- YYDEBUG(12, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case '(': goto yy80;
- case '[': goto yy82;
- case '{': goto yy84;
- default: goto yy13;
- }
-yy13:
- YYDEBUG(13, YYPEEK ());
-#line 247 "../wisitoken_grammar.re2c"
- {*id = 23; continue;}
-#line 544 "../wisitoken_grammar_re2c.c"
-yy14:
- YYDEBUG(14, YYPEEK ());
- yyaccept = 0;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case ' ':
- case '!':
- case '"':
- case '#':
- case '$':
- case '%':
- case '&':
- case '\'':
- case '(':
- case ')':
- case '*':
- case '+':
- case ',':
- case '-':
- case '.':
- case '/':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case ':':
- case ';':
- case '<':
- case '=':
- case '>':
- case '?':
- case '@':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '[':
- case '\\':
- case ']':
- case '^':
- case '_':
- case '`':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case '{':
- case '|':
- case '}':
- case '~':
- case 0x7F:
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF:
- case 0xE0:
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF:
- case 0xF0:
- case 0xF1:
- case 0xF2:
- case 0xF3:
- case 0xF4: goto yy87;
- default: goto yy3;
- }
-yy15:
- YYDEBUG(15, YYPEEK ());
- YYSKIP ();
- YYDEBUG(16, YYPEEK ());
-#line 244 "../wisitoken_grammar.re2c"
- {*id = 20; continue;}
-#line 707 "../wisitoken_grammar_re2c.c"
-yy17:
- YYDEBUG(17, YYPEEK ());
- YYSKIP ();
- YYDEBUG(18, YYPEEK ());
-#line 252 "../wisitoken_grammar.re2c"
- {*id = 28; continue;}
-#line 714 "../wisitoken_grammar_re2c.c"
-yy19:
- YYDEBUG(19, YYPEEK ());
- YYSKIP ();
- YYDEBUG(20, YYPEEK ());
-#line 255 "../wisitoken_grammar.re2c"
- {*id = 31; continue;}
-#line 721 "../wisitoken_grammar_re2c.c"
-yy21:
- YYDEBUG(21, YYPEEK ());
- YYSKIP ();
- YYDEBUG(22, YYPEEK ());
-#line 248 "../wisitoken_grammar.re2c"
- {*id = 24; continue;}
-#line 728 "../wisitoken_grammar_re2c.c"
-yy23:
- YYDEBUG(23, YYPEEK ());
- YYSKIP ();
- YYDEBUG(24, YYPEEK ());
-#line 239 "../wisitoken_grammar.re2c"
- {*id = 15; continue;}
-#line 735 "../wisitoken_grammar_re2c.c"
-yy25:
- YYDEBUG(25, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case '_': goto yy29;
- default: goto yy26;
- }
-yy26:
- YYDEBUG(26, YYPEEK ());
-#line 246 "../wisitoken_grammar.re2c"
- {*id = 22; continue;}
-#line 758 "../wisitoken_grammar_re2c.c"
-yy27:
- YYDEBUG(27, YYPEEK ());
- YYSKIP ();
- YYDEBUG(28, YYPEEK ());
-#line 254 "../wisitoken_grammar.re2c"
- {*id = 30; continue;}
-#line 765 "../wisitoken_grammar_re2c.c"
-yy29:
- YYDEBUG(29, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- YYDEBUG(30, YYPEEK ());
- switch (yych) {
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case '_': goto yy29;
- default: goto yy31;
- }
-yy31:
- YYDEBUG(31, YYPEEK ());
-#line 256 "../wisitoken_grammar.re2c"
- {*id = 32; continue;}
-#line 789 "../wisitoken_grammar_re2c.c"
-yy32:
- YYDEBUG(32, YYPEEK ());
- yyaccept = 1;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case ':': goto yy96;
- default: goto yy33;
- }
-yy33:
- YYDEBUG(33, YYPEEK ());
-#line 237 "../wisitoken_grammar.re2c"
- {*id = 13; continue;}
-#line 804 "../wisitoken_grammar_re2c.c"
-yy34:
- YYDEBUG(34, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case ';': goto yy97;
- default: goto yy35;
- }
-yy35:
- YYDEBUG(35, YYPEEK ());
-#line 253 "../wisitoken_grammar.re2c"
- {*id = 29; continue;}
-#line 817 "../wisitoken_grammar_re2c.c"
-yy36:
- YYDEBUG(36, YYPEEK ());
- YYSKIP ();
- YYDEBUG(37, YYPEEK ());
-#line 245 "../wisitoken_grammar.re2c"
- {*id = 21; continue;}
-#line 824 "../wisitoken_grammar_re2c.c"
-yy38:
- YYDEBUG(38, YYPEEK ());
- YYSKIP ();
- YYDEBUG(39, YYPEEK ());
-#line 240 "../wisitoken_grammar.re2c"
- {*id = 16; continue;}
-#line 831 "../wisitoken_grammar_re2c.c"
-yy40:
- YYDEBUG(40, YYPEEK ());
- YYSKIP ();
- YYDEBUG(41, YYPEEK ());
-#line 241 "../wisitoken_grammar.re2c"
- {*id = 17; continue;}
-#line 838 "../wisitoken_grammar_re2c.c"
-yy42:
- YYDEBUG(42, YYPEEK ());
- YYSKIP ();
- YYDEBUG(43, YYPEEK ());
-#line 249 "../wisitoken_grammar.re2c"
- {*id = 25; continue;}
-#line 845 "../wisitoken_grammar_re2c.c"
-yy44:
- YYDEBUG(44, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
-yy45:
- YYDEBUG(45, YYPEEK ());
- switch (yych) {
- case '-':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z': goto yy44;
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF: goto yy100;
- case 0xE0: goto yy101;
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF: goto yy102;
- case 0xF0: goto yy103;
- case 0xF1:
- case 0xF2:
- case 0xF3: goto yy104;
- case 0xF4: goto yy105;
- default: goto yy46;
- }
-yy46:
- YYDEBUG(46, YYPEEK ());
-#line 257 "../wisitoken_grammar.re2c"
- {*id = 33; continue;}
-#line 976 "../wisitoken_grammar_re2c.c"
-yy47:
- YYDEBUG(47, YYPEEK ());
- YYSKIP ();
- YYDEBUG(48, YYPEEK ());
-#line 243 "../wisitoken_grammar.re2c"
- {*id = 19; continue;}
-#line 983 "../wisitoken_grammar_re2c.c"
-yy49:
- YYDEBUG(49, YYPEEK ());
- YYSKIP ();
- YYDEBUG(50, YYPEEK ());
-#line 251 "../wisitoken_grammar.re2c"
- {*id = 27; continue;}
-#line 990 "../wisitoken_grammar_re2c.c"
-yy51:
- YYDEBUG(51, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'o': goto yy106;
- default: goto yy45;
- }
-yy52:
- YYDEBUG(52, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'n': goto yy107;
- default: goto yy45;
- }
-yy53:
- YYDEBUG(53, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'f': goto yy108;
- default: goto yy45;
- }
-yy54:
- YYDEBUG(54, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'e': goto yy110;
- default: goto yy45;
- }
-yy55:
- YYDEBUG(55, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'o': goto yy111;
- default: goto yy45;
- }
-yy56:
- YYDEBUG(56, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'o': goto yy112;
- default: goto yy45;
- }
-yy57:
- YYDEBUG(57, YYPEEK ());
- YYSKIP ();
- YYDEBUG(58, YYPEEK ());
-#line 242 "../wisitoken_grammar.re2c"
- {*id = 18; continue;}
-#line 1057 "../wisitoken_grammar_re2c.c"
-yy59:
- YYDEBUG(59, YYPEEK ());
- YYSKIP ();
- YYDEBUG(60, YYPEEK ());
-#line 236 "../wisitoken_grammar.re2c"
- {*id = 12; continue;}
-#line 1064 "../wisitoken_grammar_re2c.c"
-yy61:
- YYDEBUG(61, YYPEEK ());
- YYSKIP ();
- YYDEBUG(62, YYPEEK ());
-#line 250 "../wisitoken_grammar.re2c"
- {*id = 26; continue;}
-#line 1071 "../wisitoken_grammar_re2c.c"
-yy63:
- YYDEBUG(63, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy44;
- default: goto yy3;
- }
-yy64:
- YYDEBUG(64, YYPEEK ());
- yyaccept = 0;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy100;
- default: goto yy3;
- }
-yy65:
- YYDEBUG(65, YYPEEK ());
- yyaccept = 0;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy100;
- default: goto yy3;
- }
-yy66:
- YYDEBUG(66, YYPEEK ());
- yyaccept = 0;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy102;
- default: goto yy3;
- }
-yy67:
- YYDEBUG(67, YYPEEK ());
- yyaccept = 0;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy102;
- default: goto yy3;
- }
-yy68:
- YYDEBUG(68, YYPEEK ());
- yyaccept = 0;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F: goto yy102;
- default: goto yy3;
- }
-yy69:
- YYDEBUG(69, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
-yy70:
- YYDEBUG(70, YYPEEK ());
- switch (yych) {
- case ' ':
- case '!':
- case '#':
- case '$':
- case '%':
- case '&':
- case '\'':
- case '(':
- case ')':
- case '*':
- case '+':
- case ',':
- case '-':
- case '.':
- case '/':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case ':':
- case ';':
- case '<':
- case '=':
- case '>':
- case '?':
- case '@':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '[':
- case '\\':
- case ']':
- case '^':
- case '_':
- case '`':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case '{':
- case '|':
- case '}':
- case '~':
- case 0x7F: goto yy69;
- case '"': goto yy72;
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF: goto yy74;
- case 0xE0: goto yy75;
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF: goto yy76;
- case 0xF0: goto yy77;
- case 0xF1:
- case 0xF2:
- case 0xF3: goto yy78;
- case 0xF4: goto yy79;
- default: goto yy71;
- }
-yy71:
- YYDEBUG(71, YYPEEK ());
- YYRESTORE ();
- switch (yyaccept) {
- case 0: goto yy3;
- case 1: goto yy33;
- case 2: goto yy46;
- case 3: goto yy73;
- case 4: goto yy89;
- case 5: goto yy99;
- case 6: goto yy109;
- case 7: goto yy123;
- case 8: goto yy128;
- case 9: goto yy135;
- case 10: goto yy139;
- default: goto yy145;
- }
-yy72:
- YYDEBUG(72, YYPEEK ());
- yyaccept = 3;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case '"': goto yy69;
- default: goto yy73;
- }
-yy73:
- YYDEBUG(73, YYPEEK ());
-#line 258 "../wisitoken_grammar.re2c"
- {*id = 34; continue;}
-#line 1599 "../wisitoken_grammar_re2c.c"
-yy74:
- YYDEBUG(74, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy69;
- default: goto yy71;
- }
-yy75:
- YYDEBUG(75, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy74;
- default: goto yy71;
- }
-yy76:
- YYDEBUG(76, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy74;
- default: goto yy71;
- }
-yy77:
- YYDEBUG(77, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy76;
- default: goto yy71;
- }
-yy78:
- YYDEBUG(78, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy76;
- default: goto yy71;
- }
-yy79:
- YYDEBUG(79, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F: goto yy76;
- default: goto yy71;
- }
-yy80:
- YYDEBUG(80, YYPEEK ());
- YYSKIP ();
- YYDEBUG(81, YYPEEK ());
-#line 235 "../wisitoken_grammar.re2c"
- {*id = 11; skip_to(lexer, ")%"); continue;}
-#line 1936 "../wisitoken_grammar_re2c.c"
-yy82:
- YYDEBUG(82, YYPEEK ());
- YYSKIP ();
- YYDEBUG(83, YYPEEK ());
-#line 234 "../wisitoken_grammar.re2c"
- {*id = 10; skip_to(lexer, "]%"); continue;}
-#line 1943 "../wisitoken_grammar_re2c.c"
-yy84:
- YYDEBUG(84, YYPEEK ());
- YYSKIP ();
- YYDEBUG(85, YYPEEK ());
-#line 233 "../wisitoken_grammar.re2c"
- {*id = 9; skip_to(lexer, "}%"); continue;}
-#line 1950 "../wisitoken_grammar_re2c.c"
-yy86:
- YYDEBUG(86, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
-yy87:
- YYDEBUG(87, YYPEEK ());
- switch (yych) {
- case ' ':
- case '!':
- case '"':
- case '#':
- case '$':
- case '%':
- case '&':
- case '(':
- case ')':
- case '*':
- case '+':
- case ',':
- case '-':
- case '.':
- case '/':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case ':':
- case ';':
- case '<':
- case '=':
- case '>':
- case '?':
- case '@':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '[':
- case '\\':
- case ']':
- case '^':
- case '_':
- case '`':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case '{':
- case '|':
- case '}':
- case '~':
- case 0x7F: goto yy86;
- case '\'': goto yy88;
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF: goto yy90;
- case 0xE0: goto yy91;
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF: goto yy92;
- case 0xF0: goto yy93;
- case 0xF1:
- case 0xF2:
- case 0xF3: goto yy94;
- case 0xF4: goto yy95;
- default: goto yy71;
- }
-yy88:
- YYDEBUG(88, YYPEEK ());
- yyaccept = 4;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case '\'': goto yy86;
- default: goto yy89;
- }
-yy89:
- YYDEBUG(89, YYPEEK ());
-#line 259 "../wisitoken_grammar.re2c"
- {*id = 35; continue;}
-#line 2121 "../wisitoken_grammar_re2c.c"
-yy90:
- YYDEBUG(90, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy86;
- default: goto yy71;
- }
-yy91:
- YYDEBUG(91, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy90;
- default: goto yy71;
- }
-yy92:
- YYDEBUG(92, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy90;
- default: goto yy71;
- }
-yy93:
- YYDEBUG(93, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy92;
- default: goto yy71;
- }
-yy94:
- YYDEBUG(94, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy92;
- default: goto yy71;
- }
-yy95:
- YYDEBUG(95, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F: goto yy92;
- default: goto yy71;
- }
-yy96:
- YYDEBUG(96, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case '=': goto yy113;
- default: goto yy71;
- }
-yy97:
- YYDEBUG(97, YYPEEK ());
- yyaccept = 5;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- YYDEBUG(98, YYPEEK ());
- switch (yych) {
- case 0x00:
- case 0x01:
- case 0x02:
- case 0x03:
- case 0x05:
- case 0x06:
- case 0x07:
- case 0x08:
- case '\t':
- case '\v':
- case '\f':
- case '\r':
- case 0x0E:
- case 0x0F:
- case 0x10:
- case 0x11:
- case 0x12:
- case 0x13:
- case 0x14:
- case 0x15:
- case 0x16:
- case 0x17:
- case 0x18:
- case 0x19:
- case 0x1A:
- case 0x1B:
- case 0x1C:
- case 0x1D:
- case 0x1E:
- case 0x1F:
- case ' ':
- case '!':
- case '"':
- case '#':
- case '$':
- case '%':
- case '&':
- case '\'':
- case '(':
- case ')':
- case '*':
- case '+':
- case ',':
- case '-':
- case '.':
- case '/':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case ':':
- case ';':
- case '<':
- case '=':
- case '>':
- case '?':
- case '@':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '[':
- case '\\':
- case ']':
- case '^':
- case '_':
- case '`':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case '{':
- case '|':
- case '}':
- case '~':
- case 0x7F: goto yy97;
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF: goto yy115;
- case 0xE0: goto yy116;
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF: goto yy117;
- case 0xF0: goto yy118;
- case 0xF1:
- case 0xF2:
- case 0xF3: goto yy119;
- case 0xF4: goto yy120;
- default: goto yy99;
- }
-yy99:
- YYDEBUG(99, YYPEEK ());
-#line 226 "../wisitoken_grammar.re2c"
- {*id = 2; continue;}
-#line 2651 "../wisitoken_grammar_re2c.c"
-yy100:
- YYDEBUG(100, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy44;
- default: goto yy71;
- }
-yy101:
- YYDEBUG(101, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy100;
- default: goto yy71;
- }
-yy102:
- YYDEBUG(102, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy100;
- default: goto yy71;
- }
-yy103:
- YYDEBUG(103, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy102;
- default: goto yy71;
- }
-yy104:
- YYDEBUG(104, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy102;
- default: goto yy71;
- }
-yy105:
- YYDEBUG(105, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F: goto yy102;
- default: goto yy71;
- }
-yy106:
- YYDEBUG(106, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'd': goto yy121;
- default: goto yy45;
- }
-yy107:
- YYDEBUG(107, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'd': goto yy122;
- default: goto yy45;
- }
-yy108:
- YYDEBUG(108, YYPEEK ());
- yyaccept = 6;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case '-':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF:
- case 0xE0:
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF:
- case 0xF0:
- case 0xF1:
- case 0xF2:
- case 0xF3:
- case 0xF4: goto yy45;
- default: goto yy109;
- }
-yy109:
- YYDEBUG(109, YYPEEK ());
-#line 229 "../wisitoken_grammar.re2c"
- {*id = 5; continue;}
-#line 3130 "../wisitoken_grammar_re2c.c"
-yy110:
- YYDEBUG(110, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'y': goto yy124;
- default: goto yy45;
- }
-yy111:
- YYDEBUG(111, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'n': goto yy125;
- default: goto yy45;
- }
-yy112:
- YYDEBUG(112, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'k': goto yy126;
- default: goto yy45;
- }
-yy113:
- YYDEBUG(113, YYPEEK ());
- YYSKIP ();
- YYDEBUG(114, YYPEEK ());
-#line 238 "../wisitoken_grammar.re2c"
- {*id = 14; continue;}
-#line 3167 "../wisitoken_grammar_re2c.c"
-yy115:
- YYDEBUG(115, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy97;
- default: goto yy71;
- }
-yy116:
- YYDEBUG(116, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy115;
- default: goto yy71;
- }
-yy117:
- YYDEBUG(117, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy115;
- default: goto yy71;
- }
-yy118:
- YYDEBUG(118, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy117;
- default: goto yy71;
- }
-yy119:
- YYDEBUG(119, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F:
- case 0x90:
- case 0x91:
- case 0x92:
- case 0x93:
- case 0x94:
- case 0x95:
- case 0x96:
- case 0x97:
- case 0x98:
- case 0x99:
- case 0x9A:
- case 0x9B:
- case 0x9C:
- case 0x9D:
- case 0x9E:
- case 0x9F:
- case 0xA0:
- case 0xA1:
- case 0xA2:
- case 0xA3:
- case 0xA4:
- case 0xA5:
- case 0xA6:
- case 0xA7:
- case 0xA8:
- case 0xA9:
- case 0xAA:
- case 0xAB:
- case 0xAC:
- case 0xAD:
- case 0xAE:
- case 0xAF:
- case 0xB0:
- case 0xB1:
- case 0xB2:
- case 0xB3:
- case 0xB4:
- case 0xB5:
- case 0xB6:
- case 0xB7:
- case 0xB8:
- case 0xB9:
- case 0xBA:
- case 0xBB:
- case 0xBC:
- case 0xBD:
- case 0xBE:
- case 0xBF: goto yy117;
- default: goto yy71;
- }
-yy120:
- YYDEBUG(120, YYPEEK ());
- YYSKIP ();
- yych = YYPEEK ();
- switch (yych) {
- case 0x80:
- case 0x81:
- case 0x82:
- case 0x83:
- case 0x84:
- case 0x85:
- case 0x86:
- case 0x87:
- case 0x88:
- case 0x89:
- case 0x8A:
- case 0x8B:
- case 0x8C:
- case 0x8D:
- case 0x8E:
- case 0x8F: goto yy117;
- default: goto yy71;
- }
-yy121:
- YYDEBUG(121, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'e': goto yy127;
- default: goto yy45;
- }
-yy122:
- YYDEBUG(122, YYPEEK ());
- yyaccept = 7;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case '-':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF:
- case 0xE0:
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF:
- case 0xF0:
- case 0xF1:
- case 0xF2:
- case 0xF3:
- case 0xF4: goto yy45;
- default: goto yy123;
- }
-yy123:
- YYDEBUG(123, YYPEEK ());
-#line 228 "../wisitoken_grammar.re2c"
- {*id = 4; continue;}
-#line 3636 "../wisitoken_grammar_re2c.c"
-yy124:
- YYDEBUG(124, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'w': goto yy129;
- default: goto yy45;
- }
-yy125:
- YYDEBUG(125, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case '_': goto yy130;
- default: goto yy45;
- }
-yy126:
- YYDEBUG(126, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'e': goto yy131;
- default: goto yy45;
- }
-yy127:
- YYDEBUG(127, YYPEEK ());
- yyaccept = 8;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case '-':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF:
- case 0xE0:
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF:
- case 0xF0:
- case 0xF1:
- case 0xF2:
- case 0xF3:
- case 0xF4: goto yy45;
- default: goto yy128;
- }
-yy128:
- YYDEBUG(128, YYPEEK ());
-#line 227 "../wisitoken_grammar.re2c"
- {*id = 3; continue;}
-#line 3795 "../wisitoken_grammar_re2c.c"
-yy129:
- YYDEBUG(129, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'o': goto yy132;
- default: goto yy45;
- }
-yy130:
- YYDEBUG(130, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'g': goto yy133;
- default: goto yy45;
- }
-yy131:
- YYDEBUG(131, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'n': goto yy134;
- default: goto yy45;
- }
-yy132:
- YYDEBUG(132, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'r': goto yy136;
- default: goto yy45;
- }
-yy133:
- YYDEBUG(133, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'r': goto yy137;
- default: goto yy45;
- }
-yy134:
- YYDEBUG(134, YYPEEK ());
- yyaccept = 9;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case '-':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF:
- case 0xE0:
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF:
- case 0xF0:
- case 0xF1:
- case 0xF2:
- case 0xF3:
- case 0xF4: goto yy45;
- default: goto yy135;
- }
-yy135:
- YYDEBUG(135, YYPEEK ());
-#line 232 "../wisitoken_grammar.re2c"
- {*id = 8; continue;}
-#line 3974 "../wisitoken_grammar_re2c.c"
-yy136:
- YYDEBUG(136, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'd': goto yy138;
- default: goto yy45;
- }
-yy137:
- YYDEBUG(137, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'a': goto yy140;
- default: goto yy45;
- }
-yy138:
- YYDEBUG(138, YYPEEK ());
- yyaccept = 10;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case '-':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF:
- case 0xE0:
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF:
- case 0xF0:
- case 0xF1:
- case 0xF2:
- case 0xF3:
- case 0xF4: goto yy45;
- default: goto yy139;
- }
-yy139:
- YYDEBUG(139, YYPEEK ());
-#line 230 "../wisitoken_grammar.re2c"
- {*id = 6; continue;}
-#line 4123 "../wisitoken_grammar_re2c.c"
-yy140:
- YYDEBUG(140, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'm': goto yy141;
- default: goto yy45;
- }
-yy141:
- YYDEBUG(141, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'm': goto yy142;
- default: goto yy45;
- }
-yy142:
- YYDEBUG(142, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'a': goto yy143;
- default: goto yy45;
- }
-yy143:
- YYDEBUG(143, YYPEEK ());
- yyaccept = 2;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case 'r': goto yy144;
- default: goto yy45;
- }
-yy144:
- YYDEBUG(144, YYPEEK ());
- yyaccept = 11;
- YYSKIP ();
- YYBACKUP ();
- yych = YYPEEK ();
- switch (yych) {
- case '-':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- case 'G':
- case 'H':
- case 'I':
- case 'J':
- case 'K':
- case 'L':
- case 'M':
- case 'N':
- case 'O':
- case 'P':
- case 'Q':
- case 'R':
- case 'S':
- case 'T':
- case 'U':
- case 'V':
- case 'W':
- case 'X':
- case 'Y':
- case 'Z':
- case '_':
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- case 'g':
- case 'h':
- case 'i':
- case 'j':
- case 'k':
- case 'l':
- case 'm':
- case 'n':
- case 'o':
- case 'p':
- case 'q':
- case 'r':
- case 's':
- case 't':
- case 'u':
- case 'v':
- case 'w':
- case 'x':
- case 'y':
- case 'z':
- case 0xC2:
- case 0xC3:
- case 0xC4:
- case 0xC5:
- case 0xC6:
- case 0xC7:
- case 0xC8:
- case 0xC9:
- case 0xCA:
- case 0xCB:
- case 0xCC:
- case 0xCD:
- case 0xCE:
- case 0xCF:
- case 0xD0:
- case 0xD1:
- case 0xD2:
- case 0xD3:
- case 0xD4:
- case 0xD5:
- case 0xD6:
- case 0xD7:
- case 0xD8:
- case 0xD9:
- case 0xDA:
- case 0xDB:
- case 0xDC:
- case 0xDD:
- case 0xDE:
- case 0xDF:
- case 0xE0:
- case 0xE1:
- case 0xE2:
- case 0xE3:
- case 0xE4:
- case 0xE5:
- case 0xE6:
- case 0xE7:
- case 0xE8:
- case 0xE9:
- case 0xEA:
- case 0xEB:
- case 0xEC:
- case 0xED:
- case 0xEE:
- case 0xEF:
- case 0xF0:
- case 0xF1:
- case 0xF2:
- case 0xF3:
- case 0xF4: goto yy45;
- default: goto yy145;
- }
-yy145:
- YYDEBUG(145, YYPEEK ());
-#line 231 "../wisitoken_grammar.re2c"
- {*id = 7; continue;}
-#line 4292 "../wisitoken_grammar_re2c.c"
-}
-#line 263 "../wisitoken_grammar.re2c"
-
- }
- /* lexer->cursor and lexer ->char_pos are one char past end of token */
- *byte_position = lexer->byte_token_start - lexer->buffer + 1;
- *byte_length = lexer->cursor - lexer->byte_token_start;
- *char_position = lexer->char_token_start;
- *char_length = lexer->char_pos - lexer->char_token_start;
- *line_start = lexer->line_token_start;
- return status;
- }
diff --git a/packages/wisi/wisitoken_grammar_re2c_c.ads
b/packages/wisi/wisitoken_grammar_re2c_c.ads
deleted file mode 100644
index d494b3f..0000000
--- a/packages/wisi/wisitoken_grammar_re2c_c.ads
+++ /dev/null
@@ -1,63 +0,0 @@
--- generated parser support file.
--- command line: wisitoken-bnf-generate.exe --generate LALR Ada re2c
wisitoken_grammar.wy
---
-
--- Copyright (C) 2017 - 2019 Free Software Foundation, Inc.
---
--- Author: Stephen Leake <stephe-leake@stephe-leake.org>
---
--- This file is part of GNU Emacs.
---
--- GNU Emacs is free software: you can redistribute it and/or modify
--- it under the terms of the GNU General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- (at your option) any later version.
---
--- GNU Emacs is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU General Public License for more details.
---
--- You should have received a copy of the GNU General Public License
--- along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-with Interfaces.C;
-with WisiToken;
-with System;
-package wisitoken_grammar_re2c_c is
-
- function New_Lexer
- (Buffer : in System.Address;
- Length : in Interfaces.C.size_t;
- Verbosity : in Interfaces.C.int)
- return System.Address
- with Import => True,
- Convention => C,
- External_Name => "wisitoken_grammar_new_lexer";
- -- Create the lexer object, passing it the full text to process.
-
- procedure Free_Lexer (Lexer : in out System.Address)
- with Import => True,
- Convention => C,
- External_Name => "wisitoken_grammar_free_lexer";
- -- Free the lexer object
-
- procedure Reset_Lexer (Lexer : in System.Address)
- with Import => True,
- Convention => C,
- External_Name => "wisitoken_grammar_reset_lexer";
-
- function Next_Token
- (Lexer : in System.Address;
- ID : out WisiToken.Token_ID;
- Byte_Position : out Interfaces.C.size_t;
- Byte_Length : out Interfaces.C.size_t;
- Char_Position : out Interfaces.C.size_t;
- Char_Length : out Interfaces.C.size_t;
- Line_Start : out Interfaces.C.int)
- return Interfaces.C.int
- with Import => True,
- Convention => C,
- External_Name => "wisitoken_grammar_next_token";
-
-end wisitoken_grammar_re2c_c;
diff --git a/packages/wisi/wisitoken_grammar_runtime.adb
b/packages/wisi/wisitoken_grammar_runtime.adb
deleted file mode 100644
index e40c147..0000000
--- a/packages/wisi/wisitoken_grammar_runtime.adb
+++ /dev/null
@@ -1,3442 +0,0 @@
--- Abstract :
---
--- See spec.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Characters.Handling;
-with Ada.Exceptions;
-with Ada.Strings.Unbounded;
-with Ada.Text_IO;
-with GNAT.Regexp;
-with SAL.Generic_Decimal_Image;
-with WisiToken.Generate; use WisiToken.Generate;
-package body WisiToken_Grammar_Runtime is
-
- use WisiToken;
- use Wisitoken_Grammar_Actions;
-
- ----------
- -- Body subprograms, misc order
-
- function Get_Line
- (Data : in User_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Node : in WisiToken.Valid_Node_Index)
- return WisiToken.Line_Number_Type
- is
- -- Find a source line for Node.
-
- use WisiToken.Syntax_Trees;
-
- Temp : Node_Index := Node;
- begin
- loop
- if Tree.First_Shared_Terminal (Temp) = Invalid_Token_Index then
- -- Node is empty or all virtual_identifiers; try parents.
- Temp := Tree.Parent (Temp);
- exit when Temp = Invalid_Node_Index;
- else
- return Data.Terminals.all (Tree.First_Shared_Terminal (Temp)).Line;
- end if;
- end loop;
- return Invalid_Line_Number;
- end Get_Line;
-
- function Get_Text
- (Data : in User_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Tree_Index : in Valid_Node_Index;
- Strip_Quotes : in Boolean := False)
- return String
- is
- use all type Syntax_Trees.Node_Label;
-
- 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));
-
- elsif -Tree.ID (Tree_Index) in STRING_LITERAL_1_ID |
STRING_LITERAL_2_ID and Strip_Quotes then
- return Data.Grammar_Lexer.Buffer_Text ((Region.First + 1,
Region.Last - 1));
- else
- return Data.Grammar_Lexer.Buffer_Text (Region);
- end if;
- end Strip_Delimiters;
-
- begin
- case Tree.Label (Tree_Index) is
- when Shared_Terminal =>
- return Strip_Delimiters (Tree_Index);
-
- when Virtual_Terminal =>
- -- 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 =>
- if Strip_Quotes then
- declare
- Quoted : constant String := -Data.Tokens.Virtual_Identifiers
(Tree.Identifier (Tree_Index));
- begin
- return Quoted (Quoted'First + 1 .. Quoted'Last - 1);
- end;
- else
- return -Data.Tokens.Virtual_Identifiers (Tree.Identifier
(Tree_Index));
- end if;
-
- 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 (Data, Tree, Tree_Index, Strip_Quotes);
- Need_Space := True;
- end loop;
- return -Result;
- end;
- end case;
- end Get_Text;
-
- function Get_Child_Text
- (Data : in User_Data_Type;
- Tree : in Syntax_Trees.Tree;
- Parent : in Valid_Node_Index;
- Child : in SAL.Peek_Type;
- Strip_Quotes : in Boolean := False)
- return String
- is
- Tree_Indices : constant Valid_Node_Index_Array := Tree.Get_Terminals
(Parent);
- begin
- return Get_Text (Data, Tree, Tree_Indices (Child), Strip_Quotes);
- end Get_Child_Text;
-
- procedure Start_If_1
- (Data : in out User_Data_Type;
- Tree : in Syntax_Trees.Tree;
- A_Index : in Valid_Node_Index;
- B_Index : in Valid_Node_Index)
- is
- use all type WisiToken.BNF.Generate_Algorithm;
- use all type WisiToken.BNF.Lexer_Type;
- begin
- if "lexer" = Get_Text (Data, Tree, A_Index) then
- Data.If_Lexer_Present := True;
- Data.Ignore_Lines := Data.User_Lexer /= WisiToken.BNF.To_Lexer
(Get_Text (Data, Tree, B_Index));
-
- elsif "parser" = Get_Text (Data, Tree, A_Index) then
- Data.If_Parser_Present := True;
- Data.Ignore_Lines := Data.User_Parser /=
WisiToken.BNF.Generate_Algorithm'Value
- (Get_Text (Data, Tree, B_Index));
-
- else
- raise Grammar_Error with
- Error_Message
- (Data.Grammar_Lexer.File_Name, Data.Terminals.all
(Tree.First_Shared_Terminal (A_Index)).Line,
- "invalid '%if'; must be one of {lexer | parser}");
- end if;
- end Start_If_1;
-
- function Get_RHS
- (Data : in out User_Data_Type;
- Tree : in Syntax_Trees.Tree;
- 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
- return RHS : WisiToken.BNF.RHS_Type do
- RHS.Source_Line := Get_Line (Data, Tree, Token);
-
- if Children'Length > 0 then
- for I of Tree.Get_IDs (Children (1), +rhs_element_ID) loop
- case Tree.RHS_Index (I) is
- when 0 =>
- -- rhs_item
- RHS.Tokens.Append
- ((Label => +"",
- Identifier => +Get_Text (Data, Tree, Tree.Child (I,
1))));
-
- when 1 =>
- -- IDENTIFIER = rhs_item
- declare
- Label : constant String := Get_Text (Data, Tree,
Tree.Child (I, 1));
- begin
- RHS.Tokens.Append
- ((Label => +Label,
- Identifier => +Get_Text (Data, Tree, Tree.Child (I,
3))));
-
- if (for all L of Labels => -L /= Label) then
- Labels.Append (+Label);
- end if;
- end;
-
- when others =>
- Raise_Programmer_Error ("Get_RHS; unimplimented token",
Data, Tree, I);
- end case;
- end loop;
-
- if Children'Last >= 2 then
- declare
- Text : constant String := Get_Text (Data, Tree, Children
(2));
- begin
- if Text'Length > 0 and (for some C of Text => C /= ' ') then
- RHS.Action := +Text;
- Data.Action_Count := Data.Action_Count + 1;
- end if;
- end;
- end if;
-
- if Children'Last >= 3 then
- RHS.Check := +Get_Text (Data, Tree, Children (3));
- Data.Check_Count := Data.Check_Count + 1;
- end if;
- end if;
- end return;
- exception
- when SAL.Programmer_Error =>
- raise;
- when E : others =>
- declare
- use Ada.Exceptions;
- begin
- Raise_Programmer_Error ("Get_RHS: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Token);
- end;
- end Get_RHS;
-
- procedure Get_Right_Hand_Sides
- (Data : in out User_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Right_Hand_Sides : in out WisiToken.BNF.RHS_Lists.List;
- 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
- case Tree.RHS_Index (Token) is
- when 0 =>
- -- | rhs
- if not Data.Ignore_Lines then
- Right_Hand_Sides.Append (Get_RHS (Data, Tree, Labels, Tokens (1)));
- end if;
-
- when 1 =>
- -- | rhs_list BAR rhs
- Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Labels, Tokens
(1));
-
- if not Data.Ignore_Lines then
- Right_Hand_Sides.Append (Get_RHS (Data, Tree, Labels, Tokens (3)));
- end if;
-
- when 2 =>
- -- | rhs_list PERCENT IF IDENTIFIER EQUAL IDENTIFIER
- Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Labels, Tokens
(1));
- Start_If_1 (Data, Tree, Tokens (4), Tokens (6));
-
- when 3 =>
- -- | rhs_list PERCENT END IF
- Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Labels, Tokens
(1));
- Data.Ignore_Lines := False;
-
- when others =>
- Raise_Programmer_Error ("Get_Right_Hand_Sides", Data, Tree, Token);
- end case;
- end Get_Right_Hand_Sides;
-
- ----------
- -- Public subprograms, declaration order
-
- overriding
- procedure Set_Lexer_Terminals
- (User_Data : in out User_Data_Type;
- Lexer : in WisiToken.Lexer.Handle;
- Terminals : in Base_Token_Array_Access_Constant)
- is begin
- User_Data.Grammar_Lexer := Lexer;
- User_Data.Terminals := Terminals;
- end Set_Lexer_Terminals;
-
- overriding procedure Reset (Data : in out User_Data_Type)
- is begin
- -- Preserve data set in Phase Meta, or by Set_Lexer_Terminals, or by
- -- wisitoken-bnf-generate.
-
- -- Preserve Grammar_Lexer
- -- Preserve User_Lexer
- -- Preserve User_Parser
- -- Perserve Generate_Set
- -- Preserve Meta_Syntax
- -- Preserve Phase
- -- Preserve Terminals
- -- Preserve Non_Grammar
- -- EBNF_Nodes handled in Initialize_Actions
- Data.Raw_Code := (others => <>);
- Data.Language_Params :=
- (Case_Insensitive => Data.Language_Params.Case_Insensitive,
- others => <>);
- Data.Tokens :=
- (Virtual_Identifiers => Data.Tokens.Virtual_Identifiers,
- others => <>);
- Data.Conflicts.Clear;
- Data.McKenzie_Recover := (others => <>);
- Data.Rule_Count := 0;
- Data.Action_Count := 0;
- Data.Check_Count := 0;
- Data.Label_Count := 0;
- Data.If_Lexer_Present := False;
- Data.If_Parser_Present := False;
- Data.Ignore_Lines := False;
- end Reset;
-
- overriding procedure Initialize_Actions
- (Data : in out User_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree'Class)
- is begin
- Data.EBNF_Nodes.Clear;
- Data.EBNF_Nodes.Set_First_Last (Tree.First_Index, Tree.Last_Index);
- end Initialize_Actions;
-
- overriding
- procedure Lexer_To_Augmented
- (Data : in out User_Data_Type;
- Tree : in out WisiToken.Syntax_Trees.Tree'Class;
- Token : in WisiToken.Base_Token;
- Lexer : not null access WisiToken.Lexer.Instance'Class)
- is
- pragma Unreferenced (Lexer);
- use all type Ada.Containers.Count_Type;
- begin
- if Token.ID < Wisitoken_Grammar_Actions.Descriptor.First_Terminal then
- -- Non-grammar token
- if Data.Terminals.Length = 0 then
- Data.Leading_Non_Grammar.Append (Token);
- else
- declare
- Containing_Aug : Augmented_Token_Access :=
Augmented_Token_Access
- (Tree.Augmented (Data.Last_Terminal_Node));
- begin
- if Containing_Aug = null then
- Containing_Aug := new Augmented_Token'
- (Data.Terminals.all (Tree.First_Shared_Terminal
(Data.Last_Terminal_Node)) with Non_Grammar => <>);
- Tree.Set_Augmented (Data.Last_Terminal_Node,
WisiToken.Base_Token_Class_Access (Containing_Aug));
- end if;
-
- Containing_Aug.Non_Grammar.Append (Token);
- end;
- end if;
- else
- Data.Last_Terminal_Node := Token.Tree_Index;
- end if;
- end Lexer_To_Augmented;
-
- procedure Start_If
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is begin
- -- all phases
- Start_If_1 (User_Data_Type (User_Data), Tree, Tokens (3), Tokens (5));
- end Start_If;
-
- procedure End_If (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class)
- is
- Data : User_Data_Type renames User_Data_Type (User_Data);
- begin
- -- all phases
- Data.Ignore_Lines := False;
- end End_If;
-
- procedure Add_Declaration
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- use all type WisiToken.Syntax_Trees.Node_Label;
- use all type Ada.Strings.Unbounded.Unbounded_String;
-
- Data : User_Data_Type renames User_Data_Type (User_Data);
-
- function Token (Index : in SAL.Peek_Type) return Base_Token
- is
- use all type SAL.Base_Peek_Type;
- begin
- if Tokens'Last < Index then
- raise SAL.Programmer_Error;
- elsif Tree.Label (Tokens (Index)) /=
WisiToken.Syntax_Trees.Shared_Terminal then
- raise SAL.Programmer_Error with "token at " & Image
(Tree.Byte_Region (Tokens (Index))) &
- " is a " & WisiToken.Syntax_Trees.Node_Label'Image (Tree.Label
(Tokens (Index))) &
- ", expecting Shared_Terminal";
- else
- return Data.Terminals.all (Tree.Terminal (Tokens (Index)));
- end if;
- end Token;
-
- function Enum_ID (Index : in SAL.Peek_Type) return Token_Enum_ID
- is (To_Token_Enum (Token (Index).ID));
-
- begin
- if Data.Phase = Meta then
- if Tree.Label (Tokens (2)) = WisiToken.Syntax_Trees.Shared_Terminal
then
- case Enum_ID (2) is
- when IDENTIFIER_ID =>
- declare
- Kind : constant String := Data.Grammar_Lexer.Buffer_Text
(Token (2).Byte_Region);
- begin
- if Kind = "case_insensitive" then
- Data.Language_Params.Case_Insensitive := True;
-
- elsif Kind = "generate" then
- declare
- use all type SAL.Base_Peek_Type;
- Children : constant Valid_Node_Index_Array :=
Tree.Get_Terminals (Tokens (3));
- Tuple : WisiToken.BNF.Generate_Tuple;
- begin
- Tuple.Gen_Alg := WisiToken.BNF.To_Generate_Algorithm
(Get_Text (Data, Tree, Children (1)));
- if Children'Last >= 2 then
- Tuple.Out_Lang := WisiToken.BNF.To_Output_Language
(Get_Text (Data, Tree, Children (2)));
- end if;
- for I in 3 .. SAL.Base_Peek_Type (Children'Length) loop
- declare
- Text : constant String := Get_Text (Data, Tree,
Children (I));
- begin
- if Text = "text_rep" then
- Tuple.Text_Rep := True;
-
- elsif (for some I of WisiToken.BNF.Lexer_Image
=> Text = I.all) then
- Tuple.Lexer := WisiToken.BNF.To_Lexer (Text);
-
- elsif (for some I in
WisiToken.BNF.Valid_Interface =>
- WisiToken.BNF.To_Lower (Text) =
WisiToken.BNF.To_Lower
- (WisiToken.BNF.Valid_Interface'Image
(I)))
- then
- Tuple.Interface_Kind :=
WisiToken.BNF.Valid_Interface'Value (Text);
- else
- declare
- Token : Base_Token renames
Data.Terminals.all (Tree.Terminal (Children (I)));
- begin
- raise Grammar_Error with Error_Message
- (Data.Grammar_Lexer.File_Name,
Token.Line, Token.Column,
- "invalid generate param '" & Text &
"'");
- end;
- end if;
- end;
- end loop;
- WisiToken.BNF.Add (Data.Generate_Set, Tuple);
- end;
-
- elsif Kind = "meta_syntax" then
- if Data.Meta_Syntax = Unknown then
- -- Don't overwrite; somebody set it for a reason.
- declare
- Value_Str : constant String :=
WisiToken.BNF.To_Lower (Get_Text (Data, Tree, Tokens (3)));
- begin
- if Value_Str = "bnf" then
- Data.Meta_Syntax := BNF_Syntax;
- elsif Value_Str = "ebnf" then
- Data.Meta_Syntax := EBNF_Syntax;
- Data.EBNF_Nodes (Tree.Find_Ancestor (Tokens (2),
+declaration_ID)) := True;
-
- else
- Put_Error ("invalid value for %meta_syntax; must
be BNF | EBNF.");
- end if;
- end;
- end if;
- end if;
- end;
- when others =>
- null;
- end case;
- end if;
- return;
- end if;
-
- -- Add declaration to User_Data.Generate_Set, Language_Params,
- -- Tokens, Conflicts, or McKenzie_Recover.
-
- if Data.Ignore_Lines then
- return;
- end if;
-
- case Tree.Label (Tokens (2)) is
- when Syntax_Trees.Nonterm =>
- -- must be token_keyword_non_grammar
- declare
- Children_2 : constant Valid_Node_Index_Array := Tree.Children
(Tokens (2));
- Child_1_ID : constant Token_Enum_ID := To_Token_Enum (Tree.ID
(Children_2 (1)));
- begin
- case Child_1_ID is
- when Wisitoken_Grammar_Actions.TOKEN_ID =>
- declare
- Children_4 : constant Valid_Node_Index_Array :=
Tree.Children (Tokens (4));
- begin
- WisiToken.BNF.Add_Token
- (Data.Tokens.Tokens,
- Kind => Get_Text (Data, Tree, Children_2 (3)),
- Name => Get_Text (Data, Tree, Tokens (3)),
- Value => Get_Text (Data, Tree, Children_4 (1)),
- Repair_Image => (if Children_4'Length = 1 then "" else
Get_Text (Data, Tree, Children_4 (2))));
- end;
-
- when KEYWORD_ID =>
-
- Data.Tokens.Keywords.Append
- ((Name => +Get_Text (Data, Tree, Tokens (3)),
- Value => +Get_Text (Data, Tree, Tokens (4))));
-
- when NON_GRAMMAR_ID =>
-
- WisiToken.BNF.Add_Token
- (Data.Tokens.Non_Grammar,
- Kind => Get_Text (Data, Tree, Children_2 (3)),
- Name => Get_Text (Data, Tree, Tokens (3)),
- Value => Get_Text (Data, Tree, Tokens (4)));
-
- when others =>
- raise SAL.Programmer_Error;
- end case;
- end;
-
- when Syntax_Trees.Shared_Terminal =>
- case Enum_ID (2) is
- when CODE_ID =>
- declare
- Location : WisiToken.BNF.Raw_Code_Location;
-
- -- % code identifier_list raw_code
- -- 1 2 3 4
- --
- -- identifier_list = "action spec context"
- -- identifier_list children = identifier_list IDENTIFIER_ID
- -- children = identifier_list IDENTIFIER_ID
- -- children = IDENTIFIER_ID
- function Get_Loc_List return Base_Token_Array
- with Pre => Tree.ID (Tokens (3)) = +identifier_list_ID
- is
- use all type SAL.Base_Peek_Type;
- use WisiToken.Syntax_Trees;
- Node : Valid_Node_Index := Tokens (3);
- Result : Base_Token_Array (1 .. 3);
- First : SAL.Peek_Type := Result'Last + 1;
- begin
- loop
- pragma Assert (Tree.ID (Node) = +identifier_list_ID);
- exit when not Tree.Has_Children (Node);
- declare
- Children : constant Valid_Node_Index_Array :=
Tree.Children (Node);
- begin
- if Children'Length = 1 then
- -- identifier_list : IDENTIFIER
- First := First - 1;
- Result (First) := Data.Terminals.all (Tree.Terminal
(Children (1)));
- exit;
-
- elsif Children'Length = 2 then
- -- identifier_list : identifier_list IDENTIFIER
- First := First - 1;
- Result (First) := Data.Terminals.all (Tree.Terminal
(Children (2)));
-
- Node := Children (1);
- else
- raise SAL.Programmer_Error;
- end if;
- end;
- end loop;
- return Result (First .. Result'Last);
- end Get_Loc_List;
-
- Loc_List : constant Base_Token_Array := Get_Loc_List;
-
- function Get_Loc (Index : in SAL.Peek_Type) return String
- is (Data.Grammar_Lexer.Buffer_Text (Loc_List
(Index).Byte_Region));
-
- begin
- if Get_Loc (Loc_List'First) = "actions" then
- Location :=
- (if Get_Loc (2) = "spec" then
- (if Get_Loc (3) = "context" then
WisiToken.BNF.Actions_Spec_Context
- elsif Get_Loc (3) = "pre" then
WisiToken.BNF.Actions_Spec_Pre
- elsif Get_Loc (3) = "post" then
WisiToken.BNF.Actions_Spec_Post
- else raise Grammar_Error with
- Error_Message
- (Data.Grammar_Lexer.File_Name, Loc_List (2).Line,
- "expecting {context | pre | post}"))
-
- elsif Get_Loc (2) = "body" then
- (if Get_Loc (3) = "context" then
WisiToken.BNF.Actions_Body_Context
- elsif Get_Loc (3) = "pre" then
WisiToken.BNF.Actions_Body_Pre
- elsif Get_Loc (3) = "post" then
WisiToken.BNF.Actions_Body_Post
- else raise Grammar_Error with
- Error_Message
- (Data.Grammar_Lexer.File_Name, Loc_List (2).Line,
- "expecting {context | pre | post}"))
-
- else raise Grammar_Error);
-
- elsif Get_Loc (Loc_List'First) = "copyright_license" then
- Location := WisiToken.BNF.Copyright_License;
-
- else
- raise Grammar_Error with
- Error_Message
- (Data.Grammar_Lexer.File_Name, Loc_List
(Loc_List'First).Line,
- "expecting {actions | copyright_license}");
- end if;
-
- Data.Raw_Code (Location) := WisiToken.BNF.Split_Lines (Get_Text
(Data, Tree, Tokens (4)));
- exception
- when Grammar_Error =>
- Put_Error
- (Error_Message
- (Data.Grammar_Lexer.File_Name, Token (2).Line, Token
(2).Column,
- "invalid raw code location; actions {spec | body}
{context | pre | post}"));
- end;
-
- when IDENTIFIER_ID =>
- declare
- Kind : constant String := Data.Grammar_Lexer.Buffer_Text (Token
(2).Byte_Region);
- begin
- -- Alphabetical by Kind
-
- if Kind = "case_insensitive" then
- -- Not in phase Other
- null;
-
- elsif Kind = "conflict" then
- declare
- Tree_Indices : constant Valid_Node_Index_Array :=
Tree.Get_Terminals
- (Tokens (3));
- -- %conflict <action_a>/<action_b> in state <LHS_A>,
<LHS_B> on token <on>
- -- 1 2 3 4 5 6 7 8
9 10 11
- begin
- Data.Conflicts.Append
- ((Source_Line => Data.Terminals.all (Tree.Terminal
(Tree_Indices (1))).Line,
- Action_A => +Get_Text (Data, Tree, Tree_Indices
(1)),
- LHS_A => +Get_Text (Data, Tree, Tree_Indices
(6)),
- Action_B => +Get_Text (Data, Tree, Tree_Indices
(3)),
- LHS_B => +Get_Text (Data, Tree, Tree_Indices
(8)),
- On => +Get_Text (Data, Tree, Tree_Indices
(11))));
- end;
-
- elsif Kind = "end" then
- -- matching '%if' specified current lexer.
- null;
-
- elsif Kind = "elisp_face" then
- Data.Tokens.Faces.Append (Get_Text (Data, Tree, Tokens (3),
Strip_Quotes => True));
-
- elsif Kind = "elisp_indent" then
- Data.Tokens.Indents.Append
- ((Name => +Get_Child_Text (Data, Tree, Tokens (3), 1,
Strip_Quotes => True),
- Value => +Get_Child_Text (Data, Tree, Tokens (3), 2)));
-
- elsif Kind = "elisp_action" then
- Data.Tokens.Actions.Insert
- (Key => +Get_Child_Text (Data, Tree, Tokens
(3), 2),
- New_Item =>
- (Action_Label => +Get_Child_Text (Data, Tree, Tokens
(3), 1),
- Ada_Name => +Get_Child_Text (Data, Tree, Tokens
(3), 3)));
-
- elsif Kind = "end_names_optional_option" then
- Data.Language_Params.End_Names_Optional_Option := +Get_Text
(Data, Tree, Tokens (3));
-
- elsif Kind = "generate" then
- -- Not in Other phase
- null;
-
- elsif Kind = "language_runtime" then
- Data.Language_Params.Language_Runtime_Name :=
- +Get_Text (Data, Tree, Tokens (3), Strip_Quotes => True);
-
- elsif Kind = "mckenzie_check_limit" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Check_Limit := Token_Index'Value
(Get_Text (Data, Tree, Tokens (3)));
-
- elsif Kind = "mckenzie_check_delta_limit" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Check_Delta_Limit := Integer'Value
(Get_Text (Data, Tree, Tokens (3)));
-
- elsif Kind = "mckenzie_cost_default" then
- if Tree.Get_Terminals (Tokens (3))'Length /= 4 then
- raise Grammar_Error with
- Error_Message
- (Data.Grammar_Lexer.File_Name,
- Data.Terminals.all (Tree.First_Shared_Terminal
(Tokens (3))).Line,
- "too " & (if Tree.Get_Terminals (Tokens (3))'Length
> 4 then "many" else "few") &
- " default costs; should be 'insert, delete, push
back, ignore check fail'.");
- end if;
-
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Source_Line := Data.Terminals.all
- (Tree.First_Shared_Terminal (Tokens (1))).Line;
-
- Data.McKenzie_Recover.Default_Insert :=
Natural'Value
- (Get_Child_Text (Data, Tree, Tokens (3), 1));
- Data.McKenzie_Recover.Default_Delete_Terminal :=
Natural'Value
- (Get_Child_Text (Data, Tree, Tokens (3), 2));
- Data.McKenzie_Recover.Default_Push_Back :=
Natural'Value
- (Get_Child_Text (Data, Tree, Tokens (3), 3));
- Data.McKenzie_Recover.Ignore_Check_Fail :=
Natural'Value
- (Get_Child_Text (Data, Tree, Tokens (3), 4));
-
- elsif Kind = "mckenzie_cost_delete" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Delete.Append
- ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
- +Get_Child_Text (Data, Tree, Tokens (3), 2)));
-
- elsif Kind = "mckenzie_cost_fast_forward" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Fast_Forward :=
- Integer'Value (Get_Text (Data, Tree, Tokens (3)));
-
- elsif Kind = "mckenzie_cost_insert" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Insert.Append
- ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
- +Get_Child_Text (Data, Tree, Tokens (3), 2)));
-
- elsif Kind = "mckenzie_cost_matching_begin" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Matching_Begin :=
- Integer'Value (Get_Text (Data, Tree, Tokens (3)));
-
- elsif Kind = "mckenzie_cost_push_back" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Push_Back.Append
- ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
- +Get_Child_Text (Data, Tree, Tokens (3), 2)));
-
- elsif Kind = "mckenzie_cost_undo_reduce" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Undo_Reduce.Append
- ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
- +Get_Child_Text (Data, Tree, Tokens (3), 2)));
-
- elsif Kind = "mckenzie_enqueue_limit" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Enqueue_Limit := Natural'Value
(Get_Text (Data, Tree, Tokens (3)));
-
- elsif Kind = "mckenzie_minimal_complete_cost_delta" then
- Data.Language_Params.Error_Recover := True;
- Data.McKenzie_Recover.Minimal_Complete_Cost_Delta :=
- Integer'Value (Get_Text (Data, Tree, Tokens (3)));
-
- elsif Kind = "meta_syntax" then
- -- not in Other phase
- null;
-
- elsif Kind = "no_enum" then
- Data.Language_Params.Declare_Enums := False;
-
- elsif Kind = "no_language_runtime" then
- Data.Language_Params.Use_Language_Runtime := False;
-
- elsif Kind = "partial_recursion" then
- Data.Language_Params.Partial_Recursion := True;
-
- elsif Kind = "start" then
- Data.Language_Params.Start_Token := +Get_Text (Data, Tree,
Tokens (3));
-
- elsif Kind = "re2c_regexp" then
- Data.Tokens.re2c_Regexps.Append
- ((+Get_Child_Text (Data, Tree, Tokens (3), 1),
- +Get_Child_Text (Data, Tree, Tokens (3), 2)));
-
- else
- raise Grammar_Error with Error_Message
- (Data.Grammar_Lexer.File_Name, Token (2).Line, Token
(2).Column, "unexpected syntax");
-
- end if;
- end;
-
- when others =>
- raise Grammar_Error with Error_Message
- (Data.Grammar_Lexer.File_Name, Token (2).Line, Token (2).Column,
"unexpected syntax");
- end case;
-
- when Syntax_Trees.Virtual_Terminal | Syntax_Trees.Virtual_Identifier =>
- raise SAL.Programmer_Error;
- end case;
- end Add_Declaration;
-
- procedure Add_Nonterminal
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tokens : in WisiToken.Valid_Node_Index_Array)
- is
- use all type Ada.Containers.Count_Type;
- use WisiToken.Syntax_Trees;
-
- Data : User_Data_Type renames User_Data_Type (User_Data);
-
- LHS_Node : constant Valid_Node_Index := Tokens (1);
- LHS_String : constant String := Get_Text (Data, Tree,
LHS_Node);
-
- Right_Hand_Sides : WisiToken.BNF.RHS_Lists.List;
- Labels : WisiToken.BNF.String_Arrays.Vector;
- begin
- if Data.Phase = Meta or Data.Ignore_Lines then
- return;
- end if;
-
- Data.Rule_Count := Data.Rule_Count + 1;
-
- Get_Right_Hand_Sides (Data, Tree, Right_Hand_Sides, Labels, Tokens (3));
-
- if WisiToken.BNF.Is_Present (Data.Tokens.Rules, LHS_String) then
- case Tree.Label (LHS_Node) is
- when Shared_Terminal =>
- declare
- LHS_Token : Base_Token renames Data.Terminals.all
(Tree.Terminal (LHS_Node));
- begin
- raise Grammar_Error with Error_Message
- (Data.Grammar_Lexer.File_Name, LHS_Token.Line,
LHS_Token.Column, "duplicate nonterm");
- end;
-
- when Virtual_Identifier =>
- raise Grammar_Error with Error_Message
- (Data.Grammar_Lexer.File_Name, 1, 1, "duplicate virtual nonterm
'" & LHS_String & "'");
-
- when others =>
- Raise_Programmer_Error ("Add_Nonterminal", Data, Tree, LHS_Node);
- end case;
- else
- Data.Label_Count := Data.Label_Count + Labels.Length;
-
- Data.Tokens.Rules.Append
- ((+LHS_String, Right_Hand_Sides, Labels,
- Source_Line =>
- (case Tree.Label (LHS_Node) is
- when Shared_Terminal => Data.Terminals.all
(Tree.First_Shared_Terminal (LHS_Node)).Line,
- when Virtual_Identifier => Invalid_Line_Number, -- IMPROVEME:
get line from Right_Hand_Sides
- when others => raise SAL.Programmer_Error)));
- 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;
- Tokens : in WisiToken.Valid_Node_Index_Array;
- Token : in WisiToken.Positive_Index_Type)
- is
- Data : User_Data_Type renames User_Data_Type (User_Data);
- begin
- case Data.Phase is
- when Meta =>
- Data.EBNF_Nodes (Tokens (Token)) := True;
-
- if Data.Meta_Syntax /= EBNF_Syntax then
- declare
- Tok : Base_Token renames Data.Terminals.all
(Tree.First_Shared_Terminal (Tokens (Token)));
- begin
- raise Grammar_Error with Error_Message
- (Data.Grammar_Lexer.File_Name, Tok.Line, Tok.Column,
- "EBNF syntax used, but BNF specified; set '%meta_syntax
EBNF'");
- end;
- end if;
- when Other =>
- Raise_Programmer_Error ("untranslated EBNF node", Data, Tree,
Tree.Parent (Tokens (Token)));
- 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;
-
- Symbol_Regexp : constant GNAT.Regexp.Regexp := GNAT.Regexp.Compile
- ((if Data.Language_Params.Case_Insensitive
- then "[A-Z0-9_]+"
- 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
- Erase_Copied_EBNF_Node (Node);
- end if;
- end Clear_EBNF_Node;
-
- function New_Identifier (Text : in String) return Identifier_Index
- is
- ID : constant Identifier_Index := Base_Identifier_Index
(Data.Tokens.Virtual_Identifiers.Length) + 1;
- begin
- Data.Tokens.Virtual_Identifiers.Append (+Text);
- return ID;
- end New_Identifier;
-
- Keyword_Ident : constant Identifier_Index := New_Identifier ("keyword");
- Percent_Ident : constant Identifier_Index := New_Identifier ("percent");
-
- function Next_Nonterm_Name (Suffix : in String := "") return
Identifier_Index
- is
- function Image is new SAL.Generic_Decimal_Image (Identifier_Index);
- ID : constant Identifier_Index := Identifier_Index
(Data.Tokens.Virtual_Identifiers.Length) + 1;
- begin
-
- if ID > 999 then
- -- We assume 3 digits below
- raise SAL.Programmer_Error with "more than 3 digits needed for
virtual identifiers in EBNF translate";
- end if;
-
- Data.Tokens.Virtual_Identifiers.Append (+("nonterminal_" & Image (ID,
Width => 3) & Suffix));
-
- 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;
- Child_3 : in Valid_Node_Index;
- Child_4 : in Valid_Node_Index)
- return Valid_Node_Index
- is begin
- -- Work around GNAT error about arbitrary evaluation order in
- -- aggregates (no error about the arbitrary order in subprogram
- -- parameter_assocation_lists!).
- return Tree.Add_Nonterm
- (Production => (+nonterminal_ID, 0),
- Children => (Child_1, Child_2, Child_3, Child_4),
- Action => Wisitoken_Grammar_Actions.nonterminal_0'Access);
- end Tree_Add_Nonterminal;
-
- function Duplicate
- (List : in Syntax_Trees.LR_Utils.List;
- New_Content : in Node_Index)
- return Boolean
- is
- -- 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
- for N of List loop
- if New_Content_Str = Get_Text (Data, Tree, N) then
- return True;
- end if;
- end loop;
- 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
- 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
- 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;
- 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;
-
- procedure Erase_Deleted_EBNF_Nodes (Node : in Valid_Node_Index)
- is
- 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
- Tree.Process_Tree (Erase_Deleted_Node'Access, Node);
- end Erase_Deleted_EBNF_Nodes;
-
- 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
- -- B is an optional item in an rhs_item_list:
- -- | A B? C
- --
- -- or B is a rhs_multiple_item that is allowed to be empty:
- -- | A B* C
- --
- -- or B is a virtual identifier naming the new nonterm replacing the
- -- original
- --
- -- A, C can be empty. The containing element may be rhs or
- -- rhs_alternative_list.
- --
- -- 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.
-
- use Syntax_Trees.LR_Utils;
- use Syntax_Trees.LR_Utils.Creators;
- use all type Ada.Containers.Count_Type;
-
- 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);
-
- Skip_Node := List_Root (Tree, Skip_Node,
+rhs_item_list_ID);
-
- 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);
-
- declare
- Result : Skip_Info (Skip_Last);
- begin
- if Result.Skips'Length = 0 then
- return Result;
- end if;
-
- Result.Start_List_Root := Non_Empty_List;
- Result.Start_List_ID := +rhs_item_list_ID;
- Result.Start_Element_ID := +rhs_element_ID;
-
- Result.Start_Separator_ID := Invalid_Token_ID;
- Result.Start_Multi_Element_RHS := 1;
-
- Result.Skips (Skip_Last) := (Skip, Last_Skip_Node);
-
- if Result.Skips'Length = 1 then
- return Result;
- 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;
-
- declare
- Skip_List : constant Skip_Info := Find_Skips;
-
- 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 ("skip: " & Image (Skip_List,
Wisitoken_Grammar_Actions.Descriptor));
- end if;
-
- 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
- Insert_RHS (Container_List, New_RHS_AC, After =>
Container);
- end if;
- end if;
-
- else
- -- Insert an edited rhs_item_list into an rhs_alternative_list
-
- New_RHS_AC := Copy_Skip_Nested (Skip_List, Tree);
-
- 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;
-
- 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 if;
-
- 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;
-
- 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
- -- 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
- List.Append (Comp_Unit);
- end if;
-
- if Trace_Generate_EBNF > Extra then
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("new " & Label & ":" & Comp_Unit'Image & ":
'" & Get_Text (Data, Tree, Unit) & "'");
- end if;
- end Add_Compilation_Unit;
-
- function To_RHS_List (RHS_Element : in Valid_Node_Index) return
Valid_Node_Index
- with Pre => Tree.ID (RHS_Element) = +rhs_element_ID
- is
- RHS_Item_List : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_item_list_ID, 0), (1 => RHS_Element));
- RHS : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_ID, 1), (1 => RHS_Item_List));
- begin
- return Tree.Add_Nonterm ((+rhs_list_ID, 0), (1 => RHS));
- end To_RHS_List;
-
- function Convert_RHS_Alternative (Content : in Valid_Node_Index) return
Valid_Node_Index
- with Pre => Tree.ID (Content) = +rhs_alternative_list_ID
- is
- -- Convert rhs_alternative_list rooted at Content to an rhs_list
- Node : Valid_Node_Index := Content;
- begin
- loop
- exit when Tree.RHS_Index (Node) = 0;
-
- -- current tree:
- -- rhs_alternative_list : Node
- -- | rhs_alternative_list: Node.Child (1)
- -- | | ...
- -- | BAR: Node.child (2)
- -- | rhs_item_list: Node.Child (3)
-
- -- new tree:
- -- rhs_list: Node
- -- | rhs_alternative_list: keep Node.Child (1)
- -- | | ...
- -- | BAR: keep
- -- | rhs: new
- -- | | rhs_item_list: keep Node,Child (3)
-
- 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),
- (+rhs_ID, 0),
- (1 .. 0 => Invalid_Node_Index));
-
- Tree.Set_Children
- (Node,
- (+rhs_list_ID, 1),
- (1 => Tree.Child (Node, 1),
- 2 => Tree.Child (Node, 2),
- 3 => Tree.Child (Node, 3)));
- else
- Tree.Set_Children
- (Node,
- (+rhs_list_ID, 1),
- (1 => Tree.Child (Node, 1),
- 2 => Tree.Child (Node, 2),
- 3 => Tree.Add_Nonterm
- ((+rhs_ID, 1),
- (1 => Tree.Child (Node, 3)))));
- end if;
-
- Node := Tree.Child (Node, 1);
- end loop;
-
- -- current tree:
- -- rhs_alternative_list : Node
- -- | rhs_item_list: Node.Child (1)
-
- -- new tree:
- -- rhs_list: Node
- -- | rhs: new
- -- | | rhs_item_list: Node.Child (1)
-
- Tree.Set_Children
- (Node,
- (+rhs_list_ID, 0),
- (1 => Tree.Add_Nonterm ((+rhs_ID, 1), (1 => Tree.Child (Node,
1)))));
-
- return Content;
- end Convert_RHS_Alternative;
-
- procedure New_Nonterminal
- (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.
- begin
- 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
- (List_Nonterm : in Identifier_Index;
- RHS_Element_1 : in Valid_Node_Index;
- RHS_Element_3 : in Valid_Node_Index;
- Byte_Region : in Buffer_Region)
- with Pre => Tree.ID (RHS_Element_1) = +rhs_element_ID and
- Tree.ID (RHS_Element_3) = +rhs_element_ID
- is
- -- nonterminal: foo_list
- -- | IDENTIFIER: "foo_list" List_Nonterm
- -- | COLON:
- -- | rhs_list:
- -- | | rhs_list: RHS_List_2
- -- | | | rhs: RHS_2
- -- | | | | rhs_item_list: RHS_Item_List_1
- -- | | | | | rhs_element: RHS_Element_1
- -- | | | | | | rhs_item: RHS_Item_1
- -- | | | | | | | IDENTIFIER: List_Element
- -- | | BAR:
- -- | | rhs: RHS_3
- -- | | | rhs_item_list: RHS_Item_List_2
- -- | | | | | rhs_item_list: RHS_Item_List_3
- -- | | | | | | rhs_element: RHS_Element_2
- -- | | | | | | | rhs_item: RHS_Item_2
- -- | | | | | | | | IDENTIFIER: List_Nonterm
- -- | | | | rhs_element: RHS_Element_3
- -- | | | | | rhs_item: RHS_Item_3
- -- | | | | | | IDENTIFIER: List_Element
- -- | semicolon_opt:
- -- | | SEMICOLON:
-
- RHS_Item_2 : constant Valid_Node_Index := Tree.Add_Nonterm
- ((+rhs_item_ID, 0), (1 => Tree.Add_Identifier (+IDENTIFIER_ID,
List_Nonterm, Byte_Region)));
-
- RHS_Element_2 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_2));
-
- RHS_Item_List_1 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_item_list_ID, 0), (1 => RHS_Element_1));
- RHS_Item_List_3 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_item_list_ID, 0), (1 => RHS_Element_2));
- RHS_Item_List_2 : constant Valid_Node_Index := Tree.Add_Nonterm
- ((+rhs_item_list_ID, 1), (1 => RHS_Item_List_3, 2 =>
RHS_Element_3));
-
- RHS_2 : constant Valid_Node_Index := Tree.Add_Nonterm ((+rhs_ID, 1),
(1 => RHS_Item_List_1));
- RHS_3 : constant Valid_Node_Index := Tree.Add_Nonterm ((+rhs_ID, 1),
(1 => RHS_Item_List_2));
-
- Bar_1 : constant Valid_Node_Index := Tree.Add_Terminal (+BAR_ID);
-
- RHS_List_2 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_list_ID, 0), (1 => RHS_2));
-
- List_Nonterminal : constant Valid_Node_Index := Tree_Add_Nonterminal
- (Child_1 => Tree.Add_Identifier (+IDENTIFIER_ID, List_Nonterm,
Byte_Region),
- Child_2 => Tree.Add_Terminal (+COLON_ID),
- Child_3 => Tree.Add_Nonterm
- ((+rhs_list_ID, 1),
- (1 => RHS_List_2,
- 2 => Bar_1,
- 3 => RHS_3)),
- Child_4 => Tree.Add_Nonterm
- ((+semicolon_opt_ID, 0),
- (1 => Tree.Add_Terminal (+SEMICOLON_ID))));
- begin
- Add_Compilation_Unit ("canonical list" & List_Nonterm'Image,
List_Nonterminal);
- end New_Nonterminal_List_1;
-
- procedure New_Nonterminal_List
- (List_Nonterm : in Identifier_Index;
- List_Element : in Identifier_Index;
- Byte_Region : in Buffer_Region)
- is
- RHS_Item_1 : constant Valid_Node_Index := Tree.Add_Nonterm
- ((+rhs_item_ID, 0), (1 => Tree.Add_Identifier (+IDENTIFIER_ID,
List_Element, Byte_Region)));
- RHS_Item_3 : constant Valid_Node_Index := Tree.Add_Nonterm
- ((+rhs_item_ID, 0), (1 => Tree.Add_Identifier (+IDENTIFIER_ID,
List_Element, Byte_Region)));
- RHS_Element_1 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_1));
- RHS_Element_3 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_3));
- begin
- New_Nonterminal_List_1 (List_Nonterm, RHS_Element_1, RHS_Element_3,
Byte_Region);
- end New_Nonterminal_List;
-
- procedure New_Nonterminal_List
- (List_Nonterm : in Identifier_Index;
- List_Element : in Token_Index;
- Terminals : in Base_Token_Arrays.Vector;
- Byte_Region : in Buffer_Region)
- is
- RHS_Item_1 : constant Valid_Node_Index := Tree.Add_Nonterm
- ((+rhs_item_ID, 0), (1 => Tree.Add_Terminal (List_Element,
Terminals)));
- RHS_Item_3 : constant Valid_Node_Index := Tree.Add_Nonterm
- ((+rhs_item_ID, 0), (1 => Tree.Add_Terminal (List_Element,
Terminals)));
- RHS_Element_1 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_1));
- RHS_Element_3 : constant Valid_Node_Index := Tree.Add_Nonterm
((+rhs_element_ID, 0), (1 => RHS_Item_3));
- begin
- New_Nonterminal_List_1 (List_Nonterm, RHS_Element_1, RHS_Element_3,
Byte_Region);
- end New_Nonterminal_List;
-
- procedure Copy_Non_Grammar
- (From : in Valid_Node_Index;
- To : in Valid_Node_Index)
- is
- From_Aug : constant Base_Token_Class_Access := Tree.Augmented (From);
- begin
- if From_Aug /= null then
- declare
- New_Aug : constant Augmented_Token_Access := new
Augmented_Token'
- (ID => Tree.ID (From),
- Tree_Index => To,
- Non_Grammar => Augmented_Token_Access (From_Aug).Non_Grammar,
- others => <>);
- begin
- Tree.Set_Augmented (To, Base_Token_Class_Access (New_Aug));
- end;
- end if;
- end Copy_Non_Grammar;
-
- 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
-
- 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;
-
- 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;
-
- 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:
- --
- -- SwitchLabels : SwitchLabel {SwitchLabel} ;
- --
- -- where Node is the rhs_multiple_item containing "(','
- -- enumConstant)*" or "{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.
-
- 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
- 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
- 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;
-
- 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
- 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
- -- 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
-
- 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;
-
- 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;
-
- Erase_Deleted_EBNF_Nodes (Get_Node (Container_Cur));
- -- This includes B, so we don't do 'Clear_EBNF_Node (B)'.
-
- Container_List.Delete (Container_Cur);
- end;
-
- when 2 =>
- -- | IDENTIFIER QUESTION
- --
- -- Current tree:
- -- rhs_item_3
- -- | rhs_optional_item_2: B
- -- | | IDENTIFIER
- -- | | QUESTION
- --
- -- Change to:
- -- rhs_item_0
- -- | IDENTIFIER
-
- Tree.Set_Children (Tree.Parent (B), (+rhs_item_ID, 0), (1 =>
Tree.Child (B, 1)));
- Clear_EBNF_Node (B);
-
- 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;
-
- 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 (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
- 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;
-
- 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
- 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;
-
- 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;
-
- 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;
-
- when others =>
- Put_Error ("unexpected RHS_Index");
- end case;
-
- when rhs_ID =>
- case RHS_Index is
- when 0 =>
- if Children'Length /= 0 then
- Put_Error ("expected child_count 0");
- end if;
-
- 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;
-
- 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;
-
- 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;
-
- when others =>
- Put_Error ("unexpected RHS_Index");
- end case;
-
- when rhs_attribute_ID =>
- Check_EBNF_Allowed;
-
- 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;
-
- 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
- Put_Error ("expecting IDENTIFIER EQUAL rhs_item");
- end if;
-
- when others =>
- Put_Error ("unexpected RHS_Index");
- end case;
-
- 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 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 =>
- Put_Error ("unexpected RHS_Index");
- end case;
-
- when rhs_item_ID =>
- if Tree.Child_Count (Node) /= 1 then
- Put_Error ("expected child_count 1");
- end if;
-
- case RHS_Index is
- when 0 =>
- if Tree.ID (Children (1)) /= +IDENTIFIER_ID then
- Put_Error ("expecting IDENTIFIER");
- end if;
-
- when 1 =>
- if Tree.ID (Children (1)) /= +STRING_LITERAL_2_ID then
- Put_Error ("expecting STRING_LITERAL_2");
- end if;
-
- when 2 =>
- if Tree.ID (Children (1)) /= +rhs_attribute_ID then
- Put_Error ("expecting rhs_attribute");
- end if;
-
- when 3 =>
- if Tree.ID (Children (1)) /= +rhs_optional_item_ID then
- Put_Error ("expecting rhs_optional_item");
- end if;
-
- when 4 =>
- if Tree.ID (Children (1)) /= +rhs_multiple_item_ID then
- Put_Error ("expecting rhs_multiple_item");
- end if;
-
- when 5 =>
- if Tree.ID (Children (1)) /= +rhs_group_item_ID then
- Put_Error ("expecting rhs_group_item");
- end if;
-
- when others =>
- Put_Error ("unexpected RHS_Index");
- end case;
-
- 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;
-
- 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;
-
- 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;
-
- 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;
-
- 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;
-
- when others =>
- Put_Error ("unexpected RHS_Index");
- end case;
-
- 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;
-
- 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 =>
- 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 =>
- 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;
-
- 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 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;
-
- when others =>
- Put_Error ("unexpected RHS_Index");
- end case;
-
- 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;
-
- 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;
- when others =>
- Put_Error ("unexpected RHS_Index");
- end case;
-
- when compilation_unit_ID =>
- null;
-
- when compilation_unit_list_ID =>
- null;
-
- when others =>
- null;
- end case;
- end;
- end Validate_Node;
-
- 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;
-
- 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;
-
- declare
- 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;
- 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
- Ada.Text_IO.New_Line;
- Ada.Text_IO.Put_Line ("Identifiers:");
- for I in Data.Tokens.Virtual_Identifiers.First_Index ..
Data.Tokens.Virtual_Identifiers.Last_Index loop
- Ada.Text_IO.Put_Line (Base_Identifier_Index'Image (I) & " " &
(-Data.Tokens.Virtual_Identifiers (I)));
- end loop;
- end if;
- end Translate_EBNF_To_BNF;
-
- procedure Print_Source
- (File_Name : in String;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Data : in User_Data_Type)
- is
- use Ada.Text_IO;
- use WisiToken.Syntax_Trees;
-
- File : File_Type;
-
- procedure Put_Comments
- (Node : in Valid_Node_Index;
- Force_New_Line : in Boolean := False;
- Force_Comment : in String := "")
- is
- Last_Term : constant Node_Index := Tree.Last_Terminal
(Node);
- Aug : constant Base_Token_Class_Access :=
- (if Last_Term = Invalid_Node_Index
- then null
- else Tree.Augmented (Last_Term));
-
- Comments_Include_Newline : Boolean := False;
- begin
- if Aug = null then
- if Force_Comment /= "" then
- Put_Line (File, Force_Comment);
-
- elsif Force_New_Line then
- New_Line (File);
- end if;
- else
- for Token of Augmented_Token_Access (Aug).Non_Grammar loop
- if Token.ID = +NEW_LINE_ID then
- Comments_Include_Newline := True;
- end if;
- Put (File, Data.Grammar_Lexer.Buffer_Text (Token.Byte_Region));
- end loop;
- if Force_New_Line and not Comments_Include_Newline then
- New_Line (File);
- end if;
- end if;
- end Put_Comments;
-
- procedure Put_Declaration_Item (Node : in Valid_Node_Index)
- is
- Children : constant Valid_Node_Index_Array := Tree.Children (Node);
- begin
- case To_Token_Enum (Tree.ID (Children (1))) is
- when IDENTIFIER_ID | NUMERIC_LITERAL_ID | STRING_LITERAL_1_ID |
STRING_LITERAL_2_ID =>
- Put (File, ' ' & Get_Text (Data, Tree, Children (1)));
- when REGEXP_ID =>
- Put (File, " %[" & Get_Text (Data, Tree, Children (1)) & "]%");
- when others =>
- Put (File, Image (Tree.ID (Children (1)),
Wisitoken_Grammar_Actions.Descriptor));
- end case;
- end Put_Declaration_Item;
-
- procedure Put_Declaration_Item_List (Node : in Valid_Node_Index)
- is
- Children : constant Valid_Node_Index_Array := Tree.Children (Node);
- begin
- if Children'Length = 1 then
- Put_Declaration_Item (Children (1));
- else
- Put_Declaration_Item_List (Children (1));
- Put_Declaration_Item (Children (2));
- end if;
- end Put_Declaration_Item_List;
-
- procedure Put_Identifier_List (Node : in Valid_Node_Index)
- is
- Children : constant Valid_Node_Index_Array := Tree.Children (Node);
- begin
- if Children'Length = 1 then
- Put (File, Get_Text (Data, Tree, Children (1)));
- else
- Put_Identifier_List (Children (1));
- Put (File, ' ');
- Put (File, Get_Text (Data, Tree, Children (2)));
- end if;
- end Put_Identifier_List;
-
- procedure Put_RHS_Element (Node : in Valid_Node_Index)
- with Pre => Tree.ID (Node) = +rhs_element_ID
- is begin
- -- We don't raise an exception for errors here; it's easier to debug
from the
- -- mangled source listing.
-
- case Tree.RHS_Index (Node) is
- when 0 =>
- Put (File, Get_Text (Data, Tree, Node));
-
- when 1 =>
- -- Output no spaces around "="
- declare
- Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
- begin
- Put (File, Get_Text (Data, Tree, Children (1)) & "=" & Get_Text
(Data, Tree, Children (3)));
- end;
-
- when others =>
- New_Line (File);
- Put (File, " ;; not translated: " & Node_Index'Image (Node) & ":" &
- Tree.Image (Node, Wisitoken_Grammar_Actions.Descriptor,
- Include_Children => True,
- Include_RHS_Index => True,
- Node_Numbers => True));
- end case;
- exception
- when SAL.Programmer_Error =>
- raise;
-
- when E : others =>
- declare
- use Ada.Exceptions;
- begin
- Raise_Programmer_Error
- ("Put_RHS_Element: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Node);
- end;
- end Put_RHS_Element;
-
- procedure Put_RHS_Item_List (Node : in Valid_Node_Index)
- with Pre => Tree.ID (Node) = +rhs_item_list_ID
- is
- Children : constant Valid_Node_Index_Array := Tree.Children (Node);
- begin
- if Children'Length = 1 then
- Put_RHS_Element (Children (1));
- else
- Put_RHS_Item_List (Children (1));
- Put (File, ' ');
- Put_RHS_Element (Children (2));
- end if;
- exception
- when SAL.Programmer_Error =>
- raise;
-
- when E : others =>
- declare
- use Ada.Exceptions;
- begin
- Raise_Programmer_Error
- ("Put_RHS_Item_List: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Node);
- end;
- end Put_RHS_Item_List;
-
- procedure Put_RHS
- (Node : in Valid_Node_Index;
- First : in Boolean)
- with Pre => Tree.ID (Node) = +rhs_ID
- is
- Children : constant Valid_Node_Index_Array := Tree.Children (Node);
- begin
- Put (File, (if First then " : " else " | "));
- case Tree.RHS_Index (Node) is
- when 0 =>
- Put_Comments (Tree.Parent (Node), Force_Comment => ";; empty");
-
- when 1 .. 3 =>
- Put_RHS_Item_List (Children (1));
- Put_Comments (Children (1), Force_New_Line => True);
-
- if Tree.RHS_Index (Node) > 1 then
- Put (File, " %(" & Get_Text (Data, Tree, Children (2)) &
")%"); -- action
- Put_Comments (Children (2), Force_New_Line => True);
-
- if Tree.RHS_Index (Node) > 2 then
- Put (File, " %(" & Get_Text (Data, Tree, Children (3)) &
")%"); -- check
- Put_Comments (Children (3), Force_New_Line => True);
- end if;
- end if;
-
- when others =>
- Raise_Programmer_Error ("Put_RHS", Data, Tree, Node);
- end case;
- exception
- when SAL.Programmer_Error =>
- raise;
-
- when E : others =>
- declare
- use Ada.Exceptions;
- begin
- Raise_Programmer_Error ("Put_RHS: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Node);
- end;
- end Put_RHS;
-
- procedure Put_RHS_List
- (Node : in Valid_Node_Index;
- First : in out Boolean;
- Virtual : 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), First);
- First := False;
- when 1 =>
- Put_RHS_List (Children (1), First, Virtual);
- Put_RHS (Children (3), First => False);
- when 2 =>
- Put
- (File, "%if " & Get_Text (Data, Tree, Children (3)) & " = " &
Get_Text (Data, Tree, Children (4)));
- Put_Comments (Node);
-
- when 3 =>
- Put (File, "%end if");
- Put_Comments (Node);
-
- when others =>
- Raise_Programmer_Error ("Put_RHS_List", Data, Tree, Node);
- end case;
- exception
- when SAL.Programmer_Error =>
- raise;
-
- when E : others =>
- declare
- use Ada.Exceptions;
- begin
- Raise_Programmer_Error
- ("Put_RHS_List: " & Exception_Name (E) & ": " &
Exception_Message (E), Data, Tree, Node);
- end;
- 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 =>
- declare
- Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
- begin
- case Tree.RHS_Index (Node) is
- when 0 =>
- case Tree.RHS_Index (Children (2)) is
- when 0 =>
- Put (File, "%keyword");
- when 1 =>
- Put (File, "%non_grammar <" & Get_Text (Data, Tree,
Tree.Child (Children (2), 3)) & ">");
- when 2 =>
- Put (File, "%token <" & Get_Text (Data, Tree, Tree.Child
(Children (2), 3)) & ">");
- when others =>
- raise SAL.Programmer_Error;
- end case;
-
- Put (File, " " & Get_Text (Data, Tree, Children (3)));
- Put_Declaration_Item_List (Children (4));
- Put_Comments (Children (4), Force_New_Line => True);
-
- when 1 =>
- Put (File, "%code ");
- Put_Identifier_List (Children (3));
- Put (File, " %{" & Get_Text (Data, Tree, Children (4)) &
"}%"); -- RAW_CODE
- Put_Comments (Node);
-
- when 2 =>
- declare
- Key : constant String := Get_Text (Data, Tree, Children
(2));
- begin
- if Key = "conflict" then
- Put (File, Data.Grammar_Lexer.Buffer_Text
(Tree.Byte_Region (Node)));
- else
- Put (File, "%" & Key);
- Put_Declaration_Item_List (Children (3));
- end if;
- end;
- Put_Comments (Children (3));
-
- when 3 =>
- Put (File, "%" & Get_Text (Data, Tree, Children (2)));
- Put_Comments (Children (2));
-
- when 4 =>
- Put
- (File, "%if" & Get_Text (Data, Tree, Children (2)) & " = "
& Get_Text (Data, Tree, Children (4)));
- Put_Comments (Node);
-
- when 5 =>
- Put (File, "%end if");
- Put_Comments (Node);
-
- when others =>
- raise SAL.Programmer_Error;
- end case;
- end;
-
- when nonterminal_ID =>
- declare
- Children : constant Valid_Node_Index_Array := Tree.Children
(Node);
- Virtual : constant Boolean := Tree.Label
(Children (1)) = Virtual_Identifier;
- First : Boolean := True;
- begin
- Put (File, Get_Text (Data, Tree, Children (1)));
- Put_Comments (Children (1), Force_New_Line => True);
-
- Put_RHS_List (Children (3), First, Virtual);
-
- if Tree.Children (Children (4))'Length > 0 then
- if Virtual then
- Put_Line (File, " ;");
- else
- Put (File, " ;");
- Put_Comments (Children (4));
- end if;
- end if;
- 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, File_Name);
- Put_Line (File, ";;; generated from " & Data.Grammar_Lexer.File_Name & "
-*- buffer-read-only:t -*-");
- Put_Line (File, ";;;");
-
- for Token of Data.Leading_Non_Grammar loop
- Put (File, Data.Grammar_Lexer.Buffer_Text (Token.Byte_Region));
- end loop;
-
- Process_Node (Tree.Root);
-
- Close (File);
- exception
- when E : SAL.Not_Implemented =>
- Close (File);
- Ada.Text_IO.Put_Line
- (Ada.Text_IO.Standard_Error, "Print_Source not implemented: " &
Ada.Exceptions.Exception_Message (E));
- end Print_Source;
-
-end WisiToken_Grammar_Runtime;
--- Local Variables:
--- ada-which-func-parse-size: 50000
--- End:
diff --git a/packages/wisi/wisitoken_grammar_runtime.ads
b/packages/wisi/wisitoken_grammar_runtime.ads
deleted file mode 100644
index a9de950..0000000
--- a/packages/wisi/wisitoken_grammar_runtime.ads
+++ /dev/null
@@ -1,166 +0,0 @@
--- Abstract :
---
--- Runtime utils for wisi_grammar.wy actions.
---
--- Copyright (C) 2018 - 2020 Free Software Foundation, Inc.
---
--- This library is free software; you can redistribute it and/or modify it
--- under terms of the GNU General Public License as published by the Free
--- Software Foundation; either version 3, or (at your option) any later
--- version. This library is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN-
--- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
--- As a special exception under Section 7 of GPL version 3, you are granted
--- additional permissions described in the GCC Runtime Library Exception,
--- version 3.1, as published by the Free Software Foundation.
-
-pragma License (Modified_GPL);
-
-with Ada.Containers;
-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);
- -- Syntax used in grammar file.
-
- type Action_Phase is (Meta, Other);
-
- type User_Data_Type is new WisiToken.Syntax_Trees.User_Data_Type with
- record
- Grammar_Lexer : WisiToken.Lexer.Handle; -- used to read the .wy file now.
-
- User_Lexer : WisiToken.BNF.Lexer_Type := WisiToken.BNF.None;
- -- Used to read the user language file, after user parser is generated;
- -- used now in '%if lexer' statements.
-
- User_Parser : WisiToken.BNF.Generate_Algorithm := WisiToken.BNF.None;
- -- Used to generate the user parser; used now in '%if parser'
- -- statements.
-
- Generate_Set : WisiToken.BNF.Generate_Set_Access;
- -- As specified by %generate directives or command line.
-
- Phase : Action_Phase := Meta;
- -- Determines which actions Execute_Actions executes:
- -- Meta - meta declarations, like %meta_syntax, %generate
- -- Other - everything else
-
- Meta_Syntax : WisiToken_Grammar_Runtime.Meta_Syntax := Unknown;
- 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;
- Conflicts : WisiToken.BNF.Conflict_Lists.List;
- McKenzie_Recover : WisiToken.BNF.McKenzie_Recover_Param_Type;
-
- Leading_Non_Grammar : WisiToken.Base_Token_Arrays.Vector;
- -- leading blank lines and comments
-
- Last_Terminal_Node : WisiToken.Node_Index :=
WisiToken.Invalid_Node_Index;
-
- Rule_Count : Integer := 0;
- Action_Count : Integer := 0;
- Check_Count : Integer := 0;
- Label_Count : Ada.Containers.Count_Type := 0;
-
- EBNF_Nodes : WisiToken.Syntax_Trees.Node_Sets.Vector;
-
- If_Lexer_Present : Boolean := False;
- If_Parser_Present : Boolean := False;
- -- Set True by %if statements in Execute_Actions.
-
- Ignore_Lines : Boolean := False;
- -- An '%if' specified a different lexer, during Execute_Actions
- end record;
-
- type Augmented_Token is new WisiToken.Base_Token with
- record
- Non_Grammar : WisiToken.Base_Token_Arrays.Vector;
- end record;
- type Augmented_Token_Access is access all Augmented_Token;
-
- function Image (Item : in WisiToken.Base_Token_Class_Access) return String
- is (WisiToken.Image (Augmented_Token_Access (Item).Non_Grammar,
Wisitoken_Grammar_Actions.Descriptor));
-
- overriding
- procedure Set_Lexer_Terminals
- (User_Data : in out User_Data_Type;
- Lexer : in WisiToken.Lexer.Handle;
- Terminals : in WisiToken.Base_Token_Array_Access_Constant);
-
- overriding procedure Reset (Data : in out User_Data_Type);
-
- overriding
- procedure Initialize_Actions
- (Data : in out User_Data_Type;
- Tree : in WisiToken.Syntax_Trees.Tree'Class);
-
- overriding
- procedure Lexer_To_Augmented
- (Data : in out User_Data_Type;
- Tree : in out WisiToken.Syntax_Trees.Tree'Class;
- Token : in WisiToken.Base_Token;
- Lexer : not null access WisiToken.Lexer.Instance'Class);
-
- procedure Start_If
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tokens : in WisiToken.Valid_Node_Index_Array);
-
- procedure End_If (User_Data : in out
WisiToken.Syntax_Trees.User_Data_Type'Class);
-
- procedure Add_Declaration
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tokens : in WisiToken.Valid_Node_Index_Array);
-
- procedure Add_Nonterminal
- (User_Data : in out WisiToken.Syntax_Trees.User_Data_Type'Class;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Tokens : in WisiToken.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);
- -- Process EBNF nonterms, adding new nonterms as needed, resulting in
- -- a BNF tree.
- --
- -- Generator.LR.*_Generate requires a BNF grammar.
-
- procedure Print_Source
- (File_Name : in String;
- Tree : in WisiToken.Syntax_Trees.Tree;
- Data : in User_Data_Type);
- -- Print the wisitoken grammar source represented by Tree, Terminals
- -- to a new file File_Name.
-
-end WisiToken_Grammar_Runtime;
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [elpa] master ab6f759: * externals-list: Convert wisi to :external,
Stefan Monnier <=