1971 lines
72 KiB
EmacsLisp
1971 lines
72 KiB
EmacsLisp
;;; semantic/grammar.el --- Major mode framework for Semantic grammars -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2002-2005, 2007-2024 Free Software Foundation, Inc.
|
||
|
||
;; Author: David Ponce <david@dponce.com>
|
||
|
||
;; 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 <https://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
;;
|
||
;; Major mode framework for editing Semantic's input grammar files.
|
||
|
||
;;; Code:
|
||
|
||
(require 'semantic)
|
||
(require 'semantic/wisent)
|
||
(require 'semantic/ctxt)
|
||
(require 'semantic/format)
|
||
;; FIXME this is a generated file, but we need to load this file to
|
||
;; generate it!
|
||
;; We need `semantic/grammar-wy.el' but we're also needed to generate
|
||
;; that file from `grammar.wy', so to break the dependency, we keep
|
||
;; a bootstrap copy of `grammar-wy.el' in `grm-wy-boot.el'. See bug#16008.
|
||
(eval-and-compile
|
||
(unless (require 'semantic/grammar-wy nil t)
|
||
(load "semantic/grm-wy-boot")))
|
||
(require 'semantic/idle)
|
||
(require 'help-fns)
|
||
(require 'semantic/analyze)
|
||
|
||
(declare-function semantic-momentary-highlight-tag "semantic/decorate")
|
||
(declare-function semantic-analyze-tags-of-class-list
|
||
"semantic/analyze/complete")
|
||
|
||
(eval-when-compile
|
||
(require 'eldoc)
|
||
(require 'semantic/edit)
|
||
(require 'semantic/find)
|
||
(require 'semantic/db))
|
||
|
||
(declare-function semantic-grammar-wy--install-parser "semantic/grammar-wy")
|
||
|
||
|
||
;;;;
|
||
;;;; Set up lexer
|
||
;;;;
|
||
|
||
(defconst semantic-grammar-lex-c-char-re "'\\s\\?.'"
|
||
"Regexp matching C-like character literals.")
|
||
|
||
;; Most of the analyzers are auto-generated from the grammar, but the
|
||
;; following which need special handling code.
|
||
;;
|
||
(define-lex-regex-analyzer semantic-grammar-lex-prologue
|
||
"Detect and create a prologue token."
|
||
"\\<%{"
|
||
;; Zing to the end of this brace block.
|
||
(semantic-lex-push-token
|
||
(semantic-lex-token
|
||
'PROLOGUE (point)
|
||
(save-excursion
|
||
(semantic-lex-unterminated-syntax-protection 'PROLOGUE
|
||
(forward-char)
|
||
(forward-sexp 1)
|
||
(point))))))
|
||
|
||
(defsubst semantic-grammar-epilogue-start ()
|
||
"Return the start position of the grammar epilogue."
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(if (re-search-forward "^\\s-*\\<%%\\>\\s-*$" nil t 2)
|
||
(match-beginning 0)
|
||
(1+ (point-max)))))
|
||
|
||
(define-lex-regex-analyzer semantic-grammar-lex-epilogue
|
||
"Detect and create an epilogue or percent-percent token."
|
||
"\\<%%\\>"
|
||
(let ((start (match-beginning 0))
|
||
(end (match-end 0))
|
||
(class 'PERCENT_PERCENT))
|
||
(when (>= start (semantic-grammar-epilogue-start))
|
||
(setq class 'EPILOGUE
|
||
end (point-max)))
|
||
(semantic-lex-push-token
|
||
(semantic-lex-token class start end))))
|
||
|
||
(define-lex semantic-grammar-lexer
|
||
"Lexical analyzer that handles Semantic grammar buffers.
|
||
It ignores whitespaces, newlines and comments."
|
||
semantic-lex-ignore-newline
|
||
semantic-lex-ignore-whitespace
|
||
;; Must detect prologue/epilogue before other symbols/keywords!
|
||
semantic-grammar-lex-prologue
|
||
semantic-grammar-lex-epilogue
|
||
semantic-grammar-wy--<keyword>-keyword-analyzer
|
||
semantic-grammar-wy--<symbol>-regexp-analyzer
|
||
semantic-grammar-wy--<char>-regexp-analyzer
|
||
semantic-grammar-wy--<string>-sexp-analyzer
|
||
;; Must detect comments after strings because `comment-start-skip'
|
||
;; regexp match semicolons inside strings!
|
||
semantic-lex-ignore-comments
|
||
;; Must detect prefixed list before punctuation because prefix chars
|
||
;; are also punctuation!
|
||
semantic-grammar-wy--<qlist>-sexp-analyzer
|
||
;; Must detect punctuation after comments because the semicolon can
|
||
;; be punctuation or a comment start!
|
||
semantic-grammar-wy--<punctuation>-string-analyzer
|
||
semantic-grammar-wy--<block>-block-analyzer
|
||
semantic-grammar-wy--<sexp>-sexp-analyzer)
|
||
|
||
;;; Test the lexer
|
||
;;
|
||
(defun semantic-grammar-lex-buffer ()
|
||
"Run `semantic-grammar-lex' on current buffer."
|
||
(interactive)
|
||
(semantic-lex-init)
|
||
(setq semantic-lex-analyzer 'semantic-grammar-lexer)
|
||
(let ((token-stream
|
||
(semantic-lex (point-min) (point-max))))
|
||
(with-current-buffer (get-buffer-create "*semantic-grammar-lex*")
|
||
(erase-buffer)
|
||
(pp token-stream (current-buffer))
|
||
(goto-char (point-min))
|
||
(pop-to-buffer (current-buffer)))))
|
||
|
||
;;;;
|
||
;;;; Semantic action expansion
|
||
;;;;
|
||
|
||
(defun semantic-grammar-ASSOC (&rest args)
|
||
"Return expansion of built-in ASSOC expression.
|
||
ARGS are ASSOC's key value list."
|
||
(let ((key t))
|
||
`(semantic-tag-make-plist
|
||
,@(mapcar (lambda (i)
|
||
(prog1
|
||
(if key
|
||
(list 'quote i)
|
||
i)
|
||
(setq key (not key))))
|
||
args))))
|
||
|
||
(defsubst semantic-grammar-quote-p (sym)
|
||
"Return non-nil if SYM is bound to the `quote' function."
|
||
(condition-case nil
|
||
(eq (indirect-function sym)
|
||
(indirect-function 'quote))
|
||
(error nil)))
|
||
|
||
(defsubst semantic-grammar-backquote-p (sym)
|
||
"Return non-nil if SYM is bound to the `backquote' function."
|
||
(condition-case nil
|
||
(eq (indirect-function sym)
|
||
(indirect-function 'backquote))
|
||
(error nil)))
|
||
|
||
;;;;
|
||
;;;; API to access grammar tags
|
||
;;;;
|
||
|
||
(define-mode-local-override semantic-tag-components
|
||
semantic-grammar-mode (tag)
|
||
"Return the children of tag TAG."
|
||
(semantic-tag-get-attribute tag :children))
|
||
|
||
(defun semantic-grammar-first-tag-name (class)
|
||
"Return the name of the first tag of class CLASS found.
|
||
Warn if other tags of class CLASS exist."
|
||
(let* ((tags (semantic-find-tags-by-class
|
||
class (current-buffer))))
|
||
(if tags
|
||
(prog1
|
||
(semantic-tag-name (car tags))
|
||
(if (cdr tags)
|
||
(message "*** Ignore all but first declared %s"
|
||
class))))))
|
||
|
||
(defun semantic-grammar-tag-symbols (class)
|
||
"Return the list of symbols defined in tags of class CLASS.
|
||
That is tag names plus names defined in tag attribute `:rest'."
|
||
(let* ((tags (semantic-find-tags-by-class
|
||
class (current-buffer))))
|
||
(apply #'append
|
||
(mapcar
|
||
(lambda (tag)
|
||
(mapcar
|
||
#'intern
|
||
(cons (semantic-tag-name tag)
|
||
(semantic-tag-get-attribute tag :rest))))
|
||
tags))))
|
||
|
||
(defsubst semantic-grammar-item-text (item)
|
||
"Return the readable string form of ITEM."
|
||
(if (string-match semantic-grammar-lex-c-char-re item)
|
||
(concat "?" (substring item 1 -1))
|
||
item))
|
||
|
||
(defsubst semantic-grammar-item-value (item)
|
||
"Return symbol or character value of ITEM string."
|
||
(if (string-match semantic-grammar-lex-c-char-re item)
|
||
(read (concat "?" (substring item 1 -1)))
|
||
(intern item)))
|
||
|
||
(defun semantic-grammar-prologue ()
|
||
"Return grammar prologue code as a string value."
|
||
(let ((tag (semantic-find-first-tag-by-name
|
||
"prologue"
|
||
(semantic-find-tags-by-class 'code (current-buffer)))))
|
||
(if tag
|
||
(save-excursion
|
||
(concat
|
||
(buffer-substring
|
||
(progn
|
||
(goto-char (semantic-tag-start tag))
|
||
(skip-chars-forward "%{\r\n\t ")
|
||
(point))
|
||
(progn
|
||
(goto-char (semantic-tag-end tag))
|
||
(skip-chars-backward "\r\n\t %}")
|
||
(point)))
|
||
"\n"))
|
||
"")))
|
||
|
||
(defun semantic-grammar-epilogue ()
|
||
"Return grammar epilogue code as a string value."
|
||
(let ((tag (semantic-find-first-tag-by-name
|
||
"epilogue"
|
||
(semantic-find-tags-by-class 'code (current-buffer)))))
|
||
(if tag
|
||
(save-excursion
|
||
(concat
|
||
(buffer-substring
|
||
(progn
|
||
(goto-char (semantic-tag-start tag))
|
||
(skip-chars-forward "%\r\n\t ")
|
||
(point))
|
||
(progn
|
||
(goto-char (semantic-tag-end tag))
|
||
(skip-chars-backward "\r\n\t")
|
||
;; If a grammar footer is found, skip it.
|
||
(re-search-backward "^;;;\\s-+\\S-+\\s-+ends here"
|
||
(line-beginning-position) t)
|
||
(skip-chars-backward "\r\n\t")
|
||
(point)))
|
||
"\n"))
|
||
"")))
|
||
|
||
(defsubst semantic-grammar-buffer-file (&optional buffer)
|
||
"Return name of file sans directory BUFFER is visiting.
|
||
No argument or nil as argument means use the current buffer."
|
||
(file-name-nondirectory (buffer-file-name buffer)))
|
||
|
||
(defun semantic-grammar-package ()
|
||
"Return the %package value as a string.
|
||
If there is no %package statement in the grammar, return a default
|
||
package name derived from the grammar file name. For example, the
|
||
default package name for the grammar file foo.wy is foo-wy, and for
|
||
foo.by it is foo-by."
|
||
(or (semantic-grammar-first-tag-name 'package)
|
||
(let* ((file (semantic-grammar-buffer-file))
|
||
(ext (file-name-extension file))
|
||
(i (string-match (format "\\([.]\\)%s\\'" ext) file)))
|
||
(concat (substring file 0 i) "-" ext))))
|
||
|
||
(defun semantic-grammar-expected-conflicts ()
|
||
"Return the number of expected shift/reduce conflicts in the package."
|
||
(semantic-grammar-tag-symbols 'expectedconflicts))
|
||
|
||
(defsubst semantic-grammar-languagemode ()
|
||
"Return the %languagemode value as a list of symbols or nil."
|
||
(semantic-grammar-tag-symbols 'languagemode))
|
||
|
||
(defsubst semantic-grammar-start ()
|
||
"Return the %start value as a list of symbols or nil."
|
||
(semantic-grammar-tag-symbols 'start))
|
||
|
||
(defsubst semantic-grammar-scopestart ()
|
||
"Return the %scopestart value as a symbol or nil."
|
||
(intern (or (semantic-grammar-first-tag-name 'scopestart) "nil")))
|
||
|
||
(defsubst semantic-grammar-quotemode ()
|
||
"Return the %quotemode value as a symbol or nil."
|
||
(intern (or (semantic-grammar-first-tag-name 'quotemode) "nil")))
|
||
|
||
(defsubst semantic-grammar-keywords ()
|
||
"Return the language keywords.
|
||
That is an alist of (VALUE . TOKEN) where VALUE is the string value of
|
||
the keyword and TOKEN is the terminal symbol identifying the keyword."
|
||
(mapcar
|
||
(lambda (key)
|
||
(cons (semantic-tag-get-attribute key :value)
|
||
(intern (semantic-tag-name key))))
|
||
(semantic-find-tags-by-class 'keyword (current-buffer))))
|
||
|
||
(defun semantic-grammar-keyword-properties (keywords)
|
||
"Return the list of KEYWORDS properties."
|
||
(let ((puts (semantic-find-tags-by-class
|
||
'put (current-buffer)))
|
||
put keys key plist assoc pkey pval props)
|
||
(while puts
|
||
(setq put (car puts)
|
||
puts (cdr puts)
|
||
keys (mapcar
|
||
#'intern
|
||
(cons (semantic-tag-name put)
|
||
(semantic-tag-get-attribute put :rest))))
|
||
(while keys
|
||
(setq key (car keys)
|
||
keys (cdr keys)
|
||
assoc (rassq key keywords))
|
||
(if (null assoc)
|
||
nil ;;(message "*** %%put to undefined keyword %s ignored" key)
|
||
(setq key (car assoc)
|
||
plist (semantic-tag-get-attribute put :value))
|
||
(while plist
|
||
(setq pkey (intern (caar plist))
|
||
pval (read (cdar plist))
|
||
props (cons (list key pkey pval) props)
|
||
plist (cdr plist))))))
|
||
props))
|
||
|
||
(defun semantic-grammar-tokens ()
|
||
"Return defined lexical tokens.
|
||
That is an alist (TYPE . DEFS) where type is a %token <type> symbol
|
||
and DEFS is an alist of (TOKEN . VALUE). TOKEN is the terminal symbol
|
||
identifying the token and VALUE is the string value of the token or
|
||
nil."
|
||
(let (tags alist assoc tag type term names value)
|
||
|
||
;; Check for <type> in %left, %right & %nonassoc declarations
|
||
(setq tags (semantic-find-tags-by-class
|
||
'assoc (current-buffer)))
|
||
(while tags
|
||
(setq tag (car tags)
|
||
tags (cdr tags))
|
||
(when (setq type (semantic-tag-type tag))
|
||
(setq names (semantic-tag-get-attribute tag :value)
|
||
assoc (assoc type alist))
|
||
(or assoc (setq assoc (list type)
|
||
alist (cons assoc alist)))
|
||
(while names
|
||
(setq term (car names)
|
||
names (cdr names))
|
||
(or (string-match semantic-grammar-lex-c-char-re term)
|
||
(setcdr assoc (cons (list (intern term))
|
||
(cdr assoc)))))))
|
||
|
||
;; Then process %token declarations so they can override any
|
||
;; previous specifications
|
||
(setq tags (semantic-find-tags-by-class
|
||
'token (current-buffer)))
|
||
(while tags
|
||
(setq tag (car tags)
|
||
tags (cdr tags))
|
||
(setq names (cons (semantic-tag-name tag)
|
||
(semantic-tag-get-attribute tag :rest))
|
||
type (or (semantic-tag-type tag) "<no-type>")
|
||
value (semantic-tag-get-attribute tag :value)
|
||
assoc (assoc type alist))
|
||
(or assoc (setq assoc (list type)
|
||
alist (cons assoc alist)))
|
||
(while names
|
||
(setq term (intern (car names))
|
||
names (cdr names))
|
||
(setcdr assoc (cons (cons term value) (cdr assoc)))))
|
||
alist))
|
||
|
||
(defun semantic-grammar-token-%type-properties (&optional props)
|
||
"Return properties set by %type statements.
|
||
This declare a new type if necessary.
|
||
If optional argument PROPS is non-nil, it is an existing list of
|
||
properties where to add new properties."
|
||
(let (type)
|
||
(dolist (tag (semantic-find-tags-by-class 'type (current-buffer)))
|
||
(setq type (semantic-tag-name tag))
|
||
;; Indicate to auto-generate the analyzer for this type
|
||
(push (list type :declared t) props)
|
||
(dolist (e (semantic-tag-get-attribute tag :value))
|
||
(push (list type (intern (car e)) (read (or (cdr e) "nil")))
|
||
props)))
|
||
props))
|
||
|
||
(defun semantic-grammar-token-%put-properties (tokens)
|
||
"For types found in TOKENS, return properties set by %put statements."
|
||
(let (found props)
|
||
(dolist (put (semantic-find-tags-by-class 'put (current-buffer)))
|
||
(dolist (type (cons (semantic-tag-name put)
|
||
(semantic-tag-get-attribute put :rest)))
|
||
(setq found (assoc type tokens))
|
||
(if (null found)
|
||
nil ;; %put <type> ignored, no token defined
|
||
(setq type (car found))
|
||
(dolist (e (semantic-tag-get-attribute put :value))
|
||
(push (list type (intern (car e)) (read (or (cdr e) "nil")))
|
||
props)))))
|
||
props))
|
||
|
||
(defsubst semantic-grammar-token-properties (tokens)
|
||
"Return properties of declared types.
|
||
Types are explicitly declared by %type statements. Types found in
|
||
TOKENS are those declared implicitly by %token statements.
|
||
Properties can be set by %put and %type statements.
|
||
Properties set by %type statements take precedence over those set by
|
||
%put statements."
|
||
(let ((props (semantic-grammar-token-%put-properties tokens)))
|
||
(semantic-grammar-token-%type-properties props)))
|
||
|
||
(defun semantic-grammar-use-macros ()
|
||
"Return macro definitions from %use-macros statements.
|
||
Also load the specified macro libraries."
|
||
(let (lib defs)
|
||
(dolist (tag (semantic-find-tags-by-class 'macro (current-buffer)))
|
||
(setq lib (intern (semantic-tag-type tag)))
|
||
(condition-case nil
|
||
;;(load lib) ;; Be sure to use the latest macro library.
|
||
(require lib)
|
||
(error nil))
|
||
(dolist (mac (semantic-tag-get-attribute tag :value))
|
||
(push (cons (intern mac)
|
||
(intern (format "%s-%s" lib mac)))
|
||
defs)))
|
||
(nreverse defs)))
|
||
|
||
(defvar-local semantic-grammar-macros nil
|
||
"List of associations (MACRO-NAME . EXPANDER).")
|
||
|
||
(defun semantic-grammar-macros ()
|
||
"Build and return the alist of defined macros."
|
||
(append
|
||
;; Definitions found in tags.
|
||
(semantic-grammar-use-macros)
|
||
;; Other pre-installed definitions.
|
||
semantic-grammar-macros))
|
||
|
||
;;;;
|
||
;;;; Overloaded functions that build parser data.
|
||
;;;;
|
||
|
||
;;; Keyword table builder
|
||
;;
|
||
(defun semantic-grammar-keywordtable-builder-default ()
|
||
"Return the default value of the keyword table."
|
||
(let ((keywords (semantic-grammar-keywords)))
|
||
`(semantic-lex-make-keyword-table
|
||
',keywords
|
||
',(semantic-grammar-keyword-properties keywords))))
|
||
|
||
(define-overloadable-function semantic-grammar-keywordtable-builder ()
|
||
"Return the keyword table value.")
|
||
|
||
;;; Token table builder
|
||
;;
|
||
(defun semantic-grammar-tokentable-builder-default ()
|
||
"Return the default value of the table of lexical tokens."
|
||
(let ((tokens (semantic-grammar-tokens)))
|
||
`(semantic-lex-make-type-table
|
||
',tokens
|
||
',(semantic-grammar-token-properties tokens))))
|
||
|
||
(define-overloadable-function semantic-grammar-tokentable-builder ()
|
||
"Return the value of the table of lexical tokens.")
|
||
|
||
;;; Parser table builder
|
||
;;
|
||
(defun semantic-grammar-parsetable-builder-default ()
|
||
"Return the default value of the parse table."
|
||
(error "`semantic-grammar-parsetable-builder' not defined"))
|
||
|
||
(define-overloadable-function semantic-grammar-parsetable-builder ()
|
||
"Return the parser table value.")
|
||
|
||
;;; Parser setup code builder
|
||
;;
|
||
(defun semantic-grammar-setupcode-builder-default ()
|
||
"Return the default value of the setup code form."
|
||
(error "`semantic-grammar-setupcode-builder' not defined"))
|
||
|
||
(define-overloadable-function semantic-grammar-setupcode-builder ()
|
||
"Return the parser setup code form.")
|
||
|
||
;;;;
|
||
;;;; Lisp code generation
|
||
;;;;
|
||
(defvar semantic--grammar-input-buffer nil)
|
||
(defvar semantic--grammar-output-buffer nil)
|
||
(defvar semantic--grammar-package nil)
|
||
(defvar semantic--grammar-provide nil)
|
||
|
||
(defsubst semantic-grammar-keywordtable ()
|
||
"Return the variable name of the keyword table."
|
||
(concat semantic--grammar-package
|
||
"--keyword-table"))
|
||
|
||
(defsubst semantic-grammar-tokentable ()
|
||
"Return the variable name of the token table."
|
||
(concat semantic--grammar-package
|
||
"--token-table"))
|
||
|
||
(defsubst semantic-grammar-parsetable ()
|
||
"Return the variable name of the parse table."
|
||
(concat semantic--grammar-package
|
||
"--parse-table"))
|
||
|
||
(defsubst semantic-grammar-setupfunction ()
|
||
"Return the name of the parser setup function."
|
||
(concat semantic--grammar-package
|
||
"--install-parser"))
|
||
|
||
(defmacro semantic-grammar-as-string (object)
|
||
"Return OBJECT as a string value."
|
||
`(if (stringp ,object)
|
||
,object
|
||
;;(require 'pp)
|
||
(pp-to-string ,object)))
|
||
|
||
(defun semantic-grammar-insert-defconst (name value docstring)
|
||
"Insert declaration of constant NAME with VALUE and DOCSTRING."
|
||
(let ((start (point)))
|
||
(insert (format "(defconst %s\n%s%S)\n\n" name value docstring))
|
||
(save-excursion
|
||
(goto-char start)
|
||
(indent-sexp))))
|
||
|
||
(defun semantic-grammar-insert-defconst-with-eval (name value docstring)
|
||
"Insert declaration of constant NAME with VALUE and DOCSTRING."
|
||
(let ((start (point)))
|
||
(insert (format "(eval-and-compile (defconst %s\n%s%S))\n\n" name value docstring))
|
||
(save-excursion
|
||
(goto-char start)
|
||
(indent-sexp))))
|
||
|
||
(defun semantic-grammar-insert-defun (name body docstring)
|
||
"Insert declaration of function NAME with BODY and DOCSTRING."
|
||
(let ((start (point)))
|
||
(insert (format "(defun %s ()\n%S\n%s)\n\n" name docstring body))
|
||
(save-excursion
|
||
(goto-char start)
|
||
(indent-sexp))))
|
||
|
||
(defun semantic-grammar-insert-define (define)
|
||
"Insert the declaration specified by DEFINE expression.
|
||
Typically a DEFINE expression should look like this:
|
||
|
||
\(define-thing name docstring expression1 ...)"
|
||
;;(require 'pp)
|
||
(let ((start (point)))
|
||
(insert (format "(%S %S" (car define) (nth 1 define)))
|
||
(dolist (item (nthcdr 2 define))
|
||
(insert "\n")
|
||
(delete-blank-lines)
|
||
(pp item (current-buffer)))
|
||
(insert ")\n\n")
|
||
(save-excursion
|
||
(goto-char start)
|
||
(indent-sexp))))
|
||
|
||
(defvar semantic-grammar-require-form
|
||
'(eval-when-compile (require 'semantic/bovine))
|
||
"The form to use to load the parser engine.")
|
||
|
||
(defconst semantic-grammar-header-template
|
||
'("\
|
||
;;; " file " --- Generated parser support file
|
||
|
||
" copy "
|
||
|
||
;; Author: " user-full-name " <" user-mail-address ">
|
||
;; Created: " date "
|
||
;; Keywords: syntax
|
||
;; X-RCS: " vcid "
|
||
|
||
;; This file is not part of GNU Emacs.
|
||
|
||
;; This program 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.
|
||
|
||
;; This software 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 this program. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
;;
|
||
;; PLEASE DO NOT MANUALLY EDIT THIS FILE! It is automatically
|
||
;; generated from the grammar file " gram ".
|
||
|
||
;;; Code:
|
||
|
||
(require 'semantic/lex)
|
||
" require-form "
|
||
")
|
||
"Generated header template.
|
||
The symbols in the template are local variables in
|
||
`semantic-grammar-header'")
|
||
|
||
(defconst semantic-grammar-footer-template
|
||
'("\
|
||
|
||
\(provide '" libr ")
|
||
|
||
;; Local Variables:
|
||
;; version-control: never
|
||
;; no-update-autoloads: t
|
||
;; End:
|
||
|
||
;;; " file " ends here
|
||
")
|
||
"Generated footer template.
|
||
The symbols in the list are local variables in
|
||
`semantic-grammar-footer'.")
|
||
|
||
(defun semantic-grammar-copyright-line ()
|
||
"Return the grammar copyright line, or nil if not found."
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(when (re-search-forward "^;;+[ \t]+Copyright (C) .*$"
|
||
;; Search only in the four top lines
|
||
(save-excursion (forward-line 4) (point))
|
||
t)
|
||
(match-string 0))))
|
||
|
||
(defun semantic-grammar--template-expand (template env)
|
||
(mapconcat (lambda (S)
|
||
(if (stringp S) S
|
||
(let ((x (assq S env)))
|
||
(cond
|
||
(x (cdr x))
|
||
((symbolp S) (symbol-value S))))))
|
||
template))
|
||
|
||
(defun semantic-grammar-header ()
|
||
"Return text of a generated standard header."
|
||
(semantic-grammar--template-expand
|
||
semantic-grammar-header-template
|
||
`((file . ,(semantic-grammar-buffer-file
|
||
semantic--grammar-output-buffer))
|
||
(gram . ,(semantic-grammar-buffer-file))
|
||
(date . ,(format-time-string "%Y-%m-%d %T%z"))
|
||
(require-form . ,(format "%S" semantic-grammar-require-form))
|
||
(vcid . ,(concat "$" "Id" "$")) ;; Avoid expansion
|
||
;; Try to get the copyright from the input grammar, or
|
||
;; generate a new one if not found.
|
||
(copy . ,(or (semantic-grammar-copyright-line)
|
||
(concat (format-time-string ";; Copyright (C) %Y ")
|
||
user-full-name))))))
|
||
|
||
(defun semantic-grammar-footer ()
|
||
"Return text of a generated standard footer."
|
||
(semantic-grammar--template-expand
|
||
semantic-grammar-footer-template
|
||
`((file . ,(semantic-grammar-buffer-file
|
||
semantic--grammar-output-buffer))
|
||
(libr . ,(or semantic--grammar-provide
|
||
semantic--grammar-package)))))
|
||
|
||
(defun semantic-grammar-token-data ()
|
||
"Return the string value of the table of lexical tokens."
|
||
(semantic-grammar-as-string
|
||
(semantic-grammar-tokentable-builder)))
|
||
|
||
(defun semantic-grammar-keyword-data ()
|
||
"Return the string value of the table of keywords."
|
||
(semantic-grammar-as-string
|
||
(semantic-grammar-keywordtable-builder)))
|
||
|
||
(defun semantic-grammar-parser-data ()
|
||
"Return the parser table as a string value."
|
||
(semantic-grammar-as-string
|
||
(semantic-grammar-parsetable-builder)))
|
||
|
||
(defun semantic-grammar-setup-data ()
|
||
"Return the parser setup code form as a string value."
|
||
(semantic-grammar-as-string
|
||
(semantic-grammar-setupcode-builder)))
|
||
|
||
;;; Generation of lexical analyzers.
|
||
;;
|
||
(defvar semantic-grammar--lex-block-specs)
|
||
|
||
(defsubst semantic-grammar--lex-delim-spec (block-spec)
|
||
"Return delimiters specification from BLOCK-SPEC."
|
||
(condition-case nil
|
||
(let* ((standard-input (cdr block-spec))
|
||
(delim-spec (read)))
|
||
(if (and (consp delim-spec)
|
||
(car delim-spec) (symbolp (car delim-spec))
|
||
(cadr delim-spec) (symbolp (cadr delim-spec)))
|
||
delim-spec
|
||
(error "Invalid delimiter")))
|
||
(error
|
||
(error "Invalid delimiters specification %s in block token %s"
|
||
(cdr block-spec) (car block-spec)))))
|
||
|
||
(defun semantic-grammar--lex-block-specs ()
|
||
"Compute lexical block specifications for the current buffer.
|
||
Block definitions are read from the current table of lexical types."
|
||
(cond
|
||
;; Block specifications have been parsed and are invalid.
|
||
((eq semantic-grammar--lex-block-specs 'error)
|
||
nil
|
||
)
|
||
;; Parse block specifications.
|
||
((null semantic-grammar--lex-block-specs)
|
||
(condition-case err
|
||
(let* ((blocks (cdr (semantic-lex-type-value "block" t)))
|
||
(open-delims (cdr (semantic-lex-type-value "open-paren" t)))
|
||
(close-delims (cdr (semantic-lex-type-value "close-paren" t)))
|
||
olist clist delim-spec open-spec close-spec)
|
||
(dolist (block-spec blocks)
|
||
(setq delim-spec (semantic-grammar--lex-delim-spec block-spec)
|
||
open-spec (assq (car delim-spec) open-delims)
|
||
close-spec (assq (cadr delim-spec) close-delims))
|
||
(or open-spec
|
||
(error "Missing open-paren token %s required by block %s"
|
||
(car delim-spec) (car block-spec)))
|
||
(or close-spec
|
||
(error "Missing close-paren token %s required by block %s"
|
||
(cdr delim-spec) (car block-spec)))
|
||
;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
|
||
(push (list (cdr open-spec) (car open-spec) (car block-spec))
|
||
olist)
|
||
;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
|
||
(push (list (cdr close-spec) (car close-spec))
|
||
clist))
|
||
(setq semantic-grammar--lex-block-specs (cons olist clist)))
|
||
(error
|
||
(setq semantic-grammar--lex-block-specs 'error)
|
||
(message "%s" (error-message-string err))
|
||
nil))
|
||
)
|
||
;; Block specifications already parsed.
|
||
(t
|
||
semantic-grammar--lex-block-specs)))
|
||
|
||
(defsubst semantic-grammar-quoted-form (exp)
|
||
"Return a quoted form of EXP if it isn't a self evaluating form."
|
||
(if (and (not (null exp))
|
||
(or (listp exp) (symbolp exp)))
|
||
(list 'quote exp)
|
||
exp))
|
||
|
||
(defun semantic-grammar-insert-defanalyzer (type)
|
||
"Insert declaration of the lexical analyzer defined with TYPE."
|
||
(let* ((type-name (symbol-name type))
|
||
(type-value (symbol-value type))
|
||
(syntax (get type 'syntax))
|
||
(declared (get type :declared))
|
||
spec mtype prefix name doc)
|
||
;; Generate an analyzer if the corresponding type has been
|
||
;; explicitly declared in a %type statement, and if at least the
|
||
;; syntax property has been provided.
|
||
(when (and declared syntax)
|
||
(setq prefix semantic--grammar-package
|
||
mtype (or (get type 'matchdatatype) 'regexp)
|
||
name (intern (format "%s--<%s>-%s-analyzer" prefix type mtype))
|
||
doc (format "%s analyzer for <%s> tokens." mtype type))
|
||
(cond
|
||
;; Regexp match analyzer
|
||
((eq mtype 'regexp)
|
||
(semantic-grammar-insert-define
|
||
`(define-lex-regex-type-analyzer ,name
|
||
,doc ,syntax
|
||
,(semantic-grammar-quoted-form (cdr type-value))
|
||
',(or (car type-value) (intern type-name))))
|
||
)
|
||
;; String compare analyzer
|
||
((eq mtype 'string)
|
||
(semantic-grammar-insert-define
|
||
`(define-lex-string-type-analyzer ,name
|
||
,doc ,syntax
|
||
,(semantic-grammar-quoted-form (cdr type-value))
|
||
',(or (car type-value) (intern type-name))))
|
||
)
|
||
;; Block analyzer
|
||
((and (eq mtype 'block)
|
||
(setq spec (semantic-grammar--lex-block-specs)))
|
||
(semantic-grammar-insert-define
|
||
`(define-lex-block-type-analyzer ,name
|
||
,doc ,syntax
|
||
,(semantic-grammar-quoted-form spec)))
|
||
)
|
||
;; Sexp analyzer
|
||
((eq mtype 'sexp)
|
||
(semantic-grammar-insert-define
|
||
`(define-lex-sexp-type-analyzer ,name
|
||
,doc ,syntax
|
||
',(or (car type-value) (intern type-name))))
|
||
)
|
||
;; keyword analyzer
|
||
((eq mtype 'keyword)
|
||
(semantic-grammar-insert-define
|
||
`(define-lex-keyword-type-analyzer ,name
|
||
,doc ,syntax))
|
||
)
|
||
))
|
||
))
|
||
|
||
(defun semantic-grammar-insert-defanalyzers ()
|
||
"Insert declarations of lexical analyzers."
|
||
(let (tokens props)
|
||
(with-current-buffer semantic--grammar-input-buffer
|
||
(setq tokens (semantic-grammar-tokens)
|
||
props (semantic-grammar-token-properties tokens)))
|
||
(let ((semantic-lex-types-obarray
|
||
(semantic-lex-make-type-table tokens props))
|
||
semantic-grammar--lex-block-specs)
|
||
(mapatoms #'semantic-grammar-insert-defanalyzer
|
||
semantic-lex-types-obarray))))
|
||
|
||
;;; Generation of the grammar support file.
|
||
;;
|
||
(defcustom semantic-grammar-file-regexp "\\.[wb]y\\'"
|
||
"Regexp which matches grammar source files."
|
||
:group 'semantic
|
||
:type 'regexp)
|
||
|
||
(defun semantic-grammar-create-package (&optional force uptodate)
|
||
"Create package Lisp code from grammar in current buffer.
|
||
If the Lisp code seems up to date, do nothing (if UPTODATE
|
||
is non-nil, return nil in such cases).
|
||
If optional argument FORCE is non-nil, unconditionally re-generate the
|
||
Lisp code."
|
||
(interactive "P")
|
||
(unless (semantic-active-p)
|
||
(error "You have to activate semantic-mode to create a package"))
|
||
(setq force (or force current-prefix-arg))
|
||
(semantic-fetch-tags)
|
||
(let* (
|
||
;; Values of the following local variables are obtained from
|
||
;; the grammar parsed tree in current buffer, that is before
|
||
;; switching to the output file.
|
||
(semantic--grammar-package (semantic-grammar-package))
|
||
(semantic--grammar-provide (semantic-grammar-first-tag-name 'provide))
|
||
(output (concat (or semantic--grammar-provide
|
||
semantic--grammar-package)
|
||
".el"))
|
||
(semantic--grammar-input-buffer (current-buffer))
|
||
(semantic--grammar-output-buffer
|
||
(find-file-noselect
|
||
(file-name-nondirectory output)))
|
||
(header (semantic-grammar-header))
|
||
(prologue (semantic-grammar-prologue))
|
||
(epilogue (semantic-grammar-epilogue))
|
||
(footer (semantic-grammar-footer))
|
||
)
|
||
(if (and (not force)
|
||
(not (buffer-modified-p))
|
||
(file-newer-than-file-p
|
||
(buffer-file-name semantic--grammar-output-buffer)
|
||
(buffer-file-name semantic--grammar-input-buffer)))
|
||
(progn
|
||
(message "Package `%s' is up to date." semantic--grammar-package)
|
||
;; It would be better if this were always the case, IMO,
|
||
;; but the (unspecified) return value of this function is
|
||
;; assumed to be non-nil in some places, it seems.
|
||
(if uptodate (setq output nil)))
|
||
;; Create the package
|
||
(set-buffer semantic--grammar-output-buffer)
|
||
;; Use Unix EOLs, so that the file is portable to all platforms.
|
||
(setq buffer-file-coding-system 'raw-text-unix)
|
||
(erase-buffer)
|
||
(unless (derived-mode-p 'emacs-lisp-mode)
|
||
(emacs-lisp-mode))
|
||
|
||
;;;; Header + Prologue
|
||
|
||
(insert header
|
||
" \n;;; Prologue\n;;\n"
|
||
prologue
|
||
)
|
||
;; Evaluate the prologue now, because it might provide definition
|
||
;; of grammar macro expanders.
|
||
(eval-region (point-min) (point))
|
||
|
||
(save-excursion
|
||
|
||
;;;; Declarations
|
||
|
||
(insert " \n;;; Declarations\n;;\n")
|
||
|
||
(semantic-grammar-insert-defconst-with-eval
|
||
(concat semantic--grammar-package "--expected-conflicts")
|
||
(with-current-buffer semantic--grammar-input-buffer
|
||
(format "%s\n" (car (semantic-grammar-expected-conflicts))))
|
||
"The number of expected shift/reduce conflicts in this grammar.")
|
||
|
||
;; `eval-defun' is not necessary to reset `defconst' values.
|
||
(semantic-grammar-insert-defconst
|
||
(semantic-grammar-keywordtable)
|
||
(with-current-buffer semantic--grammar-input-buffer
|
||
(semantic-grammar-keyword-data))
|
||
"Table of language keywords.")
|
||
|
||
(semantic-grammar-insert-defconst
|
||
(semantic-grammar-tokentable)
|
||
(with-current-buffer semantic--grammar-input-buffer
|
||
(semantic-grammar-token-data))
|
||
"Table of lexical tokens.")
|
||
|
||
(semantic-grammar-insert-defconst
|
||
(semantic-grammar-parsetable)
|
||
(with-current-buffer semantic--grammar-input-buffer
|
||
(semantic-grammar-parser-data))
|
||
"Parser table.")
|
||
|
||
(semantic-grammar-insert-defun
|
||
(semantic-grammar-setupfunction)
|
||
(with-current-buffer semantic--grammar-input-buffer
|
||
(semantic-grammar-setup-data))
|
||
"Setup the Semantic Parser.")
|
||
|
||
;;;; Analyzers
|
||
(insert " \n;;; Analyzers\n;;\n")
|
||
|
||
(semantic-grammar-insert-defanalyzers)
|
||
|
||
;;;; Epilogue & Footer
|
||
|
||
(insert " \n;;; Epilogue\n;;\n"
|
||
epilogue
|
||
footer
|
||
)
|
||
|
||
)
|
||
|
||
(save-buffer 16)
|
||
|
||
;; If running in batch mode, there is nothing more to do.
|
||
;; Save the generated file and quit.
|
||
(if noninteractive
|
||
(let ((version-control t)
|
||
(delete-old-versions t)
|
||
(make-backup-files t)
|
||
(vc-make-backup-files t))
|
||
(kill-buffer (current-buffer)))
|
||
;; If running interactively, eval declarations and epilogue
|
||
;; code, then pop to the buffer visiting the generated file.
|
||
(eval-region (point) (point-max))
|
||
;; Loop over the defvars and eval them explicitly to force
|
||
;; them to be evaluated and ready to use.
|
||
(goto-char (point-min))
|
||
(while (re-search-forward "(defvar " nil t)
|
||
(eval-defun nil))
|
||
;; Move cursor to a logical spot in the generated code.
|
||
(goto-char (point-min))
|
||
(pop-to-buffer (current-buffer))
|
||
;; The generated code has been evaluated and updated into
|
||
;; memory. Now find all buffers that match the major modes we
|
||
;; have created this language for, and force them to call our
|
||
;; setup function again, refreshing all semantic data, and
|
||
;; enabling them to work with the new code just created.
|
||
;;;; FIXME?
|
||
;; At this point, I don't know any user's defined setup code :-(
|
||
;; At least, what I can do for now, is to run the generated
|
||
;; parser-install function.
|
||
(semantic-map-mode-buffers
|
||
(semantic-grammar-setupfunction)
|
||
(semantic-grammar-languagemode)))
|
||
)
|
||
;; Return the name of the generated package file.
|
||
output))
|
||
|
||
(defun semantic-grammar-recreate-package ()
|
||
"Unconditionally create Lisp code from grammar in current buffer.
|
||
Like \\[universal-argument] \\[semantic-grammar-create-package]."
|
||
(interactive)
|
||
(semantic-grammar-create-package t))
|
||
|
||
(defun semantic-grammar-batch-build-one-package (file)
|
||
"Build a Lisp package from the grammar in FILE.
|
||
That is, generate Lisp code from FILE, and `byte-compile' it.
|
||
Return non-nil if there were no errors, nil if errors."
|
||
;; We need this require so that we can find `byte-compile-dest-file'.
|
||
(require 'bytecomp)
|
||
(unless (auto-save-file-name-p file)
|
||
;; Create the package
|
||
(let ((packagename
|
||
(condition-case err
|
||
(with-current-buffer (find-file-noselect file)
|
||
(let ((semantic-new-buffer-setup-functions nil)
|
||
(vc-handled-backends nil))
|
||
(setq semanticdb-new-database-class 'semanticdb-project-database)
|
||
(semantic-mode 1)
|
||
(semantic-grammar-create-package t)))
|
||
(error
|
||
(message "%s" (error-message-string err))
|
||
nil))))
|
||
(when packagename
|
||
;; Only byte compile if out of date
|
||
(if (file-newer-than-file-p
|
||
packagename (byte-compile-dest-file packagename))
|
||
(let (;; Some complex grammar table expressions need a few
|
||
;; more resources than the default.
|
||
(max-lisp-eval-depth (max 1000 max-lisp-eval-depth))
|
||
)
|
||
;; byte compile the resultant file
|
||
(byte-compile-file packagename))
|
||
t)))))
|
||
|
||
(defun semantic-grammar-batch-build-packages ()
|
||
"Build Lisp packages from grammar files on the command line.
|
||
That is, run `semantic-grammar-batch-build-one-package' for each file.
|
||
Each file is processed even if an error occurred previously.
|
||
Must be used from the command line, with `-batch'.
|
||
For example, to process grammar files in current directory, invoke:
|
||
|
||
\"emacs -batch -f semantic-grammar-batch-build-packages .\".
|
||
|
||
See also the variable `semantic-grammar-file-regexp'."
|
||
(or noninteractive
|
||
(error "\
|
||
`semantic-grammar-batch-build-packages' must be used with -batch"
|
||
))
|
||
(let ((status 0)
|
||
;; Remove vc from find-file-hook. It causes bad stuff to
|
||
;; happen in Emacs 20.
|
||
(find-file-hook (delete 'vc-find-file-hook find-file-hook)))
|
||
(dolist (arg command-line-args-left)
|
||
(unless (and arg (file-exists-p arg))
|
||
(error "Argument %s is not a valid file name" arg))
|
||
(setq arg (expand-file-name arg))
|
||
(if (file-directory-p arg)
|
||
;; Directory as argument
|
||
(dolist (src (condition-case nil
|
||
(directory-files
|
||
arg nil semantic-grammar-file-regexp)
|
||
(error
|
||
(error "Unable to read directory files"))))
|
||
(or (semantic-grammar-batch-build-one-package
|
||
(expand-file-name src arg))
|
||
(setq status 1)))
|
||
;; Specific file argument
|
||
(or (semantic-grammar-batch-build-one-package arg)
|
||
(setq status 1))))
|
||
(kill-emacs status)
|
||
))
|
||
|
||
;;;;
|
||
;;;; Macros highlighting
|
||
;;;;
|
||
|
||
(defvar-local semantic--grammar-macros-regexp-1 nil)
|
||
|
||
(defun semantic--grammar-macros-regexp-1 ()
|
||
"Return font-lock keyword regexp for pre-installed macro names."
|
||
(and semantic-grammar-macros
|
||
(not semantic--grammar-macros-regexp-1)
|
||
(condition-case nil
|
||
(setq semantic--grammar-macros-regexp-1
|
||
(concat "(\\s-*"
|
||
(regexp-opt
|
||
(mapcar (lambda (e) (symbol-name (car e)))
|
||
semantic-grammar-macros)
|
||
t)
|
||
"\\>"))
|
||
(error nil)))
|
||
semantic--grammar-macros-regexp-1)
|
||
|
||
(defconst semantic--grammar-macdecl-re
|
||
"\\<%use-macros\\>[ \t\r\n]+\\(\\sw\\|\\s_\\)+[ \t\r\n]+{"
|
||
"Regexp that matches a macro declaration statement.")
|
||
|
||
(defvar-local semantic--grammar-macros-regexp-2 nil)
|
||
|
||
(defun semantic--grammar-clear-macros-regexp-2 (&rest _)
|
||
"Clear the cached regexp that match macros local in this grammar.
|
||
IGNORE arguments.
|
||
Added to `before-change-functions' hooks to be run before each text
|
||
change."
|
||
(setq semantic--grammar-macros-regexp-2 nil))
|
||
|
||
(defun semantic--grammar-macros-regexp-2 ()
|
||
"Return the regexp that match macros local in this grammar."
|
||
(unless semantic--grammar-macros-regexp-2
|
||
(let (macs)
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(while (re-search-forward semantic--grammar-macdecl-re nil t)
|
||
(condition-case nil
|
||
(setq macs (nconc macs
|
||
(split-string
|
||
(buffer-substring-no-properties
|
||
(point)
|
||
(progn
|
||
(backward-char)
|
||
(forward-list 1)
|
||
(down-list -1)
|
||
(point))))))
|
||
(error nil)))
|
||
(when macs
|
||
(setq semantic--grammar-macros-regexp-2
|
||
(concat "(\\s-*" (regexp-opt macs t) "\\>"))))))
|
||
semantic--grammar-macros-regexp-2)
|
||
|
||
(defun semantic--grammar-macros-matcher (end)
|
||
"Search for a grammar macro name to highlight.
|
||
END is the limit of the search."
|
||
(let ((regexp (semantic--grammar-macros-regexp-1)))
|
||
(or (and regexp (re-search-forward regexp end t))
|
||
(and (setq regexp (semantic--grammar-macros-regexp-2))
|
||
(re-search-forward regexp end t)))))
|
||
|
||
;;;;
|
||
;;;; Define major mode
|
||
;;;;
|
||
|
||
(defvar semantic-grammar-mode-syntax-table
|
||
(let ((table (make-syntax-table (standard-syntax-table))))
|
||
(modify-syntax-entry ?\: "." table) ;; COLON
|
||
(modify-syntax-entry ?\> "." table) ;; GT
|
||
(modify-syntax-entry ?\< "." table) ;; LT
|
||
(modify-syntax-entry ?\| "." table) ;; OR
|
||
(modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
|
||
(modify-syntax-entry ?\n ">" table) ;; Comment end
|
||
(modify-syntax-entry ?\" "\"" table) ;; String
|
||
(modify-syntax-entry ?\% "w" table) ;; Word
|
||
(modify-syntax-entry ?\- "_" table) ;; Symbol
|
||
(modify-syntax-entry ?\. "_" table) ;; Symbol
|
||
(modify-syntax-entry ?\\ "\\" table) ;; Quote
|
||
(modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
|
||
(modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
|
||
(modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
|
||
(modify-syntax-entry ?\# "'" table) ;; Prefix # (sharp)
|
||
table)
|
||
"Syntax table used in a Semantic grammar buffers.")
|
||
|
||
(defvar semantic-grammar-mode-hook nil
|
||
"Hook run when starting Semantic grammar mode.")
|
||
|
||
(defvar semantic-grammar-mode-keywords-1
|
||
`(("\\(\\<%%\\>\\|\\<%[{}]\\)"
|
||
0 font-lock-constant-face)
|
||
("\\(%\\)\\(\\(\\sw\\|\\s_\\)+\\)"
|
||
(1 font-lock-constant-face)
|
||
(2 font-lock-keyword-face))
|
||
("\\<error\\>"
|
||
0 (unless (semantic-grammar-in-lisp-p) 'bold))
|
||
("^\\(\\(\\sw\\|\\s_\\)+\\)[ \n\r\t]*:"
|
||
1 font-lock-function-name-face)
|
||
(semantic--grammar-macros-matcher
|
||
1 font-lock-builtin-face)
|
||
("\\$\\(\\sw\\|\\s_\\)*"
|
||
0 font-lock-variable-name-face)
|
||
("<\\(\\(\\sw\\|\\s_\\)+\\)>"
|
||
1 font-lock-type-face)
|
||
(,semantic-grammar-lex-c-char-re
|
||
0 font-lock-constant-face t)
|
||
;; Must highlight :keyword here, because ':' is a punctuation in
|
||
;; grammar mode!
|
||
("[\r\n\t ]+:\\sw+\\>"
|
||
0 font-lock-builtin-face)
|
||
;; ;; Append the Semantic keywords
|
||
;; ,@semantic-fw-font-lock-keywords
|
||
)
|
||
"Font Lock keywords used to highlight Semantic grammar buffers.")
|
||
|
||
(defvar semantic-grammar-mode-keywords-2
|
||
(append semantic-grammar-mode-keywords-1
|
||
(if (boundp 'lisp-font-lock-keywords-1)
|
||
lisp-font-lock-keywords-1
|
||
lisp-el-font-lock-keywords-1))
|
||
"Font Lock keywords used to highlight Semantic grammar buffers.")
|
||
|
||
(defvar semantic-grammar-mode-keywords-3
|
||
(append semantic-grammar-mode-keywords-1
|
||
(if (boundp 'lisp-font-lock-keywords-2)
|
||
lisp-font-lock-keywords-2
|
||
lisp-el-font-lock-keywords-2))
|
||
"Font Lock keywords used to highlight Semantic grammar buffers.")
|
||
|
||
(defvar semantic-grammar-mode-keywords
|
||
semantic-grammar-mode-keywords-1
|
||
"Font Lock keywords used to highlight Semantic grammar buffers.")
|
||
|
||
(defvar semantic-grammar-mode-map
|
||
(let ((km (make-sparse-keymap)))
|
||
|
||
(define-key km "|" #'semantic-grammar-electric-punctuation)
|
||
(define-key km ";" #'semantic-grammar-electric-punctuation)
|
||
(define-key km "%" #'semantic-grammar-electric-punctuation)
|
||
(define-key km "(" #'semantic-grammar-electric-punctuation)
|
||
(define-key km ")" #'semantic-grammar-electric-punctuation)
|
||
(define-key km ":" #'semantic-grammar-electric-punctuation)
|
||
|
||
(define-key km "\t" #'semantic-grammar-indent)
|
||
(define-key km "\M-\t" #'semantic-grammar-complete)
|
||
(define-key km "\C-c\C-c" #'semantic-grammar-create-package)
|
||
(define-key km "\C-cm" #'semantic-grammar-find-macro-expander)
|
||
(define-key km "\C-cik" #'semantic-grammar-insert-keyword)
|
||
;; (define-key km "\C-cc" #'semantic-grammar-generate-and-load)
|
||
;; (define-key km "\C-cr" #'semantic-grammar-generate-one-rule)
|
||
|
||
km)
|
||
"Keymap used in `semantic-grammar-mode'.")
|
||
|
||
(defvar semantic-grammar-menu
|
||
'("Grammar"
|
||
["Indent Line" semantic-grammar-indent]
|
||
["Complete Symbol" semantic-grammar-complete]
|
||
["Find Macro" semantic-grammar-find-macro-expander]
|
||
"--"
|
||
["Insert %keyword" semantic-grammar-insert-keyword]
|
||
"--"
|
||
["Update Lisp Package" semantic-grammar-create-package]
|
||
["Recreate Lisp Package" semantic-grammar-recreate-package]
|
||
)
|
||
"Common semantic grammar menu.")
|
||
|
||
(defun semantic-grammar-setup-menu-emacs (symbol mode-menu)
|
||
"Setup a GNU Emacs grammar menu in variable SYMBOL.
|
||
MODE-MENU is an optional specific menu whose items are appended to the
|
||
common grammar menu."
|
||
(let ((items (make-symbol "items")))
|
||
`(unless (boundp ',symbol)
|
||
(easy-menu-define ,symbol (current-local-map)
|
||
"Grammar Menu" semantic-grammar-menu)
|
||
(let ((,items (cdr ,mode-menu)))
|
||
(when ,items
|
||
(easy-menu-add-item ,symbol nil "--")
|
||
(while ,items
|
||
(easy-menu-add-item ,symbol nil (car ,items))
|
||
(setq ,items (cdr ,items))))))
|
||
))
|
||
|
||
(defun semantic-grammar-setup-menu-xemacs (symbol mode-menu)
|
||
"Setup an XEmacs grammar menu in variable SYMBOL.
|
||
MODE-MENU is an optional specific menu whose items are appended to the
|
||
common grammar menu."
|
||
(declare (obsolete nil "28.1"))
|
||
(let ((items (make-symbol "items"))
|
||
(path (make-symbol "path")))
|
||
`(progn
|
||
(unless (boundp ',symbol)
|
||
(easy-menu-define ,symbol nil
|
||
"Grammar Menu" (copy-sequence semantic-grammar-menu)))
|
||
(when (featurep 'xemacs)
|
||
(easy-menu-add ,symbol))
|
||
(let ((,items (cdr ,mode-menu))
|
||
(,path (list (car ,symbol))))
|
||
(when ,items
|
||
(easy-menu-add-item nil ,path "--")
|
||
(while ,items
|
||
(easy-menu-add-item nil ,path (car ,items))
|
||
(setq ,items (cdr ,items))))))
|
||
))
|
||
|
||
(defmacro semantic-grammar-setup-menu (&optional mode-menu)
|
||
"Setup a mode local grammar menu.
|
||
MODE-MENU is an optional specific menu whose items are appended to the
|
||
common grammar menu."
|
||
(semantic-grammar-setup-menu-emacs
|
||
(intern (format "%s-menu" major-mode)) mode-menu))
|
||
|
||
(defsubst semantic-grammar-in-lisp-p ()
|
||
"Return non-nil if point is in Lisp code."
|
||
(or (>= (point) (semantic-grammar-epilogue-start))
|
||
(condition-case nil
|
||
(save-excursion
|
||
(up-list -1)
|
||
t)
|
||
(error nil))))
|
||
|
||
(defun semantic-grammar-edits-new-change-hook-fcn (overlay)
|
||
"Function set into `semantic-edits-new-change-hook'.
|
||
Argument OVERLAY is the overlay created to mark the change.
|
||
When OVERLAY marks a change in the scope of a nonterminal tag extend
|
||
the change bounds to encompass the whole nonterminal tag."
|
||
(let ((outer (car (semantic-find-tag-by-overlay-in-region
|
||
(semantic-edits-os overlay)
|
||
(semantic-edits-oe overlay)))))
|
||
(if (semantic-tag-of-class-p outer 'nonterminal)
|
||
(move-overlay overlay
|
||
(semantic-tag-start outer)
|
||
(semantic-tag-end outer)))))
|
||
|
||
(define-derived-mode semantic-grammar-mode
|
||
fundamental-mode "Semantic Grammar Framework"
|
||
"Initialize a buffer for editing Semantic grammars.
|
||
|
||
\\{semantic-grammar-mode-map}"
|
||
(setq-local parse-sexp-ignore-comments t)
|
||
(setq-local comment-start ";;")
|
||
;; Look within the line for a ; following an even number of backslashes
|
||
;; after either a non-backslash or the line beginning.
|
||
(setq-local comment-start-skip
|
||
"\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
|
||
(setq-local indent-line-function #'semantic-grammar-indent)
|
||
(setq-local fill-paragraph-function #'lisp-fill-paragraph)
|
||
(setq-local font-lock-multiline 'undecided)
|
||
(setq-local font-lock-defaults
|
||
'((semantic-grammar-mode-keywords
|
||
semantic-grammar-mode-keywords-1
|
||
semantic-grammar-mode-keywords-2
|
||
semantic-grammar-mode-keywords-3)
|
||
nil ;; perform string/comment fontification
|
||
nil ;; keywords are case sensitive.
|
||
;; This puts _ & - as a word constituent,
|
||
;; simplifying our keywords significantly
|
||
((?_ . "w") (?- . "w"))))
|
||
;; Setup Semantic to parse grammar
|
||
(semantic-grammar-wy--install-parser)
|
||
(setq semantic-lex-comment-regex ";;"
|
||
semantic-lex-analyzer #'semantic-grammar-lexer
|
||
semantic-type-relation-separator-character '(":")
|
||
semantic-symbol->name-assoc-list
|
||
'(
|
||
(code . "Setup Code")
|
||
(keyword . "Keyword")
|
||
(token . "Token")
|
||
(nonterminal . "Nonterminal")
|
||
(rule . "Rule")
|
||
))
|
||
(setq-local semantic-format-face-alist
|
||
'((code . default)
|
||
(keyword . font-lock-keyword-face)
|
||
(token . font-lock-type-face)
|
||
(nonterminal . font-lock-function-name-face)
|
||
(rule . default)))
|
||
(setq-local semantic-stickyfunc-sticky-classes
|
||
'(nonterminal))
|
||
;; Before each change, clear the cached regexp used to highlight
|
||
;; macros local in this grammar.
|
||
(add-hook 'before-change-functions
|
||
#'semantic--grammar-clear-macros-regexp-2 nil t)
|
||
;; Handle safe re-parse of grammar rules.
|
||
(add-hook 'semantic-edits-new-change-functions
|
||
#'semantic-grammar-edits-new-change-hook-fcn
|
||
nil t))
|
||
|
||
;;;;
|
||
;;;; Useful commands
|
||
;;;;
|
||
|
||
(defvar semantic-grammar-skip-quoted-syntax-table
|
||
(let ((st (copy-syntax-table semantic-grammar-mode-syntax-table)))
|
||
(modify-syntax-entry ?\' "$" st)
|
||
st)
|
||
"Syntax table to skip a whole quoted expression in grammar code.
|
||
Consider quote as a \"paired delimiter\", so `forward-sexp' will skip
|
||
whole quoted expression.")
|
||
|
||
(defsubst semantic-grammar-backward-item ()
|
||
"Move point to beginning of the previous grammar item."
|
||
(forward-comment (- (point-max)))
|
||
(if (zerop (skip-syntax-backward "."))
|
||
(if (eq (char-before) ?\')
|
||
(with-syntax-table
|
||
;; Can't be Lisp code here! Temporarily consider quote
|
||
;; as a "paired delimiter", so `forward-sexp' can skip
|
||
;; the whole quoted expression.
|
||
semantic-grammar-skip-quoted-syntax-table
|
||
(forward-sexp -1))
|
||
(forward-sexp -1))))
|
||
|
||
(defun semantic-grammar-anchored-indentation ()
|
||
"Return indentation based on previous anchor character found."
|
||
(let (indent)
|
||
(save-excursion
|
||
(while (not indent)
|
||
(semantic-grammar-backward-item)
|
||
(cond
|
||
((bobp)
|
||
(setq indent 0))
|
||
((looking-at ":\\(\\s-\\|$\\)")
|
||
(setq indent (current-column))
|
||
(forward-char)
|
||
(skip-syntax-forward "-")
|
||
(if (eolp) (setq indent 2))
|
||
)
|
||
((and (looking-at "[;%]")
|
||
(not (looking-at "\\<%prec\\>")))
|
||
(setq indent 0)
|
||
))))
|
||
indent))
|
||
|
||
(defun semantic-grammar-do-grammar-indent ()
|
||
"Indent a line of grammar.
|
||
When called the point is not in Lisp code."
|
||
(let (indent n)
|
||
(save-excursion
|
||
(beginning-of-line)
|
||
(skip-syntax-forward "-")
|
||
(setq indent (current-column))
|
||
(cond
|
||
((or (bobp)
|
||
(looking-at "\\(\\w\\|\\s_\\)+\\s-*:")
|
||
(and (looking-at "%")
|
||
(not (looking-at "%prec\\>"))))
|
||
(setq n 0))
|
||
((looking-at ":")
|
||
(setq n 2))
|
||
((and (looking-at ";;")
|
||
(save-excursion (forward-comment (point-max))
|
||
(looking-at ":")))
|
||
(setq n 1))
|
||
(t
|
||
(setq n (semantic-grammar-anchored-indentation))
|
||
(unless (zerop n)
|
||
(cond
|
||
((looking-at ";;")
|
||
(setq n (1- n)))
|
||
((looking-at "[|;]")
|
||
)
|
||
(t
|
||
(setq n (+ n 2)))))))
|
||
(when (/= n indent)
|
||
(beginning-of-line)
|
||
(delete-horizontal-space)
|
||
(indent-to n)))))
|
||
|
||
(defvar semantic-grammar-brackets-as-parens-syntax-table
|
||
(let ((st (copy-syntax-table emacs-lisp-mode-syntax-table)))
|
||
(modify-syntax-entry ?\{ "(} " st)
|
||
(modify-syntax-entry ?\} "){ " st)
|
||
st)
|
||
"Syntax table that consider brackets as parenthesis.
|
||
So `lisp-indent-line' will work inside bracket blocks.")
|
||
|
||
(defun semantic-grammar-do-lisp-indent ()
|
||
"Maybe run the Emacs Lisp indenter on a line of code.
|
||
Return nil if not in a Lisp expression."
|
||
(condition-case nil
|
||
(save-excursion
|
||
(beginning-of-line)
|
||
(skip-chars-forward "\t ")
|
||
(let ((first (point)))
|
||
(or (>= first (semantic-grammar-epilogue-start))
|
||
(up-list -1))
|
||
(condition-case nil
|
||
(while t
|
||
(up-list -1))
|
||
(error nil))
|
||
(beginning-of-line)
|
||
(save-restriction
|
||
(narrow-to-region (point) first)
|
||
(goto-char (point-max))
|
||
(with-syntax-table
|
||
;; Temporarily consider brackets as parenthesis so
|
||
;; `lisp-indent-line' can indent Lisp code inside
|
||
;; brackets.
|
||
semantic-grammar-brackets-as-parens-syntax-table
|
||
(lisp-indent-line))))
|
||
t)
|
||
(error nil)))
|
||
|
||
(defun semantic-grammar-indent ()
|
||
"Indent the current line.
|
||
Use the Lisp or grammar indenter depending on point location."
|
||
(interactive)
|
||
(let ((orig (point))
|
||
first)
|
||
(or (semantic-grammar-do-lisp-indent)
|
||
(semantic-grammar-do-grammar-indent))
|
||
(setq first (save-excursion
|
||
(beginning-of-line)
|
||
(skip-chars-forward "\t ")
|
||
(point)))
|
||
(if (or (< orig first) (/= orig (point)))
|
||
(goto-char first))))
|
||
|
||
(defun semantic-grammar-electric-punctuation ()
|
||
"Insert and reindent for the symbol just typed in."
|
||
(interactive)
|
||
(self-insert-command 1)
|
||
(save-excursion
|
||
(semantic-grammar-indent)))
|
||
|
||
(defun semantic-grammar-complete ()
|
||
"Attempt to complete the symbol under point.
|
||
Completion is position sensitive. If the cursor is in a match section of
|
||
a rule, then nonterminals symbols are scanned. If the cursor is in a Lisp
|
||
expression then Lisp symbols are completed."
|
||
(interactive)
|
||
(if (semantic-grammar-in-lisp-p)
|
||
;; We are in lisp code. Do lisp completion.
|
||
(let ((completion-at-point-functions
|
||
(append '(lisp-completion-at-point)
|
||
completion-at-point-functions)))
|
||
(completion-at-point))
|
||
;; We are not in lisp code. Do rule completion.
|
||
(let* ((nonterms (semantic-find-tags-by-class 'nonterminal (current-buffer)))
|
||
(sym (car (semantic-ctxt-current-symbol)))
|
||
(ans (try-completion sym nonterms)))
|
||
(cond ((eq ans t)
|
||
;; All done
|
||
(message "Symbols is already complete"))
|
||
((and (stringp ans) (string= ans sym))
|
||
;; Max matchable. Show completions.
|
||
(with-output-to-temp-buffer "*Completions*"
|
||
(display-completion-list (all-completions sym nonterms)))
|
||
)
|
||
((stringp ans)
|
||
;; Expand the completions
|
||
(forward-sexp -1)
|
||
(delete-region (point) (progn (forward-sexp 1) (point)))
|
||
(insert ans))
|
||
(t (message "No Completions."))
|
||
))
|
||
))
|
||
|
||
(defun semantic-grammar-insert-keyword (name)
|
||
"Insert a new %keyword declaration with NAME.
|
||
Assumes it is typed in with the correct casing."
|
||
(interactive "sKeyword: ")
|
||
(if (not (bolp)) (insert "\n"))
|
||
(insert "%keyword " (upcase name) " \"" name "\"
|
||
%put " (upcase name) " summary
|
||
\"\"\n")
|
||
(forward-char -2))
|
||
|
||
;;; Macro facilities
|
||
;;
|
||
|
||
(defsubst semantic--grammar-macro-function-tag (name)
|
||
"Search for a function tag for the grammar macro with name NAME.
|
||
Return the tag found or nil if not found."
|
||
(car (semantic-find-tags-by-class
|
||
'function
|
||
(or (semantic-find-tags-by-name name (current-buffer))
|
||
(and (featurep 'semantic/db)
|
||
semanticdb-current-database
|
||
(cdar (semanticdb-find-tags-by-name name nil t)))))))
|
||
|
||
(defsubst semantic--grammar-macro-lib-part (def)
|
||
"Return the library part of the grammar macro defined by DEF."
|
||
(let ((suf (format "-%s\\'" (regexp-quote (symbol-name (car def)))))
|
||
(fun (symbol-name (cdr def))))
|
||
(substring fun 0 (string-match suf fun))))
|
||
|
||
(defun semantic--grammar-macro-compl-elt (def &optional full)
|
||
"Return a completion entry for the grammar macro defined by DEF.
|
||
If optional argument FULL is non-nil qualify the macro name with the
|
||
library found in DEF."
|
||
(let ((mac (car def))
|
||
(lib (semantic--grammar-macro-lib-part def)))
|
||
(cons (if full
|
||
(format "%s/%s" mac lib)
|
||
(symbol-name mac))
|
||
(list mac lib))))
|
||
|
||
(defun semantic--grammar-macro-compl-dict ()
|
||
"Return a completion dictionary of macro definitions."
|
||
(let ((defs (semantic-grammar-macros))
|
||
def dups dict)
|
||
(while defs
|
||
(setq def (car defs)
|
||
defs (cdr defs))
|
||
(if (or (assoc (car def) defs) (assoc (car def) dups))
|
||
(push def dups)
|
||
(push (semantic--grammar-macro-compl-elt def) dict)))
|
||
(while dups
|
||
(setq def (car dups)
|
||
dups (cdr dups))
|
||
(push (semantic--grammar-macro-compl-elt def t) dict))
|
||
dict))
|
||
|
||
(defun semantic-grammar-find-macro-expander (macro-name library)
|
||
"Visit the Emacs Lisp library where a grammar macro is implemented.
|
||
MACRO-NAME is a symbol that identifies a grammar macro.
|
||
LIBRARY is the name (sans extension) of the Emacs Lisp library where
|
||
to start searching the macro implementation. Lookup in included
|
||
libraries, if necessary.
|
||
Find a function tag (in current tags table) whose name contains MACRO-NAME.
|
||
Select the buffer containing the tag's definition, and move point there."
|
||
(interactive
|
||
(let* ((dic (semantic--grammar-macro-compl-dict))
|
||
(def (assoc (completing-read "Macro: " dic nil 1) dic)))
|
||
(or (cdr def) '(nil nil))))
|
||
(when (and macro-name library)
|
||
(let* ((lib (format "%s.el" library))
|
||
(buf (find-file-noselect (or (locate-library lib t) lib)))
|
||
(tag (with-current-buffer buf
|
||
(semantic--grammar-macro-function-tag
|
||
(format "%s-%s" library macro-name)))))
|
||
(if tag
|
||
(progn
|
||
(require 'semantic/decorate)
|
||
(pop-to-buffer (semantic-tag-buffer tag))
|
||
(goto-char (semantic-tag-start tag))
|
||
(semantic-momentary-highlight-tag tag))
|
||
(pop-to-buffer buf)
|
||
(message "No expander found in library %s for macro %s"
|
||
library macro-name)))))
|
||
|
||
;;; Additional help
|
||
;;
|
||
|
||
(defvar semantic-grammar-syntax-help
|
||
'(
|
||
;; Lexical Symbols
|
||
("symbol" . "Syntax: A symbol of alpha numeric and symbol characters")
|
||
("number" . "Syntax: Numeric characters.")
|
||
("punctuation" . "Syntax: Punctuation character.")
|
||
("semantic-list" . "Syntax: A list delimited by any valid list characters")
|
||
("open-paren" . "Syntax: Open Parenthesis character")
|
||
("close-paren" . "Syntax: Close Parenthesis character")
|
||
("string" . "Syntax: String character delimited text")
|
||
("comment" . "Syntax: Comment character delimited text")
|
||
;; Special Macros
|
||
("EMPTY" . "Syntax: Match empty text")
|
||
("ASSOC" . "Lambda Key: (ASSOC key1 value1 key2 value2 ...)")
|
||
("EXPAND" . "Lambda Key: (EXPAND <list id> <rule>)")
|
||
("EXPANDFULL" . "Lambda Key: (EXPANDFULL <list id> <rule>)")
|
||
;; Tag Generator Macros
|
||
("TAG" . "Generic Tag Generation: (TAG <name> <tag-class> [ :key value ]*)")
|
||
("VARIABLE-TAG" . "(VARIABLE-TAG <name> <lang-type> <default-value> [ :key value ]*)")
|
||
("FUNCTION-TAG" . "(FUNCTION-TAG <name> <lang-type> <arg-list> [ :key value ]*)")
|
||
("TYPE-TAG" . "(TYPE-TAG <name> <lang-type> <part-list> <parents> [ :key value ]*)")
|
||
("INCLUDE-TAG" . "(INCLUDE-TAG <name> <system-flag> [ :key value ]*)")
|
||
("PACKAGE-TAG" . "(PACKAGE-TAG <name> <detail> [ :key value ]*)")
|
||
("CODE-TAG" . "(CODE-TAG <name> <detail> [ :key value ]*)")
|
||
("ALIAS-TAG" . "(ALIAS-TAG <name> <aliasclass> <definition> [:key value]*)")
|
||
;; Special value macros
|
||
("$1" . "Match Value: Value from match list in slot 1")
|
||
("$2" . "Match Value: Value from match list in slot 2")
|
||
("$3" . "Match Value: Value from match list in slot 3")
|
||
("$4" . "Match Value: Value from match list in slot 4")
|
||
("$5" . "Match Value: Value from match list in slot 5")
|
||
("$6" . "Match Value: Value from match list in slot 6")
|
||
("$7" . "Match Value: Value from match list in slot 7")
|
||
("$8" . "Match Value: Value from match list in slot 8")
|
||
("$9" . "Match Value: Value from match list in slot 9")
|
||
;; Same, but with annoying , in front.
|
||
(",$1" . "Match Value: Value from match list in slot 1")
|
||
(",$2" . "Match Value: Value from match list in slot 2")
|
||
(",$3" . "Match Value: Value from match list in slot 3")
|
||
(",$4" . "Match Value: Value from match list in slot 4")
|
||
(",$5" . "Match Value: Value from match list in slot 5")
|
||
(",$6" . "Match Value: Value from match list in slot 6")
|
||
(",$7" . "Match Value: Value from match list in slot 7")
|
||
(",$8" . "Match Value: Value from match list in slot 8")
|
||
(",$9" . "Match Value: Value from match list in slot 9")
|
||
)
|
||
"Association of syntax elements, and the corresponding help.")
|
||
|
||
(defvar semantic-grammar-eldoc-last-data (cons nil nil))
|
||
|
||
(defun semantic--docstring-format-sym-doc (prefix doc &optional face)
|
||
"Combine PREFIX and DOC, and shorten the result to fit in the echo area.
|
||
|
||
When PREFIX is a symbol, propertize its symbol name with FACE
|
||
before combining it with DOC. If FACE is not provided, just
|
||
apply the nil face.
|
||
|
||
See also: `eldoc-echo-area-use-multiline-p'."
|
||
;; Hoisted from old `eldoc-docstring-format-sym-doc'.
|
||
;; If the entire line cannot fit in the echo area, the symbol name may be
|
||
;; truncated or eliminated entirely from the output to make room for the
|
||
;; description.
|
||
(when (symbolp prefix)
|
||
(setq prefix (concat (propertize (symbol-name prefix) 'face face) ": ")))
|
||
(let* ((ea-multi eldoc-echo-area-use-multiline-p)
|
||
;; Subtract 1 from window width since emacs will not write
|
||
;; any chars to the last column, or in later versions, will
|
||
;; cause a wraparound and resize of the echo area.
|
||
(ea-width (1- (window-width (minibuffer-window))))
|
||
(strip (- (+ (length prefix)
|
||
(length doc))
|
||
ea-width)))
|
||
(cond ((or (<= strip 0)
|
||
(eq ea-multi t)
|
||
(and ea-multi (> (length doc) ea-width)))
|
||
(concat prefix doc))
|
||
((> (length doc) ea-width)
|
||
(substring (format "%s" doc) 0 ea-width))
|
||
((>= strip (string-match-p ":? *\\'" prefix))
|
||
doc)
|
||
(t
|
||
;; Show the end of the partial symbol name, rather
|
||
;; than the beginning, since the former is more likely
|
||
;; to be unique given package namespace conventions.
|
||
(concat (substring prefix strip) doc)))))
|
||
|
||
(defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
|
||
"Return a one-line docstring for the given grammar MACRO.
|
||
EXPANDER is the name of the function that expands MACRO."
|
||
(require 'eldoc)
|
||
(cond
|
||
((eq expander (car semantic-grammar-eldoc-last-data))
|
||
(cdr semantic-grammar-eldoc-last-data))
|
||
((fboundp 'eldoc-function-argstring) ;; Emacs<25
|
||
(let* ((doc (help-split-fundoc (documentation expander t) expander)))
|
||
(cond
|
||
(doc
|
||
(setq doc (car doc))
|
||
(string-match "\\`[^ )]* ?" doc)
|
||
(setq doc (concat "(" (substring doc (match-end 0)))))
|
||
(t
|
||
(setq doc (eldoc-function-argstring expander))))
|
||
(when doc
|
||
(setq doc
|
||
(semantic--docstring-format-sym-doc
|
||
macro (format "==> %s %s" expander doc) 'default))
|
||
(setq semantic-grammar-eldoc-last-data (cons expander doc)))
|
||
doc))
|
||
((fboundp 'elisp-get-fnsym-args-string) ;; Emacs≥25
|
||
(concat (propertize (symbol-name macro)
|
||
'face 'font-lock-keyword-face)
|
||
" ==> "
|
||
(propertize (symbol-name macro)
|
||
'face 'font-lock-function-name-face)
|
||
": "
|
||
(elisp-get-fnsym-args-string expander nil )))))
|
||
|
||
(define-mode-local-override semantic-idle-summary-current-symbol-info
|
||
semantic-grammar-mode ()
|
||
"Display additional eldoc information about grammar syntax elements.
|
||
Syntax element is the current symbol at point.
|
||
If it is associated a help string in `semantic-grammar-syntax-help',
|
||
return that string.
|
||
If it is a macro name, return a description of the associated expander
|
||
function parameter list.
|
||
If it is a function name, return a description of this function
|
||
parameter list.
|
||
If it is a variable name, return a brief (one-line) documentation
|
||
string for the variable.
|
||
If a default description of the current context can be obtained,
|
||
return it.
|
||
Otherwise return nil."
|
||
(require 'eldoc)
|
||
(let* ((elt (car (semantic-ctxt-current-symbol)))
|
||
(val (and elt (cdr (assoc elt semantic-grammar-syntax-help)))))
|
||
(when (and (not val) elt (semantic-grammar-in-lisp-p))
|
||
;; Ensure to load macro definitions before doing `intern-soft'.
|
||
(setq val (semantic-grammar-macros)
|
||
elt (intern-soft elt)
|
||
val (and elt (cdr (assq elt val))))
|
||
(cond
|
||
;; Grammar macro
|
||
((and val (fboundp val))
|
||
(setq val (semantic-grammar-eldoc-get-macro-docstring elt val)))
|
||
;; Function
|
||
((and elt (fboundp elt))
|
||
(setq val (if (fboundp 'eldoc-get-fnsym-args-string)
|
||
(eldoc-get-fnsym-args-string elt)
|
||
(elisp-get-fnsym-args-string elt))))
|
||
;; Variable
|
||
((and elt (boundp elt))
|
||
(setq val (if (fboundp 'eldoc-get-var-docstring)
|
||
(eldoc-get-var-docstring elt)
|
||
(elisp-get-var-docstring elt))))
|
||
(t nil)))
|
||
(or val (semantic-idle-summary-current-symbol-info-default))))
|
||
|
||
(define-mode-local-override semantic-tag-boundary-p
|
||
semantic-grammar-mode (tag)
|
||
"Return non-nil for tags that should have a boundary drawn.
|
||
Only tags of type `nonterminal' will be so marked."
|
||
(let ((c (semantic-tag-class tag)))
|
||
(eq c 'nonterminal)))
|
||
|
||
(define-mode-local-override semantic-ctxt-current-function
|
||
semantic-grammar-mode (&optional point)
|
||
"Determine the name of the current function at POINT."
|
||
(save-excursion
|
||
(and point (goto-char point))
|
||
(when (semantic-grammar-in-lisp-p)
|
||
(with-mode-local emacs-lisp-mode
|
||
(semantic-ctxt-current-function)))))
|
||
|
||
(define-mode-local-override semantic-ctxt-current-argument
|
||
semantic-grammar-mode (&optional point)
|
||
"Determine the argument index of the called function at POINT."
|
||
(save-excursion
|
||
(and point (goto-char point))
|
||
(when (semantic-grammar-in-lisp-p)
|
||
(with-mode-local emacs-lisp-mode
|
||
(semantic-ctxt-current-argument)))))
|
||
|
||
(define-mode-local-override semantic-ctxt-current-assignment
|
||
semantic-grammar-mode (&optional point)
|
||
"Determine the tag being assigned into at POINT."
|
||
(save-excursion
|
||
(and point (goto-char point))
|
||
(when (semantic-grammar-in-lisp-p)
|
||
(with-mode-local emacs-lisp-mode
|
||
(semantic-ctxt-current-assignment)))))
|
||
|
||
(define-mode-local-override semantic-ctxt-current-class-list
|
||
semantic-grammar-mode (&optional point)
|
||
"Determine the class of tags that can be used at POINT."
|
||
(save-excursion
|
||
(and point (goto-char point))
|
||
(if (semantic-grammar-in-lisp-p)
|
||
(with-mode-local emacs-lisp-mode
|
||
(semantic-ctxt-current-class-list))
|
||
'(nonterminal token keyword))))
|
||
|
||
(define-mode-local-override semantic-ctxt-current-mode
|
||
semantic-grammar-mode (&optional point)
|
||
"Return the major mode active at POINT.
|
||
POINT defaults to the value of point in current buffer.
|
||
Return `emacs-lisp-mode' is POINT is within Lisp code, otherwise
|
||
return the current major mode."
|
||
(save-excursion
|
||
(and point (goto-char point))
|
||
(if (semantic-grammar-in-lisp-p)
|
||
'emacs-lisp-mode
|
||
(semantic-ctxt-current-mode-default))))
|
||
|
||
(define-mode-local-override semantic-format-tag-abbreviate
|
||
semantic-grammar-mode (tag &optional parent color)
|
||
"Return a string abbreviation of TAG.
|
||
Optional PARENT is not used.
|
||
Optional COLOR is used to flag if color is added to the text."
|
||
(let ((class (semantic-tag-class tag))
|
||
(name (semantic-format-tag-name tag parent color)))
|
||
(cond
|
||
((eq class 'nonterminal)
|
||
(concat name ":"))
|
||
((eq class 'setting)
|
||
"%settings%")
|
||
((memq class '(rule keyword))
|
||
name)
|
||
(t
|
||
(concat "%" (symbol-name class) " " name)))))
|
||
|
||
(define-mode-local-override semantic-format-tag-summarize
|
||
semantic-grammar-mode (tag &optional parent color)
|
||
"Return a string summarizing TAG.
|
||
Optional PARENT is not used.
|
||
Optional argument COLOR determines if color is added to the text."
|
||
(let ((class (semantic-tag-class tag))
|
||
(name (semantic-format-tag-name tag parent color))
|
||
(label nil)
|
||
(desc nil))
|
||
(cond
|
||
((eq class 'nonterminal)
|
||
(setq label "Nonterminal: "
|
||
desc (format
|
||
" with %d match lists."
|
||
(length (semantic-tag-components tag)))))
|
||
((eq class 'keyword)
|
||
(setq label "Keyword: ")
|
||
(let (summary)
|
||
(semantic--find-tags-by-function
|
||
(lambda (put)
|
||
(unless summary
|
||
(setq summary (cdr (assoc "summary"
|
||
(semantic-tag-get-attribute
|
||
put :value))))))
|
||
;; Get `put' tag with TAG name.
|
||
(semantic-find-tags-by-name-regexp
|
||
(regexp-quote (semantic-tag-name tag))
|
||
(semantic-find-tags-by-class 'put (current-buffer))))
|
||
(setq desc (concat " = "
|
||
(semantic-tag-get-attribute tag :value)
|
||
(if summary
|
||
(concat " - " (read summary))
|
||
"")))))
|
||
((eq class 'token)
|
||
(setq label "Token: ")
|
||
(let ((val (semantic-tag-get-attribute tag :value))
|
||
(names (semantic-tag-get-attribute tag :rest))
|
||
(type (semantic-tag-type tag)))
|
||
(if names
|
||
(setq name (mapconcat #'identity (cons name names) " ")))
|
||
(setq desc (concat
|
||
(if type
|
||
(format " <%s>" type)
|
||
"")
|
||
(if val
|
||
(format "%s%S" val (if type " " ""))
|
||
"")))))
|
||
((eq class 'assoc)
|
||
(setq label "Assoc: ")
|
||
(let ((val (semantic-tag-get-attribute tag :value))
|
||
(type (semantic-tag-type tag)))
|
||
(setq desc (concat
|
||
(if type
|
||
(format " <%s>" type)
|
||
"")
|
||
(if val
|
||
(concat " " (mapconcat #'identity val " "))
|
||
"")))))
|
||
(t
|
||
(setq desc (semantic-format-tag-abbreviate tag parent color))))
|
||
(if (and color label)
|
||
(setq label (semantic--format-colorize-text label 'label)))
|
||
(if (and color label desc)
|
||
(setq desc (semantic--format-colorize-text desc 'comment)))
|
||
(if label
|
||
(concat label name desc)
|
||
;; Just a description is the abbreviated version
|
||
desc)))
|
||
|
||
;;; Semantic Analysis
|
||
|
||
(define-mode-local-override semantic-analyze-current-context
|
||
semantic-grammar-mode (point)
|
||
"Provide a semantic analysis object describing a context in a grammar."
|
||
(if (semantic-grammar-in-lisp-p)
|
||
(with-mode-local emacs-lisp-mode
|
||
(semantic-analyze-current-context point))
|
||
|
||
(let* ((context-return nil)
|
||
(prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
|
||
(prefix (car prefixandbounds))
|
||
(bounds (nth 2 prefixandbounds))
|
||
(prefixsym nil)
|
||
(prefixclass (semantic-ctxt-current-class-list))
|
||
)
|
||
|
||
;; Do context for rules when in a match list.
|
||
(setq prefixsym
|
||
(semantic-find-first-tag-by-name
|
||
(car prefix)
|
||
(current-buffer)))
|
||
|
||
(setq context-return
|
||
(semantic-analyze-context
|
||
:buffer (current-buffer)
|
||
:scope nil
|
||
:bounds bounds
|
||
:prefix (if prefixsym
|
||
(list prefixsym)
|
||
prefix)
|
||
:prefixtypes nil
|
||
:prefixclass prefixclass
|
||
))
|
||
|
||
context-return)))
|
||
|
||
(define-mode-local-override semantic-analyze-possible-completions
|
||
semantic-grammar-mode (context &rest _flags)
|
||
"Return a list of possible completions based on CONTEXT."
|
||
(require 'semantic/analyze/complete)
|
||
(if (semantic-grammar-in-lisp-p)
|
||
(with-mode-local emacs-lisp-mode
|
||
(semantic-analyze-possible-completions context))
|
||
(with-current-buffer (oref context buffer)
|
||
(let* ((prefix (car (reverse (oref context prefix))))
|
||
(completetext (cond ((semantic-tag-p prefix)
|
||
(semantic-tag-name prefix))
|
||
((stringp prefix)
|
||
prefix)
|
||
((stringp (car prefix))
|
||
(car prefix))))
|
||
(tags (semantic-find-tags-for-completion completetext
|
||
(current-buffer))))
|
||
(semantic-analyze-tags-of-class-list
|
||
tags (oref context prefixclass)))
|
||
)))
|
||
|
||
(provide 'semantic/grammar)
|
||
|
||
|
||
;; Local variables:
|
||
;; generated-autoload-load-name: "semantic/grammar"
|
||
;; End:
|
||
|
||
;;; semantic/grammar.el ends here
|