[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/wisi a4e4907 01/35: Add ada-mode, wisi packages
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] externals/wisi a4e4907 01/35: Add ada-mode, wisi packages |
|
Date: |
Sat, 28 Nov 2020 14:47:49 -0500 (EST) |
branch: externals/wisi
commit a4e49077a917c63accfb993d7b7dfee258e39706
Author: U-takverstephe <stephe@takver.(none)>
Commit: U-takverstephe <stephe@takver.(none)>
Add ada-mode, wisi packages
* packages/ada-mode/: New directory.
* packages/wisi/: New directory.
---
wisi-compile.el | 223 +++++++++++
wisi-parse.el | 426 +++++++++++++++++++++
wisi.el | 1112 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 1761 insertions(+)
diff --git a/wisi-compile.el b/wisi-compile.el
new file mode 100755
index 0000000..39ed689
--- /dev/null
+++ b/wisi-compile.el
@@ -0,0 +1,223 @@
+;;; Grammar compiler for the wisent LALR parser, integrating Wisi OpenToken
output.
+;;
+;; Copyright (C) 2012, 2013 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/>.
+;;
+;;; History: first experimental version Jan 2013
+;;
+;;; Context
+;;
+;; Semantic (info "(semantic)Top") provides an LALR(1) parser
+;; wisent-parse. The grammar used is defined by the functions
+;; semantic-grammar-create-package, which reads a bison-like source
+;; file and produces corresponding elisp source, and
+;; wisent-compile-grammar, which generates a parser table.
+;;
+;; However, the algorithm used in wisent-compile-grammar cannot cope
+;; with the grammar for the Ada language, because it is not
+;; LALR(1). So we provide a generalized LALR parser, which spawns
+;; parallel LALR parsers at each conflict. Instead of also rewriting
+;; the entire semantic grammar compiler, we use the OpenToken LALR
+;; parser generator, which is easier to modify (it is written in Ada,
+;; not Lisp).
+;;
+;; The Ada function Wisi.Generate reads the bison-like input and
+;; produces corresponding elisp source code, similar to that
+;; produced by semantic-grammar-create-package.
+;;
+;; wisi-compile-grammar (provided here) generate the automaton
+;; structure required by wisi-parse, using functions from
+;; wisent/comp.el
+;;
+;;;;
+
+(eval-when-compile
+ ;; can't just 'require'; `wisent-with-context' doesn't work.
+ ;; also can't load .elc; must load .el
+ (load (locate-library "semantic/wisent/comp.el")))
+
+(eval-and-compile
+ (require 'semantic/wisent/comp))
+
+(defun wisi-compose-action (value symbol-array nonterms)
+ (let ((symbol (intern-soft (format "%s:%d" (car value) (cdr value))
symbol-array))
+ (prod (car (nth (cdr value) (cdr (assoc (car value) nonterms))))))
+ (if symbol
+ (list (car value) symbol (length prod))
+ (error "%s not in symbol-array" symbol))))
+
+(defun wisi-replace-actions (action symbol-array nonterms)
+ "Replace semantic action symbol names in ACTION with list as defined in
`wisi-compile-grammar'.
+ACTION is the alist for one state from the grammar; NONTERMS is from the
grammar.
+Return the new alist."
+ ;; result is (nonterm index action-symbol token-count)
+ (let (result item)
+ (while action
+ (setq item (pop action))
+ (cond
+ ((or
+ (memq (cdr item) '(error accept))
+ (numberp (cdr item)))
+ (push item result))
+
+ ((listp (cdr item))
+ (let ((value (cdr item)))
+ (cond
+ ((symbolp (car value))
+ ;; reduction
+ (push (cons (car item)
+ (wisi-compose-action value symbol-array nonterms))
+ result))
+
+ ((integerp (car value))
+ ;; shift/reduce conflict
+ (push (cons (car item)
+ (list (car value)
+ (wisi-compose-action (cadr value) symbol-array
nonterms)))
+ result))
+
+ ((integerp (cadr value))
+ ;; reduce/shift conflict
+ (push (cons (car item)
+ (list (wisi-compose-action (car value) symbol-array
nonterms)
+ (cadr value)))
+ result))
+
+ (t ;; reduce/reduce conflict
+ (push (cons (car item)
+ (list (wisi-compose-action (car value) symbol-array
nonterms)
+ (wisi-compose-action (cadr value) symbol-array
nonterms)))
+ result))
+ )))
+
+ (t
+ (error "unexpected '%s'; expected 'error, 'accept, numberp, stringp,
listp" (cdr item)))
+ ));; while/cond
+
+ (reverse result)))
+
+(defun wisi-semantic-action (r rcode tags rlhs)
+ "Define an Elisp function for semantic action at rule R.
+On entry RCODE[R] contains a vector [BODY N (NTERM I)] where BODY
+is the body of the semantic action, N is the number of tokens in
+the production, NTERM is the nonterminal the semantic action
+belongs to, and I is the index of the production and associated
+semantic action in the NTERM rule. Returns the semantic action
+symbol, which is interned in RCODE[0].
+
+The semantic action function accepts one argument, the list of
+tokens to be reduced. It returns nil; it is called for the user
+side-effects only."
+ ;; based on comp.el wisent-semantic-action
+ (let* ((actn (aref rcode r))
+ (n (aref actn 1)) ; number of tokens in production
+ (name (apply 'format "%s:%d" (aref actn 2)))
+ (form (aref actn 0))
+ (action-symbol (intern name (aref rcode 0))))
+
+ (fset action-symbol
+ `(lambda (wisi-tokens)
+ (let* (($nterm ',(aref tags (aref rlhs r)))
+ ($1 nil));; wisent-parse-nonterminals defines a default
body of $1 for empty actions
+ ,form
+ nil)))
+
+ (list (car (aref actn 2)) action-symbol n)))
+
+(defun wisi-compile-grammar (grammar)
+ "Compile the LALR(1) GRAMMAR; return the automaton for wisi-parse.
+GRAMMAR is a list TERMINALS NONTERMS ACTIONS GOTOS, where:
+
+TERMINALS is a list of terminal token symbols.
+
+NONTERMS is a list of productions; each production is a
+list (nonterm (tokens action) ...) where `action' is any lisp form.
+
+ACTIONS is an array indexed by parser state, of alists indexed by
+terminal tokens. The value of each item in the alists is one of:
+
+'error
+
+'accept
+
+integer - shift; gives new state
+
+'(nonterm . index) - reduce by nonterm production index.
+
+'(integer (nonterm . index)) - a shift/reduce conflict
+'((nonterm . index) integer) - a reduce/shift conflict
+'((nonterm . index) (nonterm . index)) - a reduce/reduce conflict
+
+The first item in the alist must have the key 'default (not a
+terminal token); it is used when no other item matches the
+current token.
+
+GOTOS is an array indexed by parser state, of alists giving the
+new state after a reduce for each nonterminal legal in that
+state.
+
+The automaton is an array with 3 elements:
+
+parser-actions is a copy of the input ACTIONS, with reduction
+actions replaced by a list (nonterm action-symbol token-count),
+where `nonterm' is a symbol from NONTERMS, and is the
+non-terminal to reduce to, token-count is the number of tokens in
+the reduction, action-symbol is nil if there is no user action,
+or a symbol from semantic-actions (below).
+
+gotos is a copy of GOTOS.
+
+semantic-actions is an obarray containing functions that
+implement the user action for each nonterminal; the function
+names have the format nonterm:index."
+ (wisent-with-context compile-grammar
+ (wisent-parse-grammar;; set global vars used by wisent-semantic-action
+ (cons
+ (nth 0 grammar);; TOKENS
+ (cons nil ;; ASSOCS
+ (nth 1 grammar));; NONTERMS
+ ))
+
+ (aset rcode 0 (make-vector 13 0));; obarray for semantic actions
+
+ ;; create semantic action functions, interned in rcode[0]
+ (let* ((i 1))
+ (while (<= i nrules)
+ (wisi-semantic-action i rcode tags rlhs)
+ (setq i (1+ i)))
+ )
+
+ ;; replace semantic actions in ACTIONS with symbols from symbol-array
+ (let ((nactions (length (nth 2 grammar)))
+ (actions (nth 2 grammar))
+ (symbol-array (aref rcode 0))
+ (i 0))
+ (while (< i nactions)
+ (aset actions i
+ (wisi-replace-actions (aref actions i) symbol-array (nth 1
grammar)))
+ (setq i (1+ i)))
+ (vector
+ actions
+ (nth 3 grammar)
+ symbol-array)
+ )))
+
+(provide 'wisi-compile)
+
+;;;; end of file
diff --git a/wisi-parse.el b/wisi-parse.el
new file mode 100755
index 0000000..5c1af98
--- /dev/null
+++ b/wisi-parse.el
@@ -0,0 +1,426 @@
+;; Wisi parser
+;;
+;; An extended LALR parser, that handles shift/reduce and
+;; reduce/reduce conflicts by spawning parallel parsers to follow each
+;; path.
+
+(require 'semantic/wisent)
+(eval-when-compile (require 'cl-macs))
+
+(cl-defstruct (wisi-parser-state
+ (:copier nil))
+ label ;; integer identifying parser for debug
+
+ active
+ ;; 'shift - need new token
+ ;; 'reduce - need reduce
+ ;; 'accept - parsing completed
+ ;; 'error - failed, error not reported yet
+ ;; nil - terminated
+ ;;
+ ;; 'pending-shift, 'pending-reduce - newly created parser; see wisi-parse
+
+ stack
+ ;; Each stack item takes two slots: (token-symbol token-text (token-start .
token-end)), state
+ ;; token-text is nil for nonterminals.
+ ;; this is _not_ the same as the wisent-parse stack; that leaves out
token-symbol.
+
+ sp ;; stack pointer
+
+ pending
+ ;; list of (action-symbol stack-fragment)
+ )
+
+(defun wisi-error-msg (message &rest args)
+ (let ((line (line-number-at-pos))
+ (col (- (point) (line-beginning-position))))
+ (format
+ "%s:%d:%d: %s"
+ (file-name-nondirectory (buffer-name)) ;; buffer-file-name is sometimes
nil here!?
+ line col
+ (apply 'format message args))))
+
+(defvar wisi-parse-error nil)
+(put 'wisi-parse-error
+ 'error-conditions
+ '(error wisi-parse-error))
+(put 'wisi-parse-error
+ 'error-message
+ "wisi parse error")
+
+(defvar wisi-parse-max-parallel 15
+ "Maximum number of parallel parsers for acceptable performance.
+If a file needs more than this, it's probably an indication that
+the grammar is excessively redundant.")
+
+(defun wisi-parse (automaton lexer)
+ "Parse input using the automaton specified in AUTOMATON.
+
+- AUTOMATON is the parse table generated by `wisi-compile-grammar'.
+
+- LEXER is a function with no argument called by the parser to
+ obtain the next token in input, as a list (symbol text start
+ . end), where `symbol' is the terminal symbol, `text' is the
+ token string, `start . end' is the range in the buffer."
+ (let* ((actions (aref automaton 0))
+ (gotos (aref automaton 1))
+ (parser-states ;; vector of parallel parser states
+ (vector
+ (make-wisi-parser-state
+ :label 0
+ :active 'shift
+ :stack (make-vector wisent-parse-max-stack-size nil)
+ ;; FIXME: better error message when stack overflows, so
+ ;; user can set wisent-parse-max-stack-size in file-local
+ ;; vars.
+ :sp 0
+ :pending nil)))
+ (active-parser-count 1)
+ active-parser-count-prev
+ (active 'shift)
+ (token (funcall lexer))
+ some-pending)
+
+ (aset (wisi-parser-state-stack (aref parser-states 0)) 0 0) ;; Initial
state
+
+ (while (not (eq active 'accept))
+ (setq active-parser-count-prev active-parser-count)
+ (setq some-pending nil)
+ (dotimes (parser-index (length parser-states))
+ (when (eq active (wisi-parser-state-active (aref parser-states
parser-index)))
+ (let* ((parser-state (aref parser-states parser-index))
+ (result (wisi-parse-1 token parser-state (>
active-parser-count 1) actions gotos)))
+ (when result
+ ;; spawn a new parser
+ (when (= active-parser-count wisi-parse-max-parallel)
+ (signal 'wisi-parse-error
+ (wisi-error-msg (concat "too many parallel parsers
required;"
+ " simplify grammar, or increase
`wisi-parse-max-parallel'"))))
+ (let ((j (wisi-free-parser parser-states)))
+ (cond
+ ((= j -1)
+ ;; add to parser-states; the new parser won't be executed
again in this parser-index loop
+ (setq parser-states (vconcat parser-states (vector nil)))
+ (setq j (1- (length parser-states))))
+ ((< j parser-index)
+ ;; the new parser won't be executed again in this
parser-index loop; nothing to do
+ )
+ (t
+ ;; don't let the new parser execute again in this
parser-index loop
+ (setq some-pending t)
+ (setf (wisi-parser-state-active result)
+ (cl-case (wisi-parser-state-active result)
+ (shift 'pending-shift)
+ (reduce 'pending-reduce)
+ )))
+ )
+ (setq active-parser-count (1+ active-parser-count))
+ (setf (wisi-parser-state-label result) j)
+ (aset parser-states j result))
+ (when (> wisi-debug 1) (message "spawn parser (%d active)"
active-parser-count)))
+
+ (when (eq 'error (wisi-parser-state-active parser-state))
+ (setq active-parser-count (1- active-parser-count))
+ (when (> wisi-debug 1) (message "terminate parser (%d active)"
active-parser-count))
+ (cl-case active-parser-count
+ (0
+ (cond
+ ((= active-parser-count-prev 1)
+ ;; we were not in a parallel parse; report the error
+ (let ((state (aref (wisi-parser-state-stack parser-state)
(wisi-parser-state-sp parser-state))))
+ (signal 'wisi-parse-error
+ (wisi-error-msg "syntax error in grammar state %d;
unexpected %s, expecting one of %s"
+ state
+ (nth 1 token)
+ (mapcar 'car (aref actions
state))))
+ ))
+ (t
+ ;; report errors from all parsers that failed on this token
+ (let ((msg))
+ (dotimes (index (length parser-states))
+ (let* ((parser-state (aref parser-states parser-index))
+ (state (aref (wisi-parser-state-stack
parser-state)
+ (wisi-parser-state-sp
parser-state))))
+ (when (eq 'error (wisi-parser-state-active
parser-state))
+ (setq msg
+ (concat msg
+ (when msg "\n")
+ (wisi-error-msg
+ "syntax error in grammar state %d;
unexpected %s, expecting one of %s"
+ state
+ (nth 1 token)
+ (mapcar 'car (aref actions state)))))
+ )))
+ (signal 'wisi-parse-error msg)))
+ ))
+
+ (1
+ (setf (wisi-parser-state-active parser-state) nil); don't save
error for later
+ (wisi-execute-pending (wisi-parser-state-pending
+ (aref parser-states (wisi-active-parser
parser-states))))
+ (setf (wisi-parser-state-pending
+ (aref parser-states (wisi-active-parser parser-states)))
+ nil))
+ (t
+ ;; we were in a parallel parse, and this parser
+ ;; failed; mark it inactive, don't save error for
+ ;; later
+ (setf (wisi-parser-state-active parser-state) nil)
+ )))
+ )));; end dotimes
+
+ (when some-pending
+ ;; change pending-* parsers to *
+ (dotimes (parser-index (length parser-states))
+ (cond
+ ((eq (wisi-parser-state-active (aref parser-states parser-index))
'pending-shift)
+ (setf (wisi-parser-state-active (aref parser-states parser-index))
'shift))
+ ((eq (wisi-parser-state-active (aref parser-states parser-index))
'pending-reduce)
+ (setf (wisi-parser-state-active (aref parser-states parser-index))
'reduce))
+ )))
+
+ (setq active (wisi-parsers-active parser-states active-parser-count))
+ (when (eq active 'shift)
+ (when (> active-parser-count 1)
+ (setq active-parser-count (wisi-parse-elim-identical parser-states
active-parser-count)))
+ (setq token (funcall lexer)))
+ )
+ (when (> active-parser-count 1)
+ (error "ambiguous parse result"))))
+
+(defun wisi-parsers-active (parser-states active-count)
+ "Return the type of parser cycle to execute.
+PARSER-STATES[*].active is the last action a parser took. If it
+was 'shift, that parser used the input token, and should not be
+executed again until another input token is available, after all
+parsers have shifted the current token or terminated.
+
+'accept : all PARSER-STATES have active set to nil or 'accept -
+done parsing
+
+'shift : all PARSER-STATES have active set to nil, 'accept, or
+'shift - get a new token, execute 'shift parsers.
+
+'reduce : some PARSER-STATES have active set to 'reduce - no new
+token, execute 'reduce parsers."
+ (let ((result nil)
+ (i 0)
+ (shift-count 0)
+ (accept-count 0)
+ active)
+ (while (and (not result)
+ (< i (length parser-states)))
+ (setq active (wisi-parser-state-active (aref parser-states i)))
+ (cond
+ ((eq active 'shift) (setq shift-count (1+ shift-count)))
+ ((eq active 'reduce) (setq result 'reduce))
+ ((eq active 'accept) (setq accept-count (1+ accept-count)))
+ )
+ (setq i (1+ i)))
+
+ (cond
+ (result )
+ ((= accept-count active-count)
+ 'accept)
+ ((= (+ shift-count accept-count) active-count)
+ 'shift)
+ (t (error "unexpected result in wisi-parsers-active"))
+ )))
+
+(defun wisi-free-parser (parser-states)
+ "Return index to a non-active parser in PARSER-STATES, -1 if there is none."
+ (let ((result nil)
+ (i 0))
+ (while (and (not result)
+ (< i (length parser-states)))
+ (when (not (wisi-parser-state-active (aref parser-states i)))
+ (setq result i))
+ (setq i (1+ i)))
+ (if result result -1)))
+
+(defun wisi-active-parser (parser-states)
+ "Return index to the first active parser in PARSER-STATES."
+ (let ((result nil)
+ (i 0))
+ (while (and (not result)
+ (< i (length parser-states)))
+ (when (wisi-parser-state-active (aref parser-states i))
+ (setq result i))
+ (setq i (1+ i)))
+ (unless result
+ (error "no active parsers"))
+ result))
+
+(defun wisi-parse-elim-identical (parser-states active-parser-count)
+ "Check for parsers in PARSER-STATES that have reached identical states
eliminate one.
+Return new ACTIVE-PARSER-COUNT. Assumes all parsers have active
+nil, 'shift, or 'accept."
+ ;; parser-states passed by reference; active-parser-count by copy
+ ;; see test/ada_mode-slices.adb for example
+ (dotimes (parser-i (1- (length parser-states)))
+ (when (wisi-parser-state-active (aref parser-states parser-i))
+ (dotimes (parser-j (- (length parser-states) parser-i 1))
+ (when (wisi-parser-state-active (aref parser-states (+ parser-i
parser-j 1)))
+ (when (eq (wisi-parser-state-sp (aref parser-states parser-i))
+ (wisi-parser-state-sp (aref parser-states (+ parser-i
parser-j 1))))
+ (let ((compare t))
+ (dotimes (stack-i (wisi-parser-state-sp (aref parser-states
parser-i)))
+ (setq
+ compare
+ (and compare
+ (equal (aref (wisi-parser-state-stack (aref parser-states
parser-i)) stack-i)
+ (aref (wisi-parser-state-stack (aref parser-states
(+ parser-i parser-j 1))) stack-i)))))
+ (when compare
+ ;; parser stacks are identical
+ (setq active-parser-count (1- active-parser-count))
+ (when (> wisi-debug 1)
+ (message "terminate identical parser %d (%d active)"
+ (+ parser-i parser-j 1) active-parser-count))
+ (when (= active-parser-count 1)
+ ;; the actions for the two parsers are not
+ ;; identical, but either is good enough for
+ ;; indentation and navigation, so we just do one.
+ (when (> wisi-debug 1) (message "executing actions for %d" (+
parser-i parser-j 1)))
+ (wisi-execute-pending (wisi-parser-state-pending (aref
parser-states (+ parser-i parser-j 1))))
+ (setf (wisi-parser-state-pending (aref parser-states (+
parser-i parser-j 1))) nil)
+
+ ;; clear pending of other parser so it can be reused
+ (setf (wisi-parser-state-pending (aref parser-states
parser-i)) nil))
+
+ (setf (wisi-parser-state-active (aref parser-states (+ parser-i
parser-j 1))) nil))
+ )))
+ )))
+ active-parser-count)
+
+(defun wisi-execute-pending (pending)
+ (while pending
+ (when (> wisi-debug 1) (message "%s" (car pending)))
+ (apply (pop pending))))
+
+(defun wisi-parse-1 (token parser-state pendingp actions gotos)
+ "Perform one shift or reduce on PARSER-STATE.
+If PENDINGP, push actions onto PARSER-STATE.pending; otherwise execute them.
+See `wisi-parse' for full details.
+Return nil or new parser (a wisi-parse-state struct)."
+ (let* ((state (aref (wisi-parser-state-stack parser-state)
+ (wisi-parser-state-sp parser-state)))
+ (parse-action (wisent-parse-action (car token) (aref actions state)))
+ new-parser-state)
+
+ (when (> wisi-debug 1)
+ ;; output trace info
+ (if (> wisi-debug 2)
+ (progn
+ ;; put top 10 stack items
+ (let* ((count (min 20 (wisi-parser-state-sp parser-state)))
+ (msg (make-vector (+ 1 count) nil)))
+ (dotimes (i count)
+ (aset msg (- count i)
+ (aref (wisi-parser-state-stack parser-state) (-
(wisi-parser-state-sp parser-state) i)))
+ )
+ (message "%d: %s: %d: %s"
+ (wisi-parser-state-label parser-state)
+ (wisi-parser-state-active parser-state)
+ (wisi-parser-state-sp parser-state)
+ msg))
+ (message " %d: %s: %s" state token parse-action))
+ (message "%d: %d: %s: %s" (wisi-parser-state-label parser-state) state
token parse-action)))
+
+ (when (and (listp parse-action)
+ (not (symbolp (car parse-action))))
+ ;; Conflict; spawn a new parser.
+ (setq new-parser-state
+ (make-wisi-parser-state
+ :active nil
+ :stack (vconcat (wisi-parser-state-stack parser-state))
+ :sp (wisi-parser-state-sp parser-state)
+ :pending (wisi-parser-state-pending parser-state)))
+
+ (wisi-parse-2 (cadr parse-action) token new-parser-state t gotos)
+ (setq pendingp t)
+ (setq parse-action (car parse-action))
+ );; when
+
+ ;; current parser
+ (wisi-parse-2 parse-action token parser-state pendingp gotos)
+
+ new-parser-state))
+
+(defun wisi-parse-2 (action token parser-state pendingp gotos)
+ "Execute parser ACTION (must not be a conflict).
+Return nil."
+ (cond
+ ((eq action 'accept)
+ (setf (wisi-parser-state-active parser-state) 'accept))
+
+ ((eq action 'error)
+ (setf (wisi-parser-state-active parser-state) 'error))
+
+ ((natnump action)
+ ;; Shift token and new state (= action) onto stack
+ (let ((stack (wisi-parser-state-stack parser-state)); reference
+ (sp (wisi-parser-state-sp parser-state))); copy
+ (setq sp (+ sp 2))
+ (aset stack (1- sp) token)
+ (aset stack sp action)
+ (setf (wisi-parser-state-sp parser-state) sp))
+ (setf (wisi-parser-state-active parser-state) 'shift))
+
+ (t
+ (wisi-parse-reduce action parser-state pendingp gotos)
+ (setf (wisi-parser-state-active parser-state) 'reduce))
+ ))
+
+(defun wisi-nonterm-bounds (stack i j)
+ "Return a pair (START . END), the buffer region for a nonterminal.
+STACK is the parser stack. I and J are the indices in STACK of
+the first and last tokens of the nonterminal."
+ (let ((start (cl-caddr (aref stack i)))
+ (end (cl-cdddr (aref stack j))))
+ (while (and (or (not start) (not end))
+ (/= i j))
+ (cond
+ ((not start)
+ ;; item i is an empty production
+ (setq start (cl-caddr (aref stack (setq i (+ i 2))))))
+
+ ((not end)
+ ;; item j is an empty production
+ (setq end (cl-cdddr (aref stack (setq j (- j 2))))))
+
+ (t (setq i j))))
+ (and start end (cons start end))))
+
+(defun wisi-parse-reduce (action parser-state pendingp gotos)
+ "Reduce PARSER-STATE.stack, and execute or pend ACTION."
+ (let* ((stack (wisi-parser-state-stack parser-state)); reference
+ (sp (wisi-parser-state-sp parser-state)); copy
+ (token-count (or (nth 2 action) 0))
+ (nonterm (nth 0 action))
+ (nonterm-region (when (> token-count 0)
+ (wisi-nonterm-bounds stack (- sp (* 2 (1-
token-count)) 1) (1- sp))))
+ (post-reduce-state (aref stack (- sp (* 2 token-count))))
+ (new-state (cdr (assoc nonterm (aref gotos post-reduce-state))))
+ tokens)
+ (when (not new-state)
+ (error "no goto for %s %d" nonterm post-reduce-state))
+ (if (= 1 token-count)
+ (setq tokens (list (aref stack (1- sp))))
+ (dotimes (i token-count)
+ (push (aref stack (- sp (* 2 i) 1)) tokens)))
+ (setq sp (+ 2 (- sp (* 2 token-count))))
+ (aset stack (1- sp) (cons nonterm (cons nil nonterm-region)))
+ (aset stack sp new-state)
+ (setf (wisi-parser-state-sp parser-state) sp)
+ (if pendingp
+ (if (wisi-parser-state-pending parser-state)
+ (setf (wisi-parser-state-pending parser-state)
+ (append (wisi-parser-state-pending parser-state)
+ (list (list (nth 1 action) tokens))))
+ (setf (wisi-parser-state-pending parser-state)
+ (list (list (nth 1 action) tokens))))
+ (funcall (nth 1 action) tokens))
+ ))
+
+(provide 'wisi-parse)
+;; end of file
diff --git a/wisi.el b/wisi.el
new file mode 100755
index 0000000..e12ce8f
--- /dev/null
+++ b/wisi.el
@@ -0,0 +1,1112 @@
+;;; wisi.el --- Utilities for implementing an indentation/navigation engine
using a generalized LALR parser
+;;
+;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@member.fsf.org>
+;; Version: 1.0
+;; url: http://stephe-leake.org/emacs/ada-mode/emacs-ada-mode.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/>.
+;;
+;;; History: first experimental version Oct 2012
+;;
+;;; indentation algorithm overview
+;;
+;; This design is inspired in part by experience writing a SMIE
+;; indentation engine for Ada, and the wisent parser.
+;;
+;; The general approach to indenting a given token is to find the
+;; start of the statement it is part of, or some other relevant point
+;; in the statement, and indent relative to that. So we need a parser
+;; that lets us find statement indent points from arbitrary places in
+;; the code.
+;;
+;; The grammar for Ada as represented by the EBNF in LRM Annex P is
+;; not LALR(1), so we use a generalized LALR(1) parser (see
+;; wisi-parse, wisi-compile).
+;;
+;; The parser actions cache indentation and other information as text
+;; properties of tokens in statements.
+;;
+;; An indentation engine moves text in the buffer, as does user
+;; editing, so we can't rely on character positions remaining
+;; constant. So the parser actions use markers to store
+;; positions. Text properties also move with the text.
+;;
+;; The stored information includes a marker at each statement indent
+;; point. Thus, the indentation algorithm is: find the previous token
+;; with cached information, and either indent from it, or fetch from
+;; it the marker for a previous statement indent point, and indent
+;; relative to that.
+;;
+;; Since we have a cache (the text properties), we need to consider
+;; when to invalidate it. Ideally, we invalidate only when a change to
+;; the buffer would change the result of a parse that crosses that
+;; change, or starts after that change. Changes in whitespace
+;; (indentation and newlines) do not affect an Ada parse. Other
+;; languages are sensitive to newlines (Bash for example) or
+;; indentation (Python). Adding comments does not change a parse,
+;; unless code is commented out. For now we invalidate the cache after
+;; the edit point if the change involves anything other than
+;; whitespace.
+;;
+;;; comparison to the SMIE parser
+;;
+;; The central problem to be solved in building the SMIE parser is
+;; grammar precedence conflicts; the general solution is refining
+;; keywords so that each new keyword can be assigned a unique
+;; precedence. This means ad hoc code must be written to determine the
+;; correct refinement for each language keyword from the surrounding
+;; tokens. In effect, for a complex language like Ada, the knowledge
+;; of the language grammar is mostly embedded in the refinement code;
+;; only a small amount is in the refined grammar. Implementing a SMIE
+;; parser for a new language involves the same amount of work as the
+;; first language.
+;;
+;; Using a generalized LALR parser avoids that particular problem;
+;; assuming the language is already defined by a grammar, it is only a
+;; matter of a format change to teach the wisi parser the
+;; language. The problem in a wisi indentation engine is caching the
+;; output of the parser in a useful way, since we can't start the
+;; parser from arbitrary places in the code (as we can with the SMIE
+;; parser). A second problem is determining when to invalidate the
+;; cache. But these problems are independent of the language being
+;; parsed, so once we have one wisi indentation engine working,
+;; adapting it to new languages should be quite simple.
+;;
+;; The SMIE parser does not find the start of each statement, only the
+;; first language keyword in each statement; additional code must be
+;; written to find the statement start and indent points. The wisi
+;; parser finds the statement start and indent points directly.
+;;
+;; In SMIE, it is best if each grammar rule is a complete statement,
+;; so forward-sexp will traverse the entire statement. If nested
+;; non-terminals are used, forward-sexp may stop inside one of the
+;; nested non-terminals. This problem does not occur with the wisi
+;; parser.
+;;
+;; A downside of the wisi parser is conflicts in the grammar; they can
+;; be much more difficult to resolve than in the SMIE parser. The
+;; generalized parser helps by handling conflicts, but it does so by
+;; running multiple parsers in parallel, persuing each choice in the
+;; conflict. If the conflict is due to a genuine ambiguity, both paths
+;; will succeed, which causes the parse to fail, since it is not clear
+;; which set of text properties to store. Even if one branch
+;; ultimately fails, running parallel parsers over large sections of
+;; code is slow. Finally, this approach can lead to exponential growth
+;; in the number of parsers. So grammar conflicts must still be
+;; analyzed and minimized.
+;;
+;; In addition, the complete grammar must be specified; in smie, it is
+;; often possible to specify a subset of the grammar.
+;;
+;;;; grammar compiler and parser
+;;
+;; Since we are using a generalized LALR(1) parser, we cannot use any
+;; of the wisent grammar functions. We use the OpenToken Ada package
+;; to compile BNF to Elisp source (similar to
+;; semantic-grammar-create-package), and wisi-compile-grammar to
+;; compile that to the parser table.
+;;
+;; Semantic provides a complex lexer, more complicated than we need
+;; for indentation. So we use the elisp lexer, which consists of
+;; `forward-comment', `skip-syntax-forward', and `scan-sexp'. We wrap
+;; that in functions that return tokens in the form wisi-parse
+;; expects.
+;;
+;;;; code style
+;;
+;; 'wisi' was originally short for "wisent indentation engine", but
+;; now is just a name.
+;;
+;; not using lexical-binding because we support Emacs 23
+;;
+;;;;;
+
+(require 'wisi-parse)
+(eval-when-compile (require 'cl-macs))
+
+;;;; lexer
+
+(defvar-local wisi-class-list nil)
+(defvar-local wisi-keyword-table nil)
+(defvar-local wisi-punctuation-table nil)
+(defvar-local wisi-punctuation-table-max-length 0)
+(defvar-local wisi-string-double-term nil) ;; string delimited by double quotes
+(defvar-local wisi-string-quote-escape-doubled nil)
+(defvar-local wisi-string-single-term nil) ;; string delimited by single quotes
+(defvar-local wisi-symbol-term nil)
+
+(defun wisi-forward-token (&optional text-only)
+ "Move point forward across one token, skipping leading whitespace and
comments.
+Return the corresponding token, in a format determined by TEXT-ONLY:
+TEXT-ONLY t: text
+TEXT-ONLY nil: (token text start . end)
+where:
+`token' is a token symbol (not string) from `wisi-punctuation-table',
+`wisi-keyword-table', `wisi-string-double-term', `wisi-string-double-term' or
`wisi-symbol-term'.
+
+`text' is the token text from the buffer
+
+`start, end' are the character positions in the buffer of the start
+and end of the token text.
+
+If at end of buffer, returns `wisent-eoi-term'."
+ (forward-comment (point-max))
+ ;; skips leading whitespace, comment, trailing whitespace.
+
+ (let ((start (point))
+ ;; (info "(elisp)Syntax Table Internals" "*info elisp syntax*")
+ (syntax (syntax-class (syntax-after (point))))
+ token-id token-text)
+ (cond
+ ((eobp)
+ (setq token-text "")
+ (setq token-id wisent-eoi-term))
+
+ ((eq syntax 1)
+ ;; punctuation. Find the longest matching string in
wisi-punctuation-table
+ (forward-char 1)
+ (let ((next-point (point))
+ temp-text temp-id done)
+ (while (not done)
+ (setq temp-text (buffer-substring-no-properties start (point)))
+ (setq temp-id (car (rassoc temp-text wisi-punctuation-table)))
+ (when temp-id
+ (setq token-text temp-text
+ token-id temp-id
+ next-point (point)))
+ (if (or
+ (eobp)
+ (= (- (point) start) wisi-punctuation-table-max-length))
+ (setq done t)
+ (forward-char 1))
+ )
+ (goto-char next-point)))
+
+ ((memq syntax '(4 5)) ;; open, close parenthesis
+ (forward-char 1)
+ (setq token-text (buffer-substring-no-properties start (point)))
+ (setq token-id (symbol-value (intern-soft token-text
wisi-keyword-table))))
+
+ ((eq syntax 7)
+ ;; string quote, either single or double. we assume point is before the
start quote, not the end quote
+ (let ((delim (char-after (point)))
+ (forward-sexp-function nil))
+ (forward-sexp)
+ ;; point is now after the end quote; check for a doubled quote
+ (while (and wisi-string-quote-escape-doubled
+ (eq (char-after (point)) delim))
+ (forward-sexp))
+ (setq token-text (buffer-substring-no-properties start (point)))
+ (setq token-id (if (= delim ?\") wisi-string-double-term
wisi-string-single-term))))
+
+ (t ;; assuming word syntax
+ (skip-syntax-forward "w_'")
+ (setq token-text (buffer-substring-no-properties start (point)))
+ (setq token-id
+ (or (symbol-value (intern-soft (downcase token-text)
wisi-keyword-table))
+ wisi-symbol-term)))
+ );; cond
+
+ (unless token-id
+ (error (wisi-error-msg "unrecognized token '%s'"
(buffer-substring-no-properties start (point)))))
+
+ (if text-only
+ token-text
+ (cons token-id (cons token-text (cons start (point)))))
+ ))
+
+(defun wisi-backward-token ()
+ "Move point backward across one token, skipping whitespace and comments.
+Return (nil text start . end) - same structure as
+wisi-forward-token, but does not look up symbol."
+ (forward-comment (- (point)))
+ ;; skips leading whitespace, comment, trailing whitespace.
+
+ ;; (info "(elisp)Syntax Table Internals" "*info elisp syntax*")
+ (let ((end (point))
+ (syntax (syntax-class (syntax-after (1- (point))))))
+ (cond
+ ((bobp) nil)
+
+ ((memq syntax '(4 5)) ;; open, close parenthesis
+ (backward-char 1))
+
+ ((eq syntax 7)
+ ;; a string quote. we assume we are after the end quote, not the start
quote
+ (let ((forward-sexp-function nil))
+ (forward-sexp -1)))
+
+ (t
+ (if (zerop (skip-syntax-backward "."))
+ (skip-syntax-backward "w_'")))
+ )
+ (cons nil (cons (buffer-substring-no-properties (point) end) (cons (point)
end)))
+ ))
+
+;;;; token info cache
+;;
+;; the cache stores the results of parsing as text properties on
+;; keywords, for use by the indention and motion engines.
+
+(cl-defstruct
+ (wisi-cache
+ (:constructor wisi-cache-create)
+ (:copier nil))
+ nonterm;; nonterminal from parse (set by wisi-statement-action)
+
+ token
+ ;; terminal symbol from wisi-keyword-table or
+ ;; wisi-punctuation-table, or lower-level nonterminal from parse
+ ;; (set by wisi-statement-action)
+
+ last ;; pos of last char in token, relative to first (0 indexed)
+
+ class
+ ;; arbitrary lisp symbol, used for indentation and navigation.
+ ;; some classes are defined by wisi:
+ ;;
+ ;; 'block-middle - a block keyword (ie: if then else end), not at the start
of a statement
+ ;;
+ ;; 'block-start - a block keyword at the start of a statement
+ ;;
+ ;; 'statement-start - the start of a statement
+ ;;
+ ;; 'open-paren
+ ;;
+ ;; others are language-specific
+
+ containing
+ ;; Marker at the containing keyword for this token.
+ ;; A containing keyword is an indent point; the start of a
+ ;; statement, or 'begin', 'then' or 'else' for a block of
+ ;; statements, etc.
+ ;; nil only for first token in buffer
+
+ prev ;; marker at previous motion token in statement; nil if none
+ next ;; marker at next motion token in statement; nil if none
+ end ;; marker at token at end of current statement
+ )
+
+(defvar-local wisi-cache-max 0
+ "Maximimum position in buffer where wisi token cache is valid.")
+
+(defvar-local wisi-parse-table nil)
+
+(defvar-local wisi-parse-failed nil
+ "Non-nil when a recent parse has failed - cleared when parse succeeds.")
+
+(defvar-local wisi-parse-try nil
+ "Non-nil when parse is needed - cleared when parse succeeds.")
+
+(defvar-local wisi-change-need-invalidate nil)
+(defvar-local wisi-change-jit-lock-mode nil)
+
+(defun wisi-invalidate-cache()
+ "Invalidate the wisi token cache for the current buffer.
+Also invalidate the Emacs syntax cache."
+ (interactive)
+ (setq wisi-cache-max 0)
+ (setq wisi-parse-try t)
+ (syntax-ppss-flush-cache (point-min))
+ (with-silent-modifications
+ (remove-text-properties (point-min) (point-max) '(wisi-cache))))
+
+(defun wisi-before-change (begin end)
+ "For `before-change-functions'."
+ ;; begin . end is range of text being deleted
+
+ ;; If jit-lock-after-change is before wisi-after-change in
+ ;; after-change-functions, it might use any invalid caches in the
+ ;; inserted text.
+ ;;
+ ;; So we check for that here, and ensure it is after
+ ;; wisi-after-change, which deletes the invalid caches
+ (when (boundp 'jit-lock-mode)
+ (when (memq 'wisi-after-change (memq 'jit-lock-after-change
after-change-functions))
+ (setq after-change-functions (delete 'wisi-after-change
after-change-functions))
+ (add-hook 'after-change-functions 'wisi-after-change nil t)
+ (setq wisi-change-jit-lock-mode (1+ wisi-change-jit-lock-mode)))
+ )
+
+ (save-excursion
+ ;; don't invalidate parse for whitespace, string, or comment changes
+ (let (;; (info "(elisp)Parser State")
+ (state (syntax-ppss begin)))
+ ;; syntax-ppss has moved point to "begin".
+ (cond
+ ((or
+ (nth 3 state); in string
+ (nth 4 state)); in comment
+ ;; FIXME: check that entire range is in comment or string
+ (setq wisi-change-need-invalidate nil))
+
+ ((progn
+ (skip-syntax-forward " " end);; does not skip newline
+ (eq (point) end))
+ (setq wisi-change-need-invalidate nil))
+
+ (t (setq wisi-change-need-invalidate t))
+ ))))
+
+(defun wisi-after-change (begin end length)
+ "For `after-change-functions'."
+ ;; begin . end is range of text being inserted (may be empty)
+ ;; (syntax-ppss-flush-cache begin) is in before-change-functions
+
+ (syntax-ppss-flush-cache begin) ;; IMPROVEME: could check for whitespace
+
+ (cond
+ (wisi-parse-failed
+ ;; The parse was failing, probably due to bad syntax; this change
+ ;; may have fixed it, so try reparse.
+ (setq wisi-parse-try t)
+
+ ;; remove 'wisi-cache on inserted text, which could have caches
+ ;; from before the failed parse, and are in any case invalid.
+ (with-silent-modifications
+ (remove-text-properties begin end '(wisi-cache)))
+ )
+
+ ((>= wisi-cache-max begin)
+ ;; The parse had succeeded paste the start of the inserted
+ ;; text.
+ (save-excursion
+ (let ((need-invalidate t)
+ ;; (info "(elisp)Parser State")
+ (state (syntax-ppss begin)))
+ ;; syntax-ppss has moved point to "begin".
+ (cond
+ (wisi-change-need-invalidate
+ ;; wisi-before change determined the removed text alters the
+ ;; parse
+ nil)
+
+ ((or
+ (nth 3 state); in string
+ (nth 4 state)); in comment
+ ;; FIXME: insert newline in comment to create non-comment!?
+ ;; or paste a chunk of code
+ ;; => check that all of change region is comment or string
+ (setq need-invalidate nil))
+
+ ((progn
+ (skip-syntax-forward " " end);; does not skip newlines
+ (eq (point) end))
+ (setq need-invalidate nil))
+
+ (t nil)
+ )
+
+ (if need-invalidate
+ ;; The inserted or deleted text could alter the parse
+ (wisi-invalidate-cache)
+
+ ;; else move cache-max by the net change length. We don't
+ ;; need to delete 'wisi-cache in the inserted text, because
+ ;; if there were any it would not pass the above.
+ (setq wisi-cache-max
+ (+ wisi-cache-max (- end begin length))))
+ )
+ ))
+
+ (t
+ ;; parse never attempted, or only done to before BEGIN. Just
+ ;; remove 'wisi-cache
+ (with-silent-modifications
+ (remove-text-properties begin end '(wisi-cache)))
+ )
+ ))
+
+(defun wisi-get-cache (pos)
+ "Return `wisi-cache' struct from the `wisi-cache' text property at POS.
+If accessing cache at a marker for a token as set by `wisi-cache-tokens', POS
must be (1- mark)."
+ (get-text-property pos 'wisi-cache))
+
+(defvar wisi-debug 0
+ "wisi debug mode:
+0 : normal - ignore parse errors, for indenting new code
+1 : report parse errors (for running tests)
+2 : show parse states, position point at parse errors, debug-on-error works in
parser
+3 : also show top 10 items of parser stack.")
+
+(defvar-local wisi-parse-error-msg nil)
+
+(defun wisi-goto-error ()
+ "Move point to position in last error message (if any)."
+ (when (string-match ":\\([0-9]+\\):\\([0-9]+\\):" wisi-parse-error-msg)
+ (let ((line (string-to-number (match-string 1 wisi-parse-error-msg)))
+ (col (string-to-number (match-string 2 wisi-parse-error-msg))))
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (forward-char col))))
+
+(defun wisi-show-parse-error ()
+ "Show last wisi-parse error."
+ (interactive)
+ (if wisi-parse-failed
+ (progn
+ (message wisi-parse-error-msg)
+ (wisi-goto-error))
+ (message "parse succeeded")))
+
+(defun wisi-validate-cache (pos)
+ "Ensure cached data is valid at least up to POS in current buffer."
+ (when (and wisi-parse-try
+ (< wisi-cache-max pos))
+ (when (> wisi-debug 0)
+ (message "wisi: parsing ..."))
+
+ (setq wisi-parse-try nil)
+ (setq wisi-parse-error-msg nil)
+ (save-excursion
+ (goto-char wisi-cache-max)
+ (if (> wisi-debug 1)
+ ;; let debugger stop in wisi-parse
+ (progn
+ (wisi-parse wisi-parse-table 'wisi-forward-token)
+ (setq wisi-cache-max (point))
+ (setq wisi-parse-failed nil))
+ ;; else capture errors from bad syntax, so higher level functions can
try to continue
+ (condition-case err
+ (progn
+ (wisi-parse wisi-parse-table 'wisi-forward-token)
+ (setq wisi-cache-max (point))
+ (setq wisi-parse-failed nil))
+ (wisi-parse-error
+ (setq wisi-parse-failed t)
+ (setq wisi-parse-error-msg (cdr err)))
+ )))
+ (if wisi-parse-error-msg
+ ;; error
+ (when (> wisi-debug 0)
+ (message "wisi: parsing ... error")
+ (wisi-goto-error)
+ (error wisi-parse-error-msg))
+ ;; no msg; success
+ (when (> wisi-debug 0)
+ (message "wisi: parsing ... done")))
+ ))
+
+(defun wisi-get-containing-cache (cache)
+ "Return cache from (wisi-cache-containing CACHE)."
+ (let ((containing (wisi-cache-containing cache)))
+ (and containing
+ (wisi-get-cache (1- 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))))
+
+;;;; parse actions
+
+(defun wisi-set-end (tokens end-mark)
+ "Set END-MARK on all unset caches in TOKENS."
+ (let ((tokens-t tokens))
+ (while tokens-t
+ (let* ((token (pop tokens-t))
+ (region (cddr token))
+ cache)
+ (when region
+ (goto-char (car region))
+ (setq cache (wisi-get-cache (car region)))
+ (while (and cache
+ (< (point) (cdr region)))
+ (if (not (wisi-cache-end cache))
+ (setf (wisi-cache-end cache) end-mark)
+ (goto-char (wisi-cache-end cache))
+ )
+ (setq cache (wisi-forward-cache))
+ ))
+ ))
+ ))
+
+(defvar wisi-tokens nil);; keep byte-compiler happy; `wisi-tokens' is bound in
action created by wisi-semantic-action
+(defun wisi-statement-action (&rest pairs)
+ "Cache information in text properties of tokens.
+Intended as a grammar non-terminal action.
+
+PAIRS is of the form [TOKEN-NUMBER CLASS] ... where TOKEN-NUMBER
+is the (1 indexed) token number in the production, CLASS is the wisi class of
+that token. Use in a grammar action as:
+ (wisi-statement-action 1 'statement-start 7 'statement-end)"
+ (save-excursion
+ (let ((first-item t)
+ first-keyword-mark
+ (override-start nil))
+ (while pairs
+ (let* ((number (1- (pop pairs)))
+ (region (cddr (nth number wisi-tokens)));; wisi-tokens is
let-bound in wisi-parse-reduce
+ (token (car (nth number wisi-tokens)))
+ (class (pop pairs))
+ (mark
+ ;; Marker one char into token, so indent-line-to
+ ;; inserts space before the mark, not after
+ (when region (copy-marker (1+ (car region)))))
+ cache)
+
+ (unless (memq class wisi-class-list)
+ (error "%s not in wisi-class-list" class))
+
+ (if region
+ (progn
+ (if (setq cache (wisi-get-cache (car region)))
+ ;; We are processing a previously set non-terminal; ie
generic_formal_part in
+ ;;
+ ;; generic_package_declaration : generic_formal_part
package_specification SEMICOLON
+ ;; (wisi-statement-action 1 'block-start 2 'block-middle
3 'statement-end)
+ ;;
+ ;; or simple_statement in
+ ;;
+ ;; statement : label_opt simple_statement
+ ;;
+ ;; override nonterm, class and containing
+ (progn
+ (cl-case (wisi-cache-class cache)
+ (block-start
+ (setf (wisi-cache-class cache)
+ (cond
+ ((eq override-start nil)
+ (cond
+ ((memq class '(block-start statement-start))
'block-start)
+ (t 'block-middle)))
+
+ ((memq override-start '(block-start
statement-start)) 'block-start)
+
+ (t (error "unexpected override-start"))
+ )))
+ (t
+ (setf (wisi-cache-class cache) (or override-start
class)))
+ )
+ (setf (wisi-cache-nonterm cache) $nterm)
+ (setf (wisi-cache-containing cache) first-keyword-mark))
+
+ ;; else create new cache
+ (with-silent-modifications
+ (put-text-property
+ (car region)
+ (1+ (car region))
+ 'wisi-cache
+ (wisi-cache-create
+ :nonterm $nterm;; $nterm defined in wisi-semantic-action
+ :token token
+ :last (- (cdr region) (car region))
+ :class (or override-start class)
+ :containing first-keyword-mark)
+ )))
+
+ (when first-item
+ (setq first-item nil)
+ (when (or override-start
+ (memq class '(block-middle block-start
statement-start)))
+ (setq override-start nil)
+ (setq first-keyword-mark mark)))
+
+ (when (eq class 'statement-end)
+ (wisi-set-end wisi-tokens (copy-marker (1+ (car region)))))
+ )
+
+ ;; region is nil when a production is empty; if the first
+ ;; token is a start, override the class on the next token.
+ (when (and first-item
+ (memq class '(block-middle block-start statement-start)))
+ (setq override-start class)))
+ ))
+ )))
+
+(defun wisi-containing-action (containing-token contained-token)
+ "Set containing marks in all tokens in CONTAINED-TOKEN with null containing
mark to marker pointing to CONTAINING-TOKEN.
+If CONTAINING-TOKEN is empty, the next token number is used."
+ ;; wisi-tokens is is bound in action created by wisi-semantic-action
+ (let* ((containing-region (cddr (nth (1- containing-token) wisi-tokens)))
+ (contained-region (cddr (nth (1- contained-token) wisi-tokens))))
+ (while (not containing-region)
+ ;; containing-token is empty; use next
+ (setq containing-region (cddr (nth containing-token wisi-tokens))))
+
+ (when contained-region
+ ;; nil when empty production, may not contain any caches
+ (save-excursion
+ (goto-char (cdr contained-region))
+ (let ((cache (wisi-backward-cache))
+ (mark (copy-marker (1+ (car containing-region)))))
+ (while cache
+
+ ;; skip blocks that are already marked
+ (while (and (>= (point) (car contained-region))
+ (markerp (wisi-cache-containing cache)))
+ (goto-char (1- (wisi-cache-containing cache)))
+ (setq cache (wisi-get-cache (point))))
+
+ (if (or (and (= (car containing-region) (car contained-region))
+ (<= (point) (car contained-region)))
+ (< (point) (car contained-region)))
+ ;; done
+ (setq cache nil)
+
+ ;; else set mark, loop
+ (setf (wisi-cache-containing cache) mark)
+ (setq cache (wisi-backward-cache)))
+ ))))))
+
+(defun wisi-motion-action (&rest token-numbers)
+ "Set prev/next marks in all tokens given by TOKEN-NUMBERS.
+Each TOKEN-NUMBERS is one of:
+
+number: the token number; mark that token
+
+list (number token_id):
+list (number (token_id token_id)):
+ mark all tokens with token_id in the nonterminal given by the number."
+ (save-excursion
+ (let (next-keyword-mark
+ prev-keyword-mark
+ prev-cache
+ cache
+ mark)
+ (while token-numbers
+ (let ((token-number (pop token-numbers))
+ target-token
+ region)
+ (cond
+ ((numberp token-number)
+ (setq target-token nil)
+ (setq region (cddr (nth (1- token-number) wisi-tokens)))
+ (when region
+ (setq cache (wisi-get-cache (car region)))
+ (setq mark (copy-marker (1+ (car region))))
+
+ (when (and prev-keyword-mark
+ cache
+ (null (wisi-cache-prev cache)))
+ (setf (wisi-cache-prev cache) prev-keyword-mark)
+ (setf (wisi-cache-next prev-cache) mark))
+
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache)
+ ))
+
+ ((listp token-number)
+ ;; token-number may contain 0, 1, or more token_id; token_id may be
a list
+ ;; the corresponding region may be empty
+ ;; there must have been a prev keyword
+ (setq target-token (cadr token-number))
+ (when (not (listp target-token))
+ (setq target-token (list target-token)))
+ (setq token-number (car token-number))
+ (setq region (cddr (nth (1- token-number) wisi-tokens)))
+ (when region ;; not an empty token
+ (goto-char (car region))
+ (while (wisi-forward-find-token target-token (cdr region) t)
+ (setq cache (wisi-get-cache (point)))
+ (setq mark (copy-marker (1+ (point))))
+
+ (when (null (wisi-cache-prev cache))
+ (setf (wisi-cache-prev cache) prev-keyword-mark)
+ (setf (wisi-cache-next prev-cache) mark)
+ (setq prev-keyword-mark mark)
+ (setq prev-cache cache))
+
+ (wisi-forward-token);; don't find same token again
+ ))
+ )
+
+ (t
+ (error "unexpected token-number %s" token-number))
+ )
+
+ ))
+ )))
+
+;;;; motion
+(defun wisi-backward-cache ()
+ "Move point backward to the beginning of the first token preceding point
that has a cache.
+Returns cache, or nil if at beginning of buffer."
+ (let (cache pos)
+ (setq pos (previous-single-property-change (point) 'wisi-cache))
+ ;; There are three cases:
+ ;;
+ ;; 1) caches separated by non-cache chars: 'if ... then'
+ ;; pos is before 'f', cache is on 'i'
+ ;;
+ ;; 2) caches not separated: ');'
+ ;; pos is before ';', cache is on ';'
+ ;;
+ ;; 3) at bob; pos is nil
+ ;;
+ (if pos
+ (progn
+ (setq cache (get-text-property pos 'wisi-cache))
+ (if cache
+ ;; case 2
+ (goto-char pos)
+ ;; case 1
+ (setq cache (get-text-property (1- pos) 'wisi-cache))
+ (goto-char (1- pos))))
+ ;; at bob
+ (goto-char (point-min))
+ (setq cache nil))
+ cache
+ ))
+
+(defun wisi-forward-cache ()
+ "Move point forward to the beginning of the first token after point that has
a cache.
+Returns cache, or nil if at end of buffer."
+ (let (cache pos)
+ (when (get-text-property (point) 'wisi-cache)
+ ;; on a cache; get past it
+ (goto-char (1+ (point))))
+
+ (setq cache (get-text-property (point) 'wisi-cache))
+ (if cache
+ nil
+
+ (setq pos (next-single-property-change (point) 'wisi-cache))
+ (if pos
+ (progn
+ (goto-char pos)
+ (setq cache (get-text-property pos 'wisi-cache)))
+ ;; at eob
+ (goto-char (point-max))
+ (setq cache nil))
+ )
+ cache
+ ))
+
+(defun wisi-forward-find-class (class limit)
+ "Search forward for a token that has a cache with CLASS.
+Return cache, or nil if at end of buffer.
+If LIMIT (a buffer position) is reached, throw an error."
+ (let ((cache (wisi-forward-cache)))
+ (while (not (eq class (wisi-cache-class cache)))
+ (setq cache (wisi-forward-cache))
+ (when (>= (point) limit)
+ (error "cache with class %s not found" class)))
+ cache))
+
+(defun wisi-forward-find-token (token limit &optional noerror)
+ "Search forward for a token that has a cache with TOKEN.
+If point is at a matching token, return that token.
+TOKEN may be a list; stop on any cache that has a member of the list.
+Return cache, or nil if at end of buffer.
+If LIMIT (a buffer position) is reached, then if NOERROR is nil, throw an
+error, if non-nil, return nil."
+ (let ((token-list (cond
+ ((listp token) token)
+ (t (list token))))
+ (cache (wisi-get-cache (point)))
+ (done nil))
+ (while (not (or done
+ (and cache
+ (memq (wisi-cache-token cache) token-list))))
+ (setq cache (wisi-forward-cache))
+ (when (>= (point) limit)
+ (if noerror
+ (progn
+ (setq done t)
+ (setq cache nil))
+ (error "cache with token %s not found" token))))
+ cache))
+
+(defun wisi-forward-find-nonterm (nonterm limit)
+ "Search forward for a token that has a cache with NONTERM.
+NONTERM may be a list; stop on any cache that has a member of the list.
+Return cache, or nil if at end of buffer.
+If LIMIT (a buffer position) is reached, throw an error."
+ (let ((nonterm-list (cond
+ ((listp nonterm) nonterm)
+ (t (list nonterm))))
+ (cache (wisi-forward-cache)))
+ (while (not (memq (wisi-cache-nonterm cache) nonterm-list))
+ (setq cache (wisi-forward-cache))
+ (when (>= (point) limit)
+ (error "cache with nonterm %s not found" nonterm)))
+ cache))
+
+(defun wisi-goto-cache-next (cache)
+ (goto-char (1- (wisi-cache-next cache)))
+ (wisi-get-cache (point))
+ )
+
+(defun wisi-forward-statement-keyword ()
+ "If not at a cached token, move forward to next
+cache. Otherwise move to cache-next, or next cache if nil.
+Return cache found."
+ (wisi-validate-cache (point-max))
+ (let ((cache (wisi-get-cache (point))))
+ (if cache
+ (let ((next (wisi-cache-next cache)))
+ (if next
+ (goto-char (1- next))
+ (wisi-forward-token)
+ (wisi-forward-cache)))
+ (wisi-forward-cache))
+ )
+ (wisi-get-cache (point))
+ )
+
+(defun wisi-backward-statement-keyword ()
+ "If not at a cached token, move backward to prev
+cache. Otherwise move to cache-prev, or prev cache if nil."
+ (wisi-validate-cache (point-max))
+ (let ((cache (wisi-get-cache (point))))
+ (if cache
+ (let ((prev (wisi-cache-prev cache)))
+ (if prev
+ (goto-char (1- prev))
+ (wisi-backward-cache)))
+ (wisi-backward-cache))
+ ))
+
+(defun wisi-goto-containing (cache &optional error)
+ "Move point to containing token for CACHE, return cache at that point."
+ (cond
+ ((markerp (wisi-cache-containing cache))
+ (goto-char (1- (wisi-cache-containing cache)))
+ (wisi-get-cache (point)))
+ (t
+ (when error
+ (error "already at outermost containing token")))
+ ))
+
+(defun wisi-goto-containing-paren (cache)
+ "Move point to just after the open-paren containing CACHE.
+Return cache for paren, or nil if no containing paren."
+ (while (and cache
+ (not (eq (wisi-cache-class cache) 'open-paren)))
+ (setq cache (wisi-goto-containing cache)))
+ (when cache
+ (forward-char 1))
+ cache)
+
+(defun wisi-goto-start (cache)
+ "Move point to containing ancestor of CACHE that has class block-start or
statement-start.
+Return start cache."
+ (when
+ ;; cache nil at bob
+ (while (and cache
+ (not (memq (wisi-cache-class cache) '(block-start
statement-start))))
+ (setq cache (wisi-goto-containing cache)))
+ )
+ cache)
+
+(defun wisi-goto-end ()
+ "Move point to token at end of statement point is in or before."
+ (interactive)
+ (wisi-validate-cache (point-max))
+ (let ((cache (or (wisi-get-cache (point))
+ (wisi-forward-cache))))
+ (when (wisi-cache-end cache)
+ ;; nil when cache is statement-end
+ (goto-char (1- (wisi-cache-end cache))))
+ ))
+
+(defun wisi-next-statement-cache (cache)
+ "Move point to CACHE-next, return cache; error if nil."
+ (when (not (markerp (wisi-cache-next cache)))
+ (error "no next statement cache"))
+ (goto-char (1- (wisi-cache-next cache)))
+ (wisi-get-cache (point)))
+
+(defun wisi-prev-statement-cache (cache)
+ "Move point to CACHE-next, return cache; error if nil."
+ (when (not (markerp (wisi-cache-prev cache)))
+ (error "no prev statement cache"))
+ (goto-char (1- (wisi-cache-prev cache)))
+ (wisi-get-cache (point)))
+
+;;;; indentation
+
+(defun wisi-comment-indent ()
+ "For `comment-indent-function'. Indent single line comment to
+the comment on the previous line."
+ ;; This should only be called by comment-indent-new-line or
+ ;; fill-comment-paragraph, so there will be a preceding comment line
+ ;; that we can trust.
+ (save-excursion
+ (forward-comment -1)
+ (if (looking-at comment-start)
+ (current-column)
+ (error "wisi-comment-indent called after non-comment"))))
+
+(defun wisi-indent-current (offset)
+ "Return indentation OFFSET relative to indentation of current line."
+ (+ (current-indentation) offset)
+ )
+
+(defun wisi-indent-paren (offset)
+ "Return indentation OFFSET relative to preceding open paren."
+ (save-excursion
+ (ada-goto-open-paren 0)
+ (+ (current-column) offset)))
+
+(defun wisi-indent-start (offset cache)
+ "Return indentation of OFFSET relative to containing ancestor
+of CACHE with class statement-start or block-start."
+ (wisi-goto-start cache)
+ (+ (current-indentation) offset))
+
+(defun wisi-indent-statement ()
+ "Indent region given by `wisi-goto-start' on cache at or before point, then
wisi-cache-end."
+ ;; force reparse, in case parser got confused
+ (let ((wisi-parse-try t))
+ (wisi-validate-cache (point)))
+
+ (save-excursion
+ (let ((cache (or (wisi-get-cache (point))
+ (wisi-backward-cache))))
+ (when cache
+ ;; can be nil if in header comment
+ (let ((start (progn (wisi-goto-start cache) (point)))
+ (end (progn
+ (when (wisi-cache-end cache)
+ ;; nil when cache is statement-end
+ (goto-char (1- (wisi-cache-end cache))))
+ (point))))
+ (indent-region start end)
+ ))
+ )))
+
+(defvar-local wisi-indent-calculate-functions nil
+ "Functions to calculate indentation. Each called with point
+ before a token at the beginning of a line (at current
+ indentation); return indentation column for that token, or
+ nil. May move point. Calling stops when first function returns
+ non-nil.")
+
+(defvar-local wisi-post-parse-fail-hook
+ "Function to reindent portion of buffer.
+Called from `wisi-indent-line' when a parse succeeds after
+failing; assumes user was editing code that is now syntactically
+correct. Must leave point at indentation of current line.")
+
+(defvar-local wisi-indent-failed nil
+ "Non-nil when wisi-indent-line fails due to parse failing; cleared when
indent succeeds.")
+
+(defun wisi-indent-line ()
+ "Indent current line using the wisi indentation engine."
+ (interactive)
+
+ (let* ((savep (point))
+ (indent
+ (or (save-excursion
+ (wisi-validate-cache (point))
+ (back-to-indentation)
+ (when (>= (point) savep) (setq savep nil))
+ (if wisi-parse-failed
+ (progn
+ ;; parse failed. Assume user is editing; indent to
previous line, fix it after parse succeeds
+ (setq wisi-indent-failed t)
+ (forward-line -1);; safe at bob
+ (back-to-indentation)
+ (current-column))
+
+ ;; else parse succeeded
+ (when wisi-indent-failed
+ (setq wisi-indent-failed nil)
+ (run-hooks 'wisi-post-parse-fail-hook))
+ (with-demoted-errors
+ (or (run-hook-with-args-until-success
'wisi-indent-calculate-functions) 0))
+ )))))
+ (if savep
+ ;; point was inside line text; leave it there
+ (save-excursion (indent-line-to indent))
+ ;; point was before line text; move to start of text
+ (indent-line-to indent))
+ ))
+
+;;;; debug
+(defun wisi-parse-buffer ()
+ (interactive)
+ (syntax-propertize (point-max))
+ (wisi-invalidate-cache)
+ (wisi-validate-cache (point-max)))
+
+(defun wisi-show-cache ()
+ "Show cache at point."
+ (interactive)
+ (message "%s" (wisi-get-cache (point))))
+
+(defun wisi-show-token ()
+ "Move forward across one keyword, show token_id."
+ (interactive)
+ (let ((token (wisi-forward-token)))
+ (message "%s" (car token))))
+
+(defun wisi-show-containing-or-previous-cache ()
+ (interactive)
+ (let ((cache (wisi-get-cache (point))))
+ (if cache
+ (message "containing %s" (wisi-goto-containing cache t))
+ (message "previous %s" (wisi-backward-cache)))
+ ))
+
+;;;;; setup
+
+(defun wisi-setup (indent-calculate post-parse-fail class-list keyword-table
token-table parse-table)
+ "Set up a buffer for parsing files with wisi."
+ (setq wisi-class-list class-list)
+ (setq wisi-string-double-term (car (symbol-value (intern-soft
"string-double" token-table))))
+ (setq wisi-string-single-term (car (symbol-value (intern-soft
"string-single" token-table))))
+ (setq wisi-symbol-term (car (symbol-value (intern-soft "symbol"
token-table))))
+
+ (setq wisi-punctuation-table (symbol-value (intern-soft "punctuation"
token-table)))
+ (setq wisi-punctuation-table-max-length 0)
+ (let (fail)
+ (dolist (item wisi-punctuation-table)
+ (when item ;; default matcher can be nil
+
+ ;; check that all chars used in punctuation tokens have punctuation
syntax
+ (mapc (lambda (char)
+ (when (not (= ?. (char-syntax char)))
+ (setq fail t)
+ (message "in %s, %c does not have punctuation syntax"
+ (car item) char)))
+ (cdr item))
+
+ (when (< wisi-punctuation-table-max-length (length (cdr item)))
+ (setq wisi-punctuation-table-max-length (length (cdr item)))))
+ )
+ (when fail
+ (error "aborting due to punctuation errors")))
+
+ (setq wisi-keyword-table keyword-table)
+ (setq wisi-parse-table parse-table)
+
+ (setq wisi-indent-calculate-functions indent-calculate)
+ (set (make-local-variable 'indent-line-function) 'wisi-indent-line)
+
+ (setq wisi-post-parse-fail-hook post-parse-fail)
+ (setq wisi-indent-failed nil)
+
+ (add-hook 'before-change-functions 'wisi-before-change nil t)
+ (add-hook 'after-change-functions 'wisi-after-change nil t)
+
+ ;; WORKAROUND: sometimes the first time font-lock is run,
+ ;; syntax-propertize is not run properly, so we run it here
+ (syntax-propertize (point-max))
+
+ (wisi-invalidate-cache)
+
+ ;; FIXME: debug counter
+ (setq wisi-change-jit-lock-mode 0)
+ )
+
+(provide 'wisi)
+
+;;; end of file
- [elpa] branch externals/wisi created (now dd09dcf), Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 931fc16 16/35: * packages/gnome-c-style/gnome-c-tests.el: Add copyright blurb, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 2f33bf8 21/35: Release Ada mode 5.3.1, wisi 1.1.6, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi e91f482 03/35: * wisi: Fix up dependency and sectioning style., Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 60b8ef1 15/35: Update ada-mode, wisi, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi d10db37 22/35: Release ada-mode version 6.0. Release wisi version 2.0, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi a4e4907 01/35: Add ada-mode, wisi packages,
Stefan Monnier <=
- [elpa] externals/wisi 922e27f 04/35: * wisi: Fix warnings and a few 80-columns overruns, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 0635f1a 14/35: * packages/wisi: Use lexical binding. Fix dos EOL. Fix EOB markers, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 7cb03cb 10/35: * packages/ada-mode/* : version 5.1.5, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi cb45dd5 07/35: * packages/ada-mode: version 5.1.1: fix wisi packaging bug, add -a in gnat-find, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 8bdcee1 11/35: publish ada-mode 5.1.6, wisi 1.0.6, new package ada-ref-man, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 364da46 20/35: Update ada-mode to version 5.2.2, wisi to version 1.1.5, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi 89eee25 23/35: Release ada-mode 6.0.1, wisi 2.0.1; fix copyright, packaging bugs, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi d0eac6a 34/35: Forgot some new files in wisi, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi a6b3115 24/35: * ada-mode, wisi: Fix file access rights, Stefan Monnier, 2020/11/28
- [elpa] externals/wisi bd1884c 02/35: Fix up copyright notices., Stefan Monnier, 2020/11/28