(scope-local-new bare beg local) (cdr bindings) body))
(scope-n local body)))
+(defun scope-interactive (local spec modes)
+ (scope-1 local spec)
+ (dolist (mode modes)
+ (and (symbol-with-pos-p mode)
+ (when-let* ((beg (symbol-with-pos-pos mode))
+ (bare (bare-symbol mode))
+ (len (length (symbol-name bare))))
+ (funcall scope-callback 'major-mode beg len nil)))))
+
(defun scope-lambda (local args body)
- (let ((int-spec nil)
- (doc-form nil))
- (cond
- ((and (consp (car body))
- (or (symbol-with-pos-p (caar body))
- (symbolp (caar body)))
- (eq (bare-symbol (caar body)) :documentation))
- (setq doc-form (cadar body))
- (setq body (cdr body)))
- ((stringp (car body)) (setq body (cdr body))))
- (when (and (consp (car body))
- (or (symbol-with-pos-p (caar body))
- (symbolp (caar body)))
- (eq (bare-symbol (caar body)) 'declare))
- (setq body (cdr body)))
- (when (and (consp (car body))
- (or (symbol-with-pos-p (caar body))
- (symbolp (caar body)))
- (eq (bare-symbol (caar body)) 'interactive))
- (setq int-spec (cadar body))
- (setq body (cdr body)))
+ "Analyze (lambda ARGS BODY) function definition in LOCAL context."
+ ;; Handle docstring.
+ (cond
+ ((and (consp (car body))
+ (or (symbol-with-pos-p (caar body))
+ (symbolp (caar body)))
+ (eq (bare-symbol (caar body)) :documentation))
+ (scope-1 local (cadar body))
+ (setq body (cdr body)))
+ ((stringp (car body)) (setq body (cdr body))))
+ ;; Handle `declare'.
+ (when (and (consp (car body))
+ (or (symbol-with-pos-p (caar body))
+ (symbolp (caar body)))
+ (eq (bare-symbol (caar body)) 'declare))
+ (setq body (cdr body)))
+ ;; Handle `interactive'.
+ (when (and (consp (car body))
+ (or (symbol-with-pos-p (caar body))
+ (symbolp (caar body)))
+ (eq (bare-symbol (caar body)) 'interactive))
+ (scope-interactive local (cadar body) (cddar body))
+ (setq body (cdr body)))
+ ;; Handle ARGS.
+ (dolist (arg args)
+ (and (symbol-with-pos-p arg)
+ (let* ((beg (symbol-with-pos-pos arg))
+ (bare (bare-symbol arg))
+ (len (length (symbol-name bare))))
+ (when beg
+ (if (memq (bare-symbol arg) '(&optional &rest _))
+ (funcall scope-callback 'ampersand beg len nil)
+ (funcall scope-callback 'variable beg len beg))))))
+ ;; Handle BODY.
+ (let ((l local))
(dolist (arg args)
- (and (symbol-with-pos-p arg)
- (not (memq (bare-symbol arg) '(&optional &rest _)))
- (let* ((beg (symbol-with-pos-pos arg))
- (bare (bare-symbol arg))
- (len (length (symbol-name bare))))
- (when beg (funcall scope-callback 'variable beg len beg)))))
- (scope-1 local doc-form)
- (scope-1 local int-spec)
- (let ((l local))
- (dolist (arg args)
- (when-let ((bare (bare-symbol arg))
- (beg (scope-sym-pos arg)))
- (unless (memq bare '(&optional &rest))
- (setq l (scope-local-new bare beg l)))))
- (scope-n l body))))
+ (when-let ((bare (bare-symbol arg))
+ (beg (scope-sym-pos arg)))
+ (unless (memq bare '(&optional &rest))
+ (setq l (scope-local-new bare beg l)))))
+ (scope-n l body)))
(defun scope-defun (local name args body)
(when-let ((beg (scope-sym-pos name))
(when beg
(funcall scope-callback 'variable beg (length (symbol-name bare)) beg))
(scope-1 local bodyform)
- (dolist (handler handlers) (scope-n l (cdr handler)))))
+ (dolist (handler handlers)
+ (dolist (cond-name (ensure-list (car-safe handler)))
+ (when-let* ((cbeg (scope-sym-pos cond-name))
+ (cbare (scope-sym-bare cond-name))
+ (clen (length (symbol-name cbare))))
+ (cond
+ ((booleanp cbare))
+ ((keywordp cbare) (funcall scope-callback 'constant cbeg clen nil))
+ (t (funcall scope-callback 'condition cbeg clen nil)))))
+ (scope-n l (cdr handler)))))
(defvar scope-flet-alist nil)
(funcall scope-callback 'function beg (length (symbol-name bare)) nil))
(scope-n local rest))
+(defun scope-catch (local tag body)
+ (when-let* (((memq (car-safe tag) '(quote \`)))
+ (sym (cadr tag))
+ (beg (scope-sym-pos sym))
+ (bare (scope-sym-bare sym)))
+ (funcall scope-callback 'throw-tag beg (length (symbol-name bare)) nil))
+ (scope-n local body))
+
+(defun scope-face (_local face-form)
+ (when-let (((memq (scope-sym-bare (car-safe face-form)) '(quote \`)))
+ (face (cadr face-form)))
+ (if (or (scope-sym-bare face)
+ (keywordp (scope-sym-bare (car-safe face))))
+ (scope-face-1 face)
+ (mapc #'scope-face-1 face))))
+
+(defun scope-face-1 (face)
+ (cond
+ ((symbol-with-pos-p face)
+ (when-let ((beg (scope-sym-pos face)) (bare (scope-sym-bare face)))
+ (funcall scope-callback 'face beg (length (symbol-name bare)) nil)))
+ ((keywordp (scope-sym-bare (car-safe face)))
+ (let ((l face))
+ (while l
+ (let ((kw (car l))
+ (vl (cadr l)))
+ (setq l (cddr l))
+ (when-let ((bare (scope-sym-bare kw))
+ ((keywordp bare)))
+ (when-let ((beg (scope-sym-pos kw))
+ (len (length (symbol-name bare))))
+ (funcall scope-callback 'constant beg len nil))
+ (when (eq bare :inherit)
+ (when-let ((beg (scope-sym-pos vl)) (fbare (scope-sym-bare vl)))
+ (funcall scope-callback 'face beg (length (symbol-name fbare)) nil))))))))))
+
+(defun scope-deftype (local name args body)
+ (when-let* ((beg (scope-sym-pos name)) (bare (scope-sym-bare name)))
+ (funcall scope-callback 'type beg (length (symbol-name bare)) nil))
+ (scope-lambda local args body))
+
(defvar scope-safe-macros t
"Specify which macros are safe to expand.
(alias (cadr alias-form))
(beg (scope-sym-pos alias))
(bare (scope-sym-bare alias)))
- (funcall scope-callback 'defface beg (length (symbol-name bare)) nil))))
+ (funcall scope-callback 'defface beg (length (symbol-name bare)) nil))
+ (when-let* ((spec-form (cadr forms))
+ ((eq (scope-sym-bare (car-safe spec-form)) 'quote))
+ (specs (cadr spec-form))
+ ((consp specs)))
+ (dolist (spec specs)
+ (scope-face local (list 'quote (cdr spec))))))
+ (throw
+ (when-let* ((tag-form (car forms))
+ ((memq (scope-sym-bare (car-safe tag-form)) '(quote \`)))
+ (tag (cadr tag-form))
+ (beg (scope-sym-pos tag))
+ (bare (scope-sym-bare tag)))
+ (funcall scope-callback 'throw-tag beg (length (symbol-name bare)) nil)))
+ (( boundp set symbol-value
+ special-variable-p local-variable-p
+ local-variable-if-set-p
+ make-variable-buffer-local
+ default-value set-default make-local-variable
+ buffer-local-value add-to-list add-hook)
+ (when-let* ((var-form (car forms))
+ ((memq (scope-sym-bare (car-safe var-form)) '(quote \`)))
+ (var (cadr var-form))
+ (beg (scope-sym-pos var))
+ (bare (scope-sym-bare var)))
+ (funcall scope-callback 'variable beg (length (symbol-name bare)) nil)))
+ ((featurep provide require)
+ (when-let* ((feat-form (car forms))
+ ((memq (scope-sym-bare (car-safe feat-form)) '(quote \`)))
+ (feat (cadr feat-form))
+ (beg (scope-sym-pos feat))
+ (bare (scope-sym-bare feat)))
+ (funcall scope-callback 'feature beg (length (symbol-name bare)) nil)))
+ ((fboundp)
+ (when-let* ((fun-form (car forms))
+ ((memq (scope-sym-bare (car-safe fun-form)) '(quote \`)))
+ (fun (cadr fun-form))
+ (beg (scope-sym-pos fun))
+ (bare (scope-sym-bare fun)))
+ (funcall scope-callback 'function beg (length (symbol-name bare)) nil)))
+ (overlay-put
+ (when-let* ((prop (cadr forms))
+ ((memq (scope-sym-bare (car-safe prop)) '(quote \`)))
+ ((eq (scope-sym-bare (cadr prop)) 'face)))
+ (scope-face local (caddr forms))))
+ ((remove-overlays put-text-property)
+ (when-let* ((prop (caddr forms))
+ ((memq (scope-sym-bare (car-safe prop)) '(quote \`)))
+ ((eq (scope-sym-bare (cadr prop)) 'face)))
+ (scope-face local (cadddr forms))))
+ (propertize
+ (when-let* ((props (cdr forms))
+ (symbols-with-pos-enabled t)
+ (val-form (plist-get props ''face #'equal)))
+ (scope-face local val-form)))
+ ((eieio-defclass-internal)
+ (when-let* ((name-form (car forms))
+ ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
+ (name (cadr name-form))
+ (beg (scope-sym-pos name))
+ (bare (scope-sym-bare name)))
+ (funcall scope-callback 'type beg (length (symbol-name bare)) nil))
+ (when-let* ((sups-form (cadr forms))
+ ((memq (scope-sym-bare (car-safe sups-form)) '(quote \`)))
+ (sups (cadr sups-form)))
+ (dolist (sup (cadr sups-form))
+ (when-let* ((beg (scope-sym-pos sup)) (bare (scope-sym-bare sup)))
+ (funcall scope-callback 'type beg (length (symbol-name bare)) nil)))))
+ ((cl-struct-define)
+ (when-let* ((name-form (car forms))
+ ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
+ (name (cadr name-form))
+ (beg (scope-sym-pos name))
+ (bare (scope-sym-bare name)))
+ (funcall scope-callback 'type beg (length (symbol-name bare)) nil))
+ (when-let* ((prnt-form (caddr forms))
+ ((memq (scope-sym-bare (car-safe prnt-form)) '(quote \`)))
+ (prnt (cadr prnt-form))
+ (beg (scope-sym-pos prnt))
+ (bare (scope-sym-bare prnt)))
+ (funcall scope-callback 'type beg (length (symbol-name bare)) nil))))
(when (symbol-with-pos-p f)
(funcall scope-callback 'function
(symbol-with-pos-pos f) (length (symbol-name bare))
(scope-condition-case local (car forms) (cadr forms) (cddr forms)))
((eq bare 'function)
(scope-sharpquote local (car forms)))
+ ((eq bare 'catch)
+ (scope-catch local (car forms) (cdr forms)))
((memq bare '( if and or while
save-excursion save-restriction save-current-buffer
- catch unwind-protect
+ unwind-protect
progn prog1))
(scope-n local forms))))
((macrop bare)
((memq bare '(gv-define-simple-setter))
(scope-gv-define-simple-setter
local (car forms) (cadr forms) (cddr forms)))
+ ((memq bare '(cl-deftype))
+ (scope-deftype local (car forms) (cadr forms) (cddr forms)))
((scope-safe-macro-p bare)
(scope-1 local (let ((symbols-with-pos-enabled t))
;; Ignore errors from trying to expand
"Read and analyze code from STREAM, reporting findings via CALLBACK.
Call CALLBACK for each analyzed symbol SYM with arguments TYPE, POS, LEN
-and BINDER, where TYPE a symbol that specifies the semantics of SYM, one
-of `variable', `function', `block' `defun' and `defvar'; POS is the
-position of SYM in STREAM; LEN is SYM's length; and BINDER is the
+and BINDER, where TYPE a symbol that specifies the semantics of SYM; POS
+is the position of SYM in STREAM; LEN is SYM's length; and BINDER is the
position in which SYM is bound. If SYM is itself a binding occurrence,
then POS and BINDER are equal. If SYM is not lexically bound, then
BINDER is nil. This function ignores `read-symbol-shorthands', so SYM
:doc "Keymap for Emacs Lisp mode.
All commands in `lisp-mode-shared-map' are inherited by this map."
:parent lisp-mode-shared-map
- "M-TAB" #'completion-at-point
"C-M-x" #'eval-defun
"C-c C-e" #'elisp-eval-region-or-buffer
"C-c C-f" #'elisp-byte-compile-file
"Face for highlighting free variables in Emacs Lisp code."
:group 'lisp)
+(defface elisp-condition '((t :foreground "red"))
+ "Face for highlighting `condition-case' conditions in Emacs Lisp code."
+ :group 'lisp)
+
+(defface elisp-major-mode-name '((t :foreground "#006400"))
+ "Face for highlighting major mode names in Emacs Lisp code."
+ :group 'lisp)
+
+(defface elisp-face '((t :inherit font-lock-type-face))
+ "Face for highlighting face names in Emacs Lisp code."
+ :group 'lisp)
+
+(defface elisp-macro-call '((t :inherit font-lock-keyword-face))
+ "Face for highlighting macro calls in Emacs Lisp code."
+ :group 'lisp)
+
+(defface elisp-special-form '((t :inherit elisp-macro-call))
+ "Face for highlighting special forms in Emacs Lisp code."
+ :group 'lisp)
+
+(defface elisp-throw-tag '((t :inherit font-lock-constant-face))
+ "Face for highlighting `catch'/`throw' tags in Emacs Lisp code."
+ :group 'lisp)
+
+(defface elisp-feature '((t :inherit font-lock-constant-face))
+ "Face for highlighting feature names in Emacs Lisp code."
+ :group 'lisp)
+
(defface elisp-binding-variable
'((t :slant italic :inherit font-lock-variable-name-face))
"Face for highlighting binding occurrences of variables in Emacs Lisp code."
:type 'boolean
:group 'lisp)
+(defun elisp--annotate-symbol-with-help-echo (type beg end bind)
+ (put-text-property
+ beg end 'help-echo
+ (cl-case type
+ (variable (cond ((equal beg bind) "Local variable definition")
+ (bind "Local variable")
+ (t "Special variable")))
+ (block (if (equal beg bind) "Block definition" "Block"))
+ (face "Face")
+ (function (cond ((equal beg bind) "Local function definition")
+ (bind "Local function call")
+ (t "Function call")))
+ (macro "Macro call")
+ (special-form "Special form")
+ (throw-tag "`throw'/`catch' tag")
+ (feature "Feature")
+ (type "Type")
+ (condition "`condition-case' condition")
+ (ampersand "Arguments separator")
+ (constant "Constant")
+ (defun "Function definition")
+ (defvar "Special variable definition")
+ (defface "Face definition")
+ (major-mode "Major mode"))))
+
(defun elisp-fontify-symbol (type sym len bind)
+ (elisp--annotate-symbol-with-help-echo type sym (+ sym len) bind)
(if (null bind)
(when-let ((face (cl-case type
- (variable 'elisp-free-variable)
- (function 'font-lock-function-call-face)
- (defun 'font-lock-function-name-face)
- (defvar 'font-lock-variable-name-face))))
+ (variable 'elisp-free-variable)
+ (face 'elisp-face)
+ (function 'font-lock-function-call-face)
+ (macro 'elisp-macro-call)
+ (special-form 'elisp-special-form)
+ (throw-tag 'elisp-throw-tag)
+ (feature 'elisp-feature)
+ (type 'font-lock-type-face)
+ (condition 'elisp-condition)
+ (ampersand 'font-lock-type-face)
+ (constant 'font-lock-builtin-face)
+ (defun 'font-lock-function-name-face)
+ (defvar 'font-lock-variable-name-face)
+ (defface 'font-lock-variable-name-face)
+ (major-mode 'elisp-major-mode-name))))
(add-face-text-property sym (+ sym len) face t))
(add-face-text-property sym (+ sym len)
(if (equal sym bind)
"Fontify symbols between BEG and END according to their semantics."
(save-excursion
(goto-char beg)
- (while (< (point) end)
- (ignore-errors
- (scope #'elisp-fontify-symbol (current-buffer))))))
+ (while (< (point) end) (ignore-errors (scope #'elisp-fontify-symbol)))))
(defun elisp-fontify-region (beg end &optional loudly)
"Fontify ELisp code between BEG and END.
(scan-error nil)))
(font-lock-default-fontify-region beg end loudly)))
+(defconst elisp-font-lock-keywords
+ `(;; Regexp negated char group.
+ ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend)
+ ;; Words inside \\[], \\<>, \\{} or \\`' tend to be for
+ ;; `substitute-command-keys'.
+ (,(rx "\\\\" (or (seq "["
+ (group-n 1 (seq lisp-mode-symbol (not "\\"))) "]")
+ (seq "`" (group-n 1
+ ;; allow multiple words, e.g. "C-x a"
+ lisp-mode-symbol (* " " lisp-mode-symbol))
+ "'")))
+ (1 font-lock-constant-face prepend))
+ (,(rx "\\\\" (or (seq "<"
+ (group-n 1 (seq lisp-mode-symbol (not "\\"))) ">")
+ (seq "{"
+ (group-n 1 (seq lisp-mode-symbol (not "\\"))) "}")))
+ (1 font-lock-variable-name-face prepend))
+ ;; Ineffective backslashes (typically in need of doubling).
+ ("\\(\\\\\\)\\([^\"\\]\\)"
+ (1 (elisp--font-lock-backslash) prepend))
+ ;; Words inside ‘’, '' and `' tend to be symbol names.
+ (,(concat "[`‘']\\(" (rx lisp-mode-symbol) "\\)['’]")
+ (1 font-lock-constant-face prepend))
+ ;; \\= tends to be an escape in doc strings.
+ (,(rx "\\\\=")
+ (0 font-lock-builtin-face prepend))
+ ;; ELisp regexp grouping constructs
+ (,(lambda (bound)
+ (catch 'found
+ ;; The following loop is needed to continue searching after matches
+ ;; that do not occur in strings. The associated regexp matches one
+ ;; of `\\\\' `\\(' `\\(?:' `\\|' `\\)'. `\\\\' has been included to
+ ;; avoid highlighting, for example, `\\(' in `\\\\('.
+ (while (re-search-forward "\\(\\\\\\\\\\)\\(?:\\(\\\\\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)" bound t)
+ (unless (match-beginning 2)
+ (let ((face (get-text-property (1- (point)) 'face)))
+ (when (or (and (listp face)
+ (memq 'font-lock-string-face face))
+ (eq 'font-lock-string-face face))
+ (throw 'found t)))))))
+ (1 'font-lock-regexp-grouping-backslash prepend)
+ (3 'font-lock-regexp-grouping-construct prepend))
+ (lisp--match-hidden-arg
+ (0 '(face font-lock-warning-face
+ help-echo "Easy to misread; consider moving the element to the next line")
+ prepend))
+ (lisp--match-confusable-symbol-character
+ 0 '(face font-lock-warning-face
+ help-echo "Confusable character")))
+ "Highlighting patterns for Emacs Lisp mode.")
+
;;;###autoload
(define-derived-mode emacs-lisp-mode lisp-data-mode
`("ELisp"
:group 'lisp
(defvar project-vc-external-roots-function)
(setq font-lock-defaults (copy-tree font-lock-defaults))
- (setcar font-lock-defaults
- '(lisp-el-font-lock-keywords
- lisp-el-font-lock-keywords-1
- lisp-el-font-lock-keywords-2))
+ (setcar font-lock-defaults '(elisp-font-lock-keywords))
(cl-pushnew 'cursor-sensor-functions
(alist-get 'font-lock-extra-managed-props
(nthcdr 5 font-lock-defaults)))
+ (cl-pushnew 'help-echo
+ (alist-get 'font-lock-extra-managed-props
+ (nthcdr 5 font-lock-defaults)))
(alist-set 'font-lock-fontify-region-function
(nthcdr 5 font-lock-defaults)
#'elisp-fontify-region)
(lambda (sym) (or (elisp--shorthand-aware-boundp sym)
(memq sym local-vars)))))
((function macro special-form top-level) #'elisp--shorthand-aware-fboundp)
+ ((major-mode) (lambda (sym) (get sym 'major-mode-name)))
+ ((type) (lambda (sym) (get sym 'cl--class)))
+ ((face) #'facep)
((nil) (lambda (sym)
(let ((sym (intern-soft (symbol-name sym))))
(or (boundp sym)
(fboundp sym)
(featurep sym)
+ (facep sym)
(symbol-plist sym)))))))
(beg-end (bounds-of-thing-at-point 'symbol))
(beg (car beg-end))
(ignore-errors (read (current-buffer))))))
(and (symbolp val) val))))
(cond
+ ((elisp--xref-infer-namespace-1 pos))
((and (eq (char-before pos) ?\')
(eq (char-before (1- pos)) ?#))
;; #'IDENT
;; a macro we cannot be sure.
(t 'maybe-variable))))))))
+(defun elisp--xref-infer-namespace-1 (pos)
+ (save-excursion
+ (beginning-of-defun-raw)
+ (cl-case (catch 'sym-type
+ (scope (lambda (type beg len _bin)
+ (when (<= beg pos (+ beg len))
+ (throw 'sym-type type))))
+ nil)
+ ((defface face) 'face)
+ ((feature) 'feature)
+ ((defvar variable constant) 'variable)
+ ((defun function macro special-form top-level major-mode) 'function))))
+
(cl-defmethod xref-backend-identifier-at-point ((_backend (eql 'elisp)))
(let ((bounds (bounds-of-thing-at-point 'symbol)))
(and bounds
projects / emacs.git / commitdiff